[make type analysis work with rules properly
John Meacham <john@repetae.net>**20060225141007] hunk ./E/TypeAnalysis.hs 26
+import Fixer.Supply
hunk ./E/TypeAnalysis.hs 29
+import Util.Gen
hunk ./E/TypeAnalysis.hs 40
-type Env = (Value (Set.Set TVr),Map.Map Id [Value Typ])
+type Env = (Supply (Module,Int) Bool,Supply TVr Bool,Map.Map Id [Value Typ])
hunk ./E/TypeAnalysis.hs 52
-    usedVals <- newValue fixer Set.empty
+    ur <- newSupply fixer
+    uv <- newSupply fixer
hunk ./E/TypeAnalysis.hs 64
-        env = (usedVals,extractValMap ds)
+        env = (ur,uv,extractValMap ds)
hunk ./E/TypeAnalysis.hs 67
-    mapM_ (calcE env . EVar ) entries
+    flip mapM_ entries $ \tvr ->  do
+        vv <- supplyValue uv tvr
+        addRule $ assert vv
hunk ./E/TypeAnalysis.hs 83
-lookupArgs t (_,tm) = maybe [] id (Map.lookup (tvrIdent t) tm)
+lookupArgs t (_,_,tm) = maybe [] id (Map.lookup (tvrIdent t) tm)
hunk ./E/TypeAnalysis.hs 85
+toLit (EPi TVr { tvrType = a } b) = return (tc_Arrow,[a,b])
+toLit (ELit (LitCons n ts _)) = return (n,ts)
+toLit _ = fail "not convertable to literal"
+
+assert :: Value Bool -> Fixer.Fixer.Rule
+assert v = v `isSuperSetOf` value True
hunk ./E/TypeAnalysis.hs 93
-calcDef env (t,e) = do
+calcDef env@(ur,uv,_) (t,e) = do
hunk ./E/TypeAnalysis.hs 98
-            let vs = concatMap (hrg r) (zip tls (ruleArgs r))
-            calcE env (substMap (Map.fromList vs) $ ruleBody r)
-        hrg r (t,EVar a) | a `elem` ruleBinds r = [(tvrIdent a,EVar t)]
-        hrg r (t,e) =  [ (tvrIdent t, EVar $ tvrInfo_u (Info.insert (value (vmapPlaceholder () :: Typ))) t) | t <- freeVars e, t `elem` ruleBinds r ]
-    mapM_ hr rs
-    calcE env e
+            ruleUsed <- supplyValue ur (ruleUniq r)
+            addRule $ conditionalRule id ruleUsed (ioToRule $ putStrLn (pprint (ruleUniq r)) >> calcE env (ruleBody r))
+            let hrg r (t,EVar a) | a `elem` ruleBinds r = do
+                    let (t'::Value Typ) = Info.fetch (tvrInfo t)
+                    let (a'::Value Typ) = Info.fetch (tvrInfo a)
+                    addRule $ a' `isSuperSetOf` t'
+                    return True
+                hrg r (t,e) | Just (n,as) <- toLit e = do
+                    let (vv::Value Typ) = Info.fetch (tvrInfo t)
+                    as' <- mapM getValue as
+                    addRule $ conditionalRule id ruleUsed $ ioToRule $ do
+                        flip mapM_ (zip [0..] as') $ \ (i,t') -> do
+                            addRule $ modifiedSuperSetOf t' vv (vmapArg n i)
+--                    addRule $ conditionalRule id ruleUsed $ ioToRule $ do
+--                        flip mapM_ (zip as' naturals)  $ \ (v,i) -> do
+--                            addRule $ modifiedSuperSetOf vv v (vmapArgSingleton n i)
+                    --addRule $ dynamicRule v $ \v' -> (mconcat [ t `isSuperSetOf` value (vmapArg n i v') | (t,i) <-  zip ts' naturals ])
+                    addRule $ conditionalRule (n `vmapMember`) vv (assert ruleUsed)
+                    return False
+            rr <- mapM (hrg r) (zip tls (ruleArgs r))
+            when (and rr) $ addRule (assert ruleUsed)
+    valUsed <- supplyValue uv t
+    addRule $ conditionalRule id valUsed $ ioToRule $ do
+        putStrLn (pprint t)
+        mapM_ hr rs
+        calcE env e
hunk ./E/TypeAnalysis.hs 126
-calcDs env@(usedVals,_) ds = do
+calcDs env@(ur,uv,_) ds = do
hunk ./E/TypeAnalysis.hs 128
-    flip mapM_ ds $ \ (v,e) -> do
-        addRule $ conditionalRule (v `Set.member`) usedVals (ioToRule $ calcDef env (v,e))
+    flip mapM_ ds $ \ (v,e) -> do calcDef env (v,e)
+      --  addRule $ conditionalRule id nv (ioToRule $ calcDef env (v,e))
hunk ./E/TypeAnalysis.hs 135
-    d (t, ELit (LitCons n xs _)) = do
+    d (t,e) | Just (n,xs) <- toLit e = do
hunk ./E/TypeAnalysis.hs 142
-    d (t, EPi TVr { tvrType = a} b) = do
-        let Just t' = Info.lookup (tvrInfo t)
-            v = vmapSingleton tc_Arrow
-        addRule $ t' `isSuperSetOf` (value v)
-        xs' <- mapM getValue [a,b]
-        flip mapM_ (zip xs' [0.. ])  $ \ (v,i) -> do
-            addRule $ modifiedSuperSetOf t' v (vmapArgSingleton tc_Arrow i)
hunk ./E/TypeAnalysis.hs 161
-calcE (usedVals,env) (ELetRec ds e) = calcDs nenv ds >> calcE nenv e where
-    nenv = (usedVals,extractValMap ds `Map.union` env)
+calcE (ur,uv,env) (ELetRec ds e) = calcDs nenv ds >> calcE nenv e where
+    nenv = (ur,uv,extractValMap ds `Map.union` env)
hunk ./E/TypeAnalysis.hs 164
-calcE env ec@ECase {} | sortStarLike (getType $ eCaseScrutinee ec) = do
-    calcE env (eCaseScrutinee ec)
-    fmapM_ (calcE env) (eCaseDefault ec)
-    v <- getValue (eCaseScrutinee ec)
-    mapM_ (calcAlt env v) (eCaseAlts ec)
+--calcE env ec@ECase {} | sortStarLike (getType $ eCaseScrutinee ec) = do
+--    calcE env (eCaseScrutinee ec)
+--    fmapM_ (calcE env) (eCaseDefault ec)
+--    v <- getValue (eCaseScrutinee ec)
+--    mapM_ (calcAlt env v) (eCaseAlts ec)
hunk ./E/TypeAnalysis.hs 177
-calcE env e | (EVar v,as@(_:_)) <- fromAp e, Just ts <- Map.lookup (tvrIdent v) (snd env) = do
+calcE env e | (EVar v,as@(_:_)) <- fromAp e = do
+    let ts = lookupArgs v env
hunk ./E/TypeAnalysis.hs 190
-tagE (usedVals,_) (EVar v) | not $ getProperty prop_RULEBINDER v = addRule $ usedVals `isSuperSetOf` value (Set.singleton v)
+tagE (ur,uv,_) (EVar v) | not $ getProperty prop_RULEBINDER v = do
+    v <- supplyValue uv v
+    addRule $ assert v