[major code rearrangement and cleanups
John Meacham <john@repetae.net>**20050919033211] hunk ./DataConstructors.hs 79
-    deriving(Binary,Monoid,HasSize)
+    {-! derive: GhcBinary, Monoid !-}
+
+instance HasSize DataTable where
+    size (DataTable d) = Map.size d
addfile ./DataConstructors.hs-boot
hunk ./DataConstructors.hs-boot 1
+module DataConstructors where
+
+
+import E.E
+
+data DataTable
+followAliases :: DataTable -> E -> E
+typesCompatable :: Monad m => DataTable -> E -> E -> m ()
hunk ./E/Arbitrary.hs 5
+import E.TypeCheck()
hunk ./E/CPR.hs 3
+import Control.Monad.Writer
+import Data.Generics
+import Data.Monoid()
+import Doc.DocLike
hunk ./E/CPR.hs 8
+import E.FreeVars
+import Name
hunk ./E/CPR.hs 12
-import Data.Monoid()
-import Name
-import Data.Generics
-import Doc.DocLike
-import Control.Monad.Writer
-import E.Values
hunk ./E/E.hs 5
-import qualified Data.IntMap as IM
-import qualified Data.IntSet as IS
-import qualified Data.Set as Set
hunk ./E/E.hs 15
-import Data.Graph as G
-import FreeVars
hunk ./E/E.hs 17
-import CanType
-import {-# SOURCE #-} E.Subst
hunk ./E/E.hs 18
+import Char(chr)
hunk ./E/E.hs 29
-data Lit e t = LitInt Number t |  LitCons Name [e] t --  | LitFrac Rational t   LitInt !Integer t  |
+data Lit e t = LitInt Number t |  LitCons Name [e] t
hunk ./E/E.hs 293
--------------------------
--- finding free variables
--------------------------
hunk ./E/E.hs 294
+isAtomic :: E -> Bool
+--isAtomic e | sortTypeLike e = True
+isAtomic EVar {}  = True
+isAtomic e = isFullyConst e
hunk ./E/E.hs 299
-instance FreeVars E IS.IntSet where
-    freeVars e = IS.fromAscList (fsts . IM.toAscList $ freeVs e)
-instance FreeVars E (Set.Set Int) where
-    freeVars e = Set.fromAscList (fsts . IM.toAscList $ freeVs e)
-instance FreeVars E [Int] where
-    freeVars e =  IM.keys $ freeVs e
-instance FreeVars E (IM.IntMap TVr) where
-    freeVars = freeVs
-instance FreeVars E (Set.Set TVr) where
-    freeVars x = Set.fromList $ freeVars x
-instance FreeVars E [TVr] where
-    freeVars x = IM.elems $ freeVars x
-instance FreeVars (Alt E) (IM.IntMap TVr) where
-    freeVars as@(Alt l e) = IM.unions $ freeVars (getType l):(freeVars e IM.\\ IM.fromList [ (tvrNum t,t) | t <- litBinds l]):( map (freeVars . getType) $ litBinds l)
-instance FreeVars E t => FreeVars TVr t where
-    freeVars tvr = freeVars (getType tvr)
-instance FreeVars (Alt E) (Set.Set Int) where
-    freeVars as@(Alt l e) = Set.unions $ freeVars (getType l):(freeVars e Set.\\ Set.fromList [ tvrNum t | t <- litBinds l]):( map (freeVars . getType) $ litBinds l)
+fullyConst :: Monad m => E -> m ()
+fullyConst (ELit (LitCons _ [] _)) = return ()
+fullyConst (ELit (LitCons _ xs _)) = mapM_ fullyConst xs
+fullyConst ELit {} = return ()
+fullyConst (EPi (TVr { tvrType = t }) x) = do
+    fullyConst t
+    fullyConst x
+fullyConst _ = fail "not fully constant"
hunk ./E/E.hs 308
+isFullyConst :: E -> Bool
+isFullyConst = maybe False (const True) . fullyConst
hunk ./E/E.hs 311
-instance FreeVars E x => FreeVars (Lit TVr E) x where
-    freeVars l =  mconcat $ freeVars (getType l):(map (freeVars . getType) $ litBinds l)
+isBottom EError {} = True
+isBottom _ = False
hunk ./E/E.hs 315
+caseBodiesMapM :: Monad m => (E -> m E) -> E -> m E
+caseBodiesMapM f (ECase e b as d) = do
+    let g (Alt l e) = f e >>= return . Alt l
+    as' <- mapM g as
+    d' <- fmapM f d
+    return $ ECase e b as' d'
+caseBodiesMapM _ _ = error "caseBodiesMapM"
hunk ./E/E.hs 323
-freeVs :: E -> IM.IntMap TVr
-freeVs =   fv where
-    (<>) = IM.union
-    delete = IM.delete
-    fv (EAp e1 e2) = fv e1 <> fv e2
-    fv (EVar tvr@(TVr { tvrIdent =  ( i), tvrType =  t })) = IM.insert i tvr (fv t)
-    fv (ELam (TVr { tvrIdent = i, tvrType = t}) e) =  (delete i $ fv e <> fv t)
-    fv (EPi (TVr { tvrIdent =  i, tvrType = t}) e) =  (delete i $ fv e <> fv t)
-    fv (ELetRec dl e) =  ((tl <> bl <> fv e) IM.\\ IM.fromList ll)  where
-        (ll,tl,bl) = liftT3 (id,IM.unions,IM.unions) $ unzip3 $
-            map (\(tvr@(TVr { tvrIdent = j, tvrType =  t}),y) -> ((j,tvr), fv t, fv y)) dl
-    fv (EError _ e) = fv e
-    fv (ELit l) = fvLit l
-    fv (EPrim _ es e) = IM.unions $ fv e : map fv es
-    fv (ECase e b as d) = IM.unions ( fv e:freeVars (getType $ b):(IM.delete (tvrNum b) $ IM.unions (freeVars d:map freeVars as)  ):[])
-    fv Unknown = IM.empty
-    fv ESort {} = IM.empty
-    fvLit (LitCons _ es e) = IM.unions $ fv e:map fv es
-    fvLit l = freeVs (getType l)
+toList :: Monad m => E -> m  [E]
+toList (ELit (LitCons n [e,b] _)) | vCons == n = toList b >>= \x -> return (e:x)
+toList (ELit (LitCons n [] _)) | vEmptyList == n = return []
+toList _ = fail "toList: not list"
hunk ./E/E.hs 328
+toString x = toList x >>= mapM fromChar where
+    fromChar (ELit (LitCons dc [ELit (LitInt ch t)] _ot)) | dc == dc_Char && t == tCharzh = return (chr $ fromIntegral ch)
+    fromChar _ = fail "fromChar: not char"
hunk ./E/E.hs 332
-
--- | separate out recursive strongly connected components from a declaration list
-
-decomposeDefns :: [(TVr, E)] -> [Either (TVr, E) [(TVr,E)]]
-decomposeDefns bs = map f mp where
-    mp = G.stronglyConnComp [ (v,i,freeVars t `mappend` freeVars e) | v@(TVr i t _ ,e) <- bs]
-    f (AcyclicSCC v) = Left v
-    f (CyclicSCC vs) = Right vs
-
-
--- | pull apart an ELet and separate out recursive strongly connected components from an ELet.
-decomposeLet :: E ->  ([Either (TVr, E) [(TVr,E)]],E)
-decomposeLet (ELetRec ds e) = (decomposeDefns ds,e)
-decomposeLet e = ([],e)
-
-
-sortStarLike e = e /= eBox && typ e == eBox
-sortTypeLike e = e /= eBox && not (sortStarLike e) && sortStarLike (typ e)
-sortTermLike e = e /= eBox && not (sortStarLike e) && not (sortTypeLike e) && sortTypeLike (typ e)
-
--- Fast (and lazy, and perhaps unsafe) typeof
-typ ::  E -> E
-typ (ESort 0) =  eBox
-typ (ESort 1) = error "Box inhabits nowhere."
-typ (ESort _) = error "What sort of sort is this?"
-typ (ELit l) = getType l
-typ (EVar v) =  getType v
-typ (EPi _ b) = typ b
-typ (EAp a b) = eAp (typ a) b
-typ (ELam (TVr { tvrIdent = x, tvrType =  a}) b) = EPi (tVr x a) (typ b)
-typ (ELetRec _ e) = typ e
-typ (ECase {eCaseScrutinee = e, eCaseDefault = Just d}) | sortTypeLike e = typ d
-typ (ECase {eCaseAlts = (x:_)}) = getType x
-typ (ECase {eCaseDefault = Just e}) = typ e
-typ (ECase _ _ [] Nothing) = error "empty case"
-typ (EError _ e) = e
-typ (EPrim _ _ t) = t
-typ Unknown = Unknown
-
-instance CanType E E where
-    getType = typ
-instance CanType TVr E where
-    getType = tvrType
-instance CanType (Lit x t) t where
-    getType (LitInt _ t) = t
-    getType (LitCons _ _ t) = t
-instance CanType e t => CanType (Alt e) t where
-    getType (Alt _ e) = getType e
-
-
-eAp (EPi (TVr { tvrIdent =  0 }) b) _ = b
-eAp (EPi t b) e = subst t e b
---eAp (EPrim n es t@(EPi _ _)) b = EPrim n (es ++ [b]) (eAp t b)  -- only apply if type is pi-like
-eAp (ELit (LitCons n es t)) b = (ELit (LitCons n (es ++ [b]) (eAp t b)))
-eAp (EError s t) b = EError s (eAp t b)
-eAp a b = EAp a b
-
+dc_Addr = toName DataConstructor ("Jhc.Addr","Addr")
+dc_Char = toName DataConstructor ("Prelude","Char")
+dc_JustIO = toName DataConstructor ("Jhc.IO", "JustIO")
+dc_Rational = toName DataConstructor ("Ratio",":%")
hunk ./E/E.hs-boot 1
-module E.E where
-
-type TVr = TVr' E
-data TVr' a
-data E 
rmfile ./E/E.hs-boot
hunk ./E/Eval.hs 9
+import E.FreeVars
addfile ./E/FreeVars.hs
hunk ./E/FreeVars.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+module E.FreeVars where
+
+import FreeVars
+import E.E
+import qualified Data.IntMap as IM
+import qualified Data.IntSet as IS
+import qualified Data.Set as Set
+import Data.Monoid
+import GenUtil
+import Data.Graph as G
+
+-------------------------
+-- finding free variables
+-------------------------
+
+
+getTyp tvr = tvrType tvr
+getLitTyp (LitInt _ t) = t
+getLitTyp (LitCons _ _ t) = t
+
+instance FreeVars E IS.IntSet where
+    freeVars e = IS.fromAscList (fsts . IM.toAscList $ freeVs e)
+instance FreeVars E (Set.Set Int) where
+    freeVars e = Set.fromAscList (fsts . IM.toAscList $ freeVs e)
+instance FreeVars E [Int] where
+    freeVars e =  IM.keys $ freeVs e
+instance FreeVars E (IM.IntMap TVr) where
+    freeVars = freeVs
+instance FreeVars E (Set.Set TVr) where
+    freeVars x = Set.fromAscList $ IM.elems (freeVs x)
+instance FreeVars E [TVr] where
+    freeVars x = IM.elems $ freeVars x
+instance FreeVars (Alt E) (IM.IntMap TVr) where
+    freeVars as@(Alt l e) = IM.unions $ freeVars (getLitTyp l):(freeVars e IM.\\ IM.fromList [ (tvrNum t,t) | t <- litBinds l]):( map (freeVars . getTyp) $ litBinds l)
+instance FreeVars E t => FreeVars TVr t where
+    freeVars tvr = freeVars (getTyp tvr :: E)
+instance FreeVars (Alt E) (Set.Set Int) where
+    freeVars as@(Alt l e) = Set.unions $ freeVars (getLitTyp l):(freeVars e Set.\\ Set.fromList [ tvrNum t | t <- litBinds l]):( map (freeVars . getTyp) $ litBinds l)
+instance (FreeVars E x) => FreeVars (Lit TVr E) x where
+    freeVars l =  mconcat $ freeVars (getLitTyp l :: E ):(map (freeVars . (getTyp :: TVr -> E) ) $ litBinds l)
+
+
+
+freeVs ::  E -> IM.IntMap TVr
+freeVs =   fv where
+    (<>) = IM.union
+    delete = IM.delete
+    fv (EAp e1 e2) = fv e1 <> fv e2
+    fv (EVar tvr@(TVr { tvrIdent =  ( i), tvrType =  t })) = IM.insert i tvr (fv t)
+    fv (ELam (TVr { tvrIdent = i, tvrType = t}) e) =  (delete i $ fv e <> fv t)
+    fv (EPi (TVr { tvrIdent =  i, tvrType = t}) e) =  (delete i $ fv e <> fv t)
+    fv (ELetRec dl e) =  ((tl <> bl <> fv e) IM.\\ IM.fromList ll)  where
+        (ll,tl,bl) = liftT3 (id,IM.unions,IM.unions) $ unzip3 $
+            map (\(tvr@(TVr { tvrIdent = j, tvrType =  t}),y) -> ((j,tvr), fv t, fv y)) dl
+    fv (EError _ e) = fv e
+    fv (ELit l) = fvLit l
+    fv (EPrim _ es e) = IM.unions $ fv e : map fv es
+    fv (ECase e b as d) = IM.unions ( fv e:freeVars (getTyp  b):(IM.delete (tvrNum b) $ IM.unions (freeVars d:map freeVars as)  ):[])
+    fv Unknown = IM.empty
+    fv ESort {} = IM.empty
+    fvLit (LitCons _ es e) = IM.unions $ fv e:map fv es
+    fvLit l = freeVs (getLitTyp l)
+
+
+
+-- | separate out recursive strongly connected components from a declaration list
+
+decomposeDefns :: [(TVr, E)] -> [Either (TVr, E) [(TVr,E)]]
+decomposeDefns bs = map f mp where
+    mp = G.stronglyConnComp [ (v,i,freeVars t `mappend` freeVars e) | v@(TVr i t _ ,e) <- bs]
+    f (AcyclicSCC v) = Left v
+    f (CyclicSCC vs) = Right vs
+
+-- | pull apart an ELet and separate out recursive strongly connected components from an ELet.
+decomposeLet :: E ->  ([Either (TVr, E) [(TVr,E)]],E)
+decomposeLet (ELetRec ds e) = (decomposeDefns ds,e)
+decomposeLet e = ([],e)
+
hunk ./E/FromHs.hs 5
+import CanType
hunk ./E/FromHs.hs 123
-argTypes e = span ((== eBox) . typ) (map tvrType xs) where
+argTypes e = span ((== eBox) . getType) (map tvrType xs) where
hunk ./E/FromHs.hs 136
-              | otherwise = case ioLike (typ maine) of
+              | otherwise = case ioLike (getType maine) of
hunk ./E/FromHs.hs 140
-            theMainTvr =  tVr (nameToInt theMainName) (typ e)
+            theMainTvr =  tVr (nameToInt theMainName) (getType e)
hunk ./E/FromHs.hs 170
-        valToPat' (ELit (LitCons x ts t)) = ELit $ LitCons x [ EVar (tVr ( j) (typ z)) | z <- ts | j <- [2,4 ..]]  t
-        valToPat' (EPi (TVr { tvrType =  a}) b)  = ELit $ LitCons tArrow [ EVar (tVr ( j) (typ z)) | z <- [a,b] | j <- [2,4 ..]]  eStar
+        valToPat' (ELit (LitCons x ts t)) = ELit $ LitCons x [ EVar (tVr ( j) (getType z)) | z <- ts | j <- [2,4 ..]]  t
+        valToPat' (EPi (TVr { tvrType =  a}) b)  = ELit $ LitCons tArrow [ EVar (tVr ( j) (getType z)) | z <- [a,b] | j <- [2,4 ..]]  eStar
hunk ./E/FromHs.hs 196
-                | EError "Bad" _ <- defe = return $ calt $  EError ( show n ++ ": undefined at type " ++  PPrint.render (pprint  t) ) (typ els)
+                | EError "Bad" _ <- defe = return $ calt $  EError ( show n ++ ": undefined at type " ++  PPrint.render (pprint  t) ) (getType els)
hunk ./E/FromHs.hs 220
-    te = typ e
+    te = getType e
hunk ./E/FromHs.hs 231
-        te = typ $ EVar tvr
+        te = getType $ EVar tvr
hunk ./E/FromHs.hs 238
-    doNegate e = eAp (eAp (func_negate funcs) (typ e)) e
+    doNegate e = eAp (eAp (func_negate funcs) (getType e)) e
hunk ./E/FromHs.hs 354
-        (_,TVr { tvrType = ty}:_) = fromPi (typ cop)
+        (_,TVr { tvrType = ty}:_) = fromPi (getType cop)
hunk ./E/FromHs.hs 368
-        z = cMatchs [cExpr e] (altConv alts) (EError ("No Match in Case expression at " ++ show (srcLoc hs))  (typ z))
+        z = cMatchs [cExpr e] (altConv alts) (EError ("No Match in Case expression at " ++ show (srcLoc hs))  (getType z))
hunk ./E/FromHs.hs 398
-    --cRhs sl rhs = g where g = cGuard rhs (ump sl $ typ g) --deliciously lazy
+    --cRhs sl rhs = g where g = cGuard rhs (ump sl $ getType g) --deliciously lazy
hunk ./E/FromHs.hs 403
-        f [] = ump sl $ typ (cExpr e)
+        f [] = ump sl $ getType (cExpr e)
hunk ./E/FromHs.hs 452
-    doNegate e = eAp (eAp (func_negate funcs) (typ e)) e
+    doNegate e = eAp (eAp (func_negate funcs) (getType e)) e
hunk ./E/FromHs.hs 471
-                [ev] <- newVars [typ err']
+                [ev] <- newVars [getType err']
hunk ./E/FromHs.hs 478
-                let tb = typ b
+                let tb = getType b
hunk ./E/FromHs.hs 499
-                        return (Alt  (litconvert l (typ b)) m)
+                        return (Alt  (litconvert l (getType b)) m)
hunk ./E/FromHs.hs 509
-                        vs <- newVars (slotTypes dataTable (toName DataConstructor name) (typ b))
+                        vs <- newVars (slotTypes dataTable (toName DataConstructor name) (getType b))
hunk ./E/FromHs.hs 512
-                        return (Alt (LitCons (toName DataConstructor name) vs (typ b))  m)
+                        return (Alt (LitCons (toName DataConstructor name) vs (getType b))  m)
hunk ./E/LambdaLift.hs 3
-import Atom
hunk ./E/LambdaLift.hs 5
+import Data.FunctorM
hunk ./E/LambdaLift.hs 7
+import List
+import qualified Data.Set as Set
+
+import Atom
+import DataConstructors
hunk ./E/LambdaLift.hs 13
+import E.FreeVars
hunk ./E/LambdaLift.hs 15
-import DataConstructors
hunk ./E/LambdaLift.hs 21
-import qualified Data.Set as Set
hunk ./E/LambdaLift.hs 23
-import List
-import Data.FunctorM
hunk ./E/Pretty.hs 11
-import E.Values
+import E.FreeVars
+--import E.Values
hunk ./E/PrimOpt.hs 3
-import E.E
-import Stats
-import E.TypeCheck
hunk ./E/PrimOpt.hs 4
-import E.Values
-import List
+import CanType
hunk ./E/PrimOpt.hs 6
-import Doc.PPrint
-import Doc.DocLike
hunk ./E/PrimOpt.hs 8
-import Monad
-import NameMonad
+import Doc.DocLike
+import Doc.PPrint
+import E.E
+import E.Values
hunk ./E/PrimOpt.hs 14
+import List
+import Monad
+import NameMonad
+import Stats
hunk ./E/PrimOpt.hs 26
-    te = typ e
+    te = getType e
hunk ./E/PrimOpt.hs 37
-    te = typ e
+    te = getType e
hunk ./E/PrimOpt.hs 66
-                (_,ta) <- lookupCType dataTable (typ a)
-                (_,tb) <- lookupCType dataTable (typ b)
+                (_,ta) <- lookupCType dataTable (getType a)
+                (_,tb) <- lookupCType dataTable (getType b)
hunk ./E/Rules.hs 17
-import E.Eval
-import E.E
-import E.Values
-import Stats
-import qualified Data.Map as Map
hunk ./E/Rules.hs 18
+import qualified Data.IntMap as IM
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import Atom(toAtom,fromAtom,Atom)
hunk ./E/Rules.hs 24
+import E.E
+import E.Eval
+import E.Pretty
hunk ./E/Rules.hs 28
-import qualified Data.IntMap as IM
+import FreeVars
hunk ./E/Rules.hs 30
+import HasSize
hunk ./E/Rules.hs 32
-import E.Pretty
-import Atom(toAtom,fromAtom,Atom)
hunk ./E/Rules.hs 33
-import FreeVars
-import qualified Data.Set as Set
-import HasSize
+import Stats
hunk ./E/SSimplify.hs 4
+import CanType
hunk ./E/SSimplify.hs 9
+import Data.Generics
hunk ./E/SSimplify.hs 16
-import qualified Info
-import qualified E.Strictness as Strict
hunk ./E/SSimplify.hs 25
+import qualified E.Strictness as Strict
+import qualified Info
hunk ./E/SSimplify.hs 29
-import CanType
-import Data.Generics
hunk ./E/SSimplify.hs 339
-        let t = typ (ECase (EVar v) b as d)
+        let t = getType (ECase (EVar v) b as d)
hunk ./E/SSimplify.hs 355
-        let t = typ (ECase e b as d)
+        let t = getType (ECase e b as d)
hunk ./E/SSimplify.hs 377
-        te = typ e
+        te = getType e
hunk ./E/Subst.hs 1
-module E.Subst(subst,subst',substMap,substMap',noShadow,doSubst,substMap'',litSMapM, app, substLet) where
-
+module E.Subst(subst,subst',eAp, substMap,substMap',noShadow,doSubst,substMap'',litSMapM, app, substLet) where
hunk ./E/Subst.hs 10
-import E.Values
hunk ./E/Subst.hs 11
+import E.FreeVars
hunk ./E/Subst.hs 19
-
hunk ./E/Subst.hs 33
-subst (TVr { tvrIdent = i }) w e = doSubst False False (Map.insert i (Just w) $ Map.fromList [ (x,Nothing) | x <- freeVars (getType w) ++ freeVars e ]) e
+--subst (TVr { tvrIdent = i }) w e = doSubst False False (Map.insert i (Just w) $ Map.fromList [ (x,Nothing) | x <- freeVars (getType w) ++ freeVars e ]) e
+subst (TVr { tvrIdent = i }) w e = doSubst False False (Map.insert i (Just w) $ Map.fromList [ (x,Nothing) | x <- freeVars w ++ freeVars e ]) e
hunk ./E/Subst.hs 44
-subst' (TVr { tvrIdent = (i) }) w e = doSubst True False (Map.insert i (Just w) $ Map.fromList [ (x,Nothing) | x <- freeVars (getType w) ++ freeVars e ]) e
+--subst' (TVr { tvrIdent = (i) }) w e = doSubst True False (Map.insert i (Just w) $ Map.fromList [ (x,Nothing) | x <- freeVars (getType w) ++ freeVars e ]) e
+subst' (TVr { tvrIdent = (i) }) w e = doSubst True False (Map.insert i (Just w) $ Map.fromList [ (x,Nothing) | x <- freeVars w ++ freeVars e ]) e
hunk ./E/Subst.hs 193
+
+eAp (EPi (TVr { tvrIdent =  0 }) b) _ = b
+eAp (EPi t b) e = subst t e b
+--eAp (EPrim n es t@(EPi _ _)) b = EPrim n (es ++ [b]) (eAp t b)  -- only apply if type is pi-like
+eAp (ELit (LitCons n es t)) b = (ELit (LitCons n (es ++ [b]) (eAp t b)))
+eAp (EError s t) b = EError s (eAp t b)
+eAp a b = EAp a b
+
hunk ./E/Subst.hs-boot 1
-module E.Subst where
-
-
-import {-# SOURCE #-} E.E
-
-subst :: E.E.TVr -> E.E.E -> E.E.E -> E.E.E
---subst :: TVr -> E -> E -> E
rmfile ./E/Subst.hs-boot
hunk ./E/Traverse.hs 12
+import DataConstructors()
hunk ./E/TypeCheck.hs 1
-module E.TypeCheck(typ, eAp, sortStarLike, sortTypeLike,  sortTermLike, inferType, typeInfer, typeInfer') where
+module E.TypeCheck(eAp, sortStarLike, sortTypeLike,  sortTermLike, inferType, typeInfer, typeInfer') where
hunk ./E/TypeCheck.hs 4
-import DataConstructors
+import {-# SOURCE #-} DataConstructors
hunk ./E/TypeCheck.hs 18
+-- Fast (and lazy, and perhaps unsafe) typeof
+typ ::  E -> E
+typ (ESort 0) =  eBox
+typ (ESort 1) = error "Box inhabits nowhere."
+typ (ESort _) = error "What sort of sort is this?"
+typ (ELit l) = getType l
+typ (EVar v) =  getType v
+typ (EPi _ b) = typ b
+typ (EAp a b) = eAp (typ a) b
+typ (ELam (TVr { tvrIdent = x, tvrType =  a}) b) = EPi (tVr x a) (typ b)
+typ (ELetRec _ e) = typ e
+typ (ECase {eCaseScrutinee = e, eCaseDefault = Just d}) | sortTypeLike e = typ d
+typ (ECase {eCaseAlts = (x:_)}) = getType x
+typ (ECase {eCaseDefault = Just e}) = typ e
+typ (ECase _ _ [] Nothing) = error "empty case"
+typ (EError _ e) = e
+typ (EPrim _ _ t) = t
+typ Unknown = Unknown
hunk ./E/TypeCheck.hs 38
+instance CanType E E where
+    getType = typ
+instance CanType TVr E where
+    getType = tvrType
+instance CanType (Lit x t) t where
+    getType (LitInt _ t) = t
+    getType (LitCons _ _ t) = t
+instance CanType e t => CanType (Alt e) t where
+    getType (Alt _ e) = getType e
hunk ./E/TypeCheck.hs 49
+sortStarLike e = e /= eBox && getType e == eBox
+sortTypeLike e = e /= eBox && not (sortStarLike e) && sortStarLike (getType e)
+sortTermLike e = e /= eBox && not (sortStarLike e) && not (sortTypeLike e) && sortTypeLike (getType e)
hunk ./E/Values.hs 3
+import CanType
hunk ./E/Values.hs 6
-import Data.FunctorM
hunk ./E/Values.hs 7
+import E.FreeVars()
+import E.Subst
+import E.TypeCheck
hunk ./E/Values.hs 13
-import VConsts
hunk ./E/Values.hs 14
-import {-# SOURCE #-} E.Subst
+import VConsts
hunk ./E/Values.hs 22
-    ts = map typ es
+    ts = map getType es
hunk ./E/Values.hs 25
-    ts = map typ es
+    ts = map getType es
hunk ./E/Values.hs 30
-toList :: Monad m => E -> m  [E]
-toList (ELit (LitCons n [e,b] _)) | vCons == n = toList b >>= \x -> return (e:x)
-toList (ELit (LitCons n [] _)) | vEmptyList == n = return []
-toList _ = fail "toList: not list"
-
-toString x = toList x >>= mapM fromChar where
-    fromChar (ELit (LitCons dc [ELit (LitInt ch t)] _ot)) | dc == dc_Char && t == tCharzh = return (chr $ fromIntegral ch)
-    fromChar _ = fail "fromChar: not char"
hunk ./E/Values.hs 61
-dc_Char = toName DataConstructor ("Prelude","Char")
-dc_Rational = toName DataConstructor ("Ratio",":%")
-dc_Addr = toName DataConstructor ("Jhc.Addr","Addr")
-dc_JustIO = toName DataConstructor ("Jhc.IO", "JustIO")
hunk ./E/Values.hs 86
-eCons x xs = ELit $ LitCons vCons [x,xs] (typ xs)
+eCons x xs = ELit $ LitCons vCons [x,xs] (getType xs)
hunk ./E/Values.hs 89
-eCaseTup e vs w = ECase e (tVr 0 (typ e)) [Alt (LitCons (toTuple (length vs)) vs (typ e)) w] Nothing
-eCaseTup' e vs w = ECase e (tVr 0 (typ e)) [Alt (LitCons (unboxedNameTuple DataConstructor (length vs)) vs (typ e)) w] Nothing
+eCaseTup e vs w = ECase e (tVr 0 (getType e)) [Alt (LitCons (toTuple (length vs)) vs (getType e)) w] Nothing
+eCaseTup' e vs w = ECase e (tVr 0 (getType e)) [Alt (LitCons (unboxedNameTuple DataConstructor (length vs)) vs (getType e)) w] Nothing
hunk ./E/Values.hs 92
-eJustIO w x = ELit (LitCons dc_JustIO [w,x] (ELit (LitCons (toName TypeConstructor ("Jhc.IO","IOResult")) [typ x] eStar)))
+eJustIO w x = ELit (LitCons dc_JustIO [w,x] (ELit (LitCons (toName TypeConstructor ("Jhc.IO","IOResult")) [getType x] eStar)))
hunk ./E/Values.hs 95
-eCase e alts Unknown = ECase { eCaseScrutinee = e, eCaseBind = (tVr 0 (typ e)), eCaseDefault = Nothing, eCaseAlts =  alts }
-eCase e alts els = ECase { eCaseScrutinee = e, eCaseBind = (tVr 0 (typ e)), eCaseDefault = Just els, eCaseAlts =  alts }
+eCase e alts Unknown = ECase { eCaseScrutinee = e, eCaseBind = (tVr 0 (getType e)), eCaseDefault = Nothing, eCaseAlts =  alts }
+eCase e alts els = ECase { eCaseScrutinee = e, eCaseBind = (tVr 0 (getType e)), eCaseDefault = Just els, eCaseAlts =  alts }
hunk ./E/Values.hs 103
-
-fullyConst :: Monad m => E -> m ()
-fullyConst (ELit (LitCons _ [] _)) = return ()
-fullyConst (ELit (LitCons _ xs _)) = mapM_ fullyConst xs
-fullyConst ELit {} = return ()
-fullyConst (EPi (TVr { tvrType = t }) x) = do
-    fullyConst t
-    fullyConst x
-fullyConst _ = fail "not fully constant"
-
-isFullyConst :: E -> Bool
-isFullyConst = maybe False (const True) . fullyConst
hunk ./E/Values.hs 104
-isAtomic :: E -> Bool
---isAtomic e | sortTypeLike e = True
-isAtomic EVar {}  = True
-isAtomic e = isFullyConst e
hunk ./E/Values.hs 106
-isBottom EError {} = True
-isBottom _ = False
hunk ./E/Values.hs 122
-prim_seq a b = ECase a (tVr 0 (typ a)) [] (Just b)
+prim_seq a b = ECase a (tVr 0 (getType a)) [] (Just b)
hunk ./E/Values.hs 138
-    f n e t | typ e == t = (n,e,id)
+    f n e t | getType e == t = (n,e,id)
hunk ./E/Values.hs 147
+
hunk ./E/Values.hs 150
-caseBodiesMapM :: Monad m => (E -> m E) -> E -> m E
-caseBodiesMapM f (ECase e b as d) = do
-    let g (Alt l e) = f e >>= return . Alt l
-    as' <- mapM g as
-    d' <- fmapM f d
-    return $ ECase e b as' d'
-caseBodiesMapM _ _ = error "caseBodiesMapM"
hunk ./Grin/FromE.hs 3
-import Atom
hunk ./Grin/FromE.hs 4
-import Control.Monad.Identity
-import C.Prims
-import DataConstructors
hunk ./Grin/FromE.hs 8
+import List
+import Maybe
+import qualified Data.Set as Set
+
+import Atom
+import CanType
+import Control.Monad.Identity
+import C.Prims
+import DataConstructors
hunk ./Grin/FromE.hs 22
+import E.FreeVars
hunk ./Grin/FromE.hs 33
-import List
-import Maybe
-import Monad
hunk ./Grin/FromE.hs 36
-import qualified Data.Set as Set
hunk ./Grin/FromE.hs 106
-        f x = (x,map (toty (TyPtr TyNode) . tvrType ) as,toty TyNode (typ e))
+        f x = (x,map (toty (TyPtr TyNode) . tvrType ) as,toty TyNode (getType (e::E) :: E))
hunk ./Grin/FromE.hs 443
-    ce (ECase e b as d) | (ELit (LitCons n [] _)) <- typ e, RawType <- nameType n = do
+    ce (ECase e b as d) | (ELit (LitCons n [] _)) <- getType e, RawType <- nameType n = do
hunk ./Grin/FromE.hs 483
-        (c,t) <- case lookupCType dataTable (typ e) of
+        (c,t) <- case lookupCType dataTable (getType e) of
hunk ./Grin/FromE.hs 676
-                x <- ce (EPrim aprim [ EVar (tvr { tvrIdent = v, tvrType =  t}) | t <- map typ es | v <- [2,4..]] pt)
+                x <- ce (EPrim aprim [ EVar (tvr { tvrIdent = v, tvrType =  t}) | t <- map getType es | v <- [2,4..]] pt)
hunk ./Ho.hs 4
+import Data.Graph(stronglyConnComp,SCC(..))
+import Data.IORef
+import Data.Monoid
+import IO(bracket)
+import List
hunk ./Ho.hs 10
+import qualified Data.Map as Map
+import qualified Text.PrettyPrint.HughesPJ as PPrint
hunk ./Ho.hs 13
+import System.Posix.Files
+import System.Posix.IO
hunk ./Ho.hs 18
+import CanType
hunk ./Ho.hs 23
-import Data.Graph(stronglyConnComp,SCC(..))
-import Data.IORef
-import Data.Monoid
hunk ./Ho.hs 31
+import E.TypeCheck()
hunk ./Ho.hs 39
-import IO(bracket)
hunk ./Ho.hs 40
-import List
hunk ./Ho.hs 47
-import qualified Data.Map as Map
hunk ./Ho.hs 49
-import qualified Text.PrettyPrint.HughesPJ as PPrint
hunk ./Ho.hs 50
-import System.Posix.Files
-import System.Posix.IO
hunk ./Ho.hs 474
-    es = Map.fromList [  (n,(tVr (atomIndex $ toAtom n) (typ v),v)) |  (n,v) <- constantMethods ] `mappend` es'
-    es' = Map.fromList [ (n,(tVr (atomIndex $ toAtom n) (typ v),v)) | (n,t,p,d) <- theMethods, let v = f n t p d  ]
+    es = Map.fromList [  (n,(tVr (atomIndex $ toAtom n) (getType v),v)) |  (n,v) <- constantMethods ] `mappend` es'
+    --es' = Map.fromList [ (n,(tVr (atomIndex $ toAtom n) (getType v),v)) | (n,t,p,d) <- theMethods, let v = f n t p d  ]
+    es' = Map.fromList [ (n,(tVr (atomIndex $ toAtom n) (error "f no longer relevant"),v)) | (n,t,p,d) <- theMethods, let v = f n t p d  ]
hunk ./data/PrimitiveOperators-in.hs 12
+import E.TypeCheck()
+import CanType
hunk ./data/PrimitiveOperators-in.hs 20
-    te = typ e
+    te = getType e
hunk ./data/PrimitiveOperators-in.hs 78
-    te = typ v
+    te = getType v
hunk ./data/PrimitiveOperators-in.hs 90
-    te = typ v
+    te = getType v