[enable type analysis by default. make type analysis work properly.
John Meacham <john@repetae.net>**20060124040300] hunk ./E/SSimplify.hs 419
-        (bs,e) <- match l as (b,d)
-        let bs' = [ x | x@(TVr { tvrIdent = n },_) <- bs, n /= 0]
-        binds <- mapM (\ (v,e) -> nname v sub inb >>= return . (,,) e v) bs'
-        e' <- f e (Map.fromList [ (n,Done $ EVar nt) | (_,TVr { tvrIdent = n },nt) <- binds] `Map.union` sub)   (envInScope_u (Map.fromList [ (n,IsBoundTo Many e) | (e,_,TVr { tvrIdent = n }) <- binds] `Map.union`) inb)
-        return $ eLetRec [ (v,e) | (e,_,v) <- binds ] e'
+        mr <- match l as (b,d)
+        case mr of
+            Just (bs,e) -> do
+                let bs' = [ x | x@(TVr { tvrIdent = n },_) <- bs, n /= 0]
+                binds <- mapM (\ (v,e) -> nname v sub inb >>= return . (,,) e v) bs'
+                e' <- f e (Map.fromList [ (n,Done $ EVar nt) | (_,TVr { tvrIdent = n },nt) <- binds] `Map.union` sub)   (envInScope_u (Map.fromList [ (n,IsBoundTo Many e) | (e,_,TVr { tvrIdent = n }) <- binds] `Map.union`) inb)
+                return $ eLetRec [ (v,e) | (e,_,v) <- binds ] e'
+            Nothing -> do
+                let t = getType (ECase (ELit l) b as d)
+                return $ EError "match falls off bottom" t
hunk ./E/SSimplify.hs 432
-        return ((zip bs xs),e)
+        return $ Just ((zip bs xs),e)
hunk ./E/SSimplify.hs 436
-        return ([],e)
+        return $ Just ([],e)
hunk ./E/SSimplify.hs 440
-        return ([(b,ELit l)],e)
-    match m [] (_,Nothing) = error $ "End of match: " ++ show m
+        return $ Just ([(b,ELit l)],e)
+    --match m [] (_,Nothing) = error $ "End of match: " ++ show m
+    match m [] (_,Nothing) = do
+        mtick (toAtom "E.Simplify.known-case.unmatch")
+        return Nothing
hunk ./E/TypeAnalysis.hs 4
-module E.TypeAnalysis(typeAnalyze) where
+module E.TypeAnalysis(typeAnalyze, pruneE) where
hunk ./E/TypeAnalysis.hs 18
+import E.Inline(emapE')
hunk ./E/TypeAnalysis.hs 23
+import Name.Names
hunk ./E/TypeAnalysis.hs 74
+-- TODO - make default case conditional
hunk ./E/TypeAnalysis.hs 76
-    calcE env e
-    flip mapM_ (zip [0..] xs) $ \ (i,t) -> do
-        let Just t' = Info.lookup (tvrInfo t)
-        modifiedSuperSetOf t' v (vmapArg n i)
+    conditionalRule (\ (VMap _ vs) -> n `Set.member` vs) v $ do
+        calcE env e
+        flip mapM_ (zip [0..] xs) $ \ (i,t) -> do
+            let Just t' = Info.lookup (tvrInfo t)
+            modifiedSuperSetOf t' v (vmapArg n i)
hunk ./E/TypeAnalysis.hs 119
+typConstant (EPi TVr { tvrType = a} b) = do
+    ab <- mapM typConstant [a,b]
+    return $ vmapValue tc_Arrow ab
hunk ./E/TypeAnalysis.hs 128
--- VMap general structure
+-- pruning the unused branches of typecase statements
+
+
+pruneE :: E -> IO E
+pruneE ec@ECase { eCaseScrutinee = EVar v } | sortStarLike (getType v), Just (VMap _ ns) <- Info.lookup (tvrInfo v) = do
+    ec' <- pruneCase ec ns
+    emapE' pruneE ec'
+pruneE e = emapE' pruneE e
+
+pruneCase :: Monad m => E -> Set.Set Name -> m E
+pruneCase ec ns = return $ if null (caseBodies nec) then err else nec where
+    err = EError "pruneCase: all alternatives pruned" (getType ec)
+    nec = ec { eCaseAlts = f [] $ eCaseAlts ec, eCaseDefault = cd (eCaseDefault ec)}
+    f xs [] = reverse xs
+    f xs (alt@(Alt (LitCons n _ _) _):rs) | not (n `Set.member` ns) = f xs rs
+    f xs (alt:rs) = f (alt:xs) rs
+    cd (Just d) | or [ n `notElem` as | n <- Set.toList ns ] = Just d
+    cd _ = Nothing
+    as = [ n | LitCons n _ _ <- casePats ec ]
+
+
+
+
+-- VMap general data type for finding the fixpoint of a general tree-like structure.
hunk ./FlagOpts.flags 23
-@default inline-pragmas rules wrapper float-in strictness defaulting
+@default inline-pragmas rules wrapper float-in strictness defaulting type-analysis
hunk ./Main.hs 364
-    when (fopts  FO.TypeAnalysis) $ do
-        let ELetRec ds _ = lco in do
-            putStrLn "Supercombinators"
-            ds' <- typeAnalyze ds
-            mapM_ (\ (t,e) -> let (_,ts) = fromLam e in putStrLn $  (showTVr t) ++ " \\" ++ concat [ "(" ++ show  (tvrInfo t) ++ ")" | t <- ts, sortStarLike (getType t) ] ) ds'
hunk ./Main.hs 366
+
+    lc <- if (fopts  FO.TypeAnalysis) then do
+        let ELetRec ds mn = lc in do
+            ds' <- typeAnalyze ds
+            putStrLn "Type analyzed methods"
+            mapM_ (\ (t,e) -> let (_,ts) = fromLam e in putStrLn $  (prettyE (EVar t)) ++ " \\" ++ concat [ "(" ++ show  (tvrInfo t) ++ ")" | t <- ts, sortStarLike (getType t) ] ) (filter (getProperty prop_METHOD . fst) ds')
+            ds' <- sequence [ pruneE e >>= return . (,) t | (t,e) <- ds' ]
+            return $ ELetRec ds' mn
+        else return lc
+