[move core definition to E.Type
John Meacham <john@repetae.net>**20061126104731] hunk ./E/E.hs 2
-module E.E where
+module E.E(module E.Type, module E.E) where
hunk ./E/E.hs 4
-import GenUtil
-import Control.Monad.Identity
-import Monad
+import Char(chr)
hunk ./E/E.hs 6
-import Maybe
+import Data.Monoid
hunk ./E/E.hs 8
-import Doc.DocLike
-import Name.VConsts
-import Name.Name
-import Name.Names
-import Binary
+import Maybe
+import Monad
+
hunk ./E/E.hs 13
-import Char(chr)
-import Data.Monoid
-import Number
-import {-# SOURCE #-} Info.Binary(putInfo,getInfo)
-import qualified Info.Info as Info
+import Control.Monad.Identity
+import E.Type
+import GenUtil
hunk ./E/E.hs 17
+import Name.Name
+import Name.Names
+import Name.VConsts
+import Number
hunk ./E/E.hs 24
---------------------------------------
--- Lambda Cube (it's just fun to say.)
--- We are now based on a PTS, which is
--- a generalization of the lambda cube
--- see E.TypeCheck for a description
--- of the type system.
---------------------------------------
hunk ./E/E.hs 26
-data Lit e t = LitInt { litNumber :: Number, litType :: t }
-    | LitCons  { litName :: Name, litArgs :: [e], litType :: t, litAliasFor :: Maybe E }
---    | LitAlias { litName :: Name, litArgs :: [e], litType :: t, litAliasFor :: Maybe E }
-    deriving(Eq,Ord)
-        {-!derive: is, GhcBinary !-}
hunk ./E/E.hs 29
-instance (Show e,Show t) => Show (Lit e t) where
-    showsPrec p (LitInt x t) = showParen (p > 10) $  shows x <> showString "::" <> shows t
-    showsPrec p LitCons { litName = n, litArgs = es, litType = t } = showParen (p > 10) $ hsep (shows n:map (showsPrec 11) es) <> showString "::" <> shows t
-
-instance Functor (Lit e) where
-    fmap f x = runIdentity $ fmapM (return . f) x
-
-instance FunctorM (Lit e) where
-    fmapM f x = case x of
-        LitCons { litName = a, litArgs = es, litType = e, litAliasFor = af } -> do  e <- f e; return LitCons { litName = a, litArgs = es, litType = e, litAliasFor = af }
-        LitInt i t -> do t <- f t; return $ LitInt i t
-
-
-data ESort =
-    EStar         -- ^ the sort of boxed lazy types
-    | EBang       -- ^ the sort of boxed strict types
-    | EHash       -- ^ the sort of unboxed types
-    | ETuple      -- ^ the sort of unboxed tuples
-    | EHashHash   -- ^ the supersort of unboxed types
-    | EStarStar   -- ^ the supersort of boxed types
-    | ESortNamed Name -- ^ user defined sorts
-    deriving(Eq, Ord)
-    {-! derive: is, GhcBinary !-}
-
-instance Show ESort where
-    showsPrec _ EStar = showString "*"
-    showsPrec _ EHash = showString "#"
-    showsPrec _ EStarStar = showString "**"
-    showsPrec _ EHashHash = showString "##"
-    showsPrec _ ETuple = showString "(#)"
-    showsPrec _ EBang = showString "!"
-
-
-data E = EAp E E
-    | ELam TVr E
-    | EPi TVr E
-    | EVar TVr
-    | Unknown
-    | ESort ESort
-    | ELit !(Lit E E)
-    | ELetRec { eDefs :: [(TVr, E)], eBody :: E }
-    | EPrim APrim [E] E
-    | EError String E
-    | ECase {
-       eCaseScrutinee :: E,
-       eCaseType :: E, -- due to GADTs and typecases, the final type of the expression might not be so obvious, so we include it here.
-       eCaseBind :: TVr,
-       eCaseAlts :: [Alt E],
-       eCaseDefault :: (Maybe E)
-       }
-	deriving(Eq, Ord, Show)
-    {-! derive: is, from, GhcBinary !-}
-
hunk ./E/E.hs 51
-type TVr = TVr' E
-data TVr' e = TVr { tvrIdent :: !Id, tvrType :: e, tvrInfo :: Info.Info }
-    {-! derive: update !-}
hunk ./E/E.hs 55
-data TvrBinary = TvrBinaryNone | TvrBinaryAtom Atom | TvrBinaryInt Int
-    {-! derive: GhcBinary !-}
-
-instance Binary TVr where
-    put_ bh (TVr { tvrIdent = 0, tvrType =  e, tvrInfo = nf} ) = do
-        put_ bh (TvrBinaryNone)
-        put_ bh e
-        putInfo bh nf
-    put_ bh (TVr { tvrIdent = i, tvrType =  e, tvrInfo = nf}) | Just x <- intToAtom i = do
-        put_ bh (TvrBinaryAtom x)
-        put_ bh e
-        putInfo bh nf
-    put_ bh (TVr { tvrIdent = i, tvrType =  e, tvrInfo = nf}) = do
-        unless (even i) $ fail "number not even"
-        put_ bh (TvrBinaryInt i)
-        put_ bh e
-        putInfo bh nf
-    get bh = do
-        (x ) <- get bh
-        e <- get bh
-        nf <- getInfo bh
-        case x of
-            TvrBinaryNone -> return $ TVr 0 e nf
-            TvrBinaryAtom a -> return $ TVr (atomIndex a) e nf
-            TvrBinaryInt i -> return $ TVr (i) e nf
hunk ./E/E.hs 57
-instance Show a => Show (TVr' a) where
-    showsPrec n TVr { tvrIdent = 0, tvrType = e} = showParen (n > 10) $ showString "_::" . shows e
-    showsPrec n TVr { tvrIdent = x, tvrType = e} = showParen (n > 10) $ case fromId x of
-        Just n -> shows n . showString "::" . shows e
-        Nothing  -> shows x . showString "::" . shows e
-
-
-
-instance FunctorM TVr' where
-    fmapM f t = do e <- f (tvrType t); return t { tvrType = e }
-instance Functor TVr' where
-    fmap f t = runIdentity (fmapM (return . f) t)
-
-instance Show e => Show (Alt e) where
-    showsPrec n (Alt l e) = showParen (n > 10) $ shows l . showString " -> " . shows e
-
-
-data Alt e = Alt (Lit TVr e) e
-    deriving(Eq,Ord)
-       {-!derive: GhcBinary !-}
-
hunk ./E/E.hs 77
-instance Eq TVr where
-    (==) (TVr { tvrIdent = i }) (TVr { tvrIdent = i' }) = i == i'
-    (/=) (TVr { tvrIdent = i }) (TVr { tvrIdent = i' }) = i /= i'
-
-instance Ord TVr where
-    compare (TVr { tvrIdent = x }) (TVr { tvrIdent = y }) = compare x y
-    x < y = tvrIdent x < tvrIdent y
-    x > y = tvrIdent x > tvrIdent y
-    x >= y = tvrIdent x >= tvrIdent y
-    x <= y = tvrIdent x <= tvrIdent y
hunk ./E/E.hs 158
-
-
hunk ./E/FreeVars.hs 4
-import Support.FreeVars
-import E.E
+import Data.Graph as G
hunk ./E/FreeVars.hs 6
+import E.E
hunk ./E/FreeVars.hs 8
-import Data.Graph as G
hunk ./E/FreeVars.hs 9
+import Support.FreeVars
hunk ./E/FreeVars.hs 99
+
hunk ./E/Rules.hs 40
-import E.Values
hunk ./E/Rules.hs 42
+import E.Values
hunk ./E/Rules.hs 44
+import Info.Types
hunk ./E/Rules.hs 46
+import Name.Id
hunk ./E/Rules.hs 49
-import qualified CharIO
-import qualified Info.Info as Info
-import Info.Types
+import Options
hunk ./E/Rules.hs 54
-import Name.Id
-import Options
hunk ./E/Rules.hs 55
+import qualified CharIO
+import qualified Info.Info as Info
hunk ./E/Rules.hs 62
-data RuleType = RuleSpecialization | RuleUser | RuleCatalyst
-    deriving(Eq)
- {-! derive: GhcBinary !-}
-
--- a rule in its user visible form
-
-data Rule = Rule {
-    ruleHead :: TVr,
-    ruleBinds :: [TVr],
-    ruleArgs :: [E],
-    ruleNArgs :: {-# UNPACK #-} !Int,
-    ruleBody :: E,
-    ruleType :: RuleType,
-    ruleUniq :: (Module,Int),
-    ruleName :: Atom
-    }
- {-! derive: GhcBinary !-}
-
-
hunk ./E/Rules.hs 197
-data ARules = ARules {
-    aruleFreeVars :: IdSet,
-    aruleRules :: [Rule]
-    }
-    deriving(Typeable)
-
addfile ./E/Type.hs
hunk ./E/Type.hs 1
+module E.Type where
+
+import Data.FunctorM
+import Control.Monad.Identity
+
+
+import Atom
+import Binary
+import C.Prims
+import Data.Typeable
+import Doc.DocLike
+import Name.Id
+import Name.Name
+import Number
+import qualified Info.Info as Info
+import {-# SOURCE #-} Info.Binary(putInfo,getInfo)
+
+data RuleType = RuleSpecialization | RuleUser | RuleCatalyst
+    deriving(Eq)
+ {-! derive: GhcBinary !-}
+
+-- a rule in its user visible form
+
+data Rule = Rule {
+    ruleHead :: TVr,
+    ruleBinds :: [TVr],
+    ruleArgs :: [E],
+    ruleNArgs :: {-# UNPACK #-} !Int,
+    ruleBody :: E,
+    ruleType :: RuleType,
+    ruleUniq :: (Module,Int),
+    ruleName :: Atom
+    }
+ {-! derive: GhcBinary !-}
+
+data ARules = ARules {
+    aruleFreeVars :: IdSet,
+    aruleRules :: [Rule]
+    }
+    deriving(Typeable)
+
+data Lit e t = LitInt { litNumber :: Number, litType :: t }
+    | LitCons  { litName :: Name, litArgs :: [e], litType :: t, litAliasFor :: Maybe E }
+    deriving(Eq,Ord)
+        {-!derive: is, GhcBinary !-}
+
+
+--------------------------------------
+-- Lambda Cube (it's just fun to say.)
+-- We are now based on a PTS, which is
+-- a generalization of the lambda cube
+-- see E.TypeCheck for a description
+-- of the type system.
+--------------------------------------
+
+data ESort =
+    EStar         -- ^ the sort of boxed lazy types
+    | EBang       -- ^ the sort of boxed strict types
+    | EHash       -- ^ the sort of unboxed types
+    | ETuple      -- ^ the sort of unboxed tuples
+    | EHashHash   -- ^ the supersort of unboxed types
+    | EStarStar   -- ^ the supersort of boxed types
+    | ESortNamed Name -- ^ user defined sorts
+    deriving(Eq, Ord)
+    {-! derive: is, GhcBinary !-}
+
+
+data E = EAp E E
+    | ELam TVr E
+    | EPi TVr E
+    | EVar TVr
+    | Unknown
+    | ESort ESort
+    | ELit !(Lit E E)
+    | ELetRec { eDefs :: [(TVr, E)], eBody :: E }
+    | EPrim APrim [E] E
+    | EError String E
+    | ECase {
+       eCaseScrutinee :: E,
+       eCaseType :: E, -- due to GADTs and typecases, the final type of the expression might not be so obvious, so we include it here.
+       eCaseBind :: TVr,
+       eCaseAlts :: [Alt E],
+       eCaseDefault :: (Maybe E)
+       }
+	deriving(Eq, Ord, Show)
+    {-! derive: is, from, GhcBinary !-}
+
+
+
+instance Functor (Lit e) where
+    fmap f x = runIdentity $ fmapM (return . f) x
+
+instance FunctorM (Lit e) where
+    fmapM f x = case x of
+        LitCons { litName = a, litArgs = es, litType = e, litAliasFor = af } -> do  e <- f e; return LitCons { litName = a, litArgs = es, litType = e, litAliasFor = af }
+        LitInt i t -> do t <- f t; return $ LitInt i t
+
+instance Show ESort where
+    showsPrec _ EStar = showString "*"
+    showsPrec _ EHash = showString "#"
+    showsPrec _ EStarStar = showString "**"
+    showsPrec _ EHashHash = showString "##"
+    showsPrec _ ETuple = showString "(#)"
+    showsPrec _ EBang = showString "!"
+
+instance (Show e,Show t) => Show (Lit e t) where
+    showsPrec p (LitInt x t) = showParen (p > 10) $  shows x <> showString "::" <> shows t
+    showsPrec p LitCons { litName = n, litArgs = es, litType = t } = showParen (p > 10) $ hsep (shows n:map (showsPrec 11) es) <> showString "::" <> shows t
+
+instance Show a => Show (TVr' a) where
+    showsPrec n TVr { tvrIdent = 0, tvrType = e} = showParen (n > 10) $ showString "_::" . shows e
+    showsPrec n TVr { tvrIdent = x, tvrType = e} = showParen (n > 10) $ case fromId x of
+        Just n -> shows n . showString "::" . shows e
+        Nothing  -> shows x . showString "::" . shows e
+
+
+type TVr = TVr' E
+data TVr' e = TVr { tvrIdent :: !Id, tvrType :: e, tvrInfo :: Info.Info }
+    {-! derive: update !-}
+
+data Alt e = Alt (Lit TVr e) e
+    deriving(Eq,Ord)
+       {-!derive: GhcBinary !-}
+
+instance FunctorM TVr' where
+    fmapM f t = do e <- f (tvrType t); return t { tvrType = e }
+instance Functor TVr' where
+    fmap f t = runIdentity (fmapM (return . f) t)
+
+instance Show e => Show (Alt e) where
+    showsPrec n (Alt l e) = showParen (n > 10) $ shows l . showString " -> " . shows e
+
+
+instance Eq TVr where
+    (==) (TVr { tvrIdent = i }) (TVr { tvrIdent = i' }) = i == i'
+    (/=) (TVr { tvrIdent = i }) (TVr { tvrIdent = i' }) = i /= i'
+
+instance Ord TVr where
+    compare (TVr { tvrIdent = x }) (TVr { tvrIdent = y }) = compare x y
+    x < y = tvrIdent x < tvrIdent y
+    x > y = tvrIdent x > tvrIdent y
+    x >= y = tvrIdent x >= tvrIdent y
+    x <= y = tvrIdent x <= tvrIdent y
+
+-- Binary instance
+data TvrBinary = TvrBinaryNone | TvrBinaryAtom Atom | TvrBinaryInt Int
+    {-! derive: GhcBinary !-}
+
+instance Binary TVr where
+    put_ bh (TVr { tvrIdent = 0, tvrType =  e, tvrInfo = nf} ) = do
+        put_ bh (TvrBinaryNone)
+        put_ bh e
+        putInfo bh nf
+    put_ bh (TVr { tvrIdent = i, tvrType =  e, tvrInfo = nf}) | Just x <- intToAtom i = do
+        put_ bh (TvrBinaryAtom x)
+        put_ bh e
+        putInfo bh nf
+    put_ bh (TVr { tvrIdent = i, tvrType =  e, tvrInfo = nf}) = do
+        unless (even i) $ fail "number not even"
+        put_ bh (TvrBinaryInt i)
+        put_ bh e
+        putInfo bh nf
+    get bh = do
+        (x ) <- get bh
+        e <- get bh
+        nf <- getInfo bh
+        case x of
+            TvrBinaryNone -> return $ TVr 0 e nf
+            TvrBinaryAtom a -> return $ TVr (atomIndex a) e nf
+            TvrBinaryInt i -> return $ TVr (i) e nf
+