[move VMap into own module, add fixer value supplier module clean up some code, add some fun Fixable instances
John Meacham <john@repetae.net>**20060125020224] hunk ./E/TypeAnalysis.hs 21
+import Fixer.VMap
hunk ./E/TypeAnalysis.hs 78
-        addRule $ dynamicRule v' $ \ v -> mconcat $ flip map (vmapHeads v) $ \ h -> 
+        addRule $ dynamicRule v' $ \ v -> mconcat $ flip map (vmapHeads v) $ \ h ->
hunk ./E/TypeAnalysis.hs 161
-
--- VMap general data type for finding the fixpoint of a general tree-like structure.
-
-data VMap n = VMap (Map.Map (n,Int) (VMap n)) (Set.Set n)
-    deriving(Typeable)
-
-vmapSingleton n = VMap Map.empty (Set.singleton n)
-
-vmapArgSingleton n i v
-    | isBottom v = bottom
-    | otherwise = VMap (Map.singleton (n,i) v) Set.empty
-
-vmapArg n i (VMap map _) = case Map.lookup (n,i) map of
-    Just x -> x
-    Nothing -> bottom
-
-vmapValue :: Ord n => n -> [VMap n] -> VMap n
-vmapValue n xs = pruneVMap $ VMap (Map.fromAscList (zip (zip (repeat n) [0..]) xs)) (Set.singleton n)
-
-vmapHeads (VMap _ set) = Set.toList set
-vmapJustHeads (VMap _ set) = VMap Map.empty set
-
-pruneVMap (VMap map set) = VMap map' set where
-    map' = Map.filter f map
-    f vs = not $ isBottom vs
-
-instance (Ord n,Show n) => Show (VMap n) where
-    showsPrec _ (VMap n s) = braces (hcat (intersperse (char ',') $ (map f $ snub $ fsts  (Map.keys n) ++ Set.toList s) )) where
-        f a = (if a `Set.member` s then tshow a else char '#' <> tshow a) <> tshow (g a)
-        g a = sortUnder fst [ (i,v) | ((a',i),v) <- Map.toList n, a' == a ]
-
-instance Ord n => Fixable (VMap n) where
-    bottom = VMap Map.empty Set.empty
-    isBottom (VMap m s) = Map.null m && Set.null s
-    lub (VMap as ns) (VMap as' ns') = pruneVMap $ VMap (Map.unionWith lub as as') (Set.union ns ns')
-    minus (VMap n1 w1) (VMap n2 w2) = pruneVMap $ VMap (Map.fromAscList $ [
-            case Map.lookup (a,i) n2 of
-                Just v' ->  ((a,i),v `minus` v')
-                Nothing ->  ((a,i),v)
-        | ((a,i),v) <- Map.toAscList n1 ] ) (w1 Set.\\ w2)
-
-instance Ord n => Monoid (VMap n) where
-    mempty = bottom
-    mappend = lub
-
-
-instance Ord n => Fixable (Set.Set n)  where
-    bottom = Set.empty
-    isBottom = Set.null
-    lub a b = Set.union a b
-    minus a b = a Set.\\ b
-
-
-instance Fixable Bool where
-    bottom = False
-    isBottom x = x == False
-    lub a b = a || b
-    minus True False = True
-    minus False True = False
-    minus True True = False
-    minus False False = False
-
hunk ./Fixer/Fixer.hs 6
-    Value,
-    Rule,
+    Value(),
+    Rule(),
+    Fixer(),
hunk ./Fixer/Fixer.hs 175
+-- some useful instances
hunk ./Fixer/Fixer.hs 177
+instance Ord n => Fixable (Set.Set n)  where
+    bottom = Set.empty
+    isBottom = Set.null
+    lub a b = Set.union a b
+    minus a b = a Set.\\ b
hunk ./Fixer/Fixer.hs 184
+instance Fixable Bool where
+    bottom = False
+    isBottom x = x == False
+    lub a b = a || b
+    minus True False = True
+    minus False True = False
+    minus True True = False
+    minus False False = False
+
+-- bottom is zero and the lub is the maximum of integer values, as in this is the lattice of maximum, not the additive one.
+instance Fixable Int where
+    bottom = 0
+    isBottom = (0 ==)
+    lub a b = max a b
+    minus a b | a > b = a
+    minus _ _ = 0
+
+instance (Fixable a,Fixable b) => Fixable (a,b) where
+    bottom = (bottom,bottom)
+    isBottom (a,b) = isBottom a && isBottom b
+    lub (x,y) (x',y') = (lub x x', lub y y')
+    minus (x,y) (x',y') = (minus x x', minus y y')
+
+
+-- the maybe instance creates a new bottom of nothing. note that (Just bottom) is a distinct point.
+instance Fixable a => Fixable (Maybe a) where
+    bottom = Nothing
+    isBottom Nothing = True
+    isBottom _ = False
+    lub Nothing b = b
+    lub a Nothing = a
+    lub (Just a) (Just b) = Just (lub a b)
+    minus (Just a) (Just b) = Just (minus a b)
+    minus (Just a) Nothing = Just a
+    minus Nothing _ = Nothing
+
addfile ./Fixer/Supply.hs
hunk ./Fixer/Supply.hs 1
+module Fixer.Supply(
+    Supply(),
+    newSupply,
+    supplyReadValues,
+    supplyValue
+    ) where
+
+import Fixer.Fixer
+import qualified Data.Map as Map
+import Data.IORef
+import Data.Typeable
+
+
+-- maps b's to values of a's, creating them as needed.
+
+data Supply b a = Supply Fixer (IORef (Map.Map b (Value a)))
+    deriving(Typeable)
+
+
+newSupply :: Fixer -> IO (Supply b a)
+newSupply fixer = do
+    ref <- newIORef Map.empty
+    return $ Supply fixer ref
+
+supplyValue :: (Ord b, Fixable a) => Supply b a -> b -> IO (Value a)
+supplyValue (Supply fixer ref) b = do
+    mp <- readIORef ref
+    case Map.lookup b mp of
+        Just v -> return v
+        Nothing -> do
+            v <- newValue fixer bottom
+            modifyIORef ref (Map.insert b v)
+            return v
+
+supplyReadValues :: Supply b a -> IO [(b,a)]
+supplyReadValues (Supply _fixer ref) = do
+    mp <- readIORef ref
+    flip mapM (Map.toList mp) $ \ (b,va) -> do
+        a <- readValue va
+        return (b,a)
+
+
addfile ./Fixer/VMap.hs
hunk ./Fixer/VMap.hs 1
+module Fixer.VMap where
+
+import Doc.DocLike
+import Fixer.Fixer
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Data.Typeable
+import Data.Monoid
+import GenUtil
+import List(intersperse)
+
+
+-- VMap general data type for finding the fixpoint of a general tree-like structure.
+
+data VMap n = VMap (Map.Map (n,Int) (VMap n)) (Set.Set n)
+    deriving(Typeable)
+
+vmapSingleton n = VMap Map.empty (Set.singleton n)
+
+vmapArgSingleton n i v
+    | isBottom v = bottom
+    | otherwise = VMap (Map.singleton (n,i) v) Set.empty
+
+vmapArg n i (VMap map _) = case Map.lookup (n,i) map of
+    Just x -> x
+    Nothing -> bottom
+
+vmapValue :: Ord n => n -> [VMap n] -> VMap n
+vmapValue n xs = pruneVMap $ VMap (Map.fromAscList (zip (zip (repeat n) [0..]) xs)) (Set.singleton n)
+
+vmapHeads (VMap _ set) = Set.toList set
+vmapJustHeads (VMap _ set) = VMap Map.empty set
+
+pruneVMap (VMap map set) = VMap map' set where
+    map' = Map.filter f map
+    f vs = not $ isBottom vs
+
+instance (Ord n,Show n) => Show (VMap n) where
+    showsPrec _ (VMap n s) = braces (hcat (intersperse (char ',') $ (map f $ snub $ fsts  (Map.keys n) ++ Set.toList s) )) where
+        f a = (if a `Set.member` s then tshow a else char '#' <> tshow a) <> tshow (g a)
+        g a = sortUnder fst [ (i,v) | ((a',i),v) <- Map.toList n, a' == a ]
+
+instance Ord n => Fixable (VMap n) where
+    bottom = VMap Map.empty Set.empty
+    isBottom (VMap m s) = Map.null m && Set.null s
+    lub (VMap as ns) (VMap as' ns') = pruneVMap $ VMap (Map.unionWith lub as as') (Set.union ns ns')
+    minus (VMap n1 w1) (VMap n2 w2) = pruneVMap $ VMap (Map.fromAscList $ [
+            case Map.lookup (a,i) n2 of
+                Just v' ->  ((a,i),v `minus` v')
+                Nothing ->  ((a,i),v)
+        | ((a,i),v) <- Map.toAscList n1 ] ) (w1 Set.\\ w2)
+
+instance Ord n => Monoid (VMap n) where
+    mempty = bottom
+    mappend = lub
hunk ./Grin/Linear.hs 9
+import Fixer.Supply
+import Fixer.Fixer