diff --git a/DDC/Core/Annot/AnT.hs b/DDC/Core/Annot/AnT.hs
deleted file mode 100644
--- a/DDC/Core/Annot/AnT.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-
-module DDC.Core.Annot.AnT
-        (AnT (..))
-where
-import DDC.Type.Exp
-import DDC.Base.Pretty
-import Control.DeepSeq
-import Data.Typeable
-
-
--- Annot ----------------------------------------------------------------------
--- | The type checker for witnesses adds this annotation to every node in the,
---   giving the type of each component of the witness.
----
---   NOTE: We want to leave the components lazy so that the checker
---         doesn't actualy need to produce the type components if they're
---         not needed.
-data AnT a n
-        = AnT
-        { annotType     :: (Type  n)
-        , annotTail     :: a }
-        deriving (Show, Typeable)
-
-
-instance (NFData a, NFData n) => NFData (AnT a n) where
- rnf !an
-        =     rnf (annotType    an)
-        `seq` rnf (annotTail    an)
-
-
-instance Pretty (AnT a n) where
- ppr _ = text "AnT"        
-
-
-
diff --git a/DDC/Core/Annot/AnTEC.hs b/DDC/Core/Annot/AnTEC.hs
deleted file mode 100644
--- a/DDC/Core/Annot/AnTEC.hs
+++ /dev/null
@@ -1,50 +0,0 @@
-
-module DDC.Core.Annot.AnTEC
-        ( AnTEC (..)
-        , fromAnT)
-where
-import DDC.Type.Compounds
-import DDC.Type.Exp
-import DDC.Base.Pretty
-import Control.DeepSeq
-import Data.Typeable
-import DDC.Core.Annot.AnT       (AnT)
-import qualified DDC.Core.Annot.AnT as AnT
-
-
--- Annot ----------------------------------------------------------------------
--- | The type checker adds this annotation to every node in the AST, 
---   giving its type, effect and closure.
----
---   NOTE: We want to leave the components lazy so that the checker
---         doesn't actualy need to produce the type components if they're
---         not needed.
-data AnTEC a n
-        = AnTEC
-        { annotType     :: (Type    n)
-        , annotEffect   :: (Effect  n)
-        , annotClosure  :: (Closure n)
-        , annotTail     :: a }
-        deriving (Show, Typeable)
-
-
--- | Promote an `AnT` to an `AnTEC` by filling in the effect and closure
---   portions with bottoms.
-fromAnT :: AnT a n -> AnTEC a n
-fromAnT (AnT.AnT t a)
-   =    (AnTEC t (tBot kEffect) (tBot kClosure) a)
-
-
-instance (NFData a, NFData n) => NFData (AnTEC a n) where
- rnf !an
-        =     rnf (annotType    an)
-        `seq` rnf (annotEffect  an)
-        `seq` rnf (annotClosure an)
-        `seq` rnf (annotTail    an)
-
-
-instance Pretty (AnTEC a n) where
- ppr _ = text "AnTEC"        
-
-
-
diff --git a/DDC/Core/Call.hs b/DDC/Core/Call.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Call.hs
@@ -0,0 +1,435 @@
+
+-- | Call patterns.
+--
+--   A call pattern describes the sequence of objects that are eliminated
+--   by some object when we apply it, and before it starts constructing
+--   new values. 
+--
+-- @
+-- Constructor (+ve)             Eliminator (-ve)
+--  /\x.  (type   abstraction)    \@'    (type   application)
+--   \x.  (object abstraction)    \@     (object application) 
+--  box   (suspend evaluation)   run   (commence evaluation)
+-- @
+--   
+module DDC.Core.Call 
+        ( -- * Call constructors
+          Cons (..)
+        , isConsType
+        , isConsValue
+        , isConsBox
+        , takeCallConsFromExp
+        , takeCallConsFromType
+        , splitStdCallCons
+        , takeStdCallConsFromTypeArity
+
+          -- * Call eliminators
+        , Elim (..)
+        , isElimType
+        , isElimValue
+        , isElimRun
+        , takeCallElim
+        , applyElim
+        , splitStdCallElims
+
+          -- * Matching
+        , elimForCons
+        , dischargeConsWithElims
+        , dischargeTypeWithElims)
+where
+import DDC.Core.Exp.Annot
+import DDC.Type.Transform.SubstituteT
+
+
+-----------------------------------------------------------------------------
+-- | One component of the call pattern of a super.
+--   This is the "outer wrapper" of the computation,
+-- 
+--   With @/\(a : k). \(x : t). box (x + 1)@ the call pattern consists of
+--   the two lambdas and the box. These three things need to be eliminated
+--   before we can construct any new values.
+--
+data Cons n
+        = -- | A type  lambda that needs a type of this kind.
+          ConsType    (Bind n)
+
+          -- | A value lambda that needs a value of this type.
+        | ConsValue   (Type n)
+
+          -- | A suspended expression that needs to be run.
+        | ConsBox
+        deriving (Show)
+
+
+-- | Check if this is an `ConsType`.
+isConsType :: Cons n -> Bool
+isConsType cc
+ = case cc of
+        ConsType{}      -> True
+        _               -> False
+
+
+-- | Check if this is an `ElimType`.
+isConsValue :: Cons n -> Bool
+isConsValue cc
+ = case cc of
+        ConsValue{}     -> True
+        _               -> False
+
+
+-- | Check if this is an `ElimType`.
+isConsBox :: Cons n -> Bool
+isConsBox cc
+ = case cc of
+        ConsBox{}       -> True
+        _               -> False
+
+
+-- | Get the call pattern of an expression.
+takeCallConsFromExp :: Exp a n -> [Cons n]
+takeCallConsFromExp xx
+ = case xx of
+        XLAM _ b x         
+         ->     ConsType  b : takeCallConsFromExp x
+
+        XLam _ b x         
+         -> let t       = typeOfBind b
+            in  ConsValue t : takeCallConsFromExp x
+
+        XCast _ CastBox x
+         ->     ConsBox     : takeCallConsFromExp x
+
+        _ -> []
+
+
+-- | Infer the call pattern of an expression from its type.
+--   If the type has a function constructor then we assume there
+--   is a corresponding lambda abstraction in the expression, and so on.
+takeCallConsFromType :: Type n -> [Cons n]
+takeCallConsFromType tt
+        | TForall bParam tBody   <- tt
+        = ConsType  bParam : takeCallConsFromType tBody
+
+        | Just (tParam, tResult) <- takeTFun tt
+        = ConsValue tParam : takeCallConsFromType tResult
+
+        | Just (_, tResult)      <- takeTSusp tt
+        = ConsBox          : takeCallConsFromType tResult
+
+        | otherwise
+        = []
+
+
+-- | Like `splitStdCallElim`, but for the constructor side.
+--
+splitStdCallCons
+        :: [Cons n]
+        -> Maybe ([Cons n], [Cons n], [Cons n])
+
+splitStdCallCons cs
+ = eatTypes [] cs
+ where
+        eatTypes  accTs (e@ConsType{} : es)
+         = eatTypes (e : accTs) es
+
+        eatTypes  accTs es
+         = eatValues (reverse accTs) [] es
+
+        eatValues accTs accVs (e@ConsValue{} : es)
+         = eatValues accTs (e : accVs) es
+
+        eatValues accTs accVs es
+         = eatRuns   accTs (reverse accVs) [] es
+
+        eatRuns  accTs accVs accRs (e@ConsBox{} : es)
+         = eatRuns   accTs accVs (e : accRs) es
+
+        eatRuns  accTs accVs accRs []
+         = Just (accTs, accVs, reverse accRs)
+
+        eatRuns  _accTs _accVs _accRs _
+         = Nothing
+
+
+-- | Given the type of a super, and the number of type parameters,
+--   value parameters and boxings, produce the corresponding list
+--   of call constructors.
+--
+--   Example:
+--
+-- @
+--    takeStdCallConsFromType 
+--       [| forall (a : k1) (b : k2). a -> b -> S e b |] 
+--       2 2 1
+--    => [ ConsType  [|k1|], ConsType  [|k2|]
+--       , ConsValue [|a\],  ConsValue [|b|]
+--       , ConsBox ]
+-- @
+--
+--   When we're considering the parts of the type, if the given arity
+--   does not match what is in the type then `Nothing`.
+--
+takeStdCallConsFromTypeArity
+        :: Type n       -- ^ Type of super
+        -> Int          -- ^ Number of type parameters.
+        -> Int          -- ^ Number of value parameters.
+        -> Int          -- ^ Number of boxings.
+        -> Maybe [Cons n]
+
+takeStdCallConsFromTypeArity tt0 nTypes0 nValues0 nBoxes0
+ = eatTypes [] tt0 nTypes0
+ where
+        -- Consider type parameters.
+        eatTypes !accTs !tt !nTypes
+
+         -- The arity information tells us to expect a type parameter.
+         | nTypes  > 0
+         = case tt of
+            -- The super type matches.
+            TForall b tBody
+             -> eatTypes (ConsType b : accTs) tBody (nTypes - 1)
+
+            -- The super type does not match the arity information.
+            _ -> Nothing
+
+         -- No more type parameters expected, so consider the value parameters.
+         | otherwise
+         = eatValues (reverse accTs) [] tt nValues0
+
+
+        -- Consider value parameters.
+        eatValues !accTs !accVs !tt !nValues
+
+         -- The arity information tells us to expect a value parameter.
+         | nValues > 0
+         = case takeTFun tt of
+            -- The super type matches.
+            Just (t1, t2) 
+              -> eatValues accTs (ConsValue t1 : accVs) t2 (nValues - 1)
+
+            -- The super type does not match the arity information.
+            _ -> Nothing
+
+         -- No more value parameters expect, so consider the boxes.
+         | otherwise
+         = eatBoxes accTs (reverse accVs) [] tt nBoxes0
+
+
+        -- Consider boxes.
+        eatBoxes !accTs !accVs !accBs tt nBoxes
+
+         -- The arity information tells us to expect a boxing.
+         | nBoxes > 0
+         = case takeTSusp tt of
+            -- The super type matches.
+            Just (_eff, tBody)
+              -> eatBoxes accTs accVs (ConsBox : accBs) tBody (nBoxes - 1)
+
+            -- The super type does not match the arity information.
+            _ -> Nothing
+
+         -- No more boxings to expect, so we're done.
+         | otherwise
+         = return (accTs ++ accVs ++ reverse accBs)
+
+
+-------------------------------------------------------------------------------
+-- | One component of a super call.
+data Elim a n
+        = -- | Give a type to a type lambda.
+          ElimType    a a (Type n)
+
+          -- | Give a value to a value lambda.
+        | ElimValue   a (Exp a n)
+
+          -- | Run a suspended computation.
+        | ElimRun     a
+        deriving (Show)
+
+
+-- | Check if this is an `ElimType`.
+isElimType :: Elim a n -> Bool
+isElimType ee
+ = case ee of
+        ElimType{}      -> True
+        _               -> False
+
+
+-- | Check if this is an `ElimType`.
+isElimValue :: Elim a n -> Bool
+isElimValue ee
+ = case ee of
+        ElimValue{}     -> True
+        _               -> False
+
+
+-- | Check if this is an `ElimType`.
+isElimRun :: Elim a n -> Bool
+isElimRun ee
+ = case ee of
+        ElimRun{}       -> True
+        _               -> False
+
+
+-- | Apply an eliminator to an expression.
+applyElim :: Exp a n -> Elim a n -> Exp a n
+applyElim xx e
+ = case e of
+        ElimType  a at t -> XApp a xx (XType at t)
+        ElimValue a x    -> XApp a xx x
+        ElimRun   a      -> XCast a CastRun xx
+
+
+-- | Split the application of some object into the object being
+--   applied and its eliminators.
+takeCallElim :: Exp a n -> (Exp a n, [Elim a n])
+takeCallElim xx
+ = case xx of
+        XApp a x1 (XType at t2)
+         -> let (xF, xArgs)     = takeCallElim x1
+            in  (xF, xArgs ++ [ElimType a at t2])
+
+        XApp a x1 x2            
+         -> let (xF, xArgs)     = takeCallElim x1
+            in  (xF, xArgs ++ [ElimValue a x2])
+
+        XCast a CastRun x1
+         -> let (xF, xArgs)     = takeCallElim x1
+            in  (xF, xArgs ++ [ElimRun a])
+
+        _ -> (xx, [])
+
+
+-- | Group eliminators into sets for a standard call.
+--
+--   The standard call sequence is a list of type arguments, followed
+--   by some objects, and optionally running the result suspension.
+--
+--   @run f [T1] [T2] x1 x2@
+--
+--   If 'f' is a super, and this is a saturating call then the super header
+--   will look like the following:
+--
+--   @f = (/\t1. /\t2. \v1. \v2. box. body)@
+
+--   If the eliminators are not in the standard call sequence then `Nothing`.
+--
+splitStdCallElims 
+        :: [Elim a n] 
+        -> Maybe ([Elim a n], [Elim a n], [Elim a n])
+
+splitStdCallElims ee
+ = eatTypes [] ee
+ where
+        eatTypes  accTs (e@ElimType{} : es)
+         = eatTypes (e : accTs) es
+
+        eatTypes  accTs es
+         = eatValues (reverse accTs) [] es
+
+        eatValues accTs accVs (e@ElimValue{} : es)
+         = eatValues accTs (e : accVs) es
+
+        eatValues accTs accVs es
+         = eatRuns   accTs (reverse accVs) [] es
+
+        eatRuns  accTs accVs accRs (e@ElimRun{} : es)
+         = eatRuns   accTs accVs (e : accRs) es
+
+        eatRuns  accTs accVs accRs []
+         = Just (accTs, accVs, reverse accRs)
+
+        eatRuns  _accTs _accVs _accRs _
+         = Nothing
+
+
+-------------------------------------------------------------------------------
+-- | Check if this an eliminator for the given constructor.
+--   This only checks the general form of the eliminator 
+--   and constructor, not the exact types or kinds.
+elimForCons :: Elim a n -> Cons n -> Bool
+elimForCons e c
+ = case (e, c) of
+        (ElimType{},  ConsType{})       -> True
+        (ElimValue{}, ConsValue{})      -> True
+        (ElimRun{},   ConsBox{})        -> True
+        _                               -> False
+
+
+-- | Given lists of constructors and eliminators, check if the
+--   eliminators satisfy the constructors, and return any remaining
+--   unmatching constructors and eliminators.
+--
+--   We assume that the application is well typed and that applying
+--   the given eliminators will not cause variable capture.
+---
+--   ISSUE #347: Avoid name capture in dischargeConsWithElims
+--   This process doesn't avoid name capture by ConsTypes earlier
+--   in the list, but it's only called from the Curry transform
+--   where there shouldn't be any shadowed type binders.
+--
+dischargeConsWithElims
+        :: Ord n
+        => [Cons n] 
+        -> [Elim a n] 
+        -> ([Cons n], [Elim a n])
+
+dischargeConsWithElims (c : cs) (e : es)
+ = case (c, e) of
+        (ConsType  b1, ElimType  _ _ t2)
+          -> dischargeConsWithElims 
+                (map (instantiateConsT b1 t2) cs) 
+                es
+
+        (ConsValue _t1, ElimValue _ _x2)
+          -> dischargeConsWithElims cs es
+
+        (ConsBox,       ElimRun _)
+          -> dischargeConsWithElims cs es
+
+        _ -> (c : cs, e : es)
+
+dischargeConsWithElims cs es
+ = (cs, es)
+
+
+instantiateConsT :: Ord n => Bind n -> Type n -> Cons n -> Cons n
+instantiateConsT b t cc
+ = case cc of
+        ConsType{}      -> cc
+        ConsValue t'    -> ConsValue (substituteT b t t')
+        ConsBox{}       -> cc
+
+
+-- | Given a type of a function and eliminators, discharge
+--   foralls, abstractions and boxes to get the result type
+--   of performing the application.
+-- 
+--   We assume that the application is well typed.
+--
+dischargeTypeWithElims
+        :: Ord n
+        => Type n
+        -> [Elim a n]
+        -> Maybe (Type n)
+
+dischargeTypeWithElims tt (ElimType  _ _ tArg : es)
+        | TForall b tBody         <- tt
+        = dischargeTypeWithElims 
+                (substituteT b tArg tBody) 
+                es
+
+dischargeTypeWithElims tt (ElimValue _ _xArg  : es)
+        | Just (_tParam, tResult) <- takeTFun tt
+        = dischargeTypeWithElims tResult es
+
+dischargeTypeWithElims tt (ElimRun _ : es)
+        | Just (_, tBody)         <- takeTSusp tt
+        = dischargeTypeWithElims tBody es
+ 
+dischargeTypeWithElims tt []
+        = Just tt
+
+dischargeTypeWithElims _tt _es
+        = Nothing
+
diff --git a/DDC/Core/Check.hs b/DDC/Core/Check.hs
--- a/DDC/Core/Check.hs
+++ b/DDC/Core/Check.hs
@@ -16,7 +16,8 @@
         , checkModule
         
           -- * Checking Expressions
-        , Mode       (..)
+        , Mode   (..)
+        , Demand (..)
         , checkExp,     typeOfExp
 
           -- * Checking Witnesses
diff --git a/DDC/Core/Check/Base.hs b/DDC/Core/Check/Base.hs
--- a/DDC/Core/Check/Base.hs
+++ b/DDC/Core/Check/Base.hs
@@ -7,6 +7,8 @@
         , CheckM
         , newExists
         , newPos
+        , applyContext
+        , applySolved
 
         , CheckTrace (..)
         , ctrace
@@ -20,10 +22,8 @@
         , Set
         , module DDC.Core.Check.Error
         , module DDC.Core.Collect
-        , module DDC.Core.Predicates
-        , module DDC.Core.Compounds
         , module DDC.Core.Pretty
-        , module DDC.Core.Exp
+        , module DDC.Core.Exp.Annot
         , module DDC.Type.Check.Context
         , module DDC.Type.DataDef
         , module DDC.Type.Equiv
@@ -38,10 +38,8 @@
 where
 import DDC.Core.Check.Error
 import DDC.Core.Collect
-import DDC.Core.Predicates
-import DDC.Core.Compounds
 import DDC.Core.Pretty
-import DDC.Core.Exp
+import DDC.Core.Exp.Annot
 import DDC.Type.Check.Context
 import DDC.Type.Check                           (Config (..), configOfProfile)
 import DDC.Type.Env                             (KindEnv, TypeEnv)
@@ -58,13 +56,15 @@
 import Data.Monoid                              hiding ((<>))
 import Data.Maybe
 import Data.Set                                 (Set)
+import qualified Data.Set                       as Set
 import qualified DDC.Type.Check                 as T
 import qualified DDC.Control.Monad.Check        as G
+import Prelude                                  hiding ((<$>))
 
 
--- | Type checker monad. 
+-- | Type checker monad.
 --   Used to manage type errors.
-type CheckM a n   
+type CheckM a n
         = G.CheckM (CheckTrace, Int, Int) (Error a n)
 
 -- | Allocate a new existential.
@@ -83,9 +83,28 @@
         return  (Pos pos)
 
 
+-- | Apply the checker context to a type.
+applyContext :: Ord n => Context n -> Type n -> CheckM a n (Type n)
+applyContext ctx tt
+ = case applyContextEither ctx Set.empty tt of
+        Left  (tExt, tBind)       
+                -> throw $ ErrorType $ T.ErrorInfinite tExt tBind
+        Right t -> return t
+
+
+-- | Substitute solved constraints into a type.
+applySolved :: Ord n => Context n -> Type n -> CheckM a n (Type n)
+applySolved ctx tt
+ = case applySolvedEither ctx Set.empty tt of
+        Left  (tExt, tBind)
+                -> throw $ ErrorType $ T.ErrorInfinite tExt tBind
+        Right t -> return t
+
+
+
 -- CheckTrace -----------------------------------------------------------------
 -- | Human readable trace of the type checker.
-data CheckTrace 
+data CheckTrace
         = CheckTrace
         { checkTraceDoc :: Doc }
 
@@ -94,9 +113,9 @@
 
 instance Monoid CheckTrace where
  mempty = CheckTrace empty
- 
+
  mappend ct1 ct2
-        = CheckTrace 
+        = CheckTrace
         { checkTraceDoc = checkTraceDoc ct1 <> checkTraceDoc ct2 }
 
 
@@ -122,15 +141,15 @@
         -> CheckM a n (Bind n, Type n, Context n)
 
 checkBindM config kenv ctx uni bb mode
- = do   (t', k, ctx')   <- checkTypeM config kenv ctx uni 
+ = do   (t', k, ctx')   <- checkTypeM config kenv ctx uni
                                 (typeOfBind bb) mode
         return (replaceTypeOfBind t' bb, k, ctx')
 
 
 -- Type -----------------------------------------------------------------------
 -- | Check a type in the exp checking monad, returning its kind.
-checkTypeM 
-        :: (Ord n, Show n, Pretty n) 
+checkTypeM
+        :: (Ord n, Show n, Pretty n)
         => Config n             -- ^ Checker configuration.
         -> KindEnv n            -- ^ Global kind environment.
         -> Context n            -- ^ Local context.
@@ -140,24 +159,24 @@
         -> CheckM a n (Type n, Kind n, Context n)
 
 checkTypeM config kenv ctx uni tt mode
- = do   
-        -- Run the inner type/kind checker computation, 
-        -- giving it our current values for the existential and position 
+ = do
+        -- Run the inner type/kind checker computation,
+        -- giving it our current values for the existential and position
         -- generators.
         (tr, ix, pos)   <- G.get
-        
+
         let ((ix', pos'), result)
                 = G.runCheck (ix, pos)
                 $ T.checkTypeM config kenv ctx uni tt mode
-        
+
         G.put (tr, ix', pos')
-        
-        -- If the type/kind checker returns an error then wrap it 
+
+        -- If the type/kind checker returns an error then wrap it
         -- so we can throw it from our exp/type checker.
         case result of
-         Left err               
+         Left err
           -> throw $ ErrorType err
 
-         Right (t, k, ctx')     
+         Right (t, k, ctx')
           -> return (t, k, ctx')
 
diff --git a/DDC/Core/Check/Error.hs b/DDC/Core/Check/Error.hs
--- a/DDC/Core/Check/Error.hs
+++ b/DDC/Core/Check/Error.hs
@@ -19,7 +19,6 @@
         | ErrorData
         { errorData             :: T.ErrorData n }
 
-
         -- Module -----------------------------------------
         -- | Exported value is undefined.
         | ErrorExportUndefined
@@ -40,6 +39,10 @@
         | ErrorImportDuplicate
         { errorName             :: n }
 
+        -- | An imported capability that does not have kind Effect.
+        | ErrorImportCapNotEffect
+        { errorName             :: n }
+
         -- | An imported value that doesn't have kind Data.
         | ErrorImportValueNotData
         { errorName             :: n }
@@ -58,7 +61,7 @@
         -- | An undefined type variable.
         | ErrorUndefinedVar
         { errorAnnot            :: a
-        , errorBound            :: Bound n 
+        , errorBound            :: Bound n
         , errorUniverse         :: Universe }
 
 
@@ -81,7 +84,7 @@
         | ErrorAppNotFun
         { errorAnnot            :: a
         , errorChecking         :: Exp a n
-        , errorNotFunType       :: Type n } 
+        , errorNotFunType       :: Type n }
 
         -- | Cannot infer type of polymorphic expression.
         | ErrorAppCannotInferPolymorphic
@@ -93,10 +96,10 @@
         --   already in the environment.
         | ErrorLamShadow
         { errorAnnot            :: a
-        , errorChecking         :: Exp a n 
+        , errorChecking         :: Exp a n
         , errorBind             :: Bind n }
 
-        -- | An abstraction where the body has a visible side effect that 
+        -- | An abstraction where the body has a visible side effect that
         --   is not supported by the current language fragment.
         | ErrorLamNotPure
         { errorAnnot            :: a
@@ -104,19 +107,11 @@
         , errorUniverse         :: Universe
         , errorEffect           :: Effect n }
 
-        -- | An abstraction where the body has a visible closure that 
-        --   is not supported by the current language fragment.
-        | ErrorLamNotEmpty
-        { errorAnnot            :: a
-        , errorChecking         :: Exp a n
-        , errorUniverse         :: Universe
-        , errorClosure          :: Closure n }
-
         -- | A value function where the parameter does not have data
         --   or witness kind.
         | ErrorLamBindBadKind
         { errorAnnot            :: a
-        , errorChecking         :: Exp a n 
+        , errorChecking         :: Exp a n
         , errorType             :: Type n
         , errorKind             :: Kind n }
 
@@ -133,7 +128,7 @@
         { errorAnnot            :: a
         , errorChecking         :: Exp a n
         , errorBind             :: Bind n }
-        
+
         -- | A type abstraction without a kind annotation on the parameter.
         | ErrorLAMParamUnannotated
         { errorAnnot            :: a
@@ -176,7 +171,7 @@
         --   a lambda abstraction.
         | ErrorLetrecBindingNotLambda
         { errorAnnot            :: a
-        , errorChecking         :: Exp a n 
+        , errorChecking         :: Exp a n
         , errorExp              :: Exp a n }
 
         -- | A recursive let-binding with a missing type annotation.
@@ -217,7 +212,7 @@
         , errorBinds            :: [Bind n]
         , errorType             :: Type n }
 
-        -- | A letregion-expression that tried to create a witness with an 
+        -- | A letregion-expression that tried to create a witness with an
         --   invalid type.
         | ErrorLetRegionWitnessInvalid
         { errorAnnot            :: a
@@ -240,23 +235,6 @@
         , errorBindWitness      :: Bind  n }
 
 
-        -- Withregion -------------------------------------
-        -- | A withregion-expression where the handle does not have region kind.
-        | ErrorWithRegionNotRegion
-        { errorAnnot            :: a
-        , errorChecking         :: Exp a n
-        , errorBound            :: Bound n
-        , errorKind             :: Kind n }
-
-        -- | A letregion-expression where some of the the bound region variables
-        --   are free in the type of the body.
-        | ErrorWithRegionFree
-        { errorAnnot            :: a
-        , errorChecking         :: Exp a n
-        , errorBound            :: Bound n
-        , errorType             :: Type n }
-
-
         -- Witnesses --------------------------------------
         -- | A witness application where the argument type does not match
         --   the parameter type.
@@ -273,15 +251,6 @@
         , errorNotFunType       :: Type n
         , errorArgType          :: Type n }
 
-        -- | An invalid witness join.
-        | ErrorCannotJoin
-        { errorAnnot            :: a
-        , errorWitness          :: Witness a n
-        , errorWitnessLeft      :: Witness a n
-        , errorTypeLeft         :: Type n
-        , errorWitnessRight     :: Witness a n
-        , errorTypeRight        :: Type n }
-
         -- | A witness provided for a purify cast that does not witness purity.
         | ErrorWitnessNotPurity
         { errorAnnot            :: a
@@ -289,14 +258,7 @@
         , errorWitness          :: Witness a n
         , errorType             :: Type n }
 
-        -- | A witness provided for a forget cast that does not witness emptiness.
-        | ErrorWitnessNotEmpty
-        { errorAnnot            :: a
-        , errorChecking         :: Exp a n
-        , errorWitness          :: Witness a n
-        , errorType             :: Type n }
 
-
         -- Case Expressions -------------------------------
         -- | A case-expression where the scrutinee type is not algebraic.
         | ErrorCaseScrutineeNotAlgebraic
@@ -308,7 +270,7 @@
         --   of data type declarations.
         | ErrorCaseScrutineeTypeUndeclared
         { errorAnnot            :: a
-        , errorChecking         :: Exp a n 
+        , errorChecking         :: Exp a n
         , errorTypeScrutinee    :: Type n }
 
         -- | A case-expression with no alternatives.
@@ -348,7 +310,7 @@
         | ErrorCaseCannotInstantiate
         { errorAnnot            :: a
         , errorChecking         :: Exp a n
-        , errorTypeScrutinee    :: Type n 
+        , errorTypeScrutinee    :: Type n
         , errorTypeCtor         :: Type n }
 
         -- | A case-expression where the type of the scrutinee does not match
diff --git a/DDC/Core/Check/ErrorMessage.hs b/DDC/Core/Check/ErrorMessage.hs
--- a/DDC/Core/Check/ErrorMessage.hs
+++ b/DDC/Core/Check/ErrorMessage.hs
@@ -8,16 +8,16 @@
 import DDC.Type.Universe
 
 
-instance (Pretty a, Show n, Eq n, Pretty n) 
+instance (Pretty a, Show n, Eq n, Pretty n)
        => Pretty (Error a n) where
  ppr err
   = case err of
-        ErrorType err'  
+        ErrorType err'
          -> ppr err'
 
         ErrorData err'
          -> ppr err'
-        
+
         -- Modules ---------------------------------------
         ErrorExportUndefined n
          -> vcat [ text "Exported name '" <> ppr n <> text "' is undefined." ]
@@ -25,7 +25,7 @@
         ErrorExportDuplicate n
          -> vcat [ text "Duplicate exported name '" <> ppr n <> text "'."]
 
-        ErrorExportMismatch n tExport tDef 
+        ErrorExportMismatch n tExport tDef
          -> vcat [ text "Type of exported name does not match type of definition."
                  , text "             with binding: "   <> ppr n
                  , text "           type of export: "   <> ppr tExport
@@ -34,8 +34,15 @@
         ErrorImportDuplicate n
          -> vcat [ text "Duplicate imported name '" <> ppr n <> text "'."]
 
+        ErrorImportCapNotEffect n
+         -> vcat [ text "Imported capability '"
+                        <> ppr n 
+                        <> text "' does not have kind Effect." ]
+
         ErrorImportValueNotData n
-         -> vcat [ text "Imported value '" <> ppr n <> text "' does not have kind Data." ]
+         -> vcat [ text "Imported value '"
+                        <> ppr n 
+                        <> text "' does not have kind Data." ]
 
 
         -- Exp --------------------------------------------
@@ -78,12 +85,12 @@
         -- Application ------------------------------------
         ErrorAppMismatch a xx t1 t2
          -> vcat [ ppr a
-                 , text "Type mismatch in application." 
+                 , text "Type mismatch in application."
                  , text "     Function expects: "       <> ppr t1
                  , text "      but argument is: "       <> ppr t2
                  , empty
                  , text "with: "                        <> align (ppr xx) ]
-         
+
         ErrorAppNotFun a xx t1
          -> vcat [ ppr a
                  , text "Cannot apply non-function"
@@ -108,21 +115,13 @@
                  , text "with: "                        <> align (ppr xx) ]
 
         ErrorLamNotPure a xx universe eff
-         -> vcat 
+         -> vcat
                 [ ppr a
                 , text "Impure" <+> ppr universe <+> text "abstraction"
                 , text "           has effect: "       <> ppr eff
                 , empty
                 , text "with: "                        <> align (ppr xx) ]
 
-        ErrorLamNotEmpty a xx universe eff
-         -> vcat 
-                [ ppr a
-                , text "Non-empty" <+> ppr universe <+> text "abstraction"
-                , text "           has closure: "       <> ppr eff
-                , empty
-                , text "with: "                        <> align (ppr xx) ]
-                 
         ErrorLamBindBadKind a xx t1 k1
          -> vcat [ ppr a
                  , text "Function parameter has invalid kind."
@@ -145,7 +144,7 @@
         ErrorLamParamUnannotated a xx b1
          -> vcat [ ppr a
                  , text "Missing type annotation on function parameter."
-                 , text "             With paramter: " <> ppr b1 
+                 , text "             With paramter: " <> ppr b1
                  , empty
                  , text "with: "                        <> align (ppr xx) ]
 
@@ -203,7 +202,7 @@
 
         ErrorLetrecMissingAnnot a b xx
          -> vcat [ ppr a
-                 , text "Missing or incomplete type annotation on recursive let-binding '" 
+                 , text "Missing or incomplete type annotation on recursive let-binding '"
                         <> ppr (binderOfBind b) <> text "'."
                  , text "Recursive functions must have full type annotations."
                  , empty
@@ -223,7 +222,7 @@
                  , text "Letregion binders do not have region kind."
                  , text "        Region binders: "       <> (hcat $ map ppr bs)
                  , text "             has kinds: "       <> (hcat $ map ppr ks)
-                 , text "       but they must all be: Region" 
+                 , text "       but they must all be: Region"
                  , empty
                  , text "with: "                         <> align (ppr xx) ]
 
@@ -242,7 +241,7 @@
                  , text "   is free in the body type: "   <> ppr t
                  , empty
                  , text "with: "                         <> align (ppr xx) ]
-        
+
         ErrorLetRegionWitnessInvalid a xx b
          -> vcat [ ppr a
                  , text "Invalid witness type with private."
@@ -255,7 +254,7 @@
          -> vcat [ ppr a
                  , text "Conflicting witness types with private."
                  , text "      Witness binding: "       <> ppr b1
-                 , text "       conflicts with: "       <> ppr b2 
+                 , text "       conflicts with: "       <> ppr b2
                  , empty
                  , text "with: "                        <> align (ppr xx) ]
 
@@ -266,27 +265,8 @@
                  , text "  but witness type is: "       <> ppr b2
                  , empty
                  , text "with: "                        <> align (ppr xx) ]
-                 
 
-        -- Withregion -------------------------------------
-        ErrorWithRegionFree a xx u t
-         -> vcat [ ppr a
-                 , text "Region handle escapes scope of withregion."
-                 , text "         The region handle: "   <> ppr u
-                 , text "  is used in the body type: "   <> ppr t
-                 , empty
-                 , text "with: "                         <> align (ppr xx) ]
 
-        ErrorWithRegionNotRegion a xx u k
-         -> vcat [ ppr a
-                 , text "Withregion handle does not have region kind."
-                 , text "   Region var or ctor: "       <> ppr u
-                 , text "             has kind: "       <> ppr k
-                 , text "       but it must be: Region"
-                 , empty
-                 , text "with: "                        <> align (ppr xx) ]
-
-
         -- Witnesses --------------------------------------
         ErrorWAppMismatch a ww t1 t2
          -> vcat [ ppr a
@@ -304,16 +284,6 @@
                  , empty
                  , text "with: "                        <> align (ppr ww) ]
 
-        ErrorCannotJoin a ww w1 t1 w2 t2
-         -> vcat [ ppr a
-                 , text "Cannot join witnesses."
-                 , text "          Cannot join: "       <> ppr w1
-                 , text "              of type: "       <> ppr t1
-                 , text "         with witness: "       <> ppr w2
-                 , text "              of type: "       <> ppr t2
-                 , empty
-                 , text "with: "                        <> align (ppr ww) ]
-
         ErrorWitnessNotPurity a xx w t
          -> vcat [ ppr a
                  , text "Witness for a purify does not witness purity."
@@ -322,15 +292,7 @@
                  , empty
                  , text "with: "                        <> align (ppr xx) ]
 
-        ErrorWitnessNotEmpty a xx w t
-         -> vcat [ ppr a
-                 , text "Witness for a forget does not witness emptiness."
-                 , text "        Witness: "             <> ppr w
-                 , text "       has type: "             <> ppr t
-                 , empty
-                 , text "with: "                        <> align (ppr xx) ]
 
-
         -- Case Expressions -------------------------------
         ErrorCaseScrutineeNotAlgebraic a xx tScrutinee
          -> vcat [ ppr a
@@ -338,7 +300,7 @@
                  , text "     Scrutinee type: "         <> ppr tScrutinee
                  , empty
                  , text "with: "                        <> align (ppr xx) ]
-        
+
         ErrorCaseScrutineeTypeUndeclared a xx tScrutinee
          -> vcat [ ppr a
                  , text "Type of scrutinee does not have a data declaration."
@@ -355,7 +317,7 @@
         ErrorCaseNonExhaustive a xx ns
          -> vcat [ ppr a
                  , text "Case alternatives are non-exhaustive."
-                 , text " Constructors not matched: "   
+                 , text " Constructors not matched: "
                         <> (sep $ punctuate comma $ map ppr ns)
                  , empty
                  , text "with: "                        <> align (ppr xx) ]
@@ -376,10 +338,10 @@
          -> vcat [ ppr a
                  , text "Pattern has more binders than there are fields in the constructor."
                  , text "     Contructor: " <> ppr uCtor
-                 , text "            has: " <> ppr iCtorFields      
+                 , text "            has: " <> ppr iCtorFields
                                             <+> text "fields"
-                 , text "  but there are: " <> ppr iPatternFields   
-                                           <+> text "binders in the pattern" 
+                 , text "  but there are: " <> ppr iPatternFields
+                                           <+> text "binders in the pattern"
                  , empty
                  , text "with: "                        <> align (ppr xx) ]
 
@@ -426,7 +388,7 @@
                  , text "       has kind: "             <> ppr k
                  , empty
                  , text "with: "                        <> align (ppr xx) ]
-       
+
         ErrorRunNotSuspension a xx t
          -> vcat [ ppr a
                  , text "Expression to run is not a suspension."
diff --git a/DDC/Core/Check/Exp.hs b/DDC/Core/Check/Exp.hs
--- a/DDC/Core/Check/Exp.hs
+++ b/DDC/Core/Check/Exp.hs
@@ -3,17 +3,17 @@
 --   The algorithm is based on:
 --    Complete and Easy Bidirectional Typechecking for Higher-Rank Polymorphism.
 --    Joshua Dunfield, Neelakantan R. Krishnaswami, ICFP 2013.
---  
+--
 --   Extensions include:
 --    * Check let-bindings and case-expressions.
 --    * Allow type annotations on function parameters.
 --    * Allow explicit type abstraction and application.
 --    * Infer the kinds of type parameters.
---    * Insert type applications in the checked expression, so that the 
+--    * Insert type applications in the checked expression, so that the
 --      resulting program can be checked by the standard bottom-up algorithm.
---    * Allow explicit hole '?' annotations to indicate a type or kind 
+--    * Allow explicit hole '?' annotations to indicate a type or kind
 --      that should be inferred.
--- 
+--
 module DDC.Core.Check.Exp
         ( -- * Checker configuation.
           Config (..)
@@ -21,6 +21,7 @@
           -- * Pure checking.
         , AnTEC         (..)
         , Mode          (..)
+        , Demand        (..)
         , Context
         , emptyContext
         , checkExp
@@ -31,10 +32,7 @@
         , makeTable
         , CheckM
         , checkExpM
-        , CheckTrace    (..)
-
-          -- * Tagged closures.
-        , TaggedClosure(..))
+        , CheckTrace    (..))
 where
 import DDC.Core.Check.Judge.Type.VarCon
 import DDC.Core.Check.Judge.Type.LamT
@@ -48,73 +46,70 @@
 import DDC.Core.Check.Judge.Type.Witness
 import DDC.Core.Check.Judge.Type.Base
 import DDC.Core.Transform.MapT
-import Data.Monoid                      hiding ((<>))
 import qualified DDC.Type.Env           as Env
 
 
 -- Wrappers -------------------------------------------------------------------
--- | Type check an expression. 
+-- | Type check an expression.
 --
---   If it's good, you get a new version with types attached every AST node, 
+--   If it's good, you get a new version with types attached every AST node,
 --   as well as every binding occurrence of a variable.
 --
 --   If it's bad, you get a description of the error.
 --
---   The kinds and types of primitives are added to the environments 
---   automatically, you don't need to supply these as part of the starting 
+--   The kinds and types of primitives are added to the environments
+--   automatically, you don't need to supply these as part of the starting
 --   kind and type environment.
 --
-checkExp 
-        :: (Ord n, Show n, Pretty n)
+checkExp
+        :: (Show a, Ord n, Show n, Pretty n)
         => Config n                     -- ^ Static configuration.
         -> KindEnv n                    -- ^ Starting kind environment.
         -> TypeEnv n                    -- ^ Starting type environment.
-        -> Exp a n                      -- ^ Expression to check.
         -> Mode  n                      -- ^ Check mode.
-        -> ( Either (Error a n)         --   Type error message. 
+        -> Demand                       -- ^ Demand placed on the expression.
+        -> Exp a n                      -- ^ Expression to check.
+        -> ( Either (Error a n)         --   Type error message.
                     ( Exp (AnTEC a n) n --   Expression with type annots
                     , Type n            --   Type of expression.
-                    , Effect n          --   Effect of expression.
-                    , Closure n)        --   Closure of expression.
+                    , Effect n)         --   Effect of expression.
            , CheckTrace)                --   Type checker debug trace.
 
-checkExp !config !kenv !tenv !xx !mode
+checkExp !config !kenv !tenv !mode !demand !xx
  = (result, ct)
- where  
+ where
   ((ct, _, _), result)
-   = runCheck (mempty, 0, 0) 
+   = runCheck (mempty, 0, 0)
    $ do
         -- Check the expression, using the monadic checking function.
-        (xx', t, effs, clos, ctx) 
-         <- checkExpM 
+        (xx', t, effs, ctx)
+         <- checkExpM
                 (makeTable config
                         (Env.union kenv (configPrimKinds config))
                         (Env.union tenv (configPrimTypes config)))
-                emptyContext xx mode
-                
+                emptyContext mode demand xx 
+
         -- Apply the final context to the annotations in expressions.
         -- This ensures that existentials are expanded to solved types.
-        let applyToAnnot (AnTEC t0 e0 c0 x0)
-                = AnTEC (applySolved ctx t0)
-                        (applySolved ctx e0)
-                        (applySolved ctx c0)
-                        x0
+        let applyToAnnot (AnTEC t0 e0 _ x0)
+             = do t0' <- applySolved ctx t0
+                  e0' <- applySolved ctx e0
+                  return $ AnTEC t0' e0' (tBot kClosure) x0
 
-        let xx'' = reannotate applyToAnnot 
-                 $ mapT (applySolved ctx) xx'
+        xx_solved <- mapT (applySolved ctx) xx'
+        xx_annot  <- reannotateM applyToAnnot xx_solved
 
-        -- Also apply the final context to the overall type, 
+        -- Also apply the final context to the overall type,
         -- effect and closure of the expression.
-        let t'   = applySolved ctx t
-        let e'   = applySolved ctx $ TSum effs
-        let c'   = applySolved ctx $ closureOfTaggedSet clos
+        t'      <- applySolved ctx t
+        e'      <- applySolved ctx $ TSum effs
 
-        return  (xx'', t', e', c')
+        return  (xx_annot, t', e')
 
 
 -- | Like `checkExp`, but only return the value type of an expression.
-typeOfExp 
-        :: (Ord n, Pretty n, Show n)
+typeOfExp
+        :: (Show a, Ord n, Pretty n, Show n)
         => Config n                     -- ^ Static configuration.
         -> KindEnv n                    -- ^ Starting Kind environment
         -> TypeEnv n                    -- ^ Starting Type environment.
@@ -122,42 +117,41 @@
         -> Either (Error a n) (Type n)
 
 typeOfExp !config !kenv !tenv !xx
- = case fst $ checkExp config kenv tenv xx Recon of
-        Left err           -> Left err
-        Right (_, t, _, _) -> Right t
+ = case fst $ checkExp config kenv tenv Recon DemandNone xx of
+        Left err        -> Left err
+        Right (_, t, _) -> Right t
 
 
 -- Monadic Checking -----------------------------------------------------------
 -- | Like `checkExp` but using the `CheckM` monad to handle errors.
-checkExpM 
-        :: (Show n, Pretty n, Ord n)
+checkExpM
+        :: (Show a, Show n, Pretty n, Ord n)
         => Table a n                    -- ^ Static config.
         -> Context n                    -- ^ Input context.
-        -> Exp a n                      -- ^ Expression to check.
         -> Mode n                       -- ^ Check mode.
-        -> CheckM a n 
+        -> Demand                       -- ^ Demand placed on the expression.
+        -> Exp a n                      -- ^ Expression to check.
+        -> CheckM a n
                 ( Exp (AnTEC a n) n     -- Annotated expression.
                 , Type n                -- Output type.
                 , TypeSum n             -- Output effect
-                , Set (TaggedClosure n) -- Output closure
                 , Context n)            -- Output context.
 
 -- Dispatch to the checker table based on what sort of AST node we're at.
-checkExpM !table !ctx !xx !mode
+checkExpM !table !ctx !mode !demand !xx 
  = case xx of
-    XVar{}                 -> tableCheckVarCon     table table ctx xx mode
-    XCon{}                 -> tableCheckVarCon     table table ctx xx mode
-    XApp _ _ XType{}       -> tableCheckAppT       table table ctx xx mode
-    XApp{}                 -> tableCheckAppX       table table ctx xx mode
-    XLAM{}                 -> tableCheckLamT       table table ctx xx mode
-    XLam{}                 -> tableCheckLamX       table table ctx xx mode
-    XLet _ LPrivate{} _    -> tableCheckLetPrivate table table ctx xx mode
-    XLet _ LWithRegion{} _ -> tableCheckLetPrivate table table ctx xx mode
-    XLet{}                 -> tableCheckLet        table table ctx xx mode
-    XCase{}                -> tableCheckCase       table table ctx xx mode
-    XCast{}                -> tableCheckCast       table table ctx xx mode
-    XWitness{}             -> tableCheckWitness    table table ctx xx mode
-    XType    a _           -> throw $ ErrorNakedType    a xx 
+    XVar{}              -> tableCheckVarCon     table table ctx mode demand xx
+    XCon{}              -> tableCheckVarCon     table table ctx mode demand xx
+    XApp _ _ XType{}    -> tableCheckAppT       table table ctx mode demand xx
+    XApp{}              -> tableCheckAppX       table table ctx mode demand xx
+    XLAM{}              -> tableCheckLamT       table table ctx mode demand xx
+    XLam{}              -> tableCheckLamX       table table ctx mode demand xx
+    XLet _ LPrivate{} _ -> tableCheckLetPrivate table table ctx mode demand xx
+    XLet{}              -> tableCheckLet        table table ctx mode demand xx
+    XCase{}             -> tableCheckCase       table table ctx mode demand xx
+    XCast{}             -> tableCheckCast       table table ctx mode demand xx
+    XWitness{}          -> tableCheckWitness    table table ctx mode demand xx
+    XType    a _        -> throw $ ErrorNakedType    a xx
 
 
 -- Table ----------------------------------------------------------------------
@@ -176,6 +170,6 @@
         , tableCheckLet         = checkLet
         , tableCheckLetPrivate  = checkLetPrivate
         , tableCheckCase        = checkCase
-        , tableCheckCast        = checkCast 
+        , tableCheckCast        = checkCast
         , tableCheckWitness     = checkWit }
 
diff --git a/DDC/Core/Check/Judge/Eq.hs b/DDC/Core/Check/Judge/Eq.hs
--- a/DDC/Core/Check/Judge/Eq.hs
+++ b/DDC/Core/Check/Judge/Eq.hs
@@ -3,12 +3,12 @@
         (makeEq)
 where
 import DDC.Core.Check.Base
-import DDC.Type.Transform.Crush
-import DDC.Type.Transform.Trim
+import qualified DDC.Type.Sum   as Sum
 
+
 -- | Make two types equivalent to each other,
 --   or throw the provided error if this is not possible.
-makeEq  :: (Eq n, Ord n, Pretty n)
+makeEq  :: (Eq n, Ord n, Pretty n, Show n)
         => Config n
         -> a
         -> Context n
@@ -25,11 +25,11 @@
  = do   let Just ctx1   = updateExists [] iL tR ctx0
 
         ctrace  $ vcat
-                [ text "* EqLSolve"
-                , text "  LEFT:  " <> ppr tL
-                , text "  RIGHT: " <> ppr tR
-                , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx1
+                [ text "**  EqLSolve"
+                , text "    LEFT:  " <> ppr tL
+                , text "    RIGHT: " <> ppr tR
+                , indent 4 $ ppr ctx0
+                , indent 4 $ ppr ctx1
                 , empty ]
 
         return ctx1
@@ -41,11 +41,11 @@
  = do   let Just ctx1   = updateExists [] iR tL ctx0
 
         ctrace  $ vcat
-                [ text "* EqRSolve"
-                , text "  LEFT:  " <> ppr tL
-                , text "  RIGHT: " <> ppr tR
-                , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx1
+                [ text "**  EqRSolve"
+                , text "    LEFT:  " <> ppr tL
+                , text "    RIGHT: " <> ppr tR
+                , indent 4 $ ppr ctx0
+                , indent 4 $ ppr ctx1
                 , empty ]
 
         return ctx1
@@ -59,13 +59,13 @@
  , Just iR <- takeExists tR,    Just lR <- locationOfExists iR ctx0
  , lL > lR
  = do   let Just ctx1   = updateExists [] iR tL ctx0
-        
-        ctrace  $ vcat 
-                [ text "* EqLReach"
-                , text "  LEFT:  " <> ppr tL
-                , text "  RIGHT: " <> ppr tR
-                , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx1
+
+        ctrace  $ vcat
+                [ text "**  EqLReach"
+                , text "    LEFT:  " <> ppr tL
+                , text "    RIGHT: " <> ppr tR
+                , indent 4 $ ppr ctx0
+                , indent 4 $ ppr ctx1
                 , empty ]
 
         return ctx1
@@ -79,12 +79,12 @@
  , lR > lL
  = do   let Just ctx1   = updateExists [] iL tR ctx0
 
-        ctrace  $ vcat 
-                [ text "* EqRReach"
-                , text "  LEFT:  " <> ppr tL
-                , text "  RIGHT: " <> ppr tR
-                , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx1
+        ctrace  $ vcat
+                [ text "**  EqRReach"
+                , text "    LEFT:  " <> ppr tL
+                , text "    RIGHT: " <> ppr tR
+                , indent 4 $ ppr ctx0
+                , indent 4 $ ppr ctx1
                 , empty ]
 
         return ctx1
@@ -94,12 +94,12 @@
  | TVar u1      <- tL
  , TVar u2      <- tR
  , u1 == u2
- = do   
+ = do
         ctrace  $ vcat
-                [ text "* EqVar"
-                , text "  LEFT:  " <> ppr tL
-                , text "  RIGHT: " <> ppr tR
-                , indent 2 $ ppr ctx0
+                [ text "**  EqVar"
+                , text "    LEFT:  " <> ppr tL
+                , text "    RIGHT: " <> ppr tR
+                , indent 4 $ ppr ctx0
                 , empty ]
 
         return ctx0
@@ -109,64 +109,69 @@
  | TCon tc1     <- tL
  , TCon tc2     <- tR
  , equivTyCon tc1 tc2
- = do   
+ = do
         ctrace  $ vcat
-                [ text "* EqCon"
-                , text "  LEFT:  " <> ppr tL
-                , text "  RIGHT: " <> ppr tR
-                , indent 2 $ ppr ctx0
+                [ text "**  EqCon"
+                , text "    LEFT:  " <> ppr tL
+                , text "    RIGHT: " <> ppr tR
+                , indent 4 $ ppr ctx0
                 , empty ]
 
         return ctx0
 
 
- -- EqFun
- | Just (tL1, tEffL, tCloL, tL2) <- takeTFunEC tL
- , Just (tR1, tEffR, tCloR, tR2) <- takeTFunEC tR
- = do   
-        ctx1    <- makeEq config a ctx0 tL1 tR1 err
-        ctx2    <- makeEq config a ctx1 (crushEffect tEffL) (crushEffect tEffR) err
-        
-        let Just tCloL' = trimClosure tCloL
-        let Just tCloR' = trimClosure tCloR
-        ctx3    <- makeEq config a ctx2 tCloL' tCloR' err
-
-        ctx4    <- makeEq config a ctx3 tL2 tR2 err
-        return ctx4
-
-
  -- EqApp
  | TApp tL1 tL2 <- tL
  , TApp tR1 tR2 <- tR
  = do
-        ctx1     <- makeEq config a ctx0 tL1 tR1 err
-        let tL2' = applyContext ctx1 tL2
-        let tR2' = applyContext ctx1 tR2
-        ctx2     <- makeEq config a ctx1 tL2' tR2' err
+        ctrace  $ vcat
+                [ text "*>  EqApp" 
+                , empty ]
 
+        ctx1    <- makeEq config a ctx0 tL1 tR1 err
+        tL2'    <- applyContext ctx1 tL2
+        tR2'    <- applyContext ctx1 tR2
+        ctx2    <- makeEq config a ctx1 tL2' tR2' err
+
         ctrace  $ vcat
-                [ text "* EqApp"
-                , text "  LEFT:   " <> ppr tL
-                , text "  RIGHT:  " <> ppr tR
-                , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx2
+                [ text "*<  EqApp"
+                , text "    LEFT:   " <> ppr tL
+                , text "    RIGHT:  " <> ppr tR
+                , indent 4 $ ppr ctx0
+                , indent 4 $ ppr ctx2
                 , empty ]
 
         return ctx2
 
+
  -- EqEquiv
- | equivT tL tR
- =      return ctx0
+ | equivT tL tR 
+ = do   ctrace  $ vcat
+                [ text "**  EqEquiv" ]
 
+        return ctx0
+
+
  -- Error
  | otherwise
- = do   ctrace  $ vcat
-                [ text "DDC.Core.Check.Exp.Inst.makeEq: no match" 
-                , text "  LEFT:   " <> ppr tL
-                , text "  RIGHT:  " <> ppr tR 
-                , text "  LEFTC:  " <> (ppr $ crushSomeT tL)
-                , text "  RIGHTC: " <> (ppr $ crushSomeT tR)
+ = do   let caps = configGlobalCaps config
+        let tL'  = crushEffect caps $ unpackSumT tL
+        let tR'  = crushEffect caps $ unpackSumT tR
+
+        ctrace  $ vcat
+                [ text "DDC.Core.Check.Exp.Inst.makeEq: no match"
+                , text "  LEFT:   " <> (text $ show tL)
+                , text "  RIGHT:  " <> (text $ show tR)
+                , text "  LEFTC:  " <> (text $ show tL')
+                , text "  RIGHTC: " <> (text $ show tR')
                 , indent 2 $ ppr ctx0 ]
 
         throw err
+
+
+-- | Unpack single element sums into plain types.
+unpackSumT :: Type n -> Type n
+unpackSumT (TSum ts)
+        | [t]   <- Sum.toList ts = t
+unpackSumT tt                    = tt
 
diff --git a/DDC/Core/Check/Judge/Inst.hs b/DDC/Core/Check/Judge/Inst.hs
--- a/DDC/Core/Check/Judge/Inst.hs
+++ b/DDC/Core/Check/Judge/Inst.hs
@@ -24,11 +24,11 @@
  = do   let Just ctx1   = updateExists [] iL tR ctx0
 
         ctrace  $ vcat
-                [ text "* InstLSolve"
-                , text "  LEFT:  " <> ppr tL
-                , text "  RIGHT: " <> ppr tR
-                , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx1
+                [ text "**  InstLSolve"
+                , text "    LEFT:  " <> ppr tL
+                , text "    RIGHT: " <> ppr tR
+                , indent 4 $ ppr ctx0
+                , indent 4 $ ppr ctx1
                 , empty ]
 
         return ctx1
@@ -42,13 +42,13 @@
  , Just iR <- takeExists tR,    Just lR <- locationOfExists iR ctx0
  , lL > lR
  = do   let Just ctx1   = updateExists [] iR tL ctx0
-        
-        ctrace  $ vcat 
-                [ text "* InstLReach"
-                , text "  LEFT:  " <> ppr tL
-                , text "  RIGHT: " <> ppr tR
-                , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx1
+
+        ctrace  $ vcat
+                [ text "**  InstLReach"
+                , text "    LEFT:  " <> ppr tL
+                , text "    RIGHT: " <> ppr tR
+                , indent 4 $ ppr ctx0
+                , indent 4 $ ppr ctx1
                 , empty ]
 
         return ctx1
@@ -62,12 +62,12 @@
  , lR > lL
  = do   let Just ctx1   = updateExists [] iL tR ctx0
 
-        ctrace  $ vcat 
-                [ text "* InstRReach"
-                , text "  LEFT:  " <> ppr tL
-                , text "  RIGHT: " <> ppr tR
-                , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx1
+        ctrace  $ vcat
+                [ text "**  InstRReach"
+                , text "    LEFT:  " <> ppr tL
+                , text "    RIGHT: " <> ppr tR
+                , indent 4 $ ppr ctx0
+                , indent 4 $ ppr ctx1
                 , empty ]
 
         return ctx1
@@ -79,30 +79,30 @@
  , Just (tR1, tR2)      <- takeTFun tR
  = do
         -- Make new existentials to match the function type and parameter.
-        iL1             <- newExists kData
-        let tL1         =  typeOfExists iL1 
+        iL1     <- newExists kData
+        let tL1 =  typeOfExists iL1
 
-        iL2             <- newExists kData
-        let tL2         =  typeOfExists iL2
+        iL2     <- newExists kData
+        let tL2 =  typeOfExists iL2
 
         -- Update the context with the new constraint.
         let Just ctx1   =  updateExists [iL2, iL1] iL (tFun tL1 tL2) ctx0
 
         -- Instantiate the parameter type.
-        ctx2            <- makeInst config a ctx1 tR1 tL1 err
+        ctx2    <- makeInst config a ctx1 tR1 tL1 err
 
         -- Substitute into tR2
-        let tR2'        =  applyContext ctx2 tR2
+        tR2'    <- applyContext ctx2 tR2
 
         -- Instantiate the return type.
-        ctx3            <- makeInst config a ctx2 tL2 tR2' err
+        ctx3    <- makeInst config a ctx2 tL2 tR2' err
 
         ctrace  $ vcat
-                [ text "* InstLArr"
-                , text "  LEFT:  " <> ppr tL
-                , text "  RIGHT: " <> ppr tR
-                , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx3 
+                [ text "**  InstLArr"
+                , text "    LEFT:  " <> ppr tL
+                , text "    RIGHT: " <> ppr tR
+                , indent 4 $ ppr ctx0
+                , indent 4 $ ppr ctx3
                 , empty ]
 
         return ctx3
@@ -114,11 +114,11 @@
  = do   let Just ctx1   = updateExists [] iR tL ctx0
 
         ctrace  $ vcat
-                [ text "* InstRSolve"
-                , text "  LEFT:  " <> ppr tL
-                , text "  RIGHT: " <> ppr tR
-                , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx1
+                [ text "**  InstRSolve"
+                , text "    LEFT:  " <> ppr tL
+                , text "    RIGHT: " <> ppr tR
+                , indent 4 $ ppr ctx0
+                , indent 4 $ ppr ctx1
                 , empty ]
 
         return ctx1
@@ -128,32 +128,32 @@
  --  Left is an function arrow, and right is an existential.
  | Just (tL1, tL2)      <- takeTFun tL
  , Just iR              <- takeExists tR
- = do   
+ = do
         -- Make new existentials to match the function type and parameter.
-        iR1             <- newExists kData
-        let tR1         =  typeOfExists iR1 
+        iR1     <- newExists kData
+        let tR1 =  typeOfExists iR1
 
-        iR2             <- newExists kData
-        let tR2         =  typeOfExists iR2
+        iR2     <- newExists kData
+        let tR2 =  typeOfExists iR2
 
         -- Update the context with the new constraint.
         let Just ctx1   =  updateExists [iR2, iR1] iR (tFun tR1 tR2) ctx0
 
         -- Instantiate the parameter type.
-        ctx2            <- makeInst config a ctx1 tR1 tL1 err
+        ctx2    <- makeInst config a ctx1 tR1 tL1 err
 
         -- Substitute into tL2
-        let tL2'        = applyContext ctx2 tL2
+        tL2'    <- applyContext ctx2 tL2
 
         -- Instantiate the return type.
-        ctx3            <- makeInst config a ctx2 tL2' tR2 err
+        ctx3    <- makeInst config a ctx2 tL2' tR2 err
 
         ctrace  $ vcat
-                [ text "* InstRArr"
-                , text "  LEFT:  " <> ppr tL
-                , text "  RIGHT: " <> ppr tR
-                , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx3 
+                [ text "**  InstRArr"
+                , text "    LEFT:  " <> ppr tL
+                , text "    RIGHT: " <> ppr tR
+                , indent 4 $ ppr ctx0
+                , indent 4 $ ppr ctx3
                 , empty ]
 
         return ctx3
@@ -162,7 +162,7 @@
  | otherwise
  = do
         ctrace  $ vcat
-                [ text "DDC.Core.Check.Exp.Inst.inst: no match" 
+                [ text "DDC.Core.Check.Exp.Inst.inst: no match"
                 , text "  LEFT:  " <> ppr tL
                 , text "  RIGHT: " <> ppr tR
                 , indent 2 $ ppr ctx0
diff --git a/DDC/Core/Check/Judge/Sub.hs b/DDC/Core/Check/Judge/Sub.hs
--- a/DDC/Core/Check/Judge/Sub.hs
+++ b/DDC/Core/Check/Judge/Sub.hs
@@ -3,7 +3,7 @@
         ( makeSub)
 where
 import DDC.Type.Transform.SubstituteT
-import DDC.Core.Annot.AnTEC
+import DDC.Core.Exp.Annot.AnTEC
 import DDC.Core.Check.Judge.Eq
 import DDC.Core.Check.Judge.Inst
 import DDC.Core.Check.Base
@@ -19,7 +19,7 @@
         -> Type n
         -> Type n
         -> Error a n
-        -> CheckM a n 
+        -> CheckM a n
                 ( Exp (AnTEC a n) n
                 , Context n)
 
@@ -33,12 +33,13 @@
  | TCon tc1     <- tL
  , TCon tc2     <- tR
  , equivTyCon tc1 tc2
- = do   
+ = do
         ctrace  $ vcat
-                [ text "* SubCon"
-                , text "  LEFT:  " <> ppr tL
-                , text "  RIGHT: " <> ppr tR
-                , indent 2 $ ppr ctx0
+                [ text "**  SubCon"
+                , text "    xL: " <> ppr xL
+                , text "    tL: " <> ppr tL
+                , text "    tR: " <> ppr tR
+                , indent 4 $ ppr ctx0
                 , empty ]
 
         return (xL, ctx0)
@@ -49,12 +50,13 @@
  | TVar u1      <- tL
  , TVar u2      <- tR
  , u1 == u2
- = do   
+ = do
         ctrace  $ vcat
-                [ text "* SubVar"
-                , text "  LEFT:  " <> ppr tL
-                , text "  RIGHT: " <> ppr tR
-                , indent 2 $ ppr ctx0
+                [ text "**  SubVar"
+                , text "    xL: " <> ppr xL
+                , text "    tL: " <> ppr tL
+                , text "    tR: " <> ppr tR
+                , indent 4 $ ppr ctx0
                 , empty ]
 
         return (xL, ctx0)
@@ -65,32 +67,45 @@
  | Just iL <- takeExists tL
  , Just iR <- takeExists tR
  , iL == iR
- = do   
+ = do
         ctrace  $ vcat
-                [ text "* SubExVar"
-                , text "  LEFT:  " <> ppr tL
-                , text "  RIGHT: " <> ppr tR
-                , indent 2 $ ppr ctx0 
+                [ text "**  SubExVar"
+                , text "    xL: " <> ppr xL
+                , text "    tL: " <> ppr tL
+                , text "    tR: " <> ppr tR
+                , indent 4 $ ppr ctx0
                 , empty ]
 
         return (xL, ctx0)
 
 
+ -- SubEquiv
+ --  Both sides are equivalent
+ | equivT tL tR
+ = do
+        ctrace  $ vcat
+                [ text "**  SubEquiv"
+                , text "    xL: " <> ppr xL
+                , text "    tL: " <> ppr tL
+                , text "    tR: " <> ppr tR
+                , indent 4 $ ppr ctx0
+                , empty ]
+
+        return (xL, ctx0)
+
+
  -- SubInstL
  --  Left is an existential.
- --
- --  ISSUE #326: Do free variables check in new inferencer.
- --    check  tL /= FV(tR)
- --
  | isTExists tL
  = do   ctx1    <- makeInst config a ctx0 tR tL err
 
         ctrace  $ vcat
-                [ text "* SubInstL"
-                , text "  LEFT:   " <> ppr tL
-                , text "  RIGHT:  " <> ppr tR
-                , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx1
+                [ text "**  SubInstL"
+                , text "    xL: " <> ppr xL
+                , text "    tL: " <> ppr tL
+                , text "    tR: " <> ppr tR
+                , indent 4 $ ppr ctx0
+                , indent 4 $ ppr ctx1
                 , empty ]
 
         return (xL, ctx1)
@@ -98,19 +113,16 @@
 
  -- SubInstR
  --  Right is an existential.
- --
- --  ISSUE #326: Do free variables check in new inferencer.
- --     check  tR /= FV(tL)
- --
  | isTExists tR
  = do   ctx1    <- makeInst config a ctx0 tL tR err
 
         ctrace  $ vcat
-                [ text "* SubInstR"
-                , text "  LEFT:  " <> ppr tL
-                , text "  RIGHT: " <> ppr tR
-                , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx1 
+                [ text "**  SubInstR"
+                , text "    xL: " <> ppr xL
+                , text "    tL: " <> ppr tL
+                , text "    tR: " <> ppr tR
+                , indent 4 $ ppr ctx0
+                , indent 4 $ ppr ctx1
                 , empty ]
 
         return (xL, ctx1)
@@ -120,42 +132,52 @@
  --  Both sides are arrow types.
  | Just (tL1, tL2)  <- takeTFun tL
  , Just (tR1, tR2)  <- takeTFun tR
- = do   
-        (_, ctx1)   <- makeSub config a ctx0 xL tR1 tL1 err
-        let tL2'    =  applyContext  ctx1    tL2
-        let tR2'    =  applyContext  ctx1    tR2
-        (_, ctx2)   <- makeSub config a ctx1 xL tL2' tR2' err
+ = do
+        ctrace  $ vcat
+                [ text "*>  SubArr"
+                , empty ]
 
+        (_, ctx1) <- makeSub config a ctx0 xL tR1 tL1 err
+        tL2'      <- applyContext     ctx1 tL2
+        tR2'      <- applyContext     ctx1 tR2
+        (_, ctx2) <- makeSub config a ctx1 xL tL2' tR2' err
+
         ctrace  $ vcat
-                [ text "* SubArr"
-                , text "  LEFT:  " <> ppr tL
-                , text "  RIGHT: " <> ppr tR
-                , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx1
-                , indent 2 $ ppr ctx2 
+                [ text "*<  SubArr"
+                , text "    xL: " <> ppr xL
+                , text "    tL: " <> ppr tL
+                , text "    tR: " <> ppr tR
+                , indent 4 $ ppr ctx0
+                , indent 4 $ ppr ctx1
+                , indent 4 $ ppr ctx2
                 , empty ]
 
         return (xL, ctx2)
 
 
- -- SubApp 
+ -- SubApp
  --   Both sides are type applications.
  --   Assumes non-function type constructors are invariant.
  | TApp tL1 tL2 <- tL
  , TApp tR1 tR2 <- tR
- = do   
-        ctx1     <- makeEq config a ctx0 tL1 tR1 err
-        let tL2' =  applyContext ctx1 tL2
-        let tR2' =  applyContext ctx1 tR2
-        ctx2     <- makeEq config a ctx1 tL2' tR2' err
+ = do
+        ctrace  $ vcat
+                [ text "*>  SubApp"
+                , empty ]
 
+        ctx1    <- makeEq config a ctx0 tL1 tR1 err
+        tL2'    <- applyContext ctx1 tL2
+        tR2'    <- applyContext ctx1 tR2
+        ctx2    <- makeEq config a ctx1 tL2' tR2' err
+
         ctrace  $ vcat
-                [ text "* SubApp"
-                , text "  LEFT:  " <> ppr tL
-                , text "  RIGHT: " <> ppr tR
-                , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx1
-                , indent 2 $ ppr ctx2 
+                [ text "*<  SubApp"
+                , text "    xL: " <> ppr xL
+                , text "    tL: " <> ppr tL
+                , text "    tR: " <> ppr tR
+                , indent 4 $ ppr ctx0
+                , indent 4 $ ppr ctx1
+                , indent 4 $ ppr ctx2
                 , empty ]
 
         return (xL, ctx2)
@@ -164,49 +186,56 @@
  -- SubForall
  --   Left side is a forall type.
  | TForall b t1 <- tL
- = do   
+ = do
+        ctrace  $ vcat
+                [ text "*>  SubForall"
+                , empty ]
+
         -- Make a new existential to instantiate the quantified
-        -- variable and substitute it into the body. 
+        -- variable and substitute it into the body.
         iA        <- newExists (typeOfBind b)
         let tA    = typeOfExists iA
         let t1'   = substituteT b tA t1
 
-        -- Check the new body against the right type, 
+        -- Check the new body against the right type,
         -- so that the existential we just made is instantiated
         -- to match the right.
         let (ctx1, pos1) =  markContext ctx0
         let ctx2         =  pushExists  iA ctx1
-        (xL1, ctx3)      <- makeSub config a ctx2 xL t1' tR err
 
+        -- Wrap the expression with a type application to cause
+        -- the instantiation.
+        let AnTEC _ e0 c0 _
+                 = annotOfExp xL
+        let aFn  = AnTEC t1' (substituteT b tA e0) (substituteT b tA c0) a
+        let aArg = AnTEC (typeOfBind b) (tBot kEffect) (tBot kClosure) a
+        let xL1  = XApp aFn xL (XType aArg tA)
+
+        (xL2, ctx3) <- makeSub config a ctx2 xL1 t1' tR err
+
         -- Pop the existential and constraints above it back off
         -- the stack.
         let ctx4  = popToPos pos1 ctx3
 
         ctrace  $ vcat
-                [ text "* SubForall"
-                , text "  LEFT:  " <> ppr tL
-                , text "  RIGHT: " <> ppr tR
-                , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx4 
+                [ text "*<  SubForall"
+                , text "    xL:    " <> ppr xL
+                , text "    LEFT:  " <> ppr tL
+                , text "    RIGHT: " <> ppr tR
+                , text "    xL2:   " <> ppr xL2
+                , indent 4 $ ppr ctx0
+                , indent 4 $ ppr ctx4
                 , empty ]
 
-        -- Wrap the expression with a type application to cause
-        -- the instantiation.
-        let AnTEC _ e0 c0 _    
-                 = annotOfExp xL
-        let aFn  = AnTEC t1' (substituteT b tA e0) (substituteT b tA c0) a
-        let aArg = AnTEC (typeOfBind b) (tBot kEffect) (tBot kClosure) a
-        let xL2  = XApp aFn xL1 (XType aArg tA) 
-
         return (xL2, ctx4)
 
 
  -- Error
  | otherwise
  = do   ctrace  $ vcat
-                [ text "DDC.Core.Check.Exp.Inst.makeSub: no match" 
-                , text "  LEFT:   " <> text (show tL)
-                , text "  RIGHT:  " <> text (show tR) ]
+                [ text "DDC.Core.Check.Exp.Inst.makeSub: no match"
+                , text "  LEFT:   " <> ppr tL
+                , text "  RIGHT:  " <> ppr tR ]
 
         throw err
 
diff --git a/DDC/Core/Check/Judge/Type/AppT.hs b/DDC/Core/Check/Judge/Type/AppT.hs
--- a/DDC/Core/Check/Judge/Type/AppT.hs
+++ b/DDC/Core/Check/Judge/Type/AppT.hs
@@ -4,27 +4,24 @@
 where
 import DDC.Core.Check.Judge.Type.Sub
 import DDC.Core.Check.Judge.Type.Base
-import qualified Data.Set       as Set
 
 
 -- | Check a spec application.
 checkAppT :: Checker a n
 
-checkAppT !table !ctx0 xx@(XApp aApp xFn (XType aArg tArg)) Recon
- = do   let config      = tableConfig table
+checkAppT !table !ctx0 Recon demand
+        xx@(XApp aApp xFn (XType aArg tArg))
+ = do   
+        let config      = tableConfig table
         let kenv        = tableKindEnv table
 
         -- Check the functional expression.
-        (xFn', tFn, effsFn, closFn, ctx1) 
-         <- tableCheckExp table table ctx0 xFn Recon
+        (xFn', tFn, effsFn, ctx1)
+         <- tableCheckExp table table ctx0 Recon demand xFn
 
         -- Check the argument.
         (tArg', kArg, ctx2)
-         <- checkTypeM config kenv ctx1 UniverseSpec tArg Recon
-                        
-        -- Take any Use annots from a region arg.
-        --  This always matches because we just checked tArg.
-        let Just t2_clo = taggedClosureOfTyArg kenv ctx2 tArg'
+         <- checkTypeM    config kenv ctx1 UniverseSpec tArg Recon
 
         -- Determine the type of the result.
         --  The function must have a quantified type, which we then instantiate
@@ -48,7 +45,7 @@
         -- thus we can't be sharing objects that have it in its type.
 
         -- Build an annotated version of the type application.
-        let aApp' = AnTEC tResult (TSum effsFn)  (closureOfTaggedSet closFn) aApp  
+        let aApp' = AnTEC tResult (TSum effsFn)  (tBot kClosure) aApp
         let aArg' = AnTEC kArg    (tBot kEffect) (tBot kClosure) aArg
         let xx'   = XApp aApp' xFn' (XType aArg' tArg')
 
@@ -64,27 +61,22 @@
 
         returnX aApp
                 (\z -> XApp z xFn' (XType aArg' tArg'))
-                tResult effsFn (closFn `Set.union` t2_clo)
-                ctx2
-
-checkAppT !table !ctx0 xx@(XApp aApp xFn (XType aArg tArg)) Synth
- = do   let kenv        = tableKindEnv table
+                tResult effsFn ctx2
 
+checkAppT !table !ctx0 Synth demand 
+        xx@(XApp aApp xFn (XType aArg tArg))
+ = do
         -- Check the functional expression.
-        (xFn', tFn, effsFn, closFn, ctx1) 
-         <- tableCheckExp table table ctx0 xFn Synth
+        (xFn', tFn, effsFn, ctx1)
+         <- tableCheckExp table table ctx0 Synth demand xFn
 
         -- Apply the type argument to the type of the function.
+        tFn' <- applyContext ctx1 tFn
         (tResult, tArg', kArg, ctx2)
-         <- synthAppArgT table aApp xx ctx1 
-                (applyContext ctx1 tFn) tArg
-        
-        -- Take any Use annots from a region arg.
-        --  This always matches because we just checked tArg.
-        let Just t2_clo = taggedClosureOfTyArg kenv ctx2 tArg'
+             <- synthAppArgT table aApp xx ctx1 tFn' tArg
 
         -- Build an annotated version of the type application.
-        let aApp' = AnTEC tResult (TSum effsFn)  (closureOfTaggedSet closFn) aApp  
+        let aApp' = AnTEC tResult (TSum effsFn)  (tBot kClosure) aApp
         let aArg' = AnTEC kArg    (tBot kEffect) (tBot kClosure) aArg
         let xx'   = XApp aApp' xFn' (XType aArg' tArg')
 
@@ -100,14 +92,14 @@
 
         returnX aApp
                 (\z -> XApp z xFn' (XType aArg' tArg'))
-                tResult effsFn (closFn `Set.union` t2_clo)
-                ctx2
+                tResult effsFn ctx2
 
 
-checkAppT !table !ctx0 xx@(XApp aApp _ (XType _ _)) (Check tExpected)
- =      checkSub table aApp ctx0 xx tExpected
+checkAppT !table !ctx0 (Check tExpected) demand 
+        xx@(XApp aApp _ (XType _ _)) 
+ =      checkSub table aApp ctx0 demand xx tExpected
 
-checkAppT _ _ _ _
+checkAppT _ _ _ _ _
  = error "ddc-core.checkAppT: no match"
 
 
@@ -132,7 +124,7 @@
  -- Rule (AppT Synth exists)
  --  Functional type is an existential.
  --
- --  Although we know the functional part should have a quantified type, 
+ --  Although we know the functional part should have a quantified type,
  --  we can't infer a type for the result because we would need to represent
  --  a delayed substitution of a type into an existential. The rule would be
  --  as follows:
@@ -141,7 +133,7 @@
  --   -----------------------------------------------------
  --      Env0[?0] |- ?0 * t2 => ?2 [t2/a] -| Env1
  --
- --  .. but we can't represent the (?2 [t2/a]) part. This is an inherent 
+ --  .. but we can't represent the (?2 [t2/a]) part. This is an inherent
  --  limitation of our type inference algorithm.
  --
  | Just _               <- takeExists tFn
@@ -149,7 +141,7 @@
 
 
  -- Rule (AppT Synth Forall)
- --  The function already has a quantified type, so we can instantiate it 
+ --  The function already has a quantified type, so we can instantiate it
  --  with the supplied type argument.
  | TForall b11 t12      <- tFn
  = do   let config      = tableConfig table
@@ -157,7 +149,7 @@
 
         -- The kind of the argument must match the annotation on the quantifier.
         (tArg', kArg, ctx1)
-         <- checkTypeM config kenv ctx0 UniverseSpec tArg 
+         <- checkTypeM config kenv ctx0 UniverseSpec tArg
                 (Check (typeOfBind b11))
 
         -- Instantiate the type of the function with the type argument.
diff --git a/DDC/Core/Check/Judge/Type/AppX.hs b/DDC/Core/Check/Judge/Type/AppX.hs
--- a/DDC/Core/Check/Judge/Type/AppX.hs
+++ b/DDC/Core/Check/Judge/Type/AppX.hs
@@ -5,115 +5,130 @@
 import DDC.Core.Check.Judge.Type.Sub
 import DDC.Core.Check.Judge.Type.Base
 import qualified DDC.Type.Sum   as Sum
-import qualified Data.Set       as Set
 
 
 -------------------------------------------------------------------------------
 -- | Check a value expression application.
 checkAppX :: Checker a n
 
-checkAppX !table !ctx xx@(XApp a xFn xArg) Recon
- = do   
+checkAppX !table !ctx Recon demand
+        xx@(XApp a xFn xArg)
+ = do
         -- Check the functional expression.
-        (xFn',  tFn,  effsFn,  closFn,  ctx1) 
-         <- tableCheckExp table table ctx  xFn Recon
+        (xFn',  tFn,  effsFn, ctx1)
+         <- tableCheckExp table table ctx  Recon demand xFn
 
         -- Check the argument.
-        (xArg', tArg, effsArg, closArg, ctx2) 
-         <- tableCheckExp table table ctx1 xArg Recon
+        (xArg', tArg, effsArg, ctx2)
+         <- tableCheckExp table table ctx1 Recon DemandNone xArg
 
         -- The type of the parameter must match that of the argument.
         (tResult, effsLatent)
          <- case splitFunType tFn of
              Just (tParam, effs, _, tResult)
-              | tParam `equivT` tArg 
+              | tParam `equivT` tArg
               -> return (tResult, effs)
 
-              | otherwise           
+              | otherwise
               -> throw  $ ErrorAppMismatch a xx tParam tArg
 
              Nothing
               -> throw  $ ErrorAppNotFun a xx tFn
 
         -- Effect of the overall application.
-        let effsResult  = Sum.unions kEffect
-                        $ [effsFn, effsArg, Sum.singleton kEffect effsLatent]
-
-        -- Closure of the overall application.
-        let closResult  = Set.union  closFn closArg
+        let effsResult  
+                = Sum.unions kEffect
+                $ [effsFn, effsArg, Sum.singleton kEffect effsLatent]
 
-        returnX a 
+        returnX a
                 (\z -> XApp z xFn' xArg')
-                tResult effsResult closResult 
+                tResult effsResult
                 ctx2
 
 
-checkAppX !table !ctx0 xx@(XApp a xFn xArg) Synth
- = do   
+checkAppX !table !ctx0 Synth demand 
+        xx@(XApp a xFn xArg)
+ = do
+        ctrace  $ vcat
+                [ text "*>  App Synth"
+                , empty ]
+
         -- Synth a type for the functional expression.
-        (xFn', tFn, effsFn, closFn, ctx1) 
-         <- tableCheckExp table table ctx0 xFn Synth
+        (xFn', tFn, effsFn, ctx1)
+         <- tableCheckExp table table ctx0 Synth demand xFn
 
         -- Substitute context into synthesised type.
-        let tFn' = applyContext ctx1 tFn
+        tFn' <- applyContext ctx1 tFn
 
         -- Synth a type for the function applied to its argument.
-        (xFn'', xArg', tResult, effsResult, closResult, ctx2)
-         <- synthAppArg table a xx ctx1
-                xFn' tFn' effsFn closFn 
-                xArg
+        (xResult, tResult, esResult, ctx2)
+         <- synthAppArg table a xx ctx1 demand
+                xFn' tFn' effsFn xArg
 
         ctrace  $ vcat
-                [ text "* App Synth"
-                , indent 2 $ ppr xx
-                , text "      tFn:  " <> ppr tFn'
-                , text "     xArg:  " <> ppr xArg
-                , text "  tResult:  " <> ppr tResult
-                , ppr ctx0
-                , ppr ctx2
+                [ text "*<  App Synth"
+                , text "    demand  : " <> (text $ show demand)
+                , indent 4 $ ppr xx
+                , text "    tFn     : " <> ppr tFn'
+                , text "    tArg    : " <> ppr xArg
+                , text "    xResult : " <> ppr xResult
+                , text "    tResult : " <> ppr tResult
+                , indent 4 $ ppr ctx0
+                , indent 4 $ ppr ctx2
                 , empty ]
 
-        returnX a 
-                (\z -> XApp z xFn'' xArg')
-                tResult effsResult closResult 
-                ctx2
+        return  (xResult, tResult, esResult, ctx2)
 
 
-checkAppX !table !ctx xx@(XApp a _ _) (Check tEx)
- =      checkSub table a ctx xx tEx
+checkAppX !table !ctx (Check tExpected) demand 
+        xx@(XApp a _ _) 
+ = do   
+        ctrace  $ vcat
+                [ text "*>  App Check"
+                , text "    tExpected: " <> ppr tExpected
+                , empty ]
 
+        result  <- checkSub table a ctx demand xx tExpected
 
-checkAppX _ _ _ _
+        ctrace  $ vcat
+                [ text "*<  App Check"
+                , empty ]
+
+        return  result   
+
+checkAppX _ _ _ _ _
  = error "ddc-core.checkApp: no match"
 
 
 -------------------------------------------------------------------------------
 -- | Synthesize the type of a function applied to its argument.
-synthAppArg 
-        :: (Show n, Ord n, Pretty n)
+synthAppArg
+        :: (Show a, Show n, Ord n, Pretty n)
         => Table a n
-        -> a                             -- Annot for error messages.
-        -> Exp a n                       -- Expression for error messages.
-        -> Context n                     -- Current context.
-        -> Exp (AnTEC a n) n             -- Checked functional expression.
-                -> Type n                -- Type of functional expression.
-                -> TypeSum n             -- Effect of functional expression.
-                -> Set (TaggedClosure n) -- Closure of functional expression.
-        -> Exp a n                       -- Function argument.
+        -> a                         -- Annot for error messages.
+        -> Exp a n                   -- Expression for error messages.
+        -> Context n                 -- Current context.
+        -> Demand                    -- Demand placed on result of application.
+        -> Exp (AnTEC a n) n         -- Checked functional expression.
+                -> Type n            -- Type of functional expression.
+                -> TypeSum n         -- Effect of functional expression.
+        -> Exp a n                   -- Function argument.
         -> CheckM a n
-                ( Exp (AnTEC a n) n      -- Checked functional expression.
-                , Exp (AnTEC a n) n      -- Checked argument   expression.
-                , Type n                 -- Type of result.
-                , TypeSum n              -- Effect of result.
-                , Set (TaggedClosure n)  -- Closure of result.
-                , Context n)             -- Result context.
+                ( Exp (AnTEC a n) n  -- Checked application.
+                , Type n             -- Type of result.
+                , TypeSum n          -- Effect of result.
+                , Context n)         -- Result context.
 
-synthAppArg table a xx ctx0 xFn tFn effsFn closFn xArg
+synthAppArg table a xx ctx0 demand xFn tFn effsFn xArg
 
  -- Rule (App Synth exists)
  --  Functional type is an existential.
  | Just iFn      <- takeExists tFn
- = do   
+ = do
+        ctrace  $ vcat
+                [ text "*>  App Synth Exists"
+                , empty ]
+
         -- New existential for the type of the function parameter.
         iA1      <- newExists kData
         let tA1  = typeOfExists iA1
@@ -126,28 +141,39 @@
         let Just ctx1 = updateExists [iA2, iA1] iFn (tFun tA1 tA2) ctx0
 
         -- Check the argument under the new context.
-        (xArg', _, effsArg, closArg, ctx2)
-         <- tableCheckExp table table ctx1 xArg (Check tA1)
+        (xArg', _, effsArg, ctx2)
+         <- tableCheckExp table table ctx1 (Check tA1) DemandRun xArg
 
         -- Effect and closure of the overall function application.
-        let effsResult = effsFn `Sum.union` effsArg
-        let closResult = closFn `Set.union` closArg
+        let esResult    = effsFn `Sum.union` effsArg
 
+        -- Result expression.
+        let xResult    = XApp  (AnTEC tA2 (TSum esResult) (tBot kClosure) a)
+                                xFn xArg'
+
         ctrace  $ vcat
-                [ text "* App Synth exists"
-                , indent 2 $ ppr xx
-                , indent 2 $ ppr ctx2 
+                [ text "*<  App Synth Exists"
+                , text "    xFn    :"  <> ppr xFn
+                , text "    tFn    :"  <> ppr tFn
+                , text "    xArg   :"  <> ppr xArg
+                , text "    xArg'  :"  <> ppr xArg'
+                , text "    xResult:"  <> ppr xResult
+                , indent 4 $ ppr xx
+                , indent 4 $ ppr ctx2
                 , empty ]
 
-        return  ( xFn, xArg'
-                , tA2, effsResult, closResult, ctx2)
+        return  (xResult, tA2, esResult, ctx2)
 
 
  -- Rule (App Synth Forall)
  --  Function has a quantified type, but we're applying an expression to it.
  --  We need to inject a new type argument.
  | TForall b tBody      <- tFn
- = do   
+ = do
+        ctrace  $ vcat
+                [ text "*>  App Synth Forall"
+                , empty ]
+
         -- Make a new existential for the type of the argument,
         -- and push it onto the context.
         iA         <- newExists (typeOfBind b)
@@ -158,78 +184,106 @@
         let tBody' = substituteT b tA tBody
 
         -- Add the missing type application.
-        --  Because we were applying a function to an expression argument, 
+        --  Because we were applying a function to an expression argument,
         --  and the type of the function was quantified, we know there should
         --  be a type application here.
-        let aFn    = AnTEC tFn (TSum effsFn) (closureOfTaggedSet closFn) a
+        let aFn    = AnTEC tFn (TSum effsFn) (tBot kClosure) a
         let aArg   = AnTEC (typeOfBind b) (tBot kEffect) (tBot kClosure) a
         let xFnTy  = XApp aFn xFn (XType aArg tA)
 
-        -- Synthesise the result type of a function being applied to its 
+        -- Synthesise the result type of a function being applied to its
         -- argument. We know the type of the function up-front, but we pass
         -- in the whole argument expression.
-        (xFnTy', xArg', tResult, effsResult, closResult, ctx2)
-         <- synthAppArg table a xx ctx1 xFnTy tBody' effsFn closFn xArg
+        (xResult, tResult, esResult, ctx2)
+         <- synthAppArg table a xx ctx1 demand xFnTy tBody' effsFn xArg
 
+        -- Result expression.
+
         ctrace  $ vcat
-                [ text "* App Synth Forall"
-                , text "      xFn:  " <> ppr xFnTy'
-                , text "     tArg:  " <> ppr xArg'
-                , text "      tFn:  " <> ppr tFn
-                , text "  tResult:  " <> ppr tResult
-                , indent 2 $ ppr ctx2
+                [ text "*<  App Synth Forall"
+                , text "    xFn     : " <> ppr xFn
+                , text "    tFn     : " <> ppr tFn
+                , text "    xArg    : " <> ppr xArg
+                , text "    xResult : " <> ppr xResult
+                , text "    tResult : " <> ppr tResult
+                , indent 4 $ ppr ctx2
                 , empty ]
 
-        return  ( xFnTy'
-                , xArg'
-                , tResult, effsResult, closResult, ctx2)
+        return  (xResult, tResult, esResult, ctx2)
 
 
  -- Rule (App Synth Fun)
  --  Function already has a concrete function type.
  | Just (tParam, tResult)   <- takeTFun tFn
- = do   
+ = do
+        ctrace  $ vcat
+                [ text "*>  App Synth Fun"
+                , empty ]
+
         -- Check the argument.
-        (xArg', tArg, effsArg, closArg, ctx1) 
-         <- tableCheckExp table table ctx0 xArg (Check tParam)
+        (xArg', tArg, esArg, ctx1)
+         <- tableCheckExp table table ctx0 (Check tParam) DemandRun xArg
 
-        let tFn1     = applyContext ctx1 tFn
-        let tArg1    = applyContext ctx1 tArg
-        let tResult1 = applyContext ctx1 tResult
+        tFn'     <- applyContext ctx1 tFn
+        tArg'    <- applyContext ctx1 tArg
+        tResult' <- applyContext ctx1 tResult
 
         -- Get the type, effect and closure resulting from the application
         -- of a function of this type to its argument.
-        effsLatent
-         <- case splitFunType tFn1 of
+        esLatent
+         <- case splitFunType tFn' of
              Just (_tParam, effsLatent, _closLatent, _tResult)
               -> return effsLatent
 
              -- This shouldn't happen because this rule (App Synth Fun) only
-             -- applies when 'tFn' is has a functional type, and applying 
+             -- applies when 'tFn' is has a functional type, and applying
              -- the current context to it as above should not change this.
              Nothing
               -> error "ddc-core.synthAppArg: unexpected type of function."
 
-        -- Effect of the overall application.
-        let effsResult  = Sum.unions kEffect
-                        $ [ effsFn, effsArg, Sum.singleton kEffect effsLatent]
-        
-        -- Closure of the overall application.
-        let closResult  = Set.union closFn closArg
 
+        -- Result of evaluating the functional expression applied
+        -- to its argument.
+        let esExp       = Sum.unions kEffect
+                        $ [ effsFn, esArg, Sum.singleton kEffect esLatent]
+
+        -- The checked application.
+        let xExp'       = XApp  (AnTEC tResult' (TSum esExp) (tBot kClosure) a)
+                                xFn xArg'
+
+        -- If the function returns a suspension then automatically run it.
+        let (xExpRun, tExpRun, esExpRun)
+                | configImplicitRun (tableConfig table)
+                , DemandRun     <- demand
+                , Just (eExpRun', tExpRun') <- takeTSusp tResult'
+                = let   
+                        eTotal  = tSum kEffect [TSum esExp, eExpRun']
+
+                  in    ( XCast (AnTEC tResult' eTotal (tBot kClosure) a)
+                                CastRun xExp'
+                        , tExpRun'
+                        , Sum.fromList kEffect [eTotal])
+
+                | otherwise
+                =       ( xExp'
+                        , tResult'
+                        , esExp)
+
         ctrace  $ vcat
-                [ text "* App Synth Fun"
-                , indent 2 $ ppr xx
-                , text "      tFn: " <> ppr tFn1
-                , text "     tArg: " <> ppr tArg1
-                , text "  tResult: " <> ppr tResult1
-                , indent 2 $ ppr ctx1
+                [ text "*<  App Synth Fun"
+                , indent 4 $ ppr xx
+                , text "    xArg    : " <> ppr xArg
+                , text "    tFn'    : " <> ppr tFn'
+                , text "    tArg'   : " <> ppr tArg'
+                , text "    xArg'   : " <> ppr xArg'
+                , text "    xExpRun : " <> ppr xExpRun
+                , text "    tExpRun : " <> ppr tExpRun
+                , indent 4 $ ppr ctx1
                 , empty ]
 
-        return  ( xFn, xArg'
-                , tResult, effsResult, closResult, ctx1)
+        return  (xExpRun, tExpRun, esExpRun, ctx1)
 
- 
+
  -- Applied expression is not a function.
  | otherwise
  =      throw $ ErrorAppNotFun a xx tFn
@@ -248,8 +302,5 @@
         TApp (TApp (TCon (TyConSpec TcConFun)) t11) t12
           -> Just (t11, tBot kEffect, tBot kClosure, t12)
 
-        TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFunEC)) t11) eff) clo) t12
-          -> Just (t11, eff, clo, t12)
-
         _ -> Nothing
-         
+
diff --git a/DDC/Core/Check/Judge/Type/Base.hs b/DDC/Core/Check/Judge/Type/Base.hs
--- a/DDC/Core/Check/Judge/Type/Base.hs
+++ b/DDC/Core/Check/Judge/Type/Base.hs
@@ -1,62 +1,68 @@
 
-module DDC.Core.Check.Judge.Type.Base 
+module DDC.Core.Check.Judge.Type.Base
         ( Checker
-        , Table (..)
+        , Demand (..)
+        , Table  (..)
         , returnX
+        , runForDemand
 
         , module DDC.Core.Check.Base
         , module DDC.Core.Check.Judge.Inst
         , module DDC.Core.Check.Judge.Sub
         , module DDC.Core.Check.Judge.Eq
-        , module DDC.Core.Check.TaggedClosure
         , module DDC.Core.Check.Witness
         , module DDC.Core.Check.Error
         , module DDC.Core.Transform.Reannotate
         , module DDC.Core.Transform.SubstituteTX
-        , module DDC.Core.Annot.AnTEC
+        , module DDC.Core.Exp.Annot.AnTEC
 
         , module DDC.Type.Transform.SubstituteT
         , module DDC.Type.Transform.Instantiate
-        , module DDC.Type.Transform.Crush
-        , module DDC.Type.Transform.LiftT
-        , module DDC.Type.Transform.Trim)
+        , module DDC.Type.Transform.BoundT)
 where
 import DDC.Core.Check.Base
 import DDC.Core.Check.Judge.Inst
 import DDC.Core.Check.Judge.Sub
 import DDC.Core.Check.Judge.Eq
-import DDC.Core.Check.TaggedClosure
 import DDC.Core.Check.Witness
 import DDC.Core.Check.Error
 import DDC.Core.Transform.Reannotate
 import DDC.Core.Transform.SubstituteTX
-import DDC.Core.Annot.AnTEC
+import DDC.Core.Exp.Annot.AnTEC
 
 import DDC.Type.Transform.SubstituteT
 import DDC.Type.Transform.Instantiate
-import DDC.Type.Transform.Crush
-import DDC.Type.Transform.LiftT
-import DDC.Type.Transform.Trim
+import DDC.Type.Transform.BoundT
 
 
+-- | Demand placed on suspensions by the surrounding context.
+data Demand
+        -- | Run suspensions as we encounter them.
+        = DemandRun
+
+        -- | Ignore suspensions, don't run them.
+        | DemandNone
+        deriving Show
+
+
 -- | Type of the function that checks some node of the core AST.
 type Checker a n
-        =  (Show n, Ord n, Pretty n)
+        =  (Show a, Show n, Ord n, Pretty n)
         => Table a n                    -- ^ Static configuration.
         -> Context n                    -- ^ Input context.
-        -> Exp a n                      -- ^ Expression to check.
         -> Mode n                       -- ^ Type checker mode.
+        -> Demand                       -- ^ Demand on the expression.
+        -> Exp a n                      -- ^ Expression to check.
         -> CheckM a n
                 ( Exp (AnTEC a n) n     -- Annotated, checked expression.
                 , Type n                -- Type of the expression.
                 , TypeSum n             -- Effect sum of expression.
-                , Set (TaggedClosure n) -- Closure of expression.
                 , Context n)            -- Output context.
 
 
 -- | Table of environment things that do not change during type checking
 --
---   We've got the static config, 
+--   We've got the static config,
 --    global kind and type environments,
 --    and a type checking function for each node of the AST.
 --
@@ -80,33 +86,78 @@
         , tableCheckLet         :: Checker a n
         , tableCheckLetPrivate  :: Checker a n
         , tableCheckCase        :: Checker a n
-        , tableCheckCast        :: Checker a n 
+        , tableCheckCast        :: Checker a n
         , tableCheckWitness     :: Checker a n }
 
 
 -- | Helper function for building the return value of checkExpM'
 --   It builts the AnTEC annotation and attaches it to the new AST node,
 --   as well as returning the current effect and closure in the appropriate
---   form as part of the tuple. 
-returnX :: Ord n 
+--   form as part of the tuple.
+returnX :: Ord n
         => a                            -- ^ Annotation for the returned expression.
-        -> (AnTEC a n 
+        -> (AnTEC a n
                 -> Exp (AnTEC a n) n)   -- ^ Fn to build the returned expression.
         -> Type n                       -- ^ Type of expression.
         -> TypeSum n                    -- ^ Effect sum of expression.
-        -> Set (TaggedClosure n)        -- ^ Closure of expression.
         -> Context n                    -- ^ Input context.
-        -> CheckM a n 
+        -> CheckM a n
                 ( Exp (AnTEC a n) n     -- Annotated, checked expression.
                 , Type n                -- Type of expression.       (id to above)
                 , TypeSum n             -- Effect sum of expression. (id to above)
-                , Set (TaggedClosure n) -- Closure of expression.    (id to above)
                 , Context n)            -- Output context.
 
-returnX !a !f !t !es !cs !ctx
+returnX !a !f !t !es !ctx
  = let  e       = TSum es
-        c       = closureOfTaggedSet cs
-   in   return  (f (AnTEC t e c a)
-                , t, es, cs, ctx)
+   in   return  (f (AnTEC t e (tBot kClosure) a)
+                , t, es, ctx)
 {-# INLINE returnX #-}
+
+
+-- Run ------------------------------------------------------------------------
+-- | If an expression has suspension type then run it.
+runForDemand 
+        :: Ord n
+        => Config n                     -- ^ Type checker config.
+        -> a                            -- ^ Annotation for new
+        -> Demand                       -- ^ Demand placed on expression.
+        -> Exp    (AnTEC a n) n         -- ^ Expression to inspect.
+        -> Type   n                     -- ^ Type of the expression.
+        -> Effect n                     -- ^ Effect of the expression.
+        -> CheckM a n
+                ( Exp (AnTEC a n) n     -- New expression, possibly with run cast.
+                , Type   n              -- New type of expression.
+                , Effect n)             -- New effect of expression.
+
+runForDemand _config _a DemandNone xExp tExp eExp 
+ = return (xExp, tExp, eExp)
+
+runForDemand config a  DemandRun  xExp tExp eExp
+
+ -- If the expression is wrapped in an explicit box or run then
+ -- don't run it again. Doing this will just confuse the client
+ -- programmer.
+ | isXCastBox xExp || isXCastRun xExp
+ = return (xExp, tExp, eExp)
+
+ -- Insert an implicit run cast for this suspension.
+ | configImplicitRun config
+ , Just (eResult, tResult)  <- takeTSusp tExp
+ = let
+        -- Effect of overall expression is effect of computing
+        -- the suspension plus the effect we get by running 
+        -- that suspension.
+        eTotal  = tSum kEffect [eExp, eResult]
+
+        -- Annotation for the cast expression.
+        aCast   = AnTEC tResult eTotal (tBot kClosure) a
+
+   in   return  ( XCast aCast CastRun xExp
+                , tResult
+                , eTotal)
+
+ | otherwise
+ = return (xExp, tExp, eExp)
+
+
 
diff --git a/DDC/Core/Check/Judge/Type/Case.hs b/DDC/Core/Check/Judge/Type/Case.hs
--- a/DDC/Core/Check/Judge/Type/Case.hs
+++ b/DDC/Core/Check/Judge/Type/Case.hs
@@ -4,14 +4,15 @@
 where
 import DDC.Core.Check.Judge.Type.Base
 import qualified DDC.Type.Sum   as Sum
-import qualified Data.Set       as Set
 import qualified Data.Map       as Map
 import Data.List                as L
 
 ---------------------------------------------------------------------------------------------------
 checkCase :: Checker a n
-checkCase !table !ctx0 xx@(XCase a xDiscrim alts) mode
- = do   let config      = tableConfig table
+checkCase !table !ctx0 mode demand 
+        xx@(XCase a xDiscrim alts)
+ = do   
+        let config      = tableConfig table
 
         -- There must be at least one alternative, even if there are no data
         -- constructors. The rest of the checking code assumes this, and will
@@ -20,16 +21,19 @@
          $ throw $ ErrorCaseNoAlternatives a xx
 
         -- Decide what mode to use when checking the discriminant.
-        (modeDiscrim, ctx1)     
+        (modeDiscrim, ctx1)
          <- takeDiscrimCheckModeFromAlts table a ctx0 mode alts
 
         -- Check the discriminant.
-        (xDiscrim', tDiscrim, effsDiscrim, closDiscrim, ctx2) 
-         <- tableCheckExp table table ctx1 xDiscrim modeDiscrim
+        --   We set the demand to 'Run' because if the scrutinee is a
+        --   suspension then we won't be able to destruct it, so we
+        --   might as well run it to get the result.
+        (xDiscrim', tDiscrim, effsDiscrim, ctx2)
+         <- tableCheckExp table table ctx1 modeDiscrim DemandRun xDiscrim 
 
         -- Split the type into the type constructor names and type parameters.
         -- Also check that it's algebraic data, and not a function or effect
-        -- type etc. 
+        -- type etc.
         (mDataMode, tsArgs)
          <- case takeTyConApps tDiscrim of
              Just (tc, ts)
@@ -46,7 +50,7 @@
               , takeResultKind k == kData
               -> return ( lookupModeOfDataType nTyCon (configDataDefs config)
                         , ts )
-                      
+
               -- Primitive data types.
               | TyConBound (UPrim nTyCon _) k <- tc
               , takeResultKind k == kData
@@ -55,9 +59,9 @@
 
              _ -> throw $ ErrorCaseScrutineeNotAlgebraic a xx tDiscrim
 
-        -- Get the mode of the data type, 
+        -- Get the mode of the data type,
         --   this tells us how many constructors there are.
-        dataMode    
+        dataMode
          <- case mDataMode of
              Nothing -> throw $ ErrorCaseScrutineeTypeUndeclared a xx tDiscrim
              Just m  -> return m
@@ -68,22 +72,22 @@
          <- case mode of
                 Recon   -> return (mode, ctx2)
                 Check{} -> return (mode, ctx2)
-                Synth   
+                Synth
                  -> do  iA       <- newExists kData
                         let tA   = typeOfExists iA
                         let ctx3 = pushExists iA ctx2
                         return (Check tA, ctx3)
 
         -- Check the alternatives.
-        (alts', tsAlts, effss, closs, ctx4)
-         <- checkAltsM table a xx tDiscrim tsArgs modeAlts alts ctx3
+        (alts', tsAlts, effss, ctx4)
+         <- checkAltsM table a xx tDiscrim tsArgs modeAlts demand alts ctx3
 
         -- Check that all the alternatives have the same type.
-        --   In Synth mode this is enforced by passing down an existential to 
+        --   In Synth mode this is enforced by passing down an existential to
         --   unifify against, but with Recon and Check modes we might get
         --   a different type for each alternative.
-        let tsAlts'     = map (applyContext ctx4) tsAlts
-        let tAlt : _    = tsAlts'
+        tsAlts'         <- mapM (applyContext ctx4) tsAlts
+        let tAlt : _    =  tsAlts'
         forM_ tsAlts' $ \tAlt'
          -> when (not $ equivT tAlt tAlt')
           $ throw $ ErrorCaseAltResultMismatch a xx tAlt tAlt'
@@ -94,10 +98,17 @@
         -- Check that alternatives are exhaustive.
         checkAltsExhaustive a xx dataMode alts
 
-        let effsMatch    
-                = Sum.singleton kEffect 
-                $ crushEffect $ tHeadRead tDiscrim
+        -- Effect due to inspecting the scrutinee.
+        let effsMatch
+                = Sum.singleton kEffect
+                $ tHeadRead tDiscrim
 
+        -- Effect of overall expression.
+        let effTotal
+                = crushEffect (configGlobalCaps config)
+                $ TSum $ Sum.unions kEffect
+                $ effsDiscrim : effsMatch : effss
+
         ctrace  $ vcat
                 [ text "* Case"
                 , text "  modeDiscrim"  <+> ppr modeDiscrim
@@ -111,21 +122,20 @@
         returnX a
                 (\z -> XCase z xDiscrim' alts')
                 tAlt
-                (Sum.unions kEffect (effsDiscrim : effsMatch : effss))
-                (Set.unions         (closDiscrim : closs))
+                (Sum.fromList kEffect [effTotal])
                 ctx4
 
-checkCase _ _ _ _
+checkCase _ _ _ _ _
         = error "ddc-core.checkCase: no match"
 
 
 ---------------------------------------------------------------------------------------------------
 -- | Decide what type checker mode to use when checking the discriminant
---   of a case expression. 
+--   of a case expression.
 --
 --   With plain type reconstruction then we also reconsruct the discrim type.
 --
---   With bidirectional checking we use the type of the patterns as 
+--   With bidirectional checking we use the type of the patterns as
 --   the expected type when checking the discriminant.
 --
 takeDiscrimCheckModeFromAlts
@@ -135,7 +145,7 @@
         -> Context n          -- ^ Current context.
         -> Mode n             -- ^ Mode for checking enclosing case expression.
         -> [Alt a n]          -- ^ Alternatives in the case expression.
-        -> CheckM a n 
+        -> CheckM a n
                 ( Mode n
                 , Context n)
 
@@ -152,25 +162,25 @@
         tsPats       <- liftM catMaybes $ mapM (dataTypeOfPat table a) pats
 
         case tsPats of
-         -- We only have a default pattern, 
+         -- We only have a default pattern,
          -- so will need to synthesise the type of the discrim without
          -- an expected type.
-         [] 
+         []
           -> return (Synth, ctx)
 
          -- We have at least one non-default pattern, which we can use to
          -- determine how many existentials are needed to instantiate
          -- the quantifiers of its type.
-         tPat : _    
+         tPat : _
           | Just (bs, tBody) <- takeTForalls tPat
-          -> do  
+          -> do
                 -- existentials for all of the type parameters.
                 is        <- mapM  (\_ -> newExists kData) bs
                 let ts     = map typeOfExists is
                 let ctx'   = foldl (flip pushExists) ctx is
                 let tBody' = substituteTs (zip bs ts) tBody
                 return (Check tBody', ctx')
-                
+
           | otherwise
           -> return (Check tPat, ctx)
 
@@ -178,26 +188,26 @@
 ---------------------------------------------------------------------------------------------------
 -- | Check some case alternatives.
 checkAltsM
-        :: (Show n, Pretty n, Ord n)
+        :: (Show a, Show n, Pretty n, Ord n)
         => Table a n            -- ^ Checker table.
         -> a                    -- ^ Annotation for error messages.
         -> Exp a n              -- ^ Whole case expression, for error messages.
         -> Type n               -- ^ Type of discriminant.
         -> [Type n]             -- ^ Args to type constructor of discriminant.
         -> Mode n               -- ^ Check mode for the alternatives.
+        -> Demand               -- ^ Demand on the result of the alternatives.
         -> [Alt a n]            -- ^ Alternatives to check.
         -> Context n            -- ^ Context to check the alternatives in.
         -> CheckM a n
                 ( [Alt (AnTEC a n) n]      -- Checked alternatives.
                 , [Type n]                 -- Type of alternative results.
                 , [TypeSum n]              -- Alternative effects.
-                , [Set (TaggedClosure n)]  -- Alternative closures
                 , Context n)
 
-checkAltsM !table !a !xx !tDiscrim !tsArgs !mode !alts0 !ctx
+checkAltsM !table !a !xx !tDiscrim !tsArgs !mode !demand !alts0 !ctx
  = checkAltsM1 alts0 ctx
- 
- where 
+
+ where
   -- Whether we're doing bidirectional type inference.
   bidir
    = case mode of
@@ -206,57 +216,57 @@
 
   -- Check all the alternatives monadically.
   checkAltsM1 [] ctx0
-   =    return ([], [], [], [], ctx0)
+   =    return ([], [], [], ctx0)
 
   checkAltsM1 (alt : alts) ctx0
-   = do (alt',  tAlt,  eAlt, cAlt, ctx1)
+   = do (alt',  tAlt,  eAlt, ctx1)
          <- checkAltM   alt ctx0
 
-        (alts', tsAlts, esAlts, csAlts, ctx2)
+        (alts', tsAlts, esAlts, ctx2)
          <- checkAltsM1 alts ctx1
 
         return  ( alt'  : alts'
                 , tAlt  : tsAlts
                 , eAlt  : esAlts
-                , cAlt  : csAlts
                 , ctx2)
 
   -- Check a single alternative.
   checkAltM   (AAlt PDefault xBody) !ctx0
-   = do   
+   = do
         -- Check the right of the alternative.
-        (xBody', tBody, effBody, cloBody, ctx1)
-                <- tableCheckExp table table ctx0 xBody mode
+        (xBody', tBody, effBody, ctx1)
+                <- tableCheckExp table table ctx0 mode demand xBody
 
         return  ( AAlt PDefault xBody'
                 , tBody
                 , effBody
-                , cloBody
                 , ctx1)
 
   checkAltM alt@(AAlt (PData dc bsArg) xBody) !ctx0
-   = do 
+   = do
         -- Get the constructor type associated with this pattern.
         Just tCtor <- ctorTypeOfPat table a (PData dc bsArg)
-         
-        -- Take the type of the constructor and instantiate it with the 
-        -- type arguments we got from the discriminant. If the ctor type 
-        -- doesn't instantiate then it won't have enough foralls on the front, 
+
+        -- Take the type of the constructor and instantiate it with the
+        -- type arguments we got from the discriminant. If the ctor type
+        -- doesn't instantiate then it won't have enough foralls on the front,
         -- which should have been checked by the def checker.
-        tCtor_inst      
-         <- case instantiateTs tCtor tsArgs of
-                Nothing -> throw $ ErrorCaseCannotInstantiate a xx tDiscrim tCtor
-                Just t  -> return t
-        
+        tCtor_inst
+         <- if equivT tCtor tDiscrim
+             then return tCtor
+             else case instantiateTs tCtor tsArgs of
+                   Nothing -> throw $ ErrorCaseCannotInstantiate a xx tDiscrim tCtor
+                   Just t  -> return t
+
         -- Split the constructor type into the field and result types.
-        let (tsFields_ctor, tResult) 
+        let (tsFields_ctor, tResult)
                 = takeTFunArgResult tCtor_inst
 
         -- The result type of the constructor must match the discriminant type.
         -- If it doesn't then the constructor in the pattern probably isn't for
         -- the discriminant type.
         when (not $ equivT tDiscrim tResult)
-         $ throw $ ErrorCaseScrutineeTypeMismatch a xx 
+         $ throw $ ErrorCaseScrutineeTypeMismatch a xx
                         tDiscrim tResult
 
         -- There must be at least as many fields as variables in the pattern.
@@ -268,28 +278,21 @@
         -- Merge the field types we get by instantiating the constructor
         -- type with possible annotations from the source program.
         -- If the annotations don't match, then we throw an error.
-        (tsFields, ctx1) 
-                <- checkFieldAnnots table bidir a xx       
-                        (zip tsFields_ctor (map typeOfBind bsArg))
-                        ctx0
+        (tsFields, ctx1)
+         <- checkFieldAnnots table bidir a xx
+                (zip tsFields_ctor (map typeOfBind bsArg))
+                ctx0
 
         -- Extend the environment with the field types.
         let bsArg'         = zipWith replaceTypeOfBind tsFields bsArg
         let (ctx2, posArg) = markContext ctx1
         let ctxArg         = pushTypes bsArg' ctx2
-        
-        -- Check the body in this new environment.
-        (xBody', tBody, effsBody, closBody, ctxBody)
-                 <- tableCheckExp table table ctxArg xBody mode
 
-        -- Cut closure terms due to locally bound value vars.
-        -- This also lowers deBruijn indices in un-cut closure terms.
-        let closBody_cut 
-                = Set.fromList
-                $ mapMaybe (cutTaggedClosureXs bsArg')
-                $ Set.toList closBody
+        -- Check the body in this new environment.
+        (xBody', tBody, effsBody, ctxBody)
+                <- tableCheckExp table table ctxArg mode demand xBody
 
-        let tBody'      = applyContext ctxBody tBody
+        tBody'  <- applyContext ctxBody tBody
 
         -- Pop the argument types from the context.
         let ctx_cut     = popToPos posArg ctxBody
@@ -305,26 +308,25 @@
                 , empty ]
 
         -- We're returning the new context for kicks,
-        -- but the caller doesn't use it because we don't want the order of 
+        -- but the caller doesn't use it because we don't want the order of
         -- alternatives to matter for type inference.
         return  ( AAlt (PData dc bsArg') xBody'
                 , tBody'
                 , effsBody
-                , closBody_cut
                 , ctx_cut)
 
 
 -- Fields -----------------------------------------------------------------------------------------
 -- | Check the inferred type for a field against any annotation for it.
-checkFieldAnnots 
-        :: (Ord n, Pretty n)
+checkFieldAnnots
+        :: (Show a, Show n, Ord n, Pretty n)
         => Table a n            -- ^ Checker table.
         -> Bool                 -- ^ Use bi directional type inference.
         -> a                    -- ^ Annotation for error messages.
         -> Exp a n              -- ^ Whole case expression for error messages.
         -> [(Type n, Type n)]   -- ^ List of inferred and annotation types.
         -> Context n
-        -> CheckM a n 
+        -> CheckM a n
                 ( [Type n]      --   Final types for each field.
                 , Context n)    --   Result context.
 
@@ -335,19 +337,19 @@
            -> do (tField,   ctx1)  <- checkFieldAnnot tActual tAnnot ctx0
                  (tsFields, ctx')  <- checkFieldAnnots table bidir a xx tts' ctx1
                  return (tField : tsFields, ctx')
-                 
+
  where checkFieldAnnot tActual tAnnot ctx
         -- Annotation is bottom, so use the inferred type of the field.
-        | isBot tAnnot      
+        | isBot tAnnot
         = return (tActual, ctx)
 
-        -- With bidirectional checking, annotations on fields can refine the 
+        -- With bidirectional checking, annotations on fields can refine the
         -- inferred type for the overal expression.
         | bidir
         = do    ctx'    <- makeEq (tableConfig table) a ctx tAnnot tActual
-                        $  ErrorCaseFieldTypeMismatch a xx tAnnot tActual
+                        $  ErrorCaseFieldTypeMismatch a xx  tAnnot tActual
 
-                let tField = applyContext ctx' tActual
+                tField  <- applyContext ctx' tActual
                 return  (tField, ctx')
 
         -- In Recon mode, if there is an annotation on the field then it needs
@@ -357,18 +359,18 @@
         = return (tAnnot, ctx)
 
         -- Annotation does not match actual type.
-        | otherwise       
+        | otherwise
         = throw $ ErrorCaseFieldTypeMismatch a xx tAnnot tActual
 
 
 -- Ctor Types -------------------------------------------------------------------------------------
 -- | Get the constructor type associated with a pattern, or Nothing for the
---   default pattern. If the data constructor isn't defined then the spread 
+--   default pattern. If the data constructor isn't defined then the spread
 --   transform won't have given it a proper type.
 --   Note that we can't simply check whether the constructor is in the
 ---  environment because literals like 42# never are.
 ctorTypeOfPat
-        :: Ord n 
+        :: Ord n
         => Table a n            -- ^ Checker table.
         -> a                    -- ^ Annotation for error messages.
         -> Pat n                -- ^ Pattern.
@@ -378,11 +380,11 @@
  = case dc of
         DaConUnit   -> return $ Just $ tUnit
         DaConPrim{} -> return $ Just $ daConType dc
-     
+
         DaConBound n
          -- Types of algebraic data ctors should be in the defs table.
-         |  Just ctor <- Map.lookup n 
-                                $ dataDefsCtors 
+         |  Just ctor <- Map.lookup n
+                                $ dataDefsCtors
                                 $ configDataDefs $ tableConfig table
          -> return $ Just $ typeOfDataCtor ctor
 
@@ -399,8 +401,8 @@
 --   Yields  the data type with outer quantifiers for its type parametrs.
 --   For example, given pattern (Cons x xs), return (forall [a : Data]. List a)
 --
-dataTypeOfPat 
-        :: Ord n 
+dataTypeOfPat
+        :: Ord n
         => Table a n            -- ^ Checker table.
         -> a                    -- ^ Annotation for error messages.
         -> Pat n                -- ^ Pattern.
@@ -414,7 +416,7 @@
          Just tCtor -> return $ Just $ eat [] tCtor
 
  where  eat bs tt
-         = case tt of  
+         = case tt of
                 TForall b t        -> eat (bs ++ [b]) t
                 TApp{}
                  |  Just (_t1, t2) <- takeTFun tt
@@ -423,7 +425,7 @@
 
 
 ---------------------------------------------------------------------------------------------------
--- | Check for overlapping alternatives, 
+-- | Check for overlapping alternatives,
 --   and throw an error in the `CheckM` monad if there are any.
 checkAltsOverlapping
         :: Eq n
@@ -472,7 +474,7 @@
 
 checkAltsExhaustive a xx mode alts
  = do   let nsCtorsMatched      = mapMaybe takeCtorNameOfAlt alts
-        
+
         -- Check that alternatives are exhaustive.
         case mode of
 
@@ -489,13 +491,13 @@
            -> throw $ ErrorCaseNonExhaustive a xx nsCtorsMissing
 
            -- All constructors were matched.
-           | otherwise 
+           | otherwise
            -> return ()
 
           -- Large types have an effectively infinite number of constructors
           -- (like integer literals), so there needs to be a default alt.
-          DataModeLarge 
+          DataModeLarge
            | any isPDefault [p | AAlt p _ <- alts] -> return ()
-           | otherwise  
+           | otherwise
            -> throw $ ErrorCaseNonExhaustiveLarge a xx
 
diff --git a/DDC/Core/Check/Judge/Type/Cast.hs b/DDC/Core/Check/Judge/Type/Cast.hs
--- a/DDC/Core/Check/Judge/Type/Cast.hs
+++ b/DDC/Core/Check/Judge/Type/Cast.hs
@@ -1,32 +1,32 @@
 
 module DDC.Core.Check.Judge.Type.Cast
-        (checkCast)
+        ( checkCast)
 where
 import DDC.Core.Check.Judge.Type.Sub
 import DDC.Core.Check.Judge.Type.Base
 import qualified DDC.Type.Sum   as Sum
-import qualified Data.Set       as Set
 
 
 checkCast :: Checker a n
 
 -- WeakenEffect ---------------------------------------------------------------
 -- Weaken the effect of an expression.
-checkCast !table !ctx0 xx@(XCast a (CastWeakenEffect eff) x1) mode
+checkCast !table !ctx0 mode _demand
+        xx@(XCast a (CastWeakenEffect eff) x1)
  = do   let config      = tableConfig  table
         let kenv        = tableKindEnv table
 
         -- Check the effect term.
-        (eff', kEff, ctx1) 
-         <- checkTypeM config kenv ctx0 UniverseSpec eff 
+        (eff', kEff, ctx1)
+         <- checkTypeM config kenv ctx0 UniverseSpec eff
           $ case mode of
                 Recon   -> Recon
                 Synth   -> Check kEffect
                 Check _ -> Check kEffect
 
         -- Check the body.
-        (x1', t1, effs, clo, ctx2)
-         <- tableCheckExp table table ctx1 x1 mode
+        (x1', t1, effs, ctx2)
+         <- tableCheckExp table table ctx1 mode DemandNone x1
 
         -- The effect term must have Effect kind.
         when (not $ isEffectKind kEff)
@@ -36,43 +36,17 @@
         let effs'  = Sum.insert eff' effs
 
         returnX a (\z -> XCast z c' x1')
-                t1 effs' clo ctx2
-                
-
--- WeakenClosure --------------------------------------------------------------
--- Weaken the closure of an expression.
---
--- DEPRECATED: Closures are being removed in the next version,
---             so we don't bother doing proper type inference for closure
---             weakenings.
---
-checkCast !table !ctx (XCast a (CastWeakenClosure xs) x1) mode
- = do   
-        -- Check the contained expressions.
-        --  Just ditch the resulting contexts because they shouldn't
-        --  contain expression that need types infered.
-        (xs', closs, _ctx)
-                <- liftM unzip3
-                $   mapM (\x -> checkArgM table ctx x Recon) xs
-
-        -- Check the body.
-        (x1', t1, effs, clos, ctx1)
-                <- tableCheckExp table table ctx x1 mode
-        
-        let c'     = CastWeakenClosure xs'
-        let closs' = Set.unions (clos : closs)
-
-        returnX a (\z -> XCast z c' x1')
-                t1 effs closs' ctx1
+                t1 effs' ctx2
 
 
 -- Purify ---------------------------------------------------------------------
 -- Purify the effect of an expression.
--- 
+--
 -- EXPERIMENTAL: The Tetra language doesn't have purification casts yet,
 --               so proper type inference isn't implemented.
--- 
-checkCast !table !ctx xx@(XCast a (CastPurify w) x1) mode
+--
+checkCast !table !ctx mode _demand 
+        xx@(XCast a (CastPurify w) x1)
  = do   let config      = tableConfig table
         let kenv        = tableKindEnv table
         let tenv        = tableTypeEnv table
@@ -82,8 +56,8 @@
         let wTEC  = reannotate fromAnT w'
 
         -- Check the body.
-        (x1', t1, effs, clo, ctx1)
-         <- tableCheckExp table table ctx x1 mode
+        (x1', t1, effs, ctx1)
+         <- tableCheckExp table table ctx mode DemandNone x1
 
         -- The witness must have type (Pure e), for some effect e.
         effs' <- case tW of
@@ -93,135 +67,115 @@
 
         let c'  = CastPurify wTEC
         returnX a (\z -> XCast z c' x1')
-                t1 effs' clo ctx1
-
-
--- Forget ---------------------------------------------------------------------
--- Forget the closure of an expression.
---
--- DEPRECATED: Closures are being removed in the next version,
---             so we don't bother doing proper type inference for forget casts.
--- 
-checkCast !table !ctx xx@(XCast a (CastForget w) x1) mode
- = do   let config      = tableConfig table
-        let kenv        = tableKindEnv table
-        let tenv        = tableTypeEnv table
-
-        -- Check the witness.
-        (w', tW)  <- checkWitnessM config kenv tenv ctx w
-        let wTEC  = reannotate fromAnT w'
-
-        -- Check the body.
-        (x1', t1, effs, clos, ctx1)  
-         <- tableCheckExp table table ctx x1 mode
-
-        -- The witness must have type (Empty c), for some closure c.
-        clos' <- case tW of
-                  TApp (TCon (TyConWitness TwConEmpty)) cloMask
-                    -> return $ maskFromTaggedSet 
-                                        (Sum.singleton kClosure cloMask)
-                                        clos
-
-                  _ -> throw $ ErrorWitnessNotEmpty a xx w tW
-
-        let c'  = CastForget wTEC
-        returnX a (\z -> XCast z c' x1')
-                t1 effs clos' ctx1
+                t1 effs' ctx1
 
 
 -- Box ------------------------------------------------------------------------
 -- Box a computation,
 -- capturing its effects in a computation type.
-checkCast !table ctx0 xx@(XCast a CastBox x1) mode
+checkCast !table ctx0 mode _demand 
+        xx@(XCast a CastBox x1)
  = case mode of
     Check tExpected
-     -> do      
+     -> do
         let config      = tableConfig table
 
         -- Check the body.
-        (x1', tBody, effs, clos, ctx1)     
-         <- tableCheckExp table table ctx0 x1 Synth
+        (x1', tBody, effs, ctx1)
+         <- tableCheckExp table table ctx0 Synth DemandRun x1
 
+        let effs_crush 
+                = Sum.fromList kEffect
+                [ crushEffect (configGlobalCaps config) (TSum effs)]
+
         -- The actual type is (S eff tBody).
-        let tBody'      = applyContext ctx1 tBody
-        let tActual     = tApps (TCon (TyConSpec TcConSusp)) [TSum effs, tBody']
+        tBody'      <- applyContext ctx1 tBody
+        let tActual =  tApps (TCon (TyConSpec TcConSusp)) 
+                             [TSum effs_crush, tBody']
 
         -- The actual type needs to match the expected type.
         -- We're treating the S constructor as invariant in both positions,
         --  so we use 'makeEq' here instead of 'makeSub'
-        let tExpected'  = applyContext ctx1 tExpected
-        ctx2    <- makeEq config a ctx1 tActual tExpected'
-                $  ErrorMismatch a      tActual tExpected' xx
+        tExpected'  <- applyContext ctx1 tExpected
+        ctx2        <- makeEq config a ctx1 tActual tExpected'
+                    $  ErrorMismatch a      tActual tExpected' xx
 
         returnX a (\z -> XCast z CastBox x1')
-                tExpected (Sum.empty kEffect) clos ctx2
+                tExpected (Sum.empty kEffect) ctx2
 
     -- Recon and Synth mode.
     _
      -> do
+        let config      = tableConfig table
+
         -- Check the body.
-        (x1', t1, effs, clos, ctx1) 
-         <- tableCheckExp table table ctx0 x1 mode
+        (x1', t1, effs,  ctx1)
+         <- tableCheckExp table table ctx0 mode DemandRun x1
 
+        let effs_crush 
+                = Sum.fromList kEffect
+                [ crushEffect (configGlobalCaps config) (TSum effs)]
+
         -- The result type is (S effs a).
         let tS  = tApps (TCon (TyConSpec TcConSusp))
-                        [TSum effs, t1]
+                        [TSum effs_crush, t1]
 
         returnX a (\z -> XCast z CastBox x1')
-                tS (Sum.empty kEffect) clos ctx1
+                tS (Sum.empty kEffect) ctx1
 
 
 -- Run ------------------------------------------------------------------------
 -- Run a suspended computation,
 -- releasing its effects into the environment.
-checkCast !table !ctx0 xx@(XCast a CastRun xBody) mode
+checkCast !table !ctx0 mode _demand
+        xx@(XCast a CastRun xBody)
  = case mode of
     Recon
      -> do
         -- Check the body.
-        (xBody', tBody, effs, clos, ctx1)
-         <- tableCheckExp table table ctx0 xBody Recon
+        (xBody', tBody, effs, ctx1)
+         <- tableCheckExp table table ctx0 Recon DemandNone xBody
 
         -- The body must have type (S eff a),
         --  and the result has type 'a' while unleashing effect 'eff'.
         case tBody of
          TApp (TApp (TCon (TyConSpec TcConSusp)) eff2) tResult
           -> do
-                -- Check that the context has the capability to support 
+                -- Check that the context has the capability to support
                 -- this effect.
                 let config      = tableConfig table
                 checkEffectSupported config a xx ctx0 eff2
 
                 returnX a
                         (\z -> XCast z CastRun xBody')
-                        tResult 
+                        tResult
                         (Sum.union effs (Sum.singleton kEffect eff2))
-                        clos ctx1
+                        ctx1
 
          _ -> throw $ ErrorRunNotSuspension a xx tBody
 
     Synth
      -> do
         -- Synthesize a type for the body.
-        (xBody', tBody, effs, clos, ctx1)
-         <- tableCheckExp table table ctx0 xBody Synth
+        (xBody', tBody, effs, ctx1)
+         <- tableCheckExp table table ctx0 Synth DemandNone xBody
 
         -- Run the body,
         -- which needs to have been resolved to a computation type.
-        let tBody'      = applyContext ctx1 tBody
+        tBody'  <- applyContext ctx1 tBody
         (tResult, effsSusp, ctx2)
          <- synthRunSusp table a xx ctx1 tBody'
 
-        returnX a 
+        returnX a
                 (\z -> XCast z CastRun xBody')
                 tResult
                 (Sum.union effs (Sum.singleton kEffect effsSusp))
-                clos ctx2
+                ctx2
 
     Check tExpected
-     -> checkSub table a ctx0 xx tExpected
+     -> checkSub table a ctx0 DemandNone xx tExpected
 
-checkCast _ _ _ _
+checkCast _ _ _ _ _
         = error "ddc-core.checkCast: no match"
 
 
@@ -239,8 +193,8 @@
                 , Effect n      -- Effects unleashed by running the computation.
                 , Context n)    -- Result context.
 
-synthRunSusp table a xx ctx0 tt 
- 
+synthRunSusp table a xx ctx0 tt
+
  -- Rule (Run Synth exists)
  -- If the type of the suspension has not been resolved then we don't know
  -- what effects it has, and thus cannot check if running them is supported
@@ -260,52 +214,13 @@
  -- Run expression is not a suspension.
  | otherwise
  =      throw $ ErrorRunNotSuspension a xx tt
- 
 
--- Arg ------------------------------------------------------------------------
--- | Like `checkExp` but we allow naked types and witnesses.
-checkArgM 
-        :: (Show n, Pretty n, Ord n)
-        => Table a n            -- ^ Static config.
-        -> Context n            -- ^ Input context.
-        -> Exp a n              -- ^ Expression to check.
-        -> Mode n               -- ^ Checking mode.
-        -> CheckM a n 
-                ( Exp (AnTEC a n) n
-                , Set (TaggedClosure n)
-                , Context n)
 
-checkArgM !table !ctx0 !xx !mode
- = let  config  = tableConfig  table
-        tenv    = tableTypeEnv table
-        kenv    = tableKindEnv table
-   in case xx of
-        XType a t
-         -> do  (t', k, ctx1) <- checkTypeM config kenv ctx0 UniverseSpec t Recon
-                let Just clo = taggedClosureOfTyArg kenv ctx1 t
-                let a'   = AnTEC k (tBot kEffect) (tBot kClosure) a
-                return  ( XType a' t'
-                        , clo
-                        , ctx1)
-
-        XWitness a w
-         -> do  (w', t) <- checkWitnessM config kenv tenv ctx0 w
-                let a'   = AnTEC t (tBot kEffect) (tBot kClosure) a
-                return  ( XWitness a' (reannotate fromAnT w')
-                        , Set.empty
-                        , ctx0)
-
-        _ -> do
-                (xx', _, _, clos, ctx1) 
-                        <- tableCheckExp table table ctx0 xx mode
-                return  (xx', clos, ctx1)
-                        
-
 -- Support --------------------------------------------------------------------
--- | Check if the provided effect is supported by the context, 
+-- | Check if the provided effect is supported by the context,
 --   if not then throw an error.
-checkEffectSupported 
-        :: Ord n 
+checkEffectSupported
+        :: (Show n, Ord n)
         => Config n             -- ^ Static config.
         -> a                    -- ^ Annotation for error messages.
         -> Exp a n              -- ^ Expression for error messages.
@@ -317,4 +232,5 @@
  = case effectSupported eff ctx of
         Nothing         -> return ()
         Just effBad     -> throw $ ErrorRunNotSupported a xx effBad
- 
+
+
diff --git a/DDC/Core/Check/Judge/Type/DaCon.hs b/DDC/Core/Check/Judge/Type/DaCon.hs
--- a/DDC/Core/Check/Judge/Type/DaCon.hs
+++ b/DDC/Core/Check/Judge/Type/DaCon.hs
@@ -23,7 +23,7 @@
      -> return tUnit
 
     -- Primitive data constructors need to have a corresponding data type,
-    -- but there may be too many constructors to list, like with Int literals. 
+    -- but there may be too many constructors to list, like with Int literals.
     --
     -- The mode field in the data type declaration says what to expect.
     --    If the mode is 'Small' the data constructor needs to be listed,
diff --git a/DDC/Core/Check/Judge/Type/LamT.hs b/DDC/Core/Check/Judge/Type/LamT.hs
--- a/DDC/Core/Check/Judge/Type/LamT.hs
+++ b/DDC/Core/Check/Judge/Type/LamT.hs
@@ -5,16 +5,17 @@
 import DDC.Core.Check.Judge.Type.Sub
 import DDC.Core.Check.Judge.Type.Base
 import qualified DDC.Type.Sum   as Sum
-import qualified Data.Set       as Set
 
 
 -- Check a spec abstraction.
 checkLamT :: Checker a n
-checkLamT !table !ctx xx mode
+checkLamT !table !ctx mode _demand xx 
  = case xx of
-        XLAM a b1 x2    -> checkLAM table ctx a b1 x2 mode
-        _               -> error "ddc-core.checkLamT: no match."
+        XLAM a b1 x2
+           -> checkLAM table ctx a b1 x2 mode
+        _  -> error "ddc-core.checkLamT: no match."
 
+
 -- When reconstructing the type of a type abstraction,
 --  the formal parameter must have a kind annotation: eg (/\v : K. x2)
 checkLAM !table !ctx0 a b1 x2 Recon
@@ -43,19 +44,22 @@
         when (not (sA == sComp) && not (sA == sProp))
          $ throw $ ErrorLAMParamBadSort a xx b1 sA
 
-        
+
         -- Check the body -----------------------
         let (ctx2, pos1) = markContext ctxA
         let ctx3         = pushKind b1' RoleAbstract ctx2
         let ctx4         = liftTypes 1  ctx3
 
-        (x2', t2, e2, c2, ctx5)
-         <- tableCheckExp table table ctx4 x2 Recon
-        
+        -- Set the demand to 'None' because we don't want to force out
+        -- suspensions. If the body of a type abstraction has any effects
+        -- then this is a type error.
+        (x2', t2, e2, ctx5)
+         <- tableCheckExp table table ctx4 Recon DemandNone x2 
+
         -- Reconstruct the kind of the body.
-        (t2', k2, ctx6) 
+        (t2', k2, ctx6)
          <- checkTypeM config kenv ctx5 UniverseSpec t2 Recon
-        
+
         -- The type of the body must have data kind.
         when (not $ isDataKind k2)
          $ throw $ ErrorLamBodyNotData a xx b1 t2' k2
@@ -64,15 +68,10 @@
         when (e2 /= Sum.empty kEffect)
          $ throw $ ErrorLamNotPure a xx UniverseSpec (TSum e2)
 
-        -- Mask closure terms due to locally bound region vars.
-        let c2_cut      = Set.fromList
-                        $ mapMaybe (cutTaggedClosureT b1)
-                        $ Set.toList c2
-
         -- Cut the bound kind and elems under it from the context.
         let ctx_cut     = lowerTypes 1
                         $ popToPos pos1 ctx6
-                                   
+
         -- Build the result type.
         let tResult     = TForall b1' t2'
 
@@ -81,13 +80,12 @@
                 , indent 2 $ ppr (XLAM a b1' x2)
                 , text "  OUT: " <> ppr tResult
                 , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx_cut 
+                , indent 2 $ ppr ctx_cut
                 , empty ]
 
         returnX a
                 (\z -> XLAM z b1' x2')
-                tResult (Sum.empty kEffect) c2_cut
-                ctx_cut
+                tResult (Sum.empty kEffect) ctx_cut
 
 
 checkLAM !table !ctx0 a b1 x2 Synth
@@ -104,8 +102,8 @@
         -- If the annotation is missing then make a new existential for it.
         let kA  = typeOfBind b1
         (kA', sA, ctxA)
-         <- if isBot kA 
-             then do   
+         <- if isBot kA
+             then do
                 iA       <- newExists sComp
                 let kA'  = typeOfExists iA
                 let ctxA = pushExists   iA ctx0
@@ -125,29 +123,27 @@
         let ctx3         = pushKind b1' RoleAbstract ctx2
         let ctx4         = liftTypes 1  ctx3
 
-        (x2', t2, e2, c2, ctx5)
-         <- tableCheckExp table table ctx4 x2 Synth
-        
+        -- Set the demand to 'None' because we don't want to force out
+        -- suspensions. If the body of a type abstraction has any effects
+        -- then this is a type error.
+        (x2', t2, e2,ctx5)
+         <- tableCheckExp table table ctx4 Synth DemandNone x2 
+
         -- Force the kind of the body to be data.
         --  This is needed when the type of the body is an existential
         --  which doesn't yet have a resolved kind.
-        (_, _, ctx6) 
-         <- checkTypeM config kenv ctx5 UniverseSpec 
-                (applyContext ctx5 t2) (Check kData)
-        
+        t2'     <- applyContext ctx5 t2
+        (_, _, ctx6)
+         <- checkTypeM config kenv ctx5 UniverseSpec t2' (Check kData)
+
         -- The body of a spec abstraction must be pure.
         when (e2 /= Sum.empty kEffect)
          $ throw $ ErrorLamNotPure a xx UniverseSpec (TSum e2)
 
-        -- Mask closure terms due to locally bound region vars.
-        let c2_cut      = Set.fromList
-                        $ mapMaybe (cutTaggedClosureT b1)
-                        $ Set.toList c2
-
         -- Cut the bound kind and elems under it from the context.
         let ctx_cut     = lowerTypes 1
                         $ popToPos pos1 ctx6
-        
+
         -- Build the result type.
         let tResult     = TForall b1' t2
 
@@ -156,13 +152,12 @@
                 , indent 2 $ ppr (XLAM a b1' x2)
                 , text "  OUT: " <> ppr tResult
                 , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx_cut 
+                , indent 2 $ ppr ctx_cut
                 , empty ]
 
         returnX a
                 (\z -> XLAM z b1' x2')
-                tResult (Sum.empty kEffect) c2_cut
-                ctx_cut
+                tResult (Sum.empty kEffect) ctx_cut
 
 
 checkLAM !table !ctx0 a b1 x2 (Check (TForall b tBody))
@@ -184,14 +179,14 @@
         -- If both the kind annotation is missing and there is no
         -- expected kind then we need to make an existential for it.
         (kA', sA, ctxA)
-         <- if (isBot kParam && isBot kExpected) 
+         <- if (isBot kParam && isBot kExpected)
              then do
                 iA       <- newExists sComp
                 let kA'  = typeOfExists iA
                 let ctxA = pushExists   iA ctx0
                 return (kA', sComp, ctxA)
 
-             else if isBot kExpected 
+             else if isBot kExpected
               then do
                 checkTypeM config kenv ctx0 UniverseKind kParam Synth
 
@@ -218,9 +213,12 @@
                 Nothing -> return tBody
                 Just u1 -> return $ substituteT b (TVar u1) tBody
 
-        (x2', t2, e2, c2, ctx5)
-         <- tableCheckExp table table ctx4 x2 (Check tBody_skol)
-        
+        -- Set the demand to 'None' because we don't want to force out
+        -- suspensions. If the body of a type abstraction has any effects
+        -- then this is a type error.
+        (x2', t2, e2, ctx5)
+         <- tableCheckExp table table ctx4 (Check tBody_skol) DemandNone x2 
+
         -- Force the body of the spec abstraction must have data kind.
         --  This is needed when the type of the body is an existential
         --  which doesn't yet have a resolved kind.
@@ -231,21 +229,16 @@
         when (e2 /= Sum.empty kEffect)
          $ throw $ ErrorLamNotPure a xx UniverseSpec (TSum e2)
 
-        -- Mask closure terms due to locally bound region vars.
-        let c2_cut      = Set.fromList
-                        $ mapMaybe (cutTaggedClosureT b1)
-                        $ Set.toList c2
-
         -- Apply context to synthesised type.
-        -- We're about to pop the context back to how it was before the 
+        -- We're about to pop the context back to how it was before the
         -- type lambda, and want to keep information gained from synthing
         -- the body.
-        let t2_sub      = applyContext ctx6 t2'
+        t2_sub  <- applyContext ctx6 t2'
 
         -- Cut the bound kind and elems under it from the context.
         let ctx_cut     = lowerTypes 1
                         $ popToPos pos1 ctx6
-        
+
         -- Build the result type.
         let tResult     = TForall b1' t2_sub
 
@@ -254,14 +247,13 @@
                 , indent 2 $ ppr (XLAM a b1' x2)
                 , text "  OUT: " <> ppr tResult
                 , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx_cut 
+                , indent 2 $ ppr ctx_cut
                 , empty ]
 
         returnX a
                 (\z -> XLAM z b1' x2')
-                tResult (Sum.empty kEffect) c2_cut
-                ctx_cut
+                tResult (Sum.empty kEffect) ctx_cut
 
 checkLAM table ctx0 a b1 x2 (Check tExpected)
- = checkSub table a ctx0 (XLAM a b1 x2) tExpected
+ = checkSub table a ctx0 DemandNone (XLAM a b1 x2) tExpected
 
diff --git a/DDC/Core/Check/Judge/Type/LamX.hs b/DDC/Core/Check/Judge/Type/LamX.hs
--- a/DDC/Core/Check/Judge/Type/LamX.hs
+++ b/DDC/Core/Check/Judge/Type/LamX.hs
@@ -5,26 +5,29 @@
 import DDC.Core.Check.Judge.Type.Sub
 import DDC.Core.Check.Judge.Type.Base
 import qualified DDC.Type.Sum   as Sum
-import qualified Data.Set       as Set
 
 
 -- | Check a lambda abstraction.
 checkLamX :: Checker a n
-checkLamX !table !ctx xx mode
+
+checkLamX !table !ctx mode _demand xx
  = case xx of
-        XLam a b1 x2    -> checkLam table a ctx b1 x2 mode
-        _               -> error "ddc-core.checkLamX: no match."
+        XLam a b1 x2
+          -> checkLam table a ctx b1 x2 mode
+        _ -> error "ddc-core.checkLamX: no match."
 
+
 -- When reconstructing the type of a lambda abstraction,
 --  the formal parameter must have a type annotation: eg (\v : T. x2)
 checkLam !table !a !ctx !b1 !x2 !Recon
- = do   let config      = tableConfig table
+ = do
+        let config      = tableConfig table
         let kenv        = tableKindEnv table
         let xx          = XLam a b1 x2
 
         -- Check the parameter ------------------
         let t1          = typeOfBind b1
-        
+
         -- The formal parameter must have a type annotation.
         when (isBot t1)
          $ throw $ ErrorLamParamUnannotated a xx b1
@@ -38,40 +41,46 @@
         let (ctx', pos1) = markContext ctx
         let ctx1         = pushType b1 ctx'
 
-        (x2', t2, e2, c2, ctx2)
-         <- tableCheckExp table table ctx1 x2 Recon
+        -- It doesn't matter what we set the demand to at this point
+        -- because the 'Recon' mode doesn't use it. We'll just set it 
+        -- like the other modes to avoid confusion.
+        (x2', t2, e2, ctx2)
+         <- tableCheckExp table table ctx1 Recon DemandRun x2 
 
+        let e2_crush 
+                = Sum.fromList kEffect
+                [ crushEffect (configGlobalCaps config) (TSum e2)]
+
         -- The body of the function must produce data.
         (_, k2, _)      <- checkTypeM config kenv ctx2 UniverseSpec t2 Recon
         when (not $ isDataKind k2)
-         $ throw $ ErrorLamBodyNotData a xx b1 t2 k2 
-
-        -- Cut closure terms due to locally bound value vars.
-        -- This also lowers deBruijn indices in un-cut closure terms.
-        let c2_cut      = Set.fromList
-                        $ mapMaybe (cutTaggedClosureX b1)
-                        $ Set.toList c2
+         $ throw $ ErrorLamBodyNotData a xx b1 t2 k2
 
         -- Cut the bound type and elems under it from the context.
         let ctx_cut     = popToPos pos1 ctx2
-        
+
         -- Build result type --------------------
         -- Build the resulting function type.
         --   The way the effect and closure term is captured depends on
         --   the configuration flags.
-        (tResult, cResult)
-         <- makeFunctionType config a xx t1 k1 t2 e2 c2_cut
-        
-        returnX a
-                (\z -> XLam z b1' x2')
-                tResult (Sum.empty kEffect) cResult
-                ctx_cut
+        (xAbs', tAbs) 
+         <- makeFunction config a xx b1' t1 k1 x2' t2 e2_crush
 
+        return  ( xAbs'
+                , tAbs
+                , Sum.empty kEffect
+                , ctx_cut)
 
+
 -- When synthesizing the type of a lambda abstraction
 --   we produce a type (?1 -> ?2) with new unification variables.
 checkLam !table !a !ctx !b1 !x2 !Synth
- = do   let config      = tableConfig table     
+ = do
+        ctrace  $ vcat
+                [ text "*>  Lam SYNTH"
+                , text "    in  bind = " <+> ppr b1 ]
+
+        let config      = tableConfig table
         let kenv        = tableKindEnv table
         let xx          = XLam a b1 x2
 
@@ -81,7 +90,7 @@
         -- If there isn't an existing annotation then make an existential.
         (b1', t1', k1, ctx1)
          <- if isBot t1
-             then do 
+             then do
                 -- There is no annotation at all, so make an existential.
                 -- Missing anotations are assumed to have kind Data.
                 i1      <- newExists kData
@@ -89,7 +98,7 @@
                 let b1'  = replaceTypeOfBind t1' b1
                 let ctx1 = pushExists i1 ctx
                 return (b1', t1', kData, ctx1)
-                     
+
              else do
                 -- Check the existing annotation.
                 --   This also turns explit holes ? into existentials.
@@ -100,73 +109,78 @@
                 let b1' = replaceTypeOfBind t1' b1
                 return (b1', t1', k1, ctx1)
 
-        -- Check the body -----------------------        
+        -- Check the body -----------------------
         -- Make an existential for the result type.
         -- The type of a function abstraction has kind Data.
         i2              <- newExists kData
         let t2          = typeOfExists i2
-        
-        -- Push the existential for the result, 
+
+        -- Push the existential for the result,
         -- and parameter type onto the context.
         let (ctx2, pos1) = markContext 
                          $ pushExists i2 ctx1
         let ctx3         = pushType   b1' ctx2
 
         -- Check the body against the existential for it.
-        (x2', t2', e2, c2, ctx4)
-         <- tableCheckExp table table ctx3 x2 (Check t2)
+        --   Set the demand to 'Run' to force out any suspensions.
+        --   We'll box them up again just underneath the lambda
+        --   so that the effects from multiple computations get combined.
+        (x2', t2', e2, ctx4)
+         <- tableCheckExp table table ctx3 (Check t2) DemandRun x2 
 
+        let e2_crush 
+                = Sum.fromList kEffect
+                [ crushEffect (configGlobalCaps config) (TSum e2)]
+
         -- Force the kind of the body to be Data.
         --   This constrains the kind of polymorpic variables that are used
-        --   as the result of a function, like with (\x. x). 
+        --   as the result of a function, like with (\x. x).
         --   We know \x. can't bind a witness here.
-        (_, _, ctx5)    <- checkTypeM config kenv ctx4 UniverseSpec 
-                                (applyContext ctx4 t2')
-                                (Check kData)
+        t2''     <- applyContext ctx4 t2'
+        (_, _, ctx5)
+         <- checkTypeM config kenv ctx4 UniverseSpec t2'' (Check kData)
 
         -- Build the result type -------------
         -- If the kind of the parameter is unconstrained then default it
         -- to Data. This handles  "/\f. \(a : f Int#). ()"
-        let k1'        = applyContext ctx5 k1
+        k1'     <- applyContext ctx5 k1
         (k1'', ctx6)
          <- if isTExists k1'
              then do
                 ctx6    <- makeEq config a ctx5 k1' kData
                         $  ErrorMismatch a k1' kData xx
-                return (applyContext ctx6 k1', ctx6)
 
+                k1''    <- applyContext ctx6 k1'
+
+                return (k1'', ctx6)
+
              else do
                 return (k1', ctx5)
 
-        -- Cut closure terms due to locally bound value vars.
-        -- This also lowers deBruijn indices in un-cut closure terms.
-        let c2_cut      = Set.fromList
-                        $ mapMaybe (cutTaggedClosureX b1')
-                        $ Set.toList c2
- 
         -- Cut the bound type and elems under it from the context.
         let ctx_cut     = popToPos pos1 ctx6
 
         -- Build the resulting function type.
         --  This switches on the kind of the argument, so we need to apply
         --  the context to 'k1' to ensure it has all available information.
-        (tResult, cResult)
-         <- makeFunctionType config a (XLam a b1' x2) 
-                t1' k1''
-                t2' e2 c2_cut
+        (xAbs', tAbs)
+         <- makeFunction 
+                config a (XLam a b1' x2)
+                b1' t1' k1''
+                x2' t2' e2_crush
 
         ctrace  $ vcat
-                [ text "* Lam Synth"
-                , indent 2 $ ppr (XLam a b1' x2)
-                , text "  OUT: " <> ppr tResult
-                , indent 2 $ ppr ctx
-                , indent 2 $ ppr ctx_cut 
+                [ text "*<  Lam SYNTH"
+                , text "    in  bind = " <+> ppr b1
+                , text "    out type = " <+> ppr tAbs
+                , indent 4 $ ppr ctx
+                , indent 4 $ ppr ctx_cut
                 , empty ]
 
-        returnX a
-                (\z -> XLam z b1' x2')
-                tResult (Sum.empty kEffect) cResult
-                ctx_cut
+        return  ( xAbs'
+                , tAbs
+                , Sum.empty kEffect
+                , ctx_cut)
 
 
 -- When checking type type of a lambda abstraction against an existing
@@ -174,94 +188,157 @@
 --   type annotation, and in this case we replace it with the expected type.
 checkLam !table !a !ctx !b1 !x2 !(Check tExpected)
  | Just (tX1, tX2)      <- takeTFun tExpected
- = do   let config      = tableConfig table
+ = do   
+        ctrace  $ vcat
+                [ text "*>  Lam CHECK"
+                , text "    in bind =" <+> ppr b1
+                , text "    in type =" <+> ppr tExpected 
+                , empty ]
+
+        let config      = tableConfig table
         let kenv        = tableKindEnv table
         let xx          = XLam a b1 x2
 
         -- Check the parameter ------------------
         let t1          = typeOfBind b1
 
-        -- If the parameter has no type annotation at all then we can use the
-        --   expected type we were passed down from above.
-        -- If it does have an annotation, then it needs to match the
-        --   expected type.
-        (b1', t1', ctx0) 
-         <- if isBot t1             
-             then 
+        -- If the parameter has no type annotation at all then we can
+        --   use the expected type we were passed down from above.
+        -- If it does have an annotation, then the annotation also needs
+        --   to match the expected type.
+        (b1', t1', ctx0)
+         <- if isBot t1
+             then
                 return  (replaceTypeOfBind tX1 b1, tX1, ctx)
              else do
-                ctx0    <- makeEq config a ctx t1 tX1 
+                ctx0    <- makeEq config a ctx t1 tX1
                         $  ErrorMismatch a t1 tExpected (XLam a b1 x2)
                 return  (b1, t1, ctx0)
-                        
+
         -- Check the body ----------------------
         -- Check the body of the abstraction under the extended environment.
         let (ctx', pos1) = markContext ctx0
         let ctx1         = pushType b1' ctx'
 
-        (x2', t2, e2, c2, ctx2)
-         <- tableCheckExp table table ctx1 x2 (Check tX2)
+        -- Check the body against the type we have for it.
+        (x2', t2, e2, ctx2)
+         <- case takeTSusp tX2 of
 
+             -- If we're implicitly boxing bodies and we're expecting a
+             -- suspension, then check the body against the type of the
+             -- result of the suspension.
+             Just (e2Expected, t2Expected)
+              |  configImplicitBox config
+              ,  not $ isXCastBox x2
+              -> do 
+                    -- Check the body against the expected result type of the
+                    -- suspension.
+                    (x2', t2', es2Actual, ctx2)
+                      <- tableCheckExp table table ctx1 (Check t2Expected) DemandRun x2 
+
+                    let es2Actual_crushed
+                          = Sum.fromList kEffect
+                          [ crushEffect (configGlobalCaps config) (TSum es2Actual)]
+
+                    -- The expected effect in the suspension could have been an
+                    -- existential, so we need to unify it against the reconstructed
+                    -- effect to instantiate it.
+                    let e2Actual_crushed = TSum es2Actual_crushed
+                    ctx2' <- makeEq config a ctx2 e2Expected e2Actual_crushed
+                          $  ErrorMismatch a e2Actual_crushed e2Expected x2
+
+                    return (x2', t2', es2Actual_crushed, ctx2')
+
+             _
+              -> do
+                    (x2', t2', es2Actual, ctx2)
+                      <- tableCheckExp table table ctx1 (Check tX2) DemandNone x2
+
+                    let es2Actual_crushed
+                          = Sum.fromList kEffect
+                          [ crushEffect (configGlobalCaps config) (TSum es2Actual)]
+
+                    return (x2', t2', es2Actual_crushed, ctx2)
+
         -- Force the kind of the body to be Data.
         --   This constrains the kind of polymorpic variables that are used
-        --   as the result of a function, like with (\x. x). 
+        --   as the result of a function, like with (\x. x).
         --   We know \x. can't bind a witness here.
-        (_, _, ctx3)    <- checkTypeM config kenv ctx2 UniverseSpec 
-                                (applyContext ctx2 t2) 
-                                (Check kData)
+        t2' <- applyContext ctx2 t2
+        (_, _, ctx3)
+            <- checkTypeM config kenv ctx2 UniverseSpec t2' (Check kData)
 
         -- Make the result type -----------------
         -- If the kind of the parameter is unconstrained then default it
         -- to Data. This handles  "/\f. \(a : f Int#). ()"
         (_, k1, _)      <- checkTypeM config kenv ctx3 UniverseSpec t1' Synth
-        let k1'         = applyContext ctx3 k1
+        k1'             <- applyContext ctx3 k1
         (k1'', ctx4)
          <- if isTExists k1'
              then do
                 ctx4    <- makeEq config a ctx3 k1' kData
                         $  ErrorMismatch a k1' kData xx
-                return (applyContext ctx4 k1', ctx4)
 
+                k1''    <- applyContext ctx4 k1'
+
+                return (k1'', ctx4)
+
              else do
                 return (k1', ctx3)
 
-        -- Cut closure terms due to locally bound value vars.
-        -- This also lowers deBruijn indices in un-cut closure terms.
-        let c2_cut      = Set.fromList
-                        $ mapMaybe (cutTaggedClosureX b1)
-                        $ Set.toList c2
-        
-        -- Cut the bound type and elems under it from the context.
-        let ctx_cut     = popToPos pos1 ctx4
 
         -- Build the resulting function type.
         --  This switches on the kind of the argument, so we need to apply
         --  the context to 'k1' to ensure it has all available information.
-        (tResult, cResult)
-         <- makeFunctionType config a (XLam a b1' x2) 
-                t1' k1''
-                t2 e2 c2_cut
+        (xAbs', tAbs)
+         <- makeFunction
+                config a (XLam a b1' x2)
+                b1' t1' k1'' 
+                x2' t2  e2
 
-        ctrace  $ vcat 
-                [ text "* Lam Check"
-                , indent 2 $ ppr (XLam a b1' x2)
-                , text "  IN:  " <> ppr tExpected
-                , text "  OUT: " <> ppr tResult
-                , indent 2 $ ppr ctx
-                , indent 2 $ ppr ctx_cut
+
+        -- Ensure that the final type matches the one we expected.
+        --   The expected type may have had an existential for the parameter,
+        --   which we want to unify with any type annotation that was on 
+        --   the abstraction.
+        --   
+        --   The `makeFunction` can also insert implicit box casts, so we 
+        --   need to check that the result of doing this is as expected.
+        -- 
+        ctx5    <- makeEq config a ctx4 tAbs tExpected
+                $  ErrorMismatch a tAbs tExpected xx
+
+        tAbs'   <- applyContext ctx4 tAbs
+
+        -- Cut the bound type and elems under it from the context.
+        let ctx_cut     = popToPos pos1 ctx5
+
+        ctrace  $ vcat
+                [ text "*<  Lam CHECK"
+                , text "    in  type: " <> ppr tExpected
+                , text "    out type: " <> ppr tAbs'
+                , indent 4 $ ppr ctx
+                , indent 4 $ ppr ctx_cut
                 , empty ]
 
-        returnX a
-                (\z -> XLam z b1' x2')
-                tResult (Sum.empty kEffect) cResult
-                ctx_cut
+        return  ( xAbs'
+                , tAbs'
+                , Sum.empty kEffect
+                , ctx_cut)
 
+
+-- The expected type is not a functional type, yet we have a lambda
+-- abstraction. Fall through to the subsumtion checker which will
+-- throw the error message.
 checkLam !table !a !ctx !b1 !x2 !(Check tExpected)
- = checkSub table a ctx (XLam a b1 x2) tExpected
+ = do   ctrace  $ vcat
+                [ text "*>  Lam Check (not function)" ]
 
+        checkSub table a ctx DemandNone (XLam a b1 x2) tExpected
 
+
 -------------------------------------------------------------------------------
--- | Construct a function-like type with the given effect and closure.
+-- | Construct a function type with the given effect and closure.
 --
 --   Whether this is a witness or data abstraction depends on the kind
 --   of the parameter type.
@@ -270,78 +347,107 @@
 --   is set by the Config, which depends on the specific language fragment
 --   that we're checking.
 --
-makeFunctionType 
+makeFunction
         :: (Show n, Ord n)
-        => Config n              -- ^ Type checker config.
-        -> a                     -- ^ Annotation for error messages.
-        -> Exp a n               -- ^ Expression for error messages.
-        -> Type n                -- ^ Parameter type of the function.
-        -> Kind n                -- ^ Kind of the parameter.
-        -> Type n                -- ^ Result type of the function.
-        -> TypeSum n             -- ^ Effect sum.
-        -> Set (TaggedClosure n) -- ^ Closure terms.
-        -> CheckM a n (Type n, Set (TaggedClosure n))
+        => Config n             -- ^ Type checker config.
+        -> a                    -- ^ Annotation for error messages.
+        -> Exp  a n             -- ^ Expression for error messages.
+        -> Bind n               -- ^ Binder of the function parameter.
+        -> Type n               -- ^ Parameter type of the function.
+        -> Kind n               -- ^ Kind of the parameter.
+        -> Exp  (AnTEC a n) n   -- ^ Body of the function.
+        -> Type n               -- ^ Result type of the function.
+        -> TypeSum n            -- ^ Effect sum.
+        -> CheckM a n (Exp (AnTEC a n) n, Type n)
 
-makeFunctionType config a xx t1 k1 t2 e2 c2
- | isTExists k1
- = throw $ ErrorLamBindBadKind a xx t1 k1
+makeFunction config a xx bParam tParam kParam xBody tBody eBody
+ | isTExists kParam
+ = throw $ ErrorLamBindBadKind a xx tParam kParam
 
- | not (k1 == kData) && not (k1 == kWitness)
- = throw $ ErrorLamBindBadKind a xx t1 k1
+ | not (kParam == kData) && not (kParam == kWitness)
+ = throw $ ErrorLamBindBadKind a xx tParam kParam
 
  | otherwise
- = do   
+ = do
         -- Get the universe the parameter value belongs to.
-        let Just uniParam    = universeFromType2 k1
-
-        -- Trim the closure before we annotate the returned function
-        -- type with it. This should always succeed because trimClosure
-        -- only returns Nothing if the closure is miskinded, and we've
-        -- already already checked that.
-        let c2_captured
-                -- If we're not tracking closure information then just drop it 
-                -- on the floor.
-                | not  $ configTrackedClosures config   = tBot kClosure
-                | otherwise
-                = let Just c = trimClosure $ closureOfTaggedSet c2 in c
+        let Just uniParam    = universeFromType2 kParam
 
-        let e2_captured
-                -- If we're not tracking effect information then just drop it 
+        -- The effects due to evaluating the body that are 
+        -- captured by this abstraction.
+        let eCaptured
+                -- If we're not tracking effect information then just drop it
                 -- on the floor.
                 | not  $ configTrackedEffects config    = tBot kEffect
-                | otherwise                             = TSum e2
-
-
-        -- Data abstraction where the function type for the language fragment
-        -- supports latent effects and closures.
-        if      (  k1 == kData
-                && configFunctionalEffects  config
-                && configFunctionalClosures config)
-         then   return  ( tFunEC t1 e2_captured c2_captured t2
-                        , c2)
+                | otherwise                             = TSum eBody
 
         -- Data abstraction where the function constructor for the language
         -- fragment does not suport latent effects or closures.
-        else if (  k1 == kData
-                && e2_captured == tBot kEffect
-                && c2_captured == tBot kClosure)
-         then   return  ( tFun t1 t2
-                        , Set.empty)
+        if (    kParam == kData
+                && eCaptured == tBot kEffect)
+         then let tAbs  = tFun tParam tBody
+                  aAbs  = AnTEC tAbs (tBot kEffect) (tBot kClosure) a
+              in  return ( XLam aAbs bParam xBody
+                         , tAbs)
 
         -- Witness abstractions must always be pure,
         --  but closures are passed through.
-        else if (  k1 == kWitness
-                && e2_captured == tBot kEffect)
-         then   return  ( tImpl t1 t2
-                        , c2 )
+        else if (  kParam == kWitness
+                && eCaptured == tBot kEffect)
+         then let tAbs  = tImpl tParam tBody
+                  aAbs  = AnTEC tAbs (tBot kEffect) (tBot kClosure) a
+              in  return ( XLam aAbs bParam xBody
+                         , tAbs)
 
-        -- We don't have a way of forming a function with an impure effect.
-        else if (e2_captured /= tBot kEffect)
-         then   throw $ ErrorLamNotPure  a xx uniParam e2_captured
+        -- Handle ImplicitBoxBodies
+        --   Evaluating the given body causes an effect, but the body of an
+        --   abstraction must be pure. Automatically box up the body to build
+        --   a suspension that we can abstract over. We justify the fact that
+        --   inserting this cast is valid because if we didn't the program
+        --   would be ill-typed, as the next case it to throw an error.
+        else if (   configImplicitBox config
+                && (eCaptured /= tBot kEffect))
+         then 
+              case takeTSusp tBody of
 
-        -- We don't have a way of forming a function with an non-empty closure.
-        else if (c2_captured /= tBot kClosure)
-         then   throw $ ErrorLamNotEmpty a xx uniParam c2_captured
+                -- The body itself does not produce another suspension, 
+                -- so we can just box it up.
+                Nothing 
+                 -> let tBodySusp = tSusp eCaptured tBody
+                        aBox      = AnTEC tBodySusp (tBot kEffect) (tBot kClosure) a
+
+                        tAbs      = tFun tParam tBodySusp
+                        aAbs      = AnTEC tAbs      (tBot kEffect) (tBot kClosure) a
+
+                    in  return  ( XLam aAbs bParam (XCast aBox CastBox xBody)
+                                , tAbs)
+
+                -- The body itself produces another suspension.
+                -- Instead boxing this to form a result of type:
+                --    S eCaptured (S eResult tResult)
+                --
+                -- we instead run the inner suspension and re-box it,
+                -- so that we have a single suspension that includes both effects:
+                --    S (eCaptured + eResult) tResult
+                -- 
+                Just (eSusp, tResult)
+                 -> let aRun      = AnTEC tResult eSusp (tBot kClosure) a
+
+                        eTotal    = tSum kEffect [eSusp, eCaptured]
+                        tBodySusp = tSusp eTotal tResult
+                        aBox      = AnTEC tBodySusp (tBot kEffect) (tBot kClosure) a
+
+                        tAbs      = tFun tParam tBodySusp
+                        aAbs      = AnTEC tAbs      (tBot kEffect) (tBot kClosure) a
+
+                    in  return  ( XLam aAbs bParam 
+                                        $ XCast aBox CastBox 
+                                        $ XCast aRun CastRun 
+                                        $ xBody
+                                , tAbs)
+
+        -- We don't have a way of forming a function with an impure effect.
+        else if (eCaptured /= tBot kEffect)
+         then   throw $ ErrorLamNotPure  a xx uniParam eCaptured
 
         -- One of the above error reporting cases should have fired already.
         else    error $ "ddc-core.makeFunctionType: is broken."
diff --git a/DDC/Core/Check/Judge/Type/Let.hs b/DDC/Core/Check/Judge/Type/Let.hs
--- a/DDC/Core/Check/Judge/Type/Let.hs
+++ b/DDC/Core/Check/Judge/Type/Let.hs
@@ -4,129 +4,153 @@
 where
 import DDC.Core.Check.Judge.Type.Base
 import qualified DDC.Type.Sum   as Sum
-import qualified Data.Set       as Set
 import Data.List                as L
 
 
+---------------------------------------------------------------------------------------------------
 checkLet :: Checker a n
 
 -- let --------------------------------------------
-checkLet !table !ctx0 xx@(XLet a lts xBody) mode
+checkLet !table !ctx0 mode demand xx@(XLet a lts xBody)
  | case lts of
         LLet{}  -> True
         LRec{}  -> True
         _       -> False
 
- = do   let config  = tableConfig table
+ = do   ctrace  $ vcat
+                [ text "*>  Let" 
+                , text "    mode   =" <+> ppr mode 
+                , text "    demand =" <+> (text $ show demand)
+                , empty]
+
+        let config  = tableConfig table
         let kenv    = tableKindEnv table
 
         -- Check the bindings -------------------
         -- Decide whether to use bidirectional type inference when checking
         -- the types of the bindings.
-        let useBidirChecking   
+        let useBidirChecking
                 = case mode of
                         Recon   -> False
                         Check{} -> True
                         Synth   -> True
-        
-        (lts', bs', effsBinds, closBinds, pos1, ctx1)
-         <- checkLetsM useBidirChecking xx table ctx0 lts 
 
-        
+        (lts', _bs', effsBinds, pos1, ctx1)
+         <- checkLetsM useBidirChecking xx table ctx0 demand lts
+
+
         -- Check the body -----------------------
         -- -- Check the body expression in a context
         -- -- extended with the types of the bindings.
-        (xBody', tBody, effsBody, closBody, ctx2)
-         <- tableCheckExp table table ctx1 xBody mode
+        ctrace  $ vcat
+                [ text "*.  Let Body " <> ppr mode
+                , text "    demand = " <> (text $ show demand)
+                , empty]
 
+        (xBody', tBody, effsBody, ctx2)
+         <- tableCheckExp table table ctx1 mode demand xBody
+
         -- The body must have data kind.
-        (tBody', kBody, ctx3)      
+        (tBodyChecked, kBody, ctx3)
          <- checkTypeM config kenv ctx2 UniverseSpec tBody
          $  case mode of
                 Recon   -> Recon
                 _       -> Check kData
-        
-        let kBody' = applyContext ctx3 kBody
+
+        kBody' <- applyContext ctx3 kBody
         when (not $ isDataKind kBody')
          $ throw $ ErrorLetBodyNotData a xx tBody kBody'
 
+        tBody' <- applyContext ctx3 tBodyChecked
 
-        -- Build the result ---------------------
-        -- Mask closure terms due to locally bound value vars.
-        let clos_cut    = Set.fromList
-                        $ mapMaybe (cutTaggedClosureXs bs')
-                        $ Set.toList closBody
+        -- Run the body if needed ---------------
+        (xBodyRun, tBodyRun, eBodyRun)
+         <- case mode of
+                Synth   -> runForDemand (tableConfig table) a demand
+                                xBody' tBody' (TSum effsBody)
 
+                _       -> return (xBody', tBody', TSum effsBody)
+
+
+        -- Build the result ---------------------
         -- The new effect and closure.
-        let tResult     = applyContext ctx3 tBody'
-        let effs'       = effsBinds `Sum.union` effsBody
-        let clos'       = closBinds `Set.union` clos_cut
+        let eResult     = tSum kEffect [TSum effsBinds, eBodyRun]
 
         -- Pop the elements due to the let-bindings from the context.
         let ctx_cut     = popToPos pos1 ctx3
 
         ctrace  $ vcat
-                [ text "* Let"
-                , indent 2 $ ppr xx
-                , text "  tResult:  " <> ppr tResult
-                , indent 2 $ ppr ctx3
-                , indent 2 $ ppr ctx_cut ]
+                [ text "*<  Let " <> ppr mode
+                , text "    demand = " <> (text $ show demand)
+                , text "    -- EXP IN  ----"
+                , indent 4 $ ppr xx
+                , text "    -- EXP OUT ----"
+                , indent 4 $ ppr (XLet (AnTEC tBodyRun (tBot kEffect) (tBot kClosure) a) 
+                                        lts' xBodyRun)
+                , text "    --"
+                , text "    tBodyRun:  " <> ppr tBodyRun
+                , indent 4 $ ppr ctx3
+                , indent 4 $ ppr ctx_cut 
+                , empty ]
 
-        returnX a (\z -> XLet z lts' xBody')
-                tResult effs' clos' ctx_cut
+        returnX a 
+                (\z -> XLet z lts' xBodyRun)
+                tBodyRun 
+                (Sum.fromList kEffect [eResult])
+                ctx_cut
 
 
 -- others ---------------------------------------
 -- The dispatcher should only call checkLet with a XLet AST node.
-checkLet _ _ _ _
-        = error "ddc-core.checkLet: no match"        
+checkLet _ _ _ _ _
+        = error "ddc-core.checkLet: no match"
 
 
--------------------------------------------------------------------------------
+---------------------------------------------------------------------------------------------------
 -- | Check some let bindings,
 --   and push their binders onto the context.
-checkLetsM 
-        :: (Show n, Pretty n, Ord n)
+checkLetsM
+        :: (Show a, Show n, Pretty n, Ord n)
         => Bool                         -- ^ Use bidirectional inference.
         -> Exp a n                      -- ^ Expression for error messages.
         -> Table a n                    -- ^ Static configuration.
         -> Context n                    -- ^ Input context.
+        -> Demand                       -- ^ Demand placed on the bindings.
         -> Lets a n                     -- ^ Let-bindings to check.
         -> CheckM a n
                 ( Lets (AnTEC a n) n    --   Let-bindings annotated with types.
                 , [Bind n]              --   Binding occs of vars, with types.
                 , TypeSum n             --   Effect of evaluating all the bindings.
-                , Set (TaggedClosure n) --   Closure of all the bindings.
                 , Pos                   --   Context position with bindings pushed.
                 , Context n)            --   Output context.
 
-checkLetsM !bidir xx !table !ctx0 (LLet b xBind)
- 
+checkLetsM !bidir xx !table !ctx0 !demand (LLet b xBind)
+
  -- Reconstruct the type of a non-recursive let-binding.
  | False  <- bidir
- = do   
+ = do
         let config      = tableConfig table
         let kenv        = tableKindEnv table
         let a           = annotOfExp xx
 
         -- Reconstruct the type of the binding.
-        (xBind', tBind, effsBind, closBind, ctx1) 
-         <- tableCheckExp table table ctx0 xBind Recon
-        
+        (xBind', tBind, effsBind, ctx1)
+         <- tableCheckExp table table ctx0 Recon demand xBind
+
         -- The kind of the binding must be Data.
-        (_, kBind', _) 
+        (_, kBind', _)
          <- checkTypeM config kenv ctx1 UniverseSpec tBind Recon
 
         when (not $ isDataKind kBind')
          $ throw $ ErrorLetBindingNotData a xx b kBind'
-        
+
         -- If there is a type annotation on the binding then this
         -- must match the reconstructed type.
         when (not $ isBot (typeOfBind b))
          $ if equivT (typeOfBind b) tBind
                 then return ()
-                else (throw $ ErrorLetMismatch a xx b tBind)          
-        
+                else (throw $ ErrorLetMismatch a xx b tBind)
+
         -- Update the annotation on the binder with the actual type of
         -- the binding.
         let b'  = replaceTypeOfBind tBind b
@@ -137,25 +161,26 @@
 
         return  ( LLet b' xBind'
                 , [b']
-                , effsBind, closBind
+                , effsBind
                 , pos1, ctx3)
 
  -- Synthesise the type of a non-recursive let-binding,
  -- using any annotation on the binder as the expected type.
  | True   <- bidir
- = do   
+ = do
         let config      = tableConfig table
         let kenv        = tableKindEnv table
-        
+        let a           = annotOfExp xx
+
         -- If the binder has a type annotation then we use that as the expected
         -- type when checking the binding. Any annotation must also have kind
         -- Data, which we verify here.
         let tAnnot      = typeOfBind b
-        (modeCheck, ctx1)
+        (mode, ctx1)
          <- if isBot tAnnot
              -- There is no annotation on the binder.
              then return (Synth, ctx0)
-             
+
              -- Check the type annotation on the binder,
              -- expecting the kind to be Data.
              else do
@@ -163,69 +188,105 @@
                  <- checkTypeM config kenv ctx0 UniverseSpec tAnnot (Check kData)
                 return (Check tAnnot', ctx1)
 
+        ctrace  $ vcat
+                [ text "*>  Let Bind"  <+> ppr mode
+                , text "    demand = " <> (text $ show demand)
+                , text "    bind   = " <> (ppr b)
+                , empty ]
+
         -- Check the expression in the right of the binding.
-        (xBind', tBind1, effsBind, closBind, ctx2)
-         <- tableCheckExp table table ctx1 xBind modeCheck
+        (xBind_raw, tBind_raw, effs_raw, ctx2)
+         <- tableCheckExp table table ctx1 mode demand xBind
 
+        tBind_ctx <- applyContext ctx2 tBind_raw
+
+        -- Handle ImplictRunBindings
+        --   If the right of the binding is a suspended expression, but there is
+        --   no binder then the expression is probably being evaluated for its
+        --   effect only. If ImplicitRunBindings is enabled then we automatically
+        --   run the suspension to release its effect.
+        let (xBind_run, tBind_run, effs_run)
+                | configImplicitRun $ tableConfig table 
+                , not $ isXCastBox xBind_raw
+                , not $ isXCastRun xBind_raw
+                , Just  (effs_susp, tBind_susp) <- takeTSusp tBind_ctx
+                = let   
+                        -- Effect of overall expression is effect of computing
+                        -- the suspension plus the effect we get by running
+                        -- that suspension.
+                        effs_result = Sum.insert effs_susp effs_raw
+
+                        -- Annotation for the resulting cast expression.
+                        a'          = AnTEC tBind_susp (TSum $ effs_result)
+                                            (tBot kClosure) a
+                  in    ( XCast a' CastRun xBind_raw
+                        , tBind_susp
+                        , effs_result)
+
+                | otherwise
+                = (xBind_raw, tBind_raw, effs_raw)
+
+
         -- Update the annotation on the binder with the actual type of
         -- the binding.
-        let tBind2      = applyContext ctx2 tBind1
-        let b'          = replaceTypeOfBind tBind2 b
+        let b'           = replaceTypeOfBind tBind_run b
 
         -- Push the binder on the context.
         let (ctx3, pos1) =  markContext ctx2
         let ctx4         =  pushType b' ctx3
 
-        return  ( LLet b' xBind'
+        return  ( LLet b' xBind_run
                 , [b']
-                , effsBind, closBind
+                , effs_run
                 , pos1, ctx4)
 
 
 -- letrec ---------------------------------------
-checkLetsM !bidir !xx !table !ctx0 (LRec bxs)
+checkLetsM !bidir !xx !table !ctx0 !demand (LRec bxs)
  = do   let (bs, xs)    = unzip bxs
         let a           = annotOfExp xx
 
+        ctrace  $ vcat
+                [ text "*>  Let Rec"
+                , text "    demand = " <> (text $ show demand)
+                , text "    binds  = " <> (ppr  $ map fst bxs)
+                , empty ]
+
         -- Named binders cannot be multiply defined.
         checkNoDuplicateBindings a xx bs
 
         -- All right hand sides must be syntactic abstractions.
-        checkSyntacticLambdas a xx xs
+        checkSyntacticLambdas table a xx xs
 
-        -- Check the type annotations on all the binders.       
-        (bs', ctx1)      <- checkRecBinds table bidir a xx ctx0 bs
+        -- Check the type annotations on all the binders.
+        (bs', ctx1)
+         <- checkRecBinds table bidir a xx ctx0 bs
 
         -- All variables are in scope in all right hand sides.
         let (ctx2, pos1) =  markContext ctx1
         let ctx3         =  pushTypes bs' ctx2
 
         -- Check the right hand sides.
-        (results, ctx4)  <- checkRecBindExps table bidir a ctx3 (zip bs' xs)
-
-        let (bs'', xsRight', clossBinds)
-                = unzip3 results
+        (results, ctx4)  
+         <- checkRecBindExps table bidir a ctx3 demand (zip bs' xs)
 
-        -- Cut closure terms due to locally bound value vars.
-        let clos_cut 
-                 = Set.fromList
-                 $ mapMaybe (cutTaggedClosureXs bs)
-                 $ Set.toList $ Set.unions clossBinds
+        let (bs'', xsRight')
+                = unzip results
 
         return  ( LRec (zip bs'' xsRight')
                 , bs''
-                , Sum.empty kEffect, clos_cut
+                , Sum.empty kEffect
                 , pos1, ctx4)
 
 
 -- others ---------------------------------------
--- The dispatcher should only call checkLet with LLet and LRec AST nodes, 
+-- The dispatcher should only call checkLet with LLet and LRec AST nodes,
 -- so we should not see the others here.
-checkLetsM _ _ _ _ _
+checkLetsM _ _ _ _ _ _
         = error "ddc-core.checkLetsM: no match"
 
 
--------------------------------------------------------------------------------
+---------------------------------------------------------------------------------------------------
 -- | Check the annotations on a group of recursive binders.
 checkRecBinds
         :: (Pretty n, Show n, Ord n)
@@ -233,9 +294,9 @@
         -> Bool                         -- ^ Use bidirectional checking.
         -> a                            -- ^ Annotation for error messages.
         -> Exp a n                      -- ^ Expression for error messages.
-        -> Context n                    -- ^ Original context.                     
+        -> Context n                    -- ^ Original context.
         -> [Bind n]                     -- ^ Input binding group.
-        -> CheckM a n 
+        -> CheckM a n
                 ( [Bind n]              --   Result binding group.
                 ,  Context n)           --   Output context.
 
@@ -256,14 +317,14 @@
         checkRecBind b ctx
          = case bidir of
             False
-             -> do      
+             -> do
                 -- In Recon mode, all recursive let-bindings must have full
                 -- type annotations.
                 when (isBot $ typeOfBind b)
                  $ throw $ ErrorLetrecMissingAnnot a b xx
 
                 -- Check the type on the binder.
-                (b', k, ctx') 
+                (b', k, ctx')
                  <- checkBindM config kenv ctx UniverseSpec b Recon
 
                 -- The type on the binder must have kind Data.
@@ -282,85 +343,121 @@
                    let b'   = replaceTypeOfBind t b
                    return (b', ctx')
 
-             -- Recursive let-binding has a type annotation, 
+             -- Recursive let-binding has a type annotation,
              -- so check it, expecting it to have kind Data.
              | otherwise
              -> do
-                (b0, _k, ctx1) 
+                (b0, _k, ctx1)
                  <- checkBindM config kenv ctx UniverseSpec b (Check kData)
 
-                let t0  = typeOfBind b0
-                let t1  = applyContext ctx1 t0
-                let b1  = replaceTypeOfBind t1 b0
+                let t0  =  typeOfBind b0
+                t1      <- applyContext ctx1 t0
+                let b1  =  replaceTypeOfBind t1 b0
 
                 return (b1, ctx1)
 
 
--------------------------------------------------------------------------------
+---------------------------------------------------------------------------------------------------
 -- | Check some recursive bindings.
 --   Doing this won't push any more bindings onto the context,
 --   though it may solve some existentials in it.
 checkRecBindExps
-        :: (Pretty n, Show n, Ord n)
+        :: (Show a, Show n, Ord n, Pretty n)
         => Table a n
         -> Bool                         -- ^ Use bidirectional checking.
         -> a                            -- ^ Annotation for error messages.
         -> Context n                    -- ^ Original context.
+        -> Demand                       -- ^ Demand placed on bindings.
         -> [(Bind n, Exp a n)]          -- ^ Bindings and exps for rec bindings.
-        -> CheckM a n 
+        -> CheckM a n
                 ( [ ( Bind n                   -- Result bindiner.
-                    , Exp (AnTEC a n) n        -- Result expression.
-                    , Set (TaggedClosure n))]  -- Result closure.
+                    , Exp (AnTEC a n) n)]      -- Result expression.
                 , Context n)
 
-checkRecBindExps table bidir a ctx0 bxs0
+checkRecBindExps table False a ctx0 demand bxs0
  = go bxs0 ctx0
- where  
-        go [] ctx       
+ where
+        go [] ctx
          = return ([], ctx)
-        
-        go ((b, x) : bxs) ctx
-         = do   (result, ctx')  <- checkRecBindExp b x ctx
-                (moar,   ctx'') <- go bxs ctx'
-                return (result : moar, ctx'')
 
-        checkRecBindExp b x ctx
-         = case bidir of
-            False 
-             -> do
+        go ((b, xBind) : bxs) ctx
+         = do   
+                ctrace  $ vcat
+                        [ text "*>  Let Rec Bind RECON"
+                        , text "    demand     = " <> (text $ show demand)
+                        , text "    in binder  = " <> ppr (binderOfBind b)
+                        , text "    in type    = " <> ppr (typeOfBind   b)
+                        , empty ]
+
                 -- Check the right of the binding.
                 --  We checked that the expression is a syntactic lambda
                 --  abstraction in checkLetsM, so we know the effect is pure.
-                (x', t, _effs, clos, ctx')
-                 <- tableCheckExp table table ctx x Recon
+                (xBind', t, _effs, ctx')
+                 <- tableCheckExp table table ctx Recon demand xBind
 
                 -- Check the annotation on the binder matches the reconstructed
                 -- type of the binding.
                 when (not $ equivT (typeOfBind b) t)
-                 $ throw $ ErrorLetMismatch a x b t
+                 $ throw $ ErrorLetMismatch a xBind b t
 
                 -- Reconstructing the types of binders adds missing kind info to
                 -- constructors etc, so update the binders with this new info.
                 let b'  = replaceTypeOfBind t b
 
-                return ( (b', x', clos), ctx')
+                ctrace  $ vcat
+                        [ text "*<  Let Rec Bind RECON"
+                        , text "    demand     =" <+> (text $ show demand)
+                        , text "    in  binder =" <+> ppr (binderOfBind b)
+                        , text "    in  type   =" <+> ppr (typeOfBind   b)
+                        , text "    out type   =" <+> ppr t 
+                        , empty ]
 
-            True
-             -> do
+                -- Check the rest of the bindings.
+                (moar,   ctx'') <- go bxs ctx'
+
+                return ((b', xBind') : moar, ctx'')
+
+checkRecBindExps table True _a ctx0 demand bxs0
+ = go bxs0 ctx0
+ where
+        go [] ctx
+         = return ([], ctx)
+
+        go ((b, xBind) : bxs) ctx
+         = do
+                ctrace  $ vcat
+                        [ text "*>  Let Rec Bind BIDIR"
+                        , text "    demand    =" <+> (text $ show demand)
+                        , text "    in binder =" <+> ppr (binderOfBind b)
+                        , text "    in type   =" <+> ppr (typeOfBind   b)
+                        , empty ]
+
                 -- Check the right of the binding.
                 --  We checked that the expression is a syntactic lambda
                 --  abstraction in checkLetsM, so we know the effect is pure.
-                (x', t, _effs, clos, ctx')
-                 <- tableCheckExp table table ctx x (Check (typeOfBind b))
+                (xBind', t, _effs, ctx')
+                 <- tableCheckExp table table ctx 
+                        (Check (typeOfBind b)) demand xBind
 
                 -- Reconstructing the types of binders adds missing kind info to
                 -- constructors etc, so update the binders with this new info.
                 let b'  = replaceTypeOfBind t b
 
-                return ((b', x', clos), ctx')
+                ctrace  $ vcat
+                        [ text "*<  Let Rec Bind BIDIR"
+                        , text "    demand     =" <+> (text $ show demand)
+                        , text "    in  binder =" <+> ppr (binderOfBind b)
+                        , text "    in  type   =" <+> ppr (typeOfBind   b)
+                        , text "    out type   =" <+> ppr t 
+                        , empty ]
 
+                -- Check the rest of the bindings.
+                (moar, ctx'') <- go bxs ctx'
 
--------------------------------------------------------------------------------
+                return ((b', xBind') : moar, ctx'')
+
+
+---------------------------------------------------------------------------------------------------
 -- | Check that the given list of binds does not contain duplicates
 --   that would conflict if we added them to the environment
 --   at the same level. If so, then throw and error.
@@ -383,20 +480,25 @@
 duplicates (x : xs)
         | L.elem x xs   = x : duplicates (filter (/= x) xs)
         | otherwise     = duplicates xs
-        
 
--------------------------------------------------------------------------------
+
+---------------------------------------------------------------------------------------------------
 -- | Check that all the bindings in a recursive let are syntactic lambdas.
 --   We don't support value recursion, so can only define recursive functions.
 --   If one of the expression is not a lambda then throw an error.
 checkSyntacticLambdas
-        :: a                    -- ^ Annotation for error messages.
+        :: Table a n
+        -> a                    -- ^ Annotation for error messages.
         -> Exp a n              -- ^ Expression for error message.
         -> [Exp a n]            -- ^ Expressions to check.
         -> CheckM a n ()
 
-checkSyntacticLambdas a xx xs
- = forM_ xs $ \x 
-        -> when (not $ (isXLam x || isXLAM x))
-        $ throw $ ErrorLetrecBindingNotLambda a xx x
+checkSyntacticLambdas table a xx xs
+        | configGeneralLetRec $ tableConfig table
+        = return ()
+
+        | otherwise
+        = forM_ xs $ \x
+                -> when (not $ (isXLam x || isXLAM x))
+                $  throw $ ErrorLetrecBindingNotLambda a xx x
 
diff --git a/DDC/Core/Check/Judge/Type/LetPrivate.hs b/DDC/Core/Check/Judge/Type/LetPrivate.hs
--- a/DDC/Core/Check/Judge/Type/LetPrivate.hs
+++ b/DDC/Core/Check/Judge/Type/LetPrivate.hs
@@ -12,25 +12,36 @@
 checkLetPrivate :: Checker a n
 
 -- private --------------------------------------
-checkLetPrivate !table !ctx 
-        xx@(XLet a (LPrivate bsRgn mtParent bsWit) x) mode
+checkLetPrivate !table !ctx mode demand
+        xx@(XLet a (LPrivate bsRgn mtParent bsWit) x)
+
  = case takeSubstBoundsOfBinds bsRgn of
-    []   -> tableCheckExp table table ctx x Recon
+    []   -> tableCheckExp table table ctx Recon demand x
+
     us   -> do
         let config      = tableConfig table
         let kenv        = tableKindEnv table
         let depth       = length $ map isBAnon bsRgn
 
+        ctrace  $ vcat
+                [ text "*>  Let Private"
+                , text "    mode             =" <+> ppr mode
+                , text "    demand           =" <+> text (show demand)
+                , text "    in region binds  =" <+> ppr bsRgn
+                , text "    in parent bind   =" <+> text (show mtParent)
+                , text "    in witness binds =" <+> ppr bsWit
+                , empty ]
+
         -- Check the kinds of the region binders.
         -- These must already set to kind Region.
-        (bsRgn', _, _)  
+        (bsRgn', _, _)
          <- liftM unzip3
          $  mapM (\b -> checkBindM config kenv ctx UniverseKind b Recon)
                  bsRgn
         let ksRgn       = map typeOfBind bsRgn'
-        
+
         -- The binders must have region kind.
-        when (any (not . isRegionKind) ksRgn) 
+        when (any (not . isRegionKind) ksRgn)
          $ throw $ ErrorLetRegionsNotRegion a xx bsRgn ksRgn
 
         -- We can't shadow region binders because we might have witnesses
@@ -38,37 +49,41 @@
         let rebounds    = filter (flip memberKindBind ctx) bsRgn'
         when (not $ null rebounds)
          $ throw $ ErrorLetRegionsRebound a xx rebounds
-        
+
         -- Check the witness binders.
         -- These must have full type annotations, as we don't infer
         -- the types of introduced witnesses.
         let (ctx', pos1) = markContext ctx
         let ctx1         = pushKinds [(b, RoleConcrete) | b <- bsRgn] ctx'
         let ctx2         = liftTypes depth ctx1
-        (bsWit', _, _)   
+        (bsWit', _, _)
          <- liftM unzip3
-         $  mapM (\b -> checkBindM config kenv ctx2 UniverseSpec b Recon) 
+         $  mapM (\b -> checkBindM config kenv ctx2 UniverseSpec b Recon)
                  bsWit
-        
+
         -- Check that the witnesses bound here are for the region,
         -- and they don't conflict with each other.
         checkWitnessBindsM config a kenv ctx xx us bsWit'
 
         -- Check the body expression.
+        --   We always want to do this in 'Synth' mode as the expected
+        --   type uses the region names visible from outside, and will
+        --   not mention local regions are introduced by the 'private'
+        --   construct.
         let ctx3        = pushTypes bsWit' ctx2
-        (xBody3, tBody3, effs3, clo, ctx4)  
-          <- tableCheckExp table table ctx3 x mode
+        (xBody3, tBody3, effs3, ctx4)
+          <- tableCheckExp table table ctx3 Synth demand x
 
         -- The body type must have data kind.
-        (tBody4, kBody4, ctx5)   
-         <- checkTypeM config kenv ctx4 UniverseSpec tBody3
-         $  case mode of
+        (tBody4, kBody4, ctx5)
+          <- checkTypeM config kenv ctx4 UniverseSpec tBody3
+          $  case mode of
                 Recon   -> Recon
                 _       -> Check kData
 
-        let tBody5      = applyContext ctx5 tBody4
-        let kBody5      = applyContext ctx5 kBody4
-        let TSum effs5  = applyContext ctx5 (TSum effs3)
+        tBody5      <- applyContext ctx5 tBody4
+        kBody5      <- applyContext ctx5 kBody4
+        TSum effs5  <- applyContext ctx5 (TSum effs3)
         when (not $ isDataKind kBody5)
          $ throw $ ErrorLetBodyNotData a xx tBody5 kBody5
 
@@ -76,13 +91,13 @@
         tBody_final
          <- case mtParent of
                 -- If the bound region variables are children of some parent
-                -- region then they are merged into the parent when the 
+                -- region then they are merged into the parent when the
                 -- private/extend construct ends.
                 Just tParent
-                 -> do  return $ foldl  (\t b -> substituteTX b tParent t) 
+                 -> do  return $ foldl  (\t b -> substituteTX b tParent t)
                                         tBody5 bsRgn
 
-                -- If the bound region variables have no parent then they are 
+                -- If the bound region variables have no parent then they are
                 -- deallocated when the private construct ends.
                 -- The bound region variables cannot be free in the body type.
                 _
@@ -91,17 +106,27 @@
                          $ throw $ ErrorLetRegionFree a xx bsRgn tBody5
                         return $ lowerT depth tBody5
 
+        -- Check that the result matches any expected type.
+        ctx6    <- case mode of
+                    Check tExpected
+                     -> do  makeEq config a ctx5 tExpected tBody_final
+                             $  ErrorMismatch a tExpected tBody_final xx
+
+                    _ -> return ctx5
+
+        tBody_final' <- applyContext ctx6 tBody_final
+
         -- Delete effects on the bound region from the result.
         let delEff es u = Sum.delete (tRead  (TVar u))
                         $ Sum.delete (tWrite (TVar u))
                         $ Sum.delete (tAlloc (TVar u))
                         $ es
-        
+
         -- The final effect type.
         effs_cut
          <- case mtParent of
                 -- If the bound region variables are children of some parent
-                -- region then the overall effect is to allocate into 
+                -- region then the overall effect is to allocate into
                 -- the parent.
                 Just tParent
                   -> return $ (lowerT depth $ foldl delEff effs5 us)
@@ -110,93 +135,27 @@
                 -- If the bound region variables have no parent then they
                 -- are deallocated when the private construct ends and no
                 -- effect on these regions is visible.
-                _ -> return $ lowerT depth 
-                            $ foldl delEff effs5 us 
-
-        -- Delete the bound region variable from the closure.
-        -- Mask closure terms due to locally bound region vars.
-        let cutClo c r  = mapMaybe (cutTaggedClosureT r) c
-        let clos_cut    = Set.fromList 
-                        $ foldl cutClo (Set.toList clo) bsRgn
+                _ -> return $ lowerT depth
+                            $ foldl delEff effs5 us
 
         -- Cut stack back to the length we started with,
         --  remembering to lower to undo the lift we applied previously.
         let ctx_cut     = lowerTypes depth
-                        $ popToPos pos1 ctx5
+                        $ popToPos pos1 ctx6
 
         returnX a
                 (\z -> XLet z (LPrivate bsRgn mtParent bsWit) xBody3)
-                tBody_final effs_cut clos_cut
-                ctx_cut
+                tBody_final' effs_cut ctx_cut
 
 
--- withregion -----------------------------------
-checkLetPrivate !table !ctx0
-        xx@(XLet a (LWithRegion u) x) mode
- = do   let config      = tableConfig table
-        let kenv        = tableKindEnv table
-
-        -- The handle must have region kind.
-        -- We need to look in the KindEnv as well as the Context here, 
-        --  because the KindEnv knows the types of primitive variables.
-        (case listToMaybe  
-                $ catMaybes [ Env.lookup u kenv
-                            , liftM fst $ lookupKind u ctx0] of
-          Nothing -> throw $ ErrorUndefinedVar a u UniverseSpec
-
-          Just k  |  not $ isRegionKind k
-                  -> throw $ ErrorWithRegionNotRegion a xx u k
-
-          _       -> return ())
-        
-        -- Check the body expression.
-        (xBody0, tBody0, effs0, clo, ctx1) 
-         <- tableCheckExp table table ctx0 x mode
-
-        -- The body type must have data kind.
-        (tBody1, kBody1, ctx2) 
-         <- checkTypeM config kenv ctx1 UniverseSpec tBody0
-         $  case mode of
-                Recon   -> Recon
-                _       -> Check kData
-
-        let tBody2      = applyContext ctx2 tBody1
-        let kBody2      = applyContext ctx2 kBody1
-        let TSum effs2  = applyContext ctx2 (TSum effs0)
-        
-        when (not $ isDataKind kBody2)
-         $ throw $ ErrorLetBodyNotData a xx tBody2 kBody2
-        
-        -- The bound region variable cannot be free in the body type.
-        let tcs         = supportTyCon
-                        $ support Env.empty Env.empty tBody2
-        
-        when (Set.member u tcs)
-         $ throw $ ErrorWithRegionFree a xx u tBody2
-
-        -- Delete effects on the bound region from the result.
-        let tu          = TVar u
-        let effs_cut    = Sum.delete (tRead  tu)
-                        $ Sum.delete (tWrite tu)
-                        $ Sum.delete (tAlloc tu)
-                        $ effs2
-        
-        -- Delete the bound region handle from the closure.
-        let clos_cut    = Set.delete (GBoundRgnCon u) clo
-
-        returnX a
-                (\z -> XLet z (LWithRegion u) xBody0)
-                tBody2 effs_cut clos_cut
-                ctx2
-
-checkLetPrivate _ _ _ _
-        = error "ddc-core.checkLetPrivate: no match"        
+checkLetPrivate _ _ _ _ _
+        = error "ddc-core.checkLetPrivate: no match"
 
 
 -------------------------------------------------------------------------------
 -- | Check the set of witness bindings bound in a letregion for conflicts.
-checkWitnessBindsM 
-        :: (Show n, Ord n) 
+checkWitnessBindsM
+        :: (Show n, Ord n)
         => Config n             -- ^ Type checker config.
         -> a                    -- ^ Annotation for error messages.
         -> KindEnv n            -- ^ Kind Environment.
@@ -214,14 +173,14 @@
         -- when using the Eval fragment.
         inEnv tt
          = case tt of
-             TVar u'                
+             TVar u'
                 | Env.member u' kenv    -> True
                 | memberKind u' ctx     -> True
-             
-             TCon (TyConBound u' _) 
+
+             TCon (TyConBound u' _)
                 | Env.member u' kenv    -> True
                 | memberKind u' ctx     -> True
-             _                          -> False 
+             _                          -> False
 
 
         -- Check the argument of a witness type is for the region we're
@@ -229,27 +188,25 @@
         checkWitnessArg bWit t2
          = case t2 of
             TVar u'
-             |  all (/= u') uRegions 
+             |  all (/= u') uRegions
              -> throw $ ErrorLetRegionsWitnessOther a xx uRegions bWit
              | otherwise -> return ()
 
             TCon (TyConBound u' _)
-             | all (/= u') uRegions 
+             | all (/= u') uRegions
              -> throw $ ErrorLetRegionsWitnessOther a xx uRegions bWit
              | otherwise -> return ()
-            
-            -- The parser should ensure the right of a witness is a 
+
+            -- The parser should ensure the right of a witness is a
             -- constructor or variable.
             _            -> throw $ ErrorLetRegionWitnessInvalid a xx bWit
-    
+
         -- Associate each witness binder with its type.
         btsWit  = [(typeOfBind b, b) | b <- bsWit]
-  
+
         -- Check a single witness binder for conflicts with other witnesses.
         checkWitnessBindM bWit
          = case typeOfBind bWit of
-            TApp (TCon (TyConWitness TwConGlobal))   t2
-             -> checkWitnessArg bWit t2
 
             TApp (TCon (TyConWitness TwConConst))    t2
              | Just bConflict <- L.lookup (tMutable t2) btsWit
@@ -261,16 +218,6 @@
              -> throw $ ErrorLetRegionWitnessConflict a xx bWit bConflict
              | otherwise    -> checkWitnessArg bWit t2
 
-            TApp (TCon (TyConWitness TwConLazy))     t2
-             | Just bConflict <- L.lookup (tManifest t2) btsWit
-             -> throw $ ErrorLetRegionWitnessConflict a xx bWit bConflict
-             | otherwise    -> checkWitnessArg bWit t2
-
-            TApp (TCon (TyConWitness TwConManifest)) t2
-             | Just bConflict <- L.lookup (tLazy t2)     btsWit
-             -> throw $ ErrorLetRegionWitnessConflict a xx bWit bConflict
-             | otherwise    -> checkWitnessArg bWit t2
-         
             (takeTyConApps -> Just (TyConWitness (TwConDistinct 2), [t1, t2]))
              | inEnv t1  -> checkWitnessArg bWit t2
              | inEnv t2  -> checkWitnessArg bWit t1
diff --git a/DDC/Core/Check/Judge/Type/Sub.hs b/DDC/Core/Check/Judge/Type/Sub.hs
--- a/DDC/Core/Check/Judge/Type/Sub.hs
+++ b/DDC/Core/Check/Judge/Type/Sub.hs
@@ -6,33 +6,46 @@
 
 
 -- This is the subtyping rule for the type checking judgment.
-checkSub table !a ctx0 xx0 tExpect
- = do   let config      = tableConfig table
- 
-        (xx1, tSynth, eff, clo, ctx1)
-         <- tableCheckExp table table ctx0 xx0 Synth
+checkSub table !a ctx0 demand xx0 tExpect
+ = do   
+        ctrace  $ vcat 
+                [ text "*>  Sub Check"
+                , text "    demand:  " <> (text $ show demand)
+                , text "    tExpect: " <> (ppr tExpect) 
+                , empty ]
 
+        let config      = tableConfig table
+
+        (xx1, tSynth, eff, ctx1)
+         <- tableCheckExp table table ctx0 Synth demand xx0 
+
         -- Substitute context into synthesised and expected types.
-        let tSynth'     = applyContext ctx1 tSynth
-        let tExpect'    = applyContext ctx1 tExpect
-        
-        (xx2, ctx2)     <- makeSub config a 
+        tSynth'  <- applyContext ctx1 tSynth
+        tExpect' <- applyContext ctx1 tExpect
+
+        ctrace  $ vcat
+                [ text "*.  Sub Check"
+                , text "    demand:  " <> (text $ show demand)
+                , text "    tExpect: " <> (ppr tExpect) 
+                , empty ]
+
+        (xx2, ctx2)     <- makeSub config a
                                 ctx1 xx1 tSynth' tExpect'
                         $  ErrorMismatch a  tSynth' tExpect' xx0
 
         ctrace  $ vcat
-                [ text "* Sub"
-                , indent 2 $ ppr xx0
-                , text "  tExpect:  " <> ppr tExpect
-                , text "  tSynth:   " <> ppr tSynth
-                , text "  tExpect': " <> ppr tExpect'
-                , text "  tSynth':  " <> ppr tSynth'
-                , indent 2 $ ppr ctx0
-                , indent 2 $ ppr ctx1
-                , indent 2 $ ppr ctx2 
+                [ text "*<  Sub"
+                , indent 4 $ ppr xx0
+                , text "    tExpect:  " <> ppr tExpect
+                , text "    tSynth:   " <> ppr tSynth
+                , text "    tExpect': " <> ppr tExpect'
+                , text "    tSynth':  " <> ppr tSynth'
+                , indent 4 $ ppr ctx0
+                , indent 4 $ ppr ctx1
+                , indent 4 $ ppr ctx2
                 , empty ]
 
         returnX a
                 (\_ -> xx2)
                 tExpect
-                eff clo ctx2
+                eff ctx2
diff --git a/DDC/Core/Check/Judge/Type/VarCon.hs b/DDC/Core/Check/Judge/Type/VarCon.hs
--- a/DDC/Core/Check/Judge/Type/VarCon.hs
+++ b/DDC/Core/Check/Judge/Type/VarCon.hs
@@ -8,34 +8,32 @@
 import qualified DDC.Type.Env   as Env
 import qualified DDC.Type.Sum   as Sum
 import qualified Data.Map       as Map
-import qualified Data.Set       as Set
 
 
 checkVarCon :: Checker a n
 
 -- variables ------------------------------------
-checkVarCon !table !ctx xx@(XVar a u) mode
- 
+checkVarCon !table !ctx mode demand xx@(XVar a u)
+
  -- Look in the local context.
  | Just t       <- lookupType u ctx
  = case mode of
         -- Check subsumption against an existing type.
         -- This may instantiate existentials in the exising type.
         Check tExpect
-         ->     checkSub table a ctx xx tExpect
+         ->     checkSub table a ctx demand xx tExpect
 
         _ -> do ctrace  $ vcat
-                        [ text "* Var Local"
-                        , indent 2 $ ppr xx
-                        , text "  TYPE:  " <> ppr t
-                        , indent 2 $ ppr ctx 
+                        [ text "**  Var Local"
+                        , indent 4 $ ppr xx
+                        , text "    tVar: " <> ppr t
+                        , indent 4 $ ppr ctx
                         , empty ]
 
                 returnX a
                         (\z -> XVar z u)
                         t
                         (Sum.empty kEffect)
-                        (Set.singleton $ taggedClosureOfValBound t u)
                         ctx
 
  -- Look in the global environment.
@@ -44,40 +42,40 @@
         -- Check subsumption against an existing type.
         -- This may instantiate existentials in the exising type.
         Check tExpect
-         ->     checkSub table a ctx xx tExpect
+         ->     checkSub table a ctx demand xx tExpect
 
         _ -> do ctrace  $ vcat
-                        [ text "* Var Global"
-                        , indent 2 $ ppr xx
-                        , text "  TYPE:  " <> ppr t
-                        , indent 2 $ ppr ctx
+                        [ text "**  Var Global"
+                        , indent 4 $ ppr xx
+                        , text "    tVar: " <> ppr t
+                        , indent 4 $ ppr ctx
                         , empty ]
 
-                returnX a 
+                returnX a
                         (\z -> XVar z u)
                         t
                         (Sum.empty kEffect)
-                        (Set.singleton $ taggedClosureOfValBound t u)
                         ctx
- 
+
  -- Can't find this variable name in the environment.
  | otherwise
  = throw $ ErrorUndefinedVar a u UniverseData
-         
 
+
 -- constructors ---------------------------------
-checkVarCon !table !ctx xx@(XCon a dc) mode
+checkVarCon !table !ctx mode demand xx@(XCon a dc) 
  -- For recon and synthesis we already know what type the constructor
  -- should have, so we can use that.
- | mode == Recon || mode == Synth 
- = do   let config      = tableConfig table
+ | mode == Recon || mode == Synth
+ = do
+        let config      = tableConfig table
         let defs        = configDataDefs config
 
         -- All data constructors need to have valid type annotations.
-        tCtor 
+        tCtor
          <- case dc of
              DaConUnit   -> return tUnit
-             
+
              DaConPrim{} -> return $ daConType dc
 
              DaConBound n
@@ -92,10 +90,10 @@
         checkDaConM config xx a dc
 
         ctrace  $ vcat
-                [ text "* Con"
-                , indent 2 $ ppr xx
-                , text "  TYPE:  " <> ppr tCtor
-                , indent 2 $ ppr ctx
+                [ text "**  Con"
+                , indent 4 $ ppr xx
+                , text "    tCon: " <> ppr tCtor
+                , indent 4 $ ppr ctx
                 , empty ]
 
         -- Type of the data constructor.
@@ -103,17 +101,16 @@
                 (\z -> XCon z dc)
                 tCtor
                 (Sum.empty kEffect)
-                Set.empty
                 ctx
 
  -- Check subsumption against an existing type.
  -- This may instantiate existentials in the exising type.
  | otherwise
  , Check tExpect    <- mode
- = checkSub table a ctx xx tExpect
+ = checkSub table a ctx demand xx tExpect
 
 
 -- others ---------------------------------------
-checkVarCon _ _ _ _
+checkVarCon _ _ _ _ _
  = error "ddc-core.checkVarCon: no match"
 
diff --git a/DDC/Core/Check/Judge/Type/Witness.hs b/DDC/Core/Check/Judge/Type/Witness.hs
--- a/DDC/Core/Check/Judge/Type/Witness.hs
+++ b/DDC/Core/Check/Judge/Type/Witness.hs
@@ -5,11 +5,11 @@
 import DDC.Core.Check.Witness
 import DDC.Core.Check.Judge.Type.Base
 import qualified DDC.Type.Sum           as Sum
-import qualified Data.Set               as Set
 
 
 checkWit :: Checker a n
-checkWit !table !ctx (XWitness a w1) _
+checkWit !table !ctx _mode _demand 
+        (XWitness a w1)
  = do   let config      = tableConfig table
         let kenv        = tableKindEnv table
         let tenv        = tableTypeEnv table
@@ -22,8 +22,7 @@
                 (\z -> XWitness z w1TEC)
                 t1
                 (Sum.empty kEffect)
-                Set.empty
                 ctx
 
-checkWit _ _ _ _
+checkWit _ _ _ _ _
  = error "ddc-core.checkWit: no match"
diff --git a/DDC/Core/Check/Module.hs b/DDC/Core/Check/Module.hs
--- a/DDC/Core/Check/Module.hs
+++ b/DDC/Core/Check/Module.hs
@@ -3,7 +3,7 @@
         ( checkModule
         , checkModuleM)
 where
-import DDC.Core.Check.Base      (checkTypeM)
+import DDC.Core.Check.Base      (checkTypeM, applySolved)
 import DDC.Core.Check.Exp
 import DDC.Core.Check.Error
 import DDC.Core.Transform.Reannotate
@@ -20,11 +20,10 @@
 import DDC.Base.Pretty
 import DDC.Type.Env             (KindEnv, TypeEnv)
 import DDC.Control.Monad.Check  (runCheck, throw)
-import Data.Monoid
 import DDC.Data.ListUtils
 import Control.Monad
-import qualified DDC.Type.Env   as Env
-import qualified Data.Map       as Map
+import qualified DDC.Type.Env           as Env
+import qualified Data.Map.Strict        as Map
 
 
 -- Wrappers ---------------------------------------------------------------------------------------
@@ -35,7 +34,7 @@
 --
 --   If it's bad, you get a description of the error.
 checkModule
-        :: (Ord n, Show n, Pretty n)
+        :: (Show a, Ord n, Show n, Pretty n)
         => Config n             -- ^ Static configuration.
         -> Module a n           -- ^ Module to check.
         -> Mode n               -- ^ Type checker mode.
@@ -44,7 +43,7 @@
 
 checkModule !config !xx !mode
  = let  (s, result)     = runCheck (mempty, 0, 0)
-                        $ checkModuleM config 
+                        $ checkModuleM config
                                 (configPrimKinds config)
                                 (configPrimTypes config)
                                 xx mode
@@ -54,8 +53,8 @@
 
 -- checkModule ------------------------------------------------------------------------------------
 -- | Like `checkModule` but using the `CheckM` monad to handle errors.
-checkModuleM 
-        :: (Ord n, Show n, Pretty n)
+checkModuleM
+        :: (Show a, Ord n, Show n, Pretty n)
         => Config n             -- ^ Static configuration.
         -> KindEnv n            -- ^ Starting kind environment.
         -> TypeEnv n            -- ^ Starting type environment.
@@ -64,96 +63,145 @@
         -> CheckM a n (Module (AnTEC a n) n)
 
 checkModuleM !config !kenv !tenv mm@ModuleCore{} !mode
- = do   
+ = do
         -- Check kinds of imported types ------------------
-        nksImport'      <- checkImportTypes config mode   
+        nksImported'    <- checkImportTypes config mode
                         $  moduleImportTypes mm
 
-        -- Build the initial kind environment.
-        let kenv'       = Env.union kenv 
-                        $ Env.fromList  [ BName n (typeOfImportSource isrc)
-                                                | (n, isrc) <- nksImport' ]
 
+        -- Check imported data type defs ------------------
+        let defsImported = moduleImportDataDefs mm
+        defsImported'   <- case checkDataDefs config defsImported of
+                                (err : _, _)      -> throw $ ErrorData err
+                                ([], defsImported') -> return defsImported'
 
+
+        -- Build the imported defs and kind environment.
+        --  This contains kinds of type visible in the imported values.
+        let config_import = config
+                        { configDataDefs = unionDataDefs (configDataDefs config)
+                                                         (fromListDataDefs defsImported') }
+        let kenv_import = Env.union kenv
+                        $ Env.fromList  [ BName n (kindOfImportType isrc)
+                                        | (n, isrc) <- nksImported' ]
+
+
+        -- Check types of imported capabilities -----------
+        ntsImportCap'   <- checkImportCaps config_import kenv_import mode
+                        $  moduleImportCaps mm
+
+        let bsImportCap = [ BName n (typeOfImportCap   isrc)
+                          | (n, isrc) <- ntsImportCap' ]
+
         -- Check types of imported values -----------------
-        ntsImport'      <- checkImportValues config kenv' mode 
+        ntsImportValue' <- checkImportValues config_import kenv_import mode
                         $  moduleImportValues mm
-        
-        -- Build the initial type environment.
-        let tenv'       = Env.union tenv 
-                        $ Env.fromList  [ BName n (typeOfImportSource isrc)
-                                                | (n, isrc) <- ntsImport' ]
 
 
+        -- Check the local data type defs -----------------
+        let defsLocal   =  moduleDataDefsLocal mm
+        defsLocal'      <- case checkDataDefs config defsLocal of
+                                (err : _, _)     -> throw $ ErrorData err
+                                ([], defsLocal') -> return defsLocal'
+
+
+
+        -- Build the top-level config, defs and environments.
+        --  These contain names that are visible to bindings in the module.
+        let defs_top    = unionDataDefs (configDataDefs config)
+                        $ unionDataDefs (fromListDataDefs defsImported')
+                                        (fromListDataDefs defsLocal')
+
+        let caps_top    = Env.fromList
+                        $ [BName n t    | (n, ImportCapAbstract t) <- ntsImportCap' ]
+
+        let config_top  = config 
+                        { configDataDefs        = defs_top 
+                        , configGlobalCaps      = caps_top }
+
+        let kenv_top    = kenv_import
+
+        let tenv_top    = Env.unions 
+                        [ tenv
+                        , Env.fromList  [ BName n (typeOfImportValue isrc)
+                                        | (n, isrc) <- ntsImportValue' ]
+
+                        , Env.fromList  [ BName n (typeOfImportCap   isrc)
+                                        | (n, isrc) <- ntsImportCap'   ]
+                        ]
+
+        let ctx_top     = pushTypes bsImportCap emptyContext
+
         -- Check the sigs of exported types ---------------
-        esrcsType'      <- checkExportTypes config        
-                        $ moduleExportTypes mm
+        esrcsType'      <- checkExportTypes  config_top
+                        $  moduleExportTypes mm
 
+
         -- Check the sigs of exported values --------------
-        esrcsValue'     <- checkExportValues config kenv' 
-                        $ moduleExportValues mm
-        
-        
-        -- Check the local data type defs -----------------
-        defs'           <- case checkDataDefs config (moduleDataDefsLocal mm) of
-                                (err : _, _)   -> throw $ ErrorData err
-                                ([], defs')    -> return defs'
+        esrcsValue'     <- checkExportValues config_top kenv_top
+                        $  moduleExportValues mm
 
-        let defs_all =  unionDataDefs (configDataDefs config) 
-                                      (fromListDataDefs defs')
-                                      
-        
-        -- Check the body of the module -------------------
-        let bsData      = [BName (dataDefTypeName def) (kindOfDataDef def) | def <- defs' ]
-        let kenv_data   = Env.union kenv' (Env.fromList bsData)                    
-        let config_data = config { configDataDefs = defs_all }
 
-        (x', _, _effs, _, ctx) 
-                <- checkExpM 
-                        (makeTable config_data kenv_data tenv')
-                        emptyContext (moduleBody mm) mode
+        -- Check the body of the module -------------------
+        (x', _, _effs, ctx)
+         <- checkExpM   (makeTable config_top kenv_top tenv_top)
+                        ctx_top mode DemandNone (moduleBody mm) 
 
         -- Apply the final context to the annotations in expressions.
-        let applyToAnnot (AnTEC t0 e0 c0 x0)
-                = AnTEC (applySolved ctx t0)
-                        (applySolved ctx e0)
-                        (applySolved ctx c0)
-                        x0
+        let applyToAnnot (AnTEC t0 e0 _ x0)
+             = do t0' <- applySolved ctx t0
+                  e0' <- applySolved ctx e0
+                  return $ AnTEC t0' e0' (tBot kClosure) x0
 
-        let x'' = reannotate applyToAnnot 
-                $ mapT (applySolved ctx) x'
+        xx_solved <- mapT (applySolved ctx) x'
+        xx_annot  <- reannotateM applyToAnnot xx_solved
 
+        -- Build new module with infered annotations ------
+        let mm_inferred
+                = mm
+                { moduleExportTypes     = esrcsType'
+                , moduleImportTypes     = nksImported'
+                , moduleImportCaps      = ntsImportCap'
+                , moduleImportValues    = ntsImportValue'
+                , moduleBody            = xx_annot }
 
+
         -- Check that each exported signature matches the type of its binding.
-        envDef  <- checkModuleBinds (moduleExportTypes mm) (moduleExportValues mm) x''
+        -- This returns an environment containing all the bindings defined
+        -- in the module.
+        tenv_binds      <- checkModuleBinds
+                                (moduleExportTypes  mm_inferred)
+                                (moduleExportValues mm_inferred) 
+                                xx_annot
 
-        -- Check that all exported bindings are defined by the module.
-        mapM_ (checkBindDefined envDef) 
-                $ map fst $ moduleExportValues mm
+        -- Build the environment containing all names that can be exported.
+        let tenv_exportable = Env.union tenv_top tenv_binds
 
-        -- If exported names are missing types then fill them in.
-        let tsTop       = moduleTopBindTypes mm
+        -- Check that all exported bindings are defined by the module,
+        --   either directly as bindings, or by importing them from somewhere else.
+        --   Header modules don't need to contain the complete set of bindings,
+        --   but all other modules do.
+        when (not $ moduleIsHeader mm_inferred)
+                $ mapM_ (checkBindDefined tenv_exportable)
+                $ map fst $ moduleExportValues mm_inferred
 
+        -- If exported names are missing types then fill them in.
         let updateExportSource e
                 | ExportSourceLocalNoType n <- e
-                , Just t  <- Map.lookup n tsTop   
+                , Just t  <- Env.lookup (UName n) tenv_exportable
                 = ExportSourceLocal n t
-                
+
                 | otherwise = e
 
         let esrcsValue_updated
                 = [ (n, updateExportSource e) | (n, e) <- esrcsValue' ]
 
-                                 
         -- Return the checked bindings as they have explicit type annotations.
-        let mm' = mm    
-                { moduleExportTypes     = esrcsType'
-                , moduleExportValues    = esrcsValue_updated
-                , moduleImportTypes     = nksImport'
-                , moduleImportValues    = ntsImport'
-                , moduleBody            = x'' }
+        let mm_final
+                = mm_inferred
+                { moduleExportValues    = esrcsValue_updated }
 
-        return mm'
+        return mm_final
 
 
 ---------------------------------------------------------------------------------------------------
@@ -178,12 +226,12 @@
         (case takeHead dups of
           Just n -> throw $ ErrorExportDuplicate n
           _      -> return ())
-        
 
+
         -- Check the kinds of the export specs.
         mapM check nesrcs
- 
 
+
 ---------------------------------------------------------------------------------------------------
 -- | Check exported types.
 checkExportValues
@@ -217,39 +265,122 @@
 checkImportTypes
         :: (Ord n, Show n, Pretty n)
         => Config n -> Mode n
-        -> [(n, ImportSource n)]
-        -> CheckM a n [(n, ImportSource n)]
+        -> [(n, ImportType n)]
+        -> CheckM a n [(n, ImportType n)]
 
 checkImportTypes config mode nisrcs
- = let  
+ = let
         -- Checker mode to use.
         modeCheckImportTypes
          = case mode of
                 Recon   -> Recon
                 _       -> Synth
 
+        -- Check an import definition.
         check (n, isrc)
-         = do   let k           =  typeOfImportSource isrc
-                (k', _, _)      <- checkTypeM config Env.empty emptyContext UniverseKind
+         = do   let k      =  kindOfImportType isrc
+                (k', _, _) <- checkTypeM config Env.empty emptyContext UniverseKind
                                         k modeCheckImportTypes
-                return  (n, mapTypeOfImportSource (const k') isrc)
+                return  (n, mapKindOfImportType (const k') isrc)
+
+        -- Pack down duplicate import definitions.
+        --   We can import the same value via multiple modules,
+        --   which is ok provided all instances have the same kind.
+        pack !mm []
+         = return $ Map.toList mm
+
+        pack !mm ((n, isrc) : nis)
+         = case Map.lookup n mm of
+                Just isrc'
+                 | compat isrc isrc' -> pack mm nis
+                 | otherwise         -> throw $ ErrorImportDuplicate n
+
+                Nothing              -> pack (Map.insert n isrc mm) nis
+
+        -- Check if two import definitions with the same name are compatible.
+        -- The same import definition can appear multiple times provided
+        -- each instance has the same name and kind.
+        compat (ImportTypeAbstract k1) (ImportTypeAbstract k2) = equivT k1 k2
+        compat (ImportTypeBoxed    k1) (ImportTypeBoxed    k2) = equivT k1 k2
+        compat _ _ = False
+
    in do
-        -- Check for duplicate imports.
-        let dups = findDuplicates $ map fst nisrcs
-        (case takeHead dups of
-          Just n -> throw $ ErrorImportDuplicate n
-          _      -> return ())
+        -- Check all the imports individually.
+        nisrcs' <- mapM check nisrcs
 
-        mapM check nisrcs
+        -- Check that exports with the same name are compatable,
+        -- and pack down duplicates.
+        pack Map.empty nisrcs'
 
 
 ---------------------------------------------------------------------------------------------------
+-- | Check types of imported capabilities.
+checkImportCaps
+        :: (Ord n, Show n, Pretty n)
+        => Config n -> KindEnv n -> Mode n
+        -> [(n, ImportCap n)]
+        -> CheckM a n [(n, ImportCap n)]
+
+checkImportCaps config kenv mode nisrcs
+ = let
+        -- Checker mode to use.
+        modeCheckImportCaps
+         = case mode of
+                Recon   -> Recon
+                _       -> Check kEffect
+
+        -- Check an import definition.
+        check (n, isrc)
+         = do   let t      =  typeOfImportCap isrc
+                (t', k, _) <- checkTypeM config kenv emptyContext UniverseSpec
+                                         t modeCheckImportCaps
+
+                -- In Recon mode we need to post-check that the imported
+                -- capability really has kind Effect.
+                --
+                -- In Check mode we pass down the expected kind,
+                -- so this is checked locally.
+                -- 
+                when (not $ isEffectKind k)
+                 $ throw $ ErrorImportCapNotEffect n
+
+                return (n, mapTypeOfImportCap (const t') isrc)
+
+        -- Pack down duplicate import definitions.
+        --   We can import the same capability via multiple modules,
+        --   which is ok provided all instances have the same type.
+        pack !mm []
+         = return $ Map.toList mm
+
+        pack !mm ((n, isrc) : nis)
+         = case Map.lookup n mm of
+                Just isrc'
+                 | compat isrc isrc'    -> pack mm nis
+                 | otherwise            -> throw $ ErrorImportDuplicate n
+
+                Nothing                 -> pack (Map.insert n isrc mm) nis
+
+        -- Check if two imported capabilities of the same name are compatiable.
+        -- The same import definition can appear multiple times provided each 
+        -- instance has the same name and type.
+        compat (ImportCapAbstract t1) (ImportCapAbstract t2) = equivT t1 t2
+
+    in do
+        -- Check all the imports individually.
+        nisrcs' <- mapM check nisrcs
+
+        -- Check that imports with the same name are compatable,
+        -- and pack down duplicates.
+        pack Map.empty nisrcs'
+
+
+---------------------------------------------------------------------------------------------------
 -- | Check types of imported values.
 checkImportValues
         :: (Ord n, Show n, Pretty n)
         => Config n -> KindEnv n -> Mode n
-        -> [(n, ImportSource n)]
-        -> CheckM a n [(n, ImportSource n)]
+        -> [(n, ImportValue n)]
+        -> CheckM a n [(n, ImportValue n)]
 
 checkImportValues config kenv mode nisrcs
  = let
@@ -259,31 +390,60 @@
                 Recon   -> Recon
                 _       -> Check kData
 
+        -- Check an import definition.
         check (n, isrc)
-         = do   let t           = typeOfImportSource isrc
-                (t', k, _)      <- checkTypeM config kenv emptyContext UniverseSpec
-                                        t modeCheckImportTypes
+         = do   let t      =  typeOfImportValue isrc
+                (t', k, _) <- checkTypeM config kenv emptyContext UniverseSpec
+                                         t modeCheckImportTypes
 
                 -- In Recon mode we need to post-check that the imported
-                -- value really has kind data. In inference mode the expected
-                -- kind we pass down will handle this.
+                -- value really has kind Data.
+                --
+                -- In Check mode we pass down the expected kind,
+                -- so this is checked locally.
+                --
                 when (not $ isDataKind k)
                  $ throw $ ErrorImportValueNotData n
 
-                return  (n, mapTypeOfImportSource (const t') isrc)
+                return  (n, mapTypeOfImportValue (const t') isrc)
+
+        -- Pack down duplicate import definitions.
+        --   We can import the same value via multiple modules,
+        --   which is ok provided all instances have the same type.
+        pack !mm []
+         = return $ Map.toList mm
+
+        pack !mm ((n, isrc) : nis)
+         = case Map.lookup n mm of
+                Just isrc'
+                  | compat isrc isrc'   -> pack mm nis
+                  | otherwise           -> throw $ ErrorImportDuplicate n
+
+                Nothing                 -> pack (Map.insert n isrc mm) nis
+
+        -- Check if two imported values of the same name are compatable.
+        compat (ImportValueModule _ _ t1 a1) 
+               (ImportValueModule _ _ t2 a2)
+         = equivT t1 t2 && a1 == a2
+
+        compat (ImportValueSea _ t1)
+               (ImportValueSea _ t2)
+         = equivT t1 t2 
+
+        compat _ _ = False
+
    in do
-        -- Check for duplicate imports.
-        let dups = findDuplicates $ map fst nisrcs
-        (case takeHead dups of
-          Just n -> throw $ ErrorImportDuplicate n
-          _      -> return ())
+        -- Check all the imports individually.
+        nisrcs' <- mapM check nisrcs
 
-        mapM check nisrcs        
+        -- Check that imports with the same name are compatable,
+        -- and pack down duplicates.
+        pack Map.empty nisrcs'
 
 
 ---------------------------------------------------------------------------------------------------
 -- | Check that the exported signatures match the types of their bindings.
-checkModuleBinds 
+checkModuleBinds
         :: Ord n
         => [(n, ExportSource n)]        -- ^ Exported types.
         -> [(n, ExportSource n)]        -- ^ Exported values
@@ -293,7 +453,7 @@
 
 checkModuleBinds !ksExports !tsExports !xx
  = case xx of
-        XLet _ (LLet b _) x2     
+        XLet _ (LLet b _) x2
          -> do  checkModuleBind  ksExports tsExports b
                 env     <- checkModuleBinds ksExports tsExports x2
                 return  $ Env.extend b env
@@ -310,7 +470,7 @@
 
 
 -- | If some bind is exported, then check that it matches the exported version.
-checkModuleBind 
+checkModuleBind
         :: Ord n
         => [(n, ExportSource n)]        -- ^ Exported types.
         -> [(n, ExportSource n)]        -- ^ Exported values.
@@ -321,22 +481,22 @@
  | BName n tDef <- b
  = case join $ liftM takeTypeOfExportSource $ lookup n tsExports of
         Nothing                 -> return ()
-        Just tExport 
+        Just tExport
          | equivT tDef tExport  -> return ()
          | otherwise            -> throw $ ErrorExportMismatch n tExport tDef
 
- -- Only named bindings can be exported, 
+ -- Only named bindings can be exported,
  --  so we don't need to worry about non-named ones.
  | otherwise
  = return ()
 
 
 ---------------------------------------------------------------------------------------------------
--- | Check that a top-level binding is actually defined by the module.
-checkBindDefined 
+-- | Check that an exported top-level value is actually defined by the module.
+checkBindDefined
         :: Ord n
-        => TypeEnv n                    -- ^ Types defined by the module.
-        -> n                            -- ^ Name of an exported binding.
+        => TypeEnv n            -- ^ Types defined by the module.
+        -> n                    -- ^ Name of an exported binding.
         -> CheckM a n ()
 
 checkBindDefined env n
diff --git a/DDC/Core/Check/TaggedClosure.hs b/DDC/Core/Check/TaggedClosure.hs
deleted file mode 100644
--- a/DDC/Core/Check/TaggedClosure.hs
+++ /dev/null
@@ -1,234 +0,0 @@
-
-module DDC.Core.Check.TaggedClosure
-        ( TaggedClosure(..)
-        , closureOfTagged
-        , closureOfTaggedSet
-        , taggedClosureOfValBound
-        , taggedClosureOfTyArg
-        , taggedClosureOfWeakClo
-        , maskFromTaggedSet
-        , cutTaggedClosureX
-        , cutTaggedClosureXs
-        , cutTaggedClosureT)
-where
-import DDC.Type.Check.Context
-import DDC.Type.Transform.LiftT
-import DDC.Type.Transform.Trim
-import DDC.Type.Compounds
-import DDC.Type.Predicates
-import DDC.Type.Pretty
-import DDC.Type.Exp
-import Control.Monad
-import Data.Maybe
-import Data.Set                 (Set)
-import DDC.Type.Env             (Env)
-import qualified DDC.Type.Env   as Env
-import qualified DDC.Type.Sum   as Sum
-import qualified Data.Set       as Set
-
-
--- | A closure-term tagged with the bound variable that the term is due to.
-data TaggedClosure n
-        -- | Term due to a free value variable.
-        = GBoundVal    (Bound n) (TypeSum n)
-
-        -- | Term due to a free region variable.
-        | GBoundRgnVar (Bound n)
-
-        -- | Term due to a region handle.
-        | GBoundRgnCon (Bound n)
-        deriving Show
-
-
-instance Eq n  => Eq (TaggedClosure n) where
- (==)    (GBoundVal u1 _)  (GBoundVal u2 _)     = u1 == u2
- (==)    (GBoundRgnVar u1) (GBoundRgnVar u2)    = u1 == u2
- (==)    (GBoundRgnCon u1) (GBoundRgnCon u2)    = u1 == u2
- (==)    _                 _                    = False
- 
-
-instance Ord n => Ord (TaggedClosure n) where
- compare g1 g2 = compare (ordify g1) (ordify g2)
-  where 
-        ordify gg
-         = case gg of
-                GBoundVal u _   -> (0, u) :: (Int, Bound n)
-                GBoundRgnVar u  -> (1, u)
-                GBoundRgnCon u  -> (2, u)
-
-
-instance (Eq n, Pretty n) => Pretty (TaggedClosure n) where
- ppr cc
-  = case cc of
-        GBoundVal    u clos -> text "CLOVAL   " <+> ppr u <+> text ":" <+> ppr clos
-        GBoundRgnVar u      -> text "CLORGNVAR" <+> ppr u
-        GBoundRgnCon u      -> text "CLORGNCON" <+> ppr u
-
-
-instance Ord n => MapBoundT TaggedClosure n where
- mapBoundAtDepthT f d cc
-  = let down = mapBoundAtDepthT f d
-    in case cc of
-        GBoundVal u ts    -> GBoundVal (down u) (down ts)
-        GBoundRgnVar u1   -> GBoundRgnVar (down u1)
-        GBoundRgnCon u2   -> GBoundRgnCon u2
-
-
--- | Convert a tagged clousure to a regular closure by dropping the tag variables.
-closureOfTagged :: TaggedClosure n -> Closure n
-closureOfTagged gg
- = case gg of
-        GBoundVal _ clos  -> TSum $ clos
-        GBoundRgnVar u    -> tUse (TVar u)
-        GBoundRgnCon u    -> tUse (TCon (TyConBound u kRegion))
-
-
--- | Convert a set of tagged closures to a regular closure by dropping the
---   tag variables.
-closureOfTaggedSet :: Ord n => Set (TaggedClosure n) -> Closure n
-closureOfTaggedSet clos
-        = TSum  $ Sum.fromList kClosure 
-                $ map closureOfTagged 
-                $ Set.toList clos
-
-
--- | Yield the tagged closure of a value variable.
-taggedClosureOfValBound 
-        :: (Ord n, Pretty n) 
-        => Type n -> Bound n  -> TaggedClosure n
-
-taggedClosureOfValBound t u 
-        = GBoundVal u 
-        $ Sum.singleton kClosure 
-        $ (let clo = tDeepUse t
-           in  fromMaybe clo (trimClosure clo))
-
-
--- | Yield the tagged closure of a type argument,
---   or `Nothing` for out-of-scope type vars.
-taggedClosureOfTyArg 
-        :: (Ord n, Pretty n) 
-        => Env n -> Context n -> Type n -> Maybe (Set (TaggedClosure n))
-
-taggedClosureOfTyArg kenv ctx tt
- = case tt of
-        TVar u
-         | Just k          <- Env.lookup u kenv
-         -> if isRegionKind k 
-                then Just $ Set.singleton $ GBoundRgnVar u
-                else Just Set.empty
-                 
-         | Just (k, _role) <- lookupKind u ctx
-         -> if isRegionKind k
-                then Just $ Set.singleton $ GBoundRgnVar u
-                else Just Set.empty
-                                                    
-        TCon (TyConBound u k)
-         |   isRegionKind k
-         ->  Just $ Set.singleton $ GBoundRgnCon u
-
-        _ -> Just $ Set.empty
-
-
--- | Convert the closure provided as a 'weakclo' to tagged form.
---   Only terms of form `Use r` can be converted.
-taggedClosureOfWeakClo 
-        :: (Ord n, Pretty n)
-        => Closure n -> Maybe (Set (TaggedClosure n))
-
-taggedClosureOfWeakClo clo
- = liftM Set.fromList
-         $ sequence
-         $ map convert 
-         $ Sum.toList $ Sum.singleton kClosure clo
-
- where  convert c
-         = case takeTyConApps c of
-            Just (TyConSpec TcConUse, [TVar u])
-              -> Just $ GBoundRgnVar u
-
-            Just (TyConSpec TcConUse, [TCon (TyConBound u _)])
-              -> Just $ GBoundRgnCon u
-
-            _ -> Nothing
-
-
--- | Mask a closure term from a tagged closure.
---
---   This is used for the `forget` cast.
-maskFromTaggedSet 
-        :: Ord n 
-        => TypeSum n 
-        -> Set (TaggedClosure n) -> Set (TaggedClosure n)
-maskFromTaggedSet ts1 set
-        = Set.fromList $ mapMaybe mask $ Set.toList set
-
- where mask gg
-        = case gg of
-           GBoundVal u ts2              
-            -> Just $ GBoundVal u $ ts2 `Sum.difference` ts1
-
-           GBoundRgnVar u
-            | Sum.elem (tUse (TVar u)) ts1
-                                -> Nothing
-            | otherwise         -> Just gg
-
-           GBoundRgnCon u
-            | Sum.elem (tUse (TCon (TyConBound u kRegion))) ts1     
-                                -> Nothing
-            | otherwise         -> Just gg
-
-
--- | Cut the terms due to the outermost binder from a tagged closure.
-cutTaggedClosureT 
-        :: (Eq n, Ord n) 
-        => Bind n 
-        -> TaggedClosure n 
-        -> Maybe (TaggedClosure n)
-
-cutTaggedClosureT b1 cc
- = let lower    = case b1 of
-                        BAnon{} -> lowerT 1
-                        _       -> id
-   in case cc of
-        GBoundVal u2 ts            -> Just $ GBoundVal u2 (lower ts)
-
-        GBoundRgnVar u2 
-         | boundMatchesBind u2 b1  -> Nothing
-         | otherwise               -> Just $ GBoundRgnVar (lower u2)
-
-        GBoundRgnCon u2            -> Just $ GBoundRgnCon (lower u2)
-
-
--- | Like `cutTaggedClosureX` but cut terms due to several binders.
-cutTaggedClosureXs 
-        :: (Eq n, Ord n)
-        => [Bind n]
-        -> TaggedClosure n -> Maybe (TaggedClosure n)
-
-cutTaggedClosureXs bb c 
- = case bb of
-        []       -> Just c
-        (b:bs)   -> case cutTaggedClosureX b c of
-                        Nothing -> Nothing
-                        Just c' -> cutTaggedClosureXs bs c'
-
-
--- | Cut the terms due to the outermost binder from a tagged closure.
-cutTaggedClosureX
-        :: (Eq n, Ord n) 
-        => Bind n 
-        -> TaggedClosure n 
-        -> Maybe (TaggedClosure n)
-
-cutTaggedClosureX b1 cc
- = let lower    = case b1 of
-                        BAnon{} -> lowerT 1
-                        _       -> id
-   in case cc of
-        GBoundVal u2 ts
-         | boundMatchesBind u2 b1  -> Nothing
-         | otherwise               -> Just $ GBoundVal (lower u2) ts
-
-        GBoundRgnVar u2            -> Just $ GBoundRgnVar u2
-        GBoundRgnCon u2            -> Just $ GBoundRgnCon u2
diff --git a/DDC/Core/Check/Witness.hs b/DDC/Core/Check/Witness.hs
--- a/DDC/Core/Check/Witness.hs
+++ b/DDC/Core/Check/Witness.hs
@@ -3,32 +3,29 @@
         ( checkWitness
         , checkWitnessM
         , typeOfWitness
-        , typeOfWiCon
-        , typeOfWbCon)
+        , typeOfWiCon)
 where
-import DDC.Core.Annot.AnT
+import DDC.Core.Exp.Annot.AnT
 import DDC.Core.Check.Error
 import DDC.Core.Check.ErrorMessage              ()
 import DDC.Core.Check.Base
 import DDC.Type.Transform.SubstituteT
-import Data.Monoid                              hiding ((<>))
 import qualified DDC.Type.Env                   as Env
-import qualified DDC.Type.Sum                   as Sum
 
 
 -- Wrappers --------------------------------------------------------------------
 -- | Check a witness.
---   
+--
 --   If it's good, you get a new version with types attached to all the bound
 --   variables, as well as the type of the overall witness.
 --
 --   If it's bad, you get a description of the error.
 --
---   The returned expression has types attached to all variable occurrences, 
+--   The returned expression has types attached to all variable occurrences,
 --   so you can call `typeOfWitness` on any open subterm.
 --
---   The kinds and types of primitives are added to the environments 
---   automatically, you don't need to supply these as part of the 
+--   The kinds and types of primitives are added to the environments
+--   automatically, you don't need to supply these as part of the
 --   starting environments.
 --
 checkWitness
@@ -37,7 +34,7 @@
         -> KindEnv n            -- ^ Starting Kind Environment.
         -> TypeEnv n            -- ^ Strating Type Environment.
         -> Witness a n          -- ^ Witness to check.
-        -> Either (Error a n) 
+        -> Either (Error a n)
                   ( Witness (AnT a n) n
                   , Type n)
 
@@ -52,13 +49,13 @@
 --   must be attached directly to the bound occurrences.
 --   This attachment is performed by `checkWitness` above.
 --
-typeOfWitness 
-        :: (Ord n, Show n, Pretty n) 
+typeOfWitness
+        :: (Ord n, Show n, Pretty n)
         => Config n
-        -> Witness a n 
+        -> Witness a n
         -> Either (Error a n) (Type n)
 
-typeOfWitness config ww 
+typeOfWitness config ww
  = case checkWitness config Env.empty Env.empty ww of
         Left  err       -> Left err
         Right (_, t)    -> Right t
@@ -66,14 +63,14 @@
 
 ------------------------------------------------------------------------------
 -- | Like `checkWitness` but using the `CheckM` monad to manage errors.
-checkWitnessM 
+checkWitnessM
         :: (Ord n, Show n, Pretty n)
         => Config n             -- ^ Data type definitions.
         -> KindEnv n            -- ^ Kind environment.
         -> TypeEnv n            -- ^ Type environment.
         -> Context n            -- ^ Input context
         -> Witness a n          -- ^ Witness to check.
-        -> CheckM a n 
+        -> CheckM a n
                 ( Witness (AnT a n) n
                 , Type n)
 
@@ -83,17 +80,17 @@
  = return ( WVar (AnT t a) u, t)
 
  -- Witness is defined globally.
- | Just t       <- Env.lookup u tenv 
+ | Just t       <- Env.lookup u tenv
  = return ( WVar (AnT t a) u, t)
-           
+
  | otherwise
  = throw $ ErrorUndefinedVar a u UniverseWitness
- 
+
 checkWitnessM !_config !_kenv !_tenv !_ctx (WCon a wc)
  = let  t'       = typeOfWiCon wc
    in   return  ( WCon (AnT t' a) wc
                 , t')
-  
+
 -- witness-type application
 checkWitnessM !config !kenv !tenv !ctx ww@(WApp a1 w1 (WType a2 t2))
  = do   (w1', t1)       <- checkWitnessM  config kenv tenv ctx w1
@@ -114,56 +111,23 @@
         (w2', t2)       <- checkWitnessM config kenv tenv ctx w2
         case t1 of
          TApp (TApp (TCon (TyConWitness TwConImpl)) t11) t12
-          |  t11 == t2   
+          |  t11 == t2
           -> return ( WApp (AnT t12 a) w1' w2'
                     , t12)
-          
+
           | otherwise   -> throw $ ErrorWAppMismatch a ww t11 t2
          _              -> throw $ ErrorWAppNotCtor  a ww t1 t2
 
--- witness joining
-checkWitnessM !config !kenv !tenv !ctx ww@(WJoin a w1 w2)
- = do   (w1', t1) <- checkWitnessM config kenv tenv ctx w1
-        (w2', t2) <- checkWitnessM config kenv tenv ctx w2
-        case (t1, t2) of
-         (  TApp (TCon (TyConWitness TwConPure)) eff1
-          , TApp (TCon (TyConWitness TwConPure)) eff2)
-          -> let t'     = TApp (TCon (TyConWitness TwConPure))
-                               (TSum $ Sum.fromList kEffect  [eff1, eff2])
-             in  return ( WJoin (AnT t' a) w1' w2'
-                        , t')
-
-         (  TApp (TCon (TyConWitness TwConEmpty)) clo1
-          , TApp (TCon (TyConWitness TwConEmpty)) clo2)
-          -> let t'     = TApp (TCon (TyConWitness TwConEmpty))
-                               (TSum $ Sum.fromList kClosure [clo1, clo2])
-             in  return ( WJoin (AnT t' a) w1' w2'
-                        , t')
-
-         _ -> throw $ ErrorCannotJoin a ww w1 t1 w2 t2
-
 -- embedded types
 checkWitnessM !config !kenv !_tenv !ctx (WType a t)
  = do   (t', k, _)  <- checkTypeM config kenv ctx UniverseSpec t Recon
         return  ( WType (AnT k a) t'
                 , k)
-        
 
+
 -- | Take the type of a witness constructor.
 typeOfWiCon :: WiCon n -> Type n
 typeOfWiCon wc
  = case wc of
-    WiConBuiltin wb -> typeOfWbCon wb
     WiConBound _ t  -> t
-
-
--- | Take the type of a builtin witness constructor.
-typeOfWbCon :: WbCon -> Type n
-typeOfWbCon wb
- = case wb of
-    WbConPure    -> tPure  (tBot kEffect)
-    WbConEmpty   -> tEmpty (tBot kClosure)
-    WbConUse     -> tForall kRegion $ \r -> tGlobal r `tImpl` (tEmpty $ tUse r)
-    WbConRead    -> tForall kRegion $ \r -> tConst  r `tImpl` (tPure  $ tRead r)
-    WbConAlloc   -> tForall kRegion $ \r -> tConst  r `tImpl` (tPure  $ tAlloc r)
 
diff --git a/DDC/Core/Collect/Free.hs b/DDC/Core/Collect/Free.hs
--- a/DDC/Core/Collect/Free.hs
+++ b/DDC/Core/Collect/Free.hs
@@ -17,8 +17,8 @@
 
 -- freeX ----------------------------------------------------------------------
 -- | Collect the free Data and Witness variables in a thing (level-0).
-freeX   :: (BindStruct c, Ord n) 
-        => Env n -> c n -> Set (Bound n)
+freeX   :: (BindStruct c n, Ord n) 
+        => Env n -> c -> Set (Bound n)
 freeX tenv xx = Set.unions $ map (freeOfTreeX tenv) $ slurpBindTree xx
 
 freeOfTreeX :: Ord n => Env n -> BindTree n -> Set (Bound n)
@@ -41,13 +41,13 @@
 
 
 -- Module ---------------------------------------------------------------------
-instance BindStruct (Module a) where
+instance BindStruct (Module a n) n where
  slurpBindTree mm
         = slurpBindTree $ moduleBody mm
 
 
 -- Exp ------------------------------------------------------------------------
-instance BindStruct (Exp a) where
+instance BindStruct (Exp a n) n where
  slurpBindTree xx
   = case xx of
         XVar _ u
@@ -76,27 +76,22 @@
          ++ [ BindDef  BindLetRegions b
              [bindDefX BindLetRegionWith bs [x2]]]
 
-        XLet _ (LWithRegion u) x2
-         -> BindUse BoundExp u : slurpBindTree x2
-
         XCase _ x alts  -> slurpBindTree x ++ concatMap slurpBindTree alts
         XCast _ c x     -> slurpBindTree c ++ slurpBindTree x
         XType _ t       -> slurpBindTree t
         XWitness _ w    -> slurpBindTree w
 
 
-instance BindStruct (Cast a) where
+instance BindStruct (Cast a n) n where
  slurpBindTree cc
   = case cc of
         CastWeakenEffect  eff   -> slurpBindTree eff
-        CastWeakenClosure xs    -> concatMap slurpBindTree xs
         CastPurify w            -> slurpBindTree w
-        CastForget w            -> slurpBindTree w
         CastBox                 -> []
         CastRun                 -> []
 
 
-instance BindStruct (Alt a) where
+instance BindStruct (Alt a n) n where
  slurpBindTree alt
   = case alt of
         AAlt PDefault x
@@ -106,19 +101,18 @@
          -> [bindDefX BindCasePat bs [x]]
 
 
-instance BindStruct (Witness a) where
+instance BindStruct (Witness a n) n where
  slurpBindTree ww
   = case ww of
         WVar _ u        -> [BindUse BoundWit u]
         WCon{}          -> []
         WApp  _ w1 w2   -> slurpBindTree w1 ++ slurpBindTree w2
-        WJoin _ w1 w2   -> slurpBindTree w1 ++ slurpBindTree w2
         WType _ t       -> slurpBindTree t
 
 
 -- | Helper for constructing the `BindTree` for an expression or witness binder.
-bindDefX :: BindStruct c 
-         => BindWay -> [Bind n] -> [c n] -> BindTree n
+bindDefX :: BindStruct c n
+         => BindWay -> [Bind n] -> [c] -> BindTree n
 bindDefX way bs xs
         = BindDef way bs
         $   concatMap (slurpBindTree . typeOfBind) bs
diff --git a/DDC/Core/Collect/Free/Simple.hs b/DDC/Core/Collect/Free/Simple.hs
--- a/DDC/Core/Collect/Free/Simple.hs
+++ b/DDC/Core/Collect/Free/Simple.hs
@@ -4,11 +4,11 @@
 where
 import DDC.Type.Collect
 import DDC.Core.Collect.Free
-import DDC.Core.Exp.Simple
+import DDC.Core.Exp.Simple.Exp
 
 
 -- Exp ------------------------------------------------------------------------
-instance BindStruct (Exp a) where
+instance BindStruct (Exp a n) n where
  slurpBindTree xx
   = case xx of
         XAnnot _ x
@@ -41,27 +41,22 @@
          ++ [ BindDef  BindLetRegions bsR
              [bindDefX BindLetRegionWith bs [x2]] ]
 
-        XLet (LWithRegion u) x2
-         -> BindUse BoundExp u : slurpBindTree x2
-
         XCase x alts    -> slurpBindTree x ++ concatMap slurpBindTree alts
         XCast c x       -> slurpBindTree c ++ slurpBindTree x
         XType t         -> slurpBindTree t
         XWitness w      -> slurpBindTree w
 
 
-instance BindStruct (Cast a) where
+instance BindStruct (Cast a n) n where
  slurpBindTree cc
   = case cc of
         CastWeakenEffect  eff   -> slurpBindTree eff
-        CastWeakenClosure xs    -> concatMap slurpBindTree xs
         CastPurify w            -> slurpBindTree w
-        CastForget w            -> slurpBindTree w
         CastBox                 -> []
         CastRun                 -> []
 
 
-instance BindStruct (Alt a) where
+instance BindStruct (Alt a n) n where
  slurpBindTree alt
   = case alt of
         AAlt PDefault x
@@ -71,13 +66,12 @@
          -> [bindDefX BindCasePat bs [x]]
 
 
-instance BindStruct (Witness a) where
+instance BindStruct (Witness a n) n where
  slurpBindTree ww
   = case ww of
         WVar u          -> [BindUse BoundWit u]
         WCon{}          -> []
         WApp  w1 w2     -> slurpBindTree w1 ++ slurpBindTree w2
-        WJoin w1 w2     -> slurpBindTree w1 ++ slurpBindTree w2
         WType t         -> slurpBindTree t
         WAnnot _ w      -> slurpBindTree w
 
diff --git a/DDC/Core/Collect/Support.hs b/DDC/Core/Collect/Support.hs
--- a/DDC/Core/Collect/Support.hs
+++ b/DDC/Core/Collect/Support.hs
@@ -1,19 +1,20 @@
 
 module DDC.Core.Collect.Support
         ( Support       (..)
-        , SupportX      (..))
+        , SupportX      (..)
+        , supportEnvFlags)
 where
-import DDC.Core.Compounds
-import DDC.Core.Exp
+import DDC.Core.Module
+import DDC.Core.Exp.Annot
 import DDC.Type.Collect.FreeT
 import Data.Set                 (Set)
 import DDC.Type.Env             (KindEnv, TypeEnv)
 import qualified DDC.Type.Env   as Env
 import qualified Data.Set       as Set
-import Data.Monoid
 import Data.Maybe
-
+import Data.Monoid              ((<>))
 
+---------------------------------------------------------------------------------------------------
 data Support n
         = Support
         { -- | Type constructors used in the expression.
@@ -57,6 +58,26 @@
         , supportDaVar          = Set.unions [supportDaVar sp1,     supportDaVar sp2] }
 
 
+---------------------------------------------------------------------------------------------------
+-- | Get a description of the type and value environment from a Support.
+--   Type (level-1) variables are tagged with True, while
+--   value and witness (level-0) variables are tagged with False.
+supportEnvFlags
+        :: Ord n => Support n 
+        -> Set (Bool, Bound n)
+
+supportEnvFlags supp
+ = let  
+        us1   = Set.map  (\u -> (True,  u)) $ supportSpVar supp
+
+        us0   = Set.unions
+                [ Set.map  (\u -> (False, u)) $ supportDaVar supp
+                , Set.map  (\u -> (False, u)) $ supportWiVar supp]
+
+   in   Set.union us1 us0
+
+
+---------------------------------------------------------------------------------------------------
 class SupportX (c :: * -> *) where
  support
         :: Ord n
@@ -72,10 +93,11 @@
                 , supportSpVar  = fvs1 }
 
 
-instance SupportX Bind where
- support kenv tenv b
-  = support kenv tenv 
-  $ typeOfBind b
+instance SupportX (Module a) where
+ support kenv tenv mm
+  = let kenv'   = Env.union kenv (moduleKindEnv mm)
+        tenv'   = Env.union tenv (moduleTypeEnv mm)
+    in  support kenv' tenv' (moduleBody mm)
 
 
 instance SupportX (Exp a) where
@@ -152,10 +174,6 @@
          -> support kenv tenv w1
          <> support kenv tenv w2
 
-        WJoin _ w1 w2
-         -> support kenv tenv w1
-         <> support kenv tenv w2
-
         WType _ t
          -> support kenv tenv t
 
@@ -166,15 +184,9 @@
         CastWeakenEffect eff
          -> support kenv tenv eff
 
-        CastWeakenClosure xs
-         -> mconcat $ map (support kenv tenv) xs
-
         CastPurify w
          -> support kenv tenv w
 
-        CastForget w
-         -> support kenv tenv w
-
         CastBox
          -> mempty
 
@@ -200,7 +212,10 @@
          <> (let kenv' = Env.extends bs kenv
              in  mconcat $ map (support kenv' tenv) ws)
 
-        LWithRegion u
-         | Env.member u kenv    -> mempty
-         | otherwise            -> mempty { supportSpVar = Set.singleton u }
+
+instance SupportX Bind where
+ support kenv tenv b
+  = support kenv tenv 
+  $ typeOfBind b
+
 
diff --git a/DDC/Core/Compounds.hs b/DDC/Core/Compounds.hs
deleted file mode 100644
--- a/DDC/Core/Compounds.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-
--- | Utilities for constructing and destructing compound expressions.
-module DDC.Core.Compounds 
-        ( module DDC.Core.Compounds.Annot )
-where
-import DDC.Core.Compounds.Annot
-
diff --git a/DDC/Core/Compounds/Annot.hs b/DDC/Core/Compounds/Annot.hs
deleted file mode 100644
--- a/DDC/Core/Compounds/Annot.hs
+++ /dev/null
@@ -1,358 +0,0 @@
-
--- | Utilities for constructing and destructing compound expressions.
---
---   For the annotated version of the AST.
-module DDC.Core.Compounds.Annot
-        ( module DDC.Type.Compounds
-
-          -- * Annotations
-        , annotOfExp
-
-          -- * Lambdas
-        , xLAMs
-        , xLams
-        , makeXLamFlags
-        , takeXLAMs
-        , takeXLams
-        , takeXLamFlags
-
-          -- * Applications
-        , xApps
-        , makeXAppsWithAnnots
-        , takeXApps
-        , takeXApps1
-        , takeXAppsAsList
-        , takeXAppsWithAnnots
-        , takeXConApps
-        , takeXPrimApps
-
-          -- * Lets
-        , xLets,               xLetsAnnot
-        , splitXLets 
-        , bindsOfLets
-        , specBindsOfLets
-        , valwitBindsOfLets
-
-          -- * Patterns
-        , bindsOfPat
-
-
-          -- * Alternatives
-        , patOfAlt
-        , takeCtorNameOfAlt
-
-          -- * Witnesses
-        , wApp
-        , wApps
-        , annotOfWitness
-        , takeXWitness
-        , takeWAppsAsList
-        , takePrimWiConApps
-
-          -- * Types
-        , takeXType
-
-          -- * Data Constructors
-        , xUnit, dcUnit
-        , takeNameOfDaCon
-        , takeTypeOfDaCon)
-where
-import DDC.Type.Compounds
-import DDC.Core.Exp
-import DDC.Core.Exp.DaCon
-
-
--- Annotations ----------------------------------------------------------------
--- | Take the outermost annotation from an expression.
-annotOfExp :: Exp a n -> a
-annotOfExp xx
- = case xx of
-        XVar     a _      -> a
-        XCon     a _      -> a
-        XLAM     a _ _    -> a
-        XLam     a _ _    -> a
-        XApp     a _ _    -> a
-        XLet     a _ _    -> a
-        XCase    a _ _    -> a
-        XCast    a _ _    -> a
-        XType    a _      -> a
-        XWitness a _      -> a
-
-
--- Lambdas ---------------------------------------------------------------------
--- | Make some nested type lambdas.
-xLAMs :: a -> [Bind n] -> Exp a n -> Exp a n
-xLAMs a bs x
-        = foldr (XLAM a) x bs
-
-
--- | Make some nested value or witness lambdas.
-xLams :: a -> [Bind n] -> Exp a n -> Exp a n
-xLams a bs x
-        = foldr (XLam a) x bs
-
-
--- | Split type lambdas from the front of an expression,
---   or `Nothing` if there aren't any.
-takeXLAMs :: Exp a n -> Maybe ([Bind n], Exp a n)
-takeXLAMs xx
- = let  go bs (XLAM _ b x) = go (b:bs) x
-        go bs x            = (reverse bs, x)
-   in   case go [] xx of
-         ([], _)        -> Nothing
-         (bs, body)     -> Just (bs, body)
-
-
--- | Split nested value or witness lambdas from the front of an expression,
---   or `Nothing` if there aren't any.
-takeXLams :: Exp a n -> Maybe ([Bind n], Exp a n)
-takeXLams xx
- = let  go bs (XLam _ b x) = go (b:bs) x
-        go bs x            = (reverse bs, x)
-   in   case go [] xx of
-         ([], _)        -> Nothing
-         (bs, body)     -> Just (bs, body)
-
-
--- | Make some nested lambda abstractions,
---   using a flag to indicate whether the lambda is a
---   level-1 (True), or level-0 (False) binder.
-makeXLamFlags :: a -> [(Bool, Bind n)] -> Exp a n -> Exp a n
-makeXLamFlags a fbs x
- = foldr (\(f, b) x'
-           -> if f then XLAM a b x'
-                   else XLam a b x')
-                x fbs
-
-
--- | Split nested lambdas from the front of an expression, 
---   with a flag indicating whether the lambda was a level-1 (True), 
---   or level-0 (False) binder.
-takeXLamFlags :: Exp a n -> Maybe ([(Bool, Bind n)], Exp a n)
-takeXLamFlags xx
- = let  go bs (XLAM _ b x) = go ((True,  b):bs) x
-        go bs (XLam _ b x) = go ((False, b):bs) x
-        go bs x            = (reverse bs, x)
-   in   case go [] xx of
-         ([], _)        -> Nothing
-         (bs, body)     -> Just (bs, body)
-
-
--- Applications ---------------------------------------------------------------
--- | Build sequence of value applications.
-xApps   :: a -> Exp a n -> [Exp a n] -> Exp a n
-xApps a t1 ts     = foldl (XApp a) t1 ts
-
-
--- | Build sequence of applications.
---   Similar to `xApps` but also takes list of annotations for 
---   the `XApp` constructors.
-makeXAppsWithAnnots :: Exp a n -> [(Exp a n, a)] -> Exp a n
-makeXAppsWithAnnots f xas
- = case xas of
-        []              -> f
-        (arg,a ) : as   -> makeXAppsWithAnnots (XApp a f arg) as
-
-
--- | Flatten an application into the function part and its arguments.
---
---   Returns `Nothing` if there is no outer application.
-takeXApps :: Exp a n -> Maybe (Exp a n, [Exp a n])
-takeXApps xx
- = case takeXAppsAsList xx of
-        (x1 : xsArgs)   -> Just (x1, xsArgs)
-        _               -> Nothing
-
-
--- | Flatten an application into the function part and its arguments.
---
---   This is like `takeXApps` above, except we know there is at least one argument.
-takeXApps1 :: Exp a n -> Exp a n -> (Exp a n, [Exp a n])
-takeXApps1 x1 x2
- = case takeXApps x1 of
-        Nothing          -> (x1,  [x2])
-        Just (x11, x12s) -> (x11, x12s ++ [x2])
-
-
--- | Flatten an application into the function parts and arguments, if any.
-takeXAppsAsList  :: Exp a n -> [Exp a n]
-takeXAppsAsList xx
- = case xx of
-        XApp _ x1 x2    -> takeXAppsAsList x1 ++ [x2]
-        _               -> [xx]
-
-
--- | Destruct sequence of applications.
---   Similar to `takeXAppsAsList` but also keeps annotations for later.
-takeXAppsWithAnnots :: Exp a n -> (Exp a n, [(Exp a n, a)])
-takeXAppsWithAnnots xx
- = case xx of
-        XApp a f arg
-         -> let (f', args') = takeXAppsWithAnnots f
-            in  (f', args' ++ [(arg,a)])
-
-        _ -> (xx, [])
-
-
--- | Flatten an application of a primop into the variable
---   and its arguments.
---   
---   Returns `Nothing` if the expression isn't a primop application.
-takeXPrimApps :: Exp a n -> Maybe (n, [Exp a n])
-takeXPrimApps xx
- = case takeXAppsAsList xx of
-        XVar _ (UPrim p _) : xs -> Just (p, xs)
-        _                       -> Nothing
-
--- | Flatten an application of a data constructor into the constructor
---   and its arguments. 
---
---   Returns `Nothing` if the expression isn't a constructor application.
-takeXConApps :: Exp a n -> Maybe (DaCon n, [Exp a n])
-takeXConApps xx
- = case takeXAppsAsList xx of
-        XCon _ dc : xs  -> Just (dc, xs)
-        _               -> Nothing
-
-
--- Lets -----------------------------------------------------------------------
--- | Wrap some let-bindings around an expression.
-xLets :: a -> [Lets a n] -> Exp a n -> Exp a n
-xLets a lts x
- = foldr (XLet a) x lts
-
-
--- | Wrap some let-bindings around an expression, with individual annotations.
-xLetsAnnot :: [(Lets a n, a)] -> Exp a n -> Exp a n
-xLetsAnnot lts x
- = foldr (\(l, a) x' -> XLet a l x') x lts
-
-
--- | Split let-bindings from the front of an expression, if any.
-splitXLets :: Exp a n -> ([Lets a n], Exp a n)
-splitXLets xx
- = case xx of
-        XLet _ lts x 
-         -> let (lts', x')      = splitXLets x
-            in  (lts : lts', x')
-
-        _ -> ([], xx)
-
--- | Take the binds of a `Lets`.
---
---   The level-1 and level-0 binders are returned separately.
-bindsOfLets :: Lets a n -> ([Bind n], [Bind n])
-bindsOfLets ll
- = case ll of
-        LLet b _          -> ([],  [b])
-        LRec bxs          -> ([],  map fst bxs)
-        LPrivate bs _ bbs -> (bs, bbs)
-        LWithRegion{}     -> ([],  [])
-
-
--- | Like `bindsOfLets` but only take the spec (level-1) binders.
-specBindsOfLets :: Lets a n -> [Bind n]
-specBindsOfLets ll
- = case ll of
-        LLet _ _        -> []
-        LRec _          -> []
-        LPrivate bs _ _ -> bs
-        LWithRegion{}   -> []
-
-
--- | Like `bindsOfLets` but only take the value and witness (level-0) binders.
-valwitBindsOfLets :: Lets a n -> [Bind n]
-valwitBindsOfLets ll
- = case ll of
-        LLet b _        -> [b]
-        LRec bxs        -> map fst bxs
-        LPrivate _ _ bs -> bs
-        LWithRegion{}   -> []
-
-
--- Alternatives ---------------------------------------------------------------
--- | Take the pattern of an alternative.
-patOfAlt :: Alt a n -> Pat n
-patOfAlt (AAlt pat _)   = pat
-
-
--- | Take the constructor name of an alternative, if there is one.
-takeCtorNameOfAlt :: Alt a n -> Maybe n
-takeCtorNameOfAlt aa
- = case aa of
-        AAlt (PData dc _) _     -> takeNameOfDaCon dc
-        _                       -> Nothing
-
-
--- Patterns -------------------------------------------------------------------
--- | Take the binds of a `Pat`.
-bindsOfPat :: Pat n -> [Bind n]
-bindsOfPat pp
- = case pp of
-        PDefault          -> []
-        PData _ bs        -> bs
-
-
--- Witnesses ------------------------------------------------------------------
--- | Construct a witness application
-wApp :: a -> Witness a n -> Witness a n -> Witness a n
-wApp = WApp
-
-
--- | Construct a sequence of witness applications
-wApps :: a -> Witness a n -> [Witness a n] -> Witness a n
-wApps a = foldl (wApp a)
-
-
--- | Take the annotation from a witness.
-annotOfWitness :: Witness a n -> a
-annotOfWitness ww
- = case ww of
-        WVar  a _       -> a
-        WCon  a _       -> a
-        WApp  a _ _     -> a
-        WJoin a _ _     -> a
-        WType a _       -> a
-
-
--- | Take the witness from an `XWitness` argument, if any.
-takeXWitness :: Exp a n -> Maybe (Witness a n)
-takeXWitness xx
- = case xx of
-        XWitness _ t -> Just t
-        _            -> Nothing
-
-
--- | Flatten an application into the function parts and arguments, if any.
-takeWAppsAsList :: Witness a n -> [Witness a n]
-takeWAppsAsList ww
- = case ww of
-        WApp _ w1 w2 -> takeWAppsAsList w1 ++ [w2]
-        _          -> [ww]
-
-
--- | Flatten an application of a witness into the witness constructor
---   name and its arguments.
---
---   Returns nothing if there is no witness constructor in head position.
-takePrimWiConApps :: Witness a n -> Maybe (n, [Witness a n])
-takePrimWiConApps ww
- = case takeWAppsAsList ww of
-        WCon _ wc : args | WiConBound (UPrim n _) _ <- wc
-          -> Just (n, args)
-        _ -> Nothing
-
-
--- Types ----------------------------------------------------------------------
--- | Take the type from an `XType` argument, if any.
-takeXType :: Exp a n -> Maybe (Type n)
-takeXType xx
- = case xx of
-        XType _ t -> Just t
-        _         -> Nothing
-
-
--- Units -----------------------------------------------------------------------
--- | Construct a value of unit type.
-xUnit   :: a -> Exp a n
-xUnit a = XCon a dcUnit
diff --git a/DDC/Core/Compounds/Simple.hs b/DDC/Core/Compounds/Simple.hs
deleted file mode 100644
--- a/DDC/Core/Compounds/Simple.hs
+++ /dev/null
@@ -1,291 +0,0 @@
-
--- | Utilities for constructing and destructing compound expressions.
---
---   For the Simple version of the AST.
-module DDC.Core.Compounds.Simple
-        ( module DDC.Type.Compounds
-
-          -- * Lambdas
-        , xLAMs
-        , xLams
-        , makeXLamFlags
-        , takeXLAMs
-        , takeXLams
-        , takeXLamFlags
-
-          -- * Applications
-        , xApps
-        , takeXApps
-        , takeXApps1
-        , takeXAppsAsList
-        , takeXConApps
-        , takeXPrimApps
-
-          -- * Lets
-        , xLets
-        , splitXLets 
-        , bindsOfLets
-        , specBindsOfLets
-        , valwitBindsOfLets
-
-          -- * Patterns
-        , bindsOfPat
-
-          -- * Alternatives
-        , takeCtorNameOfAlt
-
-          -- * Witnesses
-        , wApp
-        , wApps
-        , takeXWitness
-        , takeWAppsAsList
-        , takePrimWiConApps
-
-          -- * Types
-        , takeXType
-
-          -- * Data Constructors
-        , xUnit, dcUnit
-        , takeNameOfDaCon
-        , takeTypeOfDaCon)
-where
-import DDC.Type.Exp
-import DDC.Core.Exp.Simple
-import DDC.Core.Exp.DaCon
-import DDC.Type.Compounds
-
-
--- Lambdas ---------------------------------------------------------------------
--- | Make some nested type lambdas.
-xLAMs :: [Bind n] -> Exp a n -> Exp a n
-xLAMs bs x
-        = foldr XLAM x bs
-
-
--- | Make some nested value or witness lambdas.
-xLams :: [Bind n] -> Exp a n -> Exp a n
-xLams bs x
-        = foldr XLam x bs
-
-
--- | Split type lambdas from the front of an expression,
---   or `Nothing` if there aren't any.
-takeXLAMs :: Exp a n -> Maybe ([Bind n], Exp a n)
-takeXLAMs xx
- = let  go bs (XLAM b x) = go (b:bs) x
-        go bs x            = (reverse bs, x)
-   in   case go [] xx of
-         ([], _)        -> Nothing
-         (bs, body)     -> Just (bs, body)
-
-
--- | Split nested value or witness lambdas from the front of an expression,
---   or `Nothing` if there aren't any.
-takeXLams :: Exp a n -> Maybe ([Bind n], Exp a n)
-takeXLams xx
- = let  go bs (XLam b x) = go (b:bs) x
-        go bs x          = (reverse bs, x)
-   in   case go [] xx of
-         ([], _)        -> Nothing
-         (bs, body)     -> Just (bs, body)
-
-
--- | Make some nested lambda abstractions,
---   using a flag to indicate whether the lambda is a
---   level-1 (True), or level-0 (False) binder.
-makeXLamFlags :: [(Bool, Bind n)] -> Exp a n -> Exp a n
-makeXLamFlags fbs x
- = foldr (\(f, b) x'
-           -> if f then XLAM b x'
-                   else XLam b x')
-                x fbs
-
-
--- | Split nested lambdas from the front of an expression, 
---   with a flag indicating whether the lambda was a level-1 (True), 
---   or level-0 (False) binder.
-takeXLamFlags :: Exp a n -> Maybe ([(Bool, Bind n)], Exp a n)
-takeXLamFlags xx
- = let  go bs (XLAM b x)  = go ((True,  b):bs) x
-        go bs (XLam b x)  = go ((False, b):bs) x
-        go bs x           = (reverse bs, x)
-   in   case go [] xx of
-         ([], _)        -> Nothing
-         (bs, body)     -> Just (bs, body)
-
-
--- Applications ---------------------------------------------------------------
--- | Build sequence of value applications.
-xApps   :: Exp a n -> [Exp a n] -> Exp a n
-xApps t1 ts     = foldl XApp t1 ts
-
-
--- | Flatten an application into the function part and its arguments.
---
---   Returns `Nothing` if there is no outer application.
-takeXApps :: Exp a n -> Maybe (Exp a n, [Exp a n])
-takeXApps xx
- = case takeXAppsAsList xx of
-        (x1 : xsArgs)   -> Just (x1, xsArgs)
-        _               -> Nothing
-
-
--- | Flatten an application into the function part and its arguments.
---
---   This is like `takeXApps` above, except we know there is at least one argument.
-takeXApps1 :: Exp a n -> Exp a n -> (Exp a n, [Exp a n])
-takeXApps1 x1 x2
- = case takeXApps x1 of
-        Nothing          -> (x1,  [x2])
-        Just (x11, x12s) -> (x11, x12s ++ [x2])
-
-
--- | Flatten an application into the function parts and arguments, if any.
-takeXAppsAsList  :: Exp a n -> [Exp a n]
-takeXAppsAsList xx
- = case xx of
-        XApp x1 x2      -> takeXAppsAsList x1 ++ [x2]
-        _               -> [xx]
-
-
--- | Flatten an application of a primop into the variable
---   and its arguments.
---   
---   Returns `Nothing` if the expression isn't a primop application.
-takeXPrimApps :: Exp a n -> Maybe (n, [Exp a n])
-takeXPrimApps xx
- = case takeXAppsAsList xx of
-        XVar (UPrim p _) : xs -> Just (p, xs)
-        _                     -> Nothing
-
--- | Flatten an application of a data constructor into the constructor
---   and its arguments. 
---
---   Returns `Nothing` if the expression isn't a constructor application.
-takeXConApps :: Exp a n -> Maybe (DaCon n, [Exp a n])
-takeXConApps xx
- = case takeXAppsAsList xx of
-        XCon dc : xs  -> Just (dc, xs)
-        _             -> Nothing
-
-
--- Lets -----------------------------------------------------------------------
--- | Wrap some let-bindings around an expression.
-xLets :: [Lets a n] -> Exp a n -> Exp a n
-xLets lts x
- = foldr XLet x lts
-
-
--- | Split let-bindings from the front of an expression, if any.
-splitXLets :: Exp a n -> ([Lets a n], Exp a n)
-splitXLets xx
- = case xx of
-        XLet lts x 
-         -> let (lts', x')      = splitXLets x
-            in  (lts : lts', x')
-
-        _ -> ([], xx)
-
-
--- | Take the binds of a `Lets`.
---
---   The level-1 and level-0 binders are returned separately.
-bindsOfLets :: Lets a n -> ([Bind n], [Bind n])
-bindsOfLets ll
- = case ll of
-        LLet b _          -> ([],  [b])
-        LRec bxs          -> ([],  map fst bxs)
-        LPrivate bs _ bbs -> (bs, bbs)
-        LWithRegion{}     -> ([],  [])
-
-
--- | Like `bindsOfLets` but only take the spec (level-1) binders.
-specBindsOfLets :: Lets a n -> [Bind n]
-specBindsOfLets ll
- = case ll of
-        LLet _ _         -> []
-        LRec _           -> []
-        LPrivate bs _ _  -> bs
-        LWithRegion{}    -> []
-
-
--- | Like `bindsOfLets` but only take the value and witness (level-0) binders.
-valwitBindsOfLets :: Lets a n -> [Bind n]
-valwitBindsOfLets ll
- = case ll of
-        LLet b _        -> [b]
-        LRec bxs        -> map fst bxs
-        LPrivate _ _ bs -> bs
-        LWithRegion{}   -> []
-
-
--- Alternatives ---------------------------------------------------------------
--- | Take the constructor name of an alternative, if there is one.
-takeCtorNameOfAlt :: Alt a n -> Maybe n
-takeCtorNameOfAlt aa
- = case aa of
-        AAlt (PData dc _) _     -> takeNameOfDaCon dc
-        _                       -> Nothing
-
-
--- Patterns -------------------------------------------------------------------
--- | Take the binds of a `Pat`.
-bindsOfPat :: Pat n -> [Bind n]
-bindsOfPat pp
- = case pp of
-        PDefault          -> []
-        PData _ bs        -> bs
-
-
--- Witnesses ------------------------------------------------------------------
--- | Construct a witness application
-wApp :: Witness a n -> Witness a n -> Witness a n
-wApp = WApp
-
-
--- | Construct a sequence of witness applications
-wApps :: Witness a n -> [Witness a n] -> Witness a n
-wApps = foldl wApp
-
-
--- | Take the witness from an `XWitness` argument, if any.
-takeXWitness :: Exp a n -> Maybe (Witness a n)
-takeXWitness xx
- = case xx of
-        XWitness t -> Just t
-        _          -> Nothing
-
-
--- | Flatten an application into the function parts and arguments, if any.
-takeWAppsAsList :: Witness a n -> [Witness a n]
-takeWAppsAsList ww
- = case ww of
-        WApp w1 w2 -> takeWAppsAsList w1 ++ [w2]
-        _          -> [ww]
-
-
--- | Flatten an application of a witness into the witness constructor
---   name and its arguments.
---
---   Returns nothing if there is no witness constructor in head position.
-takePrimWiConApps :: Witness a n -> Maybe (n, [Witness a n])
-takePrimWiConApps ww
- = case takeWAppsAsList ww of
-        WCon wc : args | WiConBound (UPrim n _) _ <- wc
-          -> Just (n, args)
-        _ -> Nothing
-
-
--- Types ----------------------------------------------------------------------
--- | Take the type from an `XType` argument, if any.
-takeXType :: Exp a n -> Maybe (Type n)
-takeXType xx
- = case xx of
-        XType t -> Just t
-        _       -> Nothing
-
-
--- Units -----------------------------------------------------------------------
--- | Construct a value of unit type.
-xUnit   :: Exp a n
-xUnit = XCon dcUnit
diff --git a/DDC/Core/Exp.hs b/DDC/Core/Exp.hs
--- a/DDC/Core/Exp.hs
+++ b/DDC/Core/Exp.hs
@@ -1,6 +1,6 @@
 
 -- | Abstract syntax for the Disciple core language.
 module DDC.Core.Exp 
-        ( module DDC.Core.Exp.Annot )
+        ( module DDC.Core.Exp.Annot.Exp )
 where
-import DDC.Core.Exp.Annot
+import DDC.Core.Exp.Annot.Exp
diff --git a/DDC/Core/Exp/Annot.hs b/DDC/Core/Exp/Annot.hs
--- a/DDC/Core/Exp/Annot.hs
+++ b/DDC/Core/Exp/Annot.hs
@@ -1,201 +1,123 @@
 
--- | Core language AST that includes an annotation on every node of 
---   an expression.
---
---   This is the default representation for Disciple Core, and should be preferred
---   over the 'Simple' version of the AST in most cases. 
---
---   * Local transformations on this AST should propagate the annotations in a way that
---   would make sense if they were source position identifiers that tracked the provenance
---   of each code snippet. If the specific annotations attached to the AST would not make
---   sense after such a transformation, then the client should erase them to @()@ beforehand
---   using the `reannotate` transform.
---
---   * Global transformations that drastically change the provenance of code snippets should
---     accept an AST with an arbitrary annotation type, but produce one with the annotations
---     set to @()@.
---
-module DDC.Core.Exp.Annot 
-        ( module DDC.Type.Exp
+module DDC.Core.Exp.Annot
+        ( 
+         ---------------------------------------
+         -- * Abstract Syntax
+          module DDC.Type.Exp
 
-         -- * Expressions
+         -- ** Expressions
         , Exp           (..)
         , Lets          (..)
         , Alt           (..)
         , Pat           (..)
         , Cast          (..)
 
-          -- * Witnesses
+          -- ** Witnesses
         , Witness       (..)
 
-          -- * Data Constructors
+          -- ** Data Constructors
         , DaCon         (..)
 
-          -- * Witness Constructors
+          -- ** Witness Constructors
         , WiCon         (..)
-        , WbCon         (..))
-where
-import DDC.Core.Exp.WiCon
-import DDC.Core.Exp.DaCon
-import DDC.Core.Exp.Pat
-import DDC.Type.Exp
-import DDC.Type.Sum             ()
-import Control.DeepSeq
 
-
--- Values ---------------------------------------------------------------------
--- | Well-typed expressions have types of kind `Data`.
-data Exp a n
-        -- | Value variable   or primitive operation.
-        = XVar     !a !(Bound n)
-
-        -- | Data constructor or literal.
-        | XCon     !a !(DaCon n)
-
-        -- | Type abstraction (level-1).
-        | XLAM     !a !(Bind n)   !(Exp a n)
-
-        -- | Value and Witness abstraction (level-0).
-        | XLam     !a !(Bind n)   !(Exp a n)
-
-        -- | Application.
-        | XApp     !a !(Exp a n)  !(Exp a n)
-
-        -- | Possibly recursive bindings.
-        | XLet     !a !(Lets a n) !(Exp a n)
-
-        -- | Case branching.
-        | XCase    !a !(Exp a n)  ![Alt a n]
-
-        -- | Type cast.
-        | XCast    !a !(Cast a n) !(Exp a n)
-
-        -- | Type can appear as the argument of an application.
-        | XType    !a !(Type n)
-
-        -- | Witness can appear as the argument of an application.
-        | XWitness !a !(Witness a n)
-        deriving (Show, Eq)
-
-
--- | Possibly recursive bindings.
-data Lets a n
-        -- | Non-recursive expression binding.
-        = LLet     !(Bind n) !(Exp a n)
-
-        -- | Recursive binding of lambda abstractions.
-        | LRec     ![(Bind n, Exp a n)]
-
-        -- | Bind a private region variable,
-        --   and witnesses to its properties.
-        | LPrivate ![Bind n] !(Maybe (Type n)) ![Bind n]
-        
-        -- | Holds a region handle during evaluation.
-        | LWithRegion !(Bound n)
-        deriving (Show, Eq)
-
-
--- | Case alternatives.
-data Alt a n
-        = AAlt !(Pat n) !(Exp a n)
-        deriving (Show, Eq)
-
+          ---------------------------------------
+          -- * Predicates
+        , module DDC.Type.Predicates
 
--- | Type casts.
-data Cast a n
-        -- | Weaken the effect of an expression.
-        --   The given effect is added to the effect
-        --   of the body.
-        = CastWeakenEffect  !(Effect n)
-        
-        -- | Weaken the closure of an expression.
-        --   The closures of these expressions are added to the closure
-        --   of the body.
-        | CastWeakenClosure ![Exp a n]
+          -- ** Atoms
+        , isXVar,  isXCon
+        , isAtomX, isAtomW
 
-        -- | Purify the effect (action) of an expression.
-        | CastPurify !(Witness a n)
+          -- ** Lambdas
+        , isXLAM, isXLam
+        , isLambdaX
 
-        -- | Forget about the closure (sharing) of an expression.
-        | CastForget !(Witness a n)
+          -- ** Applications
+        , isXApp
 
-        -- | Box up a computation, 
-        --   capturing its effects in the S computation type.
-        | CastBox 
+          -- ** Cast
+        , isXCast
+        , isXCastBox
+        , isXCastRun
 
-        -- | Run a computation,
-        --   releasing its effects into the environment.
-        | CastRun
-        deriving (Show, Eq)
+          -- ** Let bindings
+        , isXLet
 
+          -- ** Patterns
+        , isPDefault
 
--- | When a witness exists in the program it guarantees that a
---   certain property of the program is true.
-data Witness a n
-        -- | Witness variable.
-        = WVar  a !(Bound n)
-        
-        -- | Witness constructor.
-        | WCon  a !(WiCon n)
-        
-        -- | Witness application.
-        | WApp  a !(Witness a n) !(Witness a n)
+          -- ** Types and Witnesses
+        , isXType
+        , isXWitness
 
-        -- | Joining of witnesses.
-        | WJoin a !(Witness a n) !(Witness a n)
+          ---------------------------------------
+          -- * Compounds
+        , module DDC.Type.Compounds
 
-        -- | Type can appear as the argument of an application.
-        | WType a !(Type n)
-        deriving (Show, Eq)
+          -- ** Annotations
+        , annotOfExp
+        , mapAnnotOfExp
 
+          -- ** Lambdas
+        , xLAMs
+        , xLams
+        , makeXLamFlags
+        , takeXLAMs
+        , takeXLams
+        , takeXLamFlags
 
--- NFData ---------------------------------------------------------------------
-instance (NFData a, NFData n) => NFData (Exp a n) where
- rnf xx
-  = case xx of
-        XVar  a u       -> rnf a `seq` rnf u
-        XCon  a dc      -> rnf a `seq` rnf dc
-        XLAM  a b x     -> rnf a `seq` rnf b   `seq` rnf x
-        XLam  a b x     -> rnf a `seq` rnf b   `seq` rnf x
-        XApp  a x1 x2   -> rnf a `seq` rnf x1  `seq` rnf x2
-        XLet  a lts x   -> rnf a `seq` rnf lts `seq` rnf x
-        XCase a x alts  -> rnf a `seq` rnf x   `seq` rnf alts
-        XCast a c x     -> rnf a `seq` rnf c   `seq` rnf x
-        XType a t       -> rnf a `seq` rnf t
-        XWitness a w    -> rnf a `seq` rnf w
+        , Param(..)
+        , takeXLamParam
 
+          -- ** Applications
+        , xApps
+        , makeXAppsWithAnnots
+        , takeXApps
+        , takeXApps1
+        , takeXAppsAsList
+        , takeXAppsWithAnnots
+        , takeXConApps
+        , takeXPrimApps
 
-instance (NFData a, NFData n) => NFData (Cast a n) where
- rnf cc
-  = case cc of
-        CastWeakenEffect e      -> rnf e
-        CastWeakenClosure xs    -> rnf xs
-        CastPurify w            -> rnf w
-        CastForget w            -> rnf w
-        CastBox                 -> ()
-        CastRun                 -> ()
+          -- ** Lets
+        , xLets
+        , xLetsAnnot
+        , splitXLets
+        , splitXLetsAnnot
+        , bindsOfLets
+        , specBindsOfLets
+        , valwitBindsOfLets
 
+          -- ** Alternatives
+        , patOfAlt
+        , takeCtorNameOfAlt
 
-instance (NFData a, NFData n) => NFData (Lets a n) where
- rnf lts
-  = case lts of
-        LLet b x                -> rnf b `seq` rnf x
-        LRec bxs                -> rnf bxs
-        LPrivate bs1 u2 bs3     -> rnf bs1 `seq` rnf u2 `seq` rnf bs3
-        LWithRegion u           -> rnf u
+          -- ** Patterns
+        , bindsOfPat
 
+          -- ** Casts
+        , makeRuns
 
-instance (NFData a, NFData n) => NFData (Alt a n) where
- rnf aa
-  = case aa of
-        AAlt w x                -> rnf w `seq` rnf x
+          -- ** Witnesses
+        , wApp
+        , wApps
+        , annotOfWitness
+        , takeXWitness
+        , takeWAppsAsList
+        , takePrimWiConApps
 
+          -- ** Types
+        , takeXType
 
-instance (NFData a, NFData n) => NFData (Witness a n) where
- rnf ww
-  = case ww of
-        WVar  a u                 -> rnf a `seq` rnf u
-        WCon  a c                 -> rnf a `seq` rnf c
-        WApp  a w1 w2             -> rnf a `seq` rnf w1 `seq` rnf w2
-        WJoin a w1 w2             -> rnf a `seq` rnf w1 `seq` rnf w2
-        WType a tt                -> rnf a `seq` rnf tt
+          -- ** Data Constructors
+        , xUnit, dcUnit
+        , takeNameOfDaCon
+        , takeTypeOfDaCon)
+where
+import DDC.Core.Exp.Annot.Exp
+import DDC.Core.Exp.Annot.Compounds
+import DDC.Core.Exp.Annot.Predicates
+import DDC.Type.Compounds
+import DDC.Type.Predicates
+import DDC.Type.Exp
diff --git a/DDC/Core/Exp/Annot/AnT.hs b/DDC/Core/Exp/Annot/AnT.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Exp/Annot/AnT.hs
@@ -0,0 +1,35 @@
+
+module DDC.Core.Exp.Annot.AnT
+        (AnT (..))
+where
+import DDC.Type.Exp
+import DDC.Base.Pretty
+import Control.DeepSeq
+import Data.Typeable
+
+
+-- Annot ----------------------------------------------------------------------
+-- | The type checker for witnesses adds this annotation to every node in the,
+--   giving the type of each component of the witness.
+---
+--   NOTE: We want to leave the components lazy so that the checker
+--         doesn't actualy need to produce the type components if they're
+--         not needed.
+data AnT a n
+        = AnT
+        { annotType     :: (Type  n)
+        , annotTail     :: a }
+        deriving (Show, Typeable)
+
+
+instance (NFData a, NFData n) => NFData (AnT a n) where
+ rnf !an
+        =     rnf (annotType    an)
+        `seq` rnf (annotTail    an)
+
+
+instance Pretty (AnT a n) where
+ ppr _ = text "AnT"
+
+
+
diff --git a/DDC/Core/Exp/Annot/AnTEC.hs b/DDC/Core/Exp/Annot/AnTEC.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Exp/Annot/AnTEC.hs
@@ -0,0 +1,50 @@
+
+module DDC.Core.Exp.Annot.AnTEC
+        ( AnTEC (..)
+        , fromAnT)
+where
+import DDC.Type.Compounds
+import DDC.Type.Exp
+import DDC.Base.Pretty
+import Control.DeepSeq
+import Data.Typeable
+import DDC.Core.Exp.Annot.AnT           (AnT)
+import qualified DDC.Core.Exp.Annot.AnT as AnT
+
+
+-- Annot ----------------------------------------------------------------------
+-- | The type checker adds this annotation to every node in the AST,
+--   giving its type, effect and closure.
+---
+--   NOTE: We want to leave the components lazy so that the checker
+--         doesn't actualy need to produce the type components if they're
+--         not needed.
+data AnTEC a n
+        = AnTEC
+        { annotType     :: (Type    n)
+        , annotEffect   :: (Effect  n)
+        , annotClosure  :: (Closure n)
+        , annotTail     :: a }
+        deriving (Show, Typeable)
+
+
+-- | Promote an `AnT` to an `AnTEC` by filling in the effect and closure
+--   portions with bottoms.
+fromAnT :: AnT a n -> AnTEC a n
+fromAnT (AnT.AnT t a)
+   =    (AnTEC t (tBot kEffect) (tBot kClosure) a)
+
+
+instance (NFData a, NFData n) => NFData (AnTEC a n) where
+ rnf !an
+        =     rnf (annotType    an)
+        `seq` rnf (annotEffect  an)
+        `seq` rnf (annotClosure an)
+        `seq` rnf (annotTail    an)
+
+
+instance Pretty (AnTEC a n) where
+ ppr _ = text "AnTEC"
+
+
+
diff --git a/DDC/Core/Exp/Annot/Compounds.hs b/DDC/Core/Exp/Annot/Compounds.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Exp/Annot/Compounds.hs
@@ -0,0 +1,414 @@
+
+-- | Utilities for constructing and destructing compound expressions.
+--
+--   For the annotated version of the AST.
+--
+module DDC.Core.Exp.Annot.Compounds
+        ( module DDC.Type.Compounds
+
+          -- * Annotations
+        , annotOfExp
+        , mapAnnotOfExp
+
+          -- * Lambdas
+        , xLAMs
+        , xLams
+        , makeXLamFlags
+        , takeXLAMs
+        , takeXLams
+        , takeXLamFlags
+
+        , Param(..)
+        , takeXLamParam
+
+          -- * Applications
+        , xApps
+        , makeXAppsWithAnnots
+        , takeXApps
+        , takeXApps1
+        , takeXAppsAsList
+        , takeXAppsWithAnnots
+        , takeXConApps
+        , takeXPrimApps
+
+          -- * Lets
+        , xLets,               xLetsAnnot
+        , splitXLets,          splitXLetsAnnot
+        , bindsOfLets
+        , specBindsOfLets
+        , valwitBindsOfLets
+
+          -- * Alternatives
+        , patOfAlt
+        , takeCtorNameOfAlt
+
+          -- * Patterns
+        , bindsOfPat
+
+          -- * Casts
+        , makeRuns
+
+          -- * Witnesses
+        , wApp
+        , wApps
+        , annotOfWitness
+        , takeXWitness
+        , takeWAppsAsList
+        , takePrimWiConApps
+
+          -- * Types
+        , takeXType
+
+          -- * Data Constructors
+        , xUnit, dcUnit
+        , takeNameOfDaCon
+        , takeTypeOfDaCon)
+where
+import DDC.Core.Exp.Annot.Exp
+import DDC.Core.Exp.DaCon
+import DDC.Type.Compounds
+
+
+-- Annotations ----------------------------------------------------------------
+-- | Take the outermost annotation from an expression.
+annotOfExp :: Exp a n -> a
+annotOfExp xx
+ = case xx of
+        XVar     a _      -> a
+        XCon     a _      -> a
+        XLAM     a _ _    -> a
+        XLam     a _ _    -> a
+        XApp     a _ _    -> a
+        XLet     a _ _    -> a
+        XCase    a _ _    -> a
+        XCast    a _ _    -> a
+        XType    a _      -> a
+        XWitness a _      -> a
+
+
+-- | Apply a function to the annotation of an expression.
+mapAnnotOfExp :: (a -> a) -> Exp a n -> Exp a n
+mapAnnotOfExp f xx
+ = case xx of
+        XVar     a u      -> XVar     (f a) u
+        XCon     a c      -> XCon     (f a) c
+        XLAM     a b  x   -> XLAM     (f a) b  x
+        XLam     a b  x   -> XLam     (f a) b  x
+        XApp     a x1 x2  -> XApp     (f a) x1 x2
+        XLet     a lt x   -> XLet     (f a) lt x
+        XCase    a x  as  -> XCase    (f a) x  as
+        XCast    a c  x   -> XCast    (f a) c  x
+        XType    a t      -> XType    (f a) t
+        XWitness a w      -> XWitness (f a) w
+
+
+-- Lambdas ---------------------------------------------------------------------
+-- | Make some nested type lambdas.
+xLAMs :: a -> [Bind n] -> Exp a n -> Exp a n
+xLAMs a bs x
+        = foldr (XLAM a) x bs
+
+
+-- | Make some nested value or witness lambdas.
+xLams :: a -> [Bind n] -> Exp a n -> Exp a n
+xLams a bs x
+        = foldr (XLam a) x bs
+
+
+-- | Split type lambdas from the front of an expression,
+--   or `Nothing` if there aren't any.
+takeXLAMs :: Exp a n -> Maybe ([Bind n], Exp a n)
+takeXLAMs xx
+ = let  go bs (XLAM _ b x) = go (b:bs) x
+        go bs x            = (reverse bs, x)
+   in   case go [] xx of
+         ([], _)        -> Nothing
+         (bs, body)     -> Just (bs, body)
+
+
+-- | Split nested value or witness lambdas from the front of an expression,
+--   or `Nothing` if there aren't any.
+takeXLams :: Exp a n -> Maybe ([Bind n], Exp a n)
+takeXLams xx
+ = let  go bs (XLam _ b x) = go (b:bs) x
+        go bs x            = (reverse bs, x)
+   in   case go [] xx of
+         ([], _)        -> Nothing
+         (bs, body)     -> Just (bs, body)
+
+
+-- | Make some nested lambda abstractions,
+--   using a flag to indicate whether the lambda is a
+--   level-1 (True), or level-0 (False) binder.
+makeXLamFlags :: a -> [(Bool, Bind n)] -> Exp a n -> Exp a n
+makeXLamFlags a fbs x
+ = foldr (\(f, b) x'
+           -> if f then XLAM a b x'
+                   else XLam a b x')
+                x fbs
+
+
+-- | Split nested lambdas from the front of an expression,
+--   with a flag indicating whether the lambda was a level-1 (True),
+--   or level-0 (False) binder.
+takeXLamFlags :: Exp a n -> Maybe ([(Bool, Bind n)], Exp a n)
+takeXLamFlags xx
+ = let  go bs (XLAM _ b x) = go ((True,  b):bs) x
+        go bs (XLam _ b x) = go ((False, b):bs) x
+        go bs x            = (reverse bs, x)
+   in   case go [] xx of
+         ([], _)        -> Nothing
+         (bs, body)     -> Just (bs, body)
+
+
+-- | Parameters of a function.
+data Param n
+        = ParamType  (Bind n)
+        | ParamValue (Bind n)
+        | ParamBox
+        deriving Show
+
+
+-- | Take the parameters of a function.
+takeXLamParam :: Exp a n -> Maybe ([Param n], Exp a n)
+takeXLamParam xx
+ = let  go bs (XLAM  _ b x)       = go (ParamType  b : bs) x
+        go bs (XLam  _ b x)       = go (ParamValue b : bs) x
+        go bs (XCast _ CastBox x) = go (ParamBox     : bs) x
+        go bs x                   = (reverse bs, x)
+   in   case go [] xx of
+         ([], _)        -> Nothing
+         (bs, body)     -> Just (bs, body)
+
+
+-- Applications ---------------------------------------------------------------
+-- | Build sequence of value applications.
+xApps   :: a -> Exp a n -> [Exp a n] -> Exp a n
+xApps a t1 ts     = foldl (XApp a) t1 ts
+
+
+-- | Build sequence of applications.
+--   Similar to `xApps` but also takes list of annotations for
+--   the `XApp` constructors.
+makeXAppsWithAnnots :: Exp a n -> [(Exp a n, a)] -> Exp a n
+makeXAppsWithAnnots f xas
+ = case xas of
+        []              -> f
+        (arg,a ) : as   -> makeXAppsWithAnnots (XApp a f arg) as
+
+
+-- | Flatten an application into the function part and its arguments.
+--
+--   Returns `Nothing` if there is no outer application.
+takeXApps :: Exp a n -> Maybe (Exp a n, [Exp a n])
+takeXApps xx
+ = case takeXAppsAsList xx of
+        (x1 : xsArgs)   -> Just (x1, xsArgs)
+        _               -> Nothing
+
+
+-- | Flatten an application into the function part and its arguments.
+--
+--   This is like `takeXApps` above, except we know there is at least one argument.
+takeXApps1 :: Exp a n -> Exp a n -> (Exp a n, [Exp a n])
+takeXApps1 x1 x2
+ = case takeXApps x1 of
+        Nothing          -> (x1,  [x2])
+        Just (x11, x12s) -> (x11, x12s ++ [x2])
+
+
+-- | Flatten an application into the function parts and arguments, if any.
+takeXAppsAsList  :: Exp a n -> [Exp a n]
+takeXAppsAsList xx
+ = case xx of
+        XApp _ x1 x2    -> takeXAppsAsList x1 ++ [x2]
+        _               -> [xx]
+
+
+-- | Destruct sequence of applications.
+--   Similar to `takeXAppsAsList` but also keeps annotations for later.
+takeXAppsWithAnnots :: Exp a n -> (Exp a n, [(Exp a n, a)])
+takeXAppsWithAnnots xx
+ = case xx of
+        XApp a f arg
+         -> let (f', args') = takeXAppsWithAnnots f
+            in  (f', args' ++ [(arg,a)])
+
+        _ -> (xx, [])
+
+
+-- | Flatten an application of a primop into the variable
+--   and its arguments.
+--
+--   Returns `Nothing` if the expression isn't a primop application.
+takeXPrimApps :: Exp a n -> Maybe (n, [Exp a n])
+takeXPrimApps xx
+ = case takeXAppsAsList xx of
+        XVar _ (UPrim p _) : xs -> Just (p, xs)
+        _                       -> Nothing
+
+-- | Flatten an application of a data constructor into the constructor
+--   and its arguments.
+--
+--   Returns `Nothing` if the expression isn't a constructor application.
+takeXConApps :: Exp a n -> Maybe (DaCon n, [Exp a n])
+takeXConApps xx
+ = case takeXAppsAsList xx of
+        XCon _ dc : xs  -> Just (dc, xs)
+        _               -> Nothing
+
+
+-- Lets -----------------------------------------------------------------------
+-- | Wrap some let-bindings around an expression.
+xLets :: a -> [Lets a n] -> Exp a n -> Exp a n
+xLets a lts x
+ = foldr (XLet a) x lts
+
+
+-- | Wrap some let-bindings around an expression, with individual annotations.
+xLetsAnnot :: [(Lets a n, a)] -> Exp a n -> Exp a n
+xLetsAnnot lts x
+ = foldr (\(l, a) x' -> XLet a l x') x lts
+
+
+-- | Split let-bindings from the front of an expression, if any.
+splitXLets :: Exp a n -> ([Lets a n], Exp a n)
+splitXLets xx
+ = case xx of
+        XLet _ lts x
+         -> let (lts', x')      = splitXLets x
+            in  (lts : lts', x')
+
+        _ -> ([], xx)
+
+-- | Split let-bindings from the front of an expression, with annotations.
+splitXLetsAnnot :: Exp a n -> ([(Lets a n, a)], Exp a n)
+splitXLetsAnnot xx
+ = case xx of
+        XLet a lts x
+         -> let (lts', x')              = splitXLetsAnnot x
+            in  ((lts, a) : lts', x')
+
+        _ -> ([], xx)
+
+-- | Take the binds of a `Lets`.
+--
+--   The level-1 and level-0 binders are returned separately.
+bindsOfLets :: Lets a n -> ([Bind n], [Bind n])
+bindsOfLets ll
+ = case ll of
+        LLet b _          -> ([],  [b])
+        LRec bxs          -> ([],  map fst bxs)
+        LPrivate bs _ bbs -> (bs, bbs)
+
+
+-- | Like `bindsOfLets` but only take the spec (level-1) binders.
+specBindsOfLets :: Lets a n -> [Bind n]
+specBindsOfLets ll
+ = case ll of
+        LLet _ _        -> []
+        LRec _          -> []
+        LPrivate bs _ _ -> bs
+
+
+-- | Like `bindsOfLets` but only take the value and witness (level-0) binders.
+valwitBindsOfLets :: Lets a n -> [Bind n]
+valwitBindsOfLets ll
+ = case ll of
+        LLet b _        -> [b]
+        LRec bxs        -> map fst bxs
+        LPrivate _ _ bs -> bs
+
+
+-- Alternatives ---------------------------------------------------------------
+-- | Take the pattern of an alternative.
+patOfAlt :: Alt a n -> Pat n
+patOfAlt (AAlt pat _)   = pat
+
+
+-- | Take the constructor name of an alternative, if there is one.
+takeCtorNameOfAlt :: Alt a n -> Maybe n
+takeCtorNameOfAlt aa
+ = case aa of
+        AAlt (PData dc _) _     -> takeNameOfDaCon dc
+        _                       -> Nothing
+
+
+-- Patterns -------------------------------------------------------------------
+-- | Take the binds of a `Pat`.
+bindsOfPat :: Pat n -> [Bind n]
+bindsOfPat pp
+ = case pp of
+        PDefault          -> []
+        PData _ bs        -> bs
+
+
+-- Casts ----------------------------------------------------------------------
+-- | Wrap an expression in the given number of 'run' casts.
+makeRuns :: a -> Int -> Exp a n -> Exp a n
+makeRuns _a 0 x = x
+makeRuns a n x  = XCast a CastRun (makeRuns a (n - 1) x)
+
+
+-- Witnesses ------------------------------------------------------------------
+-- | Construct a witness application
+wApp :: a -> Witness a n -> Witness a n -> Witness a n
+wApp = WApp
+
+
+-- | Construct a sequence of witness applications
+wApps :: a -> Witness a n -> [Witness a n] -> Witness a n
+wApps a = foldl (wApp a)
+
+
+-- | Take the annotation from a witness.
+annotOfWitness :: Witness a n -> a
+annotOfWitness ww
+ = case ww of
+        WVar  a _       -> a
+        WCon  a _       -> a
+        WApp  a _ _     -> a
+        WType a _       -> a
+
+
+-- | Take the witness from an `XWitness` argument, if any.
+takeXWitness :: Exp a n -> Maybe (Witness a n)
+takeXWitness xx
+ = case xx of
+        XWitness _ t -> Just t
+        _            -> Nothing
+
+
+-- | Flatten an application into the function parts and arguments, if any.
+takeWAppsAsList :: Witness a n -> [Witness a n]
+takeWAppsAsList ww
+ = case ww of
+        WApp _ w1 w2 -> takeWAppsAsList w1 ++ [w2]
+        _          -> [ww]
+
+
+-- | Flatten an application of a witness into the witness constructor
+--   name and its arguments.
+--
+--   Returns nothing if there is no witness constructor in head position.
+takePrimWiConApps :: Witness a n -> Maybe (n, [Witness a n])
+takePrimWiConApps ww
+ = case takeWAppsAsList ww of
+        WCon _ wc : args | WiConBound (UPrim n _) _ <- wc
+          -> Just (n, args)
+        _ -> Nothing
+
+
+-- Types ----------------------------------------------------------------------
+-- | Take the type from an `XType` argument, if any.
+takeXType :: Exp a n -> Maybe (Type n)
+takeXType xx
+ = case xx of
+        XType _ t -> Just t
+        _         -> Nothing
+
+
+-- Units -----------------------------------------------------------------------
+-- | Construct a value of unit type.
+xUnit   :: a -> Exp a n
+xUnit a = XCon a dcUnit
diff --git a/DDC/Core/Exp/Annot/Context.hs b/DDC/Core/Exp/Annot/Context.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Exp/Annot/Context.hs
@@ -0,0 +1,152 @@
+
+module DDC.Core.Exp.Annot.Context
+        ( Context (..)
+        , enterLAM
+        , enterLam
+        , enterAppLeft
+        , enterAppRight
+        , enterLetBody
+        , enterLetLLet
+        , enterLetLRec
+        , enterCaseScrut
+        , enterCaseAlt
+        , enterCastBody)
+where
+import DDC.Core.Exp.Annot.Exp
+import DDC.Core.Exp.Annot.Ctx
+import DDC.Core.Exp.Annot.Compounds
+import DDC.Type.Env             (KindEnv, TypeEnv)
+import qualified DDC.Type.Env   as Env
+
+
+data Context a n
+        = Context
+        { contextKindEnv        :: KindEnv n
+        , contextTypeEnv        :: TypeEnv n
+        , contextGlobalCaps     :: TypeEnv n
+        , contextCtx            :: Ctx a n }
+
+
+-- | Enter the body of a type lambda.
+enterLAM 
+        :: Ord n => Context a n
+        -> a -> Bind n -> Exp a n
+        -> (Context a n -> Exp a n -> b) -> b
+
+enterLAM c a b x f
+ = let  c' = c  { contextKindEnv = Env.extend b (contextKindEnv c)
+                , contextCtx     = CtxLAM (contextCtx c) a b }
+   in   f c' x
+
+
+-- | Enter the body of a value lambda.
+enterLam
+        :: Ord n => Context a n
+        -> a -> Bind n -> Exp a n
+        -> (Context a n -> Exp a n -> b) -> b
+
+enterLam c a b x f
+ = let  c' = c  { contextTypeEnv = Env.extend b (contextTypeEnv c) 
+                , contextCtx     = CtxLam (contextCtx c) a b }
+   in   f c' x
+
+
+-- | Enter the left of an application.
+enterAppLeft   
+        :: Context a n
+        -> a -> Exp a n -> Exp a n
+        -> (Context a n -> Exp a n -> b) -> b
+
+enterAppLeft c a x1 x2 f
+ = let  c' = c  { contextCtx     = CtxAppLeft (contextCtx c) a x2 }
+
+   in   f c' x1
+
+
+-- | Enter the right of an application.
+enterAppRight
+        :: Context a n
+        -> a -> Exp a n -> Exp a n
+        -> (Context a n -> Exp a n -> b) -> b
+
+enterAppRight c a x1 x2 f
+ = let  c' = c  { contextCtx    = CtxAppRight (contextCtx c) a x1 }
+   in   f c' x2
+
+
+-- | Enter the body of a let-expression.
+enterLetBody
+        :: Ord n => Context a n 
+        -> a -> Lets a n -> Exp a n
+        -> (Context a n -> Exp a n -> b) -> b
+
+enterLetBody c a lts x f
+ = let  (bs1, bs0) = bindsOfLets lts
+        c' = c  { contextKindEnv  = Env.extends bs1 (contextKindEnv c)
+                , contextTypeEnv  = Env.extends bs0 (contextTypeEnv c)
+                , contextCtx      = CtxLetBody (contextCtx c) a lts }
+   in   f c' x
+
+
+-- | Enter the binding of a LLet
+enterLetLLet
+        :: Context a n
+        -> a -> Bind n -> Exp a n -> Exp a n
+        -> (Context a n -> Exp a n -> b) -> b
+
+enterLetLLet c a b x xBody f
+ = let  c' = c  { contextCtx    = CtxLetLLet (contextCtx c) a b xBody }
+   in   f c' x
+
+
+-- | Enter a binding of a LRec group.
+enterLetLRec
+        :: Ord n => Context a n
+        -> a -> [(Bind n, Exp a n)] -> Bind n -> Exp a n -> [(Bind n, Exp a n)] -> Exp a n
+        -> (Context a n -> Exp a n -> b) -> b
+
+enterLetLRec c a bxsBefore b x bxsAfter xBody f
+ = let  bsBefore = map fst bxsBefore
+        bsAfter  = map fst bxsAfter
+        c' = c  { contextTypeEnv = Env.extends (bsBefore ++ [b] ++ bsAfter)
+                                        (contextTypeEnv c) 
+                , contextCtx     = CtxLetLRec (contextCtx c) a 
+                                        bxsBefore b bxsAfter xBody 
+                }
+   in   f c' x
+
+
+-- | Enter the scrutinee of a case-expression.
+enterCaseScrut
+        :: Context a n
+        -> a -> Exp a n -> [Alt a n]
+        -> (Context a n -> Exp a n -> b) -> b
+
+enterCaseScrut c a x alts f
+ = let  c' = c  { contextCtx     = CtxCaseScrut (contextCtx c) a alts }
+   in   f c' x
+
+
+-- | Enter the right of an alternative.
+enterCaseAlt 
+        :: Ord n => Context a n
+        -> a -> Exp a n -> [Alt a n] -> Pat n -> Exp a n -> [Alt a n]
+        -> (Context a n -> Exp a n -> b) -> b
+
+enterCaseAlt c a xScrut altsBefore w x altsAfter f
+ = let  bs      = bindsOfPat w
+        c' = c  { contextTypeEnv = Env.extends bs (contextTypeEnv c)
+                , contextCtx     = CtxCaseAlt (contextCtx c) a
+                                        xScrut altsBefore w altsAfter }
+   in   f c' x
+
+
+-- | Enter the body of a cast
+enterCastBody
+        :: Context a n
+        -> a -> Cast a n -> Exp a n
+        -> (Context a n -> Exp a n -> b) -> b
+
+enterCastBody c a cc x f
+ = let  c' = c  { contextCtx    = CtxCastBody (contextCtx c) a cc }
+   in   f c' x
diff --git a/DDC/Core/Exp/Annot/Ctx.hs b/DDC/Core/Exp/Annot/Ctx.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Exp/Annot/Ctx.hs
@@ -0,0 +1,235 @@
+
+module DDC.Core.Exp.Annot.Ctx
+        ( Ctx (..)
+        , isTopLetCtx
+        , topOfCtx
+        , takeEnclosingCtx
+        , takeTopNameOfCtx
+        , takeTopLetEnvNamesOfCtx
+        , encodeCtx)
+where
+import DDC.Type.DataDef
+import DDC.Core.Exp.Annot.Exp
+import DDC.Type.Env             (KindEnv, TypeEnv)
+import Data.Set                 (Set)
+import qualified DDC.Type.Env   as Env
+import qualified Data.Set       as Set
+import qualified Data.Map       as Map
+
+
+-- | A one-hole context for `Exp`.
+data Ctx a n
+        -- | The top-level context.
+        = CtxTop        
+        { ctxDataDefs   :: !(DataDefs n)
+        , ctxKindEnv    :: !(KindEnv n)
+        , ctxTypeEnv    :: !(TypeEnv n) }
+
+        -- | Body of a type abstraction.
+        | CtxLAM        !(Ctx a n) !a
+                        !(Bind n)
+
+        -- | Body of a value or witness abstraction.
+        | CtxLam        !(Ctx a n) !a
+                        !(Bind n)
+
+        -- | Left of an application.
+        | CtxAppLeft    !(Ctx a n) !a
+                        !(Exp a n)
+
+        -- | Right of an application.
+        | CtxAppRight   !(Ctx a n) !a
+                        !(Exp a n)
+
+        -- | Body of a let-expression.
+        | CtxLetBody    !(Ctx a n) !a
+                        !(Lets a n)
+
+        -- | In a non-recursive let-binding.
+        --   We store the binder and body of the let expression.
+        | CtxLetLLet    !(Ctx a n) !a
+                        !(Bind n)       -- binder of current let-binding.
+                        !(Exp a n)      -- let body
+
+        -- | In a recursive binding.
+        | CtxLetLRec    !(Ctx a n) !a
+                        ![(Bind n, Exp a n)] !(Bind n) ![(Bind n, Exp a n)]
+                        !(Exp a n)
+
+        -- | Scrutinee of a case expression.
+        | CtxCaseScrut  !(Ctx a n) !a
+                        ![Alt a n]
+
+        -- | In a case alternative.
+        | CtxCaseAlt    !(Ctx a n) !a
+                        !(Exp a n)      -- case scrutinee
+                        ![Alt a n] !(Pat n) ![Alt a n]
+
+        -- | Body of a type cast
+        | CtxCastBody   !(Ctx a n) !a   -- context of let-expression.
+                        !(Cast a n)
+
+
+-- | Check if the context is a top-level let-binding.
+--   All bindings in the top-level chain of lets and letrecs are included.
+isTopLetCtx :: Ctx a n -> Bool
+isTopLetCtx ctx
+ = case ctx of
+        CtxLetLLet CtxTop{} _ _ _        -> True
+        CtxLetLRec CtxTop{} _ _ _ _ _    -> True
+
+        CtxLetLLet (CtxLetBody ctx' _ _) _ _ _
+           -> isTopLetCtx ctx'
+
+        CtxLetLRec (CtxLetBody ctx' _ _) _ _ _ _ _
+           -> isTopLetCtx ctx'
+
+        _  -> False
+
+
+-- | Get the top level of a context.
+topOfCtx :: Ctx a n
+         -> (DataDefs n, KindEnv n, TypeEnv n)
+
+topOfCtx ctx
+ = case ctx of
+        CtxTop defs kenv tenv    -> (defs, kenv, tenv)
+        CtxLAM       c _ _       -> topOfCtx c
+        CtxLam       c _ _       -> topOfCtx c
+        CtxAppLeft   c _ _       -> topOfCtx c
+        CtxAppRight  c _ _       -> topOfCtx c
+        CtxLetBody   c _ _       -> topOfCtx c
+        CtxLetLLet   c _ _ _     -> topOfCtx c
+        CtxLetLRec   c _ _ _ _ _ -> topOfCtx c
+        CtxCaseScrut c _ _       -> topOfCtx c
+        CtxCaseAlt   c _ _ _ _ _ -> topOfCtx c
+        CtxCastBody  c _ _       -> topOfCtx c
+
+
+-- | Take the enclosing context from a nested one,
+--   or `Nothing` if this is the top-level context.
+takeEnclosingCtx :: Ctx a n -> Maybe (Ctx a n)
+takeEnclosingCtx ctx
+ = case ctx of
+        CtxTop{}                 -> Nothing
+        CtxLAM       c _ _       -> Just c
+        CtxLam       c _ _       -> Just c
+        CtxAppLeft   c _ _       -> Just c
+        CtxAppRight  c _ _       -> Just c
+        CtxLetBody   c _ _       -> Just c
+        CtxLetLLet   c _ _ _     -> Just c
+        CtxLetLRec   c _ _ _ _ _ -> Just c
+        CtxCaseScrut c _ _       -> Just c
+        CtxCaseAlt   c _ _ _ _ _ -> Just c
+        CtxCastBody  c _ _       -> Just c
+
+
+-- | Take the name of the outer-most enclosing let-binding of this context,
+--   if there is one.
+takeTopNameOfCtx :: Ctx a n -> Maybe n
+takeTopNameOfCtx ctx0
+ = eat ctx0
+ where  eat ctx
+         = case ctx of
+                CtxTop{}
+                 -> Nothing
+
+                CtxLetLLet CtxTop{} _ (BName n _) _
+                 -> Just n
+
+                CtxLetLRec CtxTop{} _ _ (BName n _) _ _
+                 -> Just n
+
+                _ -> case takeEnclosingCtx ctx of
+                        Nothing   -> Nothing
+                        Just ctx' -> eat ctx'
+
+
+-- | Get the set of value names defined at top-level, including top-level
+--   let-bindings and the top level type environment.
+takeTopLetEnvNamesOfCtx :: Ord n => Ctx a n -> Set n
+takeTopLetEnvNamesOfCtx ctx0
+ = eatCtx ctx0
+ where  eatCtx ctx
+         = case ctx of
+                CtxTop _ _ tenv
+                 -> Set.fromList
+                 $  Map.keys $ Env.envMap tenv
+
+                CtxLetLLet (CtxTop _ _ tenv) _ b xBody
+                 -> Set.unions
+                        [ Set.fromList $ Map.keys $ Env.envMap tenv
+                        , eatBind b
+                        , eatExp xBody]
+
+                CtxLetLRec (CtxTop _ _ tenv) _ bxsBefore b bxsAfter xBody
+                 -> Set.unions
+                        [ Set.fromList  $ Map.keys $ Env.envMap tenv
+                        , Set.unions    $ map (eatBind . fst) bxsBefore
+                        , eatBind b
+                        , Set.unions    $ map (eatBind . fst) bxsAfter
+                        , eatExp xBody]
+
+                _ -> case takeEnclosingCtx ctx of
+                        Nothing   -> Set.empty
+                        Just ctx' -> eatCtx ctx'
+
+        eatExp xx
+         = case xx of
+                XLet _ (LLet b _) xBody
+                 -> Set.unions
+                        [ eatBind  b
+                        , eatExp xBody ]
+
+                XLet _ (LRec bxs) xBody
+                 -> Set.unions
+                        [ Set.unions $ map (eatBind . fst) bxs
+                        , eatExp xBody ]
+
+                _ -> Set.empty
+
+        eatBind (BName n _) = Set.singleton n
+        eatBind _           = Set.empty
+
+
+-- | Encode a context into a unique string.
+--   This is a name for a particlar program context, which is guaranteed
+--   to be from names of other contexts. This encoding can be used as
+--   a fresh name generator if you can base the names on the context they
+--   are created in.
+encodeCtx :: Ctx a n -> String
+encodeCtx ctx0
+ = go 1 ctx0
+ where
+
+  -- We indicate simulilar encosing contexts with by using an integer prefix
+  -- for each component. We encode the position of particular alternatives
+  -- and let-bindings with an integer suffix.
+  go (n :: Int) ctx
+   = let sn     = if n == 1
+                        then "x"
+                        else "x" ++ show n
+     in case ctx of
+        CtxTop{}                        -> "Tt"
+
+        CtxLAM       c@CtxLAM{} _ _     -> go (n + 1) c
+        CtxLAM       c _ _              -> go 1 c ++ sn ++ "Lt"
+
+        CtxLam       c@CtxLam{} _ _     -> go (n + 1) c
+        CtxLam       c _ _              -> go 1 c ++ sn ++ "Lv"
+
+        CtxAppLeft   c _ _              -> go 1 c ++ sn ++ "Al"
+        CtxAppRight  c _ _              -> go 1 c ++ sn ++ "Ar"
+
+        CtxLetBody   c@CtxLetBody{} _ _ -> go (n + 1) c
+        CtxLetBody   c _ _              -> go 1 c ++ sn ++ "Eb"
+
+        CtxLetLLet   c _ _ _            -> go 1 c ++ sn ++ "El"
+        CtxLetLRec   c _ bxs  _ _ _     -> go 1 c ++ sn ++ "Er" ++ show (length bxs + 1)
+
+        CtxCaseScrut c _ _              -> go 1 c ++ sn ++ "Cs"
+
+        CtxCaseAlt   c _ _ alts _ _     -> go 1 c ++ sn ++ "Ca" ++ show (length alts + 1)
+
+        CtxCastBody  c _ _              -> go 1 c ++ sn ++ "Sb"
+
diff --git a/DDC/Core/Exp/Annot/Exp.hs b/DDC/Core/Exp/Annot/Exp.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Exp/Annot/Exp.hs
@@ -0,0 +1,198 @@
+
+-- | Core language AST that includes an annotation on every node of
+--   an expression.
+--
+--   This is the default representation for Disciple Core, and should be preferred
+--   over the 'Simple' version of the AST in most cases.
+--
+--   * Local transformations on this AST should propagate the annotations in a way that
+--   would make sense if they were source position identifiers that tracked the provenance
+--   of each code snippet. If the specific annotations attached to the AST would not make
+--   sense after such a transformation, then the client should erase them to @()@ beforehand
+--   using the `reannotate` transform.
+--
+--   * Global transformations that drastically change the provenance of code snippets should
+--     accept an AST with an arbitrary annotation type, but produce one with the annotations
+--     set to @()@.
+--
+module DDC.Core.Exp.Annot.Exp
+        ( module DDC.Type.Exp
+
+         -- * Expressions
+        , Exp           (..)
+        , Lets          (..)
+        , Alt           (..)
+        , Pat           (..)
+        , Cast          (..)
+
+          -- * Witnesses
+        , Witness       (..)
+
+          -- * Data Constructors
+        , DaCon         (..)
+
+          -- * Witness Constructors
+        , WiCon         (..))
+where
+import DDC.Core.Exp.WiCon
+import DDC.Core.Exp.DaCon
+import DDC.Type.Exp
+import DDC.Type.Sum             ()
+import Control.DeepSeq
+
+
+-- Values ---------------------------------------------------------------------
+-- | Well-typed expressions have types of kind `Data`.
+data Exp a n
+        -- | Value variable   or primitive operation.
+        = XVar     !a !(Bound n)
+
+        -- | Data constructor or literal.
+        | XCon     !a !(DaCon n)
+
+        -- | Type abstraction (level-1).
+        | XLAM     !a !(Bind n)   !(Exp a n)
+
+        -- | Value and Witness abstraction (level-0).
+        | XLam     !a !(Bind n)   !(Exp a n)
+
+        -- | Application.
+        | XApp     !a !(Exp a n)  !(Exp a n)
+
+        -- | Possibly recursive bindings.
+        | XLet     !a !(Lets a n) !(Exp a n)
+
+        -- | Case branching.
+        | XCase    !a !(Exp a n)  ![Alt a n]
+
+        -- | Type cast.
+        | XCast    !a !(Cast a n) !(Exp a n)
+
+        -- | Type can appear as the argument of an application.
+        | XType    !a !(Type n)
+
+        -- | Witness can appear as the argument of an application.
+        | XWitness !a !(Witness a n)
+        deriving (Show, Eq)
+
+
+-- | Possibly recursive bindings.
+data Lets a n
+        -- | Non-recursive expression binding.
+        = LLet     !(Bind n) !(Exp a n)
+
+        -- | Recursive binding of lambda abstractions.
+        | LRec     ![(Bind n, Exp a n)]
+
+        -- | Bind a private region variable,
+        --   and witnesses to its properties.
+        | LPrivate ![Bind n] !(Maybe (Type n)) ![Bind n]
+        deriving (Show, Eq)
+
+
+-- | Case alternatives.
+data Alt a n
+        = AAlt !(Pat n) !(Exp a n)
+        deriving (Show, Eq)
+
+
+-- | Pattern matching.
+data Pat n
+        -- | The default pattern always succeeds.
+        = PDefault
+
+        -- | Match a data constructor and bind its arguments.
+        | PData !(DaCon n) ![Bind n]
+        deriving (Show, Eq)
+
+
+-- | Type casts.
+data Cast a n
+        -- | Weaken the effect of an expression.
+        --   The given effect is added to the effect
+        --   of the body.
+        = CastWeakenEffect  !(Effect n)
+
+        -- | Purify the effect (action) of an expression.
+        | CastPurify !(Witness a n)
+
+        -- | Box up a computation,
+        --   capturing its effects in the S computation type.
+        | CastBox
+
+        -- | Run a computation,
+        --   releasing its effects into the environment.
+        | CastRun
+        deriving (Show, Eq)
+
+
+-- | When a witness exists in the program it guarantees that a
+--   certain property of the program is true.
+data Witness a n
+        -- | Witness variable.
+        = WVar  a !(Bound n)
+
+        -- | Witness constructor.
+        | WCon  a !(WiCon n)
+
+        -- | Witness application.
+        | WApp  a !(Witness a n) !(Witness a n)
+
+        -- | Type can appear as the argument of an application.
+        | WType a !(Type n)
+        deriving (Show, Eq)
+
+
+-- NFData ---------------------------------------------------------------------
+instance (NFData a, NFData n) => NFData (Exp a n) where
+ rnf xx
+  = case xx of
+        XVar  a u       -> rnf a `seq` rnf u
+        XCon  a dc      -> rnf a `seq` rnf dc
+        XLAM  a b x     -> rnf a `seq` rnf b   `seq` rnf x
+        XLam  a b x     -> rnf a `seq` rnf b   `seq` rnf x
+        XApp  a x1 x2   -> rnf a `seq` rnf x1  `seq` rnf x2
+        XLet  a lts x   -> rnf a `seq` rnf lts `seq` rnf x
+        XCase a x alts  -> rnf a `seq` rnf x   `seq` rnf alts
+        XCast a c x     -> rnf a `seq` rnf c   `seq` rnf x
+        XType a t       -> rnf a `seq` rnf t
+        XWitness a w    -> rnf a `seq` rnf w
+
+
+instance (NFData a, NFData n) => NFData (Cast a n) where
+ rnf cc
+  = case cc of
+        CastWeakenEffect e      -> rnf e
+        CastPurify w            -> rnf w
+        CastBox                 -> ()
+        CastRun                 -> ()
+
+
+instance (NFData a, NFData n) => NFData (Lets a n) where
+ rnf lts
+  = case lts of
+        LLet b x                -> rnf b `seq` rnf x
+        LRec bxs                -> rnf bxs
+        LPrivate bs1 u2 bs3     -> rnf bs1 `seq` rnf u2 `seq` rnf bs3
+
+
+instance (NFData a, NFData n) => NFData (Alt a n) where
+ rnf aa
+  = case aa of
+        AAlt w x                -> rnf w `seq` rnf x
+
+
+instance NFData n => NFData (Pat n) where
+ rnf pp
+  = case pp of
+        PDefault                -> ()
+        PData dc bs             -> rnf dc `seq` rnf bs
+
+
+instance (NFData a, NFData n) => NFData (Witness a n) where
+ rnf ww
+  = case ww of
+        WVar  a u                 -> rnf a `seq` rnf u
+        WCon  a c                 -> rnf a `seq` rnf c
+        WApp  a w1 w2             -> rnf a `seq` rnf w1 `seq` rnf w2
+        WType a tt                -> rnf a `seq` rnf tt
diff --git a/DDC/Core/Exp/Annot/Predicates.hs b/DDC/Core/Exp/Annot/Predicates.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Exp/Annot/Predicates.hs
@@ -0,0 +1,162 @@
+
+-- | Simple predicates on core expressions.
+module DDC.Core.Exp.Annot.Predicates
+        ( module DDC.Type.Predicates
+
+          -- * Atoms
+        , isXVar,  isXCon
+        , isAtomX, isAtomW
+
+          -- * Lambdas
+        , isXLAM, isXLam
+        , isLambdaX
+
+          -- * Applications
+        , isXApp
+
+          -- * Cast
+        , isXCast
+        , isXCastBox
+        , isXCastRun
+
+          -- * Let bindings
+        , isXLet
+
+          -- * Patterns
+        , isPDefault
+
+          -- * Types and Witnesses
+        , isXType
+        , isXWitness)
+where
+import DDC.Core.Exp.Annot.Exp
+import DDC.Type.Predicates
+
+
+-- Atoms ----------------------------------------------------------------------
+-- | Check whether an expression is a variable.
+isXVar :: Exp a n -> Bool
+isXVar xx
+ = case xx of
+        XVar{}  -> True
+        _       -> False
+
+
+-- | Check whether an expression is a constructor.
+isXCon :: Exp a n -> Bool
+isXCon xx
+ = case xx of
+        XCon{}  -> True
+        _       -> False
+
+
+-- | Check whether an expression is a `XVar` or an `XCon`, 
+--   or some type or witness atom.
+isAtomX :: Exp a n -> Bool
+isAtomX xx
+ = case xx of
+        XVar{}          -> True
+        XCon{}          -> True
+        XType    _ t    -> isAtomT t
+        XWitness _ w    -> isAtomW w
+        _               -> False
+
+
+-- | Check whether a witness is a `WVar` or `WCon`.
+isAtomW :: Witness a n -> Bool
+isAtomW ww
+ = case ww of
+        WVar{}          -> True
+        WCon{}          -> True
+        _               -> False
+
+
+-- Lambdas --------------------------------------------------------------------
+-- | Check whether an expression is a spec abstraction (level-1).
+isXLAM :: Exp a n -> Bool
+isXLAM xx
+ = case xx of
+        XLAM{}  -> True
+        _       -> False
+
+
+-- | Check whether an expression is a value or witness abstraction (level-0).
+isXLam :: Exp a n -> Bool
+isXLam xx
+ = case xx of
+        XLam{}  -> True
+        _       -> False
+
+
+-- | Check whether an expression is a spec, value, or witness abstraction.
+isLambdaX :: Exp a n -> Bool
+isLambdaX xx
+        = isXLAM xx || isXLam xx
+
+
+-- Applications ---------------------------------------------------------------
+-- | Check whether an expression is an `XApp`.
+isXApp :: Exp a n -> Bool
+isXApp xx
+ = case xx of
+        XApp{}  -> True
+        _       -> False
+
+
+-- Casts ----------------------------------------------------------------------
+-- | Check whether this is a cast expression.
+isXCast :: Exp a n -> Bool
+isXCast xx
+ = case xx of
+        XCast{} -> True
+        _       -> False
+
+
+-- | Check whether this is a box cast.
+isXCastBox :: Exp a n -> Bool
+isXCastBox xx
+ = case xx of
+        XCast _ CastBox _ -> True
+        _                 -> False
+
+
+-- | Check whether this is a run cast.
+isXCastRun :: Exp a n -> Bool
+isXCastRun xx
+ = case xx of
+        XCast _ CastRun _ -> True
+        _                 -> False
+
+
+-- Let Bindings ---------------------------------------------------------------
+-- | Check whether an expression is a `XLet`.
+isXLet :: Exp a n -> Bool
+isXLet xx
+ = case xx of
+        XLet{}  -> True
+        _       -> False
+
+
+-- Type and Witness -----------------------------------------------------------
+-- | Check whether an expression is an `XType`.
+isXType :: Exp a n -> Bool
+isXType xx
+ = case xx of
+        XType{}         -> True
+        _               -> False
+
+
+-- | Check whether an expression is an `XWitness`.
+isXWitness :: Exp a n -> Bool
+isXWitness xx
+ = case xx of
+        XWitness{}      -> True
+        _               -> False
+
+
+-- Patterns -------------------------------------------------------------------
+-- | Check whether an alternative is a `PDefault`.
+isPDefault :: Pat n -> Bool
+isPDefault PDefault     = True
+isPDefault _            = False
+
diff --git a/DDC/Core/Exp/Generic/BindStruct.hs b/DDC/Core/Exp/Generic/BindStruct.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Exp/Generic/BindStruct.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module DDC.Core.Exp.Generic.BindStruct where
+import DDC.Core.Exp.Generic.Exp
+import DDC.Core.Exp.DaCon
+import DDC.Core.Collect.Free
+import DDC.Type.Collect
+import qualified DDC.Type.Exp           as T
+import Data.Maybe
+
+
+instance (GBind l ~ T.Bind l, GBound l ~ T.Bound l)
+      => BindStruct (GExp l) l where
+ slurpBindTree xx
+  = case xx of
+        XAnnot _ x              -> slurpBindTree x
+
+        XVar u                  -> [BindUse BoundExp u]
+
+        XCon dc
+         -> case dc of
+                DaConBound n    -> [BindCon BoundExp (T.UName n) Nothing]
+                _               -> []
+
+        XPrim{}                 -> []
+
+        XApp x1 a2              -> slurpBindTree x1 ++ slurpBindTree a2
+
+        XAbs (ALAM b) x         -> [bindDefT BindLAM [b] [x]]
+
+        XAbs (ALam b) x         -> [bindDefX BindLam [b] [x]]      
+
+        XLet (LLet b x1) x2
+         -> slurpBindTree x1
+         ++ [bindDefX BindLet [b] [x2]]
+
+        XLet (LRec bxs) x2
+         -> [bindDefX BindLetRec 
+                     (map fst bxs) 
+                     (map snd bxs ++ [x2])]
+        
+        XLet (LPrivate b mT bs) x2
+         -> (concat $ fmap slurpBindTree $ maybeToList mT)
+         ++ [ BindDef  BindLetRegions b
+             [bindDefX BindLetRegionWith bs [x2]]]
+
+        XCase x alts            -> slurpBindTree x ++ concatMap slurpBindTree alts
+        XCast c x               -> slurpBindTree c ++ slurpBindTree x
+
+
+instance (GBind l ~ T.Bind l, GBound l ~ T.Bound l)
+      => BindStruct (GArg l) l where
+ slurpBindTree arg
+  = case arg of
+        RType t                 -> slurpBindTree t
+        RExp x                  -> slurpBindTree x
+        RWitness w              -> slurpBindTree w
+
+
+instance (GBind l ~ T.Bind l, GBound l ~ T.Bound l)
+      => BindStruct (GAlt l) l where
+ slurpBindTree alt
+  = case alt of
+        AAlt PDefault x         -> slurpBindTree x
+        AAlt (PData _ bs) x     -> [bindDefX BindCasePat bs [x]]
+
+
+instance (GBind l ~ T.Bind l, GBound l ~ T.Bound l)
+      => BindStruct (GCast l) l where
+ slurpBindTree cc
+  = case cc of
+        CastWeakenEffect  eff   -> slurpBindTree eff
+        CastPurify w            -> slurpBindTree w
+        CastBox                 -> []
+        CastRun                 -> []
+
+
+instance (GBind l ~ T.Bind l, GBound l ~ T.Bound l)
+      => BindStruct (GWitness l) l where
+ slurpBindTree ww
+  = case ww of
+        WVar  u                 -> [BindUse BoundWit u]
+        WCon{}                  -> []
+        WApp  w1 w2             -> slurpBindTree w1 ++ slurpBindTree w2
+        WType t                 -> slurpBindTree t
+
diff --git a/DDC/Core/Exp/Generic/Compounds.hs b/DDC/Core/Exp/Generic/Compounds.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Exp/Generic/Compounds.hs
@@ -0,0 +1,146 @@
+{-# LANGUAGE TypeFamilies #-}
+
+-- | Utilities for constructing and destructing compound expressions.
+--
+--   For the generic version of the AST.
+--
+module DDC.Core.Exp.Generic.Compounds
+        ( module DDC.Type.Compounds
+
+        -- * Abstractions
+        , makeXAbs,     takeXAbs
+        , makeXLAMs,    takeXLAMs
+        , makeXLams,    takeXLams
+
+        -- * Applications
+        , makeXApps,    takeXApps,      splitXApps
+        , takeXConApps
+        , takeXPrimApps
+
+        -- * Data Constructors
+        , dcUnit
+        , takeNameOfDaCon
+        , takeTypeOfDaCon)
+where
+import DDC.Core.Exp.Generic.Exp
+import DDC.Core.Exp.DaCon
+import DDC.Type.Compounds
+import Data.Maybe
+
+
+-- Abstractions ---------------------------------------------------------------
+-- | Make some nested abstractions.
+makeXAbs  :: [GAbs l] -> GExp l -> GExp l
+makeXAbs as xx
+ = foldr XAbs xx as
+
+
+-- | Split type and value/witness abstractions from the front of an expression,
+--   or `Nothing` if there aren't any.
+takeXAbs  :: GExp l -> Maybe ([GAbs l], GExp l)
+takeXAbs xx
+ = let  go as (XAbs a x)   = go (a : as) x
+        go as x            = (reverse as, x)
+   in   case go [] xx of
+         ([], _)        -> Nothing
+         (as, body)     -> Just (as, body)
+
+
+-- | Make some nested type lambdas.
+makeXLAMs :: [GBind l] -> GExp l -> GExp l
+makeXLAMs bs x
+        = foldr XLAM x bs
+
+
+-- | Split type lambdas from the front of an expression,
+--   or `Nothing` if there aren't any.
+takeXLAMs :: GExp l -> Maybe ([GBind l], GExp l)
+takeXLAMs xx
+ = let  go bs (XLAM b x)   = go (b : bs) x
+        go bs x            = (reverse bs, x)
+   in   case go [] xx of
+         ([], _)        -> Nothing
+         (bs, body)     -> Just (bs, body)
+
+
+-- | Make some nested value or witness lambdas.
+makeXLams :: [GBind l] -> GExp l -> GExp l
+makeXLams bs x
+        = foldr XLam x bs
+
+
+-- | Split nested value or witness lambdas from the front of an expression,
+--   or `Nothing` if there aren't any.
+takeXLams :: GExp l -> Maybe ([GBind l], GExp l)
+takeXLams xx
+ = let  go bs (XLam b x)   = go (b : bs) x
+        go bs x            = (reverse bs, x)
+   in   case go [] xx of
+         ([], _)        -> Nothing
+         (bs, body)     -> Just (bs, body)
+
+
+-- Applications ---------------------------------------------------------------
+-- | Build sequence of applications.
+makeXApps  :: GExp l -> [GArg l] -> GExp l
+makeXApps t1 ts
+        = foldl XApp t1 ts
+
+
+-- | Flatten an application into the functional expression and its arguments,
+--   or `Nothing if this is not an application.
+takeXApps :: GExp l -> Maybe (GExp l, [GArg l])
+takeXApps xx
+ = case xx of
+        XApp x1@XApp{} a2
+         -> case takeXApps x1 of
+                Just (f1, as1)  -> Just (f1, as1 ++ [a2])
+                Nothing         -> Nothing
+
+        XApp x1 a2
+         -> Just (x1, [a2])
+
+        _                       -> Nothing
+
+
+-- | Flatten an application into a functional expression and its arguments,
+--   or just return the expression with no arguments if this is not
+--   an application.
+splitXApps :: GExp l -> (GExp l, [GArg l])
+splitXApps xx
+ = fromMaybe (xx, []) $ takeXApps xx
+
+
+-- | Flatten an application of a primitive operators into the operator itself
+--   and its arguments, or `Nothing` if this is not an application of a
+--   primitive.
+takeXPrimApps :: GExp l -> Maybe (GPrim l, [GArg l])
+takeXPrimApps xx
+ = case xx of
+        XApp (XPrim p) a2
+         -> Just (p, [a2])
+
+        XApp x1@XApp{} a2
+         -> case takeXPrimApps x1 of
+                Just (p, as1)   -> Just (p, as1 ++ [a2])
+                _               -> Nothing
+
+        _                       -> Nothing
+
+
+-- | Flatten an application of a data constructor into the constructor itself
+--   and its arguments, or `Nothing` if this is not an application of a 
+--   data constructor.
+takeXConApps :: GExp l -> Maybe (DaCon l, [GArg l])
+takeXConApps xx
+ = case xx of
+        XApp (XCon c) a2
+         -> Just (c, [a2])
+
+        XApp x1@XApp{} a2
+         -> case takeXConApps x1 of
+                Just (c, as1)   -> Just (c, as1 ++ [a2])
+                _               -> Nothing
+
+        _                       -> Nothing
+
diff --git a/DDC/Core/Exp/Generic/Exp.hs b/DDC/Core/Exp/Generic/Exp.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Exp/Generic/Exp.hs
@@ -0,0 +1,162 @@
+{-# LANGUAGE TypeFamilies, UndecidableInstances #-}
+
+-- | Generic expression representation.
+module DDC.Core.Exp.Generic.Exp where
+import DDC.Core.Exp.DaCon
+import qualified DDC.Type.Exp   as T
+
+
+---------------------------------------------------------------------------------------------------
+-- | Type functions associated with a language definition.
+--
+--   These produce the types used for annotations, bindings, bound occurrences
+--   and primitives for that language.
+--
+type family GAnnot l
+type family GBind  l    
+type family GBound l
+type family GPrim  l
+
+
+---------------------------------------------------------------------------------------------------
+-- | Generic expression representation.
+data GExp l
+        -- | An annotated expression.
+        = XAnnot   !(GAnnot l)  !(GExp l)
+
+        -- | Primitive operator or literal.
+        | XPrim    !(GPrim  l)
+
+        -- | Data constructor.
+        | XCon     !(DaCon l)
+
+        -- | Value or Witness variable (level-0).
+        | XVar     !(GBound l)
+
+        -- | Function abstraction.
+        | XAbs     !(GAbs  l)  !(GExp l)
+
+        -- | Function application.
+        | XApp     !(GExp  l)  !(GArg l)
+
+        -- | Possibly recursive bindings.
+        | XLet     !(GLets l)  !(GExp l)
+
+        -- | Case branching.
+        | XCase    !(GExp  l)  ![GAlt l]
+
+        -- | Type casting.
+        | XCast    !(GCast l)  !(GExp l)
+
+
+-- | Abstractions.
+--
+--   This indicates what sort of object is being abstracted over in an XAbs.
+--
+data GAbs l
+        -- | Level-1 abstraction (spec)
+        = ALAM     !(GBind l)
+
+        -- | Level-0 abstraction (value and witness)
+        | ALam     !(GBind l)
+
+pattern XLAM b x = XAbs (ALAM b) x
+pattern XLam b x = XAbs (ALam b) x
+
+
+-- | Arguments.
+--
+--   Carries an argument that can be supplied to a function.
+--
+data GArg l
+        -- | Type argument.
+        = RType    !(T.Type l)
+
+        -- | Value argument.
+        | RExp     !(GExp l)
+
+        -- | Witness argument.
+        | RWitness !(GWitness l)
+
+
+
+-- | Possibly recursive bindings.
+data GLets l
+        -- | Non-recursive binding.
+        = LLet     !(GBind l)  !(GExp l)
+
+        -- | Recursive binding.
+        | LRec     ![(GBind l, GExp l)]
+
+        -- | Introduce a private region variable and witnesses to its properties.
+        | LPrivate ![GBind l] !(Maybe (T.Type l)) ![GBind l]
+
+
+-- | Case alternatives.
+data GAlt l
+        = AAlt !(GPat l) !(GExp l)
+
+
+-- | Patterns.
+data GPat l
+        -- | The default pattern always succeeds.
+        = PDefault
+
+        -- | Match a data constructor and bind its arguments.
+        | PData !(DaCon l) ![GBind l]
+
+
+-- | Type casts.
+data GCast l
+        -- | Weaken the effect of an expression.
+        = CastWeakenEffect   !(T.Type l)
+
+        -- | Purify the effect of an expression.
+        | CastPurify         !(GWitness l)
+
+        -- | Box up a computation, suspending its evaluation and capturing 
+        --   its effects in the S computaiton type.
+        | CastBox
+
+        -- | Run a computation, releasing its effects into the context.
+        | CastRun
+
+
+-- | Witnesses.
+data GWitness l
+        -- | Witness variable.
+        = WVar  !(GBound l)
+
+        -- | Witness constructor.
+        | WCon  !(GWiCon l)
+
+        -- | Witness application.
+        | WApp  !(GWitness l) !(GWitness l)
+
+        -- | Type can appear as an argument of a witness application.
+        | WType !(T.Type l)
+
+
+-- | Witness constructors.
+data GWiCon l
+        -- | Witness constructors defined in the environment.
+        --   In the interpreter we use this to hold runtime capabilities.
+        --   The attached type must be closed.
+        = WiConBound   !(GBound l) !(T.Type l)
+
+
+---------------------------------------------------------------------------------------------------
+-- | Synonym for Show constraints of all language types.
+type ShowLanguage l
+        = (Show l, Show (GAnnot l), Show (GBind l), Show (GBound l), Show (GPrim l))
+
+deriving instance ShowLanguage l => Show (GExp     l)
+deriving instance ShowLanguage l => Show (GAbs     l)
+deriving instance ShowLanguage l => Show (GArg     l)
+deriving instance ShowLanguage l => Show (GLets    l)
+deriving instance ShowLanguage l => Show (GAlt     l)
+deriving instance ShowLanguage l => Show (GPat     l)
+deriving instance ShowLanguage l => Show (GCast    l)
+deriving instance ShowLanguage l => Show (GWitness l)
+deriving instance ShowLanguage l => Show (GWiCon   l)
+
diff --git a/DDC/Core/Exp/Generic/Predicates.hs b/DDC/Core/Exp/Generic/Predicates.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Exp/Generic/Predicates.hs
@@ -0,0 +1,122 @@
+
+-- | Simple predicates on core expressions.
+module DDC.Core.Exp.Generic.Predicates
+        ( module DDC.Type.Predicates
+
+          -- * Atoms
+        , isXVar,  isXCon
+        , isAtomX, isAtomR, isAtomW
+
+          -- * Abstractions
+        , isXAbs, isXLAM, isXLam
+
+          -- * Applications
+        , isXApp
+
+          -- * Let bindings
+        , isXLet
+
+          -- * Patterns
+        , isPDefault)
+where
+import DDC.Core.Exp.Generic.Exp
+import DDC.Type.Predicates
+
+
+-- Atoms ----------------------------------------------------------------------
+-- | Check whether an expression is a variable.
+isXVar :: GExp l -> Bool
+isXVar xx
+ = case xx of
+        XVar{}  -> True
+        _       -> False
+
+
+-- | Check whether an expression is a constructor.
+isXCon :: GExp l -> Bool
+isXCon xx
+ = case xx of
+        XCon{}  -> True
+        _       -> False
+
+
+-- | Check whether an expression is an atomic value,
+--   eg an `XVar`, `XCon`, or `XPrim`.
+isAtomX :: GExp l -> Bool
+isAtomX xx
+ = case xx of
+        XVar{}          -> True
+        XCon{}          -> True
+        XPrim{}         -> True
+        _               -> False
+
+
+-- | Check whether an argument is an atomic value,
+isAtomR :: GArg l -> Bool
+isAtomR aa
+ = case aa of
+        RWitness w      -> isAtomW w
+        RExp x          -> isAtomX x
+        RType t         -> isAtomT t
+
+
+-- | Check whether a witness is a `WVar` or `WCon`.
+isAtomW :: GWitness l -> Bool
+isAtomW ww
+ = case ww of
+        WVar{}          -> True
+        WCon{}          -> True
+        _               -> False
+
+
+-- Abstractions ---------------------------------------------------------------
+-- | Check whether an expression is an abstraction.
+isXAbs :: GExp l -> Bool
+isXAbs xx
+ = case xx of
+        XAbs{}  -> True
+        _       -> False
+
+
+-- | Check whether an expression is a spec abstraction (level-1).
+isXLAM :: GExp l -> Bool
+isXLAM xx
+ = case xx of
+        XLAM{}  -> True
+        _       -> False
+
+
+-- | Check whether an expression is a value or witness abstraction (level-0).
+isXLam :: GExp l -> Bool
+isXLam xx
+ = case xx of
+        XLam{}  -> True
+        _       -> False
+
+
+-- Applications ---------------------------------------------------------------
+-- | Check whether an expression is an `XApp`.
+isXApp :: GExp l -> Bool
+isXApp xx
+ = case xx of
+        XApp{}  -> True
+        _       -> False
+
+
+-- Let Bindings ---------------------------------------------------------------
+-- | Check whether an expression is a `XLet`.
+isXLet :: GExp l -> Bool
+isXLet xx
+ = case xx of
+        XLet{}  -> True
+        _       -> False
+        
+
+-- Patterns -------------------------------------------------------------------
+-- | Check whether an alternative is a `PDefault`.
+isPDefault :: GPat l -> Bool
+isPDefault pp
+ = case pp of
+        PDefault        -> True
+        _               -> False
+
diff --git a/DDC/Core/Exp/Generic/Pretty.hs b/DDC/Core/Exp/Generic/Pretty.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Exp/Generic/Pretty.hs
@@ -0,0 +1,293 @@
+{-# LANGUAGE TypeFamilies, UndecidableInstances #-}
+
+module DDC.Core.Exp.Generic.Pretty where
+import DDC.Core.Exp.Generic.Predicates
+import DDC.Core.Exp.Generic.Exp
+import DDC.Core.Exp.DaCon
+import DDC.Type.Pretty
+import Prelude                  hiding ((<$>))
+
+
+-- | Synonym for Pretty constraints on all language types.
+type PrettyLanguage l
+        = ( Eq l
+          , Pretty l
+          , Pretty (GAnnot l)
+          , Pretty (GBind l), Pretty (GBound l), Pretty (GPrim l))
+
+
+-- Exp --------------------------------------------------------------------------------------------
+instance PrettyLanguage l => Pretty (GExp l) where
+
+ data PrettyMode (GExp l)
+        = PrettyModeExp
+        { -- | Mode to use when pretty printing arguments.
+          modeExpArg            :: PrettyMode (GArg l)
+
+          -- | Mode to use when pretty printing let expressions.
+        , modeExpLets           :: PrettyMode (GLets l)
+
+          -- | Mode to use when pretty printing alternatives.
+        , modeExpAlt            :: PrettyMode (GAlt  l)
+                
+          -- | Use 'letcase' for single alternative case expressions.
+        , modeExpUseLetCase     :: Bool }
+
+
+ pprDefaultMode
+        = PrettyModeExp
+        { modeExpArg            = pprDefaultMode
+        , modeExpLets           = pprDefaultMode
+        , modeExpAlt            = pprDefaultMode
+        , modeExpUseLetCase     = False }
+
+
+ pprModePrec mode d xx
+  = let pprX    = pprModePrec mode 0
+        pprLts  = pprModePrec (modeExpLets mode) 0
+        pprAlt  = pprModePrec (modeExpAlt  mode) 0
+
+    in case xx of
+        XAnnot _ x      -> ppr x
+        XVar   u        -> ppr u
+        XCon   dc       -> ppr dc
+        XPrim  p        -> ppr p
+        
+        XAbs (ALAM b) xBody
+         -> pprParen' (d > 1)
+                $  text "/\\" 
+                <> ppr b
+                <> (if       isXLAM    xBody then empty
+                     else if isXLam    xBody then line <> space
+                     else if isSimpleX xBody then space
+                     else    line)
+                <> pprX xBody
+
+        XAbs (ALam b) xBody
+         -> pprParen' (d > 1)
+                $  text "\\"
+                <> ppr b
+                <> breakWhen (not $ isSimpleX xBody)
+                <> pprX xBody
+
+        XApp x1 a2
+         -> pprParen' (d > 10)
+         $  pprModePrec mode 10 x1 
+                <> nest 4 (breakWhen (not $ isSimpleR a2) 
+                          <> pprModePrec (modeExpArg mode) 11 a2)
+
+        XLet lts x
+         ->  pprParen' (d > 2)
+         $   pprLts lts <+> text "in"
+         <$> pprX x
+
+        -- Print single alternative case expressions as 'letcase'.
+        --    case x1 of { C v1 v2 -> x2 }
+        -- => letcase C v1 v2 <- x1 in x2
+        XCase x1 [AAlt p x2]
+         | modeExpUseLetCase mode
+         ->  pprParen' (d > 2)
+         $   text "letcase" <+> ppr p 
+                <+> nest 2 (breakWhen (not $ isSimpleX x1)
+                            <> text "=" <+> align (pprX x1))
+                <+> text "in"
+         <$> pprX x2
+
+        XCase x alts
+         -> pprParen' (d > 2) 
+         $  (nest 2 $ text "case" <+> ppr x <+> text "of" <+> lbrace <> line
+                <> (vcat $ punctuate semi $ map pprAlt alts))
+         <> line 
+         <> rbrace
+
+        XCast CastBox x
+         -> pprParen' (d > 2)
+         $  text "box"  <$> pprX x
+
+        XCast CastRun x
+         -> pprParen' (d > 2)
+         $  text "run"  <+> pprX x
+
+        XCast cc x
+         ->  pprParen' (d > 2)
+         $   ppr cc <+> text "in"
+         <$> pprX x
+
+
+-- Arg --------------------------------------------------------------------------------------------
+instance PrettyLanguage l => Pretty (GArg l) where
+
+ data PrettyMode (GArg l)
+        = PrettyModeArg
+        { modeArgExp            :: PrettyMode (GExp l) }
+
+ pprModePrec mode n aa 
+  = case aa of
+        RType    t      -> text "[" <> ppr t <> text "]"
+        RExp     x      -> pprModePrec (modeArgExp mode) n  x
+        RWitness w      -> text "<" <> ppr w <> text ">"
+
+
+-- Pat --------------------------------------------------------------------------------------------
+instance PrettyLanguage l => Pretty (GPat l) where
+ ppr pp
+  = case pp of
+        PDefault        -> text "_"
+        PData u bs      -> ppr u <+> sep (map ppr bs)
+
+
+-- Alt --------------------------------------------------------------------------------------------
+instance PrettyLanguage l => Pretty (GAlt l) where
+ data PrettyMode (GAlt l)
+        = PrettyModeAlt
+        { modeAltExp            :: PrettyMode (GExp l) }
+
+ pprDefaultMode
+        = PrettyModeAlt
+        { modeAltExp            = pprDefaultMode }
+
+ pprModePrec mode _ (AAlt p x)
+  = let pprX    = pprModePrec (modeAltExp mode) 0
+    in  ppr p <+> nest 1 (line <> nest 3 (text "->" <+> pprX x))
+
+
+-- Cast -------------------------------------------------------------------------------------------
+instance PrettyLanguage l => Pretty (GCast l) where
+ ppr cc
+  = case cc of
+        CastWeakenEffect  eff   
+         -> text "weakeff" <+> brackets (ppr eff)
+
+        CastPurify w
+         -> text "purify"  <+> angles   (ppr w)
+
+        CastBox
+         -> text "box"
+
+        CastRun
+         -> text "run"
+
+
+-- Lets -------------------------------------------------------------------------------------------
+instance PrettyLanguage l => Pretty (GLets l) where
+ data PrettyMode (GLets l)
+        = PrettyModeLets
+        { modeLetsExp           :: PrettyMode (GExp l)  }
+
+ pprDefaultMode
+        = PrettyModeLets
+        { modeLetsExp           = pprDefaultMode }
+
+ pprModePrec mode _ lts
+  = let pprX    = pprModePrec (modeLetsExp mode) 0
+    in case lts of
+        LLet b x
+         ->  text "let"
+         <+> align (  ppr b
+                 <> nest 2 (  breakWhen (not $ isSimpleX x)
+                           <> text "=" <+> align (pprX x)))
+
+        LRec bxs
+         -> let pprLetRecBind (b, x)
+                 =  ppr b
+                 <> nest 2 (  breakWhen (not $ isSimpleX x)
+                           <> text "=" <+> align (pprX x))
+        
+           in   (nest 2 $ text "letrec"
+                  <+> lbrace 
+                  <>  (  line 
+                      <> (vcat $ punctuate (semi <> line)
+                               $ map pprLetRecBind bxs)))
+                <$> rbrace
+
+        LPrivate bs Nothing []
+         -> text "private"
+                <+> (hcat $ punctuate space $ map ppr bs)
+
+        LPrivate bs Nothing bws
+         -> text "private"
+                <+> (hcat $ punctuate space $ map ppr bs)
+                <+> text "with"
+                <+> braces (cat $ punctuate (text "; ") $ map ppr bws)
+
+        LPrivate bs (Just parent) []
+         -> text "extend"
+                <+> ppr parent
+                <+> text "using"
+                <+> (hcat $ punctuate space $ map ppr bs)
+
+        LPrivate bs (Just parent) bws
+         -> text "extend"
+                <+> ppr parent
+                <+> text "using"
+                <+> (hcat $ punctuate space $ map ppr bs)
+                <+> text "with"
+                <+> braces (cat $ punctuate (text "; ") $ map ppr bws)
+        
+
+-- Witness ----------------------------------------------------------------------------------------
+instance PrettyLanguage l => Pretty (GWitness l) where
+ pprPrec d ww
+  = case ww of
+        WVar  n         -> ppr n
+        WCon  wc        -> ppr wc
+        WApp  w1 w2     -> pprParen (d > 10) (ppr w1 <+> pprPrec 11 w2)
+        WType t         -> text "[" <> ppr t <> text "]"
+
+
+-- WiCon ------------------------------------------------------------------------------------------
+instance PrettyLanguage l => Pretty (GWiCon l) where
+ ppr wc
+  = case wc of
+        WiConBound u  _ -> ppr u
+
+
+-- DaCon ------------------------------------------------------------------------------------------
+instance PrettyLanguage l => Pretty (DaCon l) where
+ ppr dc
+  = case dc of
+        DaConUnit       -> text "()"
+        DaConPrim  n _  -> ppr n
+        DaConBound n    -> ppr n
+
+
+-- Utils ------------------------------------------------------------------------------------------
+-- | Insert a line or a space depending on a boolean argument.
+breakWhen :: Bool -> Doc
+breakWhen True   = line
+breakWhen False  = space
+
+
+-- | Wrap a `Doc` in parens, and indent it one level.
+parens' :: Doc -> Doc
+parens' d = lparen <> nest 1 d <> rparen
+
+
+-- | Wrap a `Doc` in parens if the predicate is true.
+pprParen' :: Bool -> Doc -> Doc
+pprParen' b c
+ = if b then parens' c
+        else c
+
+
+-- | Check if this is a simple expression that does not need extra spacing when
+--   being pretty printed.
+isSimpleX :: GExp l -> Bool
+isSimpleX xx
+ = case xx of
+        XVar{}          -> True
+        XPrim{}         -> True
+        XCon{}          -> True
+        XApp x1 a2      -> isSimpleX x1 && isAtomR a2
+        _               -> False
+
+-- | Check if this is a simple argument that does not need extra spacing when
+--   being pretty printed.
+isSimpleR :: GArg l -> Bool
+isSimpleR aa
+ = case aa of
+        RType{}         -> True
+        RExp x          -> isSimpleX x
+        RWitness{}      -> True
+
+
diff --git a/DDC/Core/Exp/Pat.hs b/DDC/Core/Exp/Pat.hs
deleted file mode 100644
--- a/DDC/Core/Exp/Pat.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-
-module DDC.Core.Exp.Pat
-        ( Pat (..))
-where
-import DDC.Core.Exp.DaCon
-import DDC.Type.Exp
-import Control.DeepSeq
-
-
--- | Pattern matching.
-data Pat n
-        -- | The default pattern always succeeds.
-        = PDefault
-        
-        -- | Match a data constructor and bind its arguments.
-        | PData !(DaCon n) ![Bind n]
-        deriving (Show, Eq)
-        
-
-instance NFData n => NFData (Pat n) where
- rnf pp
-  = case pp of
-        PDefault                -> ()
-        PData dc bs             -> rnf dc `seq` rnf bs
-
-
diff --git a/DDC/Core/Exp/Simple.hs b/DDC/Core/Exp/Simple.hs
deleted file mode 100644
--- a/DDC/Core/Exp/Simple.hs
+++ /dev/null
@@ -1,201 +0,0 @@
-
--- | Core language AST with a separate node to hold annotations.
---
---   This version of the AST is used when generating code where most or all
---   of the annotations would be empty. General purpose transformations should
---   deal with the fully annotated version of the AST instead.
---
-module DDC.Core.Exp.Simple 
-        ( module DDC.Type.Exp
-
-          -- * Expressions
-        , Exp           (..)
-        , Cast          (..)
-        , Lets          (..)
-        , Alt           (..)
-        , Pat           (..)
-
-          -- * Witnesses
-        , Witness       (..)
-
-          -- * Data Constructors
-        , DaCon         (..)
-
-          -- * Witness Constructors
-        , WiCon         (..)
-        , WbCon         (..))
-where
-import DDC.Core.Exp.WiCon
-import DDC.Core.Exp.DaCon
-import DDC.Core.Exp.Pat
-import DDC.Type.Exp
-import DDC.Type.Sum             ()
-import Control.DeepSeq
-
-
--- Values ---------------------------------------------------------------------
--- | Well-typed expressions have types of kind `Data`.
-data Exp a n
-        -- | Annotation.
-        = XAnnot a (Exp a n)
-
-        -- | Value variable   or primitive operation.
-        | XVar  !(Bound n)
-
-        -- | Data constructor or literal.
-        | XCon  !(DaCon n)
-
-        -- | Type abstraction (level-1).
-        | XLAM  !(Bind n)   !(Exp a n)
-
-        -- | Value and Witness abstraction (level-0).
-        | XLam  !(Bind n)   !(Exp a n)
-
-        -- | Application.
-        | XApp  !(Exp a n)  !(Exp a n)
-
-        -- | Possibly recursive bindings.
-        | XLet  !(Lets a n) !(Exp a n)
-
-        -- | Case branching.
-        | XCase !(Exp a n)  ![Alt a n]
-
-        -- | Type cast.
-        | XCast !(Cast a n) !(Exp a n)
-
-        -- | Type can appear as the argument of an application.
-        | XType    !(Type n)
-
-        -- | Witness can appear as the argument of an application.
-        | XWitness !(Witness a n)
-        deriving (Show, Eq)
-
-
--- | Possibly recursive bindings.
-data Lets a n
-        -- | Non-recursive expression binding.
-        = LLet     !(Bind n) !(Exp a n)
-
-        -- | Recursive binding of lambda abstractions.
-        | LRec     ![(Bind n, Exp a n)]
-
-        -- | Bind a local region variable,
-        --   and witnesses to its properties.
-        | LPrivate ![Bind n] !(Maybe (Type n)) ![Bind n]
-        
-        -- | Holds a region handle during evaluation.
-        | LWithRegion !(Bound n)
-        deriving (Show, Eq)
-
-
--- | Case alternatives.
-data Alt a n
-        = AAlt !(Pat n) !(Exp a n)
-        deriving (Show, Eq)
-
-
--- | When a witness exists in the program it guarantees that a
---   certain property of the program is true.
-data Witness a n
-        = WAnnot a (Witness a n)
-
-        -- | Witness variable.
-        | WVar  !(Bound n)
-        
-        -- | Witness constructor.
-        | WCon  !(WiCon n)
-        
-        -- | Witness application.
-        | WApp  !(Witness a n) !(Witness a n)
-
-        -- | Joining of witnesses.
-        | WJoin !(Witness a n) !(Witness a n)
-
-        -- | Type can appear as the argument of an application.
-        | WType !(Type n)
-        deriving (Show, Eq)
-
-
--- | Type casts.
-data Cast a n
-        -- | Weaken the effect of an expression.
-        --   The given effect is added to the effect
-        --   of the body.
-        = CastWeakenEffect  !(Effect n)
-        
-        -- | Weaken the closure of an expression.
-        --   The closures of these expressions are added to the closure
-        --   of the body.
-        | CastWeakenClosure ![Exp a n]
-
-        -- | Purify the effect (action) of an expression.
-        | CastPurify        !(Witness a n)
-
-        -- | Forget about the closure (sharing) of an expression.
-        | CastForget        !(Witness a n)
-
-        -- | Box up a computation, 
-        --   capturing its effects in the S computation type.
-        | CastBox 
-
-        -- | Run a computation,
-        --   releasing its effects into the environment.
-        | CastRun
-        deriving (Show, Eq)
-
-
-
-
--- NFData ---------------------------------------------------------------------
-instance (NFData a, NFData n) => NFData (Exp a n) where
- rnf xx
-  = case xx of
-        XAnnot a x      -> rnf a   `seq` rnf x
-        XVar   u        -> rnf u
-        XCon   dc       -> rnf dc
-        XLAM   b x      -> rnf b   `seq` rnf x
-        XLam   b x      -> rnf b   `seq` rnf x
-        XApp   x1 x2    -> rnf x1  `seq` rnf x2
-        XLet   lts x    -> rnf lts `seq` rnf x
-        XCase  x alts   -> rnf x   `seq` rnf alts
-        XCast  c x      -> rnf c   `seq` rnf x
-        XType  t        -> rnf t
-        XWitness w      -> rnf w
-
-
-instance (NFData a, NFData n) => NFData (Cast a n) where
- rnf cc
-  = case cc of
-        CastWeakenEffect e      -> rnf e
-        CastWeakenClosure xs    -> rnf xs
-        CastPurify w            -> rnf w
-        CastForget w            -> rnf w
-        CastBox                 -> ()
-        CastRun                 -> ()
-
-
-instance (NFData a, NFData n) => NFData (Lets a n) where
- rnf lts
-  = case lts of
-        LLet b x                -> rnf b `seq` rnf x
-        LRec bxs                -> rnf bxs
-        LPrivate bs1 t2 bs3     -> rnf bs1  `seq` rnf t2 `seq` rnf bs3
-        LWithRegion u           -> rnf u
-
-
-instance (NFData a, NFData n) => NFData (Alt a n) where
- rnf aa
-  = case aa of
-        AAlt w x                -> rnf w `seq` rnf x
-
-
-instance (NFData a, NFData n) => NFData (Witness a n) where
- rnf ww
-  = case ww of
-        WAnnot a w              -> rnf a `seq` rnf w
-        WVar   u                -> rnf u
-        WCon   c                -> rnf c
-        WApp   w1 w2            -> rnf w1 `seq` rnf w2
-        WJoin  w1 w2            -> rnf w1 `seq` rnf w2
-        WType  t                -> rnf t
-
diff --git a/DDC/Core/Exp/Simple/Compounds.hs b/DDC/Core/Exp/Simple/Compounds.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Exp/Simple/Compounds.hs
@@ -0,0 +1,288 @@
+
+-- | Utilities for constructing and destructing compound expressions.
+--
+--   For the Simple version of the AST.
+module DDC.Core.Exp.Simple.Compounds
+        ( module DDC.Type.Compounds
+
+          -- * Lambdas
+        , xLAMs
+        , xLams
+        , makeXLamFlags
+        , takeXLAMs
+        , takeXLams
+        , takeXLamFlags
+
+          -- * Applications
+        , xApps
+        , takeXApps
+        , takeXApps1
+        , takeXAppsAsList
+        , takeXConApps
+        , takeXPrimApps
+
+          -- * Lets
+        , xLets
+        , splitXLets 
+        , bindsOfLets
+        , specBindsOfLets
+        , valwitBindsOfLets
+
+          -- * Patterns
+        , bindsOfPat
+
+          -- * Alternatives
+        , takeCtorNameOfAlt
+
+          -- * Witnesses
+        , wApp
+        , wApps
+        , takeXWitness
+        , takeWAppsAsList
+        , takePrimWiConApps
+
+          -- * Types
+        , takeXType
+
+          -- * Data Constructors
+        , xUnit, dcUnit
+        , takeNameOfDaCon
+        , takeTypeOfDaCon)
+where
+import DDC.Type.Exp
+import DDC.Core.Exp.Simple.Exp
+import DDC.Core.Exp.DaCon
+import DDC.Type.Compounds
+
+
+-- Lambdas ---------------------------------------------------------------------
+-- | Make some nested type lambdas.
+xLAMs :: [Bind n] -> Exp a n -> Exp a n
+xLAMs bs x
+        = foldr XLAM x bs
+
+
+-- | Make some nested value or witness lambdas.
+xLams :: [Bind n] -> Exp a n -> Exp a n
+xLams bs x
+        = foldr XLam x bs
+
+
+-- | Split type lambdas from the front of an expression,
+--   or `Nothing` if there aren't any.
+takeXLAMs :: Exp a n -> Maybe ([Bind n], Exp a n)
+takeXLAMs xx
+ = let  go bs (XLAM b x) = go (b:bs) x
+        go bs x            = (reverse bs, x)
+   in   case go [] xx of
+         ([], _)        -> Nothing
+         (bs, body)     -> Just (bs, body)
+
+
+-- | Split nested value or witness lambdas from the front of an expression,
+--   or `Nothing` if there aren't any.
+takeXLams :: Exp a n -> Maybe ([Bind n], Exp a n)
+takeXLams xx
+ = let  go bs (XLam b x) = go (b:bs) x
+        go bs x          = (reverse bs, x)
+   in   case go [] xx of
+         ([], _)        -> Nothing
+         (bs, body)     -> Just (bs, body)
+
+
+-- | Make some nested lambda abstractions,
+--   using a flag to indicate whether the lambda is a
+--   level-1 (True), or level-0 (False) binder.
+makeXLamFlags :: [(Bool, Bind n)] -> Exp a n -> Exp a n
+makeXLamFlags fbs x
+ = foldr (\(f, b) x'
+           -> if f then XLAM b x'
+                   else XLam b x')
+                x fbs
+
+
+-- | Split nested lambdas from the front of an expression, 
+--   with a flag indicating whether the lambda was a level-1 (True), 
+--   or level-0 (False) binder.
+takeXLamFlags :: Exp a n -> Maybe ([(Bool, Bind n)], Exp a n)
+takeXLamFlags xx
+ = let  go bs (XLAM b x)  = go ((True,  b):bs) x
+        go bs (XLam b x)  = go ((False, b):bs) x
+        go bs x           = (reverse bs, x)
+   in   case go [] xx of
+         ([], _)        -> Nothing
+         (bs, body)     -> Just (bs, body)
+
+
+-- Applications ---------------------------------------------------------------
+-- | Build sequence of value applications.
+xApps   :: Exp a n -> [Exp a n] -> Exp a n
+xApps t1 ts     = foldl XApp t1 ts
+
+
+-- | Flatten an application into the function part and its arguments.
+--
+--   Returns `Nothing` if there is no outer application.
+takeXApps :: Exp a n -> Maybe (Exp a n, [Exp a n])
+takeXApps xx
+ = case takeXAppsAsList xx of
+        (x1 : xsArgs)   -> Just (x1, xsArgs)
+        _               -> Nothing
+
+
+-- | Flatten an application into the function part and its arguments.
+--
+--   This is like `takeXApps` above, except we know there is at least one argument.
+takeXApps1 :: Exp a n -> Exp a n -> (Exp a n, [Exp a n])
+takeXApps1 x1 x2
+ = case takeXApps x1 of
+        Nothing          -> (x1,  [x2])
+        Just (x11, x12s) -> (x11, x12s ++ [x2])
+
+
+-- | Flatten an application into the function parts and arguments, if any.
+takeXAppsAsList  :: Exp a n -> [Exp a n]
+takeXAppsAsList xx
+ = case xx of
+        XApp x1 x2      -> takeXAppsAsList x1 ++ [x2]
+        _               -> [xx]
+
+
+-- | Flatten an application of a primop into the variable
+--   and its arguments.
+--   
+--   Returns `Nothing` if the expression isn't a primop application.
+takeXPrimApps :: Exp a n -> Maybe (n, [Exp a n])
+takeXPrimApps xx
+ = case takeXAppsAsList xx of
+        XVar (UPrim p _) : xs -> Just (p, xs)
+        _                     -> Nothing
+
+-- | Flatten an application of a data constructor into the constructor
+--   and its arguments. 
+--
+--   Returns `Nothing` if the expression isn't a constructor application.
+takeXConApps :: Exp a n -> Maybe (DaCon n, [Exp a n])
+takeXConApps xx
+ = case takeXAppsAsList xx of
+        XCon dc : xs  -> Just (dc, xs)
+        _             -> Nothing
+
+
+-- Lets -----------------------------------------------------------------------
+-- | Wrap some let-bindings around an expression.
+xLets :: [Lets a n] -> Exp a n -> Exp a n
+xLets lts x
+ = foldr XLet x lts
+
+
+-- | Split let-bindings from the front of an expression, if any.
+splitXLets :: Exp a n -> ([Lets a n], Exp a n)
+splitXLets xx
+ = case xx of
+        XLet lts x 
+         -> let (lts', x')      = splitXLets x
+            in  (lts : lts', x')
+
+        _ -> ([], xx)
+
+
+-- | Take the binds of a `Lets`.
+--
+--   The level-1 and level-0 binders are returned separately.
+bindsOfLets :: Lets a n -> ([Bind n], [Bind n])
+bindsOfLets ll
+ = case ll of
+        LLet b _          -> ([],  [b])
+        LRec bxs          -> ([],  map fst bxs)
+        LPrivate bs _ bbs -> (bs, bbs)
+
+
+-- | Like `bindsOfLets` but only take the spec (level-1) binders.
+specBindsOfLets :: Lets a n -> [Bind n]
+specBindsOfLets ll
+ = case ll of
+        LLet _ _         -> []
+        LRec _           -> []
+        LPrivate bs _ _  -> bs
+
+
+-- | Like `bindsOfLets` but only take the value and witness (level-0) binders.
+valwitBindsOfLets :: Lets a n -> [Bind n]
+valwitBindsOfLets ll
+ = case ll of
+        LLet b _        -> [b]
+        LRec bxs        -> map fst bxs
+        LPrivate _ _ bs -> bs
+
+
+-- Alternatives ---------------------------------------------------------------
+-- | Take the constructor name of an alternative, if there is one.
+takeCtorNameOfAlt :: Alt a n -> Maybe n
+takeCtorNameOfAlt aa
+ = case aa of
+        AAlt (PData dc _) _     -> takeNameOfDaCon dc
+        _                       -> Nothing
+
+
+-- Patterns -------------------------------------------------------------------
+-- | Take the binds of a `Pat`.
+bindsOfPat :: Pat n -> [Bind n]
+bindsOfPat pp
+ = case pp of
+        PDefault          -> []
+        PData _ bs        -> bs
+
+
+-- Witnesses ------------------------------------------------------------------
+-- | Construct a witness application
+wApp :: Witness a n -> Witness a n -> Witness a n
+wApp = WApp
+
+
+-- | Construct a sequence of witness applications
+wApps :: Witness a n -> [Witness a n] -> Witness a n
+wApps = foldl wApp
+
+
+-- | Take the witness from an `XWitness` argument, if any.
+takeXWitness :: Exp a n -> Maybe (Witness a n)
+takeXWitness xx
+ = case xx of
+        XWitness t -> Just t
+        _          -> Nothing
+
+
+-- | Flatten an application into the function parts and arguments, if any.
+takeWAppsAsList :: Witness a n -> [Witness a n]
+takeWAppsAsList ww
+ = case ww of
+        WApp w1 w2 -> takeWAppsAsList w1 ++ [w2]
+        _          -> [ww]
+
+
+-- | Flatten an application of a witness into the witness constructor
+--   name and its arguments.
+--
+--   Returns nothing if there is no witness constructor in head position.
+takePrimWiConApps :: Witness a n -> Maybe (n, [Witness a n])
+takePrimWiConApps ww
+ = case takeWAppsAsList ww of
+        WCon wc : args | WiConBound (UPrim n _) _ <- wc
+          -> Just (n, args)
+        _ -> Nothing
+
+
+-- Types ----------------------------------------------------------------------
+-- | Take the type from an `XType` argument, if any.
+takeXType :: Exp a n -> Maybe (Type n)
+takeXType xx
+ = case xx of
+        XType t -> Just t
+        _       -> Nothing
+
+
+-- Units -----------------------------------------------------------------------
+-- | Construct a value of unit type.
+xUnit   :: Exp a n
+xUnit = XCon dcUnit
diff --git a/DDC/Core/Exp/Simple/Exp.hs b/DDC/Core/Exp/Simple/Exp.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Exp/Simple/Exp.hs
@@ -0,0 +1,196 @@
+
+-- | Core language AST with a separate node to hold annotations.
+--
+--   This version of the AST is used when generating code where most or all
+--   of the annotations would be empty. General purpose transformations should
+--   deal with the fully annotated version of the AST instead.
+--
+module DDC.Core.Exp.Simple.Exp 
+        ( module DDC.Type.Exp
+
+          -- * Expressions
+        , Exp           (..)
+        , Cast          (..)
+        , Lets          (..)
+        , Alt           (..)
+        , Pat           (..)
+
+          -- * Witnesses
+        , Witness       (..)
+
+          -- * Data Constructors
+        , DaCon         (..)
+
+          -- * Witness Constructors
+        , WiCon         (..))
+where
+import DDC.Core.Exp.WiCon
+import DDC.Core.Exp.DaCon
+import DDC.Type.Exp
+import DDC.Type.Sum             ()
+import Control.DeepSeq
+
+
+-- Values ---------------------------------------------------------------------
+-- | Well-typed expressions have types of kind `Data`.
+data Exp a n
+        -- | Annotation.
+        = XAnnot a (Exp a n)
+
+        -- | Value variable   or primitive operation.
+        | XVar  !(Bound n)
+
+        -- | Data constructor or literal.
+        | XCon  !(DaCon n)
+
+        -- | Type abstraction (level-1).
+        | XLAM  !(Bind n)   !(Exp a n)
+
+        -- | Value and Witness abstraction (level-0).
+        | XLam  !(Bind n)   !(Exp a n)
+
+        -- | Application.
+        | XApp  !(Exp a n)  !(Exp a n)
+
+        -- | Possibly recursive bindings.
+        | XLet  !(Lets a n) !(Exp a n)
+
+        -- | Case branching.
+        | XCase !(Exp a n)  ![Alt a n]
+
+        -- | Type cast.
+        | XCast !(Cast a n) !(Exp a n)
+
+        -- | Type can appear as the argument of an application.
+        | XType    !(Type n)
+
+        -- | Witness can appear as the argument of an application.
+        | XWitness !(Witness a n)
+        deriving (Show, Eq)
+
+
+-- | Possibly recursive bindings.
+data Lets a n
+        -- | Non-recursive expression binding.
+        = LLet     !(Bind n) !(Exp a n)
+
+        -- | Recursive binding of lambda abstractions.
+        | LRec     ![(Bind n, Exp a n)]
+
+        -- | Bind a local region variable,
+        --   and witnesses to its properties.
+        | LPrivate ![Bind n] !(Maybe (Type n)) ![Bind n]
+        deriving (Show, Eq)
+
+
+-- | Case alternatives.
+data Alt a n
+        = AAlt !(Pat n) !(Exp a n)
+        deriving (Show, Eq)
+
+
+-- | Pattern matching.
+data Pat n
+        -- | The default pattern always succeeds.
+        = PDefault
+        
+        -- | Match a data constructor and bind its arguments.
+        | PData !(DaCon n) ![Bind n]
+        deriving (Show, Eq)
+
+
+-- | When a witness exists in the program it guarantees that a
+--   certain property of the program is true.
+data Witness a n
+        = WAnnot a (Witness a n)
+
+        -- | Witness variable.
+        | WVar  !(Bound n)
+        
+        -- | Witness constructor.
+        | WCon  !(WiCon n)
+        
+        -- | Witness application.
+        | WApp  !(Witness a n) !(Witness a n)
+
+        -- | Type can appear as the argument of an application.
+        | WType !(Type n)
+        deriving (Show, Eq)
+
+
+-- | Type casts.
+data Cast a n
+        -- | Weaken the effect of an expression.
+        --   The given effect is added to the effect
+        --   of the body.
+        = CastWeakenEffect  !(Effect n)
+        
+        -- | Purify the effect (action) of an expression.
+        | CastPurify        !(Witness a n)
+
+        -- | Box up a computation, 
+        --   capturing its effects in the S computation type.
+        | CastBox 
+
+        -- | Run a computation,
+        --   releasing its effects into the environment.
+        | CastRun
+        deriving (Show, Eq)
+
+
+-- NFData ---------------------------------------------------------------------
+instance (NFData a, NFData n) => NFData (Exp a n) where
+ rnf xx
+  = case xx of
+        XAnnot a x      -> rnf a   `seq` rnf x
+        XVar   u        -> rnf u
+        XCon   dc       -> rnf dc
+        XLAM   b x      -> rnf b   `seq` rnf x
+        XLam   b x      -> rnf b   `seq` rnf x
+        XApp   x1 x2    -> rnf x1  `seq` rnf x2
+        XLet   lts x    -> rnf lts `seq` rnf x
+        XCase  x alts   -> rnf x   `seq` rnf alts
+        XCast  c x      -> rnf c   `seq` rnf x
+        XType  t        -> rnf t
+        XWitness w      -> rnf w
+
+
+instance (NFData a, NFData n) => NFData (Cast a n) where
+ rnf cc
+  = case cc of
+        CastWeakenEffect e      -> rnf e
+        CastPurify w            -> rnf w
+        CastBox                 -> ()
+        CastRun                 -> ()
+
+
+instance (NFData a, NFData n) => NFData (Lets a n) where
+ rnf lts
+  = case lts of
+        LLet b x                -> rnf b `seq` rnf x
+        LRec bxs                -> rnf bxs
+        LPrivate bs1 t2 bs3     -> rnf bs1  `seq` rnf t2 `seq` rnf bs3
+
+
+instance (NFData a, NFData n) => NFData (Alt a n) where
+ rnf aa
+  = case aa of
+        AAlt w x                -> rnf w `seq` rnf x
+
+
+instance NFData n => NFData (Pat n) where
+ rnf pp
+  = case pp of
+        PDefault                -> ()
+        PData dc bs             -> rnf dc `seq` rnf bs
+
+
+instance (NFData a, NFData n) => NFData (Witness a n) where
+ rnf ww
+  = case ww of
+        WAnnot a w              -> rnf a `seq` rnf w
+        WVar   u                -> rnf u
+        WCon   c                -> rnf c
+        WApp   w1 w2            -> rnf w1 `seq` rnf w2
+        WType  t                -> rnf t
+
diff --git a/DDC/Core/Exp/WiCon.hs b/DDC/Core/Exp/WiCon.hs
--- a/DDC/Core/Exp/WiCon.hs
+++ b/DDC/Core/Exp/WiCon.hs
@@ -1,7 +1,6 @@
 
 module DDC.Core.Exp.WiCon
-        ( WiCon  (..)
-        , WbCon  (..))
+        ( WiCon  (..))
 where
 import DDC.Type.Exp
 import DDC.Type.Sum     ()
@@ -10,58 +9,10 @@
 
 -- | Witness constructors.
 data WiCon n
-        -- | Witness constructors baked into the language.
-        = WiConBuiltin !WbCon
-
         -- | Witness constructors defined in the environment.
         --   In the interpreter we use this to hold runtime capabilities.
         --   The attached type must be closed.
-        | WiConBound   !(Bound n) !(Type n)
-        deriving (Show, Eq)
-
-
--- | Built-in witness constructors.
---
---   These are used to convert a runtime capability into a witness that
---   the corresponding property is true.
-data WbCon
-        -- | (axiom) The pure effect is pure.
-        -- 
-        --   @pure     :: Pure !0@
-        = WbConPure 
-
-        -- | (axiom) The empty closure is empty.
-        --
-        --   @empty    :: Empty $0@
-        | WbConEmpty
-
-        -- | Convert a capability guaranteeing that a region is in the global
-        --   heap, into a witness that a closure using this region is empty.
-        --   This lets us rely on the garbage collector to reclaim objects
-        --   in the region. It is needed when we suspend the evaluation of 
-        --   expressions that have a region in their closure, because the
-        --   type of the returned thunk may not reveal that it references
-        --   objects in that region.
-        -- 
-        --  @use      :: [r : %]. Global r => Empty (Use r)@
-        | WbConUse      
-
-        -- | Convert a capability guaranteeing the constancy of a region, into
-        --   a witness that a read from that region is pure.
-        --   This lets us suspend applications that read constant objects,
-        --   because it doesn't matter if the read is delayed, we'll always
-        --   get the same result.
-        --
-        --   @read     :: [r : %]. Const r  => Pure (Read r)@
-        | WbConRead     
-
-        -- | Convert a capability guaranteeing the constancy of a region, into
-        --   a witness that allocation into that region is pure.
-        --   This lets us increase the sharing of constant objects,
-        --   because we can't tell constant objects of the same value apart.
-        -- 
-        --  @alloc    :: [r : %]. Const r  => Pure (Alloc r)@
-        | WbConAlloc
+        = WiConBound   !(Bound n) !(Type n)
         deriving (Show, Eq)
 
 
@@ -69,7 +20,8 @@
 instance NFData n => NFData (WiCon n) where
  rnf wi
   = case wi of
-        WiConBuiltin wb         -> rnf wb
         WiConBound   u t        -> rnf u `seq` rnf t
 
-instance NFData WbCon
+
+
+
diff --git a/DDC/Core/Fragment.hs b/DDC/Core/Fragment.hs
--- a/DDC/Core/Fragment.hs
+++ b/DDC/Core/Fragment.hs
@@ -2,17 +2,21 @@
 -- | The ambient Disciple Core language is specialised to concrete languages
 --   by adding primitive operations and optionally restricting the set of 
 --   available language features. This specialisation results in user-facing
---   language fragments such as @Disciple Core Lite@ and @Disciple Core Salt@.
+--   language fragments such as @Disciple Core Tetra@ and @Disciple Core Salt@.
 module DDC.Core.Fragment
         ( -- * Langauge fragments
           Fragment      (..)
+        , mapProfileOfFragment
+
         , Profile       (..)
+        , mapFeaturesOfProfile
         , zeroProfile
 
           -- * Fragment features
         , Feature       (..)
         , Features      (..)
         , zeroFeatures
+        , setFeature
 
         -- * Compliance
         , complies
@@ -62,3 +66,12 @@
  show frag
   = profileName $ fragmentProfile frag
 
+
+-- | Apply a function to the profile in a fragment.
+mapProfileOfFragment 
+        :: (Profile n -> Profile n) 
+        -> Fragment n err -> Fragment n err
+
+mapProfileOfFragment f fragment
+        = fragment
+        { fragmentProfile       = f (fragmentProfile fragment) }
diff --git a/DDC/Core/Fragment/Compliance.hs b/DDC/Core/Fragment/Compliance.hs
--- a/DDC/Core/Fragment/Compliance.hs
+++ b/DDC/Core/Fragment/Compliance.hs
@@ -1,18 +1,15 @@
 
 module DDC.Core.Fragment.Compliance
         ( complies
-	, compliesWithEnvs
+        , compliesWithEnvs
         , Complies)
 where
 import DDC.Core.Fragment.Feature
 import DDC.Core.Fragment.Profile
 import DDC.Core.Fragment.Error
-import DDC.Core.Compounds
-import DDC.Core.Predicates
 import DDC.Core.Module
-import DDC.Core.Exp
+import DDC.Core.Exp.Annot
 import Control.Monad
-import Control.Applicative
 import Data.Maybe
 import DDC.Type.Env                     (Env)
 import Data.Set                         (Set)
@@ -40,10 +37,10 @@
         :: (Ord n, Show n, Complies c)
         => Profile n            -- ^ Fragment profile giving the supported
                                 --   language features and primitive operators.
-	-> Env.KindEnv n        -- ^ Starting kind environment.
-	-> Env.TypeEnv n        -- ^ Starting type environment.
-	-> c a n                -- ^ The thing to check.
-	-> Maybe (Error a n)
+        -> Env.KindEnv n        -- ^ Starting kind environment.
+        -> Env.TypeEnv n        -- ^ Starting type environment.
+        -> c a n                -- ^ The thing to check.
+        -> Maybe (Error a n)
 
 compliesWithEnvs profile kenv tenv thing
  = let  merr    = result 
@@ -75,7 +72,7 @@
 
 instance Complies Module where
  compliesX profile kenv tenv context mm
-  = do  let bs          = [ BName n (typeOfImportSource isrc) 
+  = do  let bs          = [ BName n (typeOfImportValue isrc) 
                                 | (n, isrc) <- moduleImportValues mm ]
         let tenv'       = Env.extends bs tenv
         compliesX profile kenv tenv' context (moduleBody mm)
@@ -97,7 +94,7 @@
          |  args        <- fromMaybe 0 $ contextFunArgs context
          ,  Just t      <- Env.lookup u tenv
          ,  arity       <- arityOfType t
-         ,  args < arity
+         ,  args >= 1 && args < arity
          ,  not $ has featuresPartialApplication
          -> throw $ ErrorUnsupported PartialApplication
 
@@ -215,11 +212,6 @@
          -> do  (tUsed2, vUsed2) 
                  <- compliesX profile   (Env.extends rs  kenv) 
                                         (Env.extends bs tenv) 
-                                        (reset context) x2
-                return (tUsed2, vUsed2)
-
-        XLet _ (LWithRegion _) x2
-         -> do  (tUsed2, vUsed2) <- compliesX profile kenv tenv 
                                         (reset context) x2
                 return (tUsed2, vUsed2)
 
diff --git a/DDC/Core/Fragment/Feature.hs b/DDC/Core/Fragment/Feature.hs
--- a/DDC/Core/Fragment/Feature.hs
+++ b/DDC/Core/Fragment/Feature.hs
@@ -22,6 +22,12 @@
         -- | Treat effects as capabilities.
         | EffectCapabilities
 
+        -- | Insert implicit run casts for effectful applications.
+        | ImplicitRun
+
+        -- | Insert implicit box casts for bodies of abstractions.
+        | ImplicitBox
+
         -- General features -------------------------------
         -- | Partially applied primitive operators.
         | PartialPrims
@@ -38,6 +44,10 @@
         --   The output of the lambda-lifter should not contain these.
         | NestedFunctions
 
+        -- | Recursive let-expressions where the right hand sides
+        --   are not lambda abstractions.
+        | GeneralLetRec
+
         -- | Debruijn binders.
         --   Most backends will want to use real names, instead of indexed
         --   binders.
@@ -63,3 +73,4 @@
         -- | Allow unused named matches.
         | UnusedMatches
         deriving (Eq, Ord, Show)
+
diff --git a/DDC/Core/Fragment/Profile.hs b/DDC/Core/Fragment/Profile.hs
--- a/DDC/Core/Fragment/Profile.hs
+++ b/DDC/Core/Fragment/Profile.hs
@@ -2,6 +2,7 @@
 -- | A fragment profile determines what features a program can use.
 module DDC.Core.Fragment.Profile
         ( Profile (..)
+        , mapFeaturesOfProfile
         , zeroProfile
 
         , Features(..)
@@ -12,7 +13,9 @@
 import DDC.Type.DataDef
 import DDC.Type.Exp
 import DDC.Type.Env                     (KindEnv, TypeEnv)
+import DDC.Data.SourcePos
 import qualified DDC.Type.Env           as Env
+import Data.Text                        (Text)
 
 
 -- | The fragment profile describes the language features and 
@@ -40,9 +43,19 @@
 
           -- | Check whether some name represents a hole that needs
           --   to be filled in by the type checker.
-        , profileNameIsHole             :: !(Maybe (n -> Bool)) }
+        , profileNameIsHole             :: !(Maybe (n -> Bool)) 
 
+          -- | Embed a literal string in a name.
+        , profileMakeStringName         :: Maybe (SourcePos -> Text -> n) }
 
+
+-- | Apply a function to the `Features` of a `Profile`.
+mapFeaturesOfProfile :: (Features -> Features) -> Profile n -> Profile n
+mapFeaturesOfProfile f profile
+        = profile
+        { profileFeatures       = f (profileFeatures profile) }
+
+
 -- | A language profile with no features or primitive operators.
 --
 --   This provides a simple first-order language.
@@ -55,7 +68,8 @@
         , profilePrimKinds              = Env.empty
         , profilePrimTypes              = Env.empty
         , profileTypeIsUnboxed          = const False 
-        , profileNameIsHole             = Nothing }
+        , profileNameIsHole             = Nothing 
+        , profileMakeStringName         = Nothing }
 
 
 -- | A flattened set of features, for easy lookup.
@@ -66,10 +80,13 @@
         , featuresFunctionalEffects     :: Bool
         , featuresFunctionalClosures    :: Bool
         , featuresEffectCapabilities    :: Bool
+        , featuresImplicitRun           :: Bool
+        , featuresImplicitBox           :: Bool
         , featuresPartialPrims          :: Bool
         , featuresPartialApplication    :: Bool
         , featuresGeneralApplication    :: Bool
         , featuresNestedFunctions       :: Bool
+        , featuresGeneralLetRec         :: Bool
         , featuresDebruijnBinders       :: Bool
         , featuresUnboundLevel0Vars     :: Bool
         , featuresUnboxedInstantiation  :: Bool
@@ -88,10 +105,13 @@
         , featuresFunctionalEffects     = False
         , featuresFunctionalClosures    = False
         , featuresEffectCapabilities    = False
+        , featuresImplicitRun           = False
+        , featuresImplicitBox           = False
         , featuresPartialPrims          = False
         , featuresPartialApplication    = False
         , featuresGeneralApplication    = False
         , featuresNestedFunctions       = False
+        , featuresGeneralLetRec         = False
         , featuresDebruijnBinders       = False
         , featuresUnboundLevel0Vars     = False
         , featuresUnboxedInstantiation  = False
@@ -109,10 +129,13 @@
         FunctionalEffects       -> features { featuresFunctionalEffects    = val }
         FunctionalClosures      -> features { featuresFunctionalClosures   = val }
         EffectCapabilities      -> features { featuresEffectCapabilities   = val }
+        ImplicitRun             -> features { featuresImplicitRun          = val }
+        ImplicitBox             -> features { featuresImplicitBox          = val }
         PartialPrims            -> features { featuresPartialPrims         = val }
         PartialApplication      -> features { featuresPartialApplication   = val }
         GeneralApplication      -> features { featuresGeneralApplication   = val }
         NestedFunctions         -> features { featuresNestedFunctions      = val }
+        GeneralLetRec           -> features { featuresGeneralLetRec        = val }
         DebruijnBinders         -> features { featuresDebruijnBinders      = val }
         UnboundLevel0Vars       -> features { featuresUnboundLevel0Vars    = val }
         UnboxedInstantiation    -> features { featuresUnboxedInstantiation = val }
diff --git a/DDC/Core/Lexer.hs b/DDC/Core/Lexer.hs
--- a/DDC/Core/Lexer.hs
+++ b/DDC/Core/Lexer.hs
@@ -21,10 +21,12 @@
 import DDC.Data.SourcePos
 import DDC.Data.Token
 import Data.Char
-import Data.List
+import Data.Text                        (Text)
+import qualified Data.Text              as T
+import Data.Monoid
 
 
--- Module ---------------------------------------------------------------------
+-- Module -----------------------------------------------------------------------------------------
 -- | Lex a module and apply the offside rule.
 --
 --   Automatically drop comments from the token stream along the way.
@@ -40,10 +42,11 @@
         applyOffside [] []
         $ addStarts
         $ dropComments 
-        $ lexString sourceName lineStart str
+        $ lexText sourceName lineStart 
+        $ T.pack str
 
 
--- Exp ------------------------------------------------------------------------
+-- Exp --------------------------------------------------------------------------------------------
 -- | Lex a string into tokens.
 --
 --   Automatically drop comments from the token stream along the way.
@@ -57,132 +60,211 @@
  = {-# SCC lexExp #-}
         dropNewLines
         $ dropComments
-        $ lexString sourceName lineStart str
+        $ lexText sourceName lineStart 
+        $ T.pack str
 
 
--- Generic --------------------------------------------------------------------
-lexString :: String -> Int -> String -> [Token (Tok String)]
-lexString sourceName lineStart str
-        = lexWord lineStart 1 str
+-- Generic ----------------------------------------------------------------------------------------
+-- Tokenize some input text.
+--
+-- NOTE: Although the main interface for the lexer uses standard Haskell strings,
+--       we're using Text internally to get proper unicode tokenization.
+--       Eventually, we should refactor the API to only pass around Text, rather
+--       than Strings.
+--
+lexText :: String       -- ^ Name of source file, which is attached to the tokens.
+        -> Int          -- ^ Starting line number.
+        -> Text         -- ^ Text to tokenize.
+        -> [Token (Tok String)]
+
+lexText sourceName lineStart xx
+ = lexWord lineStart 1 xx
  where 
-  lexWord :: Int -> Int -> String -> [Token (Tok String)]
+
+  lexWord :: Int -> Int -> Text -> [Token (Tok String)]
   lexWord line column w
-   = let  tok t = Token t (SourcePos sourceName line column)
-          tokM  = tok . KM
-          tokA  = tok . KA
-          tokN  = tok . KN
+   = match w
+   where
+        tok t = Token t (SourcePos sourceName line column)
+        tokM  = tok . KM
+        tokA  = tok . KA
+        tokN  = tok . KN
 
-          lexUpto pat rest
-           = case dropWhile (not . isPrefixOf pat) (tails rest) of
-                (x:_)   -> x
-                _       -> []
+        lexMore n rest
+         = lexWord line (column + n) rest
 
-          lexMore n rest
-           = lexWord line (column + n) rest
+        lexUpto pat rest
+         = case dropWhile (not . T.isPrefixOf pat) (T.tails rest) of
+                x : _   -> x
+                _       -> T.empty
 
-     in case w of
-        []               -> []        
+        txt           = T.pack 
+        prefix str    = T.stripPrefix (T.pack str)
 
-        -- Whitespace
-        ' '  : w'        -> lexMore 1 w'
-        '\t' : w'        -> lexMore 8 w'
+        match cs
+         | T.null cs
+         = []
 
-        -- Literal values
-        -- This needs to come before the rule for '-'
-        c : cs
-         | isDigit c
-         , (body, rest)         <- span isLitBody cs
-         -> tokN (KLit (c:body))        : lexMore (length (c:body)) rest
+         -- Whitespace
+         | Just (' ', rest)     <- T.uncons cs
+         = lexMore 1 rest
 
-        '-' : c : cs
-         | isDigit c
-         , (body, rest)         <- span isLitBody cs
-         -> tokN (KLit ('-':c:body))    : lexMore (length (c:body)) rest
+         | Just ('\t', rest)    <- T.uncons cs
+         = lexMore 8 rest
 
-        -- Meta tokens
-        '{'  : '-' : w'
-         -> tokM KCommentBlockStart : lexMore 2 (lexUpto "-}" w')
+         -- Meta tokens
+         | Just rest            <- T.stripPrefix (txt "{-#") cs
+         , (prag, rest')        <- T.breakOn     (txt "#-}") rest
+         , rest''               <- T.drop 3 rest'
+         , len                  <- 3 + T.length prag + 3
+         = tokA (KPragma prag)          : lexMore len rest''
 
-        '-'  : '}' : w'
-         -> tokM KCommentBlockEnd   : lexMore 2 w'
 
-        '-'  : '-' : w'  
-         -> let  (_junk, w'') = span (/= '\n') w'
-            in   tokM KCommentLineStart  : lexMore 2 w''
+         | Just rest            <- T.stripPrefix (txt "{-") cs
+         = tokM KCommentBlockStart      : lexMore 2 (lexUpto (txt "-}") rest)
 
-        '\n' : w'        -> tokM KNewLine           : lexWord (line + 1) 1 w'
+         | Just rest            <- T.stripPrefix (txt "-}") cs
+         = tokM KCommentBlockEnd        : lexMore 2 rest
 
-        -- Wrapper operator symbols.
-        '(' : c : cs 
-         | isOpStart c
-         , (body, ')' : w')     <- span isOpBody cs
-         -> tokA (KOpVar (c : body))             : lexMore (2 + length (c : body)) w'
+         | Just cs1             <- T.stripPrefix (txt "--") cs
+         , (_junk, rest)        <- T.span (/= '\n') cs1
+         = tokM KCommentLineStart       : lexMore 2 rest
 
-        -- The unit data constructor
-        '(' : ')' : w'   -> tokA KDaConUnit      : lexMore 2 w'
+         | Just ('\n', rest)    <- T.uncons cs
+         = tokM KNewLine                : lexWord (line + 1) 1 rest
 
-        -- Compound Parens
-        '['  : ':' : w'  -> tokA KSquareColonBra : lexMore 2 w'
-        ':'  : ']' : w'  -> tokA KSquareColonKet : lexMore 2 w'
-        '{'  : ':' : w'  -> tokA KBraceColonBra  : lexMore 2 w'
-        ':'  : '}' : w'  -> tokA KBraceColonKet  : lexMore 2 w'
+         -- Double character symbols.
+         | not (T.compareLength cs 2 == LT)
+         , (cs1, rest)          <- T.splitAt 2 cs
+         , Just t      
+            <- case T.unpack cs1 of
+                "[:"            -> Just KSquareColonBra
+                ":]"            -> Just KSquareColonKet
+                "{:"            -> Just KBraceColonBra
+                ":}"            -> Just KBraceColonKet
+                "~>"            -> Just KArrowTilde
+                "->"            -> Just KArrowDash
+                "<-"            -> Just KArrowDashLeft
+                "=>"            -> Just KArrowEquals
+                "/\\"           -> Just KBigLambdaSlash
+                "()"            -> Just KDaConUnit
+                _               -> Nothing
+         = tokA t : lexMore 2 rest
 
-        -- Function Constructors
-        '~'  : '>'  : w' -> tokA KArrowTilde     : lexMore 2 w'
-        '-'  : '>'  : w' -> tokA KArrowDash      : lexMore 2 w'
-        '<'  : '-'  : w' -> tokA KArrowDashLeft  : lexMore 2 w'
-        '='  : '>'  : w' -> tokA KArrowEquals    : lexMore 2 w'
 
-        -- Compound symbols
-        '/'  : '\\' : w' -> tokA KBigLambda      : lexMore 2 w'
+         -- Wrapped operator symbols.
+         -- This needs to come before lexing single character symbols.
+         | Just ('(', cs1)      <- T.uncons cs
+         , Just (c,   cs2)      <- T.uncons cs1
+         , isOpStart c
+         , (body, cs3)          <- T.span isOpBody cs2
+         , Just (')', rest)     <- T.uncons cs3
+         = tokA (KOpVar (T.unpack (T.cons c body))) 
+                                                : lexMore (2 + T.length (T.cons c body)) rest
 
-        -- Debruijn indices
-        '^'  : cs
-         |  (ds, rest)   <- span isDigit cs
-         ,  length ds >= 1
-         -> tokA (KIndex (read ds))              : lexMore (1 + length ds) rest         
+         -- Literal numeric values
+         -- This needs to come before the rule for '-'
+         | Just (c, cs1)        <- T.uncons cs
+         , isDigit c
+         , (body, rest)         <- T.span isLitBody cs1
+         = let  str             =  T.unpack (T.cons c body)
+           in   tokN (KLit str) : lexMore (length str) rest
 
-        -- Parens
-        '('  : w'       -> tokA KRoundBra        : lexMore 1 w'
-        ')'  : w'       -> tokA KRoundKet        : lexMore 1 w'
-        '['  : w'       -> tokA KSquareBra       : lexMore 1 w'
-        ']'  : w'       -> tokA KSquareKet       : lexMore 1 w'
-        '{'  : w'       -> tokA KBraceBra        : lexMore 1 w'
-        '}'  : w'       -> tokA KBraceKet        : lexMore 1 w'
-        
-        -- Punctuation Symbols
-        '.'  : w'       -> tokA KDot             : lexMore 1 w'
-        ','  : w'       -> tokA KComma           : lexMore 1 w'
-        ';'  : w'       -> tokA KSemiColon       : lexMore 1 w'
-        '_'  : w'       -> tokA KUnderscore      : lexMore 1 w'
-        '\\' : w'       -> tokA KBackSlash       : lexMore 1 w'
+         | Just ('-', cs1)      <- T.uncons cs
+         , Just (c,   _)        <- T.uncons cs1
+         , isDigit c
+         = let  (body, rest)   = T.span isLitBody cs1
+                str            = T.unpack (T.cons '-' body)
+           in   tokN (KLit str) : lexMore (length str) rest
 
-        -- Operator symbols.
-        c : cs
-         |  isOpStart c
-         ,  (body, rest)         <- span isOpBody cs
-         -> tokA (KOp (c : body))                : lexMore (length (c : body)) rest
+         -- Literal strings.
+         -- We force these to be null terminated so the representation is compatable
+         -- with C string functions.
+         | Just ('\"', cc)      <- T.uncons cs
+         = let 
+                eat n acc xs
+                 | Just ('\\', xs1)     <- T.uncons xs
+                 , Just ('"',  xs2)     <- T.uncons xs1
+                 = eat (n + 2) ('"' : acc) xs2
+
+                 | Just ('\\', xs1)     <- T.uncons xs
+                 , Just ('n',  xs2)     <- T.uncons xs1
+                 = eat (n + 2) ('\n' : acc) xs2
+
+                 | Just ('"',  xs1)     <- T.uncons xs
+                 = tokA (KString (T.pack (reverse acc)))
+                 : lexWord line (column + n) xs1
+
+                 | Just (c,    xs1)     <- T.uncons xs
+                 = eat (n + 1) (c : acc) xs1
+
+                 | otherwise
+                 = [tok $ KErrorUnterm (T.unpack cs)]
+
+           in eat 0 [] cc
+
+         -- Operator symbols.
+         | Just (c, cs1)        <- T.uncons cs
+         , isOpStart c
+         , (body, rest)         <- T.span isOpBody cs1
+         , sym                  <- T.cons c body
+         , sym /= T.pack "="
+         , sym /= T.pack "|"
+         = tokA (KOp (T.unpack sym)) : lexMore (1 + T.length body) rest
+
+         -- Single character symbols.
+         | Just (c, rest)       <- T.uncons cs
+         , Just t
+            <- case c of
+                '('             -> Just KRoundBra
+                ')'             -> Just KRoundKet
+                '['             -> Just KSquareBra
+                ']'             -> Just KSquareKet
+                '{'             -> Just KBraceBra
+                '}'             -> Just KBraceKet
+                '.'             -> Just KDot
+                ','             -> Just KComma
+                ';'             -> Just KSemiColon
+                '\\'            -> Just KBackSlash
+                '='             -> Just KEquals
+                '|'             -> Just KBar
+                _               -> Nothing
+         = tokA t : lexMore 1 rest
+
+         -- Debruijn indices
+         | Just ('^', cs1)      <- T.uncons cs
+         , (ds, rest)           <- T.span isDigit cs1
+         , T.length ds >= 1
+         = tokA (KIndex (read (T.unpack ds)))   : lexMore (1 + T.length ds) rest         
         
-        -- Operator body symbols.
-        '^'  : w'       -> tokA KHat             : lexMore 1 w'
+         -- Operator body symbols.
+         | Just ('^', rest)     <- T.uncons cs
+         = tokA KHat                            : lexMore 1 rest
 
-        -- Bottoms
-        name
-         |  Just w'     <- stripPrefix "Pure"  name 
-         -> tokA KBotEffect   : lexMore 2 w'
-         
-         |  Just w'     <- stripPrefix "Empty" name 
-         -> tokA KBotClosure  : lexMore 2 w'
+         -- Lambdas
+         | Just ('λ', rest)     <- T.uncons cs
+         = tokA KLambda                         : lexMore 1 rest
 
-        -- Named Constructors
-        c : cs
-         | isConStart c
-         , (body,  rest)        <- span isConBody cs
-         , (body', rest')       <- case rest of
-                                        '\'' : rest'    -> (body ++ "'", rest')
-                                        '#'  : rest'    -> (body ++ "#", rest')
-                                        _               -> (body, rest)
-         -> let readNamedCon s
+         | Just ('Λ', rest)     <- T.uncons cs
+         = tokA KBigLambda                      : lexMore 1 rest
+
+
+         -- Bottoms
+         | Just rest            <- prefix "Pure" cs
+         = tokA KBotEffect                      : lexMore 4 rest
+
+         | Just rest            <- prefix "Empty" cs
+         = tokA KBotClosure                     : lexMore 5 rest
+
+         -- Named Constructors
+         | Just (c, cs1)        <- T.uncons cs
+         , isConStart c
+         , (body,  rest)        <- T.span isConBody cs1
+         , (body', rest')       <- case T.uncons rest of
+                                        Just ('\'', rest') -> (body <> T.pack "'", rest')
+                                        Just ('#',  rest') -> (body <> T.pack "#", rest')
+                                        _                  -> (body, rest)
+         = let readNamedCon s
                  | Just socon   <- readSoConBuiltin s
                  = tokA (KSoConBuiltin socon)    : lexMore (length s) rest'
 
@@ -199,33 +281,35 @@
                  = tokN (KCon con)               : lexMore (length s) rest'
                
                  | otherwise    
-                 = [tok (KJunk [c])]
+                 = [tok (KErrorJunk [c])]
                  
-            in  readNamedCon (c : body')
+            in  readNamedCon (T.unpack (T.cons c body'))
 
-        -- Keywords, Named Variables and Witness constructors
-        c : cs
-         | isVarStart c
-         , (body,  rest)        <- span isVarBody cs
-         , (body', rest')       <- case rest of
-                                        '#' : rest'     -> (body ++ "#", rest')
-                                        _               -> (body, rest)
-         -> let readNamedVar s
-                 | Just t  <- lookup s keywords
-                 = tok t                   : lexMore (length s) rest'
+         -- Keywords, Named Variables and Witness constructors
+         | Just (c, cs1)         <- T.uncons cs
+         , isVarStart c
+         , (body,  rest)         <- T.span isVarBody cs1
+         , (body', rest')        <- case T.uncons rest of
+                                        Just ('#', rest') -> (body <> T.pack "#", rest')
+                                        _                 -> (body, rest)
+         = let readNamedVar s
+                 | "_"          <- s
+                 = tokA KUnderscore        : lexMore (length s) rest'
 
-                 | Just wc <- readWbConBuiltin s
-                 = tokA (KWbConBuiltin wc) : lexMore (length s) rest'
+                 | Just t       <- lookup s keywords
+                 = tok t                   : lexMore (length s) rest'
          
-                 | Just v  <- readVar s
+                 | Just v       <- readVar s
                  = tokN (KVar v)           : lexMore (length s) rest'
 
                  | otherwise
-                 = [tok (KJunk [c])]
+                 = [tok (KErrorJunk [c])]
 
-            in  readNamedVar (c : body')
+            in  readNamedVar (T.unpack (T.cons c body'))
 
-        -- Some unrecognised character.
-        -- We still need to keep lexing as this may be in a comment.
-        c : cs   -> (tok $ KJunk [c]) : lexMore 1 cs
+         -- Some unrecognised character.
+         | otherwise
+         = case T.unpack cs of
+                (c : _) -> [tok $ KErrorJunk [c]]
+                _       -> [tok $ KErrorJunk []]
 
diff --git a/DDC/Core/Lexer/Names.hs b/DDC/Core/Lexer/Names.hs
--- a/DDC/Core/Lexer/Names.hs
+++ b/DDC/Core/Lexer/Names.hs
@@ -8,7 +8,6 @@
         , readKiConBuiltin
         , readTwConBuiltin
         , readTcConBuiltin
-        , readWbConBuiltin
 
           -- * Variable names
         , isVarName
@@ -34,11 +33,14 @@
 where
 import DDC.Core.Exp
 import DDC.Core.Lexer.Tokens
+import DDC.Core.Lexer.Unicode
 import DDC.Data.ListUtils
 import Data.Char
 import Data.List
+import qualified Data.Set               as Set
 
 
+---------------------------------------------------------------------------------------------------
 -- | Textual keywords in the core language.
 keywords :: [(String, Tok n)]
 keywords
@@ -48,6 +50,7 @@
         , ("foreign",    KA KForeign)
         , ("type",       KA KType)
         , ("value",      KA KValue)
+        , ("capability", KA KCapability)
         , ("data",       KA KData)
         , ("in",         KA KIn)
         , ("of",         KA KOf) 
@@ -60,16 +63,17 @@
         , ("let",        KA KLet)
         , ("case",       KA KCase)
         , ("purify",     KA KPurify)
-        , ("forget",     KA KForget)
         , ("box",        KA KBox)
         , ("run",        KA KRun)
         , ("weakeff",    KA KWeakEff)
-        , ("weakclo",    KA KWeakClo)
         , ("with",       KA KWith)
         , ("where",      KA KWhere) 
         , ("do",         KA KDo)
         , ("match",      KA KMatch)
-        , ("else",       KA KElse) ]
+        , ("if",         KA KIf)
+        , ("then",       KA KThen)
+        , ("else",       KA KElse)
+        , ("otherwise",  KA KOtherwise) ]
 
 
 -- | Read a named sort constructor.
@@ -97,17 +101,11 @@
 readTwConBuiltin :: String -> Maybe TwCon
 readTwConBuiltin ss
  = case ss of
-        "Global"        -> Just TwConGlobal
-        "DeepGlobal"    -> Just TwConDeepGlobal
         "Const"         -> Just TwConConst
         "DeepConst"     -> Just TwConDeepConst
         "Mutable"       -> Just TwConMutable
         "DeepMutable"   -> Just TwConDeepMutable
-        "Lazy"          -> Just TwConLazy
-        "HeadLazy"      -> Just TwConHeadLazy
-        "Manifest"      -> Just TwConManifest
         "Purify"        -> Just TwConPure
-        "Emptify"       -> Just TwConEmpty
         "Disjoint"      -> Just TwConDisjoint
         "Distinct"      -> Just (TwConDistinct 2)
         _               -> readTwConWithArity ss
@@ -136,24 +134,11 @@
         "DeepWrite"     -> Just TcConDeepWrite
         "Alloc"         -> Just TcConAlloc
         "DeepAlloc"     -> Just TcConDeepAlloc
-        "Use"           -> Just TcConUse
-        "DeepUse"       -> Just TcConDeepUse
         _               -> Nothing
 
 
--- | Read a witness constructor.
-readWbConBuiltin :: String -> Maybe WbCon
-readWbConBuiltin ss
- = case ss of
-        "pure"          -> Just WbConPure
-        "empty"         -> Just WbConEmpty
-        "use"           -> Just WbConUse
-        "read"          -> Just WbConRead
-        "alloc"         -> Just WbConAlloc
-        _               -> Nothing
 
-
--- Variable names -------------------------------------------------------------
+-- Variable names ---------------------------------------------------------------------------------
 -- | String is a variable name
 isVarName :: String -> Bool
 isVarName str
@@ -180,6 +165,7 @@
 isVarStart c
         =  isLower c
         || c == '?'
+        || c == '_'
         
 
 -- | Character can be part of a variable body.
@@ -200,7 +186,7 @@
         | otherwise     = Nothing
 
 
--- Constructor names ----------------------------------------------------------
+-- Constructor names ------------------------------------------------------------------------------
 -- | String is a constructor name.
 isConName :: String -> Bool
 isConName str
@@ -242,7 +228,7 @@
         | otherwise     = Nothing
 
 
--- Operator names -------------------------------------------------------------
+-- Operator names ---------------------------------------------------------------------------------
 -- | String is the name of some operator.
 isOpName :: String -> Bool
 isOpName str
@@ -265,6 +251,7 @@
         || c == '*'     || c == '-'     || c == '+'     || c == '='
         || c == ':'                     || c == '/'     || c == '|'
         || c == '<'     || c == '>'
+        || Set.member c unicodeOperatorsInfix
 
 
 -- | Character can be part of an operator body.
@@ -275,9 +262,10 @@
         || c == '*'     || c == '-'     || c == '+'     || c == '='
         || c == ':'     || c == '?'     || c == '/'     || c == '|'
         || c == '<'     || c == '>'
+        || Set.member c unicodeOperatorsInfix
 
 
--- Literal names --------------------------------------------------------------
+-- Literal names ----------------------------------------------------------------------------------
 -- | String is the name of a literal.
 isLitName :: String -> Bool
 isLitName str
@@ -302,7 +290,7 @@
 isLitBody c
         =  isDigit c
         || c == 'b' || c == 'o' || c == 'x'
-        || c == 'w' || c == 'f' || c == 'i' 
+        || c == 'w' || c == 'f' || c == 'i' || c == 's'
         || c == '.'
         || c == '#'
         || c == '\''
diff --git a/DDC/Core/Lexer/Offside.hs b/DDC/Core/Lexer/Offside.hs
--- a/DDC/Core/Lexer/Offside.hs
+++ b/DDC/Core/Lexer/Offside.hs
@@ -58,13 +58,14 @@
 -- offside rule within it.
 -- The blocks are introduced by:
 --      'exports' 'imports' 'letrec' 'where'
---      'import foreign X type'
---      'import foreign X value'
+--      'import foreign MODE type'
+--      'import foreign MODE capability'
+--      'import foreign MODE value'
 applyOffside ps [] ls
         | LexemeToken t1 
                 : (LexemeStartBlock n) : ls' <- ls
         ,   isToken t1 (KA KExport)
-         || isToken t1 (KA KImport)
+         || isToken t1 (KA KImport) 
          || isToken t1 (KA KLetRec)
          || isToken t1 (KA KWhere)
         = t1 : newCBra ls' 
@@ -78,12 +79,12 @@
         = t1 : t2 : newCBra ls'
                 : applyOffside (ParenBrace : ps) [n] ls'
 
-        -- (import | export) foreign X (type | value) { ... }
+        -- (import | export) foreign X (type | capability | value) { ... }
         | LexemeToken t1 : LexemeToken t2 : LexemeToken t3 : LexemeToken t4
                 : LexemeStartBlock n : ls' <- ls
         , isToken t1 (KA KImport)  || isToken t1 (KA KExport)
         , isToken t2 (KA KForeign)
-        , isToken t4 (KA KType)    || isToken t4 (KA KValue)
+        , isToken t4 (KA KType)    || isToken t4 (KA KCapability) || isToken t4 (KA KValue)
         = t1 : t2 : t3 : t4 : newCBra ls' 
                 : applyOffside (ParenBrace : ps) [n] ls'
 
@@ -142,7 +143,7 @@
         --  This should never happen,
         --   as there is no lexeme to start a new context at the end of the file.
         | []            <- dropNewLinesLexeme ts
-        = error "ddc-core: tried to start new context at end of file."
+        = error $ "ddc-core: tried to start new context at end of file."
 
         -- an empty block
         | otherwise
@@ -267,6 +268,7 @@
         | otherwise
         = []
 
+
 -- | Drop newline tokens at the front of this stream.
 dropNewLines :: Eq n => [Token (Tok n)] -> [Token (Tok n)]
 dropNewLines []              = []
@@ -319,11 +321,20 @@
  |  t1@Token { tokenTok = KA KImport }  : t2@Token { tokenTok = KA KValue }   : ts
  <- toks = Just ([t1, t2], ts)
 
+ -- import data
+ |  t1@Token { tokenTok = KA KImport }  : t2@Token { tokenTok = KA KData }    : ts
+ <- toks = Just ([t1, t2], ts)
+
  -- import foreign X type
  |  t1@Token { tokenTok = KA KImport }  : t2@Token { tokenTok = KA KForeign }
   : t3                                  : t4@Token { tokenTok = KA KType }    : ts
  <- toks = Just ([t1, t2, t3, t4], ts)
 
+ -- import foreign X capability
+ |  t1@Token { tokenTok = KA KImport }  : t2@Token { tokenTok = KA KForeign }
+  : t3                                  : t4@Token { tokenTok = KA KCapability } : ts
+ <- toks = Just ([t1, t2, t3, t4], ts)
+
  -- import foreign X value
  |  t1@Token { tokenTok = KA KImport}   : t2@Token { tokenTok = KA KForeign}
   : t3                                  : t4@Token { tokenTok = KA KValue }   : ts    
@@ -335,6 +346,7 @@
  |  t1@Token { tokenTok = KA KWhere }   : ts    <- toks = Just ([t1], ts)
  |  t1@Token { tokenTok = KA KExport }  : ts    <- toks = Just ([t1], ts)
  |  t1@Token { tokenTok = KA KImport }  : ts    <- toks = Just ([t1], ts)
+ |  t1@Token { tokenTok = KA KMatch }   : ts    <- toks = Just ([t1], ts)
 
  | otherwise                                             
  = Nothing
@@ -378,7 +390,7 @@
 
 takeTok :: [Lexeme n] -> Token (Tok n)
 takeTok []      
- = Token (KJunk "") (SourcePos "" 0 0)
+ = Token (KErrorJunk "") (SourcePos "" 0 0)
 
 takeTok (l : ls)
  = case l of
@@ -388,3 +400,4 @@
         LexemeToken t           -> t
         LexemeStartLine  _      -> takeTok ls
         LexemeStartBlock _      -> takeTok ls
+
diff --git a/DDC/Core/Lexer/Tokens.hs b/DDC/Core/Lexer/Tokens.hs
--- a/DDC/Core/Lexer/Tokens.hs
+++ b/DDC/Core/Lexer/Tokens.hs
@@ -20,6 +20,8 @@
 import DDC.Core.Pretty
 import DDC.Core.Exp
 import Control.Monad
+import Data.Text                (Text)
+import qualified Data.Text      as T
 
 
 -- TokenFamily ----------------------------------------------------------------
@@ -32,6 +34,8 @@
         | Keyword
         | Constructor
         | Index
+        | Literal
+        | Pragma
 
 
 -- | Describe a token family, for parser error messages.
@@ -42,14 +46,19 @@
         Keyword         -> "keyword"
         Constructor     -> "constructor"
         Index           -> "index"
+        Literal         -> "literal"
+        Pragma          -> "pragma"
 
 
 -- Tok ------------------------------------------------------------------------
 -- | Tokens accepted by the core language parser.
 data Tok n
         -- | Some junk symbol that isn't part of the language.
-        = KJunk String
+        = KErrorJunk String
 
+        -- | The first part of an unterminated string.
+        | KErrorUnterm String
+
         -- | Meta tokens contain out-of-band information that is eliminated
         --   before parsing proper.
         | KM    !TokMeta
@@ -73,7 +82,12 @@
 
 renameTok f kk
  = case kk of
-        KJunk s -> Just $ KJunk s
+        KErrorJunk s 
+         -> Just $ KErrorJunk s
+
+        KErrorUnterm s
+          -> Just $ KErrorUnterm s
+
         KM t    -> Just $ KM t
         KA t    -> Just $ KA t
         KN t    -> liftM KN $ renameTokNamed f t
@@ -83,7 +97,8 @@
 describeTok :: Pretty n => Tok n -> String
 describeTok kk
  = case kk of
-        KJunk c         -> "character " ++ show c
+        KErrorJunk c    -> "character " ++ show c
+        KErrorUnterm _  -> "unterminated string"
         KM tm           -> describeTokMeta  tm
         KA ta           -> describeTokAtom  ta
         KN tn           -> describeTokNamed tn
@@ -126,20 +141,19 @@
 --   language fragment.
 data TokAtom
         -----------------------------------------
-        -- Parens
-        = KRoundBra
-        | KRoundKet
-        | KSquareBra
-        | KSquareKet
-        | KBraceBra
-        | KBraceKet
+        -- Single char parenthesis
+        = KRoundBra             -- ^ Like '('
+        | KRoundKet             -- ^ Like ')'
+        | KSquareBra            -- ^ Like '['
+        | KSquareKet            -- ^ Like ']'
+        | KBraceBra             -- ^ Like '{'
+        | KBraceKet             -- ^ Like '}'
 
-        -----------------------------------------
-        -- Compound parens
-        | KSquareColonBra
-        | KSquareColonKet
-        | KBraceColonBra
-        | KBraceColonKet
+        -- Compound parenthesis
+        | KSquareColonBra       -- ^ Like '[:'
+        | KSquareColonKet       -- ^ Like ':]'
+        | KBraceColonBra        -- ^ Like '{:'
+        | KBraceColonKet        -- ^ Like ':}'
 
         -----------------------------------------
         -- Operator symbols
@@ -168,10 +182,14 @@
         | KSemiColon
         | KUnderscore
         | KBackSlash
+        | KEquals
+        | KBar
         
         -----------------------------------------
         -- Compound symbols.
+        | KBigLambdaSlash
         | KBigLambda
+        | KLambda
 
         -----------------------------------------
         -- symbolic constructors
@@ -192,6 +210,7 @@
         | KExport
         | KForeign
         | KType
+        | KCapability
         | KValue
         | KData
         | KWith
@@ -217,12 +236,21 @@
         -- sugar keywords
         | KDo
         | KMatch
+        | KIf
+        | KThen
         | KElse
+        | KOtherwise
 
         -----------------------------------------
         -- debruijn indices
         | KIndex Int
 
+        -- literal strings
+        | KString Text
+
+        -- pragmas
+        | KPragma Text
+
         -----------------------------------------
         -- builtin names 
         --   sort constructors.
@@ -234,9 +262,6 @@
         --   witness type constructors.
         | KTwConBuiltin TwCon
 
-        --   witness constructors.
-        | KWbConBuiltin WbCon
-
         --   other builtin spec constructors.
         | KTcConBuiltin TcCon
 
@@ -280,9 +305,16 @@
         KComma                  -> (Symbol, ",")
         KSemiColon              -> (Symbol, ";")
         KUnderscore             -> (Symbol, "_")
+
         KBackSlash              -> (Symbol, "\\")
-        KBigLambda              -> (Symbol, "/\\")
+        KLambda                 -> (Symbol, "λ")
 
+        KBigLambdaSlash         -> (Symbol, "/\\")
+        KBigLambda              -> (Symbol, "Λ")
+
+        KEquals                 -> (Symbol, "=")
+        KBar                    -> (Symbol, "|")
+
         -- symbolic constructors
         KArrowTilde             -> (Constructor, "~>")
         KArrowDash              -> (Constructor, "->")
@@ -299,6 +331,7 @@
         KExport                 -> (Keyword, "export")
         KForeign                -> (Keyword, "foreign")
         KType                   -> (Keyword, "type")
+        KCapability             -> (Keyword, "capability")
         KValue                  -> (Keyword, "value")
         KData                   -> (Keyword, "data")
         KWith                   -> (Keyword, "with")
@@ -323,16 +356,20 @@
         -- sugar keywords
         KDo                     -> (Keyword, "do")
         KMatch                  -> (Keyword, "match")
+        KIf                     -> (Keyword, "if")
+        KThen                   -> (Keyword, "then")
         KElse                   -> (Keyword, "else")
+        KOtherwise              -> (Keyword, "otherwise")
 
         -- debruijn indices
-        KIndex i                -> (Index,   "^" ++ show i)
+        KIndex  i               -> (Index,   "^" ++ show i)
+        KString s               -> (Literal, show s)
+        KPragma p               -> (Pragma,  "{-#" ++ T.unpack p ++ "#-}")
 
         -- builtin names
         KSoConBuiltin so        -> (Constructor, renderPlain $ ppr so)
         KKiConBuiltin ki        -> (Constructor, renderPlain $ ppr ki)
         KTwConBuiltin tw        -> (Constructor, renderPlain $ ppr tw)
-        KWbConBuiltin wi        -> (Constructor, renderPlain $ ppr wi)
         KTcConBuiltin tc        -> (Constructor, renderPlain $ ppr tc)
         KDaConUnit              -> (Constructor, "()")
         
diff --git a/DDC/Core/Lexer/Unicode.hs b/DDC/Core/Lexer/Unicode.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Lexer/Unicode.hs
@@ -0,0 +1,81 @@
+
+-- | Defines allowable unicode operator symbols.
+--  
+--   We want to allow the use of common operator symbols that most people
+--   can pronounce, but deny the ones that can be confused with others. 
+--
+--   NOTE: We also want to guide client programmers into using unicode
+--   symbols in a sane and friendly way. When we add operator definitions,
+--   setup the syntax so that each operator is naturally given a pronouncable
+--   name.
+--
+--    operator compose ∘    as infix 5
+--    operator union   ∪    as infix 3
+--    operator sqrt    √    as prefix
+--    operator and     ∧ /\ as infix 3
+--
+--   Give up on && and || for logical AND and OR operators.
+--   If we allow ∧ and ∨ then the ASCII version should be /\ and \/.
+--
+--   We could then provide a compiler command to lookup the name and input
+--   information for provided operators.
+--
+module DDC.Core.Lexer.Unicode
+        (unicodeOperatorsInfix)
+where
+import Data.Set                 (Set)
+import qualified Data.Set       as Set
+
+
+-- | Common use of a unicode operator.
+data Use
+        = Denied
+        | Infix
+        | Prefix
+        deriving Show
+
+
+-- | Unicode operators that are used infix.
+unicodeOperatorsInfix :: Set Char
+unicodeOperatorsInfix
+        = Set.fromList
+        $ [c | (c, _, Infix) <- unicodeOperatorTable]
+
+
+-- | Symbols from the Unicode Range 2200-22ff "Mathematical Operators".
+--   From http://www.unicode.org/charts/PDF/U2200.pdf
+--
+--   We restrict the allowable unicode to the common ones that most people
+--   know how to pronounce, that do not conflict with other symbols, 
+--   and that are tradionally used infix.
+--
+unicodeOperatorTable :: [(Char, String, Use)]
+unicodeOperatorTable
+ =      [ -- Set membership
+          ('∈', "element of",                   Infix)  -- U+2208 ok
+        , ('∉', "not an element of",            Infix)  -- U+2209 ok
+--      , ('∊', "small element of",             Infix)  -- U+220a looks like U+2208
+        , ('∋', "contains as member",           Infix)  -- U+220b
+        , ('∌', "does not contain as member",   Infix)  -- U+220c
+--      , ('∍', "small contains as member",     Denied) -- U+220d looks like U+220b 
+
+          -- Operators
+--        ('−', "minus sign",           Denied)         -- U+2212 looks like regular minus
+        , ('∓', "minus-or-plus sign",   Infix)          -- U+2213 ok
+        , ('∔', "dot plus",             Infix)          -- U+2214 ok
+--      , ('∕', "division slash",       Denied)         -- U+2215 looks like fwd slash.
+--      , ('∖', "set minus",            Denied)         -- U+2216 looks like back slash.
+--      , ('∗', "asterix operator",     Denied)         -- U+2217 looks like times
+        , ('∘', "ring operator",        Infix)          -- U+2218 ok
+        , ('∙', "bullet operator",      Infix)          -- U+2219 ok
+        , ('√', "square root",          Prefix)         -- U+221a ok
+        , ('∛', "cube root",            Prefix)         -- U+221b ok
+        , ('∜', "fourth root",          Prefix)         -- U+221c ok
+        , ('∝', "proportional to",      Infix)          -- U+221d ok
+
+        -- Logical and set operators.
+        , ('∧', "logical and",          Infix)          -- U+2227 ok
+        , ('∨', "logical or",           Infix)          -- U+2228 ok
+        , ('∩', "intersection",         Infix)          -- U+2229 ok
+        , ('∪', "union",                Infix)          -- U+222a ok
+        ]
diff --git a/DDC/Core/Load.hs b/DDC/Core/Load.hs
--- a/DDC/Core/Load.hs
+++ b/DDC/Core/Load.hs
@@ -31,7 +31,7 @@
 import DDC.Core.Lexer.Tokens
 import DDC.Core.Check                           (Mode(..), CheckTrace)
 import DDC.Core.Exp
-import DDC.Core.Annot.AnT                       (AnT)
+import DDC.Core.Exp.Annot.AnT                   (AnT)
 import DDC.Type.Transform.SpreadT
 import DDC.Type.Universe
 import DDC.Core.Module
@@ -235,9 +235,9 @@
 
         -- Check the kind of the type.
         goCheckType x
-         = case C.checkExp config kenv tenv x mode of
+         = case C.checkExp config kenv tenv mode C.DemandNone x  of
             (Left err, ct)            -> (Left  (ErrorCheckExp err),  Just ct)
-            (Right (x', _, _, _), ct) -> goCheckCompliance ct x'
+            (Right (x', _, _), ct)    -> goCheckCompliance ct x'
 
         -- Check that the module compiles with the language fragment.
         goCheckCompliance ct x 
diff --git a/DDC/Core/Module.hs b/DDC/Core/Module.hs
--- a/DDC/Core/Module.hs
+++ b/DDC/Core/Module.hs
@@ -3,34 +3,52 @@
         ( -- * Modules
           Module        (..)
         , isMainModule
-	, moduleKindEnv
+        , moduleDataDefs
+        , moduleKindEnv
         , moduleTypeEnv
         , moduleTopBinds
         , moduleTopBindTypes
+        , mapTopBinds
 
-	  -- * Module maps
-	, ModuleMap
-	, modulesExportTypes
-	, modulesExportValues
+          -- * Module maps
+        , ModuleMap
+        , modulesExportTypes
+        , modulesExportValues
 
          -- * Module Names
-        , QualName      (..)
         , ModuleName    (..)
+        , readModuleName
         , isMainModuleName
 
-        -- * Export Sources
+         -- * Qualified names.
+        , QualName      (..)
+
+         -- * Export Definitions
         , ExportSource  (..)
         , takeTypeOfExportSource
         , mapTypeOfExportSource
 
-        -- * Import Sources
-        , ImportSource  (..)
-        , typeOfImportSource
-        , mapTypeOfImportSource)
+         -- * Import Definitions
+         -- ** Import Types
+        , ImportType    (..)
+        , kindOfImportType
+        , mapKindOfImportType
+
+         -- ** Import Capabilities
+        , ImportCap     (..)
+        , typeOfImportCap
+        , mapTypeOfImportCap
+
+         -- ** Import Types
+        , ImportValue   (..)
+        , typeOfImportValue
+        , mapTypeOfImportValue)
 where
-import DDC.Core.Exp
-import DDC.Type.DataDef
-import DDC.Type.Compounds
+import DDC.Core.Module.Export
+import DDC.Core.Module.Import
+import DDC.Core.Module.Name
+import DDC.Core.Exp.Annot
+import DDC.Type.DataDef                 
 import Data.Typeable
 import Data.Map.Strict                  (Map)
 import Data.Set                         (Set)
@@ -46,45 +64,57 @@
 data Module a n
         = ModuleCore
         { -- | Name of this module.
-          moduleName                    :: !ModuleName
+          moduleName            :: !ModuleName
 
+          -- | Whether this is a module header only.
+          --   Module headers contain type definitions, as well as imports and exports, 
+          --   but no function definitions. Module headers are used in interface files.
+        , moduleIsHeader        :: !Bool
+
           -- Exports ------------------
           -- | Kinds of exported types.
-        , moduleExportTypes             :: ![(n, ExportSource n)]
+        , moduleExportTypes     :: ![(n, ExportSource n)]
 
           -- | Types of exported values.
-        , moduleExportValues            :: ![(n, ExportSource n)]
+        , moduleExportValues    :: ![(n, ExportSource n)]
 
           -- Imports ------------------
-          -- | Kinds of imported types,  along with the name of the module they are from.
-          --   These imports come from a Disciple module, that we've compiled ourself.
-        , moduleImportTypes             :: ![(n, ImportSource n)]
+          -- | Define imported types.
+        , moduleImportTypes     :: ![(n, ImportType  n)]
 
-          -- | Types of imported values, along with the name of the module they are from.
-          --   These imports come from a Disciple module, that we've compiled ourself.
-        , moduleImportValues            :: ![(n, ImportSource n)]
+          -- | Define imported capabilities.
+        , moduleImportCaps      :: ![(n, ImportCap n)]
 
-          -- Local --------------------
+          -- | Define imported values.
+        , moduleImportValues    :: ![(n, ImportValue n)]
+
+          -- | Data defs imported from other modules.
+        , moduleImportDataDefs  :: ![DataDef n]
+
+          -- Local defs ---------------
           -- | Data types defined in this module.
-        , moduleDataDefsLocal           :: ![DataDef n]
+        , moduleDataDefsLocal   :: ![DataDef n]
 
           -- | The module body consists of some let-bindings wrapping a unit
           --   data constructor. We're only interested in the bindings, with
           --   the unit being just a place-holder.
-        , moduleBody                    :: !(Exp a n)
+        , moduleBody            :: !(Exp a n)
         }
         deriving (Show, Typeable)
 
 
 instance (NFData a, NFData n) => NFData (Module a n) where
  rnf !mm
-        =     rnf (moduleName mm)
-        `seq` rnf (moduleExportTypes   mm)
-        `seq` rnf (moduleExportValues  mm)
-        `seq` rnf (moduleImportTypes   mm)
-        `seq` rnf (moduleImportValues  mm)
-        `seq` rnf (moduleDataDefsLocal mm)
-        `seq` rnf (moduleBody mm)
+        =     rnf (moduleName           mm)
+        `seq` rnf (moduleIsHeader       mm)
+        `seq` rnf (moduleExportTypes    mm)
+        `seq` rnf (moduleExportValues   mm)
+        `seq` rnf (moduleImportTypes    mm)
+        `seq` rnf (moduleImportCaps     mm)
+        `seq` rnf (moduleImportValues   mm)
+        `seq` rnf (moduleImportDataDefs mm)
+        `seq` rnf (moduleDataDefsLocal  mm)
+        `seq` rnf (moduleBody           mm)
 
 
 -- | Check if this is the `Main` module.
@@ -94,12 +124,19 @@
         $ moduleName mm
 
 
+-- | Get the data type definitions visible in a module.
+moduleDataDefs :: Ord n => Module a n -> DataDefs n
+moduleDataDefs mm
+        = fromListDataDefs 
+        $ (moduleImportDataDefs mm ++ moduleDataDefsLocal mm)
+
+
 -- | Get the top-level kind environment of a module,
 --   from its imported types.
 moduleKindEnv :: Ord n => Module a n -> KindEnv n
 moduleKindEnv mm
         = Env.fromList 
-        $ [BName n (typeOfImportSource isrc) | (n, isrc) <- moduleImportTypes mm]
+        $ [BName n (kindOfImportType isrc) | (n, isrc) <- moduleImportTypes mm]
 
 
 -- | Get the top-level type environment of a module,
@@ -107,7 +144,7 @@
 moduleTypeEnv :: Ord n => Module a n -> TypeEnv n
 moduleTypeEnv mm
         = Env.fromList 
-        $ [BName n (typeOfImportSource isrc) | (n, isrc) <- moduleImportValues mm]
+        $ [BName n (typeOfImportValue isrc) | (n, isrc) <- moduleImportValues mm]
 
 
 -- | Get the set of top-level value bindings in a module.
@@ -142,11 +179,30 @@
                   -> go acc x2
 
                 XLet _ (LRec bxs) x2
-                  -> go (Map.union acc (Map.fromList [(n, t) | BName n t <- map fst bxs])) x2
+                  -> let nts    = Map.fromList [(n, t) | BName n t <- map fst bxs]
+                     in  go (Map.union acc nts) x2
                  
                 _ -> acc
 
 
+-- | Apply a function to all the top-level bindings in a module,
+--   producing a list of the results.
+mapTopBinds :: (Bind n -> Exp a n -> b) -> Module a n -> [b]
+mapTopBinds f mm
+ = go [] (moduleBody mm)
+ where 
+        go acc xx
+         = case xx of
+                XLet _ (LLet b1 x1) x2
+                 -> go (f b1 x1 : acc) x2
+
+                XLet _ (LRec bxs)   x2
+                 -> let rs      = reverse $ map (uncurry f) bxs
+                    in  go (rs ++ acc)  x2
+
+                _ -> reverse acc
+
+
 -- ModuleMap --------------------------------------------------------------------------------------
 -- | Map of module names to modules.
 type ModuleMap a n 
@@ -177,121 +233,4 @@
         liftSnd f (x, y) = (x, f y)
 
    in   Env.unions $ base : (map envOfModule $ Map.elems mods)
-
-
--- ModuleName -------------------------------------------------------------------------------------
--- | A hierarchical module name.
-data ModuleName
-        = ModuleName [String]
-        deriving (Show, Eq, Ord, Typeable)
-
-instance NFData ModuleName where
- rnf (ModuleName ss)
-        = rnf ss
- 
-
--- | A fully qualified name, 
---   including the name of the module it is from.
-data QualName n
-        = QualName ModuleName n
-        deriving Show
-
-instance NFData n => NFData (QualName n) where
- rnf (QualName mn n)
-        = rnf mn `seq` rnf n
-
-
--- | Check whether this is the name of the \"Main\" module.
-isMainModuleName :: ModuleName -> Bool
-isMainModuleName mn
- = case mn of
-        ModuleName ["Main"]     -> True
-        _                       -> False
-
-
--- ExportSource -----------------------------------------------------------------------------------
-data ExportSource n
-        -- | A name defined in this module, with an explicit type.
-        = ExportSourceLocal   
-        { exportSourceLocalName         :: n 
-        , exportSourceLocalType         :: Type n }
-
-        -- | A named defined in this module, without a type attached.
-        --   We use this version for source language where we infer the type of
-        --   the exported thing.
-        | ExportSourceLocalNoType
-        { exportSourceLocalName         :: n }
-        deriving (Show, Eq)
-
-
-instance NFData n => NFData (ExportSource n) where
- rnf es
-  = case es of
-        ExportSourceLocal n t           -> rnf n `seq` rnf t
-        ExportSourceLocalNoType n       -> rnf n
-
-
--- | Take the type of an imported thing, if there is one.
-takeTypeOfExportSource :: ExportSource n -> Maybe (Type n)
-takeTypeOfExportSource es
- = case es of
-        ExportSourceLocal _ t           -> Just t
-        ExportSourceLocalNoType{}       -> Nothing
-
-
--- | Apply a function to any type in an ExportSource.
-mapTypeOfExportSource :: (Type n -> Type n) -> ExportSource n -> ExportSource n
-mapTypeOfExportSource f esrc
- = case esrc of
-        ExportSourceLocal n t           -> ExportSourceLocal n (f t)
-        ExportSourceLocalNoType n       -> ExportSourceLocalNoType n
-
-
--- ImportSource -----------------------------------------------------------------------------------
--- | Source of some imported thing.
-data ImportSource n
-        -- | A type imported abstractly.
-        --   It may be defined in a foreign language, but the Disciple program
-        --   treats it abstractly.
-        = ImportSourceAbstract
-        { importSourceAbstractType      :: Type n }
-
-        -- | Something imported from a Disciple module that we compiled ourself.
-        | ImportSourceModule
-        { importSourceModuleName        :: ModuleName 
-        , importSourceModuleVar         :: n 
-        , importSourceModuleType        :: Type n }
-
-        -- | Something imported via the C calling convention.
-        | ImportSourceSea
-        { importSourceSeaVar            :: String 
-        , importSourceSeaType           :: Type n }
-        deriving (Show, Eq)
-
-
-instance NFData n => NFData (ImportSource n) where
- rnf is
-  = case is of
-        ImportSourceAbstract t          -> rnf t
-        ImportSourceModule mn n t       -> rnf mn `seq` rnf n `seq` rnf t
-        ImportSourceSea v t             -> rnf v  `seq` rnf t
-
-
--- | Take the type of an imported thing.
-typeOfImportSource :: ImportSource n -> Type n
-typeOfImportSource src
- = case src of
-        ImportSourceAbstract   t        -> t
-        ImportSourceModule _ _ t        -> t
-        ImportSourceSea      _ t        -> t
-
-
--- | Apply a function to the type in an ImportSource.
-mapTypeOfImportSource :: (Type n -> Type n) -> ImportSource n -> ImportSource n
-mapTypeOfImportSource f isrc
- = case isrc of
-        ImportSourceAbstract  t         -> ImportSourceAbstract (f t)
-        ImportSourceModule mn n t       -> ImportSourceModule mn n (f t)
-        ImportSourceSea s t             -> ImportSourceSea s (f t)
-
 
diff --git a/DDC/Core/Module/Export.hs b/DDC/Core/Module/Export.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Module/Export.hs
@@ -0,0 +1,47 @@
+
+module DDC.Core.Module.Export
+        ( ExportSource  (..)
+        , takeTypeOfExportSource
+        , mapTypeOfExportSource)
+where
+import DDC.Type.Exp
+import Control.DeepSeq
+
+
+-- | Define thing exported from a module.
+data ExportSource n
+        -- | A name defined in this module, with an explicit type.
+        = ExportSourceLocal   
+        { exportSourceLocalName         :: n 
+        , exportSourceLocalType         :: Type n }
+
+        -- | A named defined in this module, without a type attached.
+        --   We use this version for source language where we infer the type of
+        --   the exported thing.
+        | ExportSourceLocalNoType
+        { exportSourceLocalName         :: n }
+        deriving Show
+
+
+instance NFData n => NFData (ExportSource n) where
+ rnf es
+  = case es of
+        ExportSourceLocal n t           -> rnf n `seq` rnf t
+        ExportSourceLocalNoType n       -> rnf n
+
+
+-- | Take the type of an imported thing, if there is one.
+takeTypeOfExportSource :: ExportSource n -> Maybe (Type n)
+takeTypeOfExportSource es
+ = case es of
+        ExportSourceLocal _ t           -> Just t
+        ExportSourceLocalNoType{}       -> Nothing
+
+
+-- | Apply a function to any type in an ExportSource.
+mapTypeOfExportSource :: (Type n -> Type n) -> ExportSource n -> ExportSource n
+mapTypeOfExportSource f esrc
+ = case esrc of
+        ExportSourceLocal n t           -> ExportSourceLocal n (f t)
+        ExportSourceLocalNoType n       -> ExportSourceLocalNoType n
+
diff --git a/DDC/Core/Module/Import.hs b/DDC/Core/Module/Import.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Module/Import.hs
@@ -0,0 +1,157 @@
+
+module DDC.Core.Module.Import
+        ( -- * Imported types
+          ImportType    (..)
+        , kindOfImportType
+        , mapKindOfImportType
+
+          -- * Imported capabilities
+        , ImportCap (..)
+        , typeOfImportCap
+        , mapTypeOfImportCap
+
+          -- * Imported values
+        , ImportValue   (..)
+        , typeOfImportValue
+        , mapTypeOfImportValue)
+where
+import DDC.Core.Module.Name
+import DDC.Type.Exp
+import Control.DeepSeq
+
+
+-- ImportType -------------------------------------------------------------------------------------
+-- | Define a foreign type being imported into a module.
+data ImportType n
+        -- | Type imported abstractly.
+        --
+        --   Used for phantom types of kind Data, as well as regions, effects,
+        --   and any other type that does not have kind Data. When a type is
+        --   imported abstractly it has no associated values, so we can just
+        --   say that we have the type without worrying about how to represent
+        --   its associated values.
+        --
+        = ImportTypeAbstract
+        { importTypeAbstractType      :: !(Kind n) }
+
+        -- | Type of some boxed data.
+        --
+        --   The objects follow the standard heap object layout, but the code
+        --   that constructs and destructs them may have been written in a 
+        --   different language.
+        --
+        --   This is used when importing data types defined in Salt modules.
+        --
+        | ImportTypeBoxed
+        { importTypeBoxed             :: !(Kind n) }
+        deriving Show
+
+
+instance NFData n => NFData (ImportType n) where
+ rnf is
+  = case is of
+        ImportTypeAbstract k            -> rnf k
+        ImportTypeBoxed    k            -> rnf k
+
+
+-- | Take the kind of an `ImportType`.
+kindOfImportType :: ImportType n -> Kind n
+kindOfImportType src
+ = case src of
+        ImportTypeAbstract k            -> k
+        ImportTypeBoxed    k            -> k
+
+
+-- | Apply a function to the kind of an `ImportType`
+mapKindOfImportType :: (Kind n -> Kind n) -> ImportType n -> ImportType n
+mapKindOfImportType f isrc
+ = case isrc of
+        ImportTypeAbstract k            -> ImportTypeAbstract (f k)
+        ImportTypeBoxed    k            -> ImportTypeBoxed    (f k)
+
+
+-- ImportCapability -------------------------------------------------------------------------------
+-- | Define a foreign capability being imported into a module.
+data ImportCap n
+        -- | Capability imported abstractly.
+        --   For capabilities like (Read r) for some top-level region r
+        --   we can just say that we have the capability.
+        = ImportCapAbstract
+        { importCapAbstractType  :: !(Type n) }
+        deriving Show
+
+
+instance NFData n => NFData (ImportCap n) where
+ rnf ii
+  = case ii of
+        ImportCapAbstract t     -> rnf t
+
+
+-- | Take the type of an `ImportCap`.
+typeOfImportCap :: ImportCap n -> Type n
+typeOfImportCap ii
+ = case ii of
+        ImportCapAbstract t     -> t
+
+
+-- | Apply a function to the type in an `ImportCapability`.
+mapTypeOfImportCap :: (Type n -> Type n) -> ImportCap n -> ImportCap n
+mapTypeOfImportCap f ii
+ = case ii of
+        ImportCapAbstract t     -> ImportCapAbstract (f t)
+
+
+-- ImportValue ------------------------------------------------------------------------------------
+-- | Define a foreign value being imported into a module.
+data ImportValue n
+        -- | Value imported from a module that we compiled ourselves.
+        = ImportValueModule
+        { -- | Name of the module that we're importing from.
+          importValueModuleName        :: !ModuleName 
+
+          -- | Name of the the value that we're importing.
+        , importValueModuleVar         :: !n 
+
+          -- | Type of the value that we're importing.
+        , importValueModuleType        :: !(Type n)
+
+          -- | Calling convention for this value,
+          --   including the number of type parameters, value parameters, and boxings.
+        , importValueModuleArity       :: !(Maybe (Int, Int, Int)) }
+
+        -- | Value imported via the C calling convention.
+        | ImportValueSea
+        { -- | Name of the symbol being imported. 
+          --   This can be different from the name that we give it in the core language.
+          importValueSeaVar            :: !String 
+
+          -- | Type of the value that we're importing.
+        , importValueSeaType           :: !(Type n) }
+        deriving Show
+
+
+instance NFData n => NFData (ImportValue n) where
+ rnf is
+  = case is of
+        ImportValueModule mn n t mAV 
+         -> rnf mn `seq` rnf n `seq` rnf t `seq` rnf mAV
+
+        ImportValueSea v t
+         -> rnf v  `seq` rnf t
+
+
+-- | Take the type of an imported thing.
+typeOfImportValue :: ImportValue n -> Type n
+typeOfImportValue src
+ = case src of
+        ImportValueModule _ _ t _       -> t
+        ImportValueSea      _ t         -> t
+
+
+-- | Apply a function to the type in an ImportValue.
+mapTypeOfImportValue :: (Type n -> Type n) -> ImportValue n -> ImportValue n
+mapTypeOfImportValue f isrc
+ = case isrc of
+        ImportValueModule mn n t a      -> ImportValueModule mn n (f t) a
+        ImportValueSea s t              -> ImportValueSea s (f t)
+
diff --git a/DDC/Core/Module/Name.hs b/DDC/Core/Module/Name.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Module/Name.hs
@@ -0,0 +1,57 @@
+
+module DDC.Core.Module.Name
+        ( ModuleName    (..)
+        , readModuleName
+        , isMainModuleName
+
+        , QualName      (..))
+where
+import Data.Typeable
+import Control.DeepSeq
+
+
+-- ModuleName -------------------------------------------------------------------------------------
+-- | A hierarchical module name.
+data ModuleName
+        = ModuleName [String]
+        deriving (Show, Eq, Ord, Typeable)
+
+instance NFData ModuleName where
+ rnf (ModuleName ss)
+        = rnf ss
+
+
+-- | Read a string like 'M1.M2.M3' as a module name.
+readModuleName :: String -> Maybe ModuleName
+readModuleName []       = Nothing
+readModuleName str
+ = Just $ ModuleName $ go str
+ where
+        go s
+         | elem '.' s
+         , (n, '.' : rest)      <- span (/= '.') s
+         = n : go rest
+
+         | otherwise
+         = [s]
+
+
+-- | Check whether this is the name of the \"Main\" module.
+isMainModuleName :: ModuleName -> Bool
+isMainModuleName mn
+ = case mn of
+        ModuleName ["Main"]     -> True
+        _                       -> False
+
+
+-- QualName ---------------------------------------------------------------------------------------
+-- | A fully qualified name, 
+--   including the name of the module it is from.
+data QualName n
+        = QualName ModuleName n
+        deriving Show
+
+instance NFData n => NFData (QualName n) where
+ rnf (QualName mn n)
+        = rnf mn `seq` rnf n
+
diff --git a/DDC/Core/Parser.hs b/DDC/Core/Parser.hs
--- a/DDC/Core/Parser.hs
+++ b/DDC/Core/Parser.hs
@@ -31,8 +31,9 @@
         , pWitnessAtom
 
           -- * Constructors
-        , pCon, pConSP
-        , pLit, pLitSP
+        , pCon,         pConSP
+        , pLit,         pLitSP
+        , pString,      pStringSP
 
           -- * Variables
         , pIndex,       pIndexSP
diff --git a/DDC/Core/Parser/Base.hs b/DDC/Core/Parser/Base.hs
--- a/DDC/Core/Parser/Base.hs
+++ b/DDC/Core/Parser/Base.hs
@@ -4,40 +4,52 @@
         , pModuleName
         , pQualName
         , pName
-        , pWbCon,       pWbConSP
         , pCon,         pConSP
         , pLit,         pLitSP
+        , pString,      pStringSP
         , pIndex,       pIndexSP
-        , pVar,         pVarSP
+        , pVar,         pVarSP,         pVarNamedSP
         , pTok,         pTokSP
         , pTokAs,       pTokAsSP
         , pOpSP
-        , pOpVarSP)
+        , pOpVarSP
+        , pPragmaSP)
 where
 import DDC.Base.Pretty
 import DDC.Core.Module
-import DDC.Core.Exp
 import DDC.Core.Lexer.Tokens
 import DDC.Base.Parser                  ((<?>), SourcePos)
+import Data.Text                        (Text)
 import qualified DDC.Base.Parser        as P
 
-
 -- | A parser of core language tokens.
 type Parser n a
         = P.Parser (Tok n) a
 
 
 -- | Parse a module name.                               
---   
----  ISSUE #273: Handle hierarchical module names.
---      Accept hierachical names, and reject hashes at the end of a name.
---      Hashes can be at the end of constructor name, but not module names.
 pModuleName :: Pretty n => Parser n ModuleName
-pModuleName = P.pTokMaybe f
- where  f (KN (KCon n)) = Just $ ModuleName [renderPlain $ ppr n]
-        f _             = Nothing
+pModuleName 
+ = do   ms      <- P.sepBy1 pModuleName1 (pTok KDot)
+        return  $  ModuleName 
+                $  concat
+                $  map (\(ModuleName ss) -> ss) ms
 
 
+-- | Parse a single component module name.
+pModuleName1 :: Pretty n => Parser n ModuleName
+pModuleName1 = P.pTokMaybe f
+ where  f (KN (KCon n))           = Just $ ModuleName [ renderPlain $ ppr n ]
+
+        -- These names are lexed as constructors
+        -- but can be part of a module name.
+        f (KA (KSoConBuiltin c))  = Just $ ModuleName [ renderPlain $ ppr c ]
+        f (KA (KKiConBuiltin c))  = Just $ ModuleName [ renderPlain $ ppr c ]
+        f (KA (KTwConBuiltin c))  = Just $ ModuleName [ renderPlain $ ppr c ]
+        f (KA (KTcConBuiltin c))  = Just $ ModuleName [ renderPlain $ ppr c ]
+        f _                       = Nothing
+
+
 -- | Parse a qualified variable or constructor name.
 pQualName :: Pretty n => Parser n (QualName n)
 pQualName
@@ -52,20 +64,6 @@
 pName   = P.choice [pCon, pVar]
 
 
--- | Parse a builtin named `WbCon`
-pWbCon :: Parser n WbCon
-pWbCon  = P.pTokMaybe f
- where  f (KA (KWbConBuiltin wb)) = Just wb
-        f _                       = Nothing
-
-
--- | Parse a builtin named `WbCon`
-pWbConSP :: Parser n (WbCon, SourcePos)
-pWbConSP = P.pTokMaybeSP f
- where  f (KA (KWbConBuiltin wb)) = Just wb
-        f _                       = Nothing
-
-
 -- | Parse a constructor name.
 pCon    :: Parser n n
 pCon    = P.pTokMaybe f
@@ -87,13 +85,27 @@
         f _             = Nothing
 
 
--- | Parse a literal, with source position.
+-- | Parse a numeric literal, with source position.
 pLitSP :: Parser n (n, SourcePos)
 pLitSP  = P.pTokMaybeSP f
- where  f (KN (KLit n)) = Just n
-        f _             = Nothing
+ where  f (KN (KLit n))    = Just n
+        f _                = Nothing
 
 
+-- | Parse a literal.
+pString :: Parser n Text
+pString    = P.pTokMaybe f
+ where  f (KA (KString tx)) = Just tx
+        f _                 = Nothing
+
+
+-- | Parse a literal string, with source position.
+pStringSP :: Parser n (Text, SourcePos)
+pStringSP  = P.pTokMaybeSP f
+ where  f (KA (KString tx)) = Just tx
+        f _                 = Nothing
+
+
 -- | Parse a variable.
 pVar :: Parser n n
 pVar    =   P.pTokMaybe f
@@ -110,6 +122,14 @@
         f _                     = Nothing
 
 
+-- | Parse a variable of a specific name, with its source position.
+pVarNamedSP :: String -> Parser String SourcePos
+pVarNamedSP str 
+        = fmap snd (P.pTokMaybeSP f <?> "a variable")
+ where  f (KN (KVar n)) | n == str = Just n
+        f _                        = Nothing
+
+
 -- | Parse a deBruijn index.
 pIndex :: Parser n Int
 pIndex  =   P.pTokMaybe f
@@ -138,6 +158,13 @@
 pOpVarSP = P.pTokMaybeSP f
  where  f (KA (KOpVar str))  = Just str
         f _                  = Nothing
+
+
+-- | Parse a pragma.
+pPragmaSP :: Parser n (Text, SourcePos)
+pPragmaSP = P.pTokMaybeSP f
+ where  f (KA (KPragma txt))  = Just txt
+        f _                   = Nothing
 
 
 -- | Parse an atomic token.
diff --git a/DDC/Core/Parser/Context.hs b/DDC/Core/Parser/Context.hs
--- a/DDC/Core/Parser/Context.hs
+++ b/DDC/Core/Parser/Context.hs
@@ -4,20 +4,22 @@
         , contextOfProfile)
 where
 import DDC.Core.Fragment
-
+import DDC.Data.SourcePos
+import Data.Text                        (Text)
 
 -- | Configuration and information from the context. 
 --   Used for context sensitive parsing.
-data Context
+data Context n
         = Context
         { contextTrackedEffects         :: Bool 
         , contextTrackedClosures        :: Bool
         , contextFunctionalEffects      :: Bool
-        , contextFunctionalClosures     :: Bool }
+        , contextFunctionalClosures     :: Bool 
+        , contextMakeStringName         :: Maybe (SourcePos -> Text -> n) }
 
 
 -- | Slurp an initital `Context` from a language `Profile`.
-contextOfProfile :: Profile n -> Context
+contextOfProfile :: Profile n -> Context n
 contextOfProfile profile
         = Context
         { contextTrackedEffects         = featuresTrackedEffects
@@ -31,4 +33,6 @@
 
         , contextFunctionalClosures     = featuresFunctionalClosures
                                         $ profileFeatures profile
+
+        , contextMakeStringName         = profileMakeStringName profile
         }
diff --git a/DDC/Core/Parser/DataDef.hs b/DDC/Core/Parser/DataDef.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Parser/DataDef.hs
@@ -0,0 +1,83 @@
+
+module DDC.Core.Parser.DataDef
+        ( DataDef    (..)
+        , pDataDef)
+where
+import DDC.Core.Exp.Annot
+import DDC.Core.Parser.Type
+import DDC.Core.Parser.Context
+import DDC.Core.Parser.Base
+import DDC.Core.Lexer.Tokens
+import DDC.Type.DataDef
+import Control.Monad
+import qualified DDC.Base.Parser        as P
+
+
+pDataDef :: Ord n => Context n -> Parser n (DataDef n)
+pDataDef c
+ = do   pTokSP KData
+        nData   <- pName 
+        bsParam <- liftM concat $ P.many (pDataParam c)
+
+        P.choice
+         [ -- Data declaration with constructors that have explicit types.
+           do   pTok KWhere
+                pTok KBraceBra
+                ctors      <- P.sepEndBy1 (pDataCtor c nData bsParam) (pTok KSemiColon)
+                let ctors' = [ ctor { dataCtorTag = tag }
+                                | ctor <- ctors
+                                | tag  <- [0..] ]
+                pTok KBraceKet
+                return  $ DataDef 
+                        { dataDefTypeName       = nData
+                        , dataDefParams         = bsParam 
+                        , dataDefCtors          = Just ctors'
+                        , dataDefIsAlgebraic    = True }
+         
+           -- Data declaration with no data constructors.
+         , do   return  $ DataDef 
+                        { dataDefTypeName       = nData
+                        , dataDefParams         = bsParam
+                        , dataDefCtors          = Just []
+                        , dataDefIsAlgebraic    = True }
+
+         ]
+
+
+-- | Parse a type parameter to a data type.
+pDataParam :: Ord n => Context n -> Parser n [Bind n]
+pDataParam c 
+ = do   pTok KRoundBra
+        ns      <- P.many1 pName
+        pTokSP (KOp ":")
+        k       <- pType c
+        pTok KRoundKet
+        return  [BName n k | n <- ns]
+
+
+-- | Parse a data constructor declaration.
+pDataCtor 
+        :: Ord n 
+        => Context n
+        -> n                    -- ^ Name of data type constructor.
+        -> [Bind n]             -- ^ Type parameters of data type constructor.
+        -> Parser n (DataCtor n)
+
+pDataCtor c nData bsParam
+ = do   n       <- pName
+        pTokSP (KOp ":")
+        t       <- pType c
+        let (tsArg, tResult)    
+                = takeTFunArgResult t
+
+        return  $ DataCtor
+                { dataCtorName          = n
+
+                -- Set tag to 0 for now. We fix this up in pDataDef above.
+                , dataCtorTag           = 0
+                
+                , dataCtorFieldTypes    = tsArg
+                , dataCtorResultType    = tResult 
+                , dataCtorTypeName      = nData 
+                , dataCtorTypeParams    = bsParam }
+
diff --git a/DDC/Core/Parser/Exp.hs b/DDC/Core/Parser/Exp.hs
--- a/DDC/Core/Parser/Exp.hs
+++ b/DDC/Core/Parser/Exp.hs
@@ -9,36 +9,35 @@
         , pTypeApp
         , pTypeAtom)
 where
-import DDC.Core.Exp
+import DDC.Core.Exp.Annot
 import DDC.Core.Parser.Witness
 import DDC.Core.Parser.Param
 import DDC.Core.Parser.Type
 import DDC.Core.Parser.Context
 import DDC.Core.Parser.Base
 import DDC.Core.Lexer.Tokens
-import DDC.Core.Compounds
 import DDC.Base.Parser                  ((<?>), SourcePos)
 import qualified DDC.Base.Parser        as P
 import qualified DDC.Type.Compounds     as T
-import Control.Monad.Error
+import Control.Monad.Except
 
 
 -- Exp --------------------------------------------------------------------------------------------
 -- | Parse a core language expression.
-pExp    :: Ord n => Context -> Parser n (Exp SourcePos n)
+pExp    :: Ord n => Context n -> Parser n (Exp SourcePos n)
 pExp c
  = P.choice
         -- Level-0 lambda abstractions
-        -- \BIND.. . EXP
- [ do   sp      <- pTokSP KBackSlash
+        -- (λBIND.. . EXP) or (\BIND.. . EXP)
+ [ do   sp      <- P.choice [ pTokSP KLambda,    pTokSP KBackSlash]
         bs      <- liftM concat $ P.many1 (pBinds c)
         pTok KDot
         xBody   <- pExp c
         return  $ foldr (XLam sp) xBody bs
 
         -- Level-1 lambda abstractions.
-        -- /\BINDS.. . EXP
- , do   sp      <- pTokSP KBigLambda
+        -- (ΛBINDS.. . EXP) or (/\BIND.. . EXP)
+ , do   sp      <- P.choice [ pTokSP KBigLambda, pTokSP KBigLambdaSlash] 
         bs      <- liftM concat $ P.many1 (pBinds c)
         pTok KDot
         xBody   <- pExp c
@@ -58,18 +57,6 @@
         pTok    KBraceKet
         return  $ xx
 
-        -- withregion CON in EXP
- , do   sp      <- pTokSP KWithRegion
-        u       <- P.choice 
-                [  do   n    <- pVar
-                        return $ UName n
-
-                ,  do   n    <- pCon
-                        return $ UPrim n kRegion]
-        pTok KIn
-        x       <- pExp c
-        return  $ XLet sp (LWithRegion u) x
-
         -- case EXP of { ALTS }
  , do   sp      <- pTokSP KCase
         x       <- pExp c
@@ -83,24 +70,12 @@
  , do   --  Sugar for a single-alternative case expression.
         sp      <- pTokSP KLetCase
         p       <- pPat c
-        pTok (KOp "=")
+        pTok KEquals
         x1      <- pExp c
         pTok KIn
         x2      <- pExp c
         return  $ XCase sp x1 [AAlt p x2]
 
-        -- match PAT <- EXP else EXP in EXP
-        --  Sugar for a case-expression.
- , do   sp      <- pTokSP KMatch
-        p       <- pPat c
-        pTok KArrowDashLeft
-        x1      <- pExp c
-        pTok KElse
-        x2      <- pExp c
-        pTok KIn
-        x3      <- pExp c
-        return  $ XCase sp x1 [AAlt p x3, AAlt PDefault x2]
-
         -- weakeff [TYPE] in EXP
  , do   sp      <- pTokSP KWeakEff
         pTok KSquareBra
@@ -110,16 +85,6 @@
         x       <- pExp c
         return  $ XCast sp (CastWeakenEffect t) x
 
-        -- weakclo {EXP;+} in EXP
- , do   sp      <- pTokSP KWeakClo
-        pTok KBraceBra
-        xs      <- liftM (map fst . concat) 
-                $  P.sepEndBy1 (pArgSPs c) (pTok KSemiColon)
-        pTok KBraceKet
-        pTok KIn
-        x       <- pExp c
-        return  $ XCast sp (CastWeakenClosure xs) x
-
         -- purify WITNESS in EXP
  , do   sp      <- pTokSP KPurify
         w       <- pWitness c
@@ -127,13 +92,6 @@
         x       <- pExp c
         return  $ XCast sp (CastPurify w) x
 
-        -- forget WITNESS in EXP
- , do   sp      <- pTokSP KForget
-        w       <- pWitness c
-        pTok KIn
-        x       <- pExp c
-        return  $ XCast sp (CastForget w) x
-
         -- box EXP
  , do   sp      <- pTokSP KBox
         x       <- pExp c
@@ -152,7 +110,7 @@
 
 
 -- | Parse a function application.
-pExpApp :: Ord n => Context -> Parser n (Exp SourcePos n)
+pExpApp :: Ord n => Context n -> Parser n (Exp SourcePos n)
 pExpApp c
   = do  (x1, _)        <- pExpAtomSP c
         
@@ -166,7 +124,7 @@
 
 
 -- Comp, Witness or Spec arguments.
-pArgSPs :: Ord n => Context -> Parser n [(Exp SourcePos n, SourcePos)]
+pArgSPs :: Ord n => Context n -> Parser n [(Exp SourcePos n, SourcePos)]
 pArgSPs c
  = P.choice
         -- [TYPE]
@@ -201,7 +159,7 @@
 
 
 -- | Parse a variable, constructor or parenthesised expression.
-pExpAtom   :: Ord n => Context -> Parser n (Exp SourcePos n)
+pExpAtom   :: Ord n => Context n -> Parser n (Exp SourcePos n)
 pExpAtom c
  = do   (x, _) <- pExpAtomSP c
         return x
@@ -211,7 +169,7 @@
 --   also returning source position.
 pExpAtomSP 
         :: Ord n 
-        => Context 
+        => Context n 
         -> Parser n (Exp SourcePos n, SourcePos)
 
 pExpAtomSP c
@@ -236,6 +194,11 @@
  , do   (lit, sp)       <- pLitSP
         return  (XCon sp (DaConPrim lit (T.tBot T.kData)), sp)
 
+ , do   (tx, sp)        <- pStringSP
+        let Just mkString = contextMakeStringName c
+        let lit           = mkString sp tx
+        return  (XCon sp (DaConPrim lit (T.tBot T.kData)), sp)
+
         -- Debruijn indices
  , do   (i, sp)         <- pIndexSP
         return  (XVar sp (UIx   i), sp)
@@ -250,7 +213,7 @@
 
 -- Alt --------------------------------------------------------------------------------------------
 -- Case alternatives.
-pAlt    :: Ord n => Context -> Parser n (Alt SourcePos n)
+pAlt    :: Ord n => Context n -> Parser n (Alt SourcePos n)
 pAlt c
  = do   p       <- pPat c
         pTok KArrowDash
@@ -260,7 +223,7 @@
 
 -- Patterns.
 pPat    :: Ord n 
-        => Context -> Parser n (Pat n)
+        => Context n -> Parser n (Pat n)
 pPat c
  = P.choice
  [      -- Wildcard
@@ -287,7 +250,7 @@
 -- or can have an annotation if the whole thing is in parens.
 pBinds
         :: Ord n 
-        => Context -> Parser n [Bind n]
+        => Context n -> Parser n [Bind n]
 pBinds c
  = P.choice
         -- Plain binder.
@@ -308,7 +271,7 @@
 -- | Parse some `Lets`, also returning the source position where they
 --   started.
 pLetsSP :: Ord n 
-        => Context -> Parser n (Lets SourcePos n, SourcePos)
+        => Context n -> Parser n (Lets SourcePos n, SourcePos)
 pLetsSP c
  = P.choice
     [ -- non-recursive let.
@@ -366,7 +329,7 @@
     
     
 pLetWits :: Ord n 
-        => Context 
+        => Context n
         -> [Bind n] -> Maybe (Type n) 
         -> Parser n (Lets SourcePos n)
 
@@ -395,7 +358,7 @@
 -- | A binding for let expression.
 pLetBinding 
         :: Ord n 
-        => Context
+        => Context n
         -> Parser n ( Bind n
                     , Exp SourcePos n)
 pLetBinding c
@@ -406,7 +369,7 @@
                 --  BINDER : TYPE = EXP
                 pTok (KOp ":")
                 t       <- pType c
-                pTok (KOp "=")
+                pTok KEquals
                 xBody   <- pExp c
 
                 return  $ (T.makeBindFromBinder b t, xBody) 
@@ -416,7 +379,7 @@
                 -- This form can't be used with letrec as we can't use it
                 -- to build the full type sig for the let-bound variable.
                 --  BINDER = EXP
-                pTok (KOp "=")
+                pTok KEquals
                 xBody   <- pExp c
                 let t   = T.tBot T.kData
                 return  $ (T.makeBindFromBinder b t, xBody)
@@ -433,7 +396,7 @@
                         --   BINDER PARAM1 PARAM2 .. PARAMN : TYPE = EXP
                         pTok (KOp ":")
                         tBody   <- pType c
-                        sp      <- pTokSP (KOp "=")
+                        sp      <- pTokSP KEquals
                         xBody   <- pExp c
 
                         let x   = expOfParams sp ps xBody
@@ -445,7 +408,7 @@
                         -- but we can create lambda abstractions with the given 
                         -- parameter types.
                         --  BINDER PARAM1 PARAM2 .. PARAMN = EXP
-                 , do   sp      <- pTokSP (KOp "=")
+                 , do   sp      <- pTokSP KEquals
                         xBody   <- pExp c
 
                         let x   = expOfParams sp ps xBody
@@ -462,7 +425,7 @@
 
 
 -- | Parse a single statement.
-pStmt :: Ord n => Context -> Parser n (Stmt n)
+pStmt :: Ord n => Context n -> Parser n (Stmt n)
 pStmt c
  = P.choice
  [ -- BINDER = EXP ;
@@ -471,7 +434,7 @@
    --  
    P.try $ 
     do  br      <- pBinder
-        sp      <- pTokSP (KOp "=")
+        sp      <- pTokSP KEquals
         x1      <- pExp c
         let t   = T.tBot T.kData
         let b   = T.makeBindFromBinder br t
@@ -496,7 +459,7 @@
 
 
 -- | Parse some statements.
-pStmts :: Ord n => Context -> Parser n (Exp SourcePos n)
+pStmts :: Ord n => Context n -> Parser n (Exp SourcePos n)
 pStmts c
  = do   stmts   <- P.sepEndBy1 (pStmt c) (pTok KSemiColon)
         case makeStmts stmts of
diff --git a/DDC/Core/Parser/ExportSpec.hs b/DDC/Core/Parser/ExportSpec.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Parser/ExportSpec.hs
@@ -0,0 +1,78 @@
+
+module DDC.Core.Parser.ExportSpec
+        ( ExportSpec    (..)
+        , pExportSpecs)
+where
+import DDC.Core.Module
+import DDC.Core.Parser.Type
+import DDC.Core.Parser.Context
+import DDC.Core.Parser.Base
+import DDC.Core.Lexer.Tokens
+import DDC.Base.Pretty
+import Control.Monad
+import qualified DDC.Base.Parser        as P
+
+
+-- An exported thing.
+data ExportSpec n
+        = ExportValue   n (ExportSource n)
+
+
+-- | Parse some export specifications.
+pExportSpecs
+        :: (Ord n, Pretty n)
+        => Context n -> Parser n [ExportSpec n]
+
+pExportSpecs c
+ = do   pTok KExport
+
+        P.choice 
+         [      -- export value { (NAME :: TYPE)+ }
+           do   P.choice [ pTok KValue, return () ]
+                pTok KBraceBra
+                specs   <- P.sepEndBy1 (pExportValue c) (pTok KSemiColon)
+                pTok KBraceKet 
+                return specs
+
+                -- export foreign X value { (NAME :: TYPE)+ }
+         , do   pTok KForeign
+                dst     <- liftM (renderIndent . ppr) pName
+                pTok KValue
+                pTok KBraceBra
+                specs   <- P.sepEndBy1 (pExportForeignValue c dst) (pTok KSemiColon)
+                pTok KBraceKet
+                return specs
+         ]
+
+
+-- | Parse an export specification.
+pExportValue
+        :: (Ord n, Pretty n)
+        => Context n -> Parser n (ExportSpec n)
+
+pExportValue c 
+ = do   
+        n       <- pName
+        pTokSP (KOp ":")
+        t       <- pType c
+        return  (ExportValue n (ExportSourceLocal n t))
+
+
+-- | Parse a foreign value export spec.
+pExportForeignValue    
+        :: (Ord n, Pretty n)
+        => Context n -> String -> Parser n (ExportSpec n)
+
+pExportForeignValue c dst
+        | "c"           <- dst
+        = do    n       <- pName
+                pTokSP (KOp ":")
+                k       <- pType c
+
+                -- ISSUE #327: Allow external symbol to be specified 
+                --             with foreign C imports and exports.
+                return  (ExportValue n (ExportSourceLocal n k))
+
+        | otherwise
+        = P.unexpected "export mode for foreign value."
+
diff --git a/DDC/Core/Parser/ImportSpec.hs b/DDC/Core/Parser/ImportSpec.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Parser/ImportSpec.hs
@@ -0,0 +1,170 @@
+
+module DDC.Core.Parser.ImportSpec
+        ( ImportSpec    (..)
+        , pImportSpecs)
+where
+import DDC.Core.Module
+import DDC.Core.Parser.Type
+import DDC.Core.Parser.Context
+import DDC.Core.Parser.Base
+import DDC.Core.Parser.DataDef
+import DDC.Core.Lexer.Tokens
+import DDC.Base.Pretty
+import Control.Monad
+import qualified DDC.Base.Parser        as P
+
+
+---------------------------------------------------------------------------------------------------
+-- | An imported thing.
+--
+--   During parsing the specifications of all imported things are bundled
+--   into this common type. The caller can split them out into separate 
+--   buckets if it wants to.
+--
+data ImportSpec n
+        = ImportType    n (ImportType   n)
+        | ImportCap     n (ImportCap    n)
+        | ImportValue   n (ImportValue  n)
+        | ImportData    (DataDef n)
+        deriving Show
+        
+
+-- | Parse some import specifications.
+pImportSpecs
+        :: (Ord n, Pretty n)
+        => Context n -> Parser n [ImportSpec n]
+
+pImportSpecs c
+ = do   
+        -- import ...
+        pTok KImport
+
+        P.choice
+         [      -- data ...
+           do   def     <- pDataDef c
+                return  [ ImportData def ]
+
+                -- import value { (NAME :: TYPE)+ }
+         , do   P.choice [ pTok KValue, return () ]
+                pTok KBraceBra
+                specs   <- P.sepEndBy1 (pImportValue c) (pTok KSemiColon)
+                pTok KBraceKet
+                return specs
+
+                -- foreign ...
+         , do   pTok KForeign
+                src     <- liftM (renderIndent . ppr) pName
+
+                P.choice
+                 [      -- import foreign MODE type { (NAME : TYPE)+ }
+                  do    pTok KType
+                        pTok KBraceBra
+                        sigs <- P.sepEndBy1 (pImportForeignType c src) (pTok KSemiColon)
+                        pTok KBraceKet
+                        return sigs
+        
+                        -- import foreign MODE capability { (NAME : TYPE)+ }
+                 , do   pTok KCapability
+                        pTok KBraceBra
+                        sigs <- P.sepEndBy1 (pImportForeignCap c src) (pTok KSemiColon)
+                        pTok KBraceKet
+                        return sigs
+
+                        -- import foreign MODE value { (NAME : TYPE)+ }
+                 , do   pTok KValue
+                        pTok KBraceBra
+                        sigs <- P.sepEndBy1 (pImportForeignValue c src) (pTok KSemiColon)
+                        pTok KBraceKet
+                        return sigs
+                 ]
+         ]
+         P.<?> "something to import"
+
+
+---------------------------------------------------------------------------------------------------
+-- | Parse a foreign type import specification.
+pImportForeignType
+        :: (Ord n, Pretty n) 
+        => Context n -> String -> Parser n (ImportSpec n)
+
+pImportForeignType c src
+
+        -- Abstract types are not associated with data values,
+        -- they can be used as phantom type parameters, 
+        -- or have a kind of something that is not Data.
+        | "abstract"    <- src
+        = do    n       <- pName
+                pTokSP (KOp ":")
+                k       <- pType c
+                return  $ ImportType n (ImportTypeAbstract k)
+
+        -- Boxed types are associate with values that follow the standard
+        -- heap object layout. They can be passed and return from functions.
+        | "boxed"       <- src
+        = do    n       <- pName
+                pTokSP (KOp ":")
+                k       <- pType c
+                return  $ ImportType n (ImportTypeBoxed k)
+
+        | otherwise
+        = P.unexpected "import mode for foreign type."
+
+
+---------------------------------------------------------------------------------------------------
+-- | Parse a foreign capability import specification.
+pImportForeignCap
+        :: (Ord n, Pretty n)
+        => Context n -> String -> Parser n (ImportSpec n)
+
+pImportForeignCap c src
+
+        -- Abstract capability.
+        | "abstract"    <- src
+        = do    n       <- pName
+                pTokSP  (KOp ":")
+                t       <- pType c
+                return  $  ImportCap n (ImportCapAbstract t)
+
+        | otherwise
+        = P.unexpected "import mode for foreign capability."
+
+
+---------------------------------------------------------------------------------------------------
+-- | Parse a value import specification.
+---
+-- When we parse this initially the arity information is set to Nothing.
+-- The arity information itself comes in with the associated ARITY pragma
+-- which is parsed separately. The information from the ARITY pragma
+-- is attached to the `InputValueModule` constructor by the Module parser.
+--
+pImportValue
+        :: (Ord n, Pretty n)
+        => Context n -> Parser n (ImportSpec n)
+
+pImportValue c
+ = do   n       <- pName
+        pTokSP (KOp ":")
+        t       <- pType c
+        return  (ImportValue n (ImportValueModule (ModuleName []) n t Nothing))
+
+
+-- | Parse a foreign value import spec.
+pImportForeignValue    
+        :: (Ord n, Pretty n)
+        => Context n -> String -> Parser n (ImportSpec n)
+
+pImportForeignValue c src
+        | "c"           <- src
+        = do    n       <- pName
+                pTokSP (KOp ":")
+                k       <- pType c
+
+                -- ISSUE #327: Allow external symbol to be specified 
+                --             with foreign C imports and exports.
+                let symbol = renderIndent (ppr n)
+
+                return  $ ImportValue n (ImportValueSea symbol k)
+
+        | otherwise
+        = P.unexpected "import mode for foreign value."
+
diff --git a/DDC/Core/Parser/Module.hs b/DDC/Core/Parser/Module.hs
--- a/DDC/Core/Parser/Module.hs
+++ b/DDC/Core/Parser/Module.hs
@@ -1,291 +1,128 @@
-
+{-# OPTIONS -fno-warn-unused-binds #-}
 module DDC.Core.Parser.Module
         (pModule)
 where
-import DDC.Core.Module
-import DDC.Core.Exp
 import DDC.Core.Parser.Type
 import DDC.Core.Parser.Exp
 import DDC.Core.Parser.Context
 import DDC.Core.Parser.Base
+import DDC.Core.Parser.ExportSpec
+import DDC.Core.Parser.ImportSpec
+import DDC.Core.Parser.DataDef
+import DDC.Core.Module
 import DDC.Core.Lexer.Tokens
-import DDC.Core.Compounds
-import DDC.Type.DataDef
+import DDC.Core.Exp.Annot
 import DDC.Base.Pretty
-import Control.Monad
+import Data.Char
+import qualified Data.Map               as Map
 import qualified DDC.Base.Parser        as P
+import qualified Data.Text              as T
 
 
--- Module -----------------------------------------------------------------------------------------
 -- | Parse a core module.
 pModule :: (Ord n, Pretty n) 
-        => Context
+        => Context n
         -> Parser n (Module P.SourcePos n)
 pModule c
  = do   sp      <- pTokSP KModule
         name    <- pModuleName
 
-        -- Export definitions.
-        tExports        <- liftM concat $ P.many (pExportSpecs c)
 
-        -- Import definitions.
-        tImports        <- liftM concat $ P.many (pImportSpecs c)
+        -- Parse header declarations
+        heads                   <- P.many (pHeadDecl c)
+        let importSpecs_noArity = concat $ [specs | HeadImportSpecs specs <- heads ]
+        let exportSpecs         = concat $ [specs | HeadExportSpecs specs <- heads ]
+        let defsLocal           =          [def   | HeadDataDef     def   <- heads ]
 
-        -- Data definitions.
-        dataDefsLocal   <- P.many (pDataDef c)
+        -- Attach arity information to import specs.
+        --   The aritity information itself comes in the ARITY pragmas,
+        --   which are parsed as separate top level things.
+        let importArities
+                = Map.fromList  [ (n, (iTypes, iValues, iBoxes ))
+                                | HeadPragmaArity n iTypes iValues iBoxes <- heads ]
 
-        pTok KWith
+        let attachAritySpec (ImportValue n (ImportValueModule mn v t _))
+                = ImportValue n (ImportValueModule mn v t (Map.lookup n importArities))
 
-        -- LET;+
-        lts             <- P.sepBy1 (pLetsSP c) (pTok KIn)
+            attachAritySpec spec = spec
 
+        let importSpecs
+                = map attachAritySpec importSpecs_noArity
+
+
+        -- Parse function definitions.
+        --  If there is a 'with' keyword then this is a standard module with bindings.
+        --  If not, then it is a module header, which doesn't need bindings.
+        (lts, isHeader) 
+         <- P.choice
+                [ do    pTok KWith
+
+                        -- LET;+
+                        lts  <- P.sepBy1 (pLetsSP c) (pTok KIn)
+                        return (lts, False)
+
+                , do    return ([],  True) ]
+
         -- The body of the module consists of the top-level bindings wrapped
         -- around a unit constructor place-holder.
         let body = xLetsAnnot lts (xUnit sp)
 
         return  $ ModuleCore
                 { moduleName            = name
+                , moduleIsHeader        = isHeader
                 , moduleExportTypes     = []
-                , moduleExportValues    = [(n, s) | ExportValue n s <- tExports]
-                , moduleImportTypes     = [(n, s) | ImportType  n s <- tImports]
-                , moduleImportValues    = [(n, s) | ImportValue n s <- tImports]
-                , moduleDataDefsLocal   = dataDefsLocal
+                , moduleExportValues    = [(n, s) | ExportValue n s <- exportSpecs]
+                , moduleImportTypes     = [(n, s) | ImportType  n s <- importSpecs]
+                , moduleImportCaps      = [(n, s) | ImportCap   n s <- importSpecs]
+                , moduleImportValues    = [(n, s) | ImportValue n s <- importSpecs]
+                , moduleImportDataDefs  = [def    | ImportData  def <- importSpecs]
+                , moduleDataDefsLocal   = defsLocal
                 , moduleBody            = body }
 
 
----------------------------------------------------------------------------------------------------
-data ExportSpec n
-        = ExportValue   n (ExportSource n)
-
-
--- | Parse some export specs.
-pExportSpecs
-        :: (Ord n, Pretty n)
-        => Context -> Parser n [ExportSpec n]
-
-pExportSpecs c
- = do   pTok KExport
-
-        P.choice 
-         [      -- export value { (NAME :: TYPE)+ }
-           do   P.choice [ pTok KValue, return () ]
-                pTok KBraceBra
-                specs   <- P.sepEndBy1 (pExportValue c) (pTok KSemiColon)
-                pTok KBraceKet 
-                return specs
-
-                -- export foreign X value { (NAME :: TYPE)+ }
-         , do   pTok KForeign
-                dst     <- liftM (renderIndent . ppr) pName
-                pTok KValue
-                pTok KBraceBra
-                specs   <- P.sepEndBy1 (pExportForeignValue c dst) (pTok KSemiColon)
-                pTok KBraceKet
-                return specs
-         ]
-
-
--- | Parse an export spec.
-pExportValue
-        :: (Ord n, Pretty n)
-        => Context -> Parser n (ExportSpec n)
-pExportValue c 
- = do   
-        n       <- pName
-        pTokSP (KOp ":")
-        t       <- pType c
-        return  (ExportValue n (ExportSourceLocal n t))
-
-
--- | Parse a foreign value export spec.
-pExportForeignValue    
-        :: (Ord n, Pretty n)
-        => Context -> String -> Parser n (ExportSpec n)
-pExportForeignValue c dst
-        | "c"           <- dst
-        = do    n       <- pName
-                pTokSP (KOp ":")
-                k       <- pType c
-
-                -- ISSUE #327: Allow external symbol to be specified 
-                --             with foreign C imports and exports.
-                return  (ExportValue n (ExportSourceLocal n k))
-
-        | otherwise
-        = P.unexpected "export mode for foreign value."
-
-
----------------------------------------------------------------------------------------------------
--- | An imported foreign type or foreign value.
-data ImportSpec n
-        = ImportType    n (ImportSource n)
-        | ImportValue   n (ImportSource n)
-        
-
--- | Parse some import specs.
-pImportSpecs    :: (Ord n, Pretty n)
-                => Context -> Parser n [ImportSpec n]
-pImportSpecs c
- = do   pTok KImport
-
-        P.choice
-         [      -- import type  { (NAME :: TYPE)+ }
-           do   pTok KType
-                pTok KBraceBra
-                specs   <- P.sepEndBy1 (pImportType c) (pTok KSemiColon)
-                pTok KBraceKet
-                return specs
-
-                -- import value { (NAME :: TYPE)+ }
-         , do   P.choice [ pTok KValue, return () ]
-                pTok KBraceBra
-                specs   <- P.sepEndBy1 (pImportValue c) (pTok KSemiColon)
-                pTok KBraceKet
-                return specs
-
-         , do   pTok KForeign
-                src     <- liftM (renderIndent . ppr) pName
-
-                P.choice
-                 [      -- import foreign X type { (NAME :: TYPE)+ }
-                  do    pTok KType
-                        pTok KBraceBra
-                        sigs <- P.sepEndBy1 (pImportForeignType c src) (pTok KSemiColon)
-                        pTok KBraceKet
-                        return sigs
-        
-                        -- imports foreign X value { (NAME :: TYPE)+ }
-                 , do   pTok KValue
-                        pTok KBraceBra
-                        sigs <- P.sepEndBy1 (pImportForeignValue c src) (pTok KSemiColon)
-                        pTok KBraceKet
-                        return sigs
-                 ]
-         ]
-
-
--- | Parse a type import spec.
-pImportType
-        :: (Ord n, Pretty n)
-        => Context -> Parser n (ImportSpec n)
-pImportType c
- = do   n       <- pName
-        pTokSP (KOp ":")
-        k       <- pType c
-        return  $ ImportType n (ImportSourceModule (ModuleName []) n k)
-
-
--- | Parse a foreign type import spec.
-pImportForeignType
-        :: (Ord n, Pretty n) 
-        => Context -> String -> Parser n (ImportSpec n)
-pImportForeignType c src
-        | "abstract"    <- src
-        = do    n       <- pName
-                pTokSP (KOp ":")
-                k       <- pType c
-                return  (ImportType n (ImportSourceAbstract k))
-
-        | otherwise
-        = P.unexpected "import mode for foreign type."
-
+-- | Wrapper for a declaration that can appear in the module header.
+data HeadDecl n
+        = HeadImportSpecs  [ImportSpec  n]
+        | HeadExportSpecs  [ExportSpec  n]
+        | HeadDataDef      (DataDef     n)
 
--- | Parse a value import spec.
-pImportValue
-        :: (Ord n, Pretty n)
-        => Context -> Parser n (ImportSpec n)
-pImportValue c
- = do   n       <- pName
-        pTokSP (KOp ":")
-        t       <- pType c
-        return  (ImportValue n (ImportSourceModule (ModuleName []) n t))
+        -- | Number of type parameters, value parameters, and boxes for some super.
+        | HeadPragmaArity  n Int Int Int
 
 
--- | Parse a foreign value import spec.
-pImportForeignValue    
-        :: (Ord n, Pretty n)
-        => Context -> String -> Parser n (ImportSpec n)
-pImportForeignValue c src
-        | "c"           <- src
-        = do    n       <- pName
-                pTokSP (KOp ":")
-                k       <- pType c
-
-                -- ISSUE #327: Allow external symbol to be specified 
-                --             with foreign C imports and exports.
-                let symbol = renderIndent (ppr n)
-
-                return  (ImportValue n (ImportSourceSea symbol k))
-
-        | otherwise
-        = P.unexpected "import mode for foreign value."
-
+-- | Parse one of the declarations that can appear in a module header.
+pHeadDecl :: (Ord n, Pretty n)
+          => Context n -> Parser n (HeadDecl n)
 
--- DataDef ----------------------------------------------------------------------------------------
-pDataDef :: Ord n => Context -> Parser n (DataDef n)
-pDataDef c
- = do   pTokSP KData
-        nData   <- pName 
-        bsParam <- liftM concat $ P.many (pDataParam c)
+pHeadDecl ctx
+ = P.choice 
+        [ do    def     <- pDataDef ctx
+                return  $ HeadDataDef def
 
-        P.choice
-         [ -- Data declaration with constructors that have explicit types.
-           do   pTok KWhere
-                pTok KBraceBra
-                ctors      <- P.sepEndBy1 (pDataCtor c nData bsParam) (pTok KSemiColon)
-                let ctors' = [ ctor { dataCtorTag = tag }
-                                | ctor <- ctors
-                                | tag  <- [0..] ]
-                pTok KBraceKet
-                return  $ DataDef 
-                        { dataDefTypeName       = nData
-                        , dataDefParams         = bsParam 
-                        , dataDefCtors          = Just ctors'
-                        , dataDefIsAlgebraic    = True }
-         
-           -- Data declaration with no data constructors.
-         , do   return  $ DataDef 
-                        { dataDefTypeName       = nData
-                        , dataDefParams         = bsParam
-                        , dataDefCtors          = Just []
-                        , dataDefIsAlgebraic    = True }
-         ]
+        , do    imports <- pImportSpecs ctx
+                return  $ HeadImportSpecs imports
 
+        , do    exports <- pExportSpecs ctx
+                return  $ HeadExportSpecs exports 
 
--- | Parse a type parameter to a data type.
-pDataParam :: Ord n => Context -> Parser n [Bind n]
-pDataParam c 
- = do   pTok KRoundBra
-        ns      <- P.many1 pName
-        pTokSP (KOp ":")
-        k       <- pType c
-        pTok KRoundKet
-        return  [BName n k | n <- ns]
+        , do    pHeadPragma ctx ]
 
 
--- | Parse a data constructor declaration.
-pDataCtor 
-        :: Ord n 
-        => Context 
-        -> n                    -- ^ Name of data type constructor.
-        -> [Bind n]             -- ^ Type parameters of data type constructor.
-        -> Parser n (DataCtor n)
-
-pDataCtor c nData bsParam
- = do   n       <- pName
-        pTokSP (KOp ":")
-        t       <- pType c
-        let (tsArg, tResult)    
-                = takeTFunArgResult t
+-- | Parse one of the pragmas that can appear in the module header.
+pHeadPragma :: Context n -> Parser n (HeadDecl n)
+pHeadPragma ctx
+ = do   (txt, sp)      <- pPragmaSP
+        case words $ T.unpack txt of
 
-        return  $ DataCtor
-                { dataCtorName          = n
+         -- The type and value arity of a super.
+         ["ARITY", name, strTypes, strValues, strBoxes]
+          |  all isDigit strTypes
+          ,  all isDigit strValues
+          ,  all isDigit strBoxes
+          , Just makeStringName <- contextMakeStringName ctx
+          -> return $ HeadPragmaArity
+                (makeStringName sp (T.pack name))
+                (read strTypes) (read strValues) (read strBoxes)
 
-                -- Set tag to 0 for now. We fix this up in pDataDef above.
-                , dataCtorTag           = 0
-                
-                , dataCtorFieldTypes    = tsArg
-                , dataCtorResultType    = tResult 
-                , dataCtorTypeName      = nData 
-                , dataCtorTypeParams    = bsParam }
+         _ -> P.unexpected $ "pragma " ++ "{-# " ++ T.unpack txt ++ "#-}"
 
diff --git a/DDC/Core/Parser/Param.hs b/DDC/Core/Parser/Param.hs
--- a/DDC/Core/Parser/Param.hs
+++ b/DDC/Core/Parser/Param.hs
@@ -48,7 +48,7 @@
 -- | Build the type of a function from specifications of its parameters,
 --   and the type of the body.
 funTypeOfParams 
-        :: Context
+        :: Context n
         -> [ParamSpec n]        -- ^ Spec of parameters.
         -> Type n               -- ^ Type of body.
         -> Type n               -- ^ Type of whole function.
@@ -66,13 +66,7 @@
          -> T.tImpl (T.typeOfBind b)
                 $ funTypeOfParams c ps tBody
 
-        ParamValue b eff clo
-         | contextFunctionalEffects c
-         , contextFunctionalClosures c
-         -> T.tFunEC (T.typeOfBind b) eff clo 
-                $ funTypeOfParams c ps tBody
-         
-         | otherwise
+        ParamValue b _eff _clo
          -> T.tFun (T.typeOfBind b)
                 $ funTypeOfParams c ps tBody
 
@@ -81,7 +75,7 @@
 --   with an optional type (or kind) annotation.
 pBindParamSpec
         :: Ord n
-        => Context -> Parser n [ParamSpec n]
+        => Context n -> Parser n [ParamSpec n]
 
 pBindParamSpec c
  = P.choice
@@ -104,7 +98,7 @@
 --
 pBindParamSpecAnnot 
         :: Ord n 
-        => Context -> Parser n [ParamSpec n]
+        => Context n -> Parser n [ParamSpec n]
 
 pBindParamSpecAnnot c
  = P.choice
@@ -140,7 +134,7 @@
          <- P.choice
                 [ do    pTok KBraceBra
                         eff'    <- pType c
-                        pTok (KOp "|")
+                        pTok KBar
                         clo'    <- pType c
                         pTok KBraceKet
                         return  (eff', clo')
diff --git a/DDC/Core/Parser/Type.hs b/DDC/Core/Parser/Type.hs
--- a/DDC/Core/Parser/Type.hs
+++ b/DDC/Core/Parser/Type.hs
@@ -21,7 +21,7 @@
 
 -- | Parse a type.
 pType   :: Ord n 
-        => Context -> Parser n (Type n)
+        => Context n -> Parser n (Type n)
 
 pType c  
  =      pTypeSum c
@@ -31,7 +31,7 @@
 --  | Parse a type sum.
 pTypeSum 
         :: Ord n 
-        => Context -> Parser n (Type n)
+        => Context n -> Parser n (Type n)
 pTypeSum c
  = do   t1      <- pTypeForall c
         P.choice 
@@ -66,7 +66,7 @@
 -- | Parse a quantified type.
 pTypeForall 
         :: Ord n 
-        => Context -> Parser n (Type n)
+        => Context n -> Parser n (Type n)
 pTypeForall c
  = P.choice
          [ -- Universal quantification.
@@ -91,40 +91,25 @@
 -- | Parse a function type.
 pTypeFun 
         :: Ord n 
-        => Context -> Parser n (Type n)
+        => Context n -> Parser n (Type n)
 
 pTypeFun c
  = do   t1      <- pTypeApp c
         P.choice 
          [ -- T1 ~> T2
            do   pTok KArrowTilde
-                t2      <- pTypeFun c
+                t2      <- pTypeForall c
                 return  $ TApp (TApp (TCon (TyConKind KiConFun)) t1) t2
 
            -- T1 => T2
          , do   pTok KArrowEquals
-                t2      <- pTypeFun c
+                t2      <- pTypeForall c
                 return  $ TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2
 
            -- T1 -> T2
          , do   pTok KArrowDash
-                t2      <- pTypeFun c
-                if (  contextFunctionalEffects c
-                   && contextFunctionalClosures c)
-                   then return $ t1 `tFunPE` t2
-                   else return $ t1 `tFun`   t2
-
-           -- T1 -(TSUM | TSUM)> t2
-         , do   pTok (KOp "-")
-                pTok KRoundBra
-                eff     <- pTypeSum c
-                pTok (KOp "|")
-                clo     <- pTypeSum c
-                pTok KRoundKet
-                pTok (KOp ">")
-                t2      <- pTypeFun c
-                return  $ tFunEC t1 eff clo t2
-
+                t2      <- pTypeForall c
+                return $ t1 `tFun`   t2
 
            -- Body type
          , do   return t1 ]
@@ -134,7 +119,7 @@
 -- | Parse a type application.
 pTypeApp 
         :: Ord n 
-        => Context -> Parser n (Type n)
+        => Context n -> Parser n (Type n)
 pTypeApp c
  = do   (t:ts)  <- P.many1 (pTypeAtom c)
         return  $  foldl TApp t ts
@@ -144,7 +129,7 @@
 -- | Parse a variable, constructor or parenthesised type.
 pTypeAtom 
         :: Ord n 
-        => Context -> Parser n (Type n)
+        => Context n -> Parser n (Type n)
 pTypeAtom c
  = P.choice
         -- (~>) and (=>) and (->) and (TYPE2)
@@ -158,14 +143,7 @@
 
           -- (->)
         , do    pTok (KOpVar "->")
-
-                -- Decide what type constructor to use for the (->) token.
-                -- Only use the function constructor with latent effects
-                -- and closures if the language fragment supports both.
-                if (  contextFunctionalEffects  c 
-                   && contextFunctionalClosures c)
-                   then return (TCon $ TyConSpec TcConFunEC)
-                   else return (TCon $ TyConSpec TcConFun)
+                return (TCon $ TyConSpec TcConFun)
 
         -- (TYPE2)
         , do    pTok KRoundBra
diff --git a/DDC/Core/Parser/Witness.hs b/DDC/Core/Parser/Witness.hs
--- a/DDC/Core/Parser/Witness.hs
+++ b/DDC/Core/Parser/Witness.hs
@@ -18,29 +18,25 @@
 -- | Parse a witness expression.
 pWitness 
         :: Ord n  
-        => Context -> Parser n (Witness SourcePos n)
+        => Context n -> Parser n (Witness SourcePos n)
 pWitness c = pWitnessJoin c
 
 
 -- | Parse a witness join.
 pWitnessJoin 
         :: Ord n 
-        => Context -> Parser n (Witness SourcePos n)
+        => Context n -> Parser n (Witness SourcePos n)
 pWitnessJoin c
    -- WITNESS  or  WITNESS & WITNESS
  = do   w1      <- pWitnessApp c
         P.choice 
-         [ do   sp      <- pTokSP (KOp "&")
-                w2      <- pWitnessJoin c
-                return  (WJoin sp w1 w2)
-
-         , do   return w1 ]
+         [ do   return w1 ]
 
 
 -- | Parse a witness application.
 pWitnessApp 
         :: Ord n 
-        => Context -> Parser n (Witness SourcePos n)
+        => Context n -> Parser n (Witness SourcePos n)
 
 pWitnessApp c
   = do  (x:xs)  <- P.many1 (pWitnessArgSP c)
@@ -55,7 +51,7 @@
 -- | Parse a witness argument.
 pWitnessArgSP 
         :: Ord n 
-        => Context -> Parser n (Witness SourcePos n, SourcePos)
+        => Context n -> Parser n (Witness SourcePos n, SourcePos)
 
 pWitnessArgSP c
  = P.choice
@@ -73,7 +69,7 @@
 -- | Parse a variable, constructor or parenthesised witness.
 pWitnessAtom   
         :: Ord n 
-        => Context -> Parser n (Witness SourcePos n)
+        => Context n -> Parser n (Witness SourcePos n)
 
 pWitnessAtom c   
         = liftM fst (pWitnessAtomSP c)
@@ -83,7 +79,7 @@
 --   also returning source position.
 pWitnessAtomSP 
         :: Ord n 
-        => Context -> Parser n (Witness SourcePos n, SourcePos)
+        => Context n -> Parser n (Witness SourcePos n, SourcePos)
 
 pWitnessAtomSP c
  = P.choice
@@ -96,11 +92,6 @@
    -- Named constructors
  , do   (con, sp) <- pConSP
         return  (WCon sp (WiConBound (UName con) (T.tBot T.kWitness)), sp)
-
-   -- Baked-in witness constructors.
- , do   (wb, sp) <- pWbConSP
-        return  (WCon sp (WiConBuiltin wb), sp)
-
                 
    -- Debruijn indices
  , do   (i, sp) <- pIndexSP
diff --git a/DDC/Core/Predicates.hs b/DDC/Core/Predicates.hs
deleted file mode 100644
--- a/DDC/Core/Predicates.hs
+++ /dev/null
@@ -1,132 +0,0 @@
-
--- | Simple predicates on core expressions.
-module DDC.Core.Predicates
-        ( module DDC.Type.Predicates
-
-          -- * Atoms
-        , isXVar,  isXCon
-        , isAtomX, isAtomW
-
-          -- * Lambdas
-        , isXLAM, isXLam
-        , isLambdaX
-
-          -- * Applications
-        , isXApp
-
-          -- * Let bindings
-        , isXLet
-
-          -- * Types and Witnesses
-        , isXType
-        , isXWitness
-
-          -- * Patterns
-        , isPDefault)
-where
-import DDC.Core.Exp
-import DDC.Type.Predicates
-
-
--- Atoms ----------------------------------------------------------------------
--- | Check whether an expression is a variable.
-isXVar :: Exp a n -> Bool
-isXVar xx
- = case xx of
-        XVar{}  -> True
-        _       -> False
-
-
--- | Check whether an expression is a constructor.
-isXCon :: Exp a n -> Bool
-isXCon xx
- = case xx of
-        XCon{}  -> True
-        _       -> False
-
-
--- | Check whether an expression is a `XVar` or an `XCon`, 
---   or some type or witness atom.
-isAtomX :: Exp a n -> Bool
-isAtomX xx
- = case xx of
-        XVar{}          -> True
-        XCon{}          -> True
-        XType    _ t    -> isAtomT t
-        XWitness _ w    -> isAtomW w
-        _               -> False
-
-
--- | Check whether a witness is a `WVar` or `WCon`.
-isAtomW :: Witness a n -> Bool
-isAtomW ww
- = case ww of
-        WVar{}          -> True
-        WCon{}          -> True
-        _               -> False
-
-
--- Lambdas --------------------------------------------------------------------
--- | Check whether an expression is a spec abstraction (level-1).
-isXLAM :: Exp a n -> Bool
-isXLAM xx
- = case xx of
-        XLAM{}  -> True
-        _       -> False
-
-
--- | Check whether an expression is a value or witness abstraction (level-0).
-isXLam :: Exp a n -> Bool
-isXLam xx
- = case xx of
-        XLam{}  -> True
-        _       -> False
-
-
--- | Check whether an expression is a spec, value, or witness abstraction.
-isLambdaX :: Exp a n -> Bool
-isLambdaX xx
-        = isXLAM xx || isXLam xx
-
-
--- Applications ---------------------------------------------------------------
--- | Check whether an expression is an `XApp`.
-isXApp :: Exp a n -> Bool
-isXApp xx
- = case xx of
-        XApp{}  -> True
-        _       -> False
-
-
--- Let Bindings ---------------------------------------------------------------
--- | Check whether an expression is a `XLet`.
-isXLet :: Exp a n -> Bool
-isXLet xx
- = case xx of
-        XLet{}  -> True
-        _       -> False
-        
-
--- Type and Witness -----------------------------------------------------------
--- | Check whether an expression is an `XType`.
-isXType :: Exp a n -> Bool
-isXType xx
- = case xx of
-        XType{}         -> True
-        _               -> False
-
-
--- | Check whether an expression is an `XWitness`.
-isXWitness :: Exp a n -> Bool
-isXWitness xx
- = case xx of
-        XWitness{}      -> True
-        _               -> False
-
-
--- Patterns -------------------------------------------------------------------
--- | Check whether an alternative is a `PDefault`.
-isPDefault :: Pat n -> Bool
-isPDefault PDefault     = True
-isPDefault _            = False
-
diff --git a/DDC/Core/Pretty.hs b/DDC/Core/Pretty.hs
--- a/DDC/Core/Pretty.hs
+++ b/DDC/Core/Pretty.hs
@@ -10,14 +10,13 @@
         , pprImportType
         , pprImportValue)
 where
-import DDC.Core.Compounds
-import DDC.Core.Predicates
 import DDC.Core.Module
-import DDC.Core.Exp
+import DDC.Core.Exp.Annot
 import DDC.Type.DataDef
 import DDC.Type.Pretty
 import DDC.Base.Pretty
 import Data.List
+import Prelude          hiding ((<$>))
 
 
 -- ModuleName -------------------------------------------------------------------------------------
@@ -46,7 +45,9 @@
         , moduleExportTypes     = exportTypes
         , moduleExportValues    = exportValues
         , moduleImportTypes     = importTypes
+        , moduleImportCaps      = importCaps
         , moduleImportValues    = importValues
+        , moduleImportDataDefs  = importData
         , moduleDataDefsLocal   = localData
         , moduleBody            = body }
   = {-# SCC "ppr[Module]" #-}
@@ -56,7 +57,7 @@
         -- Exports --------------------
         dExportTypes
          | null $ exportTypes   = empty
-         | otherwise            = (vcat $ map pprExportType  exportTypes)   <> line
+         | otherwise            = (vcat $ map pprExportType  exportTypes)  <> line
 
         dExportValues
          | null $ exportValues  = empty
@@ -65,8 +66,12 @@
         -- Imports --------------------
         dImportTypes
          | null $ importTypes   = empty
-         | otherwise            = (vcat $ map pprImportType importTypes)   <> line
+         | otherwise            = (vcat $ map pprImportType  importTypes)  <> line
 
+        dImportCaps
+         | null $ importCaps    = empty
+         | otherwise            = (vcat $ map pprImportCap   importCaps)   <> line
+
         dImportValues
          | null $ importValues  = empty
          | otherwise            = (vcat $ map pprImportValue importValues) <> line
@@ -77,14 +82,21 @@
          = empty
          
          -- If there are no imports or exports then suppress printint.
-         | null exportTypes, null exportValues, null importTypes, null importValues
+         | null exportTypes, null exportValues
+         , null importTypes, null importCaps, null importValues
          = empty
 
          | otherwise            
-         = line <> dExportTypes <> dExportValues <> dImportTypes <> dImportValues
+         = line <> dExportTypes <> dExportValues 
+                <> dImportTypes <> dImportCaps <> dImportValues
                 
-        -- Local Data Definitions -----
-        docsLocalData
+        -- Data Definitions -----
+        docsDataImport
+         | null importData = empty
+         | otherwise
+         = line <> vsep  (map (\i -> text "import" <+> (ppr i)) $ importData)
+
+        docsDataLocal
          | null localData = empty
          | otherwise
          = line <> vsep  (map ppr localData)
@@ -93,8 +105,12 @@
 
     in  text "module" <+> ppr name 
          <+> docsImportsExports
-         <>  docsLocalData
-         <>  text "with" <$$> (vcat $ map pprLts lts)
+         <>  docsDataImport
+         <>  docsDataLocal
+         <>  (case lts of
+                []       -> empty
+                [LRec[]] -> empty
+                _        -> text "with" <$$> (vcat $ map pprLts lts))
 
 
 -- Exports ----------------------------------------------------------------------------------------
@@ -103,10 +119,10 @@
 pprExportType (n, esrc)
  = case esrc of
         ExportSourceLocal _n k
-         -> text "export type" <+> ppr n  <+> text ":" <+> ppr k <> semi
+         -> text "export type" <+> padL 10 (ppr n) <+> text ":" <+> ppr k <> semi
 
         ExportSourceLocalNoType _n 
-         -> text "export type" <+> ppr n  <> semi
+         -> text "export type" <+> padL 10 (ppr n) <> semi
 
 
 -- | Pretty print an exported value definition.
@@ -114,43 +130,58 @@
 pprExportValue (n, esrc)
  = case esrc of
         ExportSourceLocal _n t
-         -> text "export value" <+> ppr n  <+> text ":" <+> ppr t <> semi
+         -> text "export value" <+> padL 10 (ppr n) <+> text ":" <+> ppr t <> semi
 
         ExportSourceLocalNoType _n
-         -> text "export value" <+> ppr n  <> semi
+         -> text "export value" <+> padL 10 (ppr n) <> semi
 
 
 -- Imports ----------------------------------------------------------------------------------------
--- | Pretty print an imported type definition.                
-pprImportType :: (Pretty n, Eq n) => (n, ImportSource n) -> Doc
+-- | Pretty print a type import.
+pprImportType :: (Pretty n, Eq n) => (n, ImportType n) -> Doc
 pprImportType (n, isrc)
  = case isrc of
-        ImportSourceModule _mn _nSrc k
-         -> text "import type" <+> ppr n <+> text ":" <+> ppr k <> semi
-
-        ImportSourceAbstract k
+        ImportTypeAbstract k
          -> text "import foreign abstract type" <> line
          <> indent 8 (ppr n <+> text ":" <+> ppr k <> semi)
+         <> line
 
-        ImportSourceSea _var k
-         -> text "import foreign c type" <> line
+        ImportTypeBoxed k
+         -> text "import foreign boxed type" <> line
          <> indent 8 (ppr n <+> text ":" <+> ppr k <> semi)
+         <> line
 
 
--- | Pretty print an imported value definition.
-pprImportValue :: (Pretty n, Eq n) => (n, ImportSource n) -> Doc
+-- | Pretty print a capability import.
+pprImportCap :: (Pretty n, Eq n) => (n, ImportCap n) -> Doc
+pprImportCap (n, isrc)
+ = case isrc of
+        ImportCapAbstract t
+         -> text "import foreign abstract capability" <> line
+         <> indent 8 (padL 15 (ppr n) <+> text ":" <+> ppr t <> semi)
+         <> line
+
+
+-- | Pretty print a value import.
+pprImportValue :: (Pretty n, Eq n) => (n, ImportValue n) -> Doc
 pprImportValue (n, isrc)
  = case isrc of
-        ImportSourceModule _mn _nSrc t
-         -> text "import value" <+> ppr n <+> text ":" <+> ppr t <> semi
+        ImportValueModule _mn _nSrc t Nothing
+         ->        text "import value" <+> padL 10 (ppr n) <+> text ":" <+> ppr t <> semi
 
-        ImportSourceAbstract t
-         -> text "import foreign abstract value" <> line
-         <> indent 8 (ppr n <+> text ":" <+> ppr t <> semi)
+        ImportValueModule _mn _nSrc t (Just (arityType, arityValue, arityBoxes))
+         -> vcat [ text "import value" <+> padL 10 (ppr n) <+> text ":" <+> ppr t <> semi
+                 , text "{-# ARITY   " <+> padL 10 (ppr n) 
+                                       <+> ppr arityType 
+                                       <+> ppr arityValue 
+                                       <+> ppr arityBoxes
+                                       <+> text "#-}"
+                 , empty ]
 
-        ImportSourceSea _var t
+        ImportValueSea _var t
          -> text "import foreign c value" <> line
-         <> indent 8 (ppr n <+> text ":" <+> ppr t <> semi)
+         <> indent 8 (padL 15 (ppr n) <+> text ":" <+> ppr t <> semi)
+         <> line
 
 
 -- DataDef ----------------------------------------------------------------------------------------
@@ -158,8 +189,8 @@
  pprPrec _ def
   = {-# SCC "ppr[DataDef]" #-}
       (text "data" 
-        <+> ppr (dataDefTypeName def)
-        <+> hsep (map (parens . ppr) (dataDefParams def))
+        <+> hsep ( ppr (dataDefTypeName def)
+                 : map (parens . ppr) (dataDefParams def))
         <+> text "where"
         <+>  lbrace)
   <$> (case dataDefCtors def of
@@ -225,7 +256,6 @@
          | otherwise
          -> ppr u
 
-
         XCon  _ dc
          | modeExpConTypes mode
          , Just t       <- takeTypeOfDaCon dc
@@ -234,14 +264,13 @@
          | otherwise
          -> ppr dc
         
-        
         XLAM{}
          -> let Just (bs, xBody) = takeXLAMs xx
                 groups = partitionBindsByType bs
             in  pprParen' (d > 1)
-                 $  (cat $ map (pprBinderGroup (text "/\\")) groups)
+                 $  (cat $ map (pprBinderGroup (text "Λ")) groups)
                  <>  (if      isXLAM    xBody then empty
-                      else if isXLam    xBody then line <> space
+                      else if isXLam    xBody then line
                       else if isSimpleX xBody then space
                       else    line)
                  <>  pprX xBody
@@ -250,7 +279,7 @@
          -> let Just (bs, xBody) = takeXLams xx
                 groups = partitionBindsByType bs
             in  pprParen' (d > 1)
-                 $  (cat $ map (pprBinderGroup (text "\\")) groups) 
+                 $  (cat $ map (pprBinderGroup (text "\955")) groups) 
                  <> breakWhen (not $ isSimpleX xBody)
                  <> pprX xBody
 
@@ -348,17 +377,9 @@
         CastWeakenEffect  eff   
          -> text "weakeff" <+> brackets (ppr eff)
 
-        CastWeakenClosure xs
-         -> text "weakclo" 
-         <+> braces (hcat $ punctuate (semi <> space) 
-                          $ map ppr xs)
-
         CastPurify w
          -> text "purify"  <+> angles   (ppr w)
 
-        CastForget w
-         -> text "forget"  <+> angles   (ppr w)
-
         CastBox
          -> text "box"
 
@@ -430,11 +451,7 @@
                 <+> text "with"
                 <+> braces (cat $ punctuate (text "; ") $ map pprWitBind bws)
         
-        LWithRegion b
-         -> text "withregion"
-                <+> ppr b
 
-
 -- | When we pretty print witness binders, 
 --   suppress the underscore when there is no name.
 pprWitBind :: (Eq n, Pretty n) => Bind n -> Doc
@@ -448,33 +465,16 @@
 instance (Pretty n, Eq n) => Pretty (Witness a n) where
  pprPrec d ww
   = case ww of
-        WVar _ n         -> ppr n
-        WCon _ wc        -> ppr wc
-
-        WApp _ w1 w2
-         -> pprParen (d > 10) (ppr w1 <+> pprPrec 11 w2)
-         
-        WJoin _ w1 w2
-         -> pprParen (d > 9)  (ppr w1 <+> text "&" <+> ppr w2)
-
-        WType _ t        -> text "[" <> ppr t <> text "]"
+        WVar _ n        -> ppr n
+        WCon _ wc       -> ppr wc
+        WApp _ w1 w2    -> pprParen (d > 10) (ppr w1 <+> pprPrec 11 w2)
+        WType _ t       -> text "[" <> ppr t <> text "]"
 
 
 instance (Pretty n, Eq n) => Pretty (WiCon n) where
  ppr wc
   = case wc of
-        WiConBuiltin wb   -> ppr wb
         WiConBound   u  _ -> ppr u
-
-
-instance Pretty WbCon where
- ppr wb
-  = case wb of
-        WbConPure       -> text "pure"
-        WbConEmpty      -> text "empty"
-        WbConUse        -> text "use"
-        WbConRead       -> text "read"
-        WbConAlloc      -> text "alloc"
 
 
 -- Binder -----------------------------------------------------------------------------------------
diff --git a/DDC/Core/Transform/Annotate.hs b/DDC/Core/Transform/Annotate.hs
--- a/DDC/Core/Transform/Annotate.hs
+++ b/DDC/Core/Transform/Annotate.hs
@@ -2,8 +2,8 @@
 module DDC.Core.Transform.Annotate
         (Annotate (..))
 where
-import qualified DDC.Core.Exp.Annot     as A
-import qualified DDC.Core.Exp.Simple    as S
+import qualified DDC.Core.Exp.Annot.Exp         as A
+import qualified DDC.Core.Exp.Simple.Exp        as S
 
 
 -- | Convert the `Simple` version of the AST to the `Annot` version,
@@ -48,9 +48,7 @@
   = let down    = annotate def
     in case cc of
         S.CastWeakenEffect eff          -> A.CastWeakenEffect  eff
-        S.CastWeakenClosure clo         -> A.CastWeakenClosure (map down clo)
         S.CastPurify w                  -> A.CastPurify        (down w)
-        S.CastForget w                  -> A.CastForget        (down w)
         S.CastBox                       -> A.CastBox
         S.CastRun                       -> A.CastRun
 
@@ -62,14 +60,14 @@
         S.LLet b x                      -> A.LLet b (down x)
         S.LRec bxs                      -> A.LRec [(b, down x) | (b, x) <- bxs]
         S.LPrivate bks mT bts           -> A.LPrivate bks mT bts
-        S.LWithRegion u                 -> A.LWithRegion u
 
 
 instance Annotate S.Alt A.Alt where
  annotate def alt
   = let down    = annotate def
     in case alt of
-        S.AAlt w x                      -> A.AAlt w (down x)
+        S.AAlt S.PDefault x             -> A.AAlt  A.PDefault (down x)
+        S.AAlt (S.PData dc bs) x        -> A.AAlt (A.PData dc bs) (down x)
 
 
 instance Annotate S.Witness A.Witness where
@@ -80,13 +78,11 @@
         S.WAnnot a (S.WVar  u)          -> A.WVar  a u
         S.WAnnot a (S.WCon  wc)         -> A.WCon  a wc
         S.WAnnot a (S.WApp  w1 w2)      -> A.WApp  a (down w1) (down w2)
-        S.WAnnot a (S.WJoin w1 w2)      -> A.WJoin a (down w1) (down w2)
         S.WAnnot a (S.WType t)          -> A.WType a t
 
         S.WVar  u                       -> A.WVar  def u
         S.WCon  dc                      -> A.WCon  def dc        
         S.WApp  x1 x2                   -> A.WApp  def (down x1) (down x2)
-        S.WJoin x1 x2                   -> A.WJoin def (down x1) (down x2)
         S.WType t                       -> A.WType def t
 
 
diff --git a/DDC/Core/Transform/BoundT.hs b/DDC/Core/Transform/BoundT.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Transform/BoundT.hs
@@ -0,0 +1,89 @@
+
+-- | Lifting and lowering level-1 deBruijn indices in code things.
+--
+--   Level-1 indices are used for type variables.
+--
+module DDC.Core.Transform.BoundT
+        ( liftT,         liftAtDepthT
+        , MapBoundT(..))
+where
+import DDC.Core.Exp.Annot.Exp
+import DDC.Type.Transform.BoundT
+
+
+instance Ord n => MapBoundT (Exp a) n where
+ mapBoundAtDepthT f d xx
+  = let down = mapBoundAtDepthT f d
+    in case xx of
+        XVar a u                -> XVar a   u
+        XCon{}                  -> xx
+        XApp a x1 x2            -> XApp a   (down x1) (down x2)
+        XLAM a b x              -> XLAM a b (mapBoundAtDepthT f (d + countBAnons [b]) x)
+        XLam a b x              -> XLam a   (down b) (down x)
+         
+        XLet a lets x   
+         -> let (lets', levels) = mapBoundAtDepthTLets f d lets 
+            in  XLet a lets' (mapBoundAtDepthT f (d + levels) x)
+
+        XCase    a x alts       -> XCase    a (down x)  (map down alts)
+        XCast    a cc x         -> XCast    a (down cc) (down x)
+        XType    a t            -> XType    a (down t)
+        XWitness a w            -> XWitness a (down w)
+
+         
+instance Ord n => MapBoundT (Witness a) n where
+ mapBoundAtDepthT f d ww
+  = let down = mapBoundAtDepthT f d
+    in case ww of
+        WVar  a u               -> WVar  a (down u)
+        WCon  _ _               -> ww
+        WApp  a w1 w2           -> WApp  a (down w1) (down w2)
+        WType a t               -> WType a (down t)
+
+
+instance Ord n => MapBoundT (Cast a) n where
+ mapBoundAtDepthT f d cc
+  = let down = mapBoundAtDepthT f d
+    in case cc of
+        CastWeakenEffect t      -> CastWeakenEffect  (down t)
+        CastPurify w            -> CastPurify (down w)
+        CastBox                 -> CastBox
+        CastRun                 -> CastRun
+
+
+instance Ord n => MapBoundT (Alt a) n where
+ mapBoundAtDepthT f d (AAlt p x)
+  = let down = mapBoundAtDepthT f d
+    in case p of
+        PDefault                -> AAlt PDefault (down x)
+        PData dc bs             -> AAlt (PData dc (map down bs)) (down x)
+        
+
+mapBoundAtDepthTLets
+        :: Ord n
+        => (Int -> Bound n -> Bound n)  -- ^ Number of levels to lift.
+        -> Int                          -- ^ Current binding depth.
+        -> Lets a n                     -- ^ Lift exp indices in this thing.
+        -> (Lets a n, Int)              -- ^ Lifted, and how much to increase depth by
+
+mapBoundAtDepthTLets f d lts
+ = let down = mapBoundAtDepthT f d
+   in case lts of
+        LLet b x
+         ->     ( LLet (down b) (down x)
+                , 0)
+
+        LRec bs
+         -> let bs' = [ (b, mapBoundAtDepthT f d x) | (b, x) <- bs ]
+            in  (LRec bs', 0)
+
+        LPrivate bsT mT bsX
+         -> let inc  = countBAnons bsT
+                bsX' = map (mapBoundAtDepthT f (d + inc)) bsX
+            in  ( LPrivate bsT mT bsX'
+                , inc)
+
+
+countBAnons = length . filter isAnon
+ where  isAnon (BAnon _) = True
+        isAnon _         = False
diff --git a/DDC/Core/Transform/BoundX.hs b/DDC/Core/Transform/BoundX.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Core/Transform/BoundX.hs
@@ -0,0 +1,166 @@
+
+-- | Lifting and lowering level-0 deBruijn indices in core things.
+-- 
+--   Level-0 indices are used for both value and witness variables.
+--
+module DDC.Core.Transform.BoundX
+        ( liftX,        liftAtDepthX
+        , lowerX,       lowerAtDepthX
+        , MapBoundX(..))
+where
+import DDC.Core.Exp
+
+
+-- Lift -----------------------------------------------------------------------
+-- | Lift debruijn indices less than or equal to the given depth.
+liftAtDepthX   
+        :: MapBoundX c n
+        => Int          -- ^ Number of levels to lift.
+        -> Int          -- ^ Current binding depth.
+        -> c n          -- ^ Lift expression indices in this thing.
+        -> c n
+
+liftAtDepthX n d
+ = {-# SCC liftAtDepthX #-} 
+   mapBoundAtDepthX liftU d
+ where  
+        liftU d' u
+         = case u of
+                UName{}         -> u
+                UPrim{}         -> u
+                UIx i
+                 | d' <= i      -> UIx (i + n)
+                 | otherwise    -> u
+
+
+-- | Wrapper for `liftAtDepthX` that starts at depth 0.       
+liftX   :: MapBoundX c n => Int -> c n -> c n
+liftX n xx  = liftAtDepthX n 0 xx
+
+
+-- Lower ----------------------------------------------------------------------
+-- | Lower debruijn indices less than or equal to the given depth.
+lowerAtDepthX   
+        :: MapBoundX c n
+        => Int          -- ^ Number of levels to lower.
+        -> Int          -- ^ Current binding depth.
+        -> c n          -- ^ Lower expression indices in this thing.
+        -> c n
+
+lowerAtDepthX n d
+ = {-# SCC lowerAtDepthX #-}
+   mapBoundAtDepthX liftU d
+ where  
+        liftU d' u
+         = case u of
+                UName{}         -> u
+                UPrim{}         -> u
+                UIx i
+                 | d' <= i      -> UIx (i - n)
+                 | otherwise    -> u
+
+
+-- | Wrapper for `lowerAtDepthX` that starts at depth 0.       
+lowerX   :: MapBoundX c n => Int -> c n -> c n
+lowerX n xx  = lowerAtDepthX n 0 xx
+
+
+-- MapBoundX ------------------------------------------------------------------
+class MapBoundX (c :: * -> *) n where
+ -- | Apply a function to all bound variables in the program.
+ --   The function is passed the current binding depth.
+ --   This is used to defined both `liftX` and `lowerX`.
+ mapBoundAtDepthX
+        :: (Int -> Bound n -> Bound n)  
+                        -- ^ Function to apply to the bound occ.
+                        --   It is passed the current binding depth.
+        -> Int          -- ^ Current binding depth.
+        -> c n          -- ^ Lift expression indices in this thing.
+        -> c n
+
+
+instance MapBoundX Bound n where
+ mapBoundAtDepthX f d u
+        = f d u
+
+
+instance MapBoundX (Exp a) n where
+ mapBoundAtDepthX f d xx
+  = let down = mapBoundAtDepthX f d
+    in case xx of
+        XVar a u        -> XVar a (f d u)
+        XCon{}          -> xx
+        XApp a x1 x2    -> XApp a (down x1) (down x2)
+        XLAM a b x      -> XLAM a b (down x)
+        XLam a b x      -> XLam a b (mapBoundAtDepthX f (d + countBAnons [b]) x)
+         
+        XLet a lets x   
+         -> let (lets', levels) = mapBoundAtDepthXLets f d lets 
+            in  XLet a lets' (mapBoundAtDepthX f (d + levels) x)
+
+        XCase a x alts  -> XCase a (down x)  (map down alts)
+        XCast a cc x    -> XCast a (down cc) (down x)
+        XType{}         -> xx
+        XWitness a w    -> XWitness a (down w)
+
+
+instance MapBoundX (Witness a) n where
+ mapBoundAtDepthX f d ww
+  = let down = mapBoundAtDepthX f d
+    in case ww of
+        WVar  a u       -> WVar  a (down u)
+        WCon  _ _       -> ww
+        WApp  a w1 w2   -> WApp  a (down w1) (down w2)
+        WType _ _       -> ww
+
+
+instance MapBoundX (Cast a) n where
+ mapBoundAtDepthX _f _d cc
+  = case cc of
+        CastWeakenEffect{} -> cc
+        CastPurify w       -> CastPurify w
+        CastBox            -> CastBox
+        CastRun            -> CastRun
+
+
+instance MapBoundX (Alt a) n where
+ mapBoundAtDepthX f d (AAlt p x)
+  = case p of
+        PDefault 
+         -> AAlt PDefault (mapBoundAtDepthX f d x)
+
+        PData _ bs 
+         -> let d' = d + countBAnons bs
+            in  AAlt p (mapBoundAtDepthX f d' x)
+        
+
+mapBoundAtDepthXLets
+        :: (Int -> Bound n -> Bound n)  
+                                -- ^ Number of levels to lift.
+        -> Int                  -- ^ Current binding depth.
+        -> Lets a n             -- ^ Lift exp indices in this thing.
+        -> (Lets a n, Int)      -- ^ Lifted, and how much to increase depth by
+
+mapBoundAtDepthXLets f d lts
+ = case lts of
+        LLet b x
+         -> let inc = countBAnons [b]
+                
+                -- non-recursive binding: do not increase x's depth
+                x'  = mapBoundAtDepthX f d x
+            in  (LLet b x', inc)
+
+        LRec bs
+         -> let inc = countBAnons (map fst bs)
+                bs' = map (\(b,e) -> (b, mapBoundAtDepthX f (d+inc) e)) bs
+            in  (LRec bs', inc)
+
+        LPrivate _b _ bs 
+         -> (lts, countBAnons bs)
+
+
+countBAnons = length . filter isAnon
+ where  isAnon (BAnon _) = True
+        isAnon _         = False
+
+
diff --git a/DDC/Core/Transform/Deannotate.hs b/DDC/Core/Transform/Deannotate.hs
--- a/DDC/Core/Transform/Deannotate.hs
+++ b/DDC/Core/Transform/Deannotate.hs
@@ -2,8 +2,8 @@
 module DDC.Core.Transform.Deannotate
         (Deannotate(..))
 where
-import qualified DDC.Core.Exp.Annot     as A
-import qualified DDC.Core.Exp.Simple    as S
+import qualified DDC.Core.Exp.Annot.Exp    as A
+import qualified DDC.Core.Exp.Simple.Exp   as S
 
 
 -- | Convert the `Annot` version of the AST to the `Simple` version,
@@ -41,13 +41,13 @@
         A.LLet b x              -> S.LLet b (down x)
         A.LRec bxs              -> S.LRec [(b, down x) | (b, x) <- bxs]
         A.LPrivate bks mt bts   -> S.LPrivate bks mt bts
-        A.LWithRegion u         -> S.LWithRegion u
 
 
 instance Deannotate A.Alt S.Alt where
  deannotate f aa
   = case aa of
-        A.AAlt w x              -> S.AAlt w (deannotate f x)
+        A.AAlt A.PDefault x      -> S.AAlt  S.PDefault (deannotate f x)
+        A.AAlt (A.PData dc bs) x -> S.AAlt (S.PData dc bs) (deannotate f x)
 
 
 instance Deannotate A.Witness S.Witness where
@@ -60,7 +60,6 @@
         A.WVar  a u             -> wrap a (S.WVar u)
         A.WCon  a wc            -> wrap a (S.WCon wc)
         A.WApp  a w1 w2         -> wrap a (S.WApp  (down w1) (down w2))
-        A.WJoin a w1 w2         -> wrap a (S.WJoin (down w1) (down w2))
         A.WType a t             -> wrap a (S.WType t)
 
 
@@ -69,9 +68,7 @@
   = let down    = deannotate f
     in case cc of
         A.CastWeakenEffect e    -> S.CastWeakenEffect e
-        A.CastWeakenClosure xs  -> S.CastWeakenClosure (map down xs)
         A.CastPurify w          -> S.CastPurify (down w)
-        A.CastForget w          -> S.CastForget (down w)
         A.CastBox               -> S.CastBox
         A.CastRun               -> S.CastRun
 
diff --git a/DDC/Core/Transform/LiftT.hs b/DDC/Core/Transform/LiftT.hs
deleted file mode 100644
--- a/DDC/Core/Transform/LiftT.hs
+++ /dev/null
@@ -1,91 +0,0 @@
-
-module DDC.Core.Transform.LiftT
-        ( liftT,         liftAtDepthT
-        , MapBoundT(..))
-where
-import DDC.Core.Exp
-import DDC.Type.Transform.LiftT
-
-
-instance Ord n => MapBoundT (Exp a) n where
- mapBoundAtDepthT f d xx
-  = let down = mapBoundAtDepthT f d
-    in case xx of
-        XVar a u                -> XVar a   u
-        XCon{}                  -> xx
-        XApp a x1 x2            -> XApp a   (down x1) (down x2)
-        XLAM a b x              -> XLAM a b (mapBoundAtDepthT f (d + countBAnons [b]) x)
-        XLam a b x              -> XLam a   (down b) (down x)
-         
-        XLet a lets x   
-         -> let (lets', levels) = mapBoundAtDepthTLets f d lets 
-            in  XLet a lets' (mapBoundAtDepthT f (d + levels) x)
-
-        XCase    a x alts       -> XCase    a (down x)  (map down alts)
-        XCast    a cc x         -> XCast    a (down cc) (down x)
-        XType    a t            -> XType    a (down t)
-        XWitness a w            -> XWitness a (down w)
-
-         
-instance Ord n => MapBoundT (Witness a) n where
- mapBoundAtDepthT f d ww
-  = let down = mapBoundAtDepthT f d
-    in case ww of
-        WVar  a u               -> WVar  a (down u)
-        WCon  _ _               -> ww
-        WApp  a w1 w2           -> WApp  a (down w1) (down w2)
-        WJoin a w1 w2           -> WJoin a (down w1) (down w2)
-        WType a t               -> WType a (down t)
-
-
-instance Ord n => MapBoundT (Cast a) n where
- mapBoundAtDepthT f d cc
-  = let down = mapBoundAtDepthT f d
-    in case cc of
-        CastWeakenEffect t      -> CastWeakenEffect  (down t)
-        CastWeakenClosure xs    -> CastWeakenClosure (map down xs)
-        CastPurify w            -> CastPurify (down w)
-        CastForget w            -> CastForget (down w)
-        CastBox                 -> CastBox
-        CastRun                 -> CastRun
-
-
-instance Ord n => MapBoundT (Alt a) n where
- mapBoundAtDepthT f d (AAlt p x)
-  = let down = mapBoundAtDepthT f d
-    in case p of
-        PDefault                -> AAlt PDefault (down x)
-        PData dc bs             -> AAlt (PData dc (map down bs)) (down x)
-        
-
-mapBoundAtDepthTLets
-        :: Ord n
-        => (Int -> Bound n -> Bound n)  -- ^ Number of levels to lift.
-        -> Int                          -- ^ Current binding depth.
-        -> Lets a n                     -- ^ Lift exp indices in this thing.
-        -> (Lets a n, Int)              -- ^ Lifted, and how much to increase depth by
-
-mapBoundAtDepthTLets f d lts
- = let down = mapBoundAtDepthT f d
-   in case lts of
-        LLet b x
-         ->     ( LLet (down b) (down x)
-                , 0)
-
-        LRec bs
-         -> let bs' = [ (b, mapBoundAtDepthT f d x) | (b, x) <- bs ]
-            in  (LRec bs', 0)
-
-        LPrivate bsT mT bsX
-         -> let inc  = countBAnons bsT
-                bsX' = map (mapBoundAtDepthT f (d + inc)) bsX
-            in  ( LPrivate bsT mT bsX'
-                , inc)
-
-        LWithRegion _
-         -> (lts, 0)
-
-
-countBAnons = length . filter isAnon
- where  isAnon (BAnon _) = True
-        isAnon _         = False
diff --git a/DDC/Core/Transform/LiftX.hs b/DDC/Core/Transform/LiftX.hs
deleted file mode 100644
--- a/DDC/Core/Transform/LiftX.hs
+++ /dev/null
@@ -1,170 +0,0 @@
-
--- | Lifting and lowering level-0 deBruijn indices in core things.
--- 
---   Level-0 indices are used for both value and witness variables.
-module DDC.Core.Transform.LiftX
-        ( liftX,        liftAtDepthX
-        , lowerX,       lowerAtDepthX
-        , MapBoundX(..))
-where
-import DDC.Core.Exp
-
-
--- Lift -----------------------------------------------------------------------
--- | Lift debruijn indices less than or equal to the given depth.
-liftAtDepthX   
-        :: MapBoundX c n
-        => Int          -- ^ Number of levels to lift.
-        -> Int          -- ^ Current binding depth.
-        -> c n          -- ^ Lift expression indices in this thing.
-        -> c n
-
-liftAtDepthX n d
- = {-# SCC liftAtDepthX #-} 
-   mapBoundAtDepthX liftU d
- where  
-        liftU d' u
-         = case u of
-                UName{}         -> u
-                UPrim{}         -> u
-                UIx i
-                 | d' <= i      -> UIx (i + n)
-                 | otherwise    -> u
-
-
--- | Wrapper for `liftAtDepthX` that starts at depth 0.       
-liftX   :: MapBoundX c n => Int -> c n -> c n
-liftX n xx  = liftAtDepthX n 0 xx
-
-
--- Lower ----------------------------------------------------------------------
--- | Lower debruijn indices less than or equal to the given depth.
-lowerAtDepthX   
-        :: MapBoundX c n
-        => Int          -- ^ Number of levels to lower.
-        -> Int          -- ^ Current binding depth.
-        -> c n          -- ^ Lower expression indices in this thing.
-        -> c n
-
-lowerAtDepthX n d
- = {-# SCC lowerAtDepthX #-}
-   mapBoundAtDepthX liftU d
- where  
-        liftU d' u
-         = case u of
-                UName{}         -> u
-                UPrim{}         -> u
-                UIx i
-                 | d' <= i      -> UIx (i - n)
-                 | otherwise    -> u
-
-
--- | Wrapper for `lowerAtDepthX` that starts at depth 0.       
-lowerX   :: MapBoundX c n => Int -> c n -> c n
-lowerX n xx  = lowerAtDepthX n 0 xx
-
-
--- MapBoundX ------------------------------------------------------------------
-class MapBoundX (c :: * -> *) n where
- -- | Apply a function to all bound variables in the program.
- --   The function is passed the current binding depth.
- --   This is used to defined both `liftX` and `lowerX`.
- mapBoundAtDepthX
-        :: (Int -> Bound n -> Bound n)  -- ^ Function to apply to the bound occ.
-                                        --   It is passed the current binding depth.
-        -> Int                          -- ^ Current binding depth.
-        -> c n                          -- ^ Lift expression indices in this thing.
-        -> c n
-
-
-instance MapBoundX Bound n where
- mapBoundAtDepthX f d u
-        = f d u
-
-
-instance MapBoundX (Exp a) n where
- mapBoundAtDepthX f d xx
-  = let down = mapBoundAtDepthX f d
-    in case xx of
-        XVar a u        -> XVar a (f d u)
-        XCon{}          -> xx
-        XApp a x1 x2    -> XApp a (down x1) (down x2)
-        XLAM a b x      -> XLAM a b (down x)
-        XLam a b x      -> XLam a b (mapBoundAtDepthX f (d + countBAnons [b]) x)
-         
-        XLet a lets x   
-         -> let (lets', levels) = mapBoundAtDepthXLets f d lets 
-            in  XLet a lets' (mapBoundAtDepthX f (d + levels) x)
-
-        XCase a x alts  -> XCase a (down x)  (map down alts)
-        XCast a cc x    -> XCast a (down cc) (down x)
-        XType{}         -> xx
-        XWitness a w	-> XWitness a (down w)
-
-
-instance MapBoundX (Witness a) n where
- mapBoundAtDepthX f d ww
-  = let down = mapBoundAtDepthX f d
-    in case ww of
-        WVar  a u       -> WVar  a (down u)
-	WCon  _ _       -> ww
-	WApp  a w1 w2   -> WApp  a (down w1) (down w2)
-	WJoin a w1 w2   -> WJoin a (down w1) (down w2)
-	WType _ _       -> ww
-
-
-instance MapBoundX (Cast a) n where
- mapBoundAtDepthX f d cc
-  = case cc of
-        CastWeakenEffect{}      
-         -> cc
-
-        CastWeakenClosure xs    
-         -> CastWeakenClosure (map (mapBoundAtDepthX f d) xs)
-
-        CastPurify w    -> CastPurify w
-        CastForget w    -> CastForget w
-        CastBox         -> CastBox
-        CastRun         -> CastRun
-
-
-instance MapBoundX (Alt a) n where
- mapBoundAtDepthX f d (AAlt p x)
-  = case p of
-	PDefault 
-         -> AAlt PDefault (mapBoundAtDepthX f d x)
-
-	PData _ bs 
-         -> let d' = d + countBAnons bs
-	    in  AAlt p (mapBoundAtDepthX f d' x)
-        
-
-mapBoundAtDepthXLets
-        :: (Int -> Bound n -> Bound n)  -- ^ Number of levels to lift.
-        -> Int                          -- ^ Current binding depth.
-        -> Lets a n                     -- ^ Lift exp indices in this thing.
-        -> (Lets a n, Int)              -- ^ Lifted, and how much to increase depth by
-
-mapBoundAtDepthXLets f d lts
- = case lts of
-        LLet b x
-         -> let inc = countBAnons [b]
-                
-		-- non-recursive binding: do not increase x's depth
-                x'  = mapBoundAtDepthX f d x
-            in  (LLet b x', inc)
-
-        LRec bs
-         -> let inc = countBAnons (map fst bs)
-                bs' = map (\(b,e) -> (b, mapBoundAtDepthX f (d+inc) e)) bs
-            in  (LRec bs', inc)
-
-        LPrivate _b _ bs -> (lts, countBAnons bs)
-        LWithRegion _    -> (lts, 0)
-
-
-countBAnons = length . filter isAnon
- where	isAnon (BAnon _) = True
-	isAnon _	 = False
-
-
diff --git a/DDC/Core/Transform/MapT.hs b/DDC/Core/Transform/MapT.hs
--- a/DDC/Core/Transform/MapT.hs
+++ b/DDC/Core/Transform/MapT.hs
@@ -2,88 +2,116 @@
 module DDC.Core.Transform.MapT
         (mapT)
 where
-import DDC.Core.Exp
-import Control.Monad
+import DDC.Core.Exp.Annot.Exp
 
+type  MAPT m c n 
+        = (Type n -> m (Type n)) -> c n -> m (c n)
 
-class MapT (c :: * -> *) where
+
+class Monad m => MapT m (c :: * -> *) where
  -- | Apply a function to all possibly open types in a thing.
  --   Not the types of primitives because they're guaranteed to
  --   be closed.
- mapT :: (Type n -> Type n) -> c n -> c n
-
-
-instance MapT Bind  where
- mapT f b       
-  = case b of
-        BNone t         -> BNone (f t)
-        BAnon t         -> BAnon (f t)
-        BName n t       -> BName n (f t)
+ mapT :: forall n. MAPT m c n
 
 
-instance MapT Bound where
- mapT _ u       = u
-  
-
-instance MapT (Exp a) where
+instance Monad m => MapT m (Exp a) where
+ mapT :: forall n. MAPT  m (Exp a) n
  mapT f xx
-  = let down    = mapT f
+  = let down :: forall (c :: * -> *). (Monad m, MapT m c) => c n -> m (c n)
+        down = mapT f
     in case xx of  
-        XVar  a u       -> XVar  a u
-        XCon  a c       -> XCon  a c
-        XApp  a x1 x2   -> XApp  a (down x1)  (down x2)
-        XLAM  a b x     -> XLAM  a (down b)   (down x)
-        XLam  a b x     -> XLam  a (down b)   (down x)
-        XLet  a lts x   -> XLet  a (down lts) (down x)
-        XCase a x alts  -> XCase a (down x)   (map down alts)
-        XCast a cc x    -> XCast a (down cc)  (down x)
-        XType a t       -> XType a (f t)
-        XWitness a w    -> XWitness a (down w)
+        XVar  a u       -> pure (XVar a u)
+        XCon  a c       -> pure (XCon a c)
+        XApp  a x1 x2   -> XApp     a <$> down x1  <*> down x2
+        XLAM  a b x     -> XLAM     a <$> down b   <*> down x
+        XLam  a b x     -> XLam     a <$> down b   <*> down x
+        XLet  a lts x   -> XLet     a <$> down lts <*> down x
+        XCase a x alts  -> XCase    a <$> down x   <*> mapM down alts
+        XCast a cc x    -> XCast    a <$> down cc  <*> down x
+        XType a t       -> XType    a <$> f t
+        XWitness a w    -> XWitness a <$> down w
 
 
-instance MapT (Lets a) where
+instance Monad m => MapT m (Lets a) where
+ mapT :: forall n. MAPT m (Lets a) n
  mapT f lts
-  = let down    = mapT f
+  = let down :: forall (c :: * -> *). (Monad m, MapT m c) => c n -> m (c n)
+        down =  mapT f
     in case lts of
-        LLet b x          -> LLet (down b) (down x)
-        LRec bxs          -> LRec [ (down b, down x) | (b, x) <- bxs]
-        LPrivate bs mT ws -> LPrivate (map down bs) (liftM f mT) (map down ws)
-        LWithRegion u     -> LWithRegion u
 
+        LLet b x
+         -> LLet <$> down b <*> down x
 
-instance MapT (Alt a) where
+        LRec bxs
+         -> do  let (bs, xs)  = unzip bxs
+                bs'     <- mapM down bs
+                xs'     <- mapM down xs
+                return  $ LRec $ zip bs' xs'
+
+        LPrivate bs mT ws
+         -> do  bs'     <- mapM down bs
+                mT'     <- case mT of
+                                Nothing -> return Nothing
+                                Just t  -> fmap Just $ f t
+                ws'     <- mapM down ws
+
+                return  $ LPrivate bs' mT' ws'
+
+
+instance Monad m => MapT m (Alt a) where
+ mapT :: forall n. MAPT m (Alt a) n
  mapT f alt
-  = let down    = mapT f
+  = let down :: forall (c :: * -> *). (Monad m, MapT m c) => c n -> m (c n)
+        down =  mapT f
     in case alt of
-        AAlt u x        -> AAlt (down u) (down x)
+        AAlt u x        -> AAlt  <$> down u <*> down x
 
 
-instance MapT Pat where
+instance Monad m => MapT m Pat where
+ mapT :: forall n. MAPT m Pat n
  mapT f pat
-  = let down    = mapT f
+  = let down :: forall (c :: * -> *). (Monad m, MapT m c) => c n -> m (c n)
+        down =  mapT f
     in case pat of
-        PDefault        -> PDefault
-        PData dc bs     -> PData dc (map down bs)
+        PDefault        -> pure PDefault
+        PData dc bs     -> PData dc <$> mapM down bs
 
 
-instance MapT (Witness a) where
+instance Monad m => MapT m (Witness a) where
+ mapT :: forall n. MAPT m (Witness a) n
  mapT f ww
-  = let down    = mapT f
+  = let down :: forall (c :: * -> *). (Monad m, MapT m c)  => c n -> m (c n)
+        down =  mapT f
     in case ww of
-        WVar a u        -> WVar  a (down u)
-        WCon{}          -> ww
-        WApp  a w1 w2   -> WApp  a (down w1) (down w2)
-        WJoin a w1 w2   -> WJoin a (down w1) (down w2)
-        WType a t       -> WType a (f t)
+        WVar a u        -> WVar  a <$> down u
+        WCon{}          -> pure ww
+        WApp  a w1 w2   -> WApp  a <$> down w1 <*> down w2
+        WType a t       -> WType a <$> f t
 
 
-instance MapT (Cast a) where
+instance Monad m => MapT m (Cast a) where
+ mapT :: forall n. MAPT m  (Cast a) n
  mapT f cc
-  = let down    = mapT f
+  = let down :: forall (c :: * -> *). (Monad m, MapT m c) => c n -> m (c n)
+        down =  mapT f
     in case cc of
-        CastWeakenEffect t      -> CastWeakenEffect  t
-        CastWeakenClosure xs    -> CastWeakenClosure (map down xs)
-        CastPurify w            -> CastPurify  (down w)
-        CastForget w            -> CastForget  (down w)
-        CastBox                 -> CastBox
-        CastRun                 -> CastRun
+        CastWeakenEffect t      -> pure $ CastWeakenEffect  t
+        CastPurify w            -> CastPurify  <$> down w
+        CastBox                 -> pure CastBox
+        CastRun                 -> pure CastRun
+
+
+instance Monad m => MapT m Bind where
+ mapT f b       
+  = case b of
+        BNone t         -> BNone   <$> (f t)
+        BAnon t         -> BAnon   <$> (f t)
+        BName n t       -> BName n <$> (f t)
+
+
+instance Monad m => MapT m Bound where
+ mapT _ u       
+  = return u
+  
+
diff --git a/DDC/Core/Transform/Reannotate.hs b/DDC/Core/Transform/Reannotate.hs
--- a/DDC/Core/Transform/Reannotate.hs
+++ b/DDC/Core/Transform/Reannotate.hs
@@ -3,79 +3,90 @@
         (Reannotate (..))
 where
 import DDC.Core.Module
-import DDC.Core.Exp
+import DDC.Core.Exp.Annot.Exp
+import Control.Monad.Identity
 
 
 -- | Apply the given function to every annotation in a core thing.
 class Reannotate c where
- reannotate :: (a -> b) -> c a n -> c b n
+ reannotate  :: (a -> b) -> c a n -> c b n
+ reannotate f xx
+  = runIdentity (reannotateM (\x -> return $ f x) xx)
 
+ reannotateM :: forall m a b n. Monad m 
+             => (a -> m b) -> c a n -> m (c b n)
 
+
 instance Reannotate Module where
- reannotate f
-     (ModuleCore name 
+ reannotateM f
+     (ModuleCore name isHeader
                  exportKinds  exportTypes 
-                 importKinds  importTypes
+                 importKinds  importCaps   importTypes  importDataDefs
                  dataDefsLocal
                  body)
-  =   ModuleCore name
-                 exportKinds  exportTypes
-                 importKinds  importTypes
-                 dataDefsLocal
-                 (reannotate f body)
 
+  = do  body'   <- reannotateM f body
+        return  $  ModuleCore name isHeader
+                        exportKinds  exportTypes
+                        importKinds  importCaps   importTypes  importDataDefs
+                        dataDefsLocal
+                        body'
 
+
 instance Reannotate Exp where
- reannotate f xx
-  = let down x   = reannotate f x
+ reannotateM f xx
+  = let down x   = reannotateM f x
     in case xx of
-        XVar     a u            -> XVar     (f a) u
-        XCon     a u            -> XCon     (f a) u
-        XLAM     a b x          -> XLAM     (f a) b (down x)
-        XLam     a b x          -> XLam     (f a) b (down x)
-        XApp     a x1 x2        -> XApp     (f a)   (down x1)  (down x2)
-        XLet     a lts x        -> XLet     (f a)   (down lts) (down x)
-        XCase    a x alts       -> XCase    (f a)   (down x)   (map down alts)
-        XCast    a c x          -> XCast    (f a)   (down c)   (down x)
-        XType    a t            -> XType    (f a) t
-        XWitness a w            -> XWitness (f a)   (down w)
+        XVar     a u            -> XVar     <$> f a <*> pure u
+        XCon     a u            -> XCon     <$> f a <*> pure u
+        XLAM     a b x          -> XLAM     <$> f a <*> pure b <*> down x
+        XLam     a b x          -> XLam     <$> f a <*> pure b <*> down x
+        XApp     a x1 x2        -> XApp     <$> f a            <*> down x1  <*> down x2
+        XLet     a lts x        -> XLet     <$> f a            <*> down lts <*> down x
+        XCase    a x alts       -> XCase    <$> f a            <*> down x   <*> mapM down alts
+        XCast    a c x          -> XCast    <$> f a            <*> down c   <*> down x
+        XType    a t            -> XType    <$> f a <*> pure t
+        XWitness a w            -> XWitness <$> f a <*> down w
 
 
 instance Reannotate Lets where
- reannotate f xx
-  = let down x  = reannotate f x
+ reannotateM f xx
+  = let down x  = reannotateM f x
     in case xx of
-        LLet b x                -> LLet b (down x)
-        LRec bxs                -> LRec [(b, down x) | (b, x) <- bxs]
-        LPrivate b t bs         -> LPrivate b t bs
-        LWithRegion b           -> LWithRegion b
+        LLet b x
+         -> LLet <$> pure b <*> down x
 
+        LRec bxs 
+         -> do  let (bs, xs) = unzip bxs
+                xs'     <- mapM down xs
+                return  $ LRec $ zip bs xs'
 
+        LPrivate b t bs
+         -> return $ LPrivate b t bs
+
+
 instance Reannotate Alt where
- reannotate f aa
+ reannotateM f aa
   = case aa of
-        AAlt w x                -> AAlt w (reannotate f x)
+        AAlt w x                -> AAlt w <$> reannotateM f x
 
 
 instance Reannotate Cast where
- reannotate f cc
-  = let down x  = reannotate f x
+ reannotateM f cc
+  = let down x  = reannotateM f x
     in case cc of
-        CastWeakenEffect  eff   -> CastWeakenEffect eff
-        CastWeakenClosure xs    -> CastWeakenClosure (map down xs)
-        CastPurify w            -> CastPurify (down w)
-        CastForget w            -> CastForget (down w)
-        CastBox                 -> CastBox
-        CastRun                 -> CastRun
+        CastWeakenEffect eff    -> pure $ CastWeakenEffect eff
+        CastPurify w            -> CastPurify <$> down w
+        CastBox                 -> pure CastBox
+        CastRun                 -> pure CastRun
 
 
 instance Reannotate Witness where
- reannotate f ww
-  = let down x = reannotate f x
+ reannotateM f ww
+  = let down x = reannotateM f x
     in case ww of
-        WVar  a u               -> WVar  (f a) u
-        WCon  a c               -> WCon  (f a) c
-        WApp  a w1 w2           -> WApp  (f a) (down w1) (down w2)
-        WJoin a w1 w2           -> WJoin (f a) (down w1) (down w2)
-        WType a t               -> WType (f a) t
+        WVar  a u               -> WVar  <$> f a <*> pure u
+        WCon  a c               -> WCon  <$> f a <*> pure c
+        WApp  a w1 w2           -> WApp  <$> f a <*> down w1 <*> down w2
+        WType a t               -> WType <$> f a <*> pure t
 
diff --git a/DDC/Core/Transform/Rename.hs b/DDC/Core/Transform/Rename.hs
--- a/DDC/Core/Transform/Rename.hs
+++ b/DDC/Core/Transform/Rename.hs
@@ -17,7 +17,7 @@
         -- * Rewriting bound occurences
         , use1,  use0)
 where
-import DDC.Core.Exp
+import DDC.Core.Exp.Annot.Exp
 import DDC.Type.Transform.Rename
 
 
@@ -28,6 +28,5 @@
         WVar  a u       -> WVar  a (use0 sub u)
         WCon  a c       -> WCon  a c
         WApp  a w1 w2   -> WApp  a (down sub w1) (down sub w2)
-        WJoin a w1 w2   -> WJoin a (down sub w1) (down sub w2)
         WType a t       -> WType a (down sub t)
 
diff --git a/DDC/Core/Transform/SpreadX.hs b/DDC/Core/Transform/SpreadX.hs
--- a/DDC/Core/Transform/SpreadX.hs
+++ b/DDC/Core/Transform/SpreadX.hs
@@ -3,8 +3,7 @@
         (SpreadX(..))
 where
 import DDC.Core.Module
-import DDC.Core.Exp
-import DDC.Core.Compounds
+import DDC.Core.Exp.Annot
 import DDC.Type.Transform.SpreadT
 import Control.Monad
 import DDC.Type.Env                     (Env)
@@ -25,24 +24,53 @@
 ---------------------------------------------------------------------------------------------------
 instance SpreadX (Module a) where
  spreadX kenv tenv mm@ModuleCore{}
-        = mm
-        { moduleExportTypes   = map (liftSnd $ spreadT kenv)      (moduleExportTypes   mm)
-        , moduleExportValues  = map (liftSnd $ spreadT kenv)      (moduleExportValues  mm)
+  = let liftSnd f (x, y) = (x, f y)
+    in  ModuleCore
+        { moduleName            
+                = moduleName mm
+
+        , moduleIsHeader        
+                = moduleIsHeader mm
+
+        , moduleExportTypes     
+                = map (liftSnd $ spreadT kenv)
+                $ moduleExportTypes mm
+
+        , moduleExportValues    
+                = map (liftSnd $ spreadT kenv)
+                $ moduleExportValues mm
           
-        , moduleImportTypes   = map (liftSnd $ spreadX kenv tenv) (moduleImportTypes   mm)
-        , moduleImportValues  = map (liftSnd $ spreadX kenv tenv) (moduleImportValues  mm)
-  
-        , moduleDataDefsLocal = map    (spreadT kenv)             (moduleDataDefsLocal mm)
+        , moduleImportTypes     
+                = map (liftSnd $ spreadX kenv tenv) 
+                $ moduleImportTypes mm
+
+        , moduleImportCaps
+                = map (liftSnd $ spreadX kenv tenv)
+                $ moduleImportCaps mm
+
+        , moduleImportValues    
+                = map (liftSnd $ spreadX kenv tenv) 
+                $ moduleImportValues mm
+
+        , moduleImportDataDefs  
+                = map (spreadT kenv)
+                $ moduleImportDataDefs mm
+
+        , moduleDataDefsLocal   
+                = map (spreadT kenv)
+                $ moduleDataDefsLocal mm
   
-        , moduleBody          = spreadX kenv tenv (moduleBody mm) }
-        where liftSnd f (x, y) = (x, f y)
+        , moduleBody           
+                 = spreadX kenv tenv
+                 $ moduleBody mm 
+        }
 
 
 ---------------------------------------------------------------------------------------------------
 instance SpreadT ExportSource where
  spreadT kenv esrc
   = case esrc of
-        ExportSourceLocal n t
+        ExportSourceLocal n t   
          -> ExportSourceLocal n (spreadT kenv t)
 
         ExportSourceLocalNoType n
@@ -50,20 +78,36 @@
 
 
 ---------------------------------------------------------------------------------------------------
-instance SpreadX ImportSource where
+instance SpreadX ImportType where
  spreadX kenv _tenv isrc
   = case isrc of
-        ImportSourceAbstract t  
-         -> ImportSourceAbstract (spreadT kenv t)
+        ImportTypeAbstract t
+         -> ImportTypeAbstract (spreadT kenv t)
 
-        ImportSourceModule mn n t
-         -> ImportSourceModule   mn n (spreadT kenv t)
+        ImportTypeBoxed t
+         -> ImportTypeBoxed    (spreadT kenv t)
 
-        ImportSourceSea n t
-         -> ImportSourceSea n (spreadT kenv t)
 
+---------------------------------------------------------------------------------------------------
+instance SpreadX ImportCap where
+ spreadX kenv _tenv isrc
+  = case isrc of
+        ImportCapAbstract t
+         -> ImportCapAbstract   (spreadT kenv t)
 
+
 ---------------------------------------------------------------------------------------------------
+instance SpreadX ImportValue where
+ spreadX kenv _tenv isrc
+  = case isrc of
+        ImportValueModule mn n t mArity
+         -> ImportValueModule   mn n (spreadT kenv t) mArity
+
+        ImportValueSea n t
+         -> ImportValueSea n    (spreadT kenv t)
+
+
+---------------------------------------------------------------------------------------------------
 instance SpreadX (Exp a) where
  spreadX kenv tenv xx 
   = {-# SCC spreadX #-}
@@ -123,9 +167,7 @@
   = let down x = spreadX kenv tenv x
     in case cc of
         CastWeakenEffect eff    -> CastWeakenEffect  (spreadT kenv eff)
-        CastWeakenClosure xs    -> CastWeakenClosure (map down xs)
         CastPurify w            -> CastPurify        (down w)
-        CastForget w            -> CastForget        (down w)
         CastBox                 -> CastBox
         CastRun                 -> CastRun
 
@@ -171,10 +213,7 @@
                 bs'      = map (spreadX kenv' tenv) bs
             in  LPrivate b' mT' bs'
 
-        LWithRegion b
-         -> LWithRegion (spreadX kenv tenv b)
 
-
 ---------------------------------------------------------------------------------------------------
 instance SpreadX (Witness a) where
  spreadX kenv tenv ww
@@ -183,7 +222,6 @@
         WCon  a wc       -> WCon  a (down wc)
         WVar  a u        -> WVar  a (down u)
         WApp  a w1 w2    -> WApp  a (down w1) (down w2)
-        WJoin a w1 w2    -> WJoin a (down w1) (down w2)
         WType a t1       -> WType a (spreadT kenv t1)
 
 
diff --git a/DDC/Core/Transform/SubstituteTX.hs b/DDC/Core/Transform/SubstituteTX.hs
--- a/DDC/Core/Transform/SubstituteTX.hs
+++ b/DDC/Core/Transform/SubstituteTX.hs
@@ -11,7 +11,7 @@
         , substituteBoundTX)
 where
 import DDC.Core.Collect
-import DDC.Core.Exp
+import DDC.Core.Exp.Annot.Exp
 import DDC.Type.Compounds
 import DDC.Type.Transform.SubstituteT
 import DDC.Type.Transform.Rename
@@ -103,9 +103,6 @@
                 x2'             = down   sub2 x2
             in  XLet a (LPrivate b' mT' bs') x2'
 
-        XLet a (LWithRegion uR) x2
-         -> XLet a (LWithRegion uR) (down sub x2)
-
         XCase a x1 alts -> XCase    a (down sub x1) (map (down sub) alts)
         XCast a cc x1   -> XCast    a (down sub cc) (down sub x1)
         XType    a t    -> XType    a (down sub t)
@@ -130,9 +127,7 @@
   = let down x   = substituteWithTX tArg x
     in case cc of
         CastWeakenEffect eff    -> CastWeakenEffect  (down sub eff)
-        CastWeakenClosure clo   -> CastWeakenClosure (map (down sub) clo)
         CastPurify w            -> CastPurify        (down sub w)
-        CastForget w            -> CastForget        (down sub w)
         CastBox                 -> CastBox
         CastRun                 -> CastRun
 
@@ -144,7 +139,6 @@
         WVar  a u               -> WVar  a u
         WCon{}                  -> ww
         WApp  a w1 w2           -> WApp  a (down sub w1) (down sub w2)
-        WJoin a w1 w2           -> WJoin a (down sub w1) (down sub w2)
         WType a t               -> WType a (down sub t)
 
 
diff --git a/DDC/Core/Transform/SubstituteWX.hs b/DDC/Core/Transform/SubstituteWX.hs
--- a/DDC/Core/Transform/SubstituteWX.hs
+++ b/DDC/Core/Transform/SubstituteWX.hs
@@ -9,10 +9,10 @@
         , substituteWX
         , substituteWXs)
 where
-import DDC.Core.Exp
+import DDC.Core.Exp.Annot.Exp
 import DDC.Core.Collect
 import DDC.Core.Transform.Rename
-import DDC.Core.Transform.LiftX
+import DDC.Core.Transform.BoundX
 import DDC.Type.Compounds
 import Data.Maybe
 import qualified DDC.Type.Env   as Env
@@ -109,9 +109,6 @@
                 mT'             = liftM (into sub) mT
             in  XLet a (LPrivate b' mT' bs') x2'
 
-        XLet a (LWithRegion uR) x2
-         -> XLet a (LWithRegion uR) (down sub x2)
-
         XCase    a x1 alts      -> XCase    a (down sub x1) (map (down sub) alts)
         XCast    a cc x1        -> XCast    a (down sub cc) (down sub x1)
         XType    a t            -> XType    a (into sub t)
@@ -137,9 +134,7 @@
         into s x = renameWith s x
     in case cc of
         CastWeakenEffect eff    -> CastWeakenEffect  (into sub eff)
-        CastWeakenClosure xs    -> CastWeakenClosure (map (down sub) xs)
         CastPurify w            -> CastPurify        (down sub w)
-        CastForget w            -> CastForget        (down sub w)
         CastBox                 -> CastBox
         CastRun                 -> CastRun
 
@@ -156,7 +151,6 @@
 
         WCon{}                  -> ww
         WApp  a w1 w2           -> WApp  a (down sub w1) (down sub w2)
-        WJoin a w1 w2           -> WJoin a (down sub w1) (down sub w2)
         WType a t               -> WType a (into sub t)
 
 
diff --git a/DDC/Core/Transform/SubstituteXX.hs b/DDC/Core/Transform/SubstituteXX.hs
--- a/DDC/Core/Transform/SubstituteXX.hs
+++ b/DDC/Core/Transform/SubstituteXX.hs
@@ -11,9 +11,9 @@
         , substituteXArg
         , substituteXArgs)
 where
-import DDC.Core.Exp
+import DDC.Core.Exp.Annot.Exp
 import DDC.Core.Collect
-import DDC.Core.Transform.LiftX
+import DDC.Core.Transform.BoundX
 import DDC.Type.Compounds
 import DDC.Core.Transform.SubstituteWX
 import DDC.Core.Transform.SubstituteTX
@@ -143,9 +143,6 @@
                 x2'             = down   sub2 x2
             in  XLet a (LPrivate b' mT' bs') x2'
 
-        XLet a (LWithRegion uR) x2
-         -> XLet a (LWithRegion uR) (down sub x2)
-
         XCase    a x1 alts      -> XCase    a (down sub x1) (map (down sub) alts)
         XCast    a cc x1        -> XCast    a (down sub cc) (down sub x1)
         XType    a t            -> XType    a (into sub t)
@@ -166,14 +163,11 @@
 
 
 instance SubstituteXX Cast where
- substituteWithXX xArg sub cc
-  = let down s x = substituteWithXX xArg s x
-        into s x = renameWith s x
+ substituteWithXX _xArg sub cc
+  = let into s x = renameWith s x
     in case cc of
         CastWeakenEffect eff    -> CastWeakenEffect  (into sub eff)
-        CastWeakenClosure xs    -> CastWeakenClosure (map (down sub) xs)
         CastPurify w            -> CastPurify (into sub w)
-        CastForget w            -> CastForget (into sub w)
         CastBox                 -> CastBox
         CastRun                 -> CastRun
 
diff --git a/DDC/Core/Transform/Trim.hs b/DDC/Core/Transform/Trim.hs
deleted file mode 100644
--- a/DDC/Core/Transform/Trim.hs
+++ /dev/null
@@ -1,112 +0,0 @@
-
--- | Trim the expressions passed to @weakclo@ casts to just those terms
---   that can affect the closure of the body. 
---
-module DDC.Core.Transform.Trim
-        ( trimX, trimClosures )
-where
-import DDC.Core.Collect()
-import DDC.Type.Collect
-import DDC.Core.Exp
-import DDC.Type.Env
-import DDC.Core.Transform.Reannotate
-import Data.List                (nubBy)
-
-
--- | Trim the expressions of a weaken closure @(XCast CastWeakenClosure)@
---   into only the free variables.
---
---   For example,
---    @trimClosures [build (\k z. something k), else]
---       = [build, something, else]
---    @
-trimClosures
-        :: (Ord n)
-        => a
-        -> [Exp a n]
-        -> [Exp a n]
-
-trimClosures a xs
- = {-# SCC trimClosures #-}
-   nub' $ concatMap (freeExp a empty empty) xs
- where  nub' = nubBy (\x y -> reannotate (const ()) x == reannotate (const ()) y)
-
-
--- | Trim an expression if it is a @weakclo@ cast. 
---
---   Non-recursive version. If you want to recursively trim closures,
---   use @transformUpX' (const trimX)@.
-trimX   :: (Ord n)
-        => Exp a n
-        -> Exp a n
-trimX (XCast a (CastWeakenClosure ws) in_)
- = XCast a (CastWeakenClosure $ trimClosures a ws) in_
-
-trimX x
- = x
-
-
--- freeExp --------------------------------------------------------------------
--- | Collect all the free variables, but return them all as expressions:
---   eg
---   @
---     freeExp 
---       (let i = 5 [R0#] () in
---        updateInt [:R0# R1#:] <w> i ...)
---
---     will return something like
---       [ XType (TCon R0#)
---       , XVar updateInt
---       , XType (TCon R0#)
---       , XType (TCon R1#)
---       , XWitness w ]
---   @
-freeExp :: (BindStruct c, Ord n) 
-        => a
-        -> Env n
-        -> Env n
-        -> c n
-        -> [Exp a n]
-freeExp a kenv tenv xx 
- = concatMap (freeOfTreeExp a kenv tenv) $ slurpBindTree xx
-
-freeOfTreeExp
-        :: Ord n
-        => a
-        -> Env n
-        -> Env n
-        -> BindTree n
-        -> [Exp a n]
-freeOfTreeExp a kenv tenv tt
- = case tt of
-        BindDef way bs ts
-         |  isBoundExpWit $ boundLevelOfBindWay way
-         ,  tenv'        <- extends bs tenv
-         -> concatMap (freeOfTreeExp a kenv tenv') ts
-
-        BindDef way bs ts
-         |  BoundSpec    <- boundLevelOfBindWay way
-         ,  kenv'        <- extends bs kenv
-         -> concatMap (freeOfTreeExp a kenv' tenv) ts
-
-        BindDef _ _ ts
-         -> concatMap (freeOfTreeExp a kenv tenv) ts
-
-        BindUse BoundExp u
-         | member u tenv     -> []
-         | otherwise         -> [XVar a u]
-
-        BindUse BoundWit u
-         | member u tenv     -> []
-         | otherwise         -> [XWitness a (WVar a u)]
-
-        BindUse BoundSpec u
-         | member u kenv     -> []
-         | otherwise         -> [XType a (TVar u)]
-
-        BindCon BoundSpec u (Just k)
-         | member u kenv     -> []
-         | otherwise         -> [XType a (TCon (TyConBound u k))]
-
-        _                    -> []
-
diff --git a/DDC/Type/Check/Base.hs b/DDC/Type/Check/Base.hs
--- a/DDC/Type/Check/Base.hs
+++ b/DDC/Type/Check/Base.hs
@@ -3,6 +3,8 @@
         ( CheckM
         , newExists
         , newPos
+        , applyContext
+        , applySolved
 
         , throw
 
@@ -21,8 +23,9 @@
 import DDC.Type.Equiv
 import DDC.Type.Exp
 import DDC.Base.Pretty
-import qualified DDC.Control.Monad.Check as G
 import DDC.Control.Monad.Check           (throw)
+import qualified Data.Set               as Set
+import qualified DDC.Control.Monad.Check as G
 
 
 -- | The type checker monad.
@@ -48,3 +51,25 @@
         return  (Pos pos)
 
 
+-- | Apply the checker context to a type.
+applyContext :: Ord n => Context n -> Type n -> CheckM n (Type n)
+applyContext ctx tt
+ = case applyContextEither ctx Set.empty tt of
+
+        -- We found an infinite path when trying to complete this
+        -- substitution. We get back the existential and the type for it.
+        Left  (tExt, tBind) 
+                -> throw $ ErrorInfinite tExt tBind
+        Right t -> return t
+
+
+-- | Substitute solved constraints into a type.
+applySolved :: Ord n => Context n -> Type n -> CheckM n (Type n)
+applySolved ctx tt
+ = case applySolvedEither ctx Set.empty tt of
+
+        -- We found an infinite path when trying to complete this
+        -- substitution. We get back the existential and the type for it.
+        Left  (tExt, tBind)
+                -> throw $ ErrorInfinite tExt tBind
+        Right t -> return t
diff --git a/DDC/Type/Check/CheckCon.hs b/DDC/Type/Check/CheckCon.hs
--- a/DDC/Type/Check/CheckCon.hs
+++ b/DDC/Type/Check/CheckCon.hs
@@ -44,17 +44,11 @@
  = case tc of
         TwConImpl       -> kWitness  `kFun`  kWitness `kFun` kWitness
         TwConPure       -> kEffect   `kFun`  kWitness
-        TwConEmpty      -> kClosure  `kFun`  kWitness
-        TwConGlobal     -> kRegion   `kFun`  kWitness
-        TwConDeepGlobal -> kData     `kFun`  kWitness
         TwConConst      -> kRegion   `kFun`  kWitness
         TwConDeepConst  -> kData     `kFun`  kWitness
         TwConMutable    -> kRegion   `kFun`  kWitness
         TwConDeepMutable-> kData     `kFun`  kWitness
-        TwConLazy       -> kRegion   `kFun`  kWitness
-        TwConHeadLazy   -> kData     `kFun`  kWitness
-        TwConManifest   -> kRegion   `kFun`  kWitness
-        TwConDisjoint	-> kEffect   `kFun`  kEffect  `kFun`  kWitness
+        TwConDisjoint   -> kEffect   `kFun`  kEffect  `kFun`  kWitness
         TwConDistinct n -> (replicate n kRegion)      `kFuns` kWitness        
 
 
@@ -64,7 +58,6 @@
  = case tc of
         TcConUnit       -> kData
         TcConFun        -> kData    `kFun` kData `kFun` kData
-        TcConFunEC      -> [kData, kEffect, kClosure, kData] `kFuns` kData
         TcConSusp       -> kEffect  `kFun` kData `kFun` kData
         TcConRead       -> kRegion  `kFun` kEffect
         TcConHeadRead   -> kData    `kFun` kEffect
@@ -73,7 +66,4 @@
         TcConDeepWrite  -> kData    `kFun` kEffect
         TcConAlloc      -> kRegion  `kFun` kEffect
         TcConDeepAlloc  -> kData    `kFun` kEffect
-        TcConUse        -> kRegion  `kFun` kClosure
-        TcConDeepUse    -> kData    `kFun` kClosure
-
 
diff --git a/DDC/Type/Check/Config.hs b/DDC/Type/Check/Config.hs
--- a/DDC/Type/Check/Config.hs
+++ b/DDC/Type/Check/Config.hs
@@ -5,6 +5,7 @@
 where
 import DDC.Type.DataDef
 import DDC.Type.Env                     (KindEnv, TypeEnv)
+import qualified DDC.Type.Env           as Env
 import qualified DDC.Core.Fragment      as F
 
 
@@ -23,9 +24,20 @@
           -- | Types of primitive operators.
         , configPrimTypes               :: TypeEnv n
 
-        -- | Data type definitions.
+          -- | Data type definitions.
         , configDataDefs                :: DataDefs n  
 
+          -- | Types of globally available capabilities.
+          --
+          --   The inferred types of computations do not contain these
+          --   capabilities as they are always available and thus do not
+          --   need to be tracked in types.
+        , configGlobalCaps              :: TypeEnv n
+
+          -- | This name represents some hole in the expression that needs
+          --   to be filled in by the type checker.
+        , configNameIsHole              :: Maybe (n -> Bool) 
+
           -- | Track effect type information.
         , configTrackedEffects          :: Bool
 
@@ -41,36 +53,37 @@
           -- | Treat effects as capabilities.
         , configEffectCapabilities      :: Bool 
 
-          -- | This name represents some hole in the expression that needs
-          --   to be filled in by the type checker.
-        , configNameIsHole              :: Maybe (n -> Bool) }
+          -- | Allow general let-rec
+        , configGeneralLetRec           :: Bool
 
+          -- | Automatically run effectful applications.
+        , configImplicitRun             :: Bool
 
+          -- | Automatically box bodies of abstractions.
+        , configImplicitBox             :: Bool
+        }
 
--- | Convert a langage profile to a type checker configuration.
+
+-- | Convert a language profile to a type checker configuration.
 configOfProfile :: F.Profile n -> Config n
 configOfProfile profile
-        = Config
-        { configPrimKinds          = F.profilePrimKinds  profile
-        , configPrimTypes          = F.profilePrimTypes  profile
-
-        , configDataDefs           = F.profilePrimDataDefs profile
+ = let  features        = F.profileFeatures profile
+   in   Config
+        { configPrimKinds               = F.profilePrimKinds            profile
+        , configPrimTypes               = F.profilePrimTypes            profile
+        , configDataDefs                = F.profilePrimDataDefs         profile
+        , configGlobalCaps              = Env.empty
+        , configNameIsHole              = F.profileNameIsHole           profile 
         
-        , configTrackedEffects     = F.featuresTrackedEffects
-                                   $ F.profileFeatures profile
-
-        , configTrackedClosures    = F.featuresTrackedClosures
-                                   $ F.profileFeatures profile
-
-        , configFunctionalEffects  = F.featuresFunctionalEffects
-                                   $ F.profileFeatures profile
-
-        , configFunctionalClosures = F.featuresFunctionalClosures
-                                   $ F.profileFeatures profile 
-
-        , configEffectCapabilities = F.featuresEffectCapabilities
-                                   $ F.profileFeatures profile
+        , configTrackedEffects          = F.featuresTrackedEffects      features
+        , configTrackedClosures         = F.featuresTrackedClosures     features
+        , configFunctionalEffects       = F.featuresFunctionalEffects   features
+        , configFunctionalClosures      = F.featuresFunctionalClosures  features
+        , configEffectCapabilities      = F.featuresEffectCapabilities  features
+        , configGeneralLetRec           = F.featuresGeneralLetRec       features
+        , configImplicitRun             = F.featuresImplicitRun         features
+        , configImplicitBox             = F.featuresImplicitBox         features
 
-        , configNameIsHole         = F.profileNameIsHole profile }
+        }
         
 
diff --git a/DDC/Type/Check/Context.hs b/DDC/Type/Check/Context.hs
--- a/DDC/Type/Check/Context.hs
+++ b/DDC/Type/Check/Context.hs
@@ -31,8 +31,8 @@
         , locationOfExists
         , updateExists
 
-        , applyContext
-        , applySolved
+        , applyContextEither
+        , applySolvedEither
         , effectSupported
 
         , liftTypes
@@ -40,13 +40,17 @@
 where
 import DDC.Type.Exp
 import DDC.Type.Pretty
-import DDC.Type.Transform.LiftT
+import DDC.Type.Transform.BoundT
+import DDC.Type.Equiv
 import DDC.Type.Compounds
 import DDC.Base.Pretty                  ()
 import Data.Maybe
 import qualified DDC.Type.Sum           as Sum
 import qualified Data.IntMap.Strict     as IntMap
 import Data.IntMap.Strict               (IntMap)
+import qualified Data.Set               as Set
+import Data.Set                         (Set)
+import Prelude                          hiding ((<$>))
 
 
 -- Mode -----------------------------------------------------------------------
@@ -466,73 +470,94 @@
 -- | Apply a context to a type, updating any existentials in the type. This
 --   uses just the solved constraints on the stack, but not in the solved set.
 --
---   This function is used during the algorithm proper, whereas we use
---   `applySolved` below to update annotations in the larger program after
---   type inference has completed.
-applyContext :: Ord n => Context n -> Type n -> Type n
-applyContext ctx tt
+--   If we find a loop through the existential equations then 
+--   return `Left` the existential and what is was locally bound to.
+applyContextEither
+        :: Ord n 
+        => Context n    -- ^ Type checker context.
+        -> Set Int      -- ^ Indexes of existentials we've already entered.
+        -> Type n       -- ^ Type to apply context to.
+        -> Either (Type n, Type n) (Type n)
+
+applyContextEither ctx is tt
  = case tt of
-        TVar{}          -> tt
+        TVar{}          
+         ->     return tt
 
         TCon (TyConExists i k)  
          |  Just t      <- lookupExistsEq (Exists i k) ctx
-         -> applyContext ctx t
+         -> if Set.member i is 
+                then Left (tt, t)
+                else applyContextEither ctx (Set.insert i is) t
 
-        TCon{}          -> tt
+        TCon{}
+         ->     return tt
 
         TForall b t     
-         -> let tb'     = applySolved ctx (typeOfBind b)
-                b'      = replaceTypeOfBind tb' b
-                t'      = applySolved ctx t
-            in  TForall b' t'
+         -> do  tb'     <- applySolvedEither ctx is (typeOfBind b)
+                let b'  =  replaceTypeOfBind tb' b
+                t'      <- applySolvedEither ctx is t
+                return $ TForall b' t'
 
         TApp t1 t2
-         -> let t1'     = applySolved ctx t1
-                t2'     = applySolved ctx t2
-            in  TApp t1' t2'
+         -> do  t1'     <- applySolvedEither ctx is t1
+                t2'     <- applySolvedEither ctx is t2
+                return  $ TApp t1' t2'
 
         TSum ts         
-         -> TSum $ Sum.fromList (Sum.kindOfSum ts) 
-                 $ map (applyContext ctx)
-                 $ Sum.toList ts
+         -> do  tss'    <- mapM (applyContextEither ctx is) 
+                        $  Sum.toList ts
 
+                return  $ TSum
+                        $ Sum.fromList (Sum.kindOfSum ts) tss'
 
--- | Apply the solved constraints in a context to a type, updating any
---   existentials in the type. This uses constraints on the stack as well
---   as in the solved constraints set.
---   
---   This function is used after the algorithm proper, to update existentials
---   in annotations in the larger program.
-applySolved :: Ord n => Context n -> Type n -> Type n
-applySolved ctx tt
+
+-- | Like `applyContextEither`, but for the solved types.
+applySolvedEither
+        :: Ord n 
+        => Context n    -- ^ Type checker context.
+        -> Set Int      -- ^ Indexes of existentials we've already entered.
+        -> Type n       -- ^ Type to apply context to.
+        -> Either (Type n, Type n) (Type n)
+
+applySolvedEither ctx is tt
  = case tt of
-        TVar{}          -> tt
+        TVar{}          
+         ->     return tt
 
         TCon (TyConExists i k)
-         | Just t       <- IntMap.lookup i (contextSolved ctx)
-         -> applySolved ctx t
+         |  Just t       <- IntMap.lookup i (contextSolved ctx)
+         -> if Set.member i is 
+                then Left (tt, t)
+                else applySolvedEither ctx (Set.insert i is) t
 
-         | Just t       <- lookupExistsEq (Exists i k) ctx
-         -> applySolved ctx t
+         |  Just t       <- lookupExistsEq (Exists i k) ctx
+         -> if Set.member i is
+                then Left (tt, t)
+                else applySolvedEither ctx (Set.insert i is) t
 
-        TCon {}         -> tt
+        TCon {}
+         ->     return tt
+
         TForall b t
-         -> let tb'     = applySolved ctx (typeOfBind b)     
-                b'      = replaceTypeOfBind tb' b
-                t'      = applySolved ctx t
-             in TForall b' t'
+         -> do  tb'     <- applySolvedEither ctx is (typeOfBind b)     
+                let b'  =  replaceTypeOfBind tb' b
+                t'      <- applySolvedEither ctx is t
+                return  $ TForall b' t'
 
         TApp t1 t2      
-         -> let t1'     = applySolved ctx t1
-                t2'     = applySolved ctx t2
-            in  TApp t1' t2'
+         -> do  t1'     <- applySolvedEither ctx is t1
+                t2'     <- applySolvedEither ctx is t2
+                return  $ TApp t1' t2'
 
         TSum ts
-         -> TSum $ Sum.fromList (Sum.kindOfSum ts)
-                 $ map (applySolved ctx)
-                 $ Sum.toList ts
+         -> do  tss'    <- mapM (applySolvedEither ctx is)
+                        $  Sum.toList ts
 
+                return  $  TSum
+                        $  Sum.fromList (Sum.kindOfSum ts) tss'
 
+
 -- Support --------------------------------------------------------------------
 -- | Check whether this effect is supported by the given context.
 --   This is used when effects are treated as capabilities.
@@ -542,7 +567,7 @@
 --    or `Just e`, where `e` is some unsuported atomic effect.
 --
 effectSupported 
-        :: Ord n 
+        :: (Ord n, Show n)
         => Effect n 
         -> Context n 
         -> Maybe (Effect n)
@@ -558,25 +583,28 @@
         | TVar {} <- eff
         = Nothing
 
-        -- For an effect on an abstract region, we allow any capability.
-        --  We'll find out if it really has this capability when we try
-        --  to run the computation.
-        | TApp (TCon (TyConSpec tc)) (TVar u) <- eff
-        , elem tc [TcConRead, TcConWrite, TcConAlloc]
-        , Just (_, RoleAbstract) <- lookupKind u ctx
+        -- Abstract global effects are always supported.
+        | TCon (TyConBound _ k)                <- eff
+        , k == kEffect
         = Nothing
 
-        -- For an effect on a concrete region,
-        --   the capability needs to be in the lexical environment.
+        -- For an effects on concrete region,
+        -- the capability is supported if it's in the lexical environment.
         | TApp (TCon (TyConSpec tc)) _t2       <- eff
         , elem tc [TcConRead, TcConWrite, TcConAlloc]
-        , elem (ElemType (BNone eff)) (contextElems ctx)
+        , any   (\b -> equivT (typeOfBind b) eff) 
+                [ b | ElemType b <- contextElems ctx ] 
         = Nothing
 
-        -- Abstract global effects are always supported.
-        | TCon (TyConBound _ k)                <- eff
-        , k == kEffect
-        = Nothing
+        -- For an effect on an abstract region, we allow any capability.
+        --  We'll find out if it really has this capability when we try
+        --  to run the computation.
+        | TApp (TCon (TyConSpec tc)) (TVar u) <- eff
+        , elem tc [TcConRead, TcConWrite, TcConAlloc]
+        = case lookupKind u ctx of
+                Just (_, RoleConcrete)  -> Just eff
+                Just (_, RoleAbstract)  -> Nothing
+                Nothing                 -> Nothing
 
         | otherwise
         = Just eff
diff --git a/DDC/Type/Check/Error.hs b/DDC/Type/Check/Error.hs
--- a/DDC/Type/Check/Error.hs
+++ b/DDC/Type/Check/Error.hs
@@ -24,6 +24,10 @@
         , errorExpected         :: Type n
         , errorChecking         :: Type n }
 
+        -- | Cannot construct infinite type.
+        | ErrorInfinite
+        { errorTypeVar          :: Type n
+        , errorTypeBind         :: Type n }
 
         -- Variables ----------------------------
         -- | An undefined type variable.
diff --git a/DDC/Type/Check/ErrorMessage.hs b/DDC/Type/Check/ErrorMessage.hs
--- a/DDC/Type/Check/ErrorMessage.hs
+++ b/DDC/Type/Check/ErrorMessage.hs
@@ -31,6 +31,9 @@
                 , empty
                 , text "with: "                         <> align (ppr tt) ]
 
+        ErrorInfinite tExt tBind
+         -> vcat [ text "Cannot construct infinite type."
+                 , text "  " <> ppr tExt <+> text "=" <+> ppr tBind ]
 
         -- Variables ----------------------------
         ErrorUndefined u
diff --git a/DDC/Type/Check/Judge/Eq.hs b/DDC/Type/Check/Judge/Eq.hs
--- a/DDC/Type/Check/Judge/Eq.hs
+++ b/DDC/Type/Check/Judge/Eq.hs
@@ -66,10 +66,10 @@
  | TApp tL1 tL2 <- tL
  , TApp tR1 tR2 <- tR
  = do
-        ctx1     <- makeEq config ctx0 tL1  tR1  err
-        let tL2' = applyContext ctx1 tL2
-        let tR2' = applyContext ctx1 tR2
-        ctx2     <- makeEq config ctx0 tL2' tR2' err
+        ctx1    <- makeEq config ctx0 tL1  tR1  err
+        tL2'    <- applyContext ctx1 tL2
+        tR2'    <- applyContext ctx1 tR2
+        ctx2    <- makeEq config ctx0 tL2' tR2' err
 
         return ctx2
 
diff --git a/DDC/Type/Check/Judge/Kind.hs b/DDC/Type/Check/Judge/Kind.hs
--- a/DDC/Type/Check/Judge/Kind.hs
+++ b/DDC/Type/Check/Judge/Kind.hs
@@ -142,17 +142,17 @@
          = throw $ ErrorUndefined u
 
    in do
-        kActual <- getActual
-        let kActual'    = applyContext ctx0 kActual
+        kActual  <- getActual
+        kActual' <- applyContext ctx0 kActual
 
         -- In Check mode we check the expected kind against the actual
         -- kind from the environment.
         case mode of
          Check kExpected
           -> do 
-                let kExpected'  = applyContext ctx0 kExpected
-                ctx1    <- makeEq config ctx0 kActual' kExpected'
-                        $  ErrorMismatch uni  kActual' kExpected' tt
+                kExpected' <- applyContext ctx0 kExpected
+                ctx1       <- makeEq config ctx0 kActual' kExpected'
+                           $  ErrorMismatch uni  kActual' kExpected' tt
 
                 return (tt, kActual', ctx1)
  
@@ -236,13 +236,13 @@
         -- Get the actual kind/sort of the constructor according to the 
         -- constructor definition.
         (tt', kActual)  <- getActual
-        let kActual'    =  applyContext ctx0 kActual
+        kActual'        <- applyContext ctx0 kActual
 
         case mode of
          -- If we have an expected kind then make the actual kind the same.
          Check kExpected
            -> do 
-                 let kExpected' = applyContext ctx0 kExpected
+                 kExpected' <- applyContext ctx0 kExpected
                  ctx1   <- makeEq config ctx0 kActual' kExpected'
                         $  ErrorMismatch uni  kActual' kExpected' tt
                  return (tt', kActual', ctx1)
@@ -267,7 +267,7 @@
         (t2', k2, ctx3) <- checkTypeM config kenv ctx2 UniverseSpec t2 Recon
 
         -- The body must have kind Data or Witness.
-        let k2'         = applyContext ctx3 k2
+        k2'             <- applyContext ctx3 k2
         when ( not (isDataKind k2')
             && not (isWitnessKind k2'))
          $ throw $ ErrorForallKindInvalid tt t2 k2'
@@ -292,14 +292,16 @@
 
         -- If the kind of the body is unconstrained then default it to Data.
         -- See [Note: Defaulting the kind of quantified types]
-        let k2' = applyContext ctx4 k2
+        k2' <- applyContext ctx4 k2
         (k2'', ctx5)
          <- if isTExists k2'
              then do
                 ctx5    <- makeEq config ctx4 k2' kData
                         $  ErrorMismatch uni  k2' kData tt
-                return (applyContext ctx5 k2', ctx5)
 
+                k2''    <- applyContext ctx5 k2'
+                return (k2'', ctx5)
+
              else do
                 return (k2', ctx4)
 
@@ -330,7 +332,7 @@
         -- kind are existentials then force them both to be data. Otherwise make
         -- the kind of the body the same as the expected kind.
         -- See [Note: Defaulting the kind of quantified types]
-        let k2' = applyContext ctx4 k2
+        k2' <- applyContext ctx4 k2
         (k2'', ctx5)
          <- if isTExists k2' && isTExists kExpected
              then do
@@ -339,13 +341,17 @@
 
                 ctx5    <- makeEq config ctx' k2' kData 
                         $  ErrorMismatch uni  k2' kData  tt
-                return (applyContext ctx5 k2', ctx5)
 
+                k2''    <- applyContext ctx5 k2'
+                return (k2'', ctx5)
+
              else do
                 ctx5    <- makeEq config ctx4 k2' kExpected
                         $  ErrorMismatch uni  k2' kExpected tt
-                return (applyContext ctx5 k2', ctx4)
 
+                k2''    <- applyContext ctx5 k2'
+                return (k2'', ctx4)
+
         -- The above horror show needs to have worked.
         when ( not (isDataKind k2'')
             && not (isWitnessKind k2''))
@@ -450,10 +456,9 @@
          <- checkTypeM config kenv ctx0 UniverseSpec tFn Synth
 
         -- Apply the argument to the function.
+        kFn'    <- applyContext ctx1 kFn
         (kResult, tArg', ctx2)
-         <- synthTAppArg config kenv ctx1
-                tFn' (applyContext ctx1 kFn )
-                tArg
+         <- synthTAppArg config kenv ctx1 tFn' kFn' tArg
 
         return (TApp tFn' tArg', kResult, ctx2)
 
@@ -464,10 +469,10 @@
          <- checkTypeM config kenv ctx0 UniverseSpec tt Synth
 
         -- Force the synthesised kind to be the same as the expected one.
-        let k1'         = applyContext ctx1 k1
-        let kExpected'  = applyContext ctx1 kExpected
-        ctx2    <- makeEq config ctx1         k1' kExpected'
-                $  ErrorMismatch UniverseSpec k1' kExpected' tt
+        k1'         <- applyContext ctx1 k1
+        kExpected'  <- applyContext ctx1 kExpected
+        ctx2        <- makeEq config ctx1         k1' kExpected'
+                    $  ErrorMismatch UniverseSpec k1' kExpected' tt
 
         return (t1', k1', ctx2)
 
@@ -511,9 +516,8 @@
          k : _ksMore
           -> do 
                 (ts'', _, ctx2)
-                 <- checkTypesM config kenv ctx1 UniverseSpec (Check k) ts
-
-                let k'  = applyContext ctx2 k
+                    <- checkTypesM config kenv ctx1 UniverseSpec (Check k) ts
+                k'  <- applyContext ctx2 k
                 return  (TSum (TS.fromList k' ts''), k', ctx2)
 
          -- If the sum does not contain an attached kind, and there are no elements
@@ -533,8 +537,8 @@
                 <- checkTypeM config kenv ctx0 UniverseSpec tt Synth
 
         -- Force the synthesised kind to match the expected one.
-        let k1'         = applyContext ctx1 k1
-        let kExpected'  = applyContext ctx1 kExpected
+        k1'         <- applyContext ctx1 k1
+        kExpected'  <- applyContext ctx1 kExpected
         ctx2    <- makeEq config ctx1         k1' kExpected'
                 $  ErrorMismatch UniverseSpec k1' kExpected' tt
 
diff --git a/DDC/Type/Collect.hs b/DDC/Type/Collect.hs
--- a/DDC/Type/Collect.hs
+++ b/DDC/Type/Collect.hs
@@ -26,85 +26,6 @@
 import Data.Set                         (Set)
 
 
--- freeT ----------------------------------------------------------------------
--- | Collect the free Spec variables in a thing (level-1).
-freeT   :: (BindStruct c, Ord n) 
-        => Env n -> c n -> Set (Bound n)
-freeT tenv xx = Set.unions $ map (freeOfTreeT tenv) $ slurpBindTree xx
-
-freeOfTreeT :: Ord n => Env n -> BindTree n -> Set (Bound n)
-freeOfTreeT kenv tt
- = case tt of
-        BindDef way bs ts
-         |  BoundSpec   <- boundLevelOfBindWay way
-         ,  kenv'       <- Env.extends bs kenv
-         -> Set.unions $ map (freeOfTreeT kenv') ts
-
-        BindDef _ _ ts
-         -> Set.unions $ map (freeOfTreeT kenv) ts
-
-        BindUse BoundSpec u
-         | Env.member u kenv -> Set.empty
-         | otherwise         -> Set.singleton u
-        _                    -> Set.empty
-
-
--- collectBound ---------------------------------------------------------------
--- | Collect all the bound variables in a thing, 
---   independent of whether they are free or not.
-collectBound :: (BindStruct c, Ord n) => c n -> Set (Bound n)
-collectBound 
-        = Set.unions . map collectBoundOfTree . slurpBindTree 
-
-collectBoundOfTree :: Ord n => BindTree n -> Set (Bound n)
-collectBoundOfTree tt
- = case tt of
-        BindDef _ _ ts  -> Set.unions $ map collectBoundOfTree ts
-        BindUse _ u     -> Set.singleton u
-        BindCon _ u _   -> Set.singleton u
-
-
--- collectSpecBinds -----------------------------------------------------------
--- | Collect all the spec and exp binders in a thing.
-collectBinds 
-        :: (BindStruct c, Ord n) 
-        => c n 
-        -> ([Bind n], [Bind n])
-
-collectBinds thing
- = let  tree    = slurpBindTree thing
-   in   ( concatMap collectSpecBindsOfTree tree
-        , concatMap collectExpBindsOfTree  tree)
-        
-
-collectSpecBindsOfTree :: Ord n => BindTree n -> [Bind n]
-collectSpecBindsOfTree tt
- = case tt of
-        BindDef way bs ts
-         |   BoundSpec <- boundLevelOfBindWay way
-         ->  concat ( bs
-                    : map collectSpecBindsOfTree ts)
-
-         | otherwise
-         ->  concatMap collectSpecBindsOfTree ts
-
-        _ -> []
-
-
-collectExpBindsOfTree :: Ord n => BindTree n -> [Bind n]
-collectExpBindsOfTree tt
- = case tt of
-        BindDef way bs ts
-         |   BoundExp <- boundLevelOfBindWay way
-         ->  concat ( bs
-                    : map collectExpBindsOfTree ts)
-
-         | otherwise
-         ->  concatMap collectExpBindsOfTree ts
-
-        _ -> []
-
-
 -------------------------------------------------------------------------------
 -- | A description of the binding structure of some type or expression.
 data BindTree n
@@ -162,11 +83,11 @@
 
 
 -- BindStruct -----------------------------------------------------------------
-class BindStruct (c :: * -> *) where
- slurpBindTree :: c n -> [BindTree n]
+class BindStruct c n | c -> n where
+ slurpBindTree :: c -> [BindTree n]
 
 
-instance BindStruct Type where
+instance BindStruct (Type n) n where
  slurpBindTree tt
   = case tt of
         TVar u          -> [BindUse BoundSpec u]
@@ -176,7 +97,7 @@
         TSum ts         -> concatMap slurpBindTree $ Sum.toList ts
 
 
-instance BindStruct TyCon where
+instance BindStruct (TyCon n) n where
  slurpBindTree tc
   = case tc of
         TyConBound u k  -> [BindCon BoundSpec u (Just k)]
@@ -184,7 +105,91 @@
 
 
 -- | Helper for constructing the `BindTree` for a type binder.
-bindDefT :: BindStruct c
-         => BindWay -> [Bind n] -> [c n] -> BindTree n
+bindDefT :: BindStruct c n
+         => BindWay -> [Bind n] -> [c] -> BindTree n
 bindDefT way bs xs
         = BindDef way bs $ concatMap slurpBindTree xs
+
+
+-- freeT ----------------------------------------------------------------------
+-- | Collect the free Spec variables in a thing (level-1).
+freeT   :: (BindStruct c n, Ord n) 
+        => Env n -> c -> Set (Bound n)
+freeT tenv xx = Set.unions $ map (freeOfTreeT tenv) $ slurpBindTree xx
+
+freeOfTreeT :: Ord n => Env n -> BindTree n -> Set (Bound n)
+freeOfTreeT kenv tt
+ = case tt of
+        BindDef way bs ts
+         |  BoundSpec   <- boundLevelOfBindWay way
+         ,  kenv'       <- Env.extends bs kenv
+         -> Set.unions $ map (freeOfTreeT kenv') ts
+
+        BindDef _ _ ts
+         -> Set.unions $ map (freeOfTreeT kenv) ts
+
+        BindUse BoundSpec u
+         | Env.member u kenv -> Set.empty
+         | otherwise         -> Set.singleton u
+        _                    -> Set.empty
+
+
+-- collectBound ---------------------------------------------------------------
+-- | Collect all the bound variables in a thing, 
+--   independent of whether they are free or not.
+collectBound 
+        :: (BindStruct c n, Ord n) 
+        => c -> Set (Bound n)
+
+collectBound 
+        = Set.unions . map collectBoundOfTree . slurpBindTree 
+
+collectBoundOfTree :: Ord n => BindTree n -> Set (Bound n)
+collectBoundOfTree tt
+ = case tt of
+        BindDef _ _ ts  -> Set.unions $ map collectBoundOfTree ts
+        BindUse _ u     -> Set.singleton u
+        BindCon _ u _   -> Set.singleton u
+
+
+-- collectSpecBinds -----------------------------------------------------------
+-- | Collect all the spec and exp binders in a thing.
+collectBinds 
+        :: (BindStruct c n, Ord n) 
+        => c
+        -> ([Bind n], [Bind n])
+
+collectBinds thing
+ = let  tree    = slurpBindTree thing
+   in   ( concatMap collectSpecBindsOfTree tree
+        , concatMap collectExpBindsOfTree  tree)
+        
+
+collectSpecBindsOfTree :: Ord n => BindTree n -> [Bind n]
+collectSpecBindsOfTree tt
+ = case tt of
+        BindDef way bs ts
+         |   BoundSpec <- boundLevelOfBindWay way
+         ->  concat ( bs
+                    : map collectSpecBindsOfTree ts)
+
+         | otherwise
+         ->  concatMap collectSpecBindsOfTree ts
+
+        _ -> []
+
+
+collectExpBindsOfTree :: Ord n => BindTree n -> [Bind n]
+collectExpBindsOfTree tt
+ = case tt of
+        BindDef way bs ts
+         |   BoundExp <- boundLevelOfBindWay way
+         ->  concat ( bs
+                    : map collectExpBindsOfTree ts)
+
+         | otherwise
+         ->  concatMap collectExpBindsOfTree ts
+
+        _ -> []
+
+
diff --git a/DDC/Type/Compounds.hs b/DDC/Type/Compounds.hs
--- a/DDC/Type/Compounds.hs
+++ b/DDC/Type/Compounds.hs
@@ -45,17 +45,20 @@
         , takePrimeRegion
 
           -- * Functions
-        , tFun,         tFunOfList
-        , tFunPE,       tFunOfListPE
-        , tFunEC
-        , takeTFun,     takeTFunEC
+        , tFun
+        , tFunOfList
+        , tFunOfParamResult
+        , takeTFun
         , takeTFunArgResult
         , takeTFunWitArgResult
         , takeTFunAllArgResult
         , arityOfType
+        , dataArityOfType
 
           -- * Suspensions
         , tSusp
+        , takeTSusp
+        , takeTSusps
 
           -- * Implications
         , tImpl
@@ -78,18 +81,11 @@
         , tWrite,       tDeepWrite
         , tAlloc,       tDeepAlloc
 
-          -- * Closure type constructors
-        , tUse,         tDeepUse
-
           -- * Witness type constructors
         , tPure
-        , tEmpty
-        , tGlobal,      tDeepGlobal
         , tConst,       tDeepConst
         , tMutable,     tDeepMutable
         , tDistinct
-        , tLazy,        tHeadLazy
-        , tManifest
         , tConData0,    tConData1)
 where
 import DDC.Type.Exp
@@ -437,22 +433,17 @@
 infixr `tFun`
 
 
--- | Construct a value type function, 
---   with the provided effect and closure.
-tFunEC    :: Type n -> Effect n -> Closure n -> Type n -> Type n
-tFunEC t1 eff clo t2
-        = (TCon $ TyConSpec TcConFunEC) `tApps` [t1, eff, clo, t2]
-infixr `tFunEC`
-
-
--- | Construct a pure and empty value type function.
-tFunPE  :: Type n -> Type n -> Type n
-tFunPE t1 t2    = tFunEC t1 (tBot kEffect) (tBot kClosure) t2
-infixr `tFunPE`
+-- | Construct a function type from a list of parameter types and the
+--   return type.
+tFunOfParamResult :: [Type n] -> Type n -> Type n
+tFunOfParamResult tsArg tResult
+ = let  tFuns' []        = tResult
+        tFuns' (t': ts') = t' `tFun` tFuns' ts'
+   in   tFuns' tsArg
 
 
--- | Construct a pure and empty function from a list containing the 
---   parameter and return type. Yields `Nothing` if the list is empty.
+-- | Construct a function type from a list containing the parameter
+--   and return types. Yields `Nothing` if the list is empty.
 tFunOfList :: [Type n] -> Maybe (Type n)
 tFunOfList ts
   = case reverse ts of
@@ -463,46 +454,17 @@
             in  Just $ tFuns' (reverse tsArgs)
 
 
--- | Construct a pure and empty function from a list containing the 
---   parameter and return type. Yields `Nothing` if the list is empty.
-tFunOfListPE :: [Type n] -> Maybe (Type n)
-tFunOfListPE ts
-  = case reverse ts of
-        []      -> Nothing
-        (t : tsArgs)       
-         -> let tFunPEs' []             = t
-                tFunPEs' (t' : ts')     = t' `tFunPE` tFunPEs' ts'
-            in  Just $ tFunPEs' (reverse tsArgs)
-
-
 -- | Yield the argument and result type of a function type.
---   
---   Works for both `TcConFun` and `TcConFunEC`.
 takeTFun :: Type n -> Maybe (Type n, Type n)
 takeTFun tt
  = case tt of
         TApp (TApp (TCon (TyConSpec TcConFun)) t1) t2
          ->  Just (t1, t2)
 
-        TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFunEC)) t1) _eff) _clo) t2
-         ->  Just (t1, t2)
-
         _ -> Nothing
 
 
--- | Yield the argument and result type of a function type.
-takeTFunEC :: Type n -> Maybe (Type n, Effect n, Closure n, Type n)
-takeTFunEC tt
- = case tt of
-        TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFunEC)) t1) eff) clo) t2
-         ->  Just (t1, eff, clo, t2)
-
-        _ -> Nothing
-
-
 -- | Destruct the type of a function, returning just the argument and result types.
---
---   Works for both `TcConFun` and `TcConFunEC`.
 takeTFunArgResult :: Type n -> ([Type n], Type n)
 takeTFunArgResult tt
  = case tt of
@@ -510,10 +472,6 @@
          -> let (tsMore, tResult) = takeTFunArgResult t2
             in  (t1 : tsMore, tResult)
 
-        TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFunEC)) t1) _eff) _clo) t2
-         -> let (tsMore, tResult) = takeTFunArgResult t2
-            in  (t1 : tsMore, tResult)
-
         _ -> ([], tt)
 
 
@@ -521,9 +479,6 @@
 --   returning the witness argument, value argument and result types.
 --   The function type must have the witness implications before 
 --   the value arguments, eg  @T1 => T2 -> T3 -> T4 -> T5@.
---
---   Works for both `TcConFun` and `TcConFunEC`.
---
 takeTFunWitArgResult :: Type n -> ([Type n], [Type n], Type n)
 takeTFunWitArgResult tt
  = case tt of
@@ -553,10 +508,6 @@
          -> let (tsMore, tResult) = takeTFunAllArgResult t2
             in  (t1 : tsMore, tResult)
 
-        TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFunEC)) t1) _eff) _clo) t2
-         -> let (tsMore, tResult) = takeTFunAllArgResult t2
-            in  (t1 : tsMore, tResult)
-
         TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2
          -> let (tsMore, tResult) = takeTFunAllArgResult t2
             in  (t1 : tsMore, tResult)
@@ -576,6 +527,25 @@
         t               -> length $ fst $ takeTFunArgResult t
 
 
+-- | The data arity of a type is the number of data values it takes. 
+--   Unlike `arityOfType` we ignore type and witness parameters.
+dataArityOfType :: Type n -> Int
+dataArityOfType tt
+ = case tt of
+        TVar{}          -> 0
+        TCon{}          -> 0
+
+        TForall _ t     -> dataArityOfType t
+
+        TApp (TApp (TCon (TyConSpec TcConFun)) _) t2
+         -> 1 + dataArityOfType t2
+
+        TApp (TApp (TCon (TyConWitness TwConImpl)) _) t2
+         -> dataArityOfType t2
+
+        _ -> 0
+
+
 -- Implications ---------------------------------------------------------------
 -- | Construct a witness implication type.
 tImpl :: Type n -> Type n -> Type n
@@ -585,11 +555,32 @@
 
 
 -- Suspensions ----------------------------------------------------------------
+-- | Construct a suspension type.
 tSusp  :: Effect n -> Type n -> Type n
 tSusp tE tA
         = (TCon $ TyConSpec TcConSusp) `tApp` tE `tApp` tA
 
 
+-- | Take the effect and result type of a suspension type.
+takeTSusp :: Type n -> Maybe (Effect n, Type n)
+takeTSusp tt
+ = case tt of
+        TApp (TApp (TCon (TyConSpec TcConSusp)) tE) tA
+          -> Just (tE, tA)
+        _ -> Nothing
+
+
+-- | Split off enclosing suspension types.
+takeTSusps :: Type n -> ([Effect n], Type n)
+takeTSusps tt
+ = case tt of
+        TApp (TApp (TCon (TyConSpec TcConSusp)) tE) tRest
+          -> let (tEs, tA) = takeTSusps tRest
+             in  (tE : tEs, tA)
+
+        _ -> ([], tt)
+
+
 -- Level 3 constructors (sorts) -----------------------------------------------
 sComp           = TCon $ TyConSort SoConComp
 sProp           = TCon $ TyConSort SoConProp
@@ -614,23 +605,13 @@
 tAlloc          = tcCon1 TcConAlloc
 tDeepAlloc      = tcCon1 TcConDeepAlloc
 
--- Closure type constructors.
-tUse            = tcCon1 TcConUse
-tDeepUse        = tcCon1 TcConDeepUse
-
 -- Witness type constructors.
 tPure           = twCon1 TwConPure
-tEmpty          = twCon1 TwConEmpty
-tGlobal         = twCon1 TwConGlobal
-tDeepGlobal     = twCon1 TwConDeepGlobal
 tConst          = twCon1 TwConConst
 tDeepConst      = twCon1 TwConDeepConst
 tMutable        = twCon1 TwConMutable
 tDeepMutable    = twCon1 TwConDeepMutable
 tDistinct n     = twCon2 (TwConDistinct n)
-tLazy           = twCon1 TwConLazy
-tHeadLazy       = twCon1 TwConHeadLazy
-tManifest       = twCon1 TwConManifest
 
 tcCon1 tc t     = (TCon $ TyConSpec    tc) `tApp` t
 twCon1 tc t     = (TCon $ TyConWitness tc) `tApp` t
diff --git a/DDC/Type/DataDef.hs b/DDC/Type/DataDef.hs
--- a/DDC/Type/DataDef.hs
+++ b/DDC/Type/DataDef.hs
@@ -212,6 +212,11 @@
   = rnf n `seq` rnf t `seq` rnf fs `seq` rnf tR `seq` rnf nT `seq` rnf bsParam
 
 
+instance Ord n => Monoid (DataDefs n) where
+ mempty  = emptyDataDefs
+ mappend = unionDataDefs
+
+
 -- | An empty table of data type definitions.
 emptyDataDefs :: DataDefs n
 emptyDataDefs
@@ -220,6 +225,14 @@
         , dataDefsCtors = Map.empty }
 
 
+-- | Union two `DataDef` tables.
+unionDataDefs :: Ord n => DataDefs n -> DataDefs n -> DataDefs n
+unionDataDefs defs1 defs2
+        = DataDefs
+        { dataDefsTypes = Map.union (dataDefsTypes defs1) (dataDefsTypes defs2)
+        , dataDefsCtors = Map.union (dataDefsCtors defs1) (dataDefsCtors defs2) }
+
+
 -- | Insert a data type definition into some DataDefs.
 insertDataDef  :: Ord n => DataDef  n -> DataDefs n -> DataDefs n
 insertDataDef (DataDef nType bsParam mCtors isAlg) dataDefs
@@ -238,15 +251,6 @@
          , dataDefsCtors = Map.union (dataDefsCtors dataDefs)
                          $ Map.fromList [(n, def) 
                                 | def@(DataCtor n _ _ _ _ _) <- concat $ maybeToList mCtors ]}
-
-
--- | Union two `DataDef` tables.
-unionDataDefs :: Ord n => DataDefs n -> DataDefs n -> DataDefs n
-unionDataDefs defs1 defs2
-        = DataDefs
-        { dataDefsTypes = Map.union (dataDefsTypes defs1) (dataDefsTypes defs2)
-        , dataDefsCtors = Map.union (dataDefsCtors defs1) (dataDefsCtors defs2) }
-
 
 
 -- | Build a `DataDefs` table from a list of `DataDef`
diff --git a/DDC/Type/Env.hs b/DDC/Type/Env.hs
--- a/DDC/Type/Env.hs
+++ b/DDC/Type/Env.hs
@@ -42,7 +42,7 @@
         , lift)
 where
 import DDC.Type.Exp
-import DDC.Type.Transform.LiftT
+import DDC.Type.Transform.BoundT
 import Data.Maybe
 import Data.Map                         (Map)
 import Prelude                          hiding (lookup)
diff --git a/DDC/Type/Equiv.hs b/DDC/Type/Equiv.hs
--- a/DDC/Type/Equiv.hs
+++ b/DDC/Type/Equiv.hs
@@ -2,15 +2,22 @@
 module DDC.Type.Equiv
         ( equivT
         , equivWithBindsT
-        , equivTyCon)
+        , equivTyCon
+
+        , crushSomeT
+        , crushEffect)
 where
-import DDC.Type.Transform.Crush
+import DDC.Type.Predicates
 import DDC.Type.Compounds
 import DDC.Type.Bind
 import DDC.Type.Exp
+import DDC.Type.Env             (TypeEnv)
+import qualified DDC.Type.Env   as Env
 import qualified DDC.Type.Sum   as Sum
+import qualified Data.Map       as Map
 
 
+---------------------------------------------------------------------------------------------------
 -- | Check equivalence of types.
 --
 --   Checks equivalence up to alpha-renaming, as well as crushing of effects
@@ -36,17 +43,18 @@
         -> Bool
 
 equivWithBindsT stack1 stack2 t1 t2
- = let  t1'     = unpackSumT $ crushSomeT t1
-        t2'     = unpackSumT $ crushSomeT t2
+ = let  t1'     = unpackSumT $ crushSomeT Env.empty t1
+        t2'     = unpackSumT $ crushSomeT Env.empty t2
+
    in case (t1', t2') of
         (TVar u1,         TVar u2)
          -- Free variables are name-equivalent, bound variables aren't:
-	 -- (forall a. a) != (forall b. a)
+         -- (forall a. a) != (forall b. a)
          | Nothing      <- getBindType stack1 u1
          , Nothing      <- getBindType stack2 u2
          , u1 == u2     -> checkBounds u1 u2 True
 
-	 -- Both variables are bound in foralls, so check the stack
+         -- Both variables are bound in foralls, so check the stack
          -- to see if they would be equivalent if we named them.
          | Just (ix1, t1a)   <- getBindType stack1 u1
          , Just (ix2, t2a)   <- getBindType stack2 u2
@@ -123,11 +131,11 @@
 -- | Unpack single element sums into plain types.
 unpackSumT :: Type n -> Type n
 unpackSumT (TSum ts)
-	| [t]   <- Sum.toList ts = t
-unpackSumT tt			 = tt
+        | [t]   <- Sum.toList ts = t
+unpackSumT tt                    = tt
 
 
--- TyCon ----------------------------------------------------------------------
+-- TyCon 
 -- | Check if two `TyCons` are equivalent.
 --   We need to handle `TyConBound` specially incase it's kind isn't attached,
 equivTyCon :: Eq n => TyCon n -> TyCon n -> Bool
@@ -136,3 +144,159 @@
         (TyConBound u1 _, TyConBound u2 _) -> u1  == u2
         _                                  -> tc1 == tc2
 
+
+
+---------------------------------------------------------------------------------------------------
+-- | Crush compound effects and closure terms.
+--   We check for a crushable term before calling crushT because that function
+--   will recursively crush the components. 
+--   As equivT is already recursive, we don't want a doubly-recursive function
+--   that tries to re-crush the same non-crushable type over and over.
+--
+crushSomeT :: Ord n => TypeEnv n -> Type n -> Type n
+crushSomeT caps tt
+ = {-# SCC crushSomeT #-}
+   case tt of
+        TApp (TCon tc) _
+         -> case tc of
+                TyConSpec    TcConDeepRead   -> crushEffect caps tt
+                TyConSpec    TcConDeepWrite  -> crushEffect caps tt
+                TyConSpec    TcConDeepAlloc  -> crushEffect caps tt
+                _                            -> tt
+
+        _ -> tt
+
+
+-- | Crush compound effect terms into their components.
+--
+--   For example, crushing @DeepRead (List r1 (Int r2))@ yields @(Read r1 + Read r2)@.
+--
+crushEffect 
+        :: Ord n 
+        => TypeEnv n            -- ^ Globally available capabilities.
+        -> Effect n             -- ^ Type to crush. 
+        -> Effect n
+
+crushEffect caps tt
+ = {-# SCC crushEffect #-}
+   case tt of
+        TVar{}          -> tt
+        TCon{}          -> tt
+
+        TForall b t
+         -> TForall b $ crushEffect caps t
+
+        TSum ts         
+         -> TSum
+          $ Sum.fromList (Sum.kindOfSum ts)   
+          $ map (crushEffect caps)
+          $ Sum.toList ts
+
+        TApp{}
+         |  or [equivT tt t | (_, t) <- Map.toList $ Env.envMap caps]
+         -> tSum kEffect []
+
+        TApp t1 t2
+         -- Head Read.
+         |  Just (TyConSpec TcConHeadRead, [t]) <- takeTyConApps tt
+         -> case takeTyConApps t of
+
+             -- Type has a head region.
+             Just (TyConBound _ k, (tR : _)) 
+              |  (k1 : _, _) <- takeKFuns k
+              ,  isRegionKind k1
+              -> tRead tR
+
+             -- Type has no head region.
+             -- This happens with  case () of { ... }
+             Just (TyConSpec  TcConUnit, [])
+              -> tBot kEffect
+
+             Just (TyConBound _ _,       _)     
+              -> tBot kEffect
+
+             _ -> tt
+
+         -- Deep Read.
+         -- See Note: Crushing with higher kinded type vars.
+         | Just (TyConSpec TcConDeepRead, [t]) <- takeTyConApps tt
+         -> case takeTyConApps t of
+             Just (TyConBound _ k, ts)
+              | (ks, _)  <- takeKFuns k
+              , length ks == length ts
+              , Just effs       <- sequence $ zipWith makeDeepRead ks ts
+              -> crushEffect caps $ TSum $ Sum.fromList kEffect effs
+
+             _ -> tt
+
+         -- Deep Write
+         -- See Note: Crushing with higher kinded type vars.
+         | Just (TyConSpec TcConDeepWrite, [t]) <- takeTyConApps tt
+         -> case takeTyConApps t of
+             Just (TyConBound _ k, ts)
+              | (ks, _)  <- takeKFuns k
+              , length ks == length ts
+              , Just effs       <- sequence $ zipWith makeDeepWrite ks ts
+              -> crushEffect caps $ TSum $ Sum.fromList kEffect effs
+
+             _ -> tt 
+
+         -- Deep Alloc
+         -- See Note: Crushing with higher kinded type vars.
+         | Just (TyConSpec TcConDeepAlloc, [t]) <- takeTyConApps tt
+         -> case takeTyConApps t of
+             Just (TyConBound _ k, ts)
+              | (ks, _)  <- takeKFuns k
+              , length ks == length ts
+              , Just effs       <- sequence $ zipWith makeDeepAlloc ks ts
+              -> crushEffect caps $ TSum $ Sum.fromList kEffect effs
+
+             _ -> tt
+
+
+         | otherwise
+         -> TApp (crushEffect caps t1) (crushEffect caps t2)
+
+
+-- | If this type has first order kind then wrap with the 
+--   appropriate read effect.
+makeDeepRead :: Kind n -> Type n -> Maybe (Effect n)
+makeDeepRead k t
+        | isRegionKind  k       = Just $ tRead t
+        | isDataKind    k       = Just $ tDeepRead t
+        | isClosureKind k       = Just $ tBot kEffect
+        | isEffectKind  k       = Just $ tBot kEffect
+        | otherwise             = Nothing
+
+
+-- | If this type has first order kind then wrap with the 
+--   appropriate read effect.
+makeDeepWrite :: Kind n -> Type n -> Maybe (Effect n)
+makeDeepWrite k t
+        | isRegionKind  k       = Just $ tWrite t
+        | isDataKind    k       = Just $ tDeepWrite t
+        | isClosureKind k       = Just $ tBot kEffect
+        | isEffectKind  k       = Just $ tBot kEffect
+        | otherwise             = Nothing
+
+
+-- | If this type has first order kind then wrap with the 
+--   appropriate read effect.
+makeDeepAlloc :: Kind n -> Type n -> Maybe (Effect n)
+makeDeepAlloc k t
+        | isRegionKind  k       = Just $ tAlloc t
+        | isDataKind    k       = Just $ tDeepAlloc t
+        | isClosureKind k       = Just $ tBot kEffect
+        | isEffectKind  k       = Just $ tBot kEffect
+        | otherwise             = Nothing
+
+
+
+{- [Note: Crushing with higher kinded type vars]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+   We can't just look at the free variables here and wrap Read and DeepRead constructors
+   around them, as the type may contain higher kinded type variables such as: (t a).
+   Instead, we'll only crush the effect when all variable have first-order kind.
+   When comparing types with higher order variables, we'll have to use the type
+   equivalence checker, instead of relying on the effects to be pre-crushed.
+-}
diff --git a/DDC/Type/Exp/Base.hs b/DDC/Type/Exp/Base.hs
--- a/DDC/Type/Exp/Base.hs
+++ b/DDC/Type/Exp/Base.hs
@@ -1,12 +1,28 @@
 
-module DDC.Type.Exp.Base where
+module DDC.Type.Exp.Base 
+        ( Binder        (..)
+        , Bind          (..)
+        , Bound         (..)
+        , Type          (..)
+        , Sort
+        , Kind
+        , Region
+        , Effect
+        , Closure
+        , TypeSum       (..)
+        , TyConHash     (..)
+        , TypeSumVarCon (..)
+        , TyCon         (..)
+        , SoCon         (..)
+        , KiCon         (..)
+        , TwCon         (..)
+        , TcCon         (..))
+where
 import Data.Array
 import Data.Map.Strict  (Map)
 import Data.Set         (Set)
 
 
--- Bind -----------------------------------------------------------------------
--- | A variable binder.
 data Binder n
         = RNone
         | RAnon
@@ -14,6 +30,7 @@
         deriving Show
 
 
+-- Bind -----------------------------------------------------------------------
 -- | A variable binder with its type.
 data Bind n
         -- | A variable with no uses in the body doesn't need a name.
@@ -193,15 +210,6 @@
         -- | Purity of some effect.
         | TwConPure             -- :: Effect  ~> Witness
 
-        -- | Emptiness of some closure.
-        | TwConEmpty            -- :: Closure ~> Witness
-
-        -- | Globalness of some region.
-        | TwConGlobal           -- :: Region  ~> Witness
-
-        -- | Globalness of material regions in some type.
-        | TwConDeepGlobal       -- :: Data    ~> Witness
-        
         -- | Constancy of some region.
         | TwConConst            -- :: Region  ~> Witness
 
@@ -217,15 +225,6 @@
         -- | Distinctness of some n regions
         | TwConDistinct Int     -- :: Data    ~> [Region] ~> Witness
         
-        -- | Laziness of some region.
-        | TwConLazy             -- :: Region  ~> Witness
-
-        -- | Laziness of the primary region in some type.
-        | TwConHeadLazy         -- :: Data    ~> Witness
-
-        -- | Manifestness of some region (not lazy).
-        | TwConManifest         -- :: Region  ~> Witness
-
         -- | Non-interfering effects are disjoint. Used for rewrite rules.
         | TwConDisjoint         -- :: Effect ~> Effect ~> Witness
         deriving (Eq, Show)
@@ -240,9 +239,6 @@
         -- | Pure function.
         | TcConFun              -- '(->)' :: Data ~> Data ~> Data
 
-        -- | Function with a latent effect and closure.
-        | TcConFunEC            -- '(->)  :: Data ~> Data ~> Effect ~> Closure ~> Data'
-
         -- | A suspended computation.
         | TcConSusp             -- 'S     :: Effect ~> Data ~> Data'
 
@@ -267,11 +263,5 @@
 
         -- | Allocation into all material regions in some data type.
         | TcConDeepAlloc        -- :: 'Data   ~> Effect'
-        
-        -- Closure type constructors ------------
-        -- | Region is captured in a closure.
-        | TcConUse              -- :: 'Region ~> Closure'
-        
-        -- | All material regions in a data type are captured in a closure.
-        | TcConDeepUse          -- :: 'Data   ~> Closure'
         deriving (Eq, Show)
+
diff --git a/DDC/Type/Exp/NFData.hs b/DDC/Type/Exp/NFData.hs
--- a/DDC/Type/Exp/NFData.hs
+++ b/DDC/Type/Exp/NFData.hs
@@ -75,8 +75,19 @@
         TyConExists  n   k      -> rnf n   `seq` rnf k
 
 
-instance NFData SoCon
-instance NFData KiCon
-instance NFData TwCon
-instance NFData TcCon
+instance NFData SoCon where
+ rnf !_ = ()
+
+
+instance NFData KiCon where
+ rnf !_ = ()
+
+
+instance NFData TwCon where
+ rnf !_ = ()
+
+
+instance NFData TcCon where
+ rnf !_ = ()
+
 
diff --git a/DDC/Type/Predicates.hs b/DDC/Type/Predicates.hs
--- a/DDC/Type/Predicates.hs
+++ b/DDC/Type/Predicates.hs
@@ -156,9 +156,9 @@
 isWitnessType :: Eq n => Type n -> Bool
 isWitnessType tt
  = case takeTyConApps tt of
-	Just (TyConWitness _, _) -> True
-	_			 -> False
-	
+        Just (TyConWitness _, _) -> True
+        _                        -> False
+        
 
 -- | Check whether this is the type of a @Const@ witness.
 isConstWitType :: Eq n => Type n -> Bool
@@ -182,7 +182,7 @@
  = case takeTyConApps tt of
         Just (TyConWitness (TwConDistinct _), _) -> True
         _                                        -> False
-	
+        
 
 -- Effects --------------------------------------------------------------------
 -- | Check whether this is an atomic read effect.
diff --git a/DDC/Type/Pretty.hs b/DDC/Type/Pretty.hs
--- a/DDC/Type/Pretty.hs
+++ b/DDC/Type/Pretty.hs
@@ -13,10 +13,13 @@
 instance (Pretty n, Eq n) => Pretty (Bind n) where
  ppr bb
   = case bb of
-        BName v t       -> ppr v     <+> text ":" <+> ppr t
-        BAnon   t       -> text "^"  <+> text ":" <+> ppr t
-        BNone   t       -> text "_"  <+> text ":" <+> ppr t
+        BName v t       -> ppr v     <> pprT t
+        BAnon   t       -> text "^"  <> pprT t
+        BNone   t       -> text "_"  <> pprT t
 
+  where pprT t
+         | isBot t      = empty
+         | otherwise    = text " : " <> ppr t 
 
 -- Binder ---------------------------------------------------------------------
 instance Pretty n => Pretty (Binder n) where
@@ -70,18 +73,6 @@
         TApp (TApp (TCon (TyConSpec TcConFun)) t1) t2
          -> pprParen (d > 5)
          $  pprPrec 6 t1 <+> text "->" </> pprPrec 5 t2
-
-        -- Function with a latent effect and closure.
-        TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFunEC)) t1) eff) clo) t2
-         | isBot eff, isBot clo
-         -> pprParen (d > 5)
-         $  pprPrec 6 t1 <+> text "->"  </> pprPrec 5 t2
-
-         | otherwise
-         -> pprParen (d > 5)
-         $  pprPrec 6 t1
-                <+> text "-(" <> ppr eff <> text " | " <> ppr clo <> text ")>" 
-                </> pprPrec 5 t2
                    
         -- Standard types.
         TCon tc    -> ppr tc
@@ -169,17 +160,11 @@
   = case tw of
         TwConImpl       -> text "(=>)"
         TwConPure       -> text "Purify"
-        TwConEmpty      -> text "Emptify"
-        TwConGlobal     -> text "Global"
-        TwConDeepGlobal -> text "DeepGlobal"
         TwConConst      -> text "Const"
         TwConDeepConst  -> text "DeepConst"
         TwConMutable    -> text "Mutable"
         TwConDeepMutable-> text "DeepMutable"
         TwConDistinct n -> text "Distinct" <> ppr n
-        TwConLazy       -> text "Lazy"
-        TwConHeadLazy   -> text "HeadLazy"
-        TwConManifest   -> text "Manifest"
         TwConDisjoint   -> text "Disjoint"
         
 
@@ -188,7 +173,6 @@
   = case tc of
         TcConUnit       -> text "Unit"
         TcConFun        -> text "(->)"
-        TcConFunEC      -> text "(->)"
         TcConSusp       -> text "S"
         TcConRead       -> text "Read"
         TcConHeadRead   -> text "HeadRead"
@@ -197,7 +181,5 @@
         TcConDeepWrite  -> text "DeepWrite"
         TcConAlloc      -> text "Alloc"
         TcConDeepAlloc  -> text "DeepAlloc"
-        TcConUse        -> text "Use"
-        TcConDeepUse    -> text "DeepUse"
 
 
diff --git a/DDC/Type/Subsumes.hs b/DDC/Type/Subsumes.hs
--- a/DDC/Type/Subsumes.hs
+++ b/DDC/Type/Subsumes.hs
@@ -3,11 +3,9 @@
 where
 import DDC.Type.Exp
 import DDC.Type.Predicates
-import DDC.Type.Transform.Crush
-import DDC.Type.Transform.Trim
+import DDC.Type.Equiv
 import qualified DDC.Type.Sum   as Sum
-import Control.Monad
-
+import qualified DDC.Type.Env   as Env
 
 -- | Check whether the first type subsumes the second.
 --
@@ -19,13 +17,8 @@
 subsumesT :: Ord n => Kind n -> Type n -> Type n -> Bool
 subsumesT k t1 t2
         | isEffectKind k
-        , ts1       <- Sum.singleton k $ crushEffect t1
-        , ts2       <- Sum.singleton k $ crushEffect t2
-        = and $ [ Sum.elem t ts1 | t <- Sum.toList ts2 ]
-
-        | isClosureKind k
-        , Just ts1  <- liftM (Sum.singleton k) $ trimClosure t1
-        , Just ts2  <- liftM (Sum.singleton k) $ trimClosure t2
+        , ts1       <- Sum.singleton k $ crushEffect Env.empty t1
+        , ts2       <- Sum.singleton k $ crushEffect Env.empty t2
         = and $ [ Sum.elem t ts1 | t <- Sum.toList ts2 ]
 
         | otherwise
diff --git a/DDC/Type/Sum.hs b/DDC/Type/Sum.hs
--- a/DDC/Type/Sum.hs
+++ b/DDC/Type/Sum.hs
@@ -217,8 +217,6 @@
         TcConWrite      -> Just $ TyConHash 2
         TcConDeepWrite  -> Just $ TyConHash 3
         TcConAlloc      -> Just $ TyConHash 4
-        TcConUse        -> Just $ TyConHash 5
-        TcConDeepUse    -> Just $ TyConHash 6
         _               -> Nothing
 
 
@@ -239,8 +237,6 @@
         2               -> TcConWrite
         3               -> TcConDeepWrite
         4               -> TcConAlloc
-        5               -> TcConUse
-        6               -> TcConDeepUse
 
         -- This should never happen, because we only produce hashes
         -- with the above 'hashTyCon' function.
@@ -312,15 +308,15 @@
         -- kind. This allows us to use (tBot sComp) as the typeSumKind field
         -- when we want to compute the real kind based on the elements. 
         | TypeSumSet{} <- ts1
-	, TypeSumSet{} <- ts2
+        , TypeSumSet{} <- ts2
         =  typeSumElems ts1      == typeSumElems ts2
         && typeSumBoundNamed ts1 == typeSumBoundNamed ts2
         && typeSumBoundAnon  ts1 == typeSumBoundAnon ts2
         && typeSumSpill      ts1 == typeSumSpill ts2
 
-	-- One is a set and one is bottom, so they are not equal.
-	| otherwise
-	= False
+        -- One is a set and one is bottom, so they are not equal.
+        | otherwise
+        = False
 
   where normalise ts
          | []   <- toList ts    = empty (typeSumKind ts)
diff --git a/DDC/Type/Transform/BoundT.hs b/DDC/Type/Transform/BoundT.hs
new file mode 100644
--- /dev/null
+++ b/DDC/Type/Transform/BoundT.hs
@@ -0,0 +1,109 @@
+
+-- | Lifting and lowering of deBruijn indices in types.
+module DDC.Type.Transform.BoundT
+        ( liftT,        liftAtDepthT
+        , lowerT,       lowerAtDepthT
+        , MapBoundT(..))
+where
+import DDC.Type.Exp
+import DDC.Type.Compounds
+import qualified DDC.Type.Sum   as Sum
+
+
+-- Lift -----------------------------------------------------------------------
+-- | Lift debruijn indices less than or equal to the given depth.
+liftAtDepthT
+        :: MapBoundT c n
+        => Int          -- ^ Number of levels to lift.
+        -> Int          -- ^ Current binding depth.
+        -> c n          -- ^ Lift expression indices in this thing.
+        -> c n
+
+liftAtDepthT n d
+ = mapBoundAtDepthT liftU d
+ where  
+        liftU d' u
+         = case u of
+                UName{}         -> u
+                UPrim{}         -> u
+                UIx i
+                 | d' <= i      -> UIx (i + n)
+                 | otherwise    -> u
+
+
+-- | Wrapper for `liftAtDepthX` that starts at depth 0.       
+liftT   :: MapBoundT c n => Int -> c n -> c n
+liftT n xx  = liftAtDepthT n 0 xx
+
+
+-- Lower ----------------------------------------------------------------------
+-- | Lower debruijn indices less than or equal to the given depth.
+lowerAtDepthT
+        :: MapBoundT c n
+        => Int          -- ^ Number of levels to lower.
+        -> Int          -- ^ Current binding depth.
+        -> c n          -- ^ Lower expression indices in this thing.
+        -> c n
+
+lowerAtDepthT n d
+ = mapBoundAtDepthT lowerU d
+ where  
+        lowerU d' u
+         = case u of
+                UName{}         -> u
+                UPrim{}         -> u
+                UIx i
+                 | d' <= i      -> UIx (i - n)
+                 | otherwise    -> u
+
+
+-- | Wrapper for `lowerAtDepthX` that starts at depth 0.       
+lowerT   :: MapBoundT c n => Int -> c n -> c n
+lowerT n xx  = lowerAtDepthT n 0 xx
+
+
+-- MapBoundT ------------------------------------------------------------------
+class MapBoundT (c :: * -> *) n where
+ -- | Apply a function to all bound variables in the program.
+ --   The function is passed the current binding depth.
+ --   This is used to defined both `liftT` and `lowerT`.
+ mapBoundAtDepthT
+        :: (Int -> Bound n -> Bound n)  
+                        -- ^ Function to apply to the bound occ.
+                        --   It is passed the current binding depth.
+        -> Int          -- ^ Current binding depth.
+        -> c n          -- ^ Lift expression indices in this thing.
+        -> c n
+
+
+instance Ord n => MapBoundT Bind n where
+ mapBoundAtDepthT f d bb
+  = replaceTypeOfBind (mapBoundAtDepthT f d $ typeOfBind bb) bb
+
+
+instance MapBoundT Bound n where
+ mapBoundAtDepthT f d u
+        = f d u
+
+
+instance Ord n => MapBoundT Type n where
+ mapBoundAtDepthT f d tt
+  = case tt of
+        TVar u          -> TVar    (f d u)
+        TCon{}          -> tt
+        TApp t1 t2      -> TApp    (mapBoundAtDepthT f d t1) (mapBoundAtDepthT f d t2)
+        TSum ss         -> TSum    (mapBoundAtDepthT f d ss)
+        TForall b t     
+         -> TForall b (mapBoundAtDepthT f (d + countBAnons [b]) t)
+
+
+instance Ord n => MapBoundT TypeSum n where
+ mapBoundAtDepthT f d ss
+  = Sum.fromList (Sum.kindOfSum ss)
+        $ map (mapBoundAtDepthT f d)
+        $ Sum.toList ss
+
+countBAnons = length . filter isAnon
+ where  isAnon (BAnon _) = True
+        isAnon _         = False
+
diff --git a/DDC/Type/Transform/Crush.hs b/DDC/Type/Transform/Crush.hs
deleted file mode 100644
--- a/DDC/Type/Transform/Crush.hs
+++ /dev/null
@@ -1,185 +0,0 @@
-module DDC.Type.Transform.Crush
-        ( crushSomeT
-        , crushEffect )
-where
-import DDC.Type.Predicates
-import DDC.Type.Compounds
-import DDC.Type.Transform.Trim
-import DDC.Type.Exp
-import qualified DDC.Type.Sum   as Sum
-import Data.Maybe
-
-
--- | Crush compound effects and closure terms.
---   We check for a crushable term before calling crushT because that function
---   will recursively crush the components. 
---   As equivT is already recursive, we don't want a doubly-recursive function
---   that tries to re-crush the same non-crushable type over and over.
---
-crushSomeT :: Ord n => Type n -> Type n
-crushSomeT tt
- = {-# SCC crushSomeT #-}
-   case tt of
-        (TApp (TCon tc) _)
-         -> case tc of
-                TyConSpec    TcConDeepRead   -> crushEffect tt
-                TyConSpec    TcConDeepWrite  -> crushEffect tt
-                TyConSpec    TcConDeepAlloc  -> crushEffect tt
-
-                -- If a closure is miskinded then 'trimClosure' 
-                -- can return Nothing, so we just leave the term untrimmed.
-                TyConSpec    TcConDeepUse    -> fromMaybe tt (trimClosure tt)
-
-                TyConWitness TwConDeepGlobal -> crushEffect tt
-                _                            -> tt
-
-        _ -> tt
-
-
--- | Crush compound effect terms into their components.
---
---   This is like `trimClosure` but for effects instead of closures.
--- 
---   For example, crushing @DeepRead (List r1 (Int r2))@ yields @(Read r1 + Read r2)@.
---
-crushEffect :: Ord n => Effect n -> Effect n
-crushEffect tt
- = {-# SCC crushEffect #-}
-   case tt of
-        TVar{}          -> tt
-        TCon{}          -> tt
-        TForall b t
-         -> TForall b (crushEffect t)
-
-        TSum ts         
-         -> TSum
-          $ Sum.fromList (Sum.kindOfSum ts)   
-          $ map crushEffect
-          $ Sum.toList ts
-
-        TApp t1 t2
-         -- Head Read.
-         |  Just (TyConSpec TcConHeadRead, [t]) <- takeTyConApps tt
-         -> case takeTyConApps t of
-
-             -- Type has a head region.
-             Just (TyConBound _ k, (tR : _)) 
-              |  (k1 : _, _) <- takeKFuns k
-              ,  isRegionKind k1
-              -> tRead tR
-
-             -- Type has no head region.
-             -- This happens with  case () of { ... }
-             Just (TyConSpec  TcConUnit, [])    -> tBot kEffect
-             Just (TyConBound _ _,       _)     -> tBot kEffect
-
-             _ -> tt
-
-         -- Deep Read.
-         -- See Note: Crushing with higher kinded type vars.
-         | Just (TyConSpec TcConDeepRead, [t]) <- takeTyConApps tt
-         -> case takeTyConApps t of
-             Just (TyConBound _ k, ts)
-              | (ks, _)  <- takeKFuns k
-              , length ks == length ts
-              , Just effs       <- sequence $ zipWith makeDeepRead ks ts
-              -> crushEffect $ TSum $ Sum.fromList kEffect effs
-
-             _ -> tt
-
-         -- Deep Write
-         -- See Note: Crushing with higher kinded type vars.
-         | Just (TyConSpec TcConDeepWrite, [t]) <- takeTyConApps tt
-         -> case takeTyConApps t of
-             Just (TyConBound _ k, ts)
-              | (ks, _)  <- takeKFuns k
-              , length ks == length ts
-              , Just effs       <- sequence $ zipWith makeDeepWrite ks ts
-              -> crushEffect $ TSum $ Sum.fromList kEffect effs
-
-             _ -> tt 
-
-         -- Deep Alloc
-         -- See Note: Crushing with higher kinded type vars.
-         | Just (TyConSpec TcConDeepAlloc, [t]) <- takeTyConApps tt
-         -> case takeTyConApps t of
-             Just (TyConBound _ k, ts)
-              | (ks, _)  <- takeKFuns k
-              , length ks == length ts
-              , Just effs       <- sequence $ zipWith makeDeepAlloc ks ts
-              -> crushEffect $ TSum $ Sum.fromList kEffect effs
-
-             _ -> tt
-
-         -- Deep Global
-         -- See Note: Crushing with higher kinded type vars.
-         --
-         -- NOTE: We're hijacking crushEffect to work on witnesses as well.
-         --       It would be better to split this into another function.
-         --
-         | Just (TyConWitness TwConDeepGlobal, [t]) <- takeTyConApps tt
-         -> case takeTyConApps t of
-             Just (TyConBound _ k, ts)
-              | (ks, _)  <- takeKFuns k
-              , length ks == length ts
-              , Just props       <- sequence $ zipWith makeDeepGlobal ks ts
-              -> crushEffect $ TSum $ Sum.fromList kWitness props
-
-             _ -> tt 
-
-         | otherwise
-         -> TApp (crushEffect t1) (crushEffect t2)
-
-
--- | If this type has first order kind then wrap with the 
---   appropriate read effect.
-makeDeepRead :: Kind n -> Type n -> Maybe (Effect n)
-makeDeepRead k t
-        | isRegionKind  k       = Just $ tRead t
-        | isDataKind    k       = Just $ tDeepRead t
-        | isClosureKind k       = Just $ tBot kEffect
-        | isEffectKind  k       = Just $ tBot kEffect
-        | otherwise             = Nothing
-
-
--- | If this type has first order kind then wrap with the 
---   appropriate read effect.
-makeDeepWrite :: Kind n -> Type n -> Maybe (Effect n)
-makeDeepWrite k t
-        | isRegionKind  k       = Just $ tWrite t
-        | isDataKind    k       = Just $ tDeepWrite t
-        | isClosureKind k       = Just $ tBot kEffect
-        | isEffectKind  k       = Just $ tBot kEffect
-        | otherwise             = Nothing
-
-
--- | If this type has first order kind then wrap with the 
---   appropriate read effect.
-makeDeepAlloc :: Kind n -> Type n -> Maybe (Effect n)
-makeDeepAlloc k t
-        | isRegionKind  k       = Just $ tAlloc t
-        | isDataKind    k       = Just $ tDeepAlloc t
-        | isClosureKind k       = Just $ tBot kEffect
-        | isEffectKind  k       = Just $ tBot kEffect
-        | otherwise             = Nothing
-
-
--- | If this type has first order kind then wrap with the 
---   appropriate read effect.
-makeDeepGlobal :: Kind n -> Type n -> Maybe (Type n)
-makeDeepGlobal k t
-        | isRegionKind  k       = Just $ tGlobal t
-        | isDataKind    k       = Just $ tDeepGlobal t
-        | isClosureKind k       = Nothing
-        | isEffectKind  k       = Just $ tBot kEffect
-        | otherwise             = Nothing
-
-
-{- [Note: Crushing with higher kinded type vars]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-   We can't just look at the free variables here and wrap Read and DeepRead constructors
-   around them, as the type may contain higher kinded type variables such as: (t a).
-   Instead, we'll only crush the effect when all variable have first-order kind.
-   When comparing types with higher order variables, we'll have to use the type
-   equivalence checker, instead of relying on the effects to be pre-crushed.
--}
diff --git a/DDC/Type/Transform/LiftT.hs b/DDC/Type/Transform/LiftT.hs
deleted file mode 100644
--- a/DDC/Type/Transform/LiftT.hs
+++ /dev/null
@@ -1,109 +0,0 @@
-
--- | Lifting of deBruijn indices in a type.
-module DDC.Type.Transform.LiftT
-        ( liftT,        liftAtDepthT
-        , lowerT,       lowerAtDepthT
-        , MapBoundT(..))
-where
-import DDC.Type.Exp
-import DDC.Type.Compounds
-import qualified DDC.Type.Sum   as Sum
-
-
--- Lift -----------------------------------------------------------------------
--- | Lift debruijn indices less than or equal to the given depth.
-liftAtDepthT
-        :: MapBoundT c n
-        => Int          -- ^ Number of levels to lift.
-        -> Int          -- ^ Current binding depth.
-        -> c n          -- ^ Lift expression indices in this thing.
-        -> c n
-
-liftAtDepthT n d
- = mapBoundAtDepthT liftU d
- where  
-        liftU d' u
-         = case u of
-                UName{}         -> u
-                UPrim{}         -> u
-                UIx i
-                 | d' <= i      -> UIx (i + n)
-                 | otherwise    -> u
-
-
--- | Wrapper for `liftAtDepthX` that starts at depth 0.       
-liftT   :: MapBoundT c n => Int -> c n -> c n
-liftT n xx  = liftAtDepthT n 0 xx
-
-
--- Lower ----------------------------------------------------------------------
--- | Lower debruijn indices less than or equal to the given depth.
-lowerAtDepthT
-        :: MapBoundT c n
-        => Int          -- ^ Number of levels to lower.
-        -> Int          -- ^ Current binding depth.
-        -> c n          -- ^ Lower expression indices in this thing.
-        -> c n
-
-lowerAtDepthT n d
- = mapBoundAtDepthT lowerU d
- where  
-        lowerU d' u
-         = case u of
-                UName{}         -> u
-                UPrim{}         -> u
-                UIx i
-                 | d' <= i      -> UIx (i - n)
-                 | otherwise    -> u
-
-
--- | Wrapper for `lowerAtDepthX` that starts at depth 0.       
-lowerT   :: MapBoundT c n => Int -> c n -> c n
-lowerT n xx  = lowerAtDepthT n 0 xx
-
-
--- MapBoundT ------------------------------------------------------------------
-class MapBoundT (c :: * -> *) n where
- -- | Apply a function to all bound variables in the program.
- --   The function is passed the current binding depth.
- --   This is used to defined both `liftT` and `lowerT`.
- mapBoundAtDepthT
-        :: (Int -> Bound n -> Bound n)  
-                        -- ^ Function to apply to the bound occ.
-                        --   It is passed the current binding depth.
-        -> Int          -- ^ Current binding depth.
-        -> c n          -- ^ Lift expression indices in this thing.
-        -> c n
-
-
-instance Ord n => MapBoundT Bind n where
- mapBoundAtDepthT f d bb
-  = replaceTypeOfBind (mapBoundAtDepthT f d $ typeOfBind bb) bb
-
-
-instance MapBoundT Bound n where
- mapBoundAtDepthT f d u
-        = f d u
-
-
-instance Ord n => MapBoundT Type n where
- mapBoundAtDepthT f d tt
-  = let down = mapBoundAtDepthT f d
-    in case tt of
-        TVar u          -> TVar    (f d u)
-        TCon{}          -> tt
-        TForall b t     -> TForall b (mapBoundAtDepthT f (d + countBAnons [b]) t)
-        TApp t1 t2      -> TApp    (down t1) (down t2)
-        TSum ss         -> TSum    (down ss)
-
-
-instance Ord n => MapBoundT TypeSum n where
- mapBoundAtDepthT f d ss
-  = Sum.fromList (Sum.kindOfSum ss)
-        $ map (mapBoundAtDepthT f d)
-        $ Sum.toList ss
-
-countBAnons = length . filter isAnon
- where	isAnon (BAnon _) = True
-	isAnon _	 = False
-
diff --git a/DDC/Type/Transform/SubstituteT.hs b/DDC/Type/Transform/SubstituteT.hs
--- a/DDC/Type/Transform/SubstituteT.hs
+++ b/DDC/Type/Transform/SubstituteT.hs
@@ -13,9 +13,7 @@
 where
 import DDC.Type.Collect
 import DDC.Type.Compounds
-import DDC.Type.Transform.LiftT
-import DDC.Type.Transform.Crush
-import DDC.Type.Transform.Trim
+import DDC.Type.Transform.BoundT
 import DDC.Type.Transform.Rename
 import DDC.Type.Exp
 import Data.Maybe
@@ -25,7 +23,7 @@
 import Data.Set                 (Set)
 
 
--- | Substitute a `Type` for the `Bound` corresponding to some `Bind` in a thing.
+-- | Substitute a `Type` for the `Bound` corresponding to a `Bind` in a thing.
 substituteT :: (SubstituteT c, Ord n) => Bind n -> Type n -> c n -> c n
 substituteT b t x
  = case takeSubstBoundOfBind b of
@@ -58,15 +56,15 @@
 class SubstituteT (c :: * -> *) where
 
  -- | Substitute a type into some thing.
- --   In the target, if we find a named binder that would capture a free variable
- --   in the type to substitute, then we rewrite that binder to anonymous form,
- --   avoiding the capture.
+ --   In the target, if we find a named binder that would capture a free
+ --   variable in the type to substitute, then we rewrite that binder to
+ --   anonymous form, avoiding the capture.
  substituteWithT
         :: forall n. Ord n
-        => Bound n       -- ^ Bound variable that we're subsituting into.
-        -> Type n        -- ^ Type to substitute.
-        -> Set  n        -- ^ Names of free varaibles in the type to substitute.
-        -> BindStack n   -- ^ Bind stack.
+        => Bound n     -- ^ Bound variable that we're subsituting into.
+        -> Type n      -- ^ Type to substitute.
+        -> Set  n      -- ^ Names of free varaibles in the type to substitute.
+        -> BindStack n -- ^ Bind stack.
         -> c n -> c n
 
 
@@ -81,32 +79,9 @@
  substituteWithT u t fns stack tt
   = let down    = substituteWithT u t fns stack
     in  case tt of
-         TCon{}          -> tt
-
-         -- Crush out compound effects and closures as we substitute them.
-         TApp t1 t2
-          -> case t1 of
-                TCon (TyConSpec TcConHeadRead)  
-                  -> crushEffect      (TApp t1 (down t2))
-
-                TCon (TyConSpec TcConDeepRead)  
-                  -> crushEffect      (TApp t1 (down t2))
-
-                TCon (TyConSpec TcConDeepWrite) 
-                  -> crushEffect      (TApp t1 (down t2))
-
-                TCon (TyConSpec TcConDeepAlloc) 
-                  -> crushEffect      (TApp t1 (down t2))
-
-                -- If the closure is miskinded then trimClosure can 
-                -- return Nothing, so we leave it untrimmed.
-                TCon (TyConSpec TcConDeepUse)
-                  -> fromMaybe tt (trimClosure (TApp t1 (down t2)))
-
-                _ -> TApp (down t1) (down t2)
-
-         TSum ss        
-          -> TSum (down ss)
+         TCon{}         -> tt
+         TApp t1 t2     -> TApp (down t1) (down t2)
+         TSum ss        -> TSum (down ss)
 
          TForall b tBody
           | namedBoundMatchesBind u b -> tt
@@ -114,7 +89,8 @@
           -> let -- Substitute into the annotation on the binder.
                  bSub            = down b
 
-                 -- Push bind onto stack, and anonymise to avoid capture if needed
+                 -- Push bind onto stack, and anonymise to avoid capture
+                 -- if needed
                  (stack', b')    = pushBind fns stack bSub
                 
                  -- Substitute into body.
diff --git a/DDC/Type/Transform/Trim.hs b/DDC/Type/Transform/Trim.hs
deleted file mode 100644
--- a/DDC/Type/Transform/Trim.hs
+++ /dev/null
@@ -1,166 +0,0 @@
-
-module DDC.Type.Transform.Trim 
-        (trimClosure)
-where
-import DDC.Type.Collect
-import DDC.Type.Check.CheckCon
-import DDC.Type.Exp
-import DDC.Type.Compounds
-import DDC.Type.Predicates
-import Control.Monad
-import Data.Set                 (Set)
-import qualified DDC.Type.Env   as Env
-import qualified DDC.Type.Sum   as Sum
-import qualified Data.Set       as Set
-
-
--- | Trim compound closures into their components. 
---
---   This is like `crushEffect`, but for closures instead of effects.
---
---   For example, trimming @DeepUse (Int r2 -(Read r1 | Use r1)> Int r2)@ yields
---   just @Use r1@. 
---   Only @r1@ might contain an actual store object that is reachable from a function
---   closure with such a type.
---
---   This function assumes the closure is well-kinded, and may return `Nothing` if
---   this is not the case.
---
-trimClosure 
-        :: Ord n
-        => Closure n 
-        -> Maybe (Closure n)
-
-trimClosure cc
-        = {-# SCC trimClosure #-}
-          liftM TSum $ trimToSumC cc
-
-
--- | Trim a closure down to a closure sum.
---   May return 'Nothing' if the closure is mis-kinded.
-trimToSumC 
-        :: forall n. Ord n
-        => Closure n -> Maybe (TypeSum n)
-
-trimToSumC cc
- = case cc of
-        -- Keep closure variables.
-        TVar{}          -> Just $ Sum.singleton kClosure cc
-
-        -- There aren't any naked constructors of closure type.
-        -- If we find a constructor the closure is miskinded.
-        TCon{}          -> Nothing
-        
-        -- The body of a forall should have data or witness kind.
-        -- If we find a forall then the closure is miskinded.
-        TForall{}       -> Nothing
-
-        -- Keep use constructor applied to a region.
-        TApp (TCon (TyConSpec TcConUse)) _
-         -> Just $ Sum.singleton kClosure cc
-        
-        -- Trim DeepUse constructor applied to a data type.
-        TApp (TCon (TyConSpec TcConDeepUse)) t2 
-         -> Just $ trimDeepUsedD t2
-
-        -- Some other constructor we don't know about,
-        --  perhaps using a type variable of higher kind.
-        TApp{}          -> Just $ Sum.singleton kClosure cc
-
-        -- Trim components of a closure sum and rebuild the sum.
-        TSum ts
-         -> case sequence $ map trimToSumC $ Sum.toList ts of
-                Nothing         -> Nothing
-                Just sums       -> Just $ Sum.fromList kClosure
-                                $  concatMap Sum.toList sums
-
-
--- | Trim the argument of a DeepUsed constructor down to a closure sum.
---   The argument is of data kind.
-trimDeepUsedD 
-        :: forall n. Ord n
-        => Type n -> TypeSum n
-
-trimDeepUsedD tt
- = case tt of
-        -- Keep type variables.
-        TVar{}          -> Sum.singleton kClosure $ tDeepUse tt
-
-        -- Naked data constructors like 'Unit' don't contain region variables,
-        --  but the interpreter uses constructors of region kind to encode
-        --  region handes, that we need to keep.
-        TCon tc
-         |  Just k       <- takeKindOfTyCon tc
-         ,  isRegionKind k
-         -> Sum.singleton kClosure $ tDeepUse tt
-
-         | otherwise
-         -> Sum.empty kClosure
-
-        -- Add locally bound variable to the environment.
-        -- See Note: Trimming Foralls. 
-        TForall{}
-         -> let ns      = freeT Env.empty tt  :: Set (Bound n)
-            in  if Set.size ns == 0
-                 then Sum.empty kClosure
-                 else Sum.singleton kClosure $ tDeepUse tt
-
-        -- Trim function constructors.
-        -- See Note: Material variables and the interpreter
-        TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFunEC)) _t1) _eff) clo) _t2
-         -> Sum.singleton kClosure clo
-
-        -- Trim a type application.
-        -- See Note: Trimming with higher kinded type vars.
-        TApp{}
-         -> case takeTyConApps tt of
-             Just (tc, args)     
-              | Just k          <- takeKindOfTyCon tc
-              , Just cs         <- sequence $ zipWith makeUsed (takeKFuns' k) args
-              ->  Sum.fromList kClosure cs
-
-             _ -> Sum.singleton kClosure $ tDeepUse tt
-
-        -- We shouldn't get sums of data types in regular code, 
-        --  but the (tBot kData) form might appear in debugging. 
-        TSum{}          -> Sum.singleton kClosure $ tDeepUse tt
-
-
--- | Make the appropriate Use term for a type of the given kind, or `Nothing` if
---  there isn't one. Also recursively trim types of data kind.
-makeUsed :: (Eq n, Ord n) => Kind n -> Type n -> Maybe (Closure n)
-makeUsed k t
-        | isRegionKind k        = Just $ tUse t
-        | isDataKind   k        = Just $ TSum $ trimDeepUsedD t
-        | isEffectKind k        = Just $ tBot kClosure
-        | isClosureKind k       = Just $ t
-        | otherwise             = Nothing 
-
-
-{- [Note: Trimming with higher kinded type vars]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-   We can't just look at the free variables here and wrap Use and DeepUse constructors
-   around them, as the type may contain higher kinded type variables such as: (t a).
-   We cannot simply drop such variables, as they may be substituted for types that
-   contain components that we must keep in the closure. To handle this, when we see
-   higher kinded type varibles we preserve the entire type application, which is
-   DeepUse (t a) in this example.
-
-   [Note: Trimming Foralls]
-   ~~~~~~~~~~~~~~~~~~~~~~~~
-   For now we just drop the forall if the free vars list is empty. This is ok because
-   we only do this at top-level, so don't need to lower debruijn indices to account for
-   deleted intermediate quantifiers.
-
-   [Note: Material variables and the interpreter]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-   Even though we're not tracking material vars properly yet, 
-   for the interpreter we need to ignore the non-material parameters of the
-   function constructor so that we can treat store location constructors as
-   having an empty closure. For example:
-
-    L2# :: Int R1# -> Int R1#
-   
-   This does not capture the R1# region, even the handle for it is in its type.
--}
-
diff --git a/DDC/Type/Universe.hs b/DDC/Type/Universe.hs
--- a/DDC/Type/Universe.hs
+++ b/DDC/Type/Universe.hs
@@ -104,7 +104,6 @@
         
         TCon (TyConSpec TcConUnit) -> Just UniverseData
         TCon (TyConSpec TcConFun)  -> Just UniverseData
-        TCon (TyConSpec TcConFunEC)-> Just UniverseData
         TCon (TyConSpec TcConSusp) -> Just UniverseData
         TCon (TyConSpec _)         -> Nothing
         
diff --git a/ddc-core.cabal b/ddc-core.cabal
--- a/ddc-core.cabal
+++ b/ddc-core.cabal
@@ -1,5 +1,5 @@
 Name:           ddc-core
-Version:        0.4.1.3
+Version:        0.4.2.1
 License:        MIT
 License-file:   LICENSE
 Author:         The Disciplined Disciple Compiler Strike Force
@@ -11,43 +11,58 @@
 Homepage:       http://disciple.ouroborus.net
 Synopsis:       Disciplined Disciple Compiler core language and type checker.
 Description:    
-        Disciple Core is an explicitly typed language based on System-F2, intended
-        as an intermediate representation for a compiler. In addition to the polymorphism of 
-        System-F2 it supports region, effect and closure typing. Evaluation order is 
-        left-to-right call-by-value by default. There is a capability system to track whether
-        objects are mutable or constant, and to ensure that computations that perform visible
-        side effects are not reordered inappropriately.
+        Disciple Core is an explicitly typed language based on System-F2,
+        intended as an intermediate representation for a compiler. In addition
+        to the polymorphism of System-F2 it supports region, effect and closure
+        typing. Evaluation order is left-to-right call-by-value by default.
+        There is a capability system to track whether objects are mutable or
+        constant, and to ensure that computations that perform visible side
+        effects are not reordered inappropriately.
 
         See the @ddc-tools@ package for a user-facing interpreter and compiler.
 
 Library
   Build-Depends: 
-        base            >= 4.6 && < 4.8,
+        base            >= 4.6 && < 4.9,
         array           >= 0.4 && < 0.6,
-        deepseq         == 1.3.*,
+        deepseq         >= 1.3 && < 1.5,
         containers      == 0.5.*,
         directory       == 1.2.*,
+        text            >= 1.0 && < 1.3,
         transformers    == 0.4.*,
-        mtl             == 2.2.*,
-        ddc-base        == 0.4.1.*
+        mtl             == 2.2.1.*,
+        ddc-base        == 0.4.2.*
 
   Exposed-modules:
-        DDC.Core.Annot.AnT
-        DDC.Core.Annot.AnTEC
+        DDC.Core.Collect.Support
 
-        DDC.Core.Compounds.Annot
-        DDC.Core.Compounds.Simple
+        DDC.Core.Exp.Annot.AnT
+        DDC.Core.Exp.Annot.AnTEC
+        DDC.Core.Exp.Annot.Compounds
+        DDC.Core.Exp.Annot.Context
+        DDC.Core.Exp.Annot.Ctx
+        DDC.Core.Exp.Annot.Exp
+        DDC.Core.Exp.Annot.Predicates
 
+        DDC.Core.Exp.Generic.BindStruct
+        DDC.Core.Exp.Generic.Compounds
+        DDC.Core.Exp.Generic.Exp
+        DDC.Core.Exp.Generic.Predicates
+        DDC.Core.Exp.Generic.Pretty
+
+        DDC.Core.Exp.Simple.Compounds
+        DDC.Core.Exp.Simple.Exp
         DDC.Core.Exp.Annot
-        DDC.Core.Exp.Simple
+        DDC.Core.Exp
 
         DDC.Core.Lexer.Names
         DDC.Core.Lexer.Tokens
+        DDC.Core.Lexer.Unicode
         
         DDC.Core.Transform.Annotate
+        DDC.Core.Transform.BoundT
+        DDC.Core.Transform.BoundX
         DDC.Core.Transform.Deannotate
-        DDC.Core.Transform.LiftT
-        DDC.Core.Transform.LiftX
         DDC.Core.Transform.MapT
         DDC.Core.Transform.Reannotate
         DDC.Core.Transform.Rename
@@ -55,27 +70,23 @@
         DDC.Core.Transform.SubstituteTX
         DDC.Core.Transform.SubstituteWX
         DDC.Core.Transform.SubstituteXX
-        DDC.Core.Transform.Trim
 
+        DDC.Core.Call
         DDC.Core.Check
         DDC.Core.Collect
-        DDC.Core.Compounds
-        DDC.Core.Exp
+
         DDC.Core.Fragment
         DDC.Core.Lexer
         DDC.Core.Load
         DDC.Core.Module
         DDC.Core.Parser
-        DDC.Core.Predicates
         DDC.Core.Pretty
 
-        DDC.Type.Transform.Crush
+        DDC.Type.Transform.BoundT
         DDC.Type.Transform.Instantiate
-        DDC.Type.Transform.LiftT
         DDC.Type.Transform.Rename
         DDC.Type.Transform.SpreadT
         DDC.Type.Transform.SubstituteT
-        DDC.Type.Transform.Trim
         
         DDC.Type.Bind
         DDC.Type.Check
@@ -112,24 +123,13 @@
         DDC.Core.Check.ErrorMessage
         DDC.Core.Check.Exp
         DDC.Core.Check.Module
-        DDC.Core.Check.TaggedClosure
         DDC.Core.Check.Witness
 
         DDC.Core.Collect.Free
         DDC.Core.Collect.Free.Simple
-        DDC.Core.Collect.Support
-        
-        DDC.Core.Exp.DaCon
-        DDC.Core.Exp.Pat
+
+        DDC.Core.Exp.DaCon        
         DDC.Core.Exp.WiCon
-        
-        DDC.Core.Parser.Base
-        DDC.Core.Parser.Context
-        DDC.Core.Parser.Exp
-        DDC.Core.Parser.Module
-        DDC.Core.Parser.Param
-        DDC.Core.Parser.Type
-        DDC.Core.Parser.Witness
 
         DDC.Core.Fragment.Compliance
         DDC.Core.Fragment.Error
@@ -138,7 +138,22 @@
 
         DDC.Core.Lexer.Comments
         DDC.Core.Lexer.Offside
+        
+        DDC.Core.Module.Export
+        DDC.Core.Module.Import
+        DDC.Core.Module.Name
 
+        DDC.Core.Parser.Base
+        DDC.Core.Parser.Context
+        DDC.Core.Parser.DataDef
+        DDC.Core.Parser.Exp
+        DDC.Core.Parser.ExportSpec
+        DDC.Core.Parser.ImportSpec
+        DDC.Core.Parser.Module
+        DDC.Core.Parser.Param
+        DDC.Core.Parser.Type
+        DDC.Core.Parser.Witness
+
         DDC.Type.Check.Judge.Eq
         DDC.Type.Check.Judge.Kind
         DDC.Type.Check.Base
@@ -150,34 +165,38 @@
         DDC.Type.Check.ErrorMessage
         
         DDC.Type.Collect.FreeT
-        DDC.Type.Pretty
 
         DDC.Type.Exp.Base
         DDC.Type.Exp.NFData
 
+        DDC.Type.Pretty
+
                   
   GHC-options:
         -Wall
         -fno-warn-orphans
-        -fno-warn-missing-signatures
         -fno-warn-unused-do-bind
         -fno-warn-missing-methods
+        -fno-warn-missing-signatures
 
   Extensions:
-        BangPatterns
-        ParallelListComp
-        PatternGuards
-        RankNTypes
-        FlexibleContexts
-        FlexibleInstances
+        NoMonomorphismRestriction
+        FunctionalDependencies
         MultiParamTypeClasses
         UndecidableInstances
-        KindSignatures
-        NoMonomorphismRestriction
         ScopedTypeVariables
         StandaloneDeriving
-        DoAndIfThenElse
         DeriveDataTypeable
+        FlexibleInstances
+        ParallelListComp
+        FlexibleContexts
+        ConstraintKinds
+        DoAndIfThenElse
+        PatternSynonyms
+        KindSignatures
+        PatternGuards
+        BangPatterns
+        InstanceSigs
         ViewPatterns
-        FunctionalDependencies
+        RankNTypes