[recursively perform casting via typecases when specializing case alternatives
John Meacham <john@repetae.net>**20070517013712] hunk ./E/TypeAnalysis.hs 6
+import Control.Monad.Error
hunk ./E/TypeAnalysis.hs 10
+import Control.Monad.State
hunk ./E/TypeAnalysis.hs 81
-    prog <- annotateProgram mempty (\_ -> return) (\_ -> return) lamread prog
+    prog <- annotateProgram mempty lamread (\_ -> return) (\_ -> return) prog
hunk ./E/TypeAnalysis.hs 121
-                            --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 ])
hunk ./E/TypeAnalysis.hs 168
-calcE env e | (e',(_:_)) <- fromLam e = calcE env e'
hunk ./E/TypeAnalysis.hs 173
+calcE env e | (e',(_:_)) <- fromLam e = calcE env e'
hunk ./E/TypeAnalysis.hs 303
+instance Error () where
+    noMsg = ()
+    strMsg _ = ()
+
+
+evalErrorT :: Monad m => a -> ErrorT () m a -> m a
+evalErrorT err action = liftM f (runErrorT action) where
+    f (Left _) = err
+    f (Right x) = x
+
+eToPatM :: Monad m => (E -> m TVr) -> E -> m (Lit TVr E)
+eToPatM cv e = f e where
+    f (ELit LitCons { litAliasFor = af,  litName = x, litArgs = ts, litType = t }) = do
+        ts <- mapM cv ts
+        return litCons { litAliasFor = af, litName = x, litArgs = ts, litType = t }
+    f (ELit (LitInt e t)) = return (LitInt e t)
+    f (EPi (TVr { tvrType =  a}) b)  = do
+        a <- cv a
+        b <- cv b
+        return litCons { litName = tc_Arrow, litArgs = [a,b], litType = eStar }
+    f x = fail $ "E.Values.eToPatM: " ++ show x
+
+
+caseCast :: TVr -> E -> E -> E
+caseCast t ty e = evalState  (f t ty e) (newIds (freeIds e),[]) where
+    f t ty e = do
+        p <- eToPatM cv ty
+        (ns,es) <- get
+        put (ns,[])
+        let rs = map (uncurry caseCast) es
+        return (eCase (EVar t) [Alt p (foldr (.) id rs e)] Unknown)
+    cv (EVar v) = return v
+    cv e = do
+        ((n:ns),es) <- get
+        let t = tvr { tvrIdent = n, tvrType = getType e }
+        put (ns,(t,e):es)
+        return t
+caseCast t _ty e = e
+
+specAlt :: MonadStats m => SpecEnv -> Alt E -> m (Alt E)
+specAlt SpecEnv { senvDataTable = dataTable, senvUnusedVars = unusedVals } (Alt lc@LitCons { litArgs = ts } e) = ans where
+    f xs = do
+        ws <- forM xs $ \t -> evalErrorT id $ do
+            False <- return $ t `member` unusedVals
+            Just nt <- return $ Info.lookup (tvrInfo t)
+            Just tt <- return $ getTyp (getType t) dataTable nt
+            mtick $ "Specialize.alt.{" ++ pprint (show nt,tt) ++ "}"
+            return $ caseCast t tt
+        return $ foldr (.) id ws
+    ans = do
+        ws <- f ts
+        return (Alt lc (ws e))
hunk ./E/TypeAnalysis.hs 363
---specBody True env e@ECase { eCaseScrutinee = EVar v } | sortKindLike (getType v)scrut = do
---    k
+specBody True env ec@ECase { eCaseScrutinee = EVar v } | sortKindLike (getType v) = do
+    alts <- mapM (specAlt env) (eCaseAlts ec)
+    emapE' (specBody True env) ec { eCaseAlts = alts }
hunk ./E/TypeAnalysis.hs 375
-    -- ds <- sequence [ specBody dataTable (nenv `mappend` env) e >>= return . (,) t | (t,e) <- ds]