diff --git a/SSTG.cabal b/SSTG.cabal
--- a/SSTG.cabal
+++ b/SSTG.cabal
@@ -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
diff --git a/src/SSTG/Core/Execution/Engine.hs b/src/SSTG/Core/Execution/Engine.hs
--- a/src/SSTG/Core/Execution/Engine.hs
+++ b/src/SSTG/Core/Execution/Engine.hs
@@ -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
diff --git a/src/SSTG/Core/Execution/Rules.hs b/src/SSTG/Core/Execution/Rules.hs
--- a/src/SSTG/Core/Execution/Rules.hs
+++ b/src/SSTG/Core/Execution/Rules.hs
@@ -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
diff --git a/src/SSTG/Core/Execution/Support.hs b/src/SSTG/Core/Execution/Support.hs
--- a/src/SSTG/Core/Execution/Support.hs
+++ b/src/SSTG/Core/Execution/Support.hs
@@ -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
 
diff --git a/src/SSTG/Core/Language/Naming.hs b/src/SSTG/Core/Language/Naming.hs
--- a/src/SSTG/Core/Language/Naming.hs
+++ b/src/SSTG/Core/Language/Naming.hs
@@ -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
diff --git a/src/SSTG/Core/Language/Typing.hs b/src/SSTG/Core/Language/Typing.hs
--- a/src/SSTG/Core/Language/Typing.hs
+++ b/src/SSTG/Core/Language/Typing.hs
@@ -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
 
diff --git a/src/SSTG/Utils/Printing.hs b/src/SSTG/Utils/Printing.hs
--- a/src/SSTG/Utils/Printing.hs
+++ b/src/SSTG/Utils/Printing.hs
@@ -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