[clean up type analysis code, fix bug in passing type argument to rules
John Meacham <john@repetae.net>**20070510080814] hunk ./E/TypeAnalysis.hs 18
-import E.Subst
-import E.Traverse(emapE',emapE_,emapE)
-import E.Program
hunk ./E/TypeAnalysis.hs 19
-import Support.FreeVars
+import E.Program
hunk ./E/TypeAnalysis.hs 21
+import E.Subst
+import E.Traverse(emapE',emapE_,emapE)
hunk ./E/TypeAnalysis.hs 29
-import Util.Gen
hunk ./E/TypeAnalysis.hs 31
+import Name.Id
hunk ./E/TypeAnalysis.hs 34
-import qualified Info.Info as Info
hunk ./E/TypeAnalysis.hs 36
-import Name.Id
+import Support.FreeVars
+import Util.Gen
hunk ./E/TypeAnalysis.hs 39
+import qualified Info.Info as Info
hunk ./E/TypeAnalysis.hs 43
-type Env = (Supply (Module,Int) Bool,Supply TVr Bool,Map.Map Id [Value Typ])
+data Env = Env {
+    envRuleSupply :: Supply (Module,Int) Bool,
+    envValSupply :: Supply TVr Bool,
+    envEnv :: IdMap [Value Typ]
+    }
hunk ./E/TypeAnalysis.hs 49
-extractValMap :: [(TVr,E)] -> Map.Map Id [Value Typ]
+extractValMap :: [(TVr,E)] -> IdMap [Value Typ]
hunk ./E/TypeAnalysis.hs 71
-        env = (ur,uv,extractValMap ds)
+        env = Env { envRuleSupply = ur, envValSupply = uv, envEnv = extractValMap ds }
hunk ./E/TypeAnalysis.hs 78
-    findFixpoint Nothing fixer
+    --findFixpoint Nothing fixer
+    calcFixpoint "TypeAnalysis" fixer
hunk ./E/TypeAnalysis.hs 91
-lookupArgs t (_,_,tm) = maybe [] id (mlookup (tvrIdent t) tm)
+lookupArgs t Env { envEnv = tm }  = maybe [] id (mlookup (tvrIdent t) tm)
hunk ./E/TypeAnalysis.hs 101
-calcDef env@(ur,uv,_) (t,e) = do
+calcDef env@Env { envRuleSupply = ur, envValSupply = uv } (t,e) = do
hunk ./E/TypeAnalysis.hs 111
-                    addRule $ a' `isSuperSetOf` t'
+                    addRule $ conditionalRule id ruleUsed $ ioToRule $ do
+                        addRule $ a' `isSuperSetOf` t'
hunk ./E/TypeAnalysis.hs 115
-                    let (vv::Value Typ) = Info.fetch (tvrInfo t)
+                    let (t'::Value Typ) = Info.fetch (tvrInfo t)
hunk ./E/TypeAnalysis.hs 118
-                        flip mapM_ (zip [0..] as') $ \ (i,t') -> do
-                            addRule $ modifiedSuperSetOf vv t' (vmapArg n i)
+                        flip mapM_ (zip naturals as') $ \ (i,a'') -> do
+                            addRule $ modifiedSuperSetOf a'' t' (vmapArg n i)
hunk ./E/TypeAnalysis.hs 125
-                    addRule $ conditionalRule (n `vmapMember`) vv (assert ruleUsed)
+                    addRule $ conditionalRule (n `vmapMember`) t' (assert ruleUsed)
hunk ./E/TypeAnalysis.hs 135
-calcDs env@(ur,uv,_) ds = do
+calcDs env@Env { envRuleSupply = ur, envValSupply = uv } ds = do
hunk ./E/TypeAnalysis.hs 170
-calcE (ur,uv,env) (ELetRec ds e) = calcDs nenv ds >> calcE nenv e where
-    nenv = (ur,uv,extractValMap ds `union` env)
+calcE env (ELetRec ds e) = calcDs nenv ds >> calcE nenv e where
+    nenv = env { envEnv = extractValMap ds `union` envEnv env }
hunk ./E/TypeAnalysis.hs 199
-tagE (ur,uv,_) (EVar v) | not $ getProperty prop_RULEBINDER v = do
+tagE Env { envValSupply = uv }  (EVar v) | not $ getProperty prop_RULEBINDER v = do
hunk ./E/TypeAnalysis.hs 336
-    if null rules then return (unsetProperty prop_PLACEHOLDER tvr, EError "placeholder, no bodies" (getType tvr)) else do
+    if null rules then return (unsetProperty prop_PLACEHOLDER tvr, EError ("Placeholder, no bodies: " ++ tvrShowName tvr) (getType tvr)) else do