SSTG 0.1.1.6 → 0.1.1.7

raw patch · 7 files changed

+180/−161 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• SSTG.cabal +1/−1
• src/SSTG/Core/Execution/Engine.hs +1/−1
• src/SSTG/Core/Execution/Rules.hs +18/−18
• src/SSTG/Core/Execution/Support.hs +34/−23
• src/SSTG/Core/Language/Naming.hs +82/−78
• src/SSTG/Core/Language/Typing.hs +42/−38
• src/SSTG/Utils/Printing.hs +2/−2

@@ -1,5 +1,5 @@ name:                SSTG-version:             0.1.1.6+version:             0.1.1.7 synopsis:            STG Symbolic Execution description:         Prototype of STG-based Symbolic Execution for Haskell. homepage:            https://github.com/AntonXue/SSTG#readme

@@ -149,7 +149,7 @@     actuals = traceArgs params expr locals globals heap     confs = map varName actuals     names' = freshSeededNames confs confs-    adjusted = map (\(n, t) -> Var n t) (zip names' (map varType actuals))+    adjusted = map (\(n, t) -> Var n t) (zip names' (map typeOf actuals))     -- Throw the parameters on heap as symbolic objects     sym_objs = map (\p -> SymObj (Symbol p Nothing)) adjusted     (heap', addrs) = allocHeapObjs sym_objs heap

@@ -86,9 +86,9 @@ liftUnInt (LiftAct var locals globals heap confs) = pass_out   where     sname = freshSeededName (varName var) confs-    svar = Var sname (varType var)+    svar = Var sname (typeOf var)     (heap', addr) = allocHeapObj (SymObj (Symbol svar Nothing)) heap-    globals' = insertGlobalsVal (var, MemVal addr) globals+    globals' = insertGlobalsVal var (MemVal addr) globals     confs' = sname : confs     pass_out = LiftAct addr locals globals' heap' confs' @@ -192,7 +192,7 @@     (mvar, addr, cvar, Alt acon expr) = args     params = case acon of { DataAlt _ ps -> ps ; _ -> [] }     snames = freshSeededNames (map varName params) confs-    svars = map (\(p, n) -> Var n (varType p)) (zip params snames)+    svars = map (\(p, n) -> Var n (typeOf p)) (zip params snames)     hobjs = map (\s -> SymObj (Symbol s Nothing)) svars     (heap', addrs) = allocHeapObjs hobjs heap     mem_vals = map MemVal addrs@@ -314,9 +314,9 @@   , Just (_, hobj) <- vlookupHeap sfun locals globals heap   , SymObj (Symbol svar _) <- hobj =     let sname = freshSeededName (varName svar) confs-        svar' = Var sname (foldl AppTy (varType svar) (map atomType args))-        sym = Symbol svar' (Just (FunApp sfun args, locals))-        (heap', addr) = allocHeapObj (SymObj sym) heap+        sres = Var sname (foldl AppTy (typeOf svar) (map typeOf args))+        sym_app = Symbol sres (Just (FunApp sfun args, locals))+        (heap', addr) = allocHeapObj (SymObj sym_app) heap     in Just (RuleFunAppSym             ,[state { state_heap = heap'                     , state_code = Return (MemVal addr)@@ -353,7 +353,7 @@   -- Rule Case Lit   | Evaluate (Case (Atom (LitAtom lit)) cvar alts) locals <- code   , (Alt _ expr):_ <- matchLitAlts lit alts =-    let locals' = insertLocalsVal (cvar, LitVal lit) locals+    let locals' = insertLocalsVal cvar (LitVal lit) locals     in Just (RuleCaseLit             ,[state { state_code = Evaluate expr locals' }]) @@ -372,7 +372,7 @@   | Evaluate (Case (Atom (LitAtom lit)) cvar alts) locals <- code   , [] <- matchLitAlts lit alts   , (Alt _ expr):_ <- defaultAlts alts =-    let locals' = insertLocalsVal (cvar, LitVal lit) locals+    let locals' = insertLocalsVal cvar (LitVal lit) locals     in Just (RuleCaseAnyLit             ,[state { state_code = Evaluate expr locals' }]) @@ -382,7 +382,7 @@   , ConObj dcon _ <- hobj   , [] <- matchDataAlts dcon alts   , (Alt _ expr):_ <- defaultAlts alts =-    let locals' = insertLocalsVal (cvar, MemVal addr) locals+    let locals' = insertLocalsVal cvar (MemVal addr) locals     in Just (RuleCaseAnyConPtr             ,[state { state_code = Evaluate expr locals' }]) @@ -417,7 +417,7 @@     let frame = UpdateFrame addr     in Just (RuleUpdateCThunk             ,[state { state_stack = pushStack frame stack-                    , state_heap = insertHeapObj (addr, Blackhole) heap+                    , state_heap = insertHeapObj addr Blackhole heap                     , state_code = Evaluate expr fun_locs }])    -- Rule Update Frame Delete Lit@@ -425,7 +425,7 @@   , Return (LitVal lit) <- code =     Just (RuleUpdateDLit          ,[state { state_stack = stack'-                 , state_heap = insertHeapObj (frm_addr, LitObj lit) heap+                 , state_heap = insertHeapObj frm_addr (LitObj lit) heap                  , state_code = Return (LitVal lit) }])    -- Rule Update Frame Delete Val Pointer@@ -435,7 +435,7 @@   , isHeapValForm hobj =     Just (RuleUpdateDValPtr          ,[state { state_stack = stack'-                 , state_heap = insertHeapRedir (frm_addr, addr) heap+                 , state_heap = insertHeapRedir frm_addr addr heap                  , state_code = Return (MemVal addr) }])    -- Rule Case Frame Create Case Non LitVal or MemVal@@ -460,9 +460,9 @@   , Just hobj <- lookupHeap addr heap   , isHeapValForm hobj =     let vname = freshSeededName (varName cvar) confs-        vvar = Var vname (varType cvar)+        vvar = Var vname (typeOf cvar)         cexpr = Case (Atom (VarAtom vvar)) cvar alts-        frm_locs' = insertLocalsVal (vvar, MemVal addr) frm_locs+        frm_locs' = insertLocalsVal vvar (MemVal addr) frm_locs     in Just (RuleCaseDValPtr             ,[state { state_stack = stack'                     , state_code = Evaluate cexpr frm_locs'@@ -501,7 +501,7 @@   , Just ftype <- memAddrType addr heap =     let fname = freshName VarNSpace confs         fvar = Var fname ftype-        frm_locs' = insertLocalsVal (fvar, MemVal addr) frm_locs+        frm_locs' = insertLocalsVal fvar (MemVal addr) frm_locs     in Just (RuleApplyDReturnFun             ,[state { state_stack = stack'                     , state_code = Evaluate (FunApp fvar args) frm_locs'@@ -513,11 +513,11 @@   , Just hobj <- lookupHeap addr heap   , SymObj (Symbol svar _) <- hobj =     let sname = freshSeededName (varName svar) confs-        svar' = Var sname (varType svar)-        frm_locs' = insertLocalsVal (svar', MemVal addr) frm_locs+        sfun = Var sname (typeOf svar)+        frm_locs' = insertLocalsVal sfun (MemVal addr) frm_locs     in Just (RuleApplyDReturnSym             ,[state { state_stack = stack'-                    , state_code = Evaluate (FunApp svar' args) frm_locs'+                    , state_code = Evaluate (FunApp sfun args) frm_locs'                     , state_names = sname : confs }])    -- State is Val Form

@@ -16,6 +16,7 @@     , Val(..)     , Locals     , Heap+    , HeapRhs(..)     , HeapObj(..)     , Globals     , Code(..)@@ -139,9 +140,15 @@ -- | Heaps map `MemAddr` to `HeapObj`, while keeping track of the last address -- that was allocated. This allows us to consistently allocate fresh addresses -- on the `Heap`.-data Heap = Heap (M.Map MemAddr (Either MemAddr HeapObj)) MemAddr+data Heap = Heap (M.Map MemAddr HeapRhs) MemAddr           deriving (Show, Eq, Read) +-- | When we look up a `Heap`, we get an intermediary `MemAddr` for lookup+-- redirection, or just the `HeapObj` itself.+data HeapRhs = HeapRedir MemAddr+             | HeapObj HeapObj+             deriving (Show, Eq, Read)+ -- | Heap objects. data HeapObj = LitObj Lit              | SymObj Symbol@@ -209,6 +216,10 @@ stackToList :: Stack -> [Frame] stackToList (Stack frames) = frames +-- | `foldr` helper function that takes (A, B) into A -> B type inputs.+foldrPair :: (a -> b -> c -> c) -> (a, b) -> c -> c+foldrPair f (a, b) c = f a b c+ -- | Empty `Locals`. empty_locals :: Locals empty_locals = Locals M.empty@@ -218,12 +229,12 @@ lookupLocals var (Locals lmap) = M.lookup (varName var) lmap  -- | `Locals` insertion.-insertLocalsVal :: (Var, Val) -> Locals -> Locals-insertLocalsVal (k, v) (Locals lmap) = Locals (M.insert (varName k) v lmap)+insertLocalsVal :: Var -> Val -> Locals -> Locals+insertLocalsVal k v (Locals lmap) = Locals (M.insert (varName k) v lmap)  -- | List insertion into `Locals`. insertLocalsVals :: [(Var, Val)] -> Locals -> Locals-insertLocalsVals kvs locals = foldr insertLocalsVal locals kvs+insertLocalsVals kvs locals = foldr (foldrPair insertLocalsVal) locals kvs  -- | `Locals` to key value pairs. localsToList :: Locals -> [(Name, Val)]@@ -235,29 +246,29 @@  -- | `Heap` lookup. lookupHeap :: MemAddr -> Heap -> Maybe HeapObj-lookupHeap addr (Heap hmap prev) = case M.lookup addr hmap of-    Just (Left redir) -> lookupHeap redir (Heap hmap prev)-    Just (Right hobj) -> Just hobj+lookupHeap addr (Heap hmap p) = case M.lookup addr hmap of+    Just (HeapRedir redir) -> lookupHeap redir (Heap hmap p)+    Just (HeapObj hobj) -> Just hobj     Nothing -> Nothing  -- | `Heap` direct insertion at a specific `MemAddr`.-insertHeapObj :: (MemAddr, HeapObj) -> Heap -> Heap-insertHeapObj (k, v) (Heap hmap prev) = Heap (M.insert k (Right v) hmap) prev+insertHeapObj :: MemAddr -> HeapObj -> Heap -> Heap+insertHeapObj k v (Heap hmap p) = Heap (M.insert k (HeapObj v) hmap) p  -- | Insert a list of `HeapObj` at specified `MemAddr` locations. insertHeapObjs :: [(MemAddr, HeapObj)] -> Heap -> Heap-insertHeapObjs kvs heap = foldr insertHeapObj heap kvs+insertHeapObjs kvs heap = foldr (foldrPair insertHeapObj) heap kvs  -- | Insert a redirection `MemAddr` into the `Heap`.-insertHeapRedir :: (MemAddr, MemAddr) -> Heap -> Heap-insertHeapRedir (a, r) (Heap hmap prev) = Heap (M.insert a (Left r) hmap) prev+insertHeapRedir :: MemAddr -> MemAddr -> Heap -> Heap+insertHeapRedir a r (Heap hmap p) = Heap (M.insert a (HeapRedir r) hmap) p  -- | `Heap` allocation. Updates the last `MemAddr` kept in the `Heap`. allocHeapObj :: HeapObj -> Heap -> (Heap, MemAddr)-allocHeapObj hobj (Heap hmap prev) = (heap', addr)+allocHeapObj hobj (Heap hmap p) = (heap', addr)   where-    addr = MemAddr ((memAddrInt prev) + 1)-    heap' = insertHeapObj (addr, hobj) (Heap hmap addr)+    addr = MemAddr ((memAddrInt p) + 1)+    heap' = insertHeapObj addr hobj (Heap hmap addr)  -- | Allocate a list of `HeapObj` in a `Heap`, returning in the same order the -- `MemAddr` at which they have been allocated at.@@ -269,7 +280,7 @@     (heapf, as) = allocHeapObjs hs heap'  -- | `Heap` to key value pairs.-heapToList :: Heap -> [(MemAddr, Either MemAddr HeapObj)]+heapToList :: Heap -> [(MemAddr, HeapRhs)] heapToList (Heap hmap _) = M.toList hmap  -- | Empty `Globals`.@@ -281,14 +292,14 @@ lookupGlobals var (Globals gmap) = M.lookup (varName var) gmap  -- | `Globals` insertion.-insertGlobalsVal :: (Var, Val) -> Globals -> Globals-insertGlobalsVal (k, v) (Globals gmap) = Globals (M.insert (varName k) v gmap)+insertGlobalsVal :: Var -> Val -> Globals -> Globals+insertGlobalsVal k v (Globals gmap) = Globals (M.insert (varName k) v gmap)  -- | Insert a list of `Var` and `Val` pairs into `Globals`. This would -- typically occur for new symbolic variables created from uninterpreted / -- out-of-scope variables during runtime. insertGlobalsVals :: [(Var, Val)] -> Globals -> Globals-insertGlobalsVals kvs globals = foldr insertGlobalsVal globals kvs+insertGlobalsVals kvs globals = foldr (foldrPair insertGlobalsVal) globals kvs  -- | `Globals` to key value pairs. globalsToList :: Globals -> [(Name, Val)]@@ -331,9 +342,9 @@ memAddrType addr heap = do     hobj <- lookupHeap addr heap     case hobj of-        LitObj lit -> Just (litType lit)-        SymObj (Symbol svar _) -> Just (varType svar)-        ConObj dcon _ -> Just (dataConType dcon)-        FunObj ps ex _ -> Just (foldr FunTy (exprType ex) (map varType ps))+        LitObj lit -> Just (typeOf lit)+        SymObj (Symbol svar _) -> Just (typeOf svar)+        ConObj dcon _ -> Just (typeOf dcon)+        FunObj ps expr _ -> Just (foldr FunTy (typeOf expr) (map typeOf ps))         Blackhole -> Just Bottom 

@@ -16,99 +16,103 @@ import qualified Data.List as L import qualified Data.Set as S --- | All `Name`s in a `State`.-allNames :: Program -> [Name]-allNames (Program bindss) = concatMap bindsNames bindss+-- | Nameable typeclass.+class Nameable a where+    allNames :: a -> [Name] --- | `Name`s in a `Binds`.-bindsNames :: Binds -> [Name]-bindsNames (Binds _ kvs) = lhs ++ rhs-  where-    lhs = concatMap (varNames . fst) kvs-    rhs = concatMap (bindRhsNames . snd) kvs+-- | `Program` instance of `Nameable`.+instance Nameable Program where+    allNames (Program bindss) = concatMap allNames bindss --- | A `Var`'s `Name`. Not to be confused with the other function.-varName :: Var -> Name-varName (Var name _) = name+-- | `Binds` instance of `Nameable`+instance Nameable Binds where+    allNames (Binds _ kvs) = lhs ++ rhs+      where+        lhs = concatMap (allNames . fst) kvs+        rhs = concatMap (allNames . snd) kvs --- | `Name`s in a `Var`.-varNames :: Var -> [Name]-varNames (Var name ty) = name : typeNames ty+-- | `Var` instance of `Nameable`+instance Nameable Var where+    allNames (Var name ty) = name : allNames ty --- | `Name`s in a `BindRhs`.-bindRhsNames :: BindRhs -> [Name]-bindRhsNames (FunForm prms expr) = concatMap varNames prms ++ exprNames expr-bindRhsNames (ConForm dcon as) = dataConNames dcon ++ concatMap atomNames as+-- | `BindRhs` instance of `Nameable`+instance Nameable BindRhs where+    allNames (FunForm prms expr) = concatMap allNames prms ++ allNames expr+    allNames (ConForm dcon as) = allNames dcon ++ concatMap allNames as --- | `Name`s in an `Expr`.-exprNames :: Expr -> [Name]-exprNames (Atom atom) = atomNames atom-exprNames (Let binds expr) = exprNames expr ++ bindsNames binds-exprNames (FunApp fun args) = varNames fun ++ concatMap atomNames args-exprNames (PrimApp pfun args) = primFunNames pfun ++ concatMap atomNames args-exprNames (ConApp dcon args) = dataConNames dcon ++ concatMap atomNames args-exprNames (Case expr var alts) = exprNames expr ++ concatMap altNames alts-                                                ++ varNames var+-- | `Expr` instance of `Nameable`+instance Nameable Expr where+    allNames (Atom atom) = allNames atom+    allNames (Let binds expr) = allNames expr ++ allNames binds+    allNames (FunApp fun args) = allNames fun ++ concatMap allNames args+    allNames (PrimApp pfun args) = allNames pfun ++ concatMap allNames args+    allNames (ConApp dcon args) = allNames dcon ++ concatMap allNames args+    allNames (Case expr var alts) = allNames expr ++ concatMap allNames alts+                                                  ++ allNames var --- | `Name`s in an `Atom`.-atomNames :: Atom -> [Name]-atomNames (LitAtom _) = []-atomNames (VarAtom var) = varNames var+-- | `Atom` instance of `Nameable`+instance Nameable Atom where+    allNames (LitAtom _) = []+    allNames (VarAtom var) = allNames var --- | `Name`s in a `PrimFun`.-primFunNames :: PrimFun -> [Name]-primFunNames (PrimFun name ty) = name : typeNames ty+-- | `PrimFun` instance of `Nameable`+instance Nameable PrimFun where+    allNames (PrimFun name ty) = name : allNames ty --- | `Name`s in a `DataCon`.-dataConNames :: DataCon -> [Name]-dataConNames (DataCon name ty tys) = name : concatMap typeNames (ty : tys)+-- | `DataCon` instance of `Nameable`+instance Nameable DataCon where+    allNames (DataCon name ty tys) = name : concatMap allNames (ty : tys) --- | `Name`s in an `Alt`.-altNames :: Alt -> [Name]-altNames (Alt acon expr) = altConNames acon ++ exprNames expr+-- | `Alt` instance of `Nameable`+instance Nameable Alt where+    allNames (Alt acon expr) = allNames acon ++ allNames expr --- | `Name`s in an `AltCon`.-altConNames :: AltCon -> [Name]-altConNames (DataAlt dcon ps) = dataConNames dcon ++ concatMap varNames ps-altConNames _ = []+-- | `AltCon` instance of `Nameable`+instance Nameable AltCon where+    allNames (DataAlt dcon ps) = allNames dcon ++ concatMap allNames ps+    allNames _ = [] --- | `Name`s in a `Type`.-typeNames :: Type -> [Name]-typeNames (TyVarTy var) = varNames var-typeNames (AppTy ty1 ty2) = typeNames ty1 ++ typeNames ty2-typeNames (ForAllTy bndr ty) = typeNames ty ++ tyBinderNames bndr-typeNames (FunTy ty1 ty2) = typeNames ty1 ++ typeNames ty2-typeNames (TyConApp tycon ty) = tyConNames tycon ++ concatMap typeNames ty-typeNames (CoercionTy coer) = coercionNames coer-typeNames (CastTy ty coer) = typeNames ty ++ coercionNames coer-typeNames (LitTy _) = []-typeNames (Bottom) = []+-- | `Type` instance of `Nameable`+instance Nameable Type where+    allNames (TyVarTy var) = allNames var+    allNames (AppTy ty1 ty2) = allNames ty1 ++ allNames ty2+    allNames (ForAllTy bndr ty) = allNames ty ++ allNames bndr+    allNames (FunTy ty1 ty2) = allNames ty1 ++ allNames ty2+    allNames (TyConApp tycon ty) = allNames tycon ++ concatMap allNames ty+    allNames (CoercionTy coer) = allNames coer+    allNames (CastTy ty coer) = allNames ty ++ allNames coer+    allNames (LitTy _) = []+    allNames (Bottom) = [] --- | `Name`s in a `TyBinder`.-tyBinderNames :: TyBinder -> [Name]-tyBinderNames (AnonTyBndr) = []-tyBinderNames (NamedTyBndr name) = [name]+-- | `TyBinder` instance of `Nameable`+instance Nameable TyBinder where+    allNames (AnonTyBndr) = []+    allNames (NamedTyBndr name) = [name] --- | `Name`s in a `TyCon`.-tyConNames :: TyCon -> [Name]-tyConNames (FamilyTyCon name params) = name : params-tyConNames (SynonymTyCon name params) = name : params-tyConNames (AlgTyCon name params rhs) = name : params ++ algTyRhsNames rhs-tyConNames (FunTyCon name bndrs) = name : concatMap tyBinderNames bndrs-tyConNames (PrimTyCon name bndrs) = name : concatMap tyBinderNames bndrs-tyConNames (Promoted name bndrs dcon) = name : concatMap tyBinderNames bndrs-                                            ++ dataConNames dcon+-- | `TyCon` instance of `Nameable`+instance Nameable TyCon where+    allNames (FamilyTyCon name params) = name : params+    allNames (SynonymTyCon name params) = name : params+    allNames (AlgTyCon name params rhs) = name : params ++ allNames rhs+    allNames (FunTyCon name bndrs) = name : concatMap allNames bndrs+    allNames (PrimTyCon name bndrs) = name : concatMap allNames bndrs+    allNames (Promoted name bndrs dcon) = name : concatMap allNames bndrs+                                              ++ allNames dcon --- | `Name`s in a `Coercion`.-coercionNames :: Coercion -> [Name]-coercionNames (Coercion ty1 ty2) = typeNames ty1 ++ typeNames ty2+-- | `Coercion` instance of `Nameable`+instance Nameable Coercion where+    allNames (Coercion ty1 ty2) = allNames ty1 ++ allNames ty2 --- | `Name`s in a `AlgTyRhs`.-algTyRhsNames :: AlgTyRhs -> [Name]-algTyRhsNames (AbstractTyCon _) = []-algTyRhsNames (DataTyCon names) = names-algTyRhsNames (TupleTyCon name) = [name]-algTyRhsNames (NewTyCon name) = [name]+-- | `AlgTyRhs` instance of `Nameable`+instance Nameable AlgTyRhs where+    allNames (AbstractTyCon _) = []+    allNames (DataTyCon names) = names+    allNames (TupleTyCon name) = [name]+    allNames (NewTyCon name) = [name]++-- | A `Var`'s `Name`. Not to be confused with the other function.+varName :: Var -> Name+varName (Var name _) = name  -- | A `Name`'s occurrence string. nameOccStr :: Name -> String

@@ -5,48 +5,52 @@  import SSTG.Core.Language.Syntax --- | Variable type.-varType :: Var -> Type-varType (Var _ ty) = ty+-- | Typeable typeclass.+class Typeable a where+    typeOf :: a -> Type --- | Literal type.-litType :: Lit -> Type-litType (MachChar _ ty) = ty-litType (MachStr _ ty) = ty-litType (MachInt _ ty) = ty-litType (MachWord _ ty) = ty-litType (MachFloat _ ty) = ty-litType (MachDouble _ ty) = ty-litType (MachLabel _ _ ty) = ty-litType (MachNullAddr ty) = ty-litType (BlankAddr) = Bottom-litType (AddrLit _) = Bottom-litType (LitEval pf args) = foldl AppTy (primFunType pf) (map litType args)+-- | `Var` instance of `Typeable`.+instance Typeable Var where+    typeOf (Var _ ty) = ty --- | Atom type.-atomType :: Atom -> Type-atomType (LitAtom lit) = litType lit-atomType (VarAtom var) = varType var+-- | `Lit` instance of `Typeable`.+instance Typeable Lit where+    typeOf (MachChar _ ty) = ty+    typeOf (MachStr _ ty) = ty+    typeOf (MachInt _ ty) = ty+    typeOf (MachWord _ ty) = ty+    typeOf (MachFloat _ ty) = ty+    typeOf (MachDouble _ ty) = ty+    typeOf (MachLabel _ _ ty) = ty+    typeOf (MachNullAddr ty) = ty+    typeOf (BlankAddr) = Bottom+    typeOf (AddrLit _) = Bottom+    typeOf (LitEval pfun args) = foldl AppTy (typeOf pfun) (map typeOf args) --- | Primitive function type.-primFunType :: PrimFun -> Type-primFunType (PrimFun _ ty) = ty+-- | `Atom` instance of `Typeable`.+instance Typeable Atom where+    typeOf (LitAtom lit) = typeOf lit+    typeOf (VarAtom var) = typeOf var --- | Data constructor type denoted as a function.-dataConType :: DataCon -> Type-dataConType (DataCon _ ty tys) = foldr FunTy ty tys+-- | `PrimFun` instance of `Typeable`.+instance Typeable PrimFun where+    typeOf (PrimFun _ ty) = ty --- | Alt type-altType :: Alt -> Type-altType (Alt _ expr) = exprType expr+-- | `DataCon` instance of `Typeable`.+instance Typeable DataCon where+    typeOf (DataCon _ ty tys) = foldr FunTy ty tys --- | I wonder what this could possibly be?-exprType :: Expr -> Type-exprType (Atom atom) = atomType atom-exprType (PrimApp pf args) = foldl AppTy (primFunType pf) (map atomType args)-exprType (ConApp dc args) = foldl AppTy (dataConType dc) (map atomType args)-exprType (FunApp fun args) = foldl AppTy (varType fun) (map atomType args)-exprType (Let _ expr) = exprType expr-exprType (Case _ _ (alt:_)) = altType alt-exprType _ = Bottom+-- | `Alt` instance of `Typeable`.+instance Typeable Alt where+    typeOf (Alt _ expr) = typeOf expr++-- | `Expr` instance of `Typeable`.+instance Typeable Expr where+    typeOf (Atom atom) = typeOf atom+    typeOf (PrimApp pfun args) = foldl AppTy (typeOf pfun) (map typeOf args)+    typeOf (ConApp dcon args) = foldl AppTy (typeOf dcon) (map typeOf args)+    typeOf (FunApp fun args) = foldl AppTy (typeOf fun) (map typeOf args)+    typeOf (Let _ expr) = typeOf expr+    typeOf (Case _ _ (alt:_)) = typeOf alt+    typeOf _ = Bottom 

@@ -201,8 +201,8 @@ pprHeapStr heap = injNewLine acc_strs   where     hlist = heapToList heap-    addr_redirs = [(addr, r) | (addr, Left r) <- hlist]-    addr_hobjs = [(addr, o) | (addr, Right o) <- hlist]+    addr_redirs = [(addr, r) | (addr, HeapRedir r) <- hlist]+    addr_hobjs = [(addr, o) | (addr, HeapObj o) <- hlist]     addr_redir_strs = map pprMemRedirStr addr_redirs     addr_hobj_strs = map pprMemHeapObjStr addr_hobjs     acc_strs = addr_redir_strs ++ addr_hobj_strs