packages feed

ddc-core 0.4.1.3 → 0.4.3.1

raw patch · 191 files changed

Files

+ DDC/Control/Check.hs view
@@ -0,0 +1,73 @@++-- | A simple exception monad.+module DDC.Control.Check+        ( CheckM (..)+        , throw+        , runCheck+        , evalCheck+        , get+        , put)+where+import Control.Monad+++-- | Checker monad maintains some state and manages errors during type checking.+data CheckM s err a+        = CheckM (s -> (s, Either err a))+++instance Functor (CheckM s err) where+ fmap   = liftM+++instance Applicative (CheckM s err) where+ (<*>)  = ap+ pure   = return+++instance Monad (CheckM s err) where+ return !x   +  = CheckM (\s -> (s, Right x))+ {-# INLINE return #-}++ (>>=) !(CheckM f) !g  +  = CheckM $ \s  +  -> case f s of+        (s', Left err)  -> (s', Left err)+        (s', Right x)   -> s `seq` x `seq` runCheck s' (g x)+ {-# INLINE (>>=) #-}+++-- | Run a checker computation,+--      returning the result and new state.+runCheck :: s -> CheckM s err a -> (s, Either err a)+runCheck s (CheckM f)   = f s+{-# INLINE runCheck #-}+++-- | Run a checker computation, +--      ignoreing the final state.+evalCheck :: s -> CheckM s err a -> Either err a+evalCheck s m   = snd $ runCheck s m+{-# INLINE evalCheck #-}+++-- | Throw a type error in the monad.+throw :: err -> CheckM s err a+throw !e        = CheckM $ \s -> (s, Left e)+{-# INLINE throw #-}+++-- | Get the state from the monad.+get :: CheckM s err s+get =  CheckM $ \s -> (s, Right s)+{-# INLINE get #-}+++-- | Put a new state into the monad.+put :: s -> CheckM s err ()+put s + =  CheckM $ \_ -> (s, Right ())+{-# INLINE put #-}++
+ DDC/Control/Panic.hs view
@@ -0,0 +1,23 @@++module DDC.Control.Panic+        (panic)+where+import DDC.Data.Pretty+++-- | Print an error message and exit the compiler, ungracefully.+--+--   This function should be called when we end up in a state that is definately+--   due to a bug in the compiler. +--+panic   :: String       -- ^ Package name,+        -> String       -- ^ Function name.+        -> Doc          -- ^ Error message that makes some suggestion of what+                        --   caused the error.+        -> a++panic pkg fun msg+        = error $ renderIndent $ vcat+        [ text "PANIC in" <+> text pkg <> text "." <> text fun +        , indent 2 msg +        , empty]
+ DDC/Control/Parser.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE TypeFamilies #-}++-- | Parser utilities.+module DDC.Control.Parser+        ( module Text.Parsec+        , Parser+        , ParserState   (..)+        , D.SourcePos   (..)+        , runTokenParser+        , pTokMaybe,    pTokMaybeSP+        , pTokAs,       pTokAsSP+        , pTok,         pTokSP)+where+import DDC.Data.Pretty+import DDC.Data.SourcePos       as D+import Data.Functor.Identity+import Text.Parsec              hiding (SourcePos)+import Text.Parsec              as P  +import Text.Parsec.Error        as P+++-- | A generic parser,+--   parameterised over token and return types.+type Parser k a+        =  Eq k+        => P.ParsecT [Located k] (ParserState k) Identity a+++-- | A parser state that keeps track of the name of the source file.+data ParserState k+        = ParseState+        { stateTokenShow        :: k -> String+        , stateFileName         :: String }+++-- | Run a generic parser, making sure all input is consumed.+runTokenParser+        :: Eq k+        => (k -> String)        -- ^ Show a token.+        -> String               -- ^ File name for error messages.+        -> Parser k a           -- ^ Parser to run.+        -> [Located k]          -- ^ Tokens to parse.+        -> Either P.ParseError a++runTokenParser tokenShow fileName parser + = P.runParser eofParser+        ParseState +        { stateTokenShow        = tokenShow+        , stateFileName         = fileName }+        fileName+ where+  eofParser+   = do r <- parser+        -- We can't use primitive Text.Parsec.eof because it requires+        -- @Show (Token k)@+        (do+                c <- pTokMaybe Just+                unexpected (tokenShow c)) <|> return r+++-------------------------------------------------------------------------------+-- | Accept the given token.+pTok   :: k -> Parser k ()+pTok k  = pTokMaybe $ \k' -> if k == k' then Just () else Nothing+++-- | Accept the given token, returning its source position.+pTokSP :: k -> Parser k D.SourcePos+pTokSP k  + = do   (_, sp) <- pTokMaybeSP +                $ \k' -> if k == k' then Just () else Nothing+        return sp+++-- | Accept a token and return the given value.+pTokAs :: k -> t -> Parser k t+pTokAs k t + = do   pTok k+        return t+++-- | Accept a token and return the given value, +--   along with the source position of the token.+pTokAsSP :: k -> t -> Parser k (t, D.SourcePos)+pTokAsSP k t + = do   sp      <- pTokSP k+        return  (t, sp)+++-- | Accept a token if the function returns `Just`. +pTokMaybe :: (k -> Maybe a) -> Parser k a+pTokMaybe f + = do   state   <- P.getState++        P.token (stateTokenShow state . valueOfLocated)+                (parsecSourcePosOfLocated)+                (f . valueOfLocated)+++-- | Accept a token if the function return `Just`, +--   also returning the source position of that token.+pTokMaybeSP  :: (k -> Maybe a) -> Parser k (a, D.SourcePos)+pTokMaybeSP f+ = do   state   <- P.getState++        let f' token' +                = case f (valueOfLocated token') of+                        Nothing -> Nothing+                        Just x  -> Just (x, sourcePosOfLocated token')++        P.token (stateTokenShow state . valueOfLocated)+                (parsecSourcePosOfLocated)+                f'+++-------------------------------------------------------------------------------+instance Pretty P.ParseError where+ data PrettyMode P.ParseError   = PrettyParseError+ pprDefaultMode                 = PrettyParseError+ ppr err+  = vcat $  [  text "Parse error in" <+> text (show (P.errorPos err)) ]+         ++ (map ppr $ packMessages $ P.errorMessages err)+         +         +instance Pretty P.Message where+ data PrettyMode P.Message      = PrettyMessage+ pprDefaultMode                 = PrettyMessage+ ppr msg+  = case msg of+        SysUnExpect str -> text "Unexpected" <+> text str <> text "."+        UnExpect    str -> text "Unexpected" <+> text str <> text "."+        Expect      str -> text "Expected"   <+> text str <> text "."+        Message     str -> text str+++-- | When we get a parse error, parsec adds multiple 'Unexpected' messages,+--   but we only want to display the first one.+packMessages :: [P.Message] -> [P.Message]+packMessages mm+ = case mm of+        []      -> []+        m1@(P.UnExpect _)   :  (P.UnExpect _)    : rest+                -> packMessages (m1 : rest)++        m1@(P.SysUnExpect _) : (P.SysUnExpect _) : rest+                -> packMessages (m1 : rest)++        m1@(P.SysUnExpect _) : (P.UnExpect _)    : rest+                -> packMessages (m1 : rest)++        m1@(P.UnExpect _)    : (P.SysUnExpect _) : rest+                -> packMessages (m1 : rest)++        m1 : rest+                -> m1 : packMessages rest+
− DDC/Core/Annot/AnT.hs 
@@ -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"        ---
− DDC/Core/Annot/AnTEC.hs 
@@ -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"        ---
+ DDC/Core/Call.hs view
@@ -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+
DDC/Core/Check.hs view
@@ -1,4 +1,3 @@- -- | Type checker for the Disciple Core language. --  --   The functions in this module do not check for language fragment compliance.@@ -15,24 +14,87 @@           -- * Checking Modules         , checkModule         +          -- * Checking Types+        , checkType,    checkTypeM+        , checkSpec+        , kindOfSpec+        , sortOfKind+           -- * Checking Expressions-        , Mode       (..)+        , Mode   (..)+        , Demand (..)         , checkExp,     typeOfExp            -- * Checking Witnesses         , checkWitness, typeOfWitness         , typeOfWiCon +          -- * Kinds of Constructors+        , takeSortOfKiCon+        , kindOfTwCon+        , kindOfTcCon+           -- * Annotations         , AnTEC(..)            -- * Error messages-        , Error         (..))+        , Error         (..)+        , ErrorType     (..)+        , ErrorData     (..)) where+import DDC.Core.Check.Judge.Kind+import DDC.Core.Check.Judge.Kind.TyCon+import DDC.Core.Check.Judge.Module+import DDC.Core.Check.Judge.Witness import DDC.Core.Check.Error-import DDC.Core.Check.ErrorMessage      ()-import DDC.Core.Check.Module import DDC.Core.Check.Exp-import DDC.Core.Check.Witness import DDC.Core.Check.Base-                +++-- | Check a type in the given universe with the given environment+--   Returns the updated type and its classifier (a kind or sort),+--   depeding on the universe of the type being checked.+checkType  :: (Ord n, Show n, Pretty n)+           => Config n -> Universe -> Type n+           -> Either (Error a n) (Type n, Type n)++checkType config uni tt+ = evalCheck (mempty, 0, 0)+ $ do   (t, k, _) <- checkTypeM config emptyContext uni tt Recon+        return (t, k)+++-- | Check a spec in the given environment, returning an error or its kind.+checkSpec  :: (Ord n, Show n, Pretty n) +           => Config n -> Type n+           -> Either (Error a n) (Type n, Kind n)++checkSpec config tt + = evalCheck (mempty, 0, 0)+ $ do   (t, k, _) <- checkTypeM config emptyContext UniverseSpec tt Recon+        return (t, k)+++-- | Check a spec in an empty environment, returning an error or its kind.+kindOfSpec+        :: (Ord n, Show n, Pretty n) +        => Config n -> Type n +        -> Either (Error a n) (Kind n)++kindOfSpec config tt+ = evalCheck (mempty, 0, 0)+ $ do   (_, k, _) <- checkTypeM config emptyContext UniverseSpec tt Recon+        return k+++-- | Check a kind in an empty environment, returning an error or its sort.+sortOfKind +        :: (Ord n, Show n, Pretty n)+        => Config n -> Kind n+        -> Either (Error a n) (Sort n)++sortOfKind config tt+ = evalCheck (mempty, 0, 0)+ $ do   (_, s, _) <- checkTypeM config emptyContext UniverseKind tt Recon+        return s+
DDC/Core/Check/Base.hs view
@@ -7,64 +7,59 @@         , CheckM         , newExists         , newPos+        , applyContext+        , applySolved          , CheckTrace (..)         , ctrace -        , checkTypeM-        , checkBindM-           -- Things defined elsewhere.         , throw, runCheck, evalCheck-        , KindEnv, TypeEnv+        , EnvX,  EnvT, TypeEnv, KindEnv         , 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.Type.Check.Context+        , module DDC.Core.Exp.Annot+        , module DDC.Core.Check.Context+         , module DDC.Type.DataDef-        , module DDC.Type.Equiv         , module DDC.Type.Universe-        , module DDC.Type.Compounds-        , module DDC.Type.Predicates-        , module DDC.Type.Exp-        , module DDC.Base.Pretty+        , module DDC.Type.Exp.Simple+        , module DDC.Data.Pretty         , module DDC.Data.ListUtils         , module Control.Monad         , module Data.Maybe) 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.Type.Check.Context-import DDC.Type.Check                           (Config (..), configOfProfile)-import DDC.Type.Env                             (KindEnv, TypeEnv)+import DDC.Core.Exp.Annot+import DDC.Core.Check.Context+import DDC.Core.Check.Config+import DDC.Core.Env.EnvT                (EnvT)+import DDC.Core.Env.EnvX                (EnvX)++import DDC.Type.Env                     (TypeEnv, KindEnv) import DDC.Type.DataDef-import DDC.Type.Equiv import DDC.Type.Universe-import DDC.Type.Compounds-import DDC.Type.Predicates-import DDC.Type.Exp-import DDC.Base.Pretty-import DDC.Control.Monad.Check                  (throw, runCheck, evalCheck)+import DDC.Type.Exp.Simple+import DDC.Control.Check                (throw, runCheck, evalCheck)+import DDC.Data.Pretty import DDC.Data.ListUtils+ import Control.Monad-import Data.Monoid                              hiding ((<>))+import Data.Monoid                      hiding ((<>)) import Data.Maybe-import Data.Set                                 (Set)-import qualified DDC.Type.Check                 as T-import qualified DDC.Control.Monad.Check        as G+import Data.Set                         (Set)+import qualified Data.Set               as Set+import qualified DDC.Control.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 +78,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 $ ErrorTypeInfinite 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 $ ErrorTypeInfinite tExt tBind+        Right t -> return t+++ -- CheckTrace ----------------------------------------------------------------- -- | Human readable trace of the type checker.-data CheckTrace +data CheckTrace         = CheckTrace         { checkTraceDoc :: Doc } @@ -94,9 +108,9 @@  instance Monoid CheckTrace where  mempty = CheckTrace empty- +  mappend ct1 ct2-        = CheckTrace +        = CheckTrace         { checkTraceDoc = checkTraceDoc ct1 <> checkTraceDoc ct2 }  @@ -107,57 +121,4 @@         let tr' = tr { checkTraceDoc = checkTraceDoc tr <$> doc' }         G.put (tr', ix, pos)         return  ()----- Bind -------------------------------------------------------------------------- | Check the type of a bind.-checkBindM-        :: (Ord n, Show n, Pretty n)-        => Config n             -- ^ Checker configuration.-        -> KindEnv n            -- ^ Global kind environment.-        -> Context n            -- ^ Local context.-        -> Universe             -- ^ Universe for the type of the bind.-        -> Bind n               -- ^ Check this bind.-        -> Mode n               -- ^ Mode for bidirectional checking.-        -> 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 -                                (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) -        => Config n             -- ^ Checker configuration.-        -> KindEnv n            -- ^ Global kind environment.-        -> Context n            -- ^ Local context.-        -> Universe             -- ^ Universe the type is supposed to be in.-        -> Type n               -- ^ Check this type.-        -> Mode n               -- ^ Mode for bidirectional checking-        -> 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 -        -- 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 -        -- so we can throw it from our exp/type checker.-        case result of-         Left err               -          -> throw $ ErrorType err--         Right (t, k, ctx')     -          -> return (t, k, ctx')
+ DDC/Core/Check/Config.hs view
@@ -0,0 +1,79 @@++module DDC.Core.Check.Config+        ( Config (..)+        , configOfProfile)+where+import DDC.Type.DataDef+import DDC.Type.Env                     (KindEnv, TypeEnv)+import qualified DDC.Core.Fragment      as F+++-- Config ---------------------------------------------------------------------+-- | Static configuration for the type checker.+--   These fields don't change as we decend into the tree.+--+--   The starting configuration should be converted from the profile that+--   defines the language fragment you are checking. +--   See "DDC.Core.Fragment" and use `configOfProfile` below.+data Config n+        = Config+        { -- | Kinds of primitive types.+          configPrimKinds               :: KindEnv n++          -- | Types of primitive operators.+        , configPrimTypes               :: TypeEnv n++          -- | Data type definitions.+        , configPrimDataDefs            :: DataDefs 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++          -- | Track closure type information.+        , configTrackedClosures         :: Bool ++          -- | Attach effect information to function types.+        , configFunctionalEffects       :: Bool++          -- | Attach closure information to function types.+        , configFunctionalClosures      :: Bool++          -- | Treat effects as capabilities.+        , configEffectCapabilities      :: Bool ++          -- | Allow general let-rec+        , configGeneralLetRec           :: Bool++          -- | Automatically run effectful applications.+        , configImplicitRun             :: Bool++          -- | Automatically box bodies of abstractions.+        , configImplicitBox             :: Bool+        }+++-- | Convert a language profile to a type checker configuration.+configOfProfile :: F.Profile n -> Config n+configOfProfile profile+ = let  features        = F.profileFeatures profile+   in   Config+        { configPrimKinds               = F.profilePrimKinds            profile+        , configPrimTypes               = F.profilePrimTypes            profile+        , configPrimDataDefs            = F.profilePrimDataDefs         profile+        , configNameIsHole              = F.profileNameIsHole           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+        }+        +
+ DDC/Core/Check/Context.hs view
@@ -0,0 +1,78 @@++module DDC.Core.Check.Context+        ( +          -- * Type Checker Mode.+          Mode    (..)++          -- * Positions in the Context.+        , Pos     (..)++          -- * Roles of Type Variable.+        , Role    (..)++          -- * Existentials+        , Exists  (..)+        , typeOfExists+        , takeExists+        , slurpExists++          -- * Context Elements.+        , Elem    (..)++          -- * Checker Context.+        , Context (..)++          -- * Construction+        , emptyContext+        , contextOfEnvT+        , contextOfEnvX+        , contextOfPrimEnvs++          -- * Projection+        , contextEquations+        , contextCapabilities+        , contextDataDefs+        , contextEnvT++          -- * Pushing+        , pushType,   pushTypes+        , pushKind,   pushKinds+        , pushExists, pushExistsBefore, pushExistsScope++          -- * Marking+        , markContext++          -- * Popping+        , popToPos++          -- * Lookup+        , lookupType+        , lookupKind+        , lookupExistsEq++          -- * Membership+        , memberType+        , memberKind+        , memberKindBind++          -- * Existentials+        , locationOfExists+        , updateExists++          -- * Lifting and Lowering+        , liftTypes+        , lowerTypes++          -- * Applying+        , applyContextEither+        , applySolvedEither++          -- * Effects+        , effectSupported)+where+import DDC.Core.Check.Context.Effect+import DDC.Core.Check.Context.Apply+import DDC.Core.Check.Context.Elem+import DDC.Core.Check.Context.Mode+import DDC.Core.Check.Context.Base+
+ DDC/Core/Check/Context/Apply.hs view
@@ -0,0 +1,121 @@++module DDC.Core.Check.Context.Apply+        ( applyContextEither+        , applySolvedEither)+where+import DDC.Core.Check.Context.Elem+import DDC.Core.Check.Context.Base+import DDC.Type.Exp.Simple+import qualified DDC.Type.Sum           as Sum++import Data.Set                         (Set)+import Data.Maybe+import qualified Data.IntMap.Strict     as IntMap+import qualified Data.Set               as Set++import Prelude                          hiding ((<$>))+++-- | 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.+--+--   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{}          +         ->     return tt++        TCon (TyConExists i k)  +         |  Just t      <- lookupExistsEq (Exists i k) ctx+         -> if Set.member i is +                then Left (tt, t)+                else applyContextEither ctx (Set.insert i is) t++        TCon{}+         ->     return tt++        TAbs b t     +         -> do  tb'     <- applySolvedEither ctx is (typeOfBind b)+                let b'  =  replaceTypeOfBind tb' b+                t'      <- applySolvedEither ctx is t+                return $ TAbs b' t'++        TApp t1 t2+         -> do  t1'     <- applySolvedEither ctx is t1+                t2'     <- applySolvedEither ctx is t2+                return  $ TApp t1' t2'++        TForall b t     +         -> do  tb'     <- applySolvedEither ctx is (typeOfBind b)+                let b'  =  replaceTypeOfBind tb' b+                t'      <- applySolvedEither ctx is t+                return $ TForall b' t'++        TSum ts         +         -> do  tss'    <- mapM (applyContextEither ctx is) +                        $  Sum.toList ts++                return  $ TSum+                        $ Sum.fromList (Sum.kindOfSum ts) tss'+++-- | 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{}          +         ->     return tt++        TCon (TyConExists i k)+         |  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+         -> if Set.member i is+                then Left (tt, t)+                else applySolvedEither ctx (Set.insert i is) t++        TCon {}+         ->     return tt++        TAbs b t+         -> do  tb'     <- applySolvedEither ctx is (typeOfBind b)     +                let b'  =  replaceTypeOfBind tb' b+                t'      <- applySolvedEither ctx is t+                return  $ TAbs b' t'++        TApp t1 t2      +         -> do  t1'     <- applySolvedEither ctx is t1+                t2'     <- applySolvedEither ctx is t2+                return  $ TApp t1' t2'++        TForall b t+         -> do  tb'     <- applySolvedEither ctx is (typeOfBind b)     +                let b'  =  replaceTypeOfBind tb' b+                t'      <- applySolvedEither ctx is t+                return  $ TForall b' t'++        TSum ts+         -> do  tss'    <- mapM (applySolvedEither ctx is)+                        $  Sum.toList ts++                return  $  TSum+                        $  Sum.fromList (Sum.kindOfSum ts) tss'+
+ DDC/Core/Check/Context/Base.hs view
@@ -0,0 +1,433 @@++module DDC.Core.Check.Context.Base +        ( Context (..)++          -- * Construction+        , emptyContext+        , contextOfEnvT+        , contextOfEnvX+        , contextOfPrimEnvs++          -- * Projection+        , contextEquations+        , contextCapabilities+        , contextDataDefs+        , contextEnvT++          -- * Pushing+        , pushType,   pushTypes+        , pushKind,   pushKinds+        , pushExists+        , pushExistsBefore+        , pushExistsScope++          -- * Marking+        , markContext++          -- * Popping+        , popToPos++          -- * Lookup+        , lookupType+        , lookupKind+        , lookupExistsEq++          -- * Membership+        , memberType+        , memberKind+        , memberKindBind++          -- * Existentials+        , locationOfExists+        , updateExists++          -- * Lifting+        , liftTypes+        , lowerTypes)+where+import DDC.Core.Check.Context.Elem+import DDC.Core.Env.EnvX                (EnvX)+import DDC.Core.Env.EnvX                (EnvT)+import DDC.Type.Transform.BoundT+import DDC.Type.Exp.Simple+import DDC.Type.DataDef+import DDC.Data.Pretty+import qualified DDC.Core.Env.EnvT      as EnvT+import qualified DDC.Core.Env.EnvX      as EnvX+import qualified DDC.Type.Env           as Env++import Data.Maybe+import Data.IntMap.Strict               (IntMap)+import Data.Map                         (Map)+import qualified Data.IntMap.Strict     as IntMap++import Prelude                          hiding ((<$>))++++-- Context --------------------------------------------------------------------+-- | The type checker context.+-- +--   Holds a position counter and a stack of elements. +--   The top of the stack is at the front of the list.+--+data Context n+        = Context +        { -- | Top level environment for terms.+          contextEnvX           :: !(EnvX n)++          -- | Fresh name generator for context positions.+        , contextGenPos         :: !Int++          -- | Fresh name generator for existential variables.+        , contextGenExists      :: !Int ++          -- | The current context stack.+        , contextElems          :: ![Elem n] +        +          -- | Types of solved existentials.+          --   When solved constraints are popped from the main context stack+          --   they are added to this map. The map is used to fill in type +          --   annotations after type inference proper. It's not used as part+          --   of the main algorithm.+        , contextSolved         :: IntMap (Type n) }+++instance (Pretty n, Eq n) => Pretty (Context n) where+ ppr (Context _ genPos genExists ls _solved)+  =   text "Context "+  <$> text "  genPos    = " <> int genPos+  <$> text "  genExists = " <> int genExists+  <$> indent 2 +        (vcat $ [padL 4 (int i)  <+> ppr l+                        | l <- reverse ls+                        | i <- [0..]])++++-- Construction ---------------------------------------------------------------+-- | An empty context.+emptyContext :: Context n+emptyContext +        = Context+        { contextEnvX           = EnvX.empty+        , contextGenPos         = 0+        , contextGenExists      = 0 +        , contextElems          = []+        , contextSolved         = IntMap.empty }+++-- | Wrap an EnvT into a Context.+contextOfEnvT :: EnvT n -> Context n+contextOfEnvT envt+ = let  envx    = EnvX.empty+                { EnvX.envxEnvT = envt }+   in   contextOfEnvX envx+++-- | Wrap an `EnvX` into a context.+contextOfEnvX :: EnvX n -> Context n+contextOfEnvX envx+        = emptyContext { contextEnvX = envx }+++-- | Build a context from prim environments.+contextOfPrimEnvs+        :: Ord n+        => Env.KindEnv n+        -> Env.TypeEnv n+        -> DataDefs n+        -> Context n++contextOfPrimEnvs kenv tenv defs+        = emptyContext +        { contextEnvX = EnvX.fromPrimEnvs kenv tenv defs }+++-- Projection -----------------------------------------------------------------+-- | Take the type equations from a context.+contextEquations :: Context n -> Map n (Type n)+contextEquations ctx+ = EnvT.envtEquations   $ contextEnvT ctx+++-- | Take the capabilities from a context.+contextCapabilities :: Context n -> Map n (Type n)+contextCapabilities ctx+ = EnvT.envtCapabilities $ contextEnvT ctx+++-- | Take the capabilities from a context.+contextDataDefs :: Context n -> DataDefs n+contextDataDefs ctx+ = EnvX.envxDataDefs $ contextEnvX ctx+++-- | Take the top level environment for types from the context.+contextEnvT :: Context n -> EnvT n+contextEnvT ctx+ = EnvX.envxEnvT (contextEnvX ctx)+++-- Push -----------------------------------------------------------------------+-- | Push the type of some value variable onto the context.+pushType  :: Bind n -> Context n -> Context n+pushType b ctx+ = ctx { contextElems = ElemType b : contextElems ctx }+++-- | Push many types onto the context.+pushTypes :: [Bind n] -> Context n -> Context n+pushTypes bs ctx+ = foldl (flip pushType) ctx bs+++-- | Push the kind of some type variable onto the context.+pushKind :: Bind n -> Role -> Context n -> Context n+pushKind b role ctx+ = ctx { contextElems = ElemKind b role : contextElems ctx }+++-- | Push many kinds onto the context.+pushKinds :: [(Bind n, Role)] -> Context n -> Context n+pushKinds brs ctx+ = foldl (\ctx' (b, r) -> pushKind b r ctx') ctx brs+++-- | Push an existential declaration onto the context.+--   If this is not an existential then `error`.+pushExists :: Exists n -> Context n -> Context n+pushExists i ctx+ = ctx { contextElems = ElemExistsDecl i : contextElems ctx }+++-- | Push the first existential into the context just before the+--   declaration of the second one.+pushExistsBefore :: Exists n -> Exists n -> Context n -> Context n+pushExistsBefore i (Exists n _) ctx+ = ctx { contextElems = go (contextElems ctx) }+ where+        go (ElemExistsDecl i'@(Exists n' _)   : es)+         | n' == n      = ElemExistsDecl i'   : ElemExistsDecl i : es++        go (ElemExistsEq   i'@(Exists n' _) t : es)+         | n' == n      = ElemExistsEq   i' t : ElemExistsDecl i : es++        go (e : es)     = e : go es+        go []           = []+++pushExistsScope :: Exists n -> [Exists n] -> Context n -> Context n+pushExistsScope i scope ctx+ = ctx { contextElems +                = go    (ElemExistsDecl i : contextElems ctx) +                        []+                        (contextElems ctx) +       }+ where  +        go cs' acc (e : es)+         | Just i' <- takeExistsOfElem e+         , elem i' scope        +         = go (reverse acc ++ (e : ElemExistsDecl i : es)) (e : acc) es++         | otherwise+         = go cs' (e : acc) es++        go cs' _acc []+         = cs'+++-- Mark / Pop -----------------------------------------------------------------+-- | Mark the context with a new position.+markContext :: Context n -> (Context n, Pos)+markContext ctx+ = let  p       = contextGenPos ctx+        pos     = Pos p+   in   ( ctx   { contextGenPos = p + 1+                , contextElems  = ElemPos pos : contextElems ctx }+        , pos )+++-- | Pop elements from a context to get back to the given position.+popToPos :: Pos -> Context n -> Context n+popToPos pos ctx+ = ctx { contextElems = go $ contextElems ctx }+ where+        go []                  = []++        go (ElemPos pos' : ls)+         | pos' == pos          = ls+         | otherwise            = go ls++        go (_ : ls)             = go ls+++-- Lookup ---------------------------------------------------------------------+-- | Given a bound level-0 (value) variable, lookup its type (level-1) +--   from the context.+lookupType :: Eq n => Bound n -> Context n -> Maybe (Type n)+lookupType u ctx+ = case u of+        UPrim{}         -> Nothing+        UName n         -> goName n    (contextElems ctx)+        UIx   ix        -> goIx   ix 0 (contextElems ctx)+ where+        goName _n []    = Nothing+        goName n  (ElemType (BName n' t) : ls)+         | n == n'      = Just t+         | otherwise    = goName n ls+        goName  n (_ : ls)+         = goName n ls+++        goIx _ix _d []  = Nothing+        goIx ix d  (ElemType (BAnon t) : ls)+         | ix == d      = Just t+         | otherwise    = goIx   ix (d + 1) ls+        goIx ix d  (_ : ls)+         = goIx ix d ls+++-- | Given a bound level-1 (type) variable, lookup its kind (level-2) from+--   the context.+lookupKind :: Eq n => Bound n -> Context n -> Maybe (Kind n, Role)+lookupKind u ctx+ = case u of+        UPrim{}         -> Nothing+        UName n         -> goName n    (contextElems ctx)+        UIx   ix        -> goIx   ix 0 (contextElems ctx)+ where+        goName _n []    = Nothing+        goName n  (ElemKind (BName n' t) role : ls)+         | n == n'      = Just (t, role)+         | otherwise    = goName n ls+        goName  n (_ : ls)+         = goName n ls+++        goIx _ix _d []  = Nothing+        goIx ix d  (ElemKind (BAnon t) role : ls)+         | ix == d      = Just (t, role)+         | otherwise    = goIx   ix (d + 1) ls+        goIx ix d  (_ : ls)+         = goIx ix d ls+++-- | Lookup the type bound to an existential, if any.+lookupExistsEq :: Exists n -> Context n -> Maybe (Type n)+lookupExistsEq i ctx+ = go (contextElems ctx)+ where  go []                           = Nothing+        go (ElemExistsEq i' t : _)+         | i == i'                      = Just t+        go (_ : ls)                     = go ls+++-- Member ---------------------------------------------------------------------+-- | See if this type variable is in the context.+memberType :: Eq n => Bound n -> Context n -> Bool+memberType u ctx = isJust $ lookupType u ctx+++-- | See if this kind variable is in the context.+memberKind :: Eq n => Bound n -> Context n -> Bool+memberKind u ctx = isJust $ lookupKind u ctx+++-- | See if the name on a named binder is in the contexts.+--   Returns False for non-named binders.+memberKindBind :: Eq n => Bind n -> Context n -> Bool+memberKindBind b ctx+ = case b of+        BName n _       -> memberKind (UName n) ctx+        _               -> False+++-- Existentials----------------------------------------------------------------+-- | Get the numeric location of an existential in the context stack,+--   or Nothing if it's not there. Returned value is relative to the TOP+--   of the stack, so the top element has location 0.+locationOfExists +        :: Exists n+        -> Context n+        -> Maybe Int++locationOfExists x ctx+ = go 0 (contextElems ctx)+ where  go !_ix []      = Nothing+        +        go !ix (ElemExistsDecl x'   : moar)+         | x == x'      = Just ix+         | otherwise    = go (ix + 1) moar++        go !ix (ElemExistsEq   x' _ : moar)+         | x == x'      = Just ix+         | otherwise    = go (ix + 1) moar++        go !ix  (_ : moar)+         = go (ix + 1) moar+++-- | Update (solve) an existential in the context stack.+--+--   If the existential is not part of the context then `Nothing`.+updateExists +        :: [Exists n]   -- ^ Other existential declarations to  add before the+                        --   updated one.+        -> Exists n     -- ^ Existential to update.+        -> Type n       -- ^ New monotype.+        -> Context n +        -> Maybe (Context n)++updateExists isMore iEx@(Exists iEx' _) tEx ctx+ = case go $ contextElems ctx of+    Just elems'     +     -> Just $ ctx { contextElems  = elems'+                   , contextSolved = IntMap.insert iEx' tEx (contextSolved ctx) }+    Nothing -> Nothing+ where+        go ll+         = case ll of+                l@ElemPos{}     : ls+                 | Just ls'     <- go ls  -> Just (l : ls')++                l@ElemKind{}    : ls   +                 | Just ls'     <- go ls  -> Just (l : ls')++                l@ElemType{}    : ls+                 | Just ls'     <- go ls  -> Just (l : ls')++                l@(ElemExistsDecl i) : ls+                 | i == iEx             +                 -> let es  =  ElemExistsEq i tEx +                            : [ElemExistsDecl n' | n' <- isMore]+                    in  Just $ es ++ ls++                 | Just ls'     <- go ls  -> Just (l : ls')++                l@ElemExistsEq{} : ls+                 | Just ls'     <- go ls  -> Just (l : ls')++                _ -> Just ll  -- Nothing+++-- Lifting --------------------------------------------------------------------+-- | Lift free debruijn indices in types by the given number of levels.+liftTypes :: Ord n => Int -> Context n -> Context n+liftTypes n ctx+ = ctx { contextElems = go $ contextElems ctx }+ where+        go []                   = []+        go (ElemType b : ls)    = ElemType (liftT n b) : go ls+        go (l:ls)               = l : go ls+++-- Lowering --------------------------------------------------------------------+-- | Lower free debruijn indices in types by the given number of levels.+lowerTypes :: Ord n => Int -> Context n -> Context n+lowerTypes n ctx+ = ctx { contextElems = go $ contextElems ctx }+ where+        go []                   = []+        go (ElemType b : ls)    = ElemType (lowerT n b) : go ls+        go (l:ls)               = l : go ls
+ DDC/Core/Check/Context/Effect.hs view
@@ -0,0 +1,69 @@++module DDC.Core.Check.Context.Effect+        (effectSupported)+where+import DDC.Core.Check.Context.Base+import DDC.Core.Check.Context.Elem+import DDC.Type.Exp.Simple+import Data.Maybe+import qualified DDC.Core.Env.EnvT      as EnvT+import qualified DDC.Type.Sum           as Sum+import qualified Data.Map.Strict        as Map+++-- | Check whether this effect is supported by the given context.+--   This is used when effects are treated as capabilities.+--+--   The overall function can be passed a compound effect, +--    it returns `Nothing` if the effect is supported, +--    or `Just e`, where `e` is some unsuported atomic effect.+--+effectSupported +        :: (Ord n, Show n)+        => Context n +        -> Effect n +        -> Maybe (Effect n)++effectSupported ctx eff +        -- Check that all the components of a sum are supported.+        | TSum ts       <- eff+        = listToMaybe $ concat [ maybeToList $ effectSupported ctx e+                               | e <- Sum.toList ts ]++        -- Abstract effects are fine.+        --  We'll find out if it is really supported once it's instantiated.+        | TVar {} <- eff+        = Nothing++        -- Abstract global effects are always supported.+        | TCon (TyConBound _ k) <- eff+        , k == kEffect+        = Nothing++        -- 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]++        ,   -- Capability in local environment. +            (any  (\b -> equivT (contextEnvT ctx) (typeOfBind b) eff) +                  [ b | ElemType b <- contextElems ctx ] )+   +            -- Capability imported at top level.+         || (any  (\t -> equivT (contextEnvT ctx) t eff)+                  (Map.elems $ EnvT.envtCapabilities $ contextEnvT ctx))+        = 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+
+ DDC/Core/Check/Context/Elem.hs view
@@ -0,0 +1,158 @@++module DDC.Core.Check.Context.Elem+        ( -- * Positions in the context.+          Pos    (..)++          -- * Roles of type variables.+        , Role   (..)++          -- * Existentials.+        , Exists (..)+        , typeOfExists+        , takeExists+        , slurpExists++          -- * Context elements.+        , Elem   (..)+        , takeExistsOfElem)+where+import DDC.Type.Exp.Simple+import DDC.Data.Pretty+import qualified DDC.Type.Sum   as Sum+++-- Positions --------------------------------------------------------------------------------------+-- | A position in the type checker context.+--   A position is used to record a particular position in the context stack,+--   so that we can pop elements higher than it.+data Pos+        = Pos !Int+        deriving (Show, Eq)++instance Pretty Pos where+ ppr (Pos p)+        = text "*" <> int p+++-- Role -------------------------------------------------------------------------------------------+-- | The role of some type variable.+data Role+        -- | Concrete type variables are region variables that have been introduced+        --   in an enclosing lexical scope. All the capabilities for these will +        --   also be in the context.+        = RoleConcrete+        +        -- | Abstract type variables are the ones that are bound by type abstraction+        --   Inside the body of a type abstraction we can assume a region supports+        --   any given capability. We only need to worry about if it really does+        --   when we actually run the enclosed computation.+        | RoleAbstract+        deriving (Show, Eq)+++instance Pretty Role where+ ppr role+  = case role of+        RoleConcrete    -> text "Concrete"+        RoleAbstract    -> text "Abstract"+++-- Exists -----------------------------------------------------------------------------------------+-- | An existential variable.+data Exists n+        = Exists !Int !(Kind n)+        deriving (Show)++instance Eq (Exists n) where+ (==)   (Exists i1 _) (Exists i2 _)     = i1 == i2+ (/=)   (Exists i1 _) (Exists i2 _)     = i1 /= i2+++instance Ord (Exists n) where+ compare (Exists i1 _) (Exists i2 _)+        = compare i1 i2+++instance Pretty (Exists n) where+ ppr (Exists i _) = text "?" <> ppr i+++-- | Wrap an existential variable into a type.+typeOfExists :: Exists n -> Type n+typeOfExists (Exists n k)+        = TCon (TyConExists n k)+++-- | Take an Exists from a type.+takeExists :: Type n -> Maybe (Exists n)+takeExists tt+ = case tt of+        TCon (TyConExists n k)  -> Just (Exists n k)+        _                       -> Nothing+++-- | Slurp all the existential variables from this type.+slurpExists :: Type n -> [Exists n]+slurpExists tt+ = case tt of+        TCon (TyConExists n k)  -> [Exists n k]+        TCon _                  -> []+        TVar {}                 -> []+        TAbs b xBody            -> slurpExists (typeOfBind b) ++ slurpExists xBody+        TApp t1 t2              -> slurpExists t1 ++ slurpExists t2+        TForall b xBody         -> slurpExists (typeOfBind b) ++ slurpExists xBody+        TSum ts                 -> concatMap slurpExists $ Sum.toList ts++++-- Elem -------------------------------------------------------------------------------------------+-- | An element in the type checker context.+data Elem n+        -- | A context position marker.+        = ElemPos        !Pos++        -- | Kind of some variable.+        | ElemKind       !(Bind n) !Role++        -- | Type of some variable.+        | ElemType       !(Bind n)++        -- | Existential variable declaration+        | ElemExistsDecl !(Exists n)++        -- | Existential variable solved to some monotype.+        | ElemExistsEq   !(Exists n) !(Type n)+        deriving (Show, Eq)+++instance (Pretty n, Eq n) => Pretty (Elem n) where+ ppr ll+  = case ll of+        ElemPos p+         -> ppr p++        ElemKind b role  +         -> (padL 4 $ ppr (binderOfBind b))+                <+> text ":" +                <+> (ppr $ typeOfBind b)+                <+> text "@" <> ppr role++        ElemType b+         -> (padL 4 $ ppr (binderOfBind b))+                <+> text ":"+                <+> (ppr $ typeOfBind b)++        ElemExistsDecl (Exists i k)+         -> padL 4 (text "?" <> ppr i) <+> text ":" <+> ppr k++        ElemExistsEq (Exists i k) t +         -> padL 4 (text "?" <> ppr i) <+> text ":" <+> ppr k <+> text "=" <+> ppr t+++-- | Take the existential from this context element, if there is one.+takeExistsOfElem :: Elem n -> Maybe (Exists n)+takeExistsOfElem ee+ = case ee of+        ElemExistsDecl i        -> Just i+        ElemExistsEq   i _      -> Just i+        _                       -> Nothing
+ DDC/Core/Check/Context/Mode.hs view
@@ -0,0 +1,42 @@++module DDC.Core.Check.Context.Mode+        (Mode (..))+where+import DDC.Core.Check.Context.Elem+import DDC.Type.Exp.Simple+import DDC.Data.Pretty+++-- | What mode we're performing type checking/inference in.+data Mode n+        -- | Reconstruct the type of the expression, requiring type annotations+        --   on parameters  as well as type applications to already be present.+        = Recon+        +        -- | The ascending smoke of incense.+        --+        --   Synthesise the type of the expression, producing unification+        --   variables for bidirectional type inference.+        --+        --   Any new unification variables introduced may be used to define the+        --   given existentials, so the need to be declared outside their scopes.+        --   If the list is empty we can add new variables to the inner most scope.+        -- +        | Synth [Exists n]++        -- | The descending tongue of flame.+        --   Check the type of an expression against this expected type, and+        --   unify expected types into unification variables for bidirecional+        --   type inference.+        | Check (Type n)+        deriving (Show, Eq)+++instance (Eq n, Pretty n) => Pretty (Mode n) where+ ppr mode+  = case mode of+        Recon    -> text "RECON"+        Synth is -> text "SYNTH" <+> ppr is+        Check t  -> text "CHECK" <+> parens (ppr t)++
DDC/Core/Check/Error.hs view
@@ -1,418 +1,17 @@ -- | Errors produced when checking core expressions. module DDC.Core.Check.Error-        (Error(..))+        ( Error         (..)+        , ErrorType     (..)+        , ErrorData     (..)) where-import DDC.Core.Exp-import DDC.Type.Universe-import qualified DDC.Type.Check as T----- | All the things that can go wrong when type checking an expression---   or witness.-data Error a n-        -- Type --------------------------------------------        -- | Found a kind error when checking a type.-        = ErrorType-        { errorTypeError        :: T.Error n }--        -- | Found an error in the data type definitions.-        | ErrorData-        { errorData             :: T.ErrorData n }---        -- Module ------------------------------------------        -- | Exported value is undefined.-        | ErrorExportUndefined-        { errorName             :: n }--        -- | Exported name is exported multiple times.-        | ErrorExportDuplicate-        { errorName             :: n }--        -- | Type signature of exported binding does not match the type at-        --   the definition site.-        | ErrorExportMismatch-        { errorName             :: n-        , errorExportType       :: Type n-        , errorDefType          :: Type n }--        -- | Imported name is imported multiple times.-        | ErrorImportDuplicate-        { errorName             :: n }--        -- | An imported value that doesn't have kind Data.-        | ErrorImportValueNotData-        { errorName             :: n }---        -- Exp ---------------------------------------------        -- | Generic mismatch between expected and inferred types.-        | ErrorMismatch-        { errorAnnot            :: a-        , errorInferred         :: Type n-        , errorExpected         :: Type n-        , errorChecking         :: Exp a n }---        -- Var ---------------------------------------------        -- | An undefined type variable.-        | ErrorUndefinedVar-        { errorAnnot            :: a-        , errorBound            :: Bound n -        , errorUniverse         :: Universe }---        -- Con ---------------------------------------------        -- | A data constructor that wasn't in the set of data definitions.-        | ErrorUndefinedCtor-        { errorAnnot            :: a-        , errorChecking         :: Exp a n }---        -- Application -------------------------------------        -- | A function application where the parameter and argument don't match.-        | ErrorAppMismatch-        { errrorAnnot           :: a-        , errorChecking         :: Exp a n-        , errorParamType        :: Type n-        , errorArgType          :: Type n }--        -- | Tried to apply something that is not a function.-        | ErrorAppNotFun-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorNotFunType       :: Type n } --        -- | Cannot infer type of polymorphic expression.-        | ErrorAppCannotInferPolymorphic-        { errorAnnot            :: a-        , errorChecking         :: Exp a n }--        -- Lambda ------------------------------------------        -- | A type abstraction that tries to shadow a type variable that is-        --   already in the environment.-        | ErrorLamShadow-        { errorAnnot            :: a-        , errorChecking         :: Exp a n -        , errorBind             :: Bind n }--        -- | An abstraction where the body has a visible side effect that -        --   is not supported by the current language fragment.-        | ErrorLamNotPure-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , 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 -        , errorType             :: Type n-        , errorKind             :: Kind n }--        -- | An abstraction where the body does not have data kind.-        | ErrorLamBodyNotData-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorBind             :: Bind n-        , errorType             :: Type n-        , errorKind             :: Kind n }--        -- | A function abstraction without a type annotation on the parameter.-        | ErrorLamParamUnannotated-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorBind             :: Bind n }-        -        -- | A type abstraction without a kind annotation on the parameter.-        | ErrorLAMParamUnannotated-        { errorAnnot            :: a-        , errorChecking         :: Exp a n }--        -- | A type abstraction parameter with a bad sort.-        | ErrorLAMParamBadSort-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorBind             :: Bind n-        , errorSort             :: Sort n }---        -- Let ---------------------------------------------        -- | A let-expression where the type of the binder does not match the right-        --   of the binding.-        | ErrorLetMismatch-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorBind             :: Bind n-        , errorType             :: Type n }--        -- | A let-expression where the right of the binding does not have data kind.-        | ErrorLetBindingNotData-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorBind             :: Bind n-        , errorKind             :: Kind n }--        -- | A let-expression where the body does not have data kind.-        | ErrorLetBodyNotData-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorType             :: Type n-        , errorKind             :: Kind n }---        -- Letrec ------------------------------------------        -- | A recursive let-expression where the right of the binding is not-        --   a lambda abstraction.-        | ErrorLetrecBindingNotLambda-        { errorAnnot            :: a-        , errorChecking         :: Exp a n -        , errorExp              :: Exp a n }--        -- | A recursive let-binding with a missing type annotation.-        | ErrorLetrecMissingAnnot-        { errorAnnot            :: a-        , errorBind             :: Bind n-        , errorExp              :: Exp a n }--        -- | A recursive let-expression that has more than one binding-        --   with the same name.-        | ErrorLetrecRebound-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorBind             :: Bind n }---        -- Letregion ---------------------------------------        -- | A letregion-expression where the some of the bound variables do not-        --   have region kind.-        | ErrorLetRegionsNotRegion-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorBinds            :: [Bind n]-        , errorKinds            :: [Kind n] }--        -- | A letregion-expression that tried to shadow some pre-existing named-        --   region variables.-        | ErrorLetRegionsRebound-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorBinds            :: [Bind n] }--        -- | A letregion-expression where some of the the bound region variables-        --   are free in the type of the body.-        | ErrorLetRegionFree-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorBinds            :: [Bind n]-        , errorType             :: Type n }--        -- | A letregion-expression that tried to create a witness with an -        --   invalid type.-        | ErrorLetRegionWitnessInvalid-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorBind             :: Bind n }--        -- | A letregion-expression that tried to create conflicting witnesses.-        | ErrorLetRegionWitnessConflict-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorBindWitness1     :: Bind n-        , errorBindWitness2     :: Bind n }--        -- | A letregion-expression where a bound witnesses was not for the-        --   the region variable being introduced.-        | ErrorLetRegionsWitnessOther-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorBoundRegions     :: [Bound n]-        , 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.-        | ErrorWAppMismatch-        { errorAnnot            :: a-        , errorWitness          :: Witness a n-        , errorParamType        :: Type n-        , errorArgType          :: Type n }--        -- | Tried to perform a witness application with a non-witness.-        | ErrorWAppNotCtor-        { errorAnnot            :: a-        , errorWitness          :: Witness a n-        , 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-        , errorChecking         :: Exp a n-        , 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-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorTypeScrutinee    :: Type n }--        -- | A case-expression where the scrutinee type is not in our set-        --   of data type declarations.-        | ErrorCaseScrutineeTypeUndeclared-        { errorAnnot            :: a-        , errorChecking         :: Exp a n -        , errorTypeScrutinee    :: Type n }--        -- | A case-expression with no alternatives.-        | ErrorCaseNoAlternatives-        { errorAnnot            :: a-        , errorChecking         :: Exp a n }--        -- | A case-expression where the alternatives don't cover all the-        --   possible data constructors.-        | ErrorCaseNonExhaustive-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorCtorNamesMissing :: [n] }--        -- | A case-expression where the alternatives don't cover all the-        --   possible constructors, and the type has too many data constructors-        --   to list.-        | ErrorCaseNonExhaustiveLarge-        { errorAnnot            :: a-        , errorChecking         :: Exp a n }--        -- | A case-expression with overlapping alternatives.-        | ErrorCaseOverlapping-        { errorAnnot            :: a-        , errorChecking         :: Exp a n }--        -- | A case-expression where one of the patterns has too many binders.-        | ErrorCaseTooManyBinders-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorCtorDaCon        :: DaCon n-        , errorCtorFields       :: Int-        , errorPatternFields    :: Int }--        -- | A case-expression where the pattern types could not be instantiated-        --   with the arguments of the scrutinee type.-        | ErrorCaseCannotInstantiate-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorTypeScrutinee    :: Type n -        , errorTypeCtor         :: Type n }--        -- | A case-expression where the type of the scrutinee does not match-        --   the type of the pattern.-        | ErrorCaseScrutineeTypeMismatch-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorTypeScrutinee    :: Type n-        , errorTypePattern      :: Type n }--        -- | A case-expression where the annotation on a pattern variable binder-        --   does not match the field type of the constructor.-        | ErrorCaseFieldTypeMismatch-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorTypeAnnot        :: Type n-        , errorTypeField        :: Type n }--        -- | A case-expression where the result types of the alternatives are not-        --   identical.-        | ErrorCaseAltResultMismatch-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorAltType1         :: Type n-        , errorAltType2         :: Type n }---        -- Casts -------------------------------------------        -- | A weakeff-cast where the type provided does not have effect kind.-        | ErrorWeakEffNotEff-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorEffect           :: Effect n-        , errorKind             :: Kind n }--        -- | A run cast applied to a non-suspension.-        | ErrorRunNotSuspension-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorType             :: Type n }--        -- | A run cast where the context does not support the suspended effect.-        | ErrorRunNotSupported-        { errorAnnot            :: a-        , errorChecking         :: Exp a n-        , errorEffect           :: Effect n }+import DDC.Core.Check.Error.ErrorExp+import DDC.Core.Check.Error.ErrorExpMessage   () -        -- | A run cast where we cannot infer the type of the suspended computation-        --   and thus cannot check if its effects are suppored by the context.-        | ErrorRunCannotInfer-        { errorAnnot            :: a-        , errorExp              :: Exp a n }+import DDC.Core.Check.Error.ErrorType+import DDC.Core.Check.Error.ErrorTypeMessage  () -        -- Types -------------------------------------------        -- | Found a naked `XType` that wasn't the argument of an application.-        | ErrorNakedType-        { errorAnnot            :: a-        , errorChecking         :: Exp a n }+import DDC.Core.Check.Error.ErrorData+import DDC.Core.Check.Error.ErrorDataMessage  ()  -        -- Witnesses ---------------------------------------        -- | Found a naked `XWitness` that wasn't the argument of an application.-        | ErrorNakedWitness-        { errorAnnot            :: a-        , errorChecking         :: Exp a n }-        deriving (Show)
+ DDC/Core/Check/Error/ErrorData.hs view
@@ -0,0 +1,23 @@++module DDC.Core.Check.Error.ErrorData+        (ErrorData(..))+where+import DDC.Core.Exp+++-- | Things that can go wrong when checking data type definitions.+data ErrorData n+        -- | A duplicate data type constructor name.+        = ErrorDataDupTypeName +        { errorDataDupTypeName          :: n }++        -- | A duplicate data constructor name.+        | ErrorDataDupCtorName+        { errorDataCtorName             :: n }++        -- | A data constructor with the wrong result type.+        | ErrorDataWrongResult+        { errorDataCtorName             :: n+        , errorDataCtorResultActual     :: Type n+        , errorDataCtorResultExpected   :: Type n }+        deriving Show
+ DDC/Core/Check/Error/ErrorDataMessage.hs view
@@ -0,0 +1,27 @@++module DDC.Core.Check.Error.ErrorDataMessage where+import DDC.Core.Check.Error.ErrorData+import DDC.Data.Pretty+++instance (Eq n, Show n, Pretty n) +       => Pretty (ErrorData n) where+ ppr = ppr'++ppr' (ErrorDataDupTypeName n)+ = vcat [ text "Duplicate data type definition."+        , text "  A constructor with name: "    <> ppr n+        , text "  is already defined." ]++ppr' (ErrorDataDupCtorName n)+ = vcat [ text "Duplicate data constructor definition."+        , text "  A constructor with name: "    <> ppr n+        , text "  is already defined." ]+++ppr' (ErrorDataWrongResult n tActual tExpected)+ = vcat [ text "Invalid result type for data constructor."+        , text "       The data constructor: "  <> ppr n+        , text "            has result type: "  <> ppr tActual+        , text "  but the enclosing type is: "  <> ppr tExpected ]+
+ DDC/Core/Check/Error/ErrorExp.hs view
@@ -0,0 +1,383 @@++module DDC.Core.Check.Error.ErrorExp+        (Error(..))+where+import DDC.Core.Check.Error.ErrorType+import DDC.Core.Check.Error.ErrorData+import DDC.Core.Exp+import DDC.Type.Universe++-- | All the things that can go wrong when type checking an expression+--   or witness.+data Error a n+        -- Type -------------------------------------------+        -- | Found a kind error when checking a type.+        = ErrorType+        { errorTypeError        :: ErrorType n }++        -- | Found an error in the data type definitions.+        | ErrorData+        { errorData             :: ErrorData n }++        -- Module -----------------------------------------+        -- | Exported value is undefined.+        | ErrorExportUndefined+        { errorName             :: n }++        -- | Exported name is exported multiple times.+        | ErrorExportDuplicate+        { errorName             :: n }++        -- | Type signature of exported binding does not match the type at+        --   the definition site.+        | ErrorExportMismatch+        { errorName             :: n+        , errorExportType       :: Type n+        , errorDefType          :: Type n }++        -- | Imported name is imported multiple times.+        | 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 }+++        -- Exp --------------------------------------------+        -- | Generic mismatch between expected and inferred types.+        | ErrorMismatch+        { errorAnnot            :: a+        , errorInferred         :: Type n+        , errorExpected         :: Type n+        , errorChecking         :: Exp a n }+++        -- Var --------------------------------------------+        -- | An undefined type variable.+        | ErrorUndefinedVar+        { errorAnnot            :: a+        , errorBound            :: Bound n+        , errorUniverse         :: Universe }+++        -- Con --------------------------------------------+        -- | A data constructor that wasn't in the set of data definitions.+        | ErrorUndefinedCtor+        { errorAnnot            :: a+        , errorChecking         :: Exp a n }+++        -- Application ------------------------------------+        -- | A function application where the parameter and argument don't match.+        | ErrorAppMismatch+        { errrorAnnot           :: a+        , errorChecking         :: Exp a n+        , errorParamType        :: Type n+        , errorArgType          :: Type n }++        -- | Tried to apply something that is not a function.+        | ErrorAppNotFun+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorNotFunType       :: Type n }++        -- | Cannot infer type of polymorphic expression.+        | ErrorAppCannotInferPolymorphic+        { errorAnnot            :: a+        , errorChecking         :: Exp a n }++        -- Lambda -----------------------------------------+        -- | A type abstraction that tries to shadow a type variable that is+        --   already in the environment.+        | ErrorLamShadow+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorBind             :: Bind n }++        -- | An abstraction where the body has a visible side effect that+        --   is not supported by the current language fragment.+        | ErrorLamNotPure+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorUniverse         :: Universe+        , errorEffect           :: Effect n }++        -- | A value function where the parameter does not have data+        --   or witness kind.+        | ErrorLamBindBadKind+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorType             :: Type n+        , errorKind             :: Kind n }++        -- | An abstraction where the body does not have data kind.+        | ErrorLamBodyNotData+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorBind             :: Bind n+        , errorType             :: Type n+        , errorKind             :: Kind n }++        -- | A function abstraction without a type annotation on the parameter.+        | ErrorLamParamUnannotated+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorBind             :: Bind n }++        -- | A type abstraction without a kind annotation on the parameter.+        | ErrorLAMParamUnannotated+        { errorAnnot            :: a+        , errorChecking         :: Exp a n }++        -- | A type abstraction parameter with a bad sort.+        | ErrorLAMParamBadSort+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorBind             :: Bind n+        , errorSort             :: Sort n }+++        -- Let --------------------------------------------+        -- | A let-expression where the type of the binder does not match the right+        --   of the binding.+        | ErrorLetMismatch+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorBind             :: Bind n+        , errorType             :: Type n }++        -- | A let-expression where the right of the binding does not have data kind.+        | ErrorLetBindingNotData+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorBind             :: Bind n+        , errorKind             :: Kind n }++        -- | A let-expression where the body does not have data kind.+        | ErrorLetBodyNotData+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorType             :: Type n+        , errorKind             :: Kind n }+++        -- Letrec -----------------------------------------+        -- | A recursive let-expression where the right of the binding is not+        --   a lambda abstraction.+        | ErrorLetrecBindingNotLambda+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorExp              :: Exp a n }++        -- | A recursive let-binding with a missing type annotation.+        | ErrorLetrecMissingAnnot+        { errorAnnot            :: a+        , errorBind             :: Bind n+        , errorExp              :: Exp a n }++        -- | A recursive let-expression that has more than one binding+        --   with the same name.+        | ErrorLetrecRebound+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorBind             :: Bind n }+++        -- Letregion --------------------------------------+        -- | A letregion-expression where the some of the bound variables do not+        --   have region kind.+        | ErrorLetRegionsNotRegion+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorBinds            :: [Bind n]+        , errorKinds            :: [Kind n] }++        -- | A letregion-expression that tried to shadow some pre-existing named+        --   region variables.+        | ErrorLetRegionsRebound+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorBinds            :: [Bind n] }++        -- | A letregion-expression where some of the the bound region variables+        --   are free in the type of the body.+        | ErrorLetRegionFree+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorBinds            :: [Bind n]+        , errorType             :: Type n }++        -- | A letregion-expression that tried to create a witness with an+        --   invalid type.+        | ErrorLetRegionWitnessInvalid+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorBind             :: Bind n }++        -- | A letregion-expression that tried to create conflicting witnesses.+        | ErrorLetRegionWitnessConflict+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorBindWitness1     :: Bind n+        , errorBindWitness2     :: Bind n }++        -- | A letregion-expression where a bound witnesses was not for the+        --   the region variable being introduced.+        | ErrorLetRegionsWitnessOther+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorBoundRegions     :: [Bound n]+        , errorBindWitness      :: Bind  n }+++        -- Witnesses --------------------------------------+        -- | A witness application where the argument type does not match+        --   the parameter type.+        | ErrorWAppMismatch+        { errorAnnot            :: a+        , errorWitness          :: Witness a n+        , errorParamType        :: Type n+        , errorArgType          :: Type n }++        -- | Tried to perform a witness application with a non-witness.+        | ErrorWAppNotCtor+        { errorAnnot            :: a+        , errorWitness          :: Witness a n+        , errorNotFunType       :: Type n+        , errorArgType          :: Type n }++        -- | A witness provided for a purify cast that does not witness purity.+        | ErrorWitnessNotPurity+        { 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+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorTypeScrutinee    :: Type n }++        -- | A case-expression where the scrutinee type is not in our set+        --   of data type declarations.+        | ErrorCaseScrutineeTypeUndeclared+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorTypeScrutinee    :: Type n }++        -- | A case-expression with no alternatives.+        | ErrorCaseNoAlternatives+        { errorAnnot            :: a+        , errorChecking         :: Exp a n }++        -- | A case-expression where the alternatives don't cover all the+        --   possible data constructors.+        | ErrorCaseNonExhaustive+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorCtorNamesMissing :: [n] }++        -- | A case-expression where the alternatives don't cover all the+        --   possible constructors, and the type has too many data constructors+        --   to list.+        | ErrorCaseNonExhaustiveLarge+        { errorAnnot            :: a+        , errorChecking         :: Exp a n }++        -- | A case-expression with overlapping alternatives.+        | ErrorCaseOverlapping+        { errorAnnot            :: a+        , errorChecking         :: Exp a n }++        -- | A case-expression where one of the patterns has too many binders.+        | ErrorCaseTooManyBinders+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorCtorDaCon        :: DaCon n (Type n)+        , errorCtorFields       :: Int+        , errorPatternFields    :: Int }++        -- | A case-expression where the pattern types could not be instantiated+        --   with the arguments of the scrutinee type.+        | ErrorCaseCannotInstantiate+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorTypeScrutinee    :: Type n+        , errorTypeCtor         :: Type n }++        -- | A case-expression where the type of the scrutinee does not match+        --   the type of the pattern.+        | ErrorCaseScrutineeTypeMismatch+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorTypeScrutinee    :: Type n+        , errorTypePattern      :: Type n }++        -- | A case-expression where the annotation on a pattern variable binder+        --   does not match the field type of the constructor.+        | ErrorCaseFieldTypeMismatch+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorTypeAnnot        :: Type n+        , errorTypeField        :: Type n }++        -- | A case-expression where the result types of the alternatives are not+        --   identical.+        | ErrorCaseAltResultMismatch+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorAltType1         :: Type n+        , errorAltType2         :: Type n }+++        -- Casts ------------------------------------------+        -- | A weakeff-cast where the type provided does not have effect kind.+        | ErrorWeakEffNotEff+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorEffect           :: Effect n+        , errorKind             :: Kind n }++        -- | A run cast applied to a non-suspension.+        | ErrorRunNotSuspension+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorType             :: Type n }++        -- | A run cast where the context does not support the suspended effect.+        | ErrorRunNotSupported+        { errorAnnot            :: a+        , errorChecking         :: Exp a n+        , errorEffect           :: Effect n }++        -- | A run cast where we cannot infer the type of the suspended computation+        --   and thus cannot check if its effects are suppored by the context.+        | ErrorRunCannotInfer+        { errorAnnot            :: a+        , errorExp              :: Exp a n }++        -- Types ------------------------------------------+        -- | Found a naked `XType` that wasn't the argument of an application.+        | ErrorNakedType+        { errorAnnot            :: a+        , errorChecking         :: Exp a n }+++        -- Witnesses --------------------------------------+        -- | Found a naked `XWitness` that wasn't the argument of an application.+        | ErrorNakedWitness+        { errorAnnot            :: a+        , errorChecking         :: Exp a n }+        deriving (Show)++++
+ DDC/Core/Check/Error/ErrorExpMessage.hs view
@@ -0,0 +1,431 @@++-- | Errors produced when checking core expressions.+module DDC.Core.Check.Error.ErrorExpMessage+        (Error(..))+where+import DDC.Core.Pretty+import DDC.Core.Check.Error.ErrorExp+import DDC.Core.Check.Error.ErrorTypeMessage      ()+import DDC.Core.Check.Error.ErrorDataMessage      ()+import DDC.Type.Exp.Simple+import DDC.Type.Universe+++instance (Pretty a, Show n, Eq n, Pretty n) +       => Pretty (Error a n) where+ ppr = ppr'+++-- Wrapped Errors -------------------------------------------------------------+ppr' (ErrorType err')+        = ppr err'++ppr' (ErrorData err')+        = ppr err'++-- Modules --------------------------------------------------------------------+ppr' (ErrorExportUndefined n)+ = vcat [ text "Exported name '" <> ppr n <> text "' is undefined." ]++ppr' (ErrorExportDuplicate n)+ = vcat [ text "Duplicate exported name '" <> ppr n <> text "'."]++ppr' (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+        , text "       type of definition: "   <> ppr tDef ]++ppr' (ErrorImportDuplicate n)+ = vcat [ text "Duplicate imported name '" <> ppr n <> text "'."]++ppr' (ErrorImportCapNotEffect n)+ = vcat [ text "Imported capability '"+                <> ppr n +                <> text "' does not have kind Effect." ]++ppr' (ErrorImportValueNotData n)+ = vcat [ text "Imported value '"+                <> ppr n +                <> text "' does not have kind Data." ]+++-- Exp -------------------------------------------------------------------------+ppr' (ErrorMismatch a tInferred tExpected xx)+ = vcat [ ppr a+        , text "Type mismatch."+        , text "  inferred type: "                     <> ppr tInferred+        , text "  expected type: "                     <> ppr tExpected+        , empty+        , text "with: "                                <> align (ppr xx) ]+++-- Variable -------------------------------------------------------------------+ppr' (ErrorUndefinedVar a u universe)+ = case universe of+        UniverseSpec+          -> vcat  [ ppr a+                   , text "Undefined spec variable: "      <> ppr u ]++        UniverseData+          -> vcat  [ ppr a+                   , text "Undefined value variable: "     <> ppr u ]++        UniverseWitness+          -> vcat  [ ppr a+                   , text "Undefined witness variable: "   <> ppr u ]++        -- Universes other than the above don't have variables,+        -- but let's not worry about that here.+        _ -> vcat  [ ppr a+                   , text "Undefined variable: "           <> ppr u ]+++-- Constructor ----------------------------------------------------------------+ppr' (ErrorUndefinedCtor a xx)+ = vcat [ ppr a+        , text "Undefined data constructor: "  <> ppr xx ]+++-- Application ----------------------------------------------------------------+ppr' (ErrorAppMismatch a xx t1 t2)+ = vcat [ ppr a+        , text "Type mismatch in application."+        , text "     Function expects: "       <> ppr t1+        , text "      but argument is: "       <> ppr t2+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorAppNotFun a xx t1)+ = vcat [ ppr a+        , text "Cannot apply non-function"+        , text "              of type: "       <> ppr t1+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorAppCannotInferPolymorphic a xx)+ = vcat [ ppr a+        , text "Cannot infer the type of a polymorphic expression."+        , text "  Please supply type annotations to constrain the functional"+        , text "  part to have a quantified type."+        , text "with: "                        <> align (ppr xx) ]+++-- Lambda ---------------------------------------------------------------------+ppr' (ErrorLamShadow a xx b)+ = vcat [ ppr a+        , text "Cannot shadow named spec variable."+        , text "  binder: "                    <> ppr b+        , text "  is already in the environment."+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorLamNotPure a xx universe eff)+ = vcat [ ppr a+        , text "Impure" <+> ppr universe <+> text "abstraction"+        , text "           has effect: "       <> ppr eff+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorLamBindBadKind a xx t1 k1)+ = vcat [ ppr a+        , text "Function parameter has invalid kind."+        , text "    The function parameter: "   <> ppr t1+        , text "                  has kind: "  <> ppr k1+        , text "            but it must be: Data or Witness"+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorLamBodyNotData a xx b1 t2 k2)+ = vcat [ ppr a+        , text "Result of function does not have data kind."+        , text "   In function with binder: "  <> ppr b1+        , text "       the result has type: "  <> ppr t2+        , text "                 with kind: "  <> ppr k2+        , text "            but it must be: Data"+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorLamParamUnannotated a xx b1)+ = vcat [ ppr a+        , text "Missing type annotation on function parameter."+        , text "             With paramter: " <> ppr b1+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorLAMParamUnannotated a xx)+ = vcat [ ppr a+        , text "Type abstraction is missing a kind annotation."+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorLAMParamBadSort a xx b s)+ = vcat [ ppr a+        , text "Kind annotation of type parameter has a bad sort."+        , text "                  Parameter: " <> ppr b+        , text "                   has sort: " <> ppr s+        , empty+        , text "with: "                        <> align (ppr xx) ]+++-- Let ------------------------------------------------------------------------+ppr' (ErrorLetMismatch a xx b t)+ = vcat [ ppr a+        , text "Type mismatch in let-binding."+        , text "                The binder: "  <> ppr (binderOfBind b)+        , text "                  has type: "  <> ppr (typeOfBind b)+        , text "     but the body has type: "  <> ppr t+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorLetBindingNotData a xx b k)+ = vcat [ ppr a+        , text "Let binding does not have data kind."+        , text "      The binding for: "       <> ppr (binderOfBind b)+        , text "             has type: "       <> ppr (typeOfBind b)+        , text "            with kind: "       <> ppr k+        , text "       but it must be: Data "+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorLetBodyNotData a xx t k)+ = vcat [ ppr a+        , text "Let body does not have data kind."+        , text " Body of let has type: "       <> ppr t+        , text "            with kind: "       <> ppr k+        , text "       but it must be: Data "+        , empty+        , text "with: "                        <> align (ppr xx) ]+++-- Letrec ---------------------------------------------------------------------+ppr' (ErrorLetrecRebound a xx b)+ = vcat [ ppr a+        , text "Redefined binder '" <> ppr b <> text "' in letrec."+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorLetrecMissingAnnot a b xx)+ = vcat [ ppr a+        , text "Missing or incomplete type annotation on recursive let-binding '"+               <> ppr (binderOfBind b) <> text "'."+        , text "Recursive functions must have full type annotations."+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorLetrecBindingNotLambda a xx x)+ = vcat [ ppr a+        , text "Letrec can only bind lambda abstractions."+        , text "      This is not one: "       <> ppr x+        , empty+        , text "with: "                        <> align (ppr xx) ]+++-- Letregion ------------------------------------------------------------------+ppr' (ErrorLetRegionsNotRegion a xx bs ks)+ = vcat [ ppr a+        , 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"+        , empty+        , text "with: "                         <> align (ppr xx) ]++ppr' (ErrorLetRegionsRebound a xx bs)+ = vcat [ ppr a+        , text "Region variables shadow existing ones."+        , text "           Region variables: "  <> (hcat $ map ppr bs)+        , text "     are already in environment"+        , empty+        , text "with: "                         <> align (ppr xx) ]++ppr' (ErrorLetRegionFree a xx bs t)+ = vcat [ ppr a+        , text "Region variables escape scope of private."+        , text "       The region variables: "  <> (hcat $ map ppr bs)+        , text "   is free in the body type: "   <> ppr t+        , empty+        , text "with: "                         <> align (ppr xx) ]++ppr' (ErrorLetRegionWitnessInvalid a xx b)+ = vcat [ ppr a+        , text "Invalid witness type with private."+        , text "          The witness: "       <> ppr b+        , text "  cannot be created with a private"+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorLetRegionWitnessConflict a xx b1 b2)+ = vcat [ ppr a+        , text "Conflicting witness types with private."+        , text "      Witness binding: "       <> ppr b1+        , text "       conflicts with: "       <> ppr b2+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorLetRegionsWitnessOther a xx bs1 b2)+ = vcat [ ppr a+        , text "Witness type is not for bound regions."+        , text "        private binds: "       <> (hsep $ map ppr bs1)+        , text "  but witness type is: "       <> ppr b2+        , empty+        , text "with: "                        <> align (ppr xx) ]+++-- Witnesses ------------------------------------------------------------------+ppr' (ErrorWAppMismatch a ww t1 t2)+ = vcat [ ppr a+        , text "Type mismatch in witness application."+        , text "  Constructor expects: "       <> ppr t1+        , text "      but argument is: "       <> ppr t2+        , empty+        , text "with: "                        <> align (ppr ww) ]++ppr' (ErrorWAppNotCtor a ww t1 t2)+ = vcat [ ppr a+        , text "Type cannot apply non-constructor witness"+        , text "              of type: "       <> ppr t1+        , text "  to argument of type: "       <> ppr t2+        , empty+        , text "with: "                        <> align (ppr ww) ]++ppr' (ErrorWitnessNotPurity a xx w t)+ = vcat [ ppr a+        , text "Witness for a purify does not witness purity."+        , text "        Witness: "             <> ppr w+        , text "       has type: "             <> ppr t+        , empty+        , text "with: "                        <> align (ppr xx) ]+++-- Case Expressions -----------------------------------------------------------+ppr' (ErrorCaseScrutineeNotAlgebraic a xx tScrutinee)+ = vcat [ ppr a+        , text "Scrutinee of case expression is not algebraic data."+        , text "     Scrutinee type: "         <> ppr tScrutinee+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorCaseScrutineeTypeUndeclared a xx tScrutinee)+ = vcat [ ppr a+        , text "Type of scrutinee does not have a data declaration."+        , text "     Scrutinee type: "         <> ppr tScrutinee+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorCaseNoAlternatives a xx)+ = vcat [ ppr a+        , text "Case expression does not have any alternatives."+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorCaseNonExhaustive a xx ns)+ = vcat [ ppr a+        , text "Case alternatives are non-exhaustive."+        , text " Constructors not matched: "+               <> (sep $ punctuate comma $ map ppr ns)+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorCaseNonExhaustiveLarge a xx)+ = vcat [ ppr a+        , text "Case alternatives are non-exhaustive."+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorCaseOverlapping a xx)+ = vcat [ ppr a+        , text "Case alternatives are overlapping."+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorCaseTooManyBinders a xx uCtor iCtorFields iPatternFields)+ = vcat [ ppr a+        , text "Pattern has more binders than there are fields in the constructor."+        , text "     Contructor: " <> ppr uCtor+        , text "            has: " <> ppr iCtorFields+                                   <+> text "fields"+        , text "  but there are: " <> ppr iPatternFields+                                  <+> text "binders in the pattern"+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorCaseCannotInstantiate a xx tScrutinee tCtor)+ = vcat [ ppr a+        , text "Cannot instantiate constructor type with scrutinee type args."+        , text " Either the constructor has an invalid type,"+        , text " or the type of the scrutinee does not match the type of the pattern."+        , text "        Scrutinee type: "      <> ppr tScrutinee+        , text "      Constructor type: "      <> ppr tCtor+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorCaseScrutineeTypeMismatch a xx tScrutinee tPattern)+ = vcat [ ppr a+        , text "Scrutinee type does not match result of pattern type."+        , text "        Scrutinee type: "      <> ppr tScrutinee+        , text "          Pattern type: "      <> ppr tPattern+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorCaseFieldTypeMismatch a xx tAnnot tField)+ = vcat [ ppr a+        , text "Annotation on pattern variable does not match type of field."+        , text "       Annotation type: "      <> ppr tAnnot+        , text "            Field type: "      <> ppr tField+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorCaseAltResultMismatch a xx t1 t2)+ = vcat [ ppr a+        , text "Mismatch in alternative result types."+        , text "   Type of alternative: "      <> ppr t1+        , text "        does not match: "      <> ppr t2+        , empty+        , text "with: "                        <> align (ppr xx) ]+++-- Casts ----------------------------------------------------------------------+ppr' (ErrorWeakEffNotEff a xx eff k)+ = vcat [ ppr a+        , text "Type provided for a 'weakeff' does not have effect kind."+        , text "           Type: "             <> ppr eff+        , text "       has kind: "             <> ppr k+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorRunNotSuspension a xx t)+ = vcat [ ppr a+        , text "Expression to run is not a suspension."+        , text "          Type: "              <> ppr t+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorRunNotSupported a xx eff)+ = vcat [ ppr a+        , text "Effect of computation not supported by context."+        , text "    Effect:  "                 <> ppr eff+        , empty+        , text "with: "                        <> align (ppr xx) ]++ppr' (ErrorRunCannotInfer a xx)+ = vcat [ ppr a+        , text "Cannot infer type of suspended computation."+        , empty+        , text "with: "                        <> align (ppr xx) ]+++-- Type -----------------------------------------------------------------------+ppr' (ErrorNakedType a xx)+ = vcat [ ppr a+        , text "Found naked type in core program."+        , empty+        , text "with: "                        <> align (ppr xx) ]+++-- Witness --------------------------------------------------------------------+ppr' (ErrorNakedWitness a xx)+ = vcat [ ppr a+        , text "Found naked witness in core program."+        , empty+        , text "with: "                        <> align (ppr xx) ]+
+ DDC/Core/Check/Error/ErrorType.hs view
@@ -0,0 +1,94 @@++module DDC.Core.Check.Error.ErrorType where+import DDC.Core.Exp+import DDC.Type.Universe+++-- | Things that can go wrong when checking the kind of at type.+data ErrorType n+        -- Generic Problems ---------------------+        -- | Tried to check a type using the wrong universe, +        --   for example: asking for the kind of a kind.+        = ErrorTypeUniverseMalfunction+        { errorTypeType         :: Type n+        , errorTypeUniverse     :: Universe }++        -- | Generic kind mismatch.+        | ErrorTypeMismatch+        { errorTypeUniverse     :: Universe+        , errorTypeInferred     :: Type n+        , errorTypeExpected     :: Type n+        , errorTypeChecking     :: Type n }++        -- | Cannot construct infinite type.+        | ErrorTypeInfinite+        { errorTypeVar          :: Type n+        , errorTypeBind         :: Type n }++        -- Variables ----------------------------+        -- | An undefined type variable.+        | ErrorTypeUndefined        +        { errorTypeBound        :: Bound n }+++        -- Constructors -------------------------+        -- | Found an unapplied kind function constructor.+        | ErrorTypeUnappliedKindFun ++        -- | Found a naked sort constructor.+        | ErrorTypeNakedSort+        { errorTypeSort         :: Sort n }++        -- | An undefined type constructor.+        | ErrorTypeUndefinedTypeCtor+        { errorTypeBound        :: Bound n }+++        -- Applications -------------------------+        -- | A type application where the thing being applied is not a function.+        | ErrorTypeAppNotFun+        { errorTypeChecking     :: Type n+        , errorTypeFunType      :: Type n+        , errorTypeFunTypeKind  :: Kind n+        , errorTypeArgType      :: Type n }++        -- | A type application where the parameter and argument kinds don't match.+        | ErrorTypeAppArgMismatch   +        { errorTypeChecking     :: Type n+        , errorTypeFunType      :: Type n+        , errorTypeFunKind      :: Kind n+        , errorTypeArgType      :: Type n+        , errorTypeArgKind      :: Kind n }++        -- | A witness implication where the premise or conclusion has an+        --   invalid kind.+        | ErrorTypeWitnessImplInvalid+        { errorTypeChecking     :: Type n+        , errorTypeLeftType     :: Type n+        , errorTypeLeftKind     :: Kind n+        , errorTypeRightType    :: Type n+        , errorTypeRightKind    :: Kind n }+++        -- Quantifiers --------------------------+        -- | A forall where the body does not have data or witness kind.+        | ErrorTypeForallKindInvalid+        { errorTypeChecking     :: Type n+        , errorTypeBody         :: Type n+        , errorTypeKind         :: Kind n }+++        -- Sums ---------------------------------+        -- | A type sum where the components have differing kinds.+        | ErrorTypeSumKindMismatch+        { errorTypeKindExpected :: Kind n+        , errorTypeTypeSum      :: TypeSum n+        , errorTypeKinds        :: [Kind n] }+        +        -- | A type sum that does not have effect or closure kind.+        | ErrorTypeSumKindInvalid+        { errorTypeCheckingSum  :: TypeSum n+        , errorTypeKind         :: Kind n }+        deriving Show++
+ DDC/Core/Check/Error/ErrorTypeMessage.hs view
@@ -0,0 +1,107 @@++-- | Errors produced when checking types.+module DDC.Core.Check.Error.ErrorTypeMessage where+import DDC.Core.Check.Error.ErrorType+import DDC.Type.Exp.Simple+import DDC.Type.Universe+import DDC.Data.Pretty+++instance (Eq n, Show n, Pretty n) +       => Pretty (ErrorType n) where+ ppr = ppr'+++-- Generic Problems -----------------------------------------------------------+ppr' (ErrorTypeUniverseMalfunction t u)+ = vcat [ text "Universe malfunction."+        , text "               Type: "  <> ppr t+        , text " is not in universe: "  <> ppr u ]++ppr' (ErrorTypeMismatch uni tInferred tExpected tt)+ = let (thing, thing')   +        = case uni of+               UniverseSpec    -> ("Kind", "kind")+               UniverseKind    -> ("Sort", "sort")+               _               -> ("Type", "type")+   in vcat +       [ text thing <+> text "mismatch."+       , text "                Expected"+               <+> text thing' <> text ":"      <+> ppr tExpected+       , text " does not match inferred"+               <+> text thing' <> text ":"      <+> ppr tInferred+       , empty+       , text "with: "                          <> align (ppr tt) ]++ppr' (ErrorTypeInfinite tExt tBind)+ = vcat [ text "Cannot construct infinite type."+        , text "  " <> ppr tExt <+> text "=" <+> ppr tBind ]+++-- Variables ------------------------------------------------------------------+ppr' (ErrorTypeUndefined u)+ = text "Undefined type variable: "     <> ppr u+++-- Constructors ---------------------------------------------------------------+ppr' (ErrorTypeUnappliedKindFun)+ = text "Can't take sort of unapplied kind function constructor."++ppr' (ErrorTypeNakedSort s)+ = text "Can't check a naked sort: "    <> ppr s+                +ppr' (ErrorTypeUndefinedTypeCtor u)+ = text "Undefined type constructor: "  <> ppr u+++-- Applications ---------------------------------------------------------------+ppr' (ErrorTypeAppNotFun tt t1 k1 t2)+ = vcat [ text "Type function used in application has invalid kind."+        , text "    In application: "           <> ppr tt+        , text " cannot apply type: "           <> ppr t1+        , text "           of kind: "           <> ppr k1+        , text "           to type: "           <> ppr t2 ]+ +ppr' (ErrorTypeAppArgMismatch tt tFn kFn tArg kArg)+ = vcat [ text "Kind mismatch in type application."+        , text "    In application: "           <> ppr tt+        , text " cannot apply type: "           <> ppr tFn+        , text "         with kind: "           <> ppr kFn+        , text "       to argument: "           <> ppr tArg+        , text "         with kind: "           <> ppr kArg ]         +++ppr' (ErrorTypeWitnessImplInvalid tt t1 k1 t2 k2)+ = vcat [ text "Invalid args for witness implication."+        , text "            left type: "        <> ppr t1+        , text "             has kind: "        <> ppr k1+        , text "           right type: "        <> ppr t2+        , text "             has kind: "        <> ppr k2 +        , text "        when checking: "        <> ppr tt ]+++-- Quantifiers ----------------------------------------------------------------+ppr' (ErrorTypeForallKindInvalid tt t k)+ = vcat [ text "Invalid kind for body of quantified type."+        , text "        the body type: "        <> ppr t+        , text "             has kind: "        <> ppr k+        , text "  but it must be Data or Prop" +        , text "        when checking: "        <> ppr tt ]+++-- Sums -----------------------------------------------------------------------+ppr' (ErrorTypeSumKindMismatch k ts ks)+ = vcat + $      [ text "Kind mismatch in type sum."+        , text " found multiple types: "        <> ppr ts+        , text " with differing kinds: "        <> ppr ks ]+ ++ (if k /= tBot sComp+                then [text "        expected kind: " <> ppr k ]+                else [])+                +ppr' (ErrorTypeSumKindInvalid ts k)+ = vcat [ text "Invalid kind for type sum."+        , text "         the type sum: "        <> ppr ts+        , text "             has kind: "        <> ppr k+        , text "  but it must be Effect or Closure" ]+
− DDC/Core/Check/ErrorMessage.hs 
@@ -1,465 +0,0 @@--- | Errors produced when checking core expressions.-module DDC.Core.Check.ErrorMessage-        (Error(..))-where-import DDC.Core.Pretty-import DDC.Core.Check.Error-import DDC.Type.Compounds-import DDC.Type.Universe---instance (Pretty a, Show n, Eq n, Pretty n) -       => Pretty (Error a n) where- ppr err-  = case err of-        ErrorType err'  -         -> ppr err'--        ErrorData err'-         -> ppr err'-        -        -- Modules ----------------------------------------        ErrorExportUndefined n-         -> vcat [ text "Exported name '" <> ppr n <> text "' is undefined." ]--        ErrorExportDuplicate n-         -> vcat [ text "Duplicate exported name '" <> ppr n <> text "'."]--        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-                 , text "       type of definition: "   <> ppr tDef ]--        ErrorImportDuplicate n-         -> vcat [ text "Duplicate imported name '" <> ppr n <> text "'."]--        ErrorImportValueNotData n-         -> vcat [ text "Imported value '" <> ppr n <> text "' does not have kind Data." ]---        -- Exp ---------------------------------------------        ErrorMismatch a tInferred tExpected xx-         -> vcat [ ppr a-                 , text "Type mismatch."-                 , text "  inferred type: "                     <> ppr tInferred-                 , text "  expected type: "                     <> ppr tExpected-                 , empty-                 , text "with: "                                <> align (ppr xx) ]---        -- Variable ----------------------------------------        ErrorUndefinedVar a u universe-         -> case universe of-             UniverseSpec-               -> vcat  [ ppr a-                        , text "Undefined spec variable: "      <> ppr u ]--             UniverseData-               -> vcat  [ ppr a-                        , text "Undefined value variable: "     <> ppr u ]--             UniverseWitness-               -> vcat  [ ppr a-                        , text "Undefined witness variable: "   <> ppr u ]--             -- Universes other than the above don't have variables,-             -- but let's not worry about that here.-             _ -> vcat  [ ppr a-                        , text "Undefined variable: "           <> ppr u ]---        -- Constructor -------------------------------------        ErrorUndefinedCtor a xx-         -> vcat [ ppr a-                 , text "Undefined data constructor: "  <> ppr xx ]---        -- Application -------------------------------------        ErrorAppMismatch a xx t1 t2-         -> vcat [ ppr a-                 , 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"-                 , text "              of type: "       <> ppr t1-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorAppCannotInferPolymorphic a xx-         -> vcat [ ppr a-                 , text "Cannot infer the type of a polymorphic expression."-                 , text "  Please supply type annotations to constrain the functional"-                 , text "  part to have a quantified type."-                 , text "with: "                        <> align (ppr xx) ]---        -- Lambda ------------------------------------------        ErrorLamShadow a xx b-         -> vcat [ ppr a-                 , text "Cannot shadow named spec variable."-                 , text "  binder: "                    <> ppr b-                 , text "  is already in the environment."-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLamNotPure a xx universe eff-         -> 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."-                 , text "    The function parameter: "   <> ppr t1-                 , text "                  has kind: "  <> ppr k1-                 , text "            but it must be: Data or Witness"-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLamBodyNotData a xx b1 t2 k2-         -> vcat [ ppr a-                 , text "Result of function does not have data kind."-                 , text "   In function with binder: "  <> ppr b1-                 , text "       the result has type: "  <> ppr t2-                 , text "                 with kind: "  <> ppr k2-                 , text "            but it must be: Data"-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLamParamUnannotated a xx b1-         -> vcat [ ppr a-                 , text "Missing type annotation on function parameter."-                 , text "             With paramter: " <> ppr b1 -                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLAMParamUnannotated a xx-         -> vcat [ ppr a-                 , text "Type abstraction is missing a kind annotation."-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLAMParamBadSort a xx b s-         -> vcat [ ppr a-                 , text "Kind annotation of type parameter has a bad sort."-                 , text "                  Parameter: " <> ppr b-                 , text "                   has sort: " <> ppr s-                 , empty-                 , text "with: "                        <> align (ppr xx) ]---        -- Let ---------------------------------------------        ErrorLetMismatch a xx b t-         -> vcat [ ppr a-                 , text "Type mismatch in let-binding."-                 , text "                The binder: "  <> ppr (binderOfBind b)-                 , text "                  has type: "  <> ppr (typeOfBind b)-                 , text "     but the body has type: "  <> ppr t-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLetBindingNotData a xx b k-         -> vcat [ ppr a-                 , text "Let binding does not have data kind."-                 , text "      The binding for: "       <> ppr (binderOfBind b)-                 , text "             has type: "       <> ppr (typeOfBind b)-                 , text "            with kind: "       <> ppr k-                 , text "       but it must be: Data "-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLetBodyNotData a xx t k-         -> vcat [ ppr a-                 , text "Let body does not have data kind."-                 , text " Body of let has type: "       <> ppr t-                 , text "            with kind: "       <> ppr k-                 , text "       but it must be: Data "-                 , empty-                 , text "with: "                        <> align (ppr xx) ]---        -- Letrec ------------------------------------------        ErrorLetrecRebound a xx b-         -> vcat [ ppr a-                 , text "Redefined binder '" <> ppr b <> text "' in letrec."-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLetrecMissingAnnot a b xx-         -> vcat [ ppr a-                 , text "Missing or incomplete type annotation on recursive let-binding '" -                        <> ppr (binderOfBind b) <> text "'."-                 , text "Recursive functions must have full type annotations."-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLetrecBindingNotLambda a xx x-         -> vcat [ ppr a-                 , text "Letrec can only bind lambda abstractions."-                 , text "      This is not one: "       <> ppr x-                 , empty-                 , text "with: "                        <> align (ppr xx) ]---        -- Letregion ---------------------------------------        ErrorLetRegionsNotRegion a xx bs ks-         -> vcat [ ppr a-                 , 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" -                 , empty-                 , text "with: "                         <> align (ppr xx) ]--        ErrorLetRegionsRebound a xx bs-         -> vcat [ ppr a-                 , text "Region variables shadow existing ones."-                 , text "           Region variables: "  <> (hcat $ map ppr bs)-                 , text "     are already in environment"-                 , empty-                 , text "with: "                         <> align (ppr xx) ]--        ErrorLetRegionFree a xx bs t-         -> vcat [ ppr a-                 , text "Region variables escape scope of private."-                 , text "       The region variables: "  <> (hcat $ map ppr bs)-                 , 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."-                 , text "          The witness: "       <> ppr b-                 , text "  cannot be created with a private"-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLetRegionWitnessConflict a xx b1 b2-         -> vcat [ ppr a-                 , text "Conflicting witness types with private."-                 , text "      Witness binding: "       <> ppr b1-                 , text "       conflicts with: "       <> ppr b2 -                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLetRegionsWitnessOther a xx bs1 b2-         -> vcat [ ppr a-                 , text "Witness type is not for bound regions."-                 , text "        private binds: "       <> (hsep $ map ppr bs1)-                 , 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-                 , text "Type mismatch in witness application."-                 , text "  Constructor expects: "       <> ppr t1-                 , text "      but argument is: "       <> ppr t2-                 , empty-                 , text "with: "                        <> align (ppr ww) ]--        ErrorWAppNotCtor a ww t1 t2-         -> vcat [ ppr a-                 , text "Type cannot apply non-constructor witness"-                 , text "              of type: "       <> ppr t1-                 , text "  to argument of type: "       <> ppr t2-                 , 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."-                 , text "        Witness: "             <> ppr w-                 , text "       has type: "             <> ppr t-                 , 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-                 , text "Scrutinee of case expression is not algebraic data."-                 , 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."-                 , text "     Scrutinee type: "         <> ppr tScrutinee-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorCaseNoAlternatives a xx-         -> vcat [ ppr a-                 , text "Case expression does not have any alternatives."-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorCaseNonExhaustive a xx ns-         -> vcat [ ppr a-                 , text "Case alternatives are non-exhaustive."-                 , text " Constructors not matched: "   -                        <> (sep $ punctuate comma $ map ppr ns)-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorCaseNonExhaustiveLarge a xx-         -> vcat [ ppr a-                 , text "Case alternatives are non-exhaustive."-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorCaseOverlapping a xx-         -> vcat [ ppr a-                 , text "Case alternatives are overlapping."-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorCaseTooManyBinders a xx uCtor iCtorFields iPatternFields-         -> vcat [ ppr a-                 , text "Pattern has more binders than there are fields in the constructor."-                 , text "     Contructor: " <> ppr uCtor-                 , text "            has: " <> ppr iCtorFields      -                                            <+> text "fields"-                 , text "  but there are: " <> ppr iPatternFields   -                                           <+> text "binders in the pattern" -                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorCaseCannotInstantiate a xx tScrutinee tCtor-         -> vcat [ ppr a-                 , text "Cannot instantiate constructor type with scrutinee type args."-                 , text " Either the constructor has an invalid type,"-                 , text " or the type of the scrutinee does not match the type of the pattern."-                 , text "        Scrutinee type: "      <> ppr tScrutinee-                 , text "      Constructor type: "      <> ppr tCtor-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorCaseScrutineeTypeMismatch a xx tScrutinee tPattern-         -> vcat [ ppr a-                 , text "Scrutinee type does not match result of pattern type."-                 , text "        Scrutinee type: "      <> ppr tScrutinee-                 , text "          Pattern type: "      <> ppr tPattern-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorCaseFieldTypeMismatch a xx tAnnot tField-         -> vcat [ ppr a-                 , text "Annotation on pattern variable does not match type of field."-                 , text "       Annotation type: "      <> ppr tAnnot-                 , text "            Field type: "      <> ppr tField-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorCaseAltResultMismatch a xx t1 t2-         -> vcat [ ppr a-                 , text "Mismatch in alternative result types."-                 , text "   Type of alternative: "      <> ppr t1-                 , text "        does not match: "      <> ppr t2-                 , empty-                 , text "with: "                        <> align (ppr xx) ]---        -- Casts -------------------------------------------        ErrorWeakEffNotEff a xx eff k-         -> vcat [ ppr a-                 , text "Type provided for a 'weakeff' does not have effect kind."-                 , text "           Type: "             <> ppr eff-                 , 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."-                 , text "          Type: "              <> ppr t-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorRunNotSupported a xx eff-         -> vcat [ ppr a-                 , text "Effect of computation not supported by context."-                 , text "    Effect:  "                 <> ppr eff-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorRunCannotInfer a xx-         -> vcat [ ppr a-                 , text "Cannot infer type of suspended computation."-                 , empty-                 , text "with: "                        <> align (ppr xx) ]---        -- Type --------------------------------------------        ErrorNakedType a xx-         -> vcat [ ppr a-                 , text "Found naked type in core program."-                 , empty-                 , text "with: "                        <> align (ppr xx) ]---        -- Witness -----------------------------------------        ErrorNakedWitness a xx-         -> vcat [ ppr a-                 , text "Found naked witness in core program."-                 , empty-                 , text "with: "                        <> align (ppr xx) ]-
DDC/Core/Check/Exp.hs view
@@ -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,125 +46,117 @@ 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.+        -> EnvX n                       -- ^ Environment of expression.+        -> Mode n                       -- ^ Check mode.+        -> Demand                       -- ^ Demand placed on the expression.         -> Exp a n                      -- ^ Expression to check.-        -> Mode  n                      -- ^ Check mode.-        -> ( Either (Error a n)         --   Type error message. +        -> ( 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 !env !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 -                (makeTable config-                        (Env.union kenv (configPrimKinds config))-                        (Env.union tenv (configPrimTypes config)))-                emptyContext xx mode-                +        (xx', t, effs, ctx)+         <- checkExpM+                (makeTable config)+                (emptyContext { contextEnvX = env })+                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)-        => Config n                     -- ^ Static configuration.-        -> KindEnv n                    -- ^ Starting Kind environment-        -> TypeEnv n                    -- ^ Starting Type environment.-        -> Exp a n                      -- ^ Expression to check.+typeOfExp+        :: (Show a, Ord n, Pretty n, Show n)+        => Config n             -- ^ Static configuration.+        -> EnvX n               -- ^ Environment of expresion.+        -> Exp a n              -- ^ Expression to check.         -> 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+typeOfExp !config !env !xx+ = case fst $ checkExp config env 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 -----------------------------------------------------------------------makeTable :: Config n -> KindEnv n -> TypeEnv n -> Table a n-makeTable config kenv tenv+makeTable :: Config n -> Table a n+makeTable config         = Table         { tableConfig           = config-        , tableKindEnv          = kenv-        , tableTypeEnv          = tenv         , tableCheckExp         = checkExpM         , tableCheckVarCon      = checkVarCon         , tableCheckAppT        = checkAppT@@ -176,6 +166,6 @@         , tableCheckLet         = checkLet         , tableCheckLetPrivate  = checkLetPrivate         , tableCheckCase        = checkCase-        , tableCheckCast        = checkCast +        , tableCheckCast        = checkCast         , tableCheckWitness     = checkWit }
+ DDC/Core/Check/Judge/DataDefs.hs view
@@ -0,0 +1,181 @@++module DDC.Core.Check.Judge.DataDefs+        (checkDataDefs)+where+import DDC.Core.Check.Config+import DDC.Core.Check.Error+import DDC.Type.DataDef+import DDC.Type.Exp.Simple+import DDC.Data.Pretty+import Data.Maybe+import DDC.Core.Env.EnvT                (EnvT)+import Data.Set                         (Set)+import qualified DDC.Type.Env           as Env+import qualified Data.Set               as Set+import qualified Data.Map               as Map+++-------------------------------------------------------------------------------+-- | Check some data type definitions.+checkDataDefs +        :: (Ord n, Show n, Pretty n)+        => Config n+        -> EnvT   n+        -> [DataDef n]+        -> ([ErrorData n], [DataDef n])++checkDataDefs config env defs + = let+        -- Primitive type constructors.+        primTypeCtors+                = Set.fromList+                $ Map.keys $ Env.envMap   $ configPrimKinds config++        -- Primitive data type constructors+        primDataTypeCtors  +                = Set.fromList +                $ Map.keys $ dataDefsTypes $ configPrimDataDefs config++        -- Primitive data constructors+        primDataCtors   +                = Set.fromList +                $ Map.keys $ dataDefsCtors $ configPrimDataDefs config++   in   checkDataDefs' env+                (Set.union primTypeCtors primDataTypeCtors)+                primDataCtors+                [] []+                defs+++checkDataDefs'+        :: (Ord n, Show n, Pretty n)+        => EnvT n               -- ^ Type equations.+        -> Set n                -- ^ Names of existing data types.+        -> Set n                -- ^ Names of existing data constructor.+        -> [ErrorData n]        -- ^ Errors found so far.+        -> [DataDef n]          -- ^ Checked data defs.+        -> [DataDef n]          -- ^ Data defs still to check.+        -> ([ErrorData n], [DataDef n])++checkDataDefs' env nsTypes nsCtors errs dsChecked ds+ -- We've checked all the defs.+ | []   <- ds+ = (reverse errs, reverse dsChecked)+ + -- Keep checking defs.+ | d : ds' <- ds+ = case checkDataDef env nsTypes nsCtors d of++    -- There are errors in this def.+    Left errs' +     -> checkDataDefs' env+                (Set.insert (dataDefTypeName d) nsTypes)+                (Set.fromList $ fromMaybe [] $ dataCtorNamesOfDataDef d)+                (errs ++ errs') dsChecked ds'++    -- This def is ok.+    Right d'   +     -> checkDataDefs' env+                (Set.insert (dataDefTypeName d') nsTypes)+                (Set.fromList $ fromMaybe [] $ dataCtorNamesOfDataDef d)+                errs (d' : dsChecked) ds'++ | otherwise+ = error "ddc-core.checkDataDefs: bogus warning suppression"+++-- DataDef --------------------------------------------------------------------+-- | Check a data type definition.+checkDataDef +        :: (Ord n, Show n, Pretty n)+        => EnvT n               -- ^ Environment of types.+        -> Set n                -- ^ Names of existing data types.+        -> Set n                -- ^ Names of existing data constructors.+        -> DataDef n            -- ^ Data type definition to check.+        -> Either [ErrorData n] (DataDef n)++checkDataDef env nsTypes nsCtors def+        + -- Check the data type name is not already defined.+ | Set.member (dataDefTypeName def) nsTypes+ = Left [ErrorDataDupTypeName (dataDefTypeName def)]++ -- No data constructors to check.+ | Nothing      <- dataDefCtors def+ = Right def++ -- Check the data constructors.+ | Just ctors   <- dataDefCtors def+ = case checkDataCtors env nsCtors [] def [] ctors of+        Left errs       -> Left errs+        Right ctors'    -> Right $ def { dataDefCtors = Just ctors' }++ | otherwise+ = error "ddc-core.checkDataDef: bogus warning suppression"++ +-- Ctors ----------------------------------------------------------------------+-- | Check the data constructor definitions from a single data type.+checkDataCtors+        :: (Ord n, Show n, Pretty n)+        => EnvT n               -- ^ Environment of types+        -> Set n                -- ^ Names of existing data constructors.+        -> [ErrorData n]        -- ^ Errors found so far.+        -> DataDef n            -- ^ The DataDef these constructors relate to.+        -> [DataCtor  n]        -- ^ Checked constructor defs.+        -> [DataCtor  n]        -- ^ Constructor defs still to check.+        -> Either [ErrorData n] [DataCtor n]++checkDataCtors env nsCtors errs def csChecked cs+ -- We've checked all the constructors and there were no errors.+ | []   <- cs, []   <- errs+ = Right (reverse csChecked)++ -- We've checked all the constructors and there were errors with some of them.+ | []   <- cs+ = Left  (reverse errs)++ -- Keep checking constructors.+ | c : cs' <- cs+ = case checkDataCtor env nsCtors def c of+        Left  err -> checkDataCtors env+                        (Set.insert (dataCtorName c) nsCtors)+                        (err : errs) def csChecked cs'+        +        Right c'  -> checkDataCtors env+                        (Set.insert (dataCtorName c') nsCtors)+                        errs         def (c' : csChecked) cs'++ | otherwise+ = error "ddc-core.checkDataCtors: bogus warning suppression"+++-- Ctor -----------------------------------------------------------------------+-- | Check a single data constructor definition.+checkDataCtor +        :: (Ord n, Show n, Pretty n)+        => EnvT n               -- ^ Environment of types.+        -> Set n                -- ^ Names of existing data constructors.+        -> DataDef  n           -- ^ Def of data type for this constructor.+        -> DataCtor n           -- ^ Data constructor to check.+        -> Either (ErrorData n) (DataCtor n)++checkDataCtor env nsCtors def ctor+        + -- Check the constructor name is not already defined.+ | Set.member (dataCtorName ctor) nsCtors + = Left $ ErrorDataDupCtorName (dataCtorName ctor)++ -- Check that the constructor produces a value of the associated data type.+ | not $ equivT env (dataTypeOfDataDef def) (dataCtorResultType ctor)+ = Left $ ErrorDataWrongResult +                (dataCtorName ctor)+                (dataCtorResultType ctor) (dataTypeOfDataDef def)++ -- This constructor looks ok.+ | otherwise+ = Right ctor+++
− DDC/Core/Check/Judge/Eq.hs 
@@ -1,172 +0,0 @@--module DDC.Core.Check.Judge.Eq-        (makeEq)-where-import DDC.Core.Check.Base-import DDC.Type.Transform.Crush-import DDC.Type.Transform.Trim---- | Make two types equivalent to each other,---   or throw the provided error if this is not possible.-makeEq  :: (Eq n, Ord n, Pretty n)-        => Config n-        -> a-        -> Context n-        -> Type n-        -> Type n-        -> Error a n-        -> CheckM a n (Context n)--makeEq config a ctx0 tL tR err-- -- EqLSolve- | Just iL <- takeExists tL- , not $ isTExists tR- = 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-                , empty ]--        return ctx1--- -- EqRSolve- | Just iR <- takeExists tR- , not $ isTExists tL- = 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-                , empty ]--        return ctx1--- -- EqLReach- --  Both types are existentials, and the left is bound earlier in the stack.- --  CAREFUL: The returned location is relative to the top of the stack,- --           hence we need lL > lR here.- | Just iL <- takeExists tL,    Just lL <- locationOfExists iL ctx0- , 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-                , empty ]--        return ctx1-- -- EqRReach- --  Both types are existentials, and the right is bound earlier in the stack.- --  CAREFUL: The returned location is relative to the top of the stack,- --           hence we need lR > lL here.- | Just iL <- takeExists tL,    Just lL <- locationOfExists iL ctx0- , Just iR <- takeExists tR,    Just lR <- locationOfExists iR ctx0- , 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-                , empty ]--        return ctx1--- -- EqVar- | TVar u1      <- tL- , TVar u2      <- tR- , u1 == u2- = do   -        ctrace  $ vcat-                [ text "* EqVar"-                , text "  LEFT:  " <> ppr tL-                , text "  RIGHT: " <> ppr tR-                , indent 2 $ ppr ctx0-                , empty ]--        return ctx0--- -- EqCon- | TCon tc1     <- tL- , TCon tc2     <- tR- , equivTyCon tc1 tc2- = do   -        ctrace  $ vcat-                [ text "* EqCon"-                , text "  LEFT:  " <> ppr tL-                , text "  RIGHT: " <> ppr tR-                , indent 2 $ 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"-                , text "  LEFT:   " <> ppr tL-                , text "  RIGHT:  " <> ppr tR-                , indent 2 $ ppr ctx0-                , indent 2 $ ppr ctx2-                , empty ]--        return ctx2-- -- EqEquiv- | equivT tL tR- =      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)-                , indent 2 $ ppr ctx0 ]--        throw err-
+ DDC/Core/Check/Judge/EqT.hs view
@@ -0,0 +1,201 @@++module DDC.Core.Check.Judge.EqT+        (makeEqT)+where+import DDC.Core.Check.Base +import qualified DDC.Core.Env.EnvT      as EnvT+import qualified Data.Map.Strict        as Map+++-- | Make two types equivalent to each other,+--   or throw the provided error if this is not possible.+makeEqT :: (Eq n, Ord n, Pretty n)+        => Config n+        -> Context n+        -> Type n+        -> Type n+        -> Error  a n+        -> CheckM a n (Context n)++makeEqT config ctx0 tL tR err++ -- EqT_SynL+ --   Expand type synonym on the left.+ | TCon (TyConBound (UName n) _) <- tL+ , Just tL' <- Map.lookup n $ EnvT.envtEquations $ contextEnvT ctx0+ = do+        ctrace  $ vcat+                [ text "**  EqT_SynL"+                , text "    tL : " <> ppr tL+                , text "    tL': " <> ppr tL'+                , text "    tR : " <> ppr tR+                , empty ]++        makeEqT config ctx0 tL' tR err+++ -- EqT_SynR+ --   Expand type synonym on the right.+ | TCon (TyConBound (UName n) _) <- tR+ , Just tR' <- Map.lookup n $ EnvT.envtEquations $ contextEnvT ctx0+ = do+        ctrace  $ vcat+                [ text "**  EqT_SynR"+                , text "    tL : " <> ppr tL+                , text "    tR : " <> ppr tR+                , text "    tR': " <> ppr tR'+                , empty ]++        makeEqT config ctx0 tL tR' err++ -- EqT_SolveL+ | Just iL <- takeExists tL+ , not $ isTExists tR+ = do   +        ctrace  $ vcat+                [ text "**  EqT_SolveL"+                , text "    tL:  " <> ppr tL+                , text "    tR:  " <> ppr tR+                , empty ]++        let Just ctx1   = updateExists [] iL tR ctx0+        +        return ctx1+++ -- EqT_SolveR+ | Just iR <- takeExists tR+ , not $ isTExists tL+ = do   +        ctrace  $ vcat+                [ text "**  EqT_SolveR"+                , text "    tL:  " <> ppr tL+                , text "    tR:  " <> ppr tR+                , empty ]+  +        let Just ctx1   = updateExists [] iR tL ctx0+        +        return ctx1+++ -- EqT_EachL+ --  Both types are existentials, and the left is bound earlier in the stack.+ --  CAREFUL: The returned location is relative to the top of the stack,+ --           hence we need lL > lR here.+ | Just iL <- takeExists tL,    Just lL <- locationOfExists iL ctx0+ , Just iR <- takeExists tR,    Just lR <- locationOfExists iR ctx0+ , lL > lR+ = do   let Just ctx1   = updateExists [] iR tL ctx0+        +        ctrace  $ vcat+                [ text "**  EqT_EachL"+                , text "    tL: " <> ppr tL+                , text "    tR: " <> ppr tR+                , indent 4 $ ppr ctx0+                , indent 4 $ ppr ctx1+                , empty ]++        return ctx1+++ -- EqT_EachR+ --  Both types are existentials, and the right is bound earlier in the stack.+ --  CAREFUL: The returned location is relative to the top of the stack,+ --           hence we need lR > lL here.+ | Just iL <- takeExists tL,    Just lL <- locationOfExists iL ctx0+ , Just iR <- takeExists tR,    Just lR <- locationOfExists iR ctx0+ , lR > lL+ = do   let Just ctx1   = updateExists [] iL tR ctx0++        ctrace  $ vcat+                [ text "**  EqT_EachR"+                , text "    tL: " <> ppr tL+                , text "    tR: " <> ppr tR+                , indent 4 $ ppr ctx0+                , indent 4 $ ppr ctx1+                , empty ]++        return ctx1+++ -- EqT_Var+ | TVar u1      <- tL+ , TVar u2      <- tR+ , u1 == u2+ = do   +        -- Suppress tracing of boring rule.+        -- ctrace  $ vcat+        --         [ text "**  EqT_Var"+        --         , text "    tL: " <> ppr tL+        --         , text "    tR: " <> ppr tR+        --         , indent 4 $ ppr ctx0+        --         , empty ]++        return ctx0+++ -- EqT_Con+ | TCon tc1     <- tL+ , TCon tc2     <- tR+ , equivTyCon tc1 tc2+ = do+        -- Only trace rule if it's done something interesting.+        when (not $ tc1 == tc2)+         $ ctrace  $ vcat+                [ text "**  EqT_Con"+                , text "    tL: " <> ppr tL+                , text "    tR: " <> ppr tR+                , empty ]++        return ctx0+++ -- EqT_App+ | TApp tL1 tL2 <- tL+ , TApp tR1 tR2 <- tR+ = do+        ctrace  $ vcat+                [ text "*>  EqT_App" +                , text "    tL: " <> ppr tL+                , text "    tR: " <> ppr tR+                , empty ]++        ctx1    <- makeEqT config ctx0 tL1  tR1  err+        tL2'    <- applyContext ctx1 tL2+        tR2'    <- applyContext ctx1 tR2+        ctx2    <- makeEqT config ctx1 tL2' tR2' err++        ctrace  $ vcat+                [ text "*<  EqT_App"+                , text "    tL: " <> ppr tL+                , text "    tR: " <> ppr tR+                , indent 4 $ ppr ctx0+                , indent 4 $ ppr ctx2+                , empty ]++        return ctx2+++ -- EqT_Equiv+ | equivT (contextEnvT ctx0) tL tR + = do   ctrace  $ vcat+                [ text "**  EqT_Equiv" +                , text "    tL: " <> ppr tL+                , text "    tR: " <> ppr tR+                , empty ]++        return ctx0+++ -- EqT_Fail+ | otherwise+ = do+        ctrace  $ vcat+                [ text "EqT_Fail"+                , text "  tL: " <> ppr tL+                , text "  tR: " <> ppr tR+                , indent 2 $ ppr ctx0+                , empty ]++        throw err+
DDC/Core/Check/Judge/Inst.hs view
@@ -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
+ DDC/Core/Check/Judge/Kind.hs view
@@ -0,0 +1,656 @@++module DDC.Core.Check.Judge.Kind+        (checkTypeM)+where+import DDC.Core.Check.Judge.Kind.TyCon+import DDC.Core.Check.Judge.EqT+import DDC.Core.Check.Context+import DDC.Core.Check.Error+import DDC.Core.Check.Config+import DDC.Type.Exp.Simple.Compounds+import DDC.Type.Exp.Simple.Predicates+import DDC.Type.DataDef+import DDC.Type.Universe+import DDC.Type.Exp+import DDC.Data.Pretty+import Control.Monad+import Data.List+import DDC.Core.Check.Base              (CheckM)+import qualified DDC.Core.Check.Base    as C+import qualified DDC.Type.Sum           as TS+import qualified DDC.Core.Env.EnvX      as EnvX+import qualified DDC.Core.Env.EnvT      as EnvT+import qualified Data.Map               as Map++import DDC.Core.Check.Base+        ( throw+        , newExists+        , applyContext)++-- | Check a type returning its kind, or a kind returning its sort.+--+--   The unverse of the thing to check is directly specified, and if the +--   thing is not actually in this universe they you'll get an error.+--+--   We track what universe the provided kind is in for defence against+--   transform bugs. Types like ([a : [b : Data]. b]. a -> a), should not be+--   accepted by the source parser, but may be created by bogus program+--   transformations. Quantifiers cannot be used at the kind level, so it's +--   better to fail early.+---+--   Note that when comparing kinds, we can just use plain equality+--   (==) instead of equivT. This is because kinds do not contain quantifiers+--   that need to be compared up to alpha-equivalence, nor do they contain+--   crushable components terms.+--+checkTypeM +        :: (Ord n, Show n, Pretty n) +        => Config n     -- ^ Type checker configuration.+        -> Context n    -- ^ Context of type to check.+        -> Universe     -- ^ What universe the type to check is in.+        -> Type n       -- ^ The type to check (can be a Spec or Kind)+        -> Mode n       -- ^ Type checker mode.+        -> CheckM a n +                ( Type n+                , Kind n+                , Context n)++-- Variables ------------------------------------+checkTypeM config ctx0 uni tt@(TVar u) mode++ -- Kind holes.+ --   This is some kind that we were explicitly told to infer,+ --   so make a new existential for it.+ | UniverseKind         <- uni+ , Just n               <- takeNameOfBound u+ , Just isHole          <- configNameIsHole config+ , isHole n+ = case mode of+        -- We don't infer kind holes in recon mode.+        -- The program should have complete kind annotations.+        Recon+         -> do  throw $ C.ErrorType $ ErrorTypeUndefined u++        -- Synthesised kinds are assumed to have sort Comp.+        Synth _+         -> do  i        <- newExists sComp+                let t    = typeOfExists i+                let ctx' = pushExists i ctx0+                return (t, sComp, ctx')++        -- We have an expected sort for the existential,+        -- so use that.+        Check sExpected+         -> do  i        <- newExists sExpected+                let t    = typeOfExists i+                let ctx' = pushExists i ctx0+                return (t, sExpected, ctx')++ -- Spec holes.+ --   This is some spec that we were explicitly told to infer,+ --   so make an existential for it.+ | UniverseSpec         <- uni+ , Just n               <- takeNameOfBound u+ , Just isHole          <- configNameIsHole config+ , isHole n+ = case mode of+        -- We don't infer spec holes in recon mode.+        -- The program should have complete spec annotations.+        Recon+         -> do  throw $ C.ErrorType $ ErrorTypeUndefined u++        -- Synthesised types could have an arbitrary kind, +        -- so we need to make two existentials.+        Synth _+         -> do  iK       <- newExists sComp+                let k    =  typeOfExists iK+                let ctx1 =  pushExists iK ctx0++                iT       <- newExists k+                let t    =  typeOfExists iT+                let ctx2 =  pushExists iT ctx1++                return  (t, k, ctx2)++        -- We have an expected kind for the existential,+        -- so use that.+        Check kExpected+         -> do  iT       <- newExists kExpected+                let t    =  typeOfExists iT+                let ctx1 =  pushExists iT ctx0+                return  (t, kExpected, ctx1)+++ -- Some variable defined in an environment, + -- or a primitive variable with its kind directly attached.+ | UniverseSpec          <- uni+ = let  +        -- Get the actual kind of the variable,+        -- according to the kind environment.+        getActual+         -- A variable in the local environment.+         | Just (k, _role) <- lookupKind u ctx0+         = return k++         -- A variable in the global environment.+         | Just k          <- EnvT.lookup u (contextEnvT ctx0)+         = return k++         -- A primitive type variable with its kind directly attached, but where+         -- the variable is not also in the kind environment. This is a hack used+         -- for static used for static region variables in the evaluator.+         -- We make them constructors rather than variables so that we don't need+         -- to have a data constructor definition for each one.+         | UPrim _ k       <- u+         = return k++         -- Type variable is no where to be found.+         | otherwise+         = throw $ C.ErrorType $ ErrorTypeUndefined u++   in do+        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 +                kExpected' <- applyContext ctx0 kExpected+                ctx1       <- makeEqT config ctx0 kActual' kExpected'+                           $  C.ErrorType $ ErrorTypeMismatch uni  kActual' kExpected' tt++                return (tt, kActual', ctx1)+ +         _ ->   return (tt, kActual', ctx0)++ -- Type variables are not a part of this universe.+ | otherwise+ = throw $ C.ErrorType $ ErrorTypeUniverseMalfunction tt uni+++-- Constructors ---------------------------------+checkTypeM config ctx0 uni tt@(TCon tc) mode+ = let  +        -- Get the actual kind of the constructor, +        -- according to the constructor definition.+        getActual+         -- Sort constructors don't have a higher classification.+         -- We should never try to check these.+         | TyConSort _          <- tc+         , UniverseSort         <- uni+         = throw $ C.ErrorType $ ErrorTypeNakedSort tt++         -- Baked-in kind constructors.+         -- We can't sort-check a naked kind function constructor because+         -- the sort of a fully applied one depends on the argument kind.+         | TyConKind kc         <- tc+         , UniverseKind         <- uni+         = case takeSortOfKiCon kc of+                Just s   -> return (tt, s)+                Nothing  -> throw $ C.ErrorType $ ErrorTypeUnappliedKindFun++         -- Baked-in witness type constructors.+         | TyConWitness tcw     <- tc+         , UniverseSpec         <- uni+         = return (tt, kindOfTwCon tcw)++         -- Baked-in spec type constructors.+         | TyConSpec    tcc     <- tc+         , UniverseSpec         <- uni+         = return (tt, kindOfTcCon tcc)++         -- Fragment specific, or user defined constructors.+         | TyConBound u k       <- tc+         = case u of+            UName n+             -- User defined data type constructors must be in the set of+             -- data defs. Attach the real kind why we're here.+             | Just def         <- Map.lookup n $ dataDefsTypes +                                                $ EnvX.envxDataDefs +                                                $ contextEnvX ctx0+             , UniverseSpec     <- uni+             -> let k'   = kindOfDataType def+                in  return (TCon (TyConBound u k'), k')++             -- The kinds of abstract imported type constructors are in the+             -- global kind environment.+             | Just k'          <- EnvT.lookupName n (contextEnvT ctx0)+             , UniverseSpec     <- uni+             -> return (TCon (TyConBound u k'), k')++             -- For type synonyms, just re-check the right of the binding.+             | Just t'          <- Map.lookup n $ EnvT.envtEquations+                                                $ contextEnvT ctx0+             -> do  (tt', k', _) <- checkTypeM config ctx0 uni t' mode+                    return (tt', k')++             -- We don't have a type for this constructor.+             | otherwise+             -> throw $ C.ErrorType $ ErrorTypeUndefinedTypeCtor u++            -- The kinds of primitive type constructors are directly attached.+            UPrim{} -> return (tt, k)++            -- Type constructors are always defined at top-level and not+            -- by anonymous debruijn binding.+            UIx{}   -> throw $ C.ErrorType $ ErrorTypeUndefinedTypeCtor u++         -- Existentials can be either in the Spec or Kind universe,+         -- and their kinds/sorts are directly attached.+         | TyConExists _ t       <- tc+         , uni == UniverseSpec || uni == UniverseKind+         = return (tt, t)++         -- Whatever constructor we were given wasn't in the expected universe.+         | otherwise+         = throw $ C.ErrorType $ ErrorTypeUniverseMalfunction tt uni+ in do+        -- Get the actual kind/sort of the constructor according to the +        -- constructor definition.+        (tt', kActual)  <- getActual+        kActual'        <- applyContext ctx0 kActual++        case mode of+         -- If we have an expected kind then make the actual kind the same.+         Check kExpected+           -> do +                 kExpected' <- applyContext ctx0 kExpected+                 ctx1   <- makeEqT config ctx0 kActual' kExpected'+                        $  C.ErrorType $ ErrorTypeMismatch uni  kActual' kExpected' tt+                 return (tt', kActual', ctx1)++         -- In Recon and Synth mode just return the actual kind.+         _ ->    return (tt', kActual', ctx0)+++-- Quantifiers ----------------------------------+checkTypeM config ctx0 uni@UniverseSpec +        tt@(TForall b1 t2) mode+ = case mode of+    Recon+     -> do+        -- Check the binder is well sorted.+        let t1  = typeOfBind b1+        _       <- checkTypeM config ctx0 UniverseKind t1 Recon++        -- Check the body with the binder in scope.+        let (ctx1, pos1) = markContext ctx0+        let ctx2         = pushKind b1 RoleAbstract ctx1+        (t2', k2, ctx3) <- checkTypeM config ctx2 UniverseSpec t2 Recon++        -- The body must have kind Data or Witness.+        k2'             <- applyContext ctx3 k2+        when ( not (isDataKind k2')+            && not (isWitnessKind k2'))+         $ throw $ C.ErrorType $ ErrorTypeForallKindInvalid tt t2 k2'++        -- Pop the quantified type off the context.+        let ctx_cut      = popToPos pos1 ctx3++        return (TForall b1 t2', k2', ctx_cut)++    Synth{}+     -> do+        -- Synthesise a sort for the binder.+        let k1  = typeOfBind b1+        (k1', _s1, ctx1) <- checkTypeM config ctx0 UniverseKind k1 (Synth [])+                +        let b1' = replaceTypeOfBind k1' b1++        -- Check the body with the binder in scope.+        let (ctx2, pos1) = markContext ctx1+        let ctx3         = pushKind b1' RoleAbstract ctx2+        (t2', k2, ctx4) <- checkTypeM config ctx3 UniverseSpec t2 (Synth [])++        -- If the kind of the body is unconstrained then default it to Data.+        -- See [Note: Defaulting the kind of quantified types]+        k2' <- applyContext ctx4 k2+        (k2'', ctx5)+         <- if isTExists k2'+             then do+                ctx5    <- makeEqT config ctx4 k2' kData+                        $  C.ErrorType $ ErrorTypeMismatch uni  k2' kData tt++                k2''    <- applyContext ctx5 k2'+                return (k2'', ctx5)++             else do+                return (k2', ctx4)++        -- The above horror show needs to have worked.+        when ( not (isDataKind k2'')+            && not (isWitnessKind k2''))+         $ throw $ C.ErrorType $ ErrorTypeForallKindInvalid tt t2 k2''++        -- Pop the quantified type off the context.+        let ctx_cut      = popToPos pos1 ctx5++        return (TForall b1' t2', k2'', ctx_cut)++    Check kExpected +     -> do+        -- Synthesise a sort for the binder.+        let k1  = typeOfBind b1+        (k1', _s1, ctx1) <- checkTypeM config ctx0 UniverseKind k1 (Synth [])++        let b1' = replaceTypeOfBind k1' b1++        -- Check the body with the binder in scope.+        let (ctx2, pos1) = markContext ctx1+        let ctx3         = pushKind b1' RoleAbstract ctx2+        (t2', k2, ctx4) <- checkTypeM config ctx3 UniverseSpec t2 (Synth [])++        -- In Check mode if *both* the current kind of the body and the expected+        -- 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]+        k2' <- applyContext ctx4 k2+        (k2'', ctx5)+         <- if isTExists k2' && isTExists kExpected+             then do+                ctx'    <- makeEqT config ctx4 k2' kExpected+                        $  C.ErrorType $ ErrorTypeMismatch uni  k2' kExpected tt++                ctx5    <- makeEqT config ctx' k2' kData +                        $  C.ErrorType $ ErrorTypeMismatch uni  k2' kData  tt++                k2''    <- applyContext ctx5 k2'+                return (k2'', ctx5)++             else do+                ctx5    <- makeEqT config ctx4 k2' kExpected+                        $  C.ErrorType $ ErrorTypeMismatch uni  k2' kExpected tt++                k2''    <- applyContext ctx5 k2'+                return (k2'', ctx4)++        -- The above horror show needs to have worked.+        when ( not (isDataKind k2'')+            && not (isWitnessKind k2''))+         $ throw $ C.ErrorType $ ErrorTypeForallKindInvalid tt t2 k2'++        -- Pop the quantified type off the context.+        let ctx_cut      = popToPos pos1 ctx5++        return (TForall b1' t2', k2'', ctx_cut)+++-- Applications ---------------------------------+-- Applications of the kind function constructor are handled directly+-- because the constructor doesn't have a sort by itself.+-- The sort of a kind function is the sort of the result.+checkTypeM config ctx0 uni@UniverseKind +        tt@(TApp (TApp ttFun k1) k2) mode+ | isFunishTCon ttFun+ = case mode of+    Recon+     -> do+        _               <- checkTypeM config ctx0 uni k1 Recon+        (_, s2, _)      <- checkTypeM config ctx0 uni k2 Recon+        return  (tt, s2, ctx0)++    Synth{}+     -> do+        (k1',  _, ctx1) <- checkTypeM config ctx0 uni k1 (Synth [])+        (k2', s2, ctx2) <- checkTypeM config ctx1 uni k2 (Synth [])+        return  (kFun k1' k2', s2, ctx2)++    Check sExpected+     -> do+        (k1',  _, ctx1) <- checkTypeM config ctx0 uni k1 (Synth [])+        (k2', s2, ctx2) <- checkTypeM config ctx1 uni k2 (Check sExpected)+        return  (kFun k1' k2', s2, ctx2)+++-- The implication constructor is overloaded and can have the+-- following kinds:+--   (=>) :: @ ~> @ ~> @,  for witness constructors.+--   (=>) :: @ ~> * ~> *,  for functions that take witnesses.+checkTypeM config ctx0 uni@UniverseSpec +        tt@(TApp (TApp tC@(TCon (TyConWitness TwConImpl)) t1) t2) mode+ = case mode of+    Recon+     -> do+        (t1', k1, ctx1) <- checkTypeM config ctx0 uni t1 Recon+        (t2', k2, ctx2) <- checkTypeM config ctx1 uni t2 Recon++        let tt' = TApp (TApp tC t1') t2'++        if      isWitnessKind k1 && isWitnessKind k2+         then     return (tt', kWitness, ctx2)+        else if isWitnessKind k1 && isDataKind k2+         then     return (tt', kData, ctx2)+        else    throw $ C.ErrorType $ ErrorTypeWitnessImplInvalid tt t1 k1 t2 k2++    Synth{}+     -> do+        (t1', _k1, ctx1) <- checkTypeM config ctx0 uni t1 mode+        (t2', k2,  ctx2) <- checkTypeM config ctx1 uni t2 mode++        return (tImpl t1' t2', k2, ctx2)++    Check kExpected+     -> do+        -- When checking type functions we don't need to worry about scopes.+        (t1', _k1, ctx1) <- checkTypeM config ctx0 uni t1 (Synth [])+        (t2', k2,  ctx2) <- checkTypeM config ctx1 uni t2 (Check kExpected)++        return (tImpl t1' t2', k2, ctx2)+++-- General type application.+checkTypeM config ctx0 UniverseSpec +        tt@(TApp tFn tArg) mode+ = case mode of+    Recon+     -> do+        -- Check the kind of the functional part.+        (tFn',  kFn,  ctx1) +         <- checkTypeM config ctx0 UniverseSpec tFn Recon+        +        -- Check the kind of the argument.+        (tArg', kArg, ctx2) +         <- checkTypeM config ctx1 UniverseSpec tArg Recon++        -- The kind of the parameter must match that of the argument+        case kFn of+         TApp (TApp ttFun kParam) kBody+           |  isFunishTCon ttFun +           ,  C.equivT (contextEnvT ctx2) kParam kArg+           -> return (tApp tFn' tArg', kBody, ctx2)++           | otherwise+           -> throw $ C.ErrorType $ ErrorTypeAppArgMismatch tt tFn' kFn tArg' kArg++         _ -> throw $ C.ErrorType $ ErrorTypeAppNotFun tt tFn' kFn tArg'++    Synth{}+     -> do+        -- Synthesise a kind for the functional part.+        (tFn', kFn, ctx1) +         <- checkTypeM config ctx0 UniverseSpec tFn (Synth [])++        -- Apply the argument to the function.+        kFn'    <- applyContext ctx1 kFn+        (kResult, tArg', ctx2)+         <- synthTAppArg config ctx1 tFn' kFn' tArg++        return (TApp tFn' tArg', kResult, ctx2)++    Check kExpected+     -> do+        -- Synthesise a kind for the overall type.+        (t1', k1, ctx1) +         <- checkTypeM config ctx0 UniverseSpec tt (Synth [])++        -- Force the synthesised kind to be the same as the expected one.+        k1'         <- applyContext   ctx1 k1+        kExpected'  <- applyContext   ctx1 kExpected+        ctx2        <- makeEqT config ctx1 k1' kExpected'+                    $  C.ErrorType $ ErrorTypeMismatch UniverseSpec k1' kExpected' tt++        return (t1', k1', ctx2)+++-- Sums -----------------------------------------+checkTypeM config ctx0 UniverseSpec tt@(TSum ss) mode+ = case mode of+    Recon+     -> do   +        -- Check all the elements,+        --  threading the context from left to right.+        (ts', ks, ctx1) +                <- checkTypesM config ctx0 UniverseSpec Recon+                $  TS.toList ss++        -- Check that all the types in the sum have the same kind.+        let kExpect = TS.kindOfSum ss+        k'      <- case nub ks of     +                     []     -> return $ TS.kindOfSum ss+                     [k]    -> return k+                     _      -> throw $ C.ErrorType $ ErrorTypeSumKindMismatch kExpect ss ks++        -- Check that the kind of the elements is a valid one.+        -- Only effects and closures can be summed.+        if (k' == kEffect || k' == kClosure)+         then return (TSum (TS.fromList k' ts'), k', ctx1)+         else throw $ C.ErrorType $ ErrorTypeSumKindInvalid ss k'++    Synth{}+     -> do+        -- Synthesise a kind for all the elements,+        --  threading the context from left to right.+        (ts, ks, ctx1)+                <- checkTypesM config ctx0 UniverseSpec (Synth [])+                $  TS.toList ss++        case ks of+         -- Force all elements to have the same kind as the first one.+         -- Note that (TS.kindOfSum ts) will be Bot in an unannotated program,+         -- so we can't use that directly.+         k : _ksMore+          -> do +                (ts'', _, ctx2)+                    <- checkTypesM  config 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+         -- then default it to Effect kind. This shouldn't happen in a well formed+         -- program, but might in a generated one.+         [] |  isBot (TS.kindOfSum ss)+            -> return   ( TSum (TS.fromList kEffect [])+                        , kEffect, ctx0)+            | otherwise+            -> return   ( TSum (TS.empty (TS.kindOfSum ss))+                        , TS.kindOfSum ss, ctx0)++    Check kExpected+     -> do+        -- Synthesise a kind for the overall type.+        (t1', k1, ctx1)+                <- checkTypeM config ctx0 UniverseSpec tt (Synth [])++        -- Force the synthesised kind to match the expected one.+        k1'         <- applyContext   ctx1 k1+        kExpected'  <- applyContext   ctx1 kExpected+        ctx2        <- makeEqT config ctx1 k1' kExpected'+                    $  C.ErrorType $ ErrorTypeMismatch UniverseSpec k1' kExpected' tt++        return  (t1', k1, ctx2)+++-- Whatever type we were given wasn't in the specified universe.+checkTypeM _ _ uni tt _mode+        = throw $ C.ErrorType $ ErrorTypeUniverseMalfunction tt uni+++-------------------------------------------------------------------------------+-- | Like `checkTypeM` but do several, chaining the contexts appropriately.+checkTypesM +        :: (Ord n, Show n, Pretty n) +        => Config n             -- ^ Type checker configuration.+        -> Context n            -- ^ Local context.+        -> Universe             -- ^ What universe the types to check are in.+        -> Mode n               -- ^ Type checker mode.+        -> [Type n]             -- ^ The types to check.+        -> CheckM a n +                ( [Type n]+                , [Kind n]+                , Context n)++checkTypesM _      ctx0 _   _    []+ = return ([], [], ctx0)++checkTypesM config ctx0 uni mode (t : ts)+ = do   (t',  k',  ctx1)  <- checkTypeM  config ctx0 uni t mode+        (ts', ks', ctx')  <- checkTypesM config ctx1 uni mode ts+        return  (t' : ts', k' : ks', ctx')+++-------------------------------------------------------------------------------+-- | Synthesise the type of a kind function applied to its argument.+synthTAppArg+        :: (Show n, Ord n, Pretty n)+        => Config n+        -> Context n+        -> Type n               -- Type function.+        -> Kind n               -- Kind of functional part.+        -> Type n               -- Type argument.+        -> CheckM a n+                ( Kind n        -- Kind of result.+                , Type n        -- Checked type argument.+                , Context n)    -- Result context. ++synthTAppArg config ctx0 tFn kFn tArg++ | Just iFn     <- takeExists kFn+ = do  +        -- New existential for the kind of the function parameter.+        iParam          <- newExists sComp+        let kParam      = typeOfExists iParam++        -- New existential for the kind of the function body+        iBody           <- newExists sComp+        let kBody       = typeOfExists iBody++        -- Update the context with the new constraint.+        let Just ctx1   = updateExists [iBody, iParam] iFn +                                (kFun kParam kBody) ctx0++        -- Check the argument under the new context.+        (tArg', _kArg, ctx2)+         <- checkTypeM config ctx1 UniverseSpec tArg (Check kParam)++        return (kBody, tArg', ctx2)+++ | TApp (TApp ttFun kParam) kBody <- kFn+ , isFunishTCon ttFun+ = do   +        -- The kind of the argument must match the parameter kind+        (tArg', _kArg, ctx1) +         <- checkTypeM config ctx0 UniverseSpec tArg (Check kParam)++        return (kBody, tArg', ctx1)++ | otherwise+ = throw $ C.ErrorType $ ErrorTypeAppNotFun (TApp tFn tArg) tFn kFn tArg +++-- [Note: Defaulting the kind of quantified types]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- For expressions like:+--   /\a. \(x : [b : Data]. a). ()+--  +-- The kind of 'a' must be Data because 'x' is used as a parameter of a function +-- abstraction. If the kind of the body of a quantified type is unconstrained +-- then we default it to data.+--+-- Although the types of witness constructors have quantified types, +-- those types are primitive, so we never need to do type inference for them.+-- There aren't any cases where defaulting the kind of a quantified type to +-- Data would be the wrong thing to do.+--
+ DDC/Core/Check/Judge/Kind/TyCon.hs view
@@ -0,0 +1,67 @@++module DDC.Core.Check.Judge.Kind.TyCon+        ( takeKindOfTyCon+        , takeSortOfKiCon+        , kindOfTwCon+        , kindOfTcCon)+where+import DDC.Type.Exp.Simple+++-- | Take the superkind of an atomic kind constructor.+--+--   Yields `Nothing` for the kind function (~>) as it doesn't have a sort+--   without being fully applied.+takeSortOfKiCon :: KiCon -> Maybe (Sort n)+takeSortOfKiCon kc+ = case kc of+        KiConFun        -> Nothing+        KiConData       -> Just sComp+        KiConRegion     -> Just sComp+        KiConEffect     -> Just sComp+        KiConClosure    -> Just sComp+        KiConWitness    -> Just sProp+++-- | Take the kind of a `TyCon`, if there is one.+takeKindOfTyCon :: TyCon n -> Maybe (Kind n)+takeKindOfTyCon tt+ = case tt of        +        -- Sorts don't have a higher classification.+        TyConSort    _   -> Nothing+ +        TyConKind    kc  -> takeSortOfKiCon kc+        TyConWitness tc  -> Just $ kindOfTwCon tc+        TyConSpec    tc  -> Just $ kindOfTcCon tc+        TyConBound   _ k -> Just k+        TyConExists  _ k -> Just k+++-- | Take the kind of a witness type constructor.+kindOfTwCon :: TwCon -> Kind n+kindOfTwCon tc+ = case tc of+        TwConImpl       -> kWitness  `kFun`  kWitness `kFun` kWitness+        TwConPure       -> kEffect   `kFun`  kWitness+        TwConConst      -> kRegion   `kFun`  kWitness+        TwConDeepConst  -> kData     `kFun`  kWitness+        TwConMutable    -> kRegion   `kFun`  kWitness+        TwConDeepMutable-> kData     `kFun`  kWitness+        TwConDisjoint   -> kEffect   `kFun`  kEffect  `kFun`  kWitness+        TwConDistinct n -> (replicate n kRegion)      `kFuns` kWitness        +++-- | Take the kind of a computation type constructor.+kindOfTcCon :: TcCon -> Kind n+kindOfTcCon tc+ = case tc of+        TcConUnit       -> kData+        TcConFun        -> kData    `kFun` kData `kFun` kData+        TcConSusp       -> kEffect  `kFun` kData `kFun` kData+        TcConRead       -> kRegion  `kFun` kEffect+        TcConHeadRead   -> kData    `kFun` kEffect+        TcConDeepRead   -> kData    `kFun` kEffect+        TcConWrite      -> kRegion  `kFun` kEffect+        TcConDeepWrite  -> kData    `kFun` kEffect+        TcConAlloc      -> kRegion  `kFun` kEffect+        TcConDeepAlloc  -> kData    `kFun` kEffect
+ DDC/Core/Check/Judge/Module.hs view
@@ -0,0 +1,673 @@++module DDC.Core.Check.Judge.Module+        ( checkModule+        , checkModuleM)+where+import DDC.Core.Check.Judge.Type.Base   (checkTypeM)+import DDC.Core.Check.Judge.DataDefs+import DDC.Core.Check.Base+import DDC.Core.Check.Exp+import DDC.Core.Transform.Reannotate+import DDC.Core.Transform.MapT+import DDC.Core.Module+import DDC.Core.Env.EnvX                (EnvX)+import DDC.Control.Check                (runCheck, throw)++import qualified DDC.Type.Env           as Env+import qualified DDC.Core.Env.EnvT      as EnvT+import qualified DDC.Core.Env.EnvX      as EnvX+import qualified Data.Map.Strict        as Map+++-- Wrappers ---------------------------------------------------------------------------------------+-- | Type check a module.+--+--   If it's good, you get a new version with types attached to all the bound+--   variables+--+--   If it's bad, you get a description of the error.+checkModule+        :: (Show a, Ord n, Show n, Pretty n)+        => Config n             -- ^ Static configuration.+        -> Module a n           -- ^ Module to check.+        -> Mode n               -- ^ Type checker mode.+        -> ( Either (Error a n) (Module (AnTEC a n) n)+           , CheckTrace )++checkModule !config !xx !mode+ = let  (s, result)     = runCheck (mempty, 0, 0)+                        $ checkModuleM config xx mode+        (tr, _, _)      = s+   in   (result, tr)+++-- checkModule ------------------------------------------------------------------------------------+-- | Like `checkModule` but using the `CheckM` monad to handle errors.+checkModuleM+        :: (Show a, Ord n, Show n, Pretty n)+        => Config n             -- ^ Static configuration.+        -> Module a n           -- ^ Module to check.+        -> Mode n               -- ^ Type checker mode.+        -> CheckM a n (Module (AnTEC a n) n)++checkModuleM !config mm@ModuleCore{} !mode+ = do+        let envT_prim+                = EnvT.empty+                { EnvT.envtPrimFun      +                        = \n -> Env.lookupName n (configPrimKinds config) }++        -- Check sorts of imported types --------------------------------------+        ctrace  $ vcat+                [ text "* Checking Sorts of Imported Types" ]++        --   These have explicit kind annotations on the type parameters,+        --   which we can sort check directly.+        nitsImportType'+                <- checkImportTypes  config envT_prim mode+                $  moduleImportTypes mm++        let nksImportType' +                = [(n, kindOfImportType i) | (n, i) <- nitsImportType']++        -- Check sorts of imported data types ---------------------------------+        ctrace  $ vcat+                [ text "* Checking Sorts of Imported Data Types." ]++        --   These have explicit kind annotations on the type parameters,+        --   which we can sort check directly.+        nksImportDataDef'   +                <- checkSortsOfDataTypes config mode+                $  moduleImportDataDefs  mm+++        ctrace  $ vcat+                [ text "* Checking Sorts of Local Data Types." ]++        nksLocalDataDef'+                <- checkSortsOfDataTypes config mode+                $  moduleDataDefsLocal   mm++        let envT_dataDefs+                = EnvT.unions+                [ envT_prim+                , EnvT.fromListNT nksImportType'+                , EnvT.fromListNT nksImportDataDef'+                , EnvT.fromListNT nksLocalDataDef' ]++        -- Check kinds of imported type equations -----------------------------+        --   The right of each type equation can mention both imported abstract+        --   types and data type definitions, so we need to include them in+        --   the kind environment as well.+        ctrace  $ vcat+                [ text "* Checking Kinds of Imported Type Equations."]++        -- Imported type equations may mention each other.+        nktsImportTypeDef'+                <- checkKindsOfTypeDefs +                        config +                        envT_dataDefs+                          { EnvT.envtEquations +                          = Map.map snd $ Map.fromList $ moduleImportTypeDefs mm }+                $  moduleImportTypeDefs mm++        let envT_importedTypeDefs+                = EnvT.unions+                [ envT_dataDefs+                , EnvT.fromListNT [ (n, k) | (n, (k, _)) <- nktsImportTypeDef']+                , EnvT.empty +                        { EnvT.envtEquations +                        = Map.fromList    [ (n, t) | (n, (_, t)) <- nktsImportTypeDef']}]+++        -- Check kinds of local type equations --------------------------------+        --   The right of each type equation can mention+        --   imported abstract types, imported and local data type definitions.+        ctrace  $ vcat+                [ text "* Checking Kinds of Local Type Equations."]++        -- Kinds of type constructors in scope in the+        -- locally defined type equations.+        nktsLocalTypeDef'+                <- checkKindsOfTypeDefs+                        config +                        envT_importedTypeDefs+                         { EnvT.envtEquations+                         = Map.map snd $ Map.fromList $ moduleTypeDefsLocal mm }+                $  moduleTypeDefsLocal  mm++        let envT_localTypeDefs+                = EnvT.unions+                [ envT_importedTypeDefs+                , EnvT.fromListNT [ (n, k) | (n, (k, _)) <- nktsLocalTypeDef']+                , EnvT.empty+                        { EnvT.envtEquations+                        = Map.unions+                                [ Map.fromList [ (n, t) | (n, (_, t)) <- nktsLocalTypeDef']+                                , Map.fromList [ (n, t) | (n, (_, t)) <- nktsImportTypeDef' ]]+                        }+                ]+++        -- Check imported data type defs --------------------------------------+        ctrace  $ vcat+                [ text "* Checking Kinds of Imported Data Types."]++        let dataDefsImported = moduleImportDataDefs mm+        dataDefsImported'  +         <- case checkDataDefs config envT_localTypeDefs dataDefsImported of+                (err : _, _)            -> throw $ ErrorData err+                ([], dataDefsImported') -> return dataDefsImported'+++        -- Check the local data defs ------------------------------------------+        ctrace  $ vcat+                [ text "* Checking Kinds of Local Data Types."]++        let dataDefsLocal    = moduleDataDefsLocal mm+        dataDefsLocal'  +         <- case checkDataDefs config envT_localTypeDefs dataDefsLocal of+                (err : _, _)            -> throw $ ErrorData err+                ([], dataDefsLocal')    -> return dataDefsLocal'++        let dataDefs_top    +                = unionDataDefs (configPrimDataDefs config)+                $ unionDataDefs (fromListDataDefs dataDefsImported')+                                (fromListDataDefs dataDefsLocal')+++        -- Check types of imported capabilities -------------------------------+        ctrace  $ vcat+                [ text "* Checking Kinds of Imported Capabilities."]++        ntsImportCap'   +                <- checkImportCaps   config  envT_localTypeDefs mode+                $  moduleImportCaps  mm++        let envT_importCaps+                = EnvT.unions+                [ envT_localTypeDefs+                , EnvT.empty+                        { EnvT.envtCapabilities +                           = Map.fromList +                           $ [ (n, t) | (n, ImportCapAbstract t) <- ntsImportCap'] }]+++        -- Check types of imported values ------------------------------------+        ctrace  $ vcat+                [ text "* Checking Types of Imported Values."]++        ntsImportValue'+                <- checkImportValues  config envT_importCaps mode+                $  moduleImportValues mm++        let envX_importValues+                = (EnvX.fromListNT [(n, typeOfImportValue i) | (n, i) <- ntsImportValue' ])+                {  EnvX.envxEnvT     = envT_importCaps +                ,  EnvX.envxDataDefs = dataDefs_top+                ,  EnvX.envxPrimFun  = \n -> Env.envPrimFun (configPrimTypes config) n }+++        -----------------------------------------------------------------------+        -- Build the top-level config, defs and environments.+        --  These contain names that are visible to bindings in the module.+        let envT_top    = envT_importCaps+        let envX_top    = envX_importValues+        let ctx_top     = emptyContext { contextEnvX = envX_top }+++        -- Check the sigs of exported types ---------------+        esrcsType'  <- checkExportTypes   config envT_top+                    $  moduleExportTypes  mm+++        -- Check the sigs of exported values --------------+        esrcsValue' <- checkExportValues  config envT_top+                    $  moduleExportValues mm+++        -- Check the body of the module -------------------+        (x', _, _effs, ctx)+         <- checkExpM   (makeTable config)+                        ctx_top mode DemandNone (moduleBody mm) ++        -- Apply the final context to the annotations in expressions.+        let applyToAnnot (AnTEC t0 e0 _ x0)+             = do t0' <- applySolved ctx t0+                  e0' <- applySolved ctx e0+                  return $ AnTEC t0' e0' (tBot kClosure) x0++        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     = nitsImportType'+                , moduleImportTypeDefs  = nktsImportTypeDef'+                , moduleImportCaps      = ntsImportCap'+                , moduleImportValues    = ntsImportValue'+                , moduleTypeDefsLocal   = nktsLocalTypeDef'+                , moduleBody            = xx_annot }+++        -- Check that each exported signature matches the type of its binding.+        -- This returns an environment containing all the bindings defined+        -- in the module.+        envX_binds+         <- checkModuleBinds envX_top+                (moduleExportTypes  mm_inferred)+                (moduleExportValues mm_inferred) +                xx_annot++        -- 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 envX_binds)+                $ map fst $ moduleExportValues mm_inferred++        -- If exported names are missing types then fill them in.+        let updateExportSource e+                | ExportSourceLocalNoType n <- e+                , Just t  <- EnvX.lookupX (UName n) envX_binds+                = 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_final+                = mm_inferred+                { moduleExportValues    = esrcsValue_updated }++        return mm_final+++---------------------------------------------------------------------------------------------------+-- | Check exported types.+checkExportTypes+        :: (Show n, Pretty n, Ord n)+        => Config  n+        -> EnvT  n+        -> [(n, ExportSource n (Type n))]+        -> CheckM a n [(n, ExportSource n (Type n))]++checkExportTypes config env nesrcs+ = let  +        ctx     = contextOfEnvT env++        check (n, esrc)+         | Just k          <- takeTypeOfExportSource esrc+         = do   (k', _, _) <- checkTypeM config ctx UniverseKind k Recon+                return  $ (n, mapTypeOfExportSource (const k') esrc)++         | otherwise+         = return (n, esrc)+   in do+        -- Check for duplicate exports.+        let dups = findDuplicates $ map fst nesrcs+        (case takeHead dups of+          Just n -> throw $ ErrorExportDuplicate n+          _      -> return ())+++        -- Check the kinds of the export specs.+        mapM check nesrcs+++---------------------------------------------------------------------------------------------------+-- | Check exported types.+checkExportValues+        :: (Show n, Pretty n, Ord n)+        => Config n +        -> EnvT   n+        -> [(n, ExportSource n (Type n))]+        -> CheckM a n [(n, ExportSource n (Type n))]++checkExportValues config env nesrcs+ = let  +        ctx     = contextOfEnvT env++        check (n, esrc)+         | Just t          <- takeTypeOfExportSource esrc+         = do   (t', _, _) <- checkTypeM config ctx UniverseSpec t Recon+                return  $ (n, mapTypeOfExportSource (const t') esrc)++         | otherwise+         = return (n, esrc)++   in do+        -- Check for duplicate exports.+        let dups = findDuplicates $ map fst nesrcs+        (case takeHead dups of+          Just n -> throw $ ErrorExportDuplicate n+          _      -> return ())++        -- Check the types of the exported values.+        mapM check nesrcs+++---------------------------------------------------------------------------------------------------+-- | Check kinds of imported types.+checkImportTypes+        :: (Ord n, Show n, Pretty n)+        => Config n+        -> EnvT   n +        -> Mode   n+        -> [(n, ImportType n (Type n))]+        -> CheckM a n [(n, ImportType n (Type n))]++checkImportTypes config env mode nisrcs+ = let+        ctx     = contextOfEnvT env++        -- Checker mode to use.+        modeCheckImportTypes+         = case mode of+                Recon   -> Recon+                _       -> Synth []++        -- Check an import definition.+        check (n, isrc)+         = do   let k      =  kindOfImportType isrc+                (k', _, _) <- checkTypeM config ctx UniverseKind k modeCheckImportTypes+                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 env k1 k2++        compat (ImportTypeBoxed    k1) (ImportTypeBoxed    k2)+                = equivT env k1 k2++        compat _ _ = False++   in do+        -- Check all the imports individually.+        nisrcs' <- mapM check nisrcs++        -- Check that exports with the same name are compatable,+        -- and pack down duplicates.+        pack Map.empty nisrcs'+++-------------------------------------------------------------------------------+-- | Check kinds of data type definitions,+--   returning a map of data type constructor constructor name to its kind.+checkSortsOfDataTypes+        :: (Ord n, Show n, Pretty n)+        => Config n +        -> Mode n+        -> [DataDef n]+        -> CheckM a n [(n, Kind n)]++checkSortsOfDataTypes config mode defs+ = let+        -- Checker mode to use.+        modeCheckDataTypes+         = case mode of+                Recon   -> Recon+                _       -> Synth []++        -- Check kind of a data type constructor.+        check def+         = do   let k   = kindOfDataDef def+                (k', _, _) <- checkTypeM config emptyContext UniverseKind k modeCheckDataTypes+                return (dataDefTypeName def, k')++   in do+        -- Check all the imports individually.+        nks     <- mapM check defs+        return  nks+++---------------------------------------------------------------------------------------------------+-- | Check kinds of imported type equations.+checkKindsOfTypeDefs+        :: (Ord n, Show n, Pretty n)+        => Config n+        -> EnvT n+        -> [(n, (Kind n, Type n))]+        -> CheckM a n [(n, (Kind n, Type n))]++checkKindsOfTypeDefs config env nkts+ = let+        ctx     = contextOfEnvT env++        -- Check a single type equation.+        check (n, (_k, t))+         = do   (t', k', _) +                 <- checkTypeM config ctx UniverseSpec t Recon++                -- ISSUE #374: Check specified kinds of type equations against inferred kinds.+                return (n, (k', t'))++   in do+        -- ISSUE #373: Check that type equations are not recursive.+        nkts' <- mapM check nkts+        return nkts'+++---------------------------------------------------------------------------------------------------+-- | Check types of imported capabilities.+checkImportCaps+        :: (Ord n, Show n, Pretty n)+        => Config n +        -> EnvT n+        -> Mode n+        -> [(n, ImportCap n (Type n))]+        -> CheckM a n [(n, ImportCap n (Type n))]++checkImportCaps config env mode nisrcs+ = let+        ctx     = contextOfEnvT env++        -- 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 ctx 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 (contextEnvT ctx) 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 +        -> EnvT n +        -> Mode n+        -> [(n, ImportValue n (Type n))]+        -> CheckM a n [(n, ImportValue n (Type n))]++checkImportValues config env mode nisrcs+ = let+        ctx = contextOfEnvT env++        -- Checker mode to use.+        modeCheckImportTypes+         = case mode of+                Recon   -> Recon+                _       -> Check kData++        -- Check an import definition.+        check (n, isrc)+         = do   let t      =  typeOfImportValue isrc+                (t', k, _) <- checkTypeM config ctx UniverseSpec+                                         t modeCheckImportTypes++                -- In Recon mode we need to post-check that the imported+                -- 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, 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 (contextEnvT ctx) t1 t2 && a1 == a2++        compat (ImportValueSea _ t1)+               (ImportValueSea _ t2)+         = equivT (contextEnvT ctx) t1 t2 ++        compat _ _ = False++   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 that the exported signatures match the types of their bindings.+checkModuleBinds+        :: Ord n+        => EnvX n                               -- ^ Starting environment.+        -> [(n, ExportSource n (Type n))]       -- ^ Exported types.+        -> [(n, ExportSource n (Type n))]       -- ^ Exported values+        -> Exp (AnTEC a n) n+        -> CheckM a n (EnvX n)                  -- ^ Environment of top-level bindings+                                                --   defined by the module++checkModuleBinds !env !ksExports !tsExports !xx+ = case xx of+        XLet _ (LLet b _) x2+         -> do  checkModuleBind (EnvX.envxEnvT env) ksExports tsExports b+                env'    <- checkModuleBinds env ksExports tsExports x2+                return  $ EnvX.extendX b env'++        XLet _ (LRec bxs) x2+         -> do  mapM_ (checkModuleBind (EnvX.envxEnvT env) ksExports tsExports) $ map fst bxs+                env'    <- checkModuleBinds env ksExports tsExports x2+                return  $ EnvX.extendsX (map fst bxs) env'++        XLet _ (LPrivate _ _ _) x2+         ->     checkModuleBinds env ksExports tsExports x2++        _ ->    return env+++-- | If some bind is exported, then check that it matches the exported version.+checkModuleBind+        :: Ord n+        => EnvT n                               -- ^ Environment of types.+        -> [(n, ExportSource n (Type n))]       -- ^ Exported types.+        -> [(n, ExportSource n (Type n))]       -- ^ Exported values.+        -> Bind n+        -> CheckM a n ()++checkModuleBind env !_ksExports !tsExports !b+ | BName n tDef <- b+ = case join $ liftM takeTypeOfExportSource $ lookup n tsExports of+        Nothing                 -> return ()+        Just tExport+         | equivT env tDef tExport  -> return ()+         | otherwise                -> throw $ ErrorExportMismatch n tExport tDef++ -- Only named bindings can be exported,+ --  so we don't need to worry about non-named ones.+ | otherwise+ = return ()+++---------------------------------------------------------------------------------------------------+-- | Check that an exported top-level value is actually defined by the module.+checkBindDefined+        :: Ord n+        => EnvX n               -- ^ Environment containing binds defined by the module.+        -> n                    -- ^ Name of an exported binding.+        -> CheckM a n ()++checkBindDefined envx n+ = case EnvX.lookupX (UName n) envx of+        Just _  -> return ()+        _       -> throw $ ErrorExportUndefined n+
DDC/Core/Check/Judge/Sub.hs view
@@ -1,212 +1,415 @@  module DDC.Core.Check.Judge.Sub-        ( makeSub)+        (makeSub) where import DDC.Type.Transform.SubstituteT-import DDC.Core.Annot.AnTEC-import DDC.Core.Check.Judge.Eq+import DDC.Core.Check.Judge.EqT+import DDC.Core.Exp.Annot.AnTEC import DDC.Core.Check.Judge.Inst import DDC.Core.Check.Base+import qualified DDC.Core.Check.Context as Context+import qualified DDC.Core.Env.EnvT      as EnvT+import qualified Data.Map.Strict        as Map+import qualified DDC.Type.Sum           as Sum   -- | Make the left type a subtype of the right type, --   or throw the provided error if this is not possible.+--+--   The inferred type may already be a subtype of the expected type,+--   and in that case we don't need to do anything extra.+--+--   If the inferred type is a 'S e a' computation type and the expected+--   type is 'a' then we can force the inferred type to be the expected one+--   by running the computation. In this case we end up with more effects.+-- makeSub :: (Eq n, Ord n, Show n, Pretty n)-        => Config n-        -> a-        -> Context n-        -> Exp  (AnTEC a n) n-        -> Type n-        -> Type n-        -> Error a n-        -> CheckM a n -                ( Exp (AnTEC a n) n-                , Context n)+        => Config n                     -- ^ Type checker configuration.+        -> a                            -- ^ Current annotation.+        -> Context n                    -- ^ Input context.+        -> Exp a n                      -- ^ Original expression, for error reporting.+        -> Exp  (AnTEC a n) n           -- ^ Expression that we've inferred the type of.+        -> Type n                       -- ^ Inferred type of the expression.+        -> Type n                       -- ^ Expected type of the expression.+        -> Error a n                    -- ^ Error to throw if we can't force subsumption.+        -> CheckM a n+                ( Exp (AnTEC a n) n     --   Expression after instantiations and running.+                , TypeSum n             --   More effects we might get from running the computation.+                , Context n)            --   Output context.  -- NOTE: The order of cases matters here. --       For example, we do something different when both sides are --       existentials, vs the case when only one side is an existential.-makeSub config a ctx0 xL tL tR err+makeSub config a ctx0 x0 xL tL tR err - -- SubCon- --  Both sides are the same type constructor.- | TCon tc1     <- tL- , TCon tc2     <- tR- , equivTyCon tc1 tc2- = do   + -- Sub_SynL+ --   Expand type synonym on the left.+ | TCon (TyConBound (UName n) _) <- tL+ , Just tL'  <- Map.lookup n $ EnvT.envtEquations+                             $ Context.contextEnvT ctx0+ = do         ctrace  $ vcat-                [ text "* SubCon"-                , text "  LEFT:  " <> ppr tL-                , text "  RIGHT: " <> ppr tR-                , indent 2 $ ppr ctx0+                [ text "**  Sub_SynL"+                , text "    tL:  " <> ppr tL+                , text "    tL': " <> ppr tL'+                , text "    tR:  " <> ppr tR                 , empty ] -        return (xL, ctx0)+        makeSub config a ctx0 x0 xL tL' tR err  - -- SubVar- --  Both sides are the same (rigid) type variable.- | TVar u1      <- tL- , TVar u2      <- tR- , u1 == u2- = do   + -- Sub_SynR+ --   Expand type synonym on the right.+ | TCon (TyConBound (UName n) _) <- tR+ , Just tR'  <- Map.lookup n $ EnvT.envtEquations+                             $ Context.contextEnvT ctx0+ = do         ctrace  $ vcat-                [ text "* SubVar"-                , text "  LEFT:  " <> ppr tL-                , text "  RIGHT: " <> ppr tR-                , indent 2 $ ppr ctx0+                [ text "**  Sub_SynR"+                , text "    tL:  " <> ppr tL+                , text "    tR:  " <> ppr tR +                , text "    tR': " <> ppr tR                 , empty ] -        return (xL, ctx0)+        makeSub config a ctx0 x0 xL tL tR' err  - -- SubExVar- --  Both sides are the same existential.+ -- Sub_ExVar+ --   Both sides are already the same existential,+ --   so we don't need to do anything further.  | 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 "**  Sub_ExVar"+                , text "    tL: " <> ppr tL+                , text "    tR: " <> ppr tR+                , text "    xL: " <> ppr xL+                , indent 4 $ ppr ctx0                 , empty ] -        return (xL, ctx0)+        return  ( xL+                , Sum.empty kEffect+                , ctx0)    -- SubInstL- --  Left is an existential.- --- --  ISSUE #326: Do free variables check in new inferencer.- --    check  tL /= FV(tR)- --+ --   Left is an existential.  | 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 "**  Sub_InstL"+                , text "    tL: " <> ppr tL+                , text "    tR: " <> ppr tR+                , text "    xL: " <> ppr xL+                , indent 4 $ ppr ctx0+                , indent 4 $ ppr ctx1                 , empty ] -        return (xL, ctx1)+        return  ( xL+                , Sum.empty kEffect+                , ctx1)    -- SubInstR- --  Right is an existential.- --- --  ISSUE #326: Do free variables check in new inferencer.- --     check  tR /= FV(tL)- --+ --   Right is an existential.  | 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 "**  Sub_InstR"+                , text "    tL: " <> ppr tL+                , text "    tR: " <> ppr tR+                , text "    xL: " <> ppr xL+                , indent 4 $ ppr ctx0+                , indent 4 $ ppr ctx1                 , empty ] -        return (xL, ctx1)+        return  ( xL+                , Sum.empty kEffect+                , ctx1)  - -- SubArr- --  Both sides are arrow types.+ -- Sub_Con+ --   Both sides are type constructors which are equivalent.+ --   + --   ISSUE #378: Complete merging (~>) and (->) type constructors.+ --   The equivTyCon function already treats these equivalent, + --   but we should just use (->) at all levels and ditch (~>).+ --+ | TCon tc1     <- tL+ , TCon tc2     <- tR+ , equivTyCon tc1 tc2+ = do+        -- Only trace rule if it's done something interesting.+        when (not $ tc1 == tc2)+         $ ctrace  $ vcat+                [ text "**  Sub_Con"+                , text "    tL: " <> ppr tL+                , text "    tR: " <> ppr tR+                , text "    xL: " <> ppr xL+                , empty ]++        return  ( xL+                , Sum.empty kEffect+                , ctx0)+++ -- Sub_Var+ --   Both sides are the same (rigid) type variable,+ --   so we don't need to do anything further.+ | TVar u1      <- tL+ , TVar u2      <- tR+ , u1 == u2+ = do+        -- Suppress tracing of noisy rule.+        -- ctrace  $ vcat+        --         [ text "**  Sub_Var"+        --         , text "    tL: " <> ppr tL+        --         , text "    tR: " <> ppr tR+        --         , text "    xL: " <> ppr xL+        --         , empty ]++        return  ( xL+                , Sum.empty kEffect+                , ctx0)++ -- Sub_Equiv+ --   Both sides are equivalent.+ --   The `equivT` function will also crush any effect types, + --   and handle comparing type sums for equivalence.+ --+ | equivT (contextEnvT ctx0) tL tR+ = do+        ctrace  $ vcat+                [ text "**  Sub_Equiv"+                , text "    tL: " <> ppr tL+                , text "    tR: " <> ppr tR+                , text "    xL: " <> ppr xL+                , indent 4 $ ppr ctx0+                , empty ]++        return  ( xL+                , Sum.empty kEffect+                , ctx0)+++ -- Sub_Arr+ --   Both sides are arrow types.+ --   Make sure to check the parameter type contravariantly.+ --  | 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 "*>  Sub_Arr"+                , text "    tL: " <> ppr tL+                , text "    tR: " <> ppr tR+                , text "    xL: " <> ppr xL+                , empty ] +        (_, effs1, ctx1) <- makeSub config a ctx0 x0 xL tR1 tL1 err+        tL2'             <- applyContext     ctx1 tL2+        tR2'             <- applyContext     ctx1 tR2+        (_, effs2, ctx2) <- makeSub config a ctx1 x0 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 "*<  Sub_Arr"+                , indent 4 $ ppr ctx0+                , indent 4 $ ppr ctx1+                , indent 4 $ ppr ctx2                 , empty ] -        return (xL, ctx2)+        return  ( xL+                , Sum.union effs1 effs2+                , ctx2) + -- Sub_Run+ --   The left (inferred) type is a suspension, but the right it not.+ --   We run the suspension to get the result value and check if the+ --   result has the expected type. Running the suspension causes some more+ --   effects which we pass pack to the caller.+ --+ | Just    (tEffect, tResult)   <- takeTSusp tL+ , Nothing                      <- takeTSusp tR+ = do   +        ctrace  $ vcat+                [ text "**  Sub_Run"+                , text "    tL:      " <> ppr tL+                , text "    tR:      " <> ppr tR+                , text "    xL:      " <> ppr xL+                , text "    tEffect: " <> ppr tEffect+                , text "    tResult: " <> ppr tResult+                , empty ] - -- SubApp - --   Both sides are type applications.- --   Assumes non-function type constructors are invariant.+        let aRun    = AnTEC tResult tEffect (tBot kClosure) a+        let xL_run  = XCast aRun CastRun xL++        (xL2, eff2, ctx2)+         <- makeSub config a ctx0 x0 xL_run tResult tR err++        let eff = Sum.unions    kEffect+                [ Sum.singleton kEffect tEffect+                , eff2 ]++        return  ( xL2+                , eff+                , ctx2)+++ -- Sub_App+ --   ISSUE #379: Track variance information in type synonyms.+ --   We're treating all non-function types as invariant, so use makeEqT+ --   rather than checking for subsumption.+ --     | 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 "*>  Sub_App"+                , text "    tL: " <> ppr tL+                , text "    tR: " <> ppr tR+                , text "    xL: " <> ppr xL+                , empty ] +        ctx1    <- makeEqT config ctx0 tL1 tR1 err+        tL2'    <- applyContext ctx1 tL2+        tR2'    <- applyContext ctx1 tR2+        ctx2    <- makeEqT config 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 "*<  Sub_App"+                , indent 4 $ ppr ctx0+                , indent 4 $ ppr ctx1+                , indent 4 $ ppr ctx2                 , empty ] -        return (xL, ctx2)+        return  ( xL+                , Sum.empty kEffect+                , ctx2)  - -- SubForall- --   Left side is a forall type.+ -- Sub_ForallL+ --   Left (inferred) type is a forall type.+ --   Apply the expression to a new existential to instantiate it, + --   then check the new instantiated type against the expected one.+ --  | TForall b t1 <- tL- = do   + = do         -- 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, +        ctrace  $ vcat+                [ text "*>  Sub_ForallL"+                , text "    tL:  " <> ppr tL+                , text "    tR:  " <> ppr tR+                , text "    xL:  " <> ppr xL+                , text "    iA:  " <> ppr iA+                , text "    t1': " <> ppr t1'+                , empty ]++        -- Check the new body against the right type,         -- so that the existential we just made is instantiated-        -- to match the right.+        -- to match the right. The new existential is used to constrain the+        -- expected type, so it needs to be in the correct scope.         let (ctx1, pos1) =  markContext ctx0-        let ctx2         =  pushExists  iA ctx1-        (xL1, ctx3)      <- makeSub config a ctx2 xL t1' tR err+        let ctx2         =  pushExistsScope iA (slurpExists tR) ctx1 +        -- 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, effs3, ctx3) +         <- makeSub config a ctx2 x0 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 "*<  Sub_ForallL"+                , text "    tL:  " <> ppr tL+                , text "    tR:  " <> ppr tR+                , text "    xL:  " <> ppr xL+                , 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+                , effs3+                , ctx4) -        return (xL2, ctx4) + -- Sub_ForallR+ --   The right (expected) type is a forall type.+ --   + | TForall bParamR tBodyR  <- tR+ = do+        ctrace  $ vcat+                [ text "*>  Sub_ForallR"+                , text "    tL: " <> ppr tL+                , text "    tR: " <> ppr tR+                , text "    xL: " <> ppr xL+                , empty ] - -- Error+        -- Make a new existential to instantiate the quantified+        -- variable and substitute it into the body.+        let Just uParam = takeSubstBoundOfBind bParamR+        let tA          = TVar uParam+        let tBodyR'     = substituteT bParamR tA tBodyR++        -- Check the new body against the left type,+        -- so that the existential is instantiated+        -- to match the left.+        let (ctx1, pos1)  =  markContext ctx0+        let ctx2          =  pushType bParamR ctx1++        (xL2, eff2, ctx3) <- makeSub config a ctx2 x0 xL tL tBodyR' err++        -- The body of our new type abstraction must be pure.+        when (not $ eff2 == Sum.empty kEffect)+         $ throw $ ErrorLamNotPure a x0 UniverseSpec (TSum eff2)++        tBodyR_ctx3       <- applyContext ctx3 tBodyR'+        let tR'           =  TForall bParamR tBodyR_ctx3+        let aApp          =  AnTEC tR' (tBot kEffect) (tBot kClosure) a+        let xL_abs        =  XLAM aApp bParamR xL2++        -- Pop the existential and constraints above it off the stack.+        let ctx4        = popToPos pos1 ctx3++        ctrace  $ vcat+                [ text "*<  SubForallR"+                , text "    tL:     " <> ppr tL+                , text "    tR:     " <> ppr tR+                , text "    xL:     " <> ppr xL+                , text "    xL_abs: " <> ppr xL_abs+                , empty ]++        return  ( xL_abs+                , Sum.empty kEffect+                , ctx4)+++ -- Sub_Fail+ --   No other rule matched, so this expression is ill-typed.  | otherwise- = do   ctrace  $ vcat-                [ text "DDC.Core.Check.Exp.Inst.makeSub: no match" -                , text "  LEFT:   " <> text (show tL)-                , text "  RIGHT:  " <> text (show tR) ]+ = do   +        ctrace  $ vcat+                [ text "**  Sub_Fail"+                , text "    tL: " <> ppr tL+                , text "    tR: " <> ppr tR+                , empty ]          throw err
DDC/Core/Check/Judge/Type/AppT.hs view
@@ -4,27 +4,23 @@ 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-        let kenv        = tableKindEnv table+checkAppT !table !ctx0 Recon demand+        xx@(XApp aApp xFn (XType aArg tArg))+ = do   +        let config      = tableConfig 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 ctx1 UniverseSpec tArg Recon          -- Determine the type of the result.         --  The function must have a quantified type, which we then instantiate@@ -48,7 +44,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 +60,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 +91,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 +123,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 +132,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,15 +140,14 @@    -- 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-        let kenv        = tableKindEnv table          -- The kind of the argument must match the annotation on the quantifier.         (tArg', kArg, ctx1)-         <- checkTypeM config kenv ctx0 UniverseSpec tArg +         <- checkTypeM config ctx0 UniverseSpec tArg                 (Check (typeOfBind b11))          -- Instantiate the type of the function with the type argument.
DDC/Core/Check/Judge/Type/AppX.hs view
@@ -5,115 +5,144 @@ 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 +              |  equivT (contextEnvT ctx2) tParam 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 +        mode@(Synth isScope)+        demand +        xx@(XApp a xFn xArg)+ = do+        ctrace  $ vcat+                [ text "*>  App Synth"+                , text "    mode    = " <> ppr mode+                , text "    xx      = " <> ppr xx+                , 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 mode 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 isScope+                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 "    mode    = " <> ppr mode+                , 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.+        -> [Exists n]                -- Scope for new unification variables.+        -> 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 isScope+        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"+                , text "    demand = " <> ppr demand+                , text "    scope  = " <> ppr isScope+                , empty ]+         -- New existential for the type of the function parameter.         iA1      <- newExists kData         let tA1  = typeOfExists iA1@@ -126,110 +155,163 @@         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   -        -- Make a new existential for the type of the argument,-        -- and push it onto the context.+ = do+        -- Make a new existential for the type of the argument, and push it+        -- onto the context. The new existential may appear in some other+        -- type constraint, so make sure to add it to the correct scope.         iA         <- newExists (typeOfBind b)-        let tA     = typeOfExists iA-        let ctx1   = pushExists iA ctx0+        let tA     =  typeOfExists iA+        let ctx1   =  pushExistsScope iA isScope ctx0          -- Instantiate the type of the function with the new existential.-        let tBody' = substituteT b tA tBody+        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 +        ctrace  $ vcat+                [ text "*>  App Synth Forall"+                , text "    demand  = " <> ppr demand+                , text "    scope   = " <> ppr isScope+                , text "    xFn     = " <> ppr xFn+                , text "    xArg    = " <> ppr xArg+                , text "    iA      = " <> ppr iA+                , text "    tBody'  = " <> ppr tBody'+                , text "    xResult = " <> ppr xFnTy+                , empty ]++        -- 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 isScope 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 "    demand  = " <> ppr demand+                , text "    scope   = " <> ppr isScope+                , 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"+                , text "    demand  = " <> ppr demand+                , text "    scope   = " <> ppr isScope+                , text "    tFn     = " <> ppr tFn+                , 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 "    demand  = " <> ppr demand+                , text "    scope   = " <> ppr isScope+                , 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 +330,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-         +
DDC/Core/Check/Judge/Type/Base.hs view
@@ -1,62 +1,78 @@ -module DDC.Core.Check.Judge.Type.Base +module DDC.Core.Check.Judge.Type.Base         ( Checker-        , Table (..)+        , Demand (..)+        , Table  (..)         , returnX+        , runForDemand+        , isHoleT+        , checkTypeM+        , checkBindM -        , 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.Judge.EqT+        , module DDC.Core.Check.Judge.Witness         , module DDC.Core.Check.Error+        , module DDC.Core.Check.Base+         , 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.Judge.EqT+import DDC.Core.Check.Judge.Witness import DDC.Core.Check.Error+import DDC.Core.Check.Base+ import DDC.Core.Transform.Reannotate import DDC.Core.Transform.SubstituteTX-import DDC.Core.Annot.AnTEC+import DDC.Core.Exp.Annot.AnTEC +import DDC.Core.Check.Judge.Kind 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++instance Pretty Demand where+ ppr DemandRun  = text "Run"+ ppr DemandNone = text "None"++ -- | 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. --@@ -69,8 +85,6 @@ data Table a n         = Table         { tableConfig           :: Config n-        , tableKindEnv          :: KindEnv n-        , tableTypeEnv          :: TypeEnv n         , tableCheckExp         :: Checker a n         , tableCheckVarCon      :: Checker a n         , tableCheckAppT        :: Checker a n@@ -80,33 +94,106 @@         , 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)+++-------------------------------------------------------------------------------+isHoleT :: Config n -> Type n -> Bool+isHoleT config tt+ = case tt of+        TVar u+         -> case u of+                UName n +                 -> case configNameIsHole config of+                        Nothing -> False +                        Just f  -> f n+                _       -> False++        _ -> isBot tt+++-- | Check the type of a bind.+checkBindM+        :: (Ord n, Show n, Pretty n)+        => Config n     -- ^ Checker configuration.+        -> Context n    -- ^ Type context.+        -> Universe     -- ^ Universe for the type of the bind.+        -> Bind n       -- ^ Check this bind.+        -> Mode n       -- ^ Mode for bidirectional checking.+        -> CheckM a n (Bind n, Type n, Context n)++checkBindM config ctx uni bb mode+ = do   (t', k, ctx')  <- checkTypeM config ctx uni (typeOfBind bb) mode+        return (replaceTypeOfBind t' bb, k, ctx')
DDC/Core/Check/Judge/Type/Case.hs view
@@ -2,16 +2,27 @@ module DDC.Core.Check.Judge.Type.Case         (checkCase) where+import DDC.Core.Check.Judge.Kind+import DDC.Core.Check.Judge.EqT 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+import DDC.Type.Exp.Simple.Equiv+import qualified DDC.Type.Sum           as Sum+import qualified DDC.Core.Env.EnvX      as EnvX+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   +        ctrace  $ vcat+                [ text "*>  Case"+                , text "    xDiscrim: " <> ppr xDiscrim+                , text "    mode:     " <> ppr mode+                , indent 2 $ ppr ctx0+                , empty ]          -- 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,18 +31,27 @@          $ 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  +        -- Reduce to head-normal form so we can see the outer+        -- data type constructor (if there is one).+        let tDiscrim' = crushHeadT (contextEnvT ctx2) tDiscrim++        let dataDefs  = EnvX.envxDataDefs $ contextEnvX ctx2+         -- 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+         <- case takeTyConApps tDiscrim' of              Just (tc, ts)               -- The unit data type.               | TyConSpec TcConUnit         <- tc@@ -40,24 +60,23 @@                -- User defined or imported data types.               | TyConBound (UName nTyCon) _ <- tc-              , Just dataType  <- Map.lookup nTyCon-                               $  dataDefsTypes $ configDataDefs config+              , Just dataType  <- Map.lookup nTyCon $ dataDefsTypes dataDefs               , k              <- kindOfDataType dataType               , takeResultKind k == kData-              -> return ( lookupModeOfDataType nTyCon (configDataDefs config)+              -> return ( lookupModeOfDataType nTyCon dataDefs                         , ts )-                      +               -- Primitive data types.               | TyConBound (UPrim nTyCon _) k <- tc               , takeResultKind k == kData-              -> return ( lookupModeOfDataType nTyCon (configDataDefs config)+              -> return ( lookupModeOfDataType nTyCon dataDefs                         , ts )               _ -> 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,24 +87,24 @@          <- 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')+         -> when (not $ equivT (contextEnvT ctx4) tAlt tAlt')           $ throw $ ErrorCaseAltResultMismatch a xx tAlt tAlt'          -- Check for overlapping alternatives.@@ -94,14 +113,21 @@         -- 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 (contextEnvT ctx4)+                $ TSum $ Sum.unions kEffect+                $ effsDiscrim : effsMatch : effss+         ctrace  $ vcat-                [ text "* Case"-                , text "  modeDiscrim"  <+> ppr modeDiscrim-                , text "  tAlt = "      <+> ppr tAlt+                [ text "*<  Case"+                , text "    modeDiscrim"  <+> ppr modeDiscrim+                , text "    tAlt = "      <+> ppr tAlt                 , indent 2 $ ppr ctx0                 , indent 2 $ ppr ctx1                 , indent 2 $ ppr ctx2@@ -111,21 +137,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 +160,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) @@ -149,28 +174,40 @@         --       This will be done by checkAltsM when we check each individual         --       pattern type against the type of the scrutinee.         let pats     = map patOfAlt alts-        tsPats       <- liftM catMaybes $ mapM (dataTypeOfPat table a) pats+        tsPats       <- liftM catMaybes $ mapM (dataTypeOfPat table ctx 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)+         []+          -> 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  +          , Check tExpect    <- mode+          , Just  iExpect    <- takeExists tExpect+          -> do                 -- existentials for all of the type parameters.-                is        <- mapM  (\_ -> newExists kData) bs+                is        <- mapM  (\b -> newExists (typeOfBind b)) bs                 let ts     = map typeOfExists is+                let ctx'   = foldl (\ctxx i -> pushExistsBefore i iExpect ctxx) ctx is+                let tBody' = substituteTs (zip bs ts) tBody+                return (Check tBody', ctx')+++          | Just (bs, tBody) <- takeTForalls tPat+          -> do+                -- existentials for all of the type parameters.+                is        <- mapM  (\b -> newExists (typeOfBind b)) 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 +215,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 +243,63 @@    -- 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+        ctrace  $ vcat+                [ text "*>  Alt"+                , text "    mode:   " <+> ppr mode+                , indent 4 $ ppr ctx+                , empty ]+         -- 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, +        Just tCtor <- ctorTypeOfPat table ctx 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,         -- 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 (contextEnvT ctx0) 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 +        when (not $ equivT (contextEnvT ctx0) tDiscrim tResult)+         $ throw $ ErrorCaseScrutineeTypeMismatch a xx                         tDiscrim tResult          -- There must be at least as many fields as variables in the pattern.@@ -268,34 +311,27 @@         -- 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+        let bsArg'  = zipWith replaceTypeOfBind tsFields bsArg+        let ctxArg  = pushTypes bsArg' ctx1 -        -- 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.+        let (ctxBody, posArg) = markContext ctxArg+        (xBody', tBody, effsBody, ctxBody')+                <- tableCheckExp table table ctxBody 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+        let ctx_cut     = popToPos posArg ctxBody'          ctrace  $ vcat-                [ text "* Alt"+                [ text "*<  Alt"                 , ppr alt                 , text "  MODE:   " <+> ppr mode                 , text "  tBody': " <+> ppr tBody'@@ -305,26 +341,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,61 +370,65 @@            -> 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 -        -- inferred type for the overal expression.+        -- With bidirectional checking, annotations on fields can refine the+        -- inferred type for the overall expression.         | bidir-        = do    ctx'    <- makeEq (tableConfig table) a ctx tAnnot tActual-                        $  ErrorCaseFieldTypeMismatch a xx tAnnot tActual+        = do    -- Check the type of the annotation.+                let config      = tableConfig table+                (tAnnot', _, ctx2) +                        <- checkTypeM config ctx UniverseSpec tAnnot (Synth []) -                let tField = applyContext ctx' tActual-                return  (tField, ctx')+                ctx3    <- makeEqT (tableConfig table)   ctx2 tAnnot' tActual+                        $  ErrorCaseFieldTypeMismatch  a xx   tAnnot' tActual +                tField  <- applyContext ctx3 tActual+                return  (tField, ctx3)+         -- In Recon mode, if there is an annotation on the field then it needs         -- to exactly match the inferred type of the field.         | not bidir-        , equivT tActual tAnnot+        , equivT (contextEnvT ctx) tActual tAnnot         = 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.+        -> Context n            -- ^ Type checker context         -> a                    -- ^ Annotation for error messages.         -> Pat n                -- ^ Pattern.         -> CheckM a n (Maybe (Type n)) -ctorTypeOfPat table a (PData dc _)+ctorTypeOfPat _table ctx a (PData dc _)  = 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 -                                $ configDataDefs $ tableConfig table+         |  Just ctor   <- Map.lookup n $ dataDefsCtors $ contextDataDefs ctx          -> return $ Just $ typeOfDataCtor ctor           | otherwise          -> throw  $ ErrorUndefinedCtor a $ XCon a dc -ctorTypeOfPat _table _a PDefault+ctorTypeOfPat _table _ctx _a PDefault  = return Nothing  @@ -399,22 +438,23 @@ --   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.+        -> Context n            -- ^ Type Checker context.         -> a                    -- ^ Annotation for error messages.         -> Pat n                -- ^ Pattern.         -> CheckM a n (Maybe (Type n)) -dataTypeOfPat table a pat- = do   mtCtor      <- ctorTypeOfPat table a pat+dataTypeOfPat table ctx a pat+ = do   mtCtor      <- ctorTypeOfPat table ctx a pat          case mtCtor of          Nothing    -> return Nothing          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 +463,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 +512,7 @@  checkAltsExhaustive a xx mode alts  = do   let nsCtorsMatched      = mapMaybe takeCtorNameOfAlt alts-        +         -- Check that alternatives are exhaustive.         case mode of @@ -489,13 +529,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
DDC/Core/Check/Judge/Type/Cast.hs view
@@ -1,32 +1,34 @@  module DDC.Core.Check.Judge.Type.Cast-        (checkCast)+        ( checkCast) where+import DDC.Core.Check.Judge.Kind+import DDC.Core.Check.Judge.EqT 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 ctx0 UniverseSpec eff           $ case mode of                 Recon   -> Recon-                Synth   -> Check kEffect-                Check _ -> Check kEffect+                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,54 +38,27 @@         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          -- Check the witness.-        (w', tW)  <- checkWitnessM config kenv tenv ctx w+        (w', tW)  <- checkWitnessM config ctx w         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 +68,116 @@          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 $ slurpExists tExpected) DemandRun x1 +        let effs_crush +                = Sum.fromList kEffect+                [ crushEffect (contextEnvT ctx0) (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        <- makeEqT config 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         -- 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 (contextEnvT ctx1) (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+    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+                mode 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 +195,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 +216,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.@@ -314,7 +231,8 @@         -> CheckM a n ()  checkEffectSupported _config a xx ctx eff- = case effectSupported eff ctx of+ = case effectSupported ctx eff of         Nothing         -> return ()         Just effBad     -> throw $ ErrorRunNotSupported a xx effBad- ++
DDC/Core/Check/Judge/Type/DaCon.hs view
@@ -6,24 +6,24 @@ import qualified Data.Map       as Map import Prelude                  as L - -- | Check a data constructor, returning its type. checkDaConM         :: (Ord n, Eq n, Show n)         => Config n+        -> Context n            -- ^ Type checker context.         -> Exp a n              -- ^ The full expression for error messages.         -> a                    -- ^ Annotation for error messages.-        -> DaCon n              -- ^ Data constructor to check.+        -> DaCon n (Type n)     -- ^ Data constructor to check.         -> CheckM a n (Type n) -checkDaConM config xx a dc+checkDaConM _config ctx xx a dc  = case dc of     -- Type type of the unit data constructor is baked-in.     DaConUnit      -> 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,@@ -34,11 +34,10 @@     DaConPrim { daConName        = nCtor               , daConType        = t }      -> let  tResult = snd $ takeTFunArgResult $ eraseTForalls t-             defs    = configDataDefs config         in case liftM fst $ takeTyConApps tResult of             Just (TyConBound u _)-                | Just nType         <- takeNameOfBound u-                , Just dataType      <- Map.lookup nType (dataDefsTypes defs)+                | Just nType     <- takeNameOfBound u+                , Just dataType  <- Map.lookup nType $ dataDefsTypes $ contextDataDefs ctx                 -> case dataTypeMode dataType of                     DataModeSmall nsCtors                         | L.elem nCtor nsCtors -> return t@@ -51,7 +50,7 @@     -- Bound data constructors are always algebraic and Small, so there needs     --   to be a data definition that gives the type of the constructor.     DaConBound { daConName = nCtor }-     -> case Map.lookup nCtor (dataDefsCtors $ configDataDefs config) of+     -> case Map.lookup nCtor (dataDefsCtors $ contextDataDefs ctx) of          Just ctor       -> return $ typeOfDataCtor ctor          Nothing         -> throw $ ErrorUndefinedCtor a xx
DDC/Core/Check/Judge/Type/LamT.hs view
@@ -5,21 +5,21 @@ 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  = do   let config      = tableConfig table-        let kenv        = tableKindEnv table         let xx          = XLAM a b1 x2          -- Check the parameter ------------------@@ -30,12 +30,12 @@          -- The parameter must have an explict kind annotation.         let kA  = typeOfBind b1-        when (isBot kA)+        when (isHoleT config kA)          $ throw $ ErrorLAMParamUnannotated a xx          -- Check the kind annotation is well-sorted.         (kA', sA, ctxA)-         <- checkTypeM config kenv ctx0 UniverseKind kA Recon+         <- checkTypeM config ctx0 UniverseKind kA Recon          let b1'         = replaceTypeOfBind kA' b1 @@ -43,19 +43,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) -         <- checkTypeM config kenv ctx5 UniverseSpec t2 Recon-        +        (t2', k2, ctx6)+         <- checkTypeM config 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 +67,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,18 +79,16 @@                 , 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+checkLAM !table !ctx0 a b1 x2 (Synth {})  = do   let config      = tableConfig table-        let kenv        = tableKindEnv table         let xx          = XLAM a b1 x2          -- Check the parameter ------------------@@ -104,15 +100,15 @@         -- 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 isHoleT config kA+             then do                 iA       <- newExists sComp                 let kA'  = typeOfExists iA                 let ctxA = pushExists   iA ctx0                 return (kA', sComp, ctxA)               else-                checkTypeM config kenv ctx0 UniverseKind kA Synth+                checkTypeM config ctx0 UniverseKind kA (Synth [])          let b1'         = replaceTypeOfBind kA' b1 @@ -125,29 +121,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 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,18 +150,16 @@                 , 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))  = do   let config      = tableConfig table-        let kenv        = tableKindEnv table         let xx          = XLAM a b1 x2          -- Check the parameter ------------------@@ -184,19 +176,19 @@         -- 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 (isHoleT config kParam && isHoleT config 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 isHoleT config kExpected               then do-                checkTypeM config kenv ctx0 UniverseKind kParam Synth+                checkTypeM config ctx0 UniverseKind kParam    (Synth [])                else do-                checkTypeM config kenv ctx0 UniverseKind kExpected Synth+                checkTypeM config ctx0 UniverseKind kExpected (Synth [])          let b1' = replaceTypeOfBind kA' b1 @@ -218,34 +210,32 @@                 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.         (t2', _k2, ctx6)-         <- checkTypeM config kenv ctx5 UniverseSpec t2 (Check kData)+         <- checkTypeM config 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-         -- 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 +244,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
DDC/Core/Check/Judge/Type/LamX.hs view
@@ -5,32 +5,34 @@ 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-        let kenv        = tableKindEnv table+ = do+        let config      = tableConfig 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          -- Determine the kind of the parameter.-        (t1', k1, _)    <- checkTypeM config kenv ctx UniverseSpec t1 Recon+        (t1', k1, _)    <- checkTypeM config ctx UniverseSpec t1 Recon         let b1'         = replaceTypeOfBind t1' b1          -- Check the body -----------------------@@ -38,41 +40,47 @@         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 (contextEnvT ctx2) (TSum e2)]+         -- The body of the function must produce data.-        (_, k2, _)      <- checkTypeM config kenv ctx2 UniverseSpec t2 Recon+        (_, k2, _)      <- checkTypeM config 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     -        let kenv        = tableKindEnv table+checkLam !table !a !ctx !b1 !x2 !(Synth {})+ = do+        ctrace  $ vcat+                [ text "*>  Lam SYNTH"+                , text "    in  bind = " <+> ppr b1+                , empty ]++        let config      = tableConfig table         let xx          = XLam a b1 x2          -- Check the parameter ------------------@@ -80,8 +88,8 @@          -- If there isn't an existing annotation then make an existential.         (b1', t1', k1, ctx1)-         <- if isBot t1-             then do +         <- if isHoleT config t1+             then do                 -- There is no annotation at all, so make an existential.                 -- Missing anotations are assumed to have kind Data.                 i1      <- newExists kData@@ -89,84 +97,89 @@                 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.                 --   The parameter must have Data or Witness kind,                 --   which is checked by 'makeFunctionType' below.                 (t1', k1, ctx1)-                        <- checkTypeM config kenv ctx UniverseSpec t1 Synth+                        <- checkTypeM config ctx UniverseSpec t1 (Synth [])                 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 (contextEnvT ctx4) (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 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)+                ctx6    <- makeEqT config ctx5 k1' kData+                        $  ErrorMismatch a     k1' kData xx +                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 +187,156 @@ --   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-        let kenv        = tableKindEnv table+ = do   +        ctrace  $ vcat+                [ text "*>  Lam CHECK"+                , text "    in bind =" <+> ppr b1+                , text "    in type =" <+> ppr tExpected +                , empty ]++        let config      = tableConfig 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 isHoleT config t1+             then                 return  (replaceTypeOfBind tX1 b1, tX1, ctx)              else do-                ctx0    <- makeEq config a ctx t1 tX1 -                        $  ErrorMismatch a t1 tExpected (XLam a b1 x2)+                ctx0    <- makeEqT config 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 (contextEnvT ctx2) (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' <- makeEqT config 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 (contextEnvT ctx2) (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 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, _)      <- checkTypeM config ctx3 UniverseSpec t1' (Synth [])+        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)+                ctx4    <- makeEqT config ctx3 k1' kData+                        $  ErrorMismatch a     k1' kData xx +                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    <- makeEqT config 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 +345,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."
DDC/Core/Check/Judge/Type/Let.hs view
@@ -4,129 +4,151 @@ 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-        let kenv    = tableKindEnv table+ = do   ctrace  $ vcat+                [ text "*>  Let" +                , text "    mode   =" <+> ppr mode +                , text "    demand =" <+> (text $ show demand)+                , empty] +        let config  = tableConfig 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 +                        Synth{} -> True -        +        (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)      -         <- checkTypeM config kenv ctx2 UniverseSpec tBody+        (tBodyChecked, kBody, ctx3)+         <- checkTypeM config 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', _) -         <- checkTypeM config kenv ctx1 UniverseSpec tBind Recon+        (_, kBind', _)+         <- checkTypeM config 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+         $ if equivT (contextEnvT ctx0) (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,95 +159,131 @@          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)-             +             then return (Synth [], ctx0)+              -- Check the type annotation on the binder,              -- expecting the kind to be Data.              else do                 (tAnnot', _kAnnot, ctx1)-                 <- checkTypeM config kenv ctx0 UniverseSpec tAnnot (Check kData)+                 <- checkTypeM config 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 +291,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. @@ -251,20 +309,19 @@                 return (b' : moar, ctx'')          config  = tableConfig  table-        kenv    = tableKindEnv table          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') -                 <- checkBindM config kenv ctx UniverseSpec b Recon+                (b', k, ctx')+                 <- checkBindM config ctx UniverseSpec b Recon                  -- The type on the binder must have kind Data.                 when (not $ isDataKind k)@@ -282,85 +339,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) -                 <- checkBindM config kenv ctx UniverseSpec b (Check kData)+                (b0, _k, ctx1)+                 <- checkBindM config 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+                when (not $ equivT (contextEnvT ctx') (typeOfBind 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 +476,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
DDC/Core/Check/Judge/Type/LetPrivate.hs view
@@ -2,35 +2,48 @@ module DDC.Core.Check.Judge.Type.LetPrivate         (checkLetPrivate) where+import DDC.Core.Check.Judge.Kind+import DDC.Core.Check.Judge.EqT import DDC.Core.Check.Judge.Type.Base-import qualified DDC.Type.Sum   as Sum-import qualified DDC.Type.Env   as Env-import qualified Data.Set       as Set-import Data.List                as L+import qualified DDC.Core.Env.EnvT      as EnvT+import qualified DDC.Type.Sum           as Sum+import qualified DDC.Type.Env           as Env+import qualified Data.Set               as Set+import Data.List                        as L   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)+         $  mapM (\b -> checkBindM config 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 +51,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 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'+        checkWitnessBindsM config a 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 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 +93,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 +108,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  makeEqT config 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,103 +137,36 @@                 -- 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.         -> Context n            -- ^ Context         -> Exp a n              -- ^ The whole expression, for error messages.         -> [Bound n]            -- ^ Region variables bound in the letregion.         -> [Bind n]             -- ^ Other witness bindings in the same set.         -> CheckM a n () -checkWitnessBindsM !config !a !kenv !ctx !xx !uRegions !bsWit+checkWitnessBindsM !config !a !ctx !xx !uRegions !bsWit  = mapM_ checkWitnessBindM  bsWit  where         -- Check if some type variable or constructor is already in the@@ -214,42 +174,40 @@         -- when using the Eval fragment.         inEnv tt          = case tt of-             TVar u'                -                | Env.member u' kenv    -> True-                | memberKind u' ctx     -> True-             -             TCon (TyConBound u' _) -                | Env.member u' kenv    -> True-                | memberKind u' ctx     -> True-             _                          -> False +             TVar u'+                | EnvT.member u' (contextEnvT ctx) -> True+                | memberKind u' ctx                -> True +             TCon (TyConBound u' _)+                | EnvT.member u' (contextEnvT ctx) -> True+                | memberKind u' ctx                -> True+             _                                     -> False +         -- Check the argument of a witness type is for the region we're         -- introducing here.         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 +219,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@@ -293,4 +241,6 @@              -> checkWitnessArg bWit t2              _ -> throw $ ErrorLetRegionWitnessInvalid a xx bWit++
DDC/Core/Check/Judge/Type/Sub.hs view
@@ -3,36 +3,166 @@         (checkSub) where import DDC.Core.Check.Judge.Type.Base+import qualified DDC.Core.Env.EnvT      as EnvT+import qualified DDC.Type.Sum           as Sum+import qualified Data.Map               as Map   -- 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) +                , indent 4 $ ppr ctx0+                , empty ] +        let config      = tableConfig table++        -- Synthesise a type for the expression.+        (xx1, tSynth, effs1, ctx1)+         <- tableCheckExp table table+                ctx0 (Synth $ slurpExists tExpect)+                demand xx0 +         -- Substitute context into synthesised and expected types.-        let tSynth'     = applyContext ctx1 tSynth-        let tExpect'    = applyContext ctx1 tExpect-        -        (xx2, ctx2)     <- makeSub config a -                                ctx1 xx1 tSynth' tExpect'-                        $  ErrorMismatch a  tSynth' tExpect' xx0+        tSynth_ctx1     <- applyContext ctx1 tSynth+        tExpect_ctx1    <- applyContext ctx1 tExpect +        -- If the synthesised type is not quantified,+        -- but the expected one is then instantiate it at some new existentials.+        -- The expected type needs to be an existential so we know where to +        -- insert the new existentials we create into the context.+        (xx_dequant, tDequant, ctx2)+         <- case takeExists tExpect of+                Just iExpect+                 -> dequantify table a ctx1 iExpect xx1 tSynth_ctx1 tExpect_ctx1++                Nothing+                 -> return (xx1, tSynth_ctx1, ctx1)+         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 Check"+                , text "    demand:   " <> (text $ show demand)+                , text "    tExpect:  " <> ppr tExpect_ctx1+                , text "    tSynth:   " <> ppr tSynth_ctx1+                , text "    tDequant: " <> ppr tDequant                 , empty ] +        -- Make the synthesised type a subtype of the expected one.+        (xx2, effs3, ctx3)+         <- makeSub config a ctx2 xx0 xx_dequant tDequant tExpect_ctx1+         $  ErrorMismatch  a tDequant tExpect_ctx1 xx0++        let effs' = Sum.union effs1 effs3++        ctrace  $ vcat+                [ text "*<  Sub"+                , indent 4 $ ppr xx0+                , text "    tExpect:  " <> ppr tExpect+                , text "    tSynth:   " <> ppr tSynth+                , text "    tDequant: " <> ppr tDequant+                , text "    tExpect': " <> ppr tExpect_ctx1+                , text "    tSynth':  " <> ppr tSynth_ctx1+                , indent 4 $ ppr ctx0+                , indent 4 $ ppr ctx1+                , indent 4 $ ppr ctx3+                , empty ]+         returnX a                 (\_ -> xx2)                 tExpect-                eff clo ctx2+                effs' ctx3+++dequantify !_table !aApp ctx0 iBefore xx0 tSynth tExpect + | TCon (TyConExists _n _k)  <- tExpect+ , shouldDequantifyX xx0+ = do   +        (bsParam, tBody)     <- stripQuantifiers ctx0 tSynth+        case bsParam of+         []     -> return (xx0, tSynth, ctx0)+         _      -> addTypeApps aApp ctx0 iBefore xx0 (reverse bsParam) tBody++ | otherwise+ = return (xx0, tSynth, ctx0)+++shouldDequantifyX :: Exp a n -> Bool+shouldDequantifyX xx+ = case xx of+        XLAM{}  -> False+        _       -> True+++-- | Apply the given expression to existentials to instantiate its type.+--+--   The new existentials are inserted into the context just before+--   the given one so that the context scoping works out.+--+addTypeApps +        :: Ord n+        => a                    -- ^ Annotation for new AST nodes.+        -> Context n            -- ^ Current type checker context.+        -> Exists n             -- ^ Add new existentials before this one.+        -> Exp (AnTEC a n) n    -- ^ Expression to add type applications to.+        -> [Bind n]             -- ^ Forall quantifiers.+        -> Type n               -- ^ Body of the forall.+        -> CheckM a n +                ( Exp (AnTEC a n) n+                , Type n+                , Context n)++addTypeApps !_aApp ctx0 _ xx0 [] tBody+ = return (xx0, tBody, ctx0)++addTypeApps !aApp  ctx0 iBefore xx0 (bParam : bsParam) tBody+ = do   +        let kParam = typeOfBind bParam++        (xx1, tBody', ctx1)+         <- addTypeApps aApp ctx0 iBefore xx0 bsParam tBody ++        iArg        <- newExists kParam+        let tArg    =  typeOfExists iArg+        let ctx2    =  pushExistsBefore iArg iBefore ctx1++        let tResult =  substituteT bParam tArg tBody'++        let aApp'   = AnTEC tResult (tBot kEffect) (tBot kClosure) aApp+        let aArg'   = AnTEC kParam  (tBot kEffect) (tBot kClosure) aApp+        let xx2     = XApp aApp' xx1 (XType aArg' tArg)++        return (xx2, tResult, ctx2)+++-- | Strip quantifiers from the front of a type, looking through any type synonyms.+--+--   ISSUE #385: Make type inference work for non trivial type synonyms.+--   If the synonym is higher kinded then we need to reduce the application.+--   trying to strip the TForall.+--+stripQuantifiers +        :: Ord n +        => Context n+        -> Type n +        -> CheckM a n ([Bind n], Type n)++stripQuantifiers ctx tt+ = case tt of+        -- Look through type synonyms.+        TCon (TyConBound (UName n) _)+         | Just tt' <- Map.lookup n +                    $  EnvT.envtEquations $ contextEnvT ctx+         -> stripQuantifiers ctx tt'++        -- Strip quantifier.+        TForall bParam tBody+         -> do  (bsParam, tBody')+                 <- stripQuantifiers ctx tBody+                return (bParam : bsParam, tBody')++        _ ->    return ([], tt)++
DDC/Core/Check/Judge/Type/VarCon.hs view
@@ -5,97 +5,107 @@ import DDC.Core.Check.Judge.Type.DaCon import DDC.Core.Check.Judge.Type.Sub import DDC.Core.Check.Judge.Type.Base-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+import qualified DDC.Core.Env.EnvX      as EnvX+import qualified DDC.Type.Sum           as Sum+import qualified Data.Map               as Map  +------------------------------------------------------------------------------- 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.- | Just t      <- Env.lookup u (tableTypeEnv table)+ | Just t      <- EnvX.lookupX u (contextEnvX 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 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- -- For recon and synthesis we already know what type the constructor- -- should have, so we can use that.- | mode == Recon || mode == Synth +-- Recon or Synth the type of a constructor.+checkVarCon !table !ctx mode@Recon _demand xx@(XCon a dc)   = do   let config      = tableConfig table-        let defs        = configDataDefs config -        -- All data constructors need to have valid type annotations.-        tCtor -         <- case dc of-             DaConUnit   -> return tUnit-             -             DaConPrim{} -> return $ daConType dc+        -- Lookup the type of the constructor from the environment.+        tCtor           <- checkDaConType config ctx a dc -             DaConBound n-              -- Types of algebraic data ctors should be in the defs table.-              |  Just ctor <- Map.lookup n (dataDefsCtors defs)-              -> return $ typeOfDataCtor ctor+        ctrace  $ vcat+                [ text "**  Con"+                , text "    MODE: " <> ppr mode+                , indent 4 $ ppr xx+                , text "    tCon: " <> ppr tCtor+                , indent 4 $ ppr ctx+                , empty ] -              | otherwise-              -> throw  $ ErrorUndefinedCtor a $ XCon a dc+        -- Type of the data constructor.+        returnX a+                (\z -> XCon z dc)+                tCtor+                (Sum.empty kEffect)+                ctx -        -- Check that the constructor is in the data type declarations.-        checkDaConM config xx a dc +-- Check a constructor against an expected type.+checkVarCon !table !ctx (Check tExpect) demand xx@(XCon a _)+ = checkSub table a ctx demand xx tExpect+++-- Synthesise the type of a data constructor.+checkVarCon !table !ctx mode@(Synth {}) _demand xx@(XCon a dc) + = do+        let config      = tableConfig table++        -- All data constructors need to have valid type annotations.+        tCtor           <- checkDaConType config ctx a dc+         ctrace  $ vcat-                [ text "* Con"-                , indent 2 $ ppr xx-                , text "  TYPE:  " <> ppr tCtor-                , indent 2 $ ppr ctx+                [ text "**  Con"+                , text "    MODE: " <> ppr mode+                , indent 4 $ ppr xx+                , text "    tCon: " <> ppr tCtor+                , indent 4 $ ppr ctx                 , empty ]          -- Type of the data constructor.@@ -103,17 +113,32 @@                 (\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 - -- others ----------------------------------------checkVarCon _ _ _ _+checkVarCon _ _ _ _ _  = error "ddc-core.checkVarCon: no match" ++-------------------------------------------------------------------------------+-- | Lookup the type of this data constructor from the context,+--   or throw an error if we can't find it.+checkDaConType config ctx a dc+ = do   -- Check that the constructor is in the data type declarations.+        checkDaConM config ctx (XCon a dc) a dc++        -- Lookup the type of the constructor.+        case dc of+         DaConUnit   -> return tUnit++         DaConPrim{} -> return $ daConType dc++         DaConBound n+          -- Types of algebraic data ctors should be in the defs table.+          |  Just ctor <- Map.lookup n (dataDefsCtors $ contextDataDefs ctx)+          -> return $ typeOfDataCtor ctor++          | otherwise+          -> throw  $ ErrorUndefinedCtor a $ XCon a dc+
DDC/Core/Check/Judge/Type/Witness.hs view
@@ -2,28 +2,25 @@ module DDC.Core.Check.Judge.Type.Witness         (checkWit) where-import DDC.Core.Check.Witness+import DDC.Core.Check.Judge.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          -- Check the witness.-        (w1', t1)       <- checkWitnessM config kenv tenv ctx w1+        (w1', t1)       <- checkWitnessM config ctx w1         let w1TEC = reannotate fromAnT w1'          returnX a                 (\z -> XWitness z w1TEC)                 t1                 (Sum.empty kEffect)-                Set.empty                 ctx -checkWit _ _ _ _+checkWit _ _ _ _ _  = error "ddc-core.checkWit: no match"
+ DDC/Core/Check/Judge/Witness.hs view
@@ -0,0 +1,135 @@+-- | Type checker for witness expressions.+module DDC.Core.Check.Judge.Witness+        ( checkWitness+        , checkWitnessM+        , typeOfWitness+        , typeOfWiCon)+where+import DDC.Core.Exp.Annot.AnT+import DDC.Core.Check.Error+import DDC.Core.Check.Base+import DDC.Core.Check.Judge.Kind+import DDC.Type.Transform.SubstituteT+import qualified DDC.Core.Env.EnvT              as EnvT+import qualified DDC.Core.Check.Context         as Context+import qualified Data.Map.Strict                as Map+++-- 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,+--   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+--   starting environments.+--+checkWitness+        :: (Ord n, Show n, Pretty n)+        => Config  n            -- ^ Type checker configuration.+        -> EnvX n               -- ^ Type checker environment.+        -> Witness a n          -- ^ Witness to check.+        -> Either (Error a n)+                  ( Witness (AnT a n) n+                  , Type n)++checkWitness config env xx+ = let  ctx     = contextOfEnvX env+   in   evalCheck (mempty, 0, 0)+         $ checkWitnessM config ctx xx+++-- | Like `checkWitness`, but check in an empty environment.+--+--   As this function is not given an environment, the types of free variables+--   must be attached directly to the bound occurrences.+--   This attachment is performed by `checkWitness` above.+--+typeOfWitness+        :: (Ord n, Show n, Pretty n)+        => Config n             -- ^ Type checker configuration.+        -> EnvX n               -- ^ Type checker environment.+        -> Witness a n          -- ^ Witness to check.+        -> Either (Error a n) (Type n)++typeOfWitness config env ww+ = case checkWitness config env ww of+        Left  err       -> Left err+        Right (_, t)    -> Right t+++------------------------------------------------------------------------------+-- | Like `checkWitness` but using the `CheckM` monad to manage errors.+checkWitnessM+        :: (Ord n, Show n, Pretty n)+        => Config n             -- ^ Type checker configuration.+        -> Context n            -- ^ Type checker context.+        -> Witness a n          -- ^ Witness to check.+        -> CheckM a n+                ( Witness (AnT a n) n+                , Type n)++checkWitnessM !_config !ctx (WVar a u)+ -- Witness is defined locally.+ | Just t       <- lookupType u ctx+ = return ( WVar (AnT t a) u, t)++ -- Witness is defined globally.+ | UName n      <- u+ , Just t       <- Map.lookup n (EnvT.envtCapabilities (Context.contextEnvT ctx))+ = return ( WVar (AnT t a) u, t)++ | otherwise+ = throw $ ErrorUndefinedVar a u UniverseWitness++checkWitnessM !_config !_ctx (WCon a wc)+ = let  t'       = typeOfWiCon wc+   in   return  ( WCon (AnT t' a) wc+                , t')++-- witness-type application+checkWitnessM !config !ctx ww@(WApp a1 w1 (WType a2 t2))+ = do   (w1', t1)       <- checkWitnessM config ctx w1+        (t2', k2, _)    <- checkTypeM    config ctx UniverseSpec t2 Recon+        case t1 of+         TForall b11 t12+          |  typeOfBind b11 == k2+          -> let t'     = substituteT b11 t2' t12+             in  return ( WApp (AnT t' a1) w1' (WType (AnT k2 a2) t2')+                        , t')++          | otherwise   -> throw $ ErrorWAppMismatch a1 ww (typeOfBind b11) k2+         _              -> throw $ ErrorWAppNotCtor  a1 ww t1 t2'++-- witness-witness application+checkWitnessM !config !ctx ww@(WApp a w1 w2)+ = do   (w1', t1)       <- checkWitnessM config ctx w1+        (w2', t2)       <- checkWitnessM config ctx w2+        case t1 of+         TApp (TApp (TCon (TyConWitness TwConImpl)) t11) t12+          |  t11 == t2+          -> return ( WApp (AnT t12 a) w1' w2'+                    , t12)++          | otherwise   -> throw $ ErrorWAppMismatch a ww t11 t2+         _              -> throw $ ErrorWAppNotCtor  a ww t1 t2++-- embedded types+checkWitnessM !config !ctx (WType a t)+ = do   (t', k, _)  <- checkTypeM config 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+    WiConBound _ t  -> t+
− DDC/Core/Check/Module.hs 
@@ -1,346 +0,0 @@--module DDC.Core.Check.Module-        ( checkModule-        , checkModuleM)-where-import DDC.Core.Check.Base      (checkTypeM)-import DDC.Core.Check.Exp-import DDC.Core.Check.Error-import DDC.Core.Transform.Reannotate-import DDC.Core.Transform.MapT-import DDC.Core.Module-import DDC.Core.Exp-import DDC.Type.Check.Context-import DDC.Type.Check.Data-import DDC.Type.Compounds-import DDC.Type.Predicates-import DDC.Type.DataDef-import DDC.Type.Equiv-import DDC.Type.Universe-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----- Wrappers ------------------------------------------------------------------------------------------ | Type check a module.------   If it's good, you get a new version with types attached to all the bound---   variables------   If it's bad, you get a description of the error.-checkModule-        :: (Ord n, Show n, Pretty n)-        => Config n             -- ^ Static configuration.-        -> Module a n           -- ^ Module to check.-        -> Mode n               -- ^ Type checker mode.-        -> ( Either (Error a n) (Module (AnTEC a n) n)-           , CheckTrace )--checkModule !config !xx !mode- = let  (s, result)     = runCheck (mempty, 0, 0)-                        $ checkModuleM config -                                (configPrimKinds config)-                                (configPrimTypes config)-                                xx mode-        (tr, _, _)      = s-   in   (result, tr)----- checkModule --------------------------------------------------------------------------------------- | Like `checkModule` but using the `CheckM` monad to handle errors.-checkModuleM -        :: (Ord n, Show n, Pretty n)-        => Config n             -- ^ Static configuration.-        -> KindEnv n            -- ^ Starting kind environment.-        -> TypeEnv n            -- ^ Starting type environment.-        -> Module a n           -- ^ Module to check.-        -> Mode n               -- ^ Type checker mode.-        -> CheckM a n (Module (AnTEC a n) n)--checkModuleM !config !kenv !tenv mm@ModuleCore{} !mode- = do   -        -- Check kinds of imported types -------------------        nksImport'      <- 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 types of imported values ------------------        ntsImport'      <- checkImportValues config kenv' mode -                        $  moduleImportValues mm-        -        -- Build the initial type environment.-        let tenv'       = Env.union tenv -                        $ Env.fromList  [ BName n (typeOfImportSource isrc)-                                                | (n, isrc) <- ntsImport' ]---        -- Check the sigs of exported types ----------------        esrcsType'      <- checkExportTypes config        -                        $ 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'--        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--        -- 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 x'' = reannotate applyToAnnot -                $ mapT (applySolved ctx) x'---        -- Check that each exported signature matches the type of its binding.-        envDef  <- checkModuleBinds (moduleExportTypes mm) (moduleExportValues mm) x''--        -- Check that all exported bindings are defined by the module.-        mapM_ (checkBindDefined envDef) -                $ map fst $ moduleExportValues mm--        -- If exported names are missing types then fill them in.-        let tsTop       = moduleTopBindTypes mm--        let updateExportSource e-                | ExportSourceLocalNoType n <- e-                , Just t  <- Map.lookup n tsTop   -                = 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'' }--        return mm'--------------------------------------------------------------------------------------------------------- | Check exported types.-checkExportTypes-        :: (Show n, Pretty n, Ord n)-        => Config n-        -> [(n, ExportSource n)]-        -> CheckM a n [(n, ExportSource n)]--checkExportTypes config nesrcs- = let  check (n, esrc)-         | Just k          <- takeTypeOfExportSource esrc-         = do   (k', _, _) <- checkTypeM config Env.empty emptyContext UniverseKind k Recon-                return  $ (n, mapTypeOfExportSource (const k') esrc)--         | otherwise-         = return (n, esrc)-   in do-        -- Check for duplicate exports.-        let dups = findDuplicates $ map fst nesrcs-        (case takeHead dups of-          Just n -> throw $ ErrorExportDuplicate n-          _      -> return ())-        --        -- Check the kinds of the export specs.-        mapM check nesrcs- -------------------------------------------------------------------------------------------------------- | Check exported types.-checkExportValues-        :: (Show n, Pretty n, Ord n)-        => Config n -> KindEnv n-        -> [(n, ExportSource n)]-        -> CheckM a n [(n, ExportSource n)]--checkExportValues config kenv nesrcs- = let  check (n, esrc)-         | Just t          <- takeTypeOfExportSource esrc-         = do   (t', _, _) <- checkTypeM config kenv emptyContext UniverseSpec t Recon-                return  $ (n, mapTypeOfExportSource (const t') esrc)--         | otherwise-         = return (n, esrc)--   in do-        -- Check for duplicate exports.-        let dups = findDuplicates $ map fst nesrcs-        (case takeHead dups of-          Just n -> throw $ ErrorExportDuplicate n-          _      -> return ())--        -- Check the types of the exported values.-        mapM check nesrcs--------------------------------------------------------------------------------------------------------- | Check kinds of imported types.-checkImportTypes-        :: (Ord n, Show n, Pretty n)-        => Config n -> Mode n-        -> [(n, ImportSource n)]-        -> CheckM a n [(n, ImportSource n)]--checkImportTypes config mode nisrcs- = let  -        -- Checker mode to use.-        modeCheckImportTypes-         = case mode of-                Recon   -> Recon-                _       -> Synth--        check (n, isrc)-         = do   let k           =  typeOfImportSource isrc-                (k', _, _)      <- checkTypeM config Env.empty emptyContext UniverseKind-                                        k modeCheckImportTypes-                return  (n, mapTypeOfImportSource (const k') isrc)-   in do-        -- Check for duplicate imports.-        let dups = findDuplicates $ map fst nisrcs-        (case takeHead dups of-          Just n -> throw $ ErrorImportDuplicate n-          _      -> return ())--        mapM check 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)]--checkImportValues config kenv mode nisrcs- = let-        -- Checker mode to use.-        modeCheckImportTypes-         = case mode of-                Recon   -> Recon-                _       -> Check kData--        check (n, isrc)-         = do   let t           = typeOfImportSource 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.-                when (not $ isDataKind k)-                 $ throw $ ErrorImportValueNotData n--                return  (n, mapTypeOfImportSource (const t') isrc)-   in do-        -- Check for duplicate imports.-        let dups = findDuplicates $ map fst nisrcs-        (case takeHead dups of-          Just n -> throw $ ErrorImportDuplicate n-          _      -> return ())--        mapM check nisrcs        --------------------------------------------------------------------------------------------------------- | Check that the exported signatures match the types of their bindings.-checkModuleBinds -        :: Ord n-        => [(n, ExportSource n)]        -- ^ Exported types.-        -> [(n, ExportSource n)]        -- ^ Exported values-        -> Exp (AnTEC a n) n-        -> CheckM a n (TypeEnv n)       -- ^ Environment of top-level bindings-                                        --   defined by the module--checkModuleBinds !ksExports !tsExports !xx- = case xx of-        XLet _ (LLet b _) x2     -         -> do  checkModuleBind  ksExports tsExports b-                env     <- checkModuleBinds ksExports tsExports x2-                return  $ Env.extend b env--        XLet _ (LRec bxs) x2-         -> do  mapM_ (checkModuleBind ksExports tsExports) $ map fst bxs-                env     <- checkModuleBinds ksExports tsExports x2-                return  $ Env.extends (map fst bxs) env--        XLet _ (LPrivate _ _ _) x2-         ->     checkModuleBinds ksExports tsExports x2--        _ ->    return Env.empty----- | If some bind is exported, then check that it matches the exported version.-checkModuleBind -        :: Ord n-        => [(n, ExportSource n)]        -- ^ Exported types.-        -> [(n, ExportSource n)]        -- ^ Exported values.-        -> Bind n-        -> CheckM a n ()--checkModuleBind !_ksExports !tsExports !b- | BName n tDef <- b- = case join $ liftM takeTypeOfExportSource $ lookup n tsExports of-        Nothing                 -> return ()-        Just tExport -         | equivT tDef tExport  -> return ()-         | otherwise            -> throw $ ErrorExportMismatch n tExport tDef-- -- 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 -        :: Ord n-        => TypeEnv n                    -- ^ Types defined by the module.-        -> n                            -- ^ Name of an exported binding.-        -> CheckM a n ()--checkBindDefined env n- = case Env.lookup (UName n) env of-        Just _  -> return ()-        _       -> throw $ ErrorExportUndefined n-
− DDC/Core/Check/TaggedClosure.hs 
@@ -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
− DDC/Core/Check/Witness.hs 
@@ -1,169 +0,0 @@--- | Type checker for witness expressions.-module DDC.Core.Check.Witness-        ( checkWitness-        , checkWitnessM-        , typeOfWitness-        , typeOfWiCon-        , typeOfWbCon)-where-import DDC.Core.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, ---   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 ---   starting environments.----checkWitness-        :: (Ord n, Show n, Pretty n)-        => Config n             -- ^ Static configuration.-        -> KindEnv n            -- ^ Starting Kind Environment.-        -> TypeEnv n            -- ^ Strating Type Environment.-        -> Witness a n          -- ^ Witness to check.-        -> Either (Error a n) -                  ( Witness (AnT a n) n-                  , Type n)--checkWitness config kenv tenv xx-        = evalCheck (mempty, 0, 0)-        $ checkWitnessM config kenv tenv emptyContext xx----- | Like `checkWitness`, but check in an empty environment.------   As this function is not given an environment, the types of free variables---   must be attached directly to the bound occurrences.---   This attachment is performed by `checkWitness` above.----typeOfWitness -        :: (Ord n, Show n, Pretty n) -        => Config n-        -> Witness a n -        -> Either (Error a n) (Type n)--typeOfWitness config ww - = case checkWitness config Env.empty Env.empty ww of-        Left  err       -> Left err-        Right (_, t)    -> Right t------------------------------------------------------------------------------------ | Like `checkWitness` but using the `CheckM` monad to manage errors.-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 -                ( Witness (AnT a n) n-                , Type n)--checkWitnessM !_config !_kenv !tenv !ctx (WVar a u)- -- Witness is defined locally.- | Just t       <- lookupType u ctx- = return ( WVar (AnT t a) u, t)-- -- Witness is defined globally.- | 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-        (t2', k2, _)    <- checkTypeM     config kenv ctx UniverseSpec t2 Recon-        case t1 of-         TForall b11 t12-          |  typeOfBind b11 == k2-          -> let t'     = substituteT b11 t2' t12-             in  return ( WApp (AnT t' a1) w1' (WType (AnT k2 a2) t2')-                        , t')--          | otherwise   -> throw $ ErrorWAppMismatch a1 ww (typeOfBind b11) k2-         _              -> throw $ ErrorWAppNotCtor  a1 ww t1 t2'---- witness-witness application-checkWitnessM !config !kenv !tenv !ctx ww@(WApp a w1 w2)- = do   (w1', t1)       <- checkWitnessM config kenv tenv ctx w1-        (w2', t2)       <- checkWitnessM config kenv tenv ctx w2-        case t1 of-         TApp (TApp (TCon (TyConWitness TwConImpl)) t11) t12-          |  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)-
DDC/Core/Collect.hs view
@@ -2,18 +2,24 @@ -- | Collecting sets of variables and constructors. module DDC.Core.Collect         ( -- * Free Variables-          freeT+          freeT,        freeVarsT         , freeX            -- * Bounds and Binds         , collectBound         , collectBinds +          -- * Abstract Binding Structures+        , BindTree      (..)+        , BindWay       (..)+        , BoundLevel    (..)+        , BindStruct    (..)+           -- * Support         , Support       (..)         , SupportX      (..)) where-import DDC.Core.Collect.Free-import DDC.Core.Collect.Free.Simple     ()+import DDC.Core.Collect.FreeX+import DDC.Core.Collect.FreeT+import DDC.Core.Collect.BindStruct import DDC.Core.Collect.Support-import DDC.Type.Collect
+ DDC/Core/Collect/BindStruct.hs view
@@ -0,0 +1,176 @@++-- | Collecting sets of variables and constructors.+module DDC.Core.Collect.BindStruct+        ( BindTree   (..)+        , BindWay    (..)+        , BoundLevel (..)+        , BindStruct (..)+        , isBoundExpWit+        , boundLevelOfBindWay+        , bindDefT++        , freeT+        , freeOfTreeT++        , collectBound+        , collectBinds)+where+import DDC.Type.Exp+import DDC.Type.Env                     (Env)+import qualified DDC.Type.Env           as Env+import qualified Data.Set               as Set+import Data.Set                         (Set)+++-------------------------------------------------------------------------------+-- | A description of the binding structure of some type or expression.+data BindTree n+        -- | An abstract binding expression.+        = BindDef BindWay    [Bind n] [BindTree n]++        -- | Use of a variable.+        | BindUse BoundLevel (Bound n)++        -- | Use of a constructor.+        | BindCon BoundLevel (Bound n) (Maybe (Kind n))+        deriving (Eq, Show)+++-- | Describes how a variable was bound.+data BindWay+        = BindTAbs+        | BindForall+        | BindLAM+        | BindLam+        | BindLet+        | BindLetRec+        | BindLetRegions+        | BindLetRegionWith+        | BindCasePat+        deriving (Eq, Show)+++-- | What level this binder is at.+data BoundLevel+        = BoundSpec+        | BoundExp+        | BoundWit+        deriving (Eq, Show)+++-- | Check if a boundlevel is expression or witness+isBoundExpWit :: BoundLevel -> Bool+isBoundExpWit BoundExp = True+isBoundExpWit BoundWit = True+isBoundExpWit _        = False+++-- | Get the `BoundLevel` corresponding to a `BindWay`.+boundLevelOfBindWay :: BindWay -> BoundLevel+boundLevelOfBindWay way+ = case way of+        BindTAbs                -> BoundSpec+        BindForall              -> BoundSpec+        BindLAM                 -> BoundSpec+        BindLam                 -> BoundExp+        BindLet                 -> BoundExp+        BindLetRec              -> BoundExp+        BindLetRegions          -> BoundSpec+        BindLetRegionWith       -> BoundExp+        BindCasePat             -> BoundExp+++-- BindStruct -----------------------------------------------------------------+class BindStruct c n | c -> n where+ slurpBindTree :: c -> [BindTree n]+++-- | Helper for constructing the `BindTree` for a type binder.+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++        _ -> []++
− DDC/Core/Collect/Free.hs 
@@ -1,125 +0,0 @@--- | Collecting sets of variables and constructors.-module DDC.Core.Collect.Free-        ( freeX-        , bindDefX)-where-import DDC.Type.Collect-import DDC.Type.Compounds-import DDC.Core.Module-import DDC.Core.Exp-import DDC.Type.Env                     (Env)-import qualified DDC.Type.Env           as Env-import qualified Data.Set               as Set-import Data.Set                         (Set)-import Data.Maybe-import Control.Monad----- 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 tenv xx = Set.unions $ map (freeOfTreeX tenv) $ slurpBindTree xx--freeOfTreeX :: Ord n => Env n -> BindTree n -> Set (Bound n)-freeOfTreeX tenv tt- = {-# SCC freeOfTreeX #-}-   case tt of-        BindDef way bs ts-         |  isBoundExpWit $ boundLevelOfBindWay way-         ,  tenv'        <- Env.extends bs tenv-         -> Set.unions $ map (freeOfTreeX tenv') ts--        BindDef _ _ ts-         -> Set.unions $ map (freeOfTreeX  tenv) ts--        BindUse bl u-         | isBoundExpWit bl-         , Env.member u tenv -> Set.empty-         | isBoundExpWit bl  -> Set.singleton u-        _                    -> Set.empty----- Module ----------------------------------------------------------------------instance BindStruct (Module a) where- slurpBindTree mm-        = slurpBindTree $ moduleBody mm----- Exp -------------------------------------------------------------------------instance BindStruct (Exp a) where- slurpBindTree xx-  = case xx of-        XVar _ u-         -> [BindUse BoundExp u]--        XCon _ dc-         -> case dc of-                DaConBound n    -> [BindCon BoundExp (UName n) Nothing]-                _               -> []--        XApp _ x1 x2            -> slurpBindTree x1 ++ slurpBindTree x2-        XLAM _ b x              -> [bindDefT BindLAM [b] [x]]-        XLam _ 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 $ liftM slurpBindTree $ maybeToList mT)-         ++ [ 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- 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- slurpBindTree alt-  = case alt of-        AAlt PDefault x-         -> slurpBindTree x--        AAlt (PData _ bs) x-         -> [bindDefX BindCasePat bs [x]]---instance BindStruct (Witness a) 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 way bs xs-        = BindDef way bs-        $   concatMap (slurpBindTree . typeOfBind) bs-        ++  concatMap slurpBindTree xs
− DDC/Core/Collect/Free/Simple.hs 
@@ -1,83 +0,0 @@--- | Collecting sets of variables and constructors.-module DDC.Core.Collect.Free.Simple-        ()-where-import DDC.Type.Collect-import DDC.Core.Collect.Free-import DDC.Core.Exp.Simple----- Exp -------------------------------------------------------------------------instance BindStruct (Exp a) where- slurpBindTree xx-  = case xx of-        XAnnot _ x-         -> slurpBindTree x-        XVar u-         -> [BindUse BoundExp u]--        XCon dc-         -> case dc of-                DaConBound n    -> [BindCon BoundExp (UName n) Nothing]-                _               -> []--        XApp x1 x2              -> slurpBindTree x1 ++ slurpBindTree x2-        XLAM b x                -> [bindDefT BindLAM [b] [x]]-        XLam 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 bsR mtExtend bs) x2                         -         -> (case mtExtend of-                Nothing -> []-                Just tR -> slurpBindTree tR)-         ++ [ 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- 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- slurpBindTree alt-  = case alt of-        AAlt PDefault x-         -> slurpBindTree x--        AAlt (PData _ bs) x-         -> [bindDefX BindCasePat bs [x]]---instance BindStruct (Witness a) 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-
+ DDC/Core/Collect/FreeT.hs view
@@ -0,0 +1,79 @@++module DDC.Core.Collect.FreeT+        ( FreeVarConT(..)+        , freeVarsT)+where+import DDC.Core.Collect.BindStruct+import DDC.Type.Exp+import DDC.Type.Env             (KindEnv)+import Data.Set                 (Set)+import qualified DDC.Type.Env   as Env+import qualified DDC.Type.Sum   as Sum+import qualified Data.Set       as Set+++-- | Collect the free type variables in a type.+freeVarsT +        :: Ord n+        => KindEnv n -> Type n+        -> Set (Bound n)+freeVarsT kenv tt+ = fst $ freeVarConT kenv tt+++instance BindStruct (Type n) n where+ slurpBindTree tt+  = case tt of+        TVar u          -> [BindUse BoundSpec u]+        TCon tc         -> slurpBindTree tc+        TAbs b t        -> [bindDefT BindTAbs   [b] [t]]+        TApp t1 t2      -> slurpBindTree t1 ++ slurpBindTree t2+        TForall b t     -> [bindDefT BindForall [b] [t]]+        TSum ts         -> concatMap slurpBindTree $ Sum.toList ts+++instance BindStruct (TyCon n) n where+ slurpBindTree tc+  = case tc of+        TyConBound u k  -> [BindCon BoundSpec u (Just k)]+        _               -> []+++class FreeVarConT (c :: * -> *) where+  -- | Collect the free type variables and constructors used in a thing.+  freeVarConT +        :: Ord n +        => KindEnv n -> c n +        -> (Set (Bound n), Set (Bound n))+++instance FreeVarConT Type where+ freeVarConT kenv tt+  = case tt of+        TVar u  +         -> if Env.member u kenv+                then (Set.empty, Set.empty)+                else (Set.singleton u, Set.empty)++        TCon tc+         | TyConBound u _ <- tc -> (Set.empty, Set.singleton u)+         | otherwise            -> (Set.empty, Set.empty)++        TAbs b t+         -> freeVarConT (Env.extend b kenv) t++        TApp t1 t2+         -> let (vs1, cs1)      = freeVarConT kenv t1+                (vs2, cs2)      = freeVarConT kenv t2+            in  ( Set.union vs1 vs2+                , Set.union cs1 cs2)++        TForall b t+         -> freeVarConT (Env.extend b kenv) t++        TSum ts+         -> let (vss, css)      = unzip $ map (freeVarConT kenv) +                                $ Sum.toList ts+            in  (Set.unions vss, Set.unions css)++
+ DDC/Core/Collect/FreeX.hs view
@@ -0,0 +1,120 @@+-- | Collecting sets of variables and constructors.+module DDC.Core.Collect.FreeX+        ( freeX+        , bindDefX)+where+import DDC.Type.Exp.Simple+import DDC.Core.Collect.BindStruct+import DDC.Core.Collect.FreeT           ()+import DDC.Core.Module+import DDC.Core.Exp+import DDC.Type.Env                     (Env)+import qualified DDC.Type.Env           as Env+import qualified Data.Set               as Set+import Data.Set                         (Set)+import Data.Maybe+import Control.Monad+++-- freeX ----------------------------------------------------------------------+-- | Collect the free Data and Witness variables in a thing (level-0).+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)+freeOfTreeX tenv tt+ = {-# SCC freeOfTreeX #-}+   case tt of+        BindDef way bs ts+         |  isBoundExpWit $ boundLevelOfBindWay way+         ,  tenv'        <- Env.extends bs tenv+         -> Set.unions $ map (freeOfTreeX tenv') ts++        BindDef _ _ ts+         -> Set.unions $ map (freeOfTreeX  tenv) ts++        BindUse bl u+         | isBoundExpWit bl+         , Env.member u tenv -> Set.empty+         | isBoundExpWit bl  -> Set.singleton u+        _                    -> Set.empty+++-- Module ---------------------------------------------------------------------+instance BindStruct (Module a n) n where+ slurpBindTree mm+        = slurpBindTree $ moduleBody mm+++-- Exp ------------------------------------------------------------------------+instance BindStruct (Exp a n) n where+ slurpBindTree xx+  = case xx of+        XVar _ u+         -> [BindUse BoundExp u]++        XCon _ dc+         -> case dc of+                DaConBound n    -> [BindCon BoundExp (UName n) Nothing]+                _               -> []++        XApp _ x1 x2            -> slurpBindTree x1 ++ slurpBindTree x2+        XLAM _ b x              -> [bindDefT BindLAM [b] [x]]+        XLam _ 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 $ liftM 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+        XType _ t       -> slurpBindTree t+        XWitness _ w    -> slurpBindTree w+++instance BindStruct (Cast a n) n where+ slurpBindTree cc+  = case cc of+        CastWeakenEffect  eff   -> slurpBindTree eff+        CastPurify w            -> slurpBindTree w+        CastBox                 -> []+        CastRun                 -> []+++instance BindStruct (Alt a n) n where+ slurpBindTree alt+  = case alt of+        AAlt PDefault x+         -> slurpBindTree x++        AAlt (PData _ bs) x+         -> [bindDefX BindCasePat bs [x]]+++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+        WType _ t       -> slurpBindTree t+++-- | Helper for constructing the `BindTree` for an expression or witness binder.+bindDefX :: BindStruct c n+         => BindWay -> [Bind n] -> [c] -> BindTree n+bindDefX way bs xs+        = BindDef way bs+        $   concatMap (slurpBindTree . typeOfBind) bs+        ++  concatMap slurpBindTree xs
DDC/Core/Collect/Support.hs view
@@ -1,19 +1,20 @@  module DDC.Core.Collect.Support         ( Support       (..)-        , SupportX      (..))+        , SupportX      (..)+        , supportEnvFlags) where-import DDC.Core.Compounds-import DDC.Core.Exp-import DDC.Type.Collect.FreeT+import DDC.Core.Module+import DDC.Core.Exp.Annot+import DDC.Core.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+
− DDC/Core/Compounds.hs 
@@ -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-
− DDC/Core/Compounds/Annot.hs 
@@ -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
− DDC/Core/Compounds/Simple.hs 
@@ -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
+ DDC/Core/Env/EnvT.hs view
@@ -0,0 +1,219 @@++-- | Environment of a type expression.+--+--   An environment contains the types +--     named bound variables,+--     named primitives, +--     and a deBruijn stack for anonymous variables.+--+module DDC.Core.Env.EnvT+        ( EnvT(..)++        -- * Construction+        , empty+        , singleton+        , extend,       extends+        , union,        unions++        -- * Conversion+        , fromList+        , fromListNT+        , fromTypeMap++        , kindEnvOfEnvT ++        -- * Projections +        , depth+        , member,       memberBind+        , lookup,       lookupName++        -- * Primitives+        , setPrimFun+        , isPrim++        -- * Lifting+        , lift)+where+import DDC.Type.Exp+import DDC.Type.Transform.BoundT+import Data.Maybe+import Data.Map                         (Map)+import Prelude                          hiding (lookup)+import qualified DDC.Type.Env           as Env+import qualified Data.Map.Strict        as Map+import qualified Prelude                as P+import Control.Monad+++-- | A type environment.+data EnvT n+        = EnvT+        { -- | Types of baked in, primitive names.+          envtPrimFun      :: !(n -> Maybe (Type n))++          -- | Map of constructor name to bound type for type equations.+        , envtEquations    :: !(Map n (Type n))++          -- | Map of globally available capabilities.+        , envtCapabilities :: !(Map n (Type n))++          -- | Kinds of named variables and constructors.+        , envtMap          :: !(Map n (Type n))++          -- | Types of anonymous deBruijn variables.+        , envtStack        :: ![Type n] +        +          -- | The length of the above stack.+        , envtStackLength  :: !Int }+++-- | An empty environment.+empty :: EnvT n+empty   = EnvT+        { envtPrimFun      = \_ -> Nothing +        , envtEquations    = Map.empty+        , envtCapabilities = Map.empty+        , envtMap          = Map.empty+        , envtStack        = [] +        , envtStackLength  = 0 }+++-- | Construct a singleton type environment.+singleton :: Ord n => Bind n -> EnvT n+singleton b+        = extend b empty+++-- | Extend an environment with a new binding.+--   Replaces bindings with the same name already in the environment.+extend :: Ord n => Bind n -> EnvT n -> EnvT n+extend bb env+ = case bb of+         BName n k -> env { envtMap         = Map.insert n k (envtMap env) }+         BAnon   k -> env { envtStack       = k : envtStack env +                          , envtStackLength = envtStackLength env + 1 }+         BNone{}   -> env+++-- | Extend an environment with a list of new bindings.+--   Replaces bindings with the same name already in the environment.+extends :: Ord n => [Bind n] -> EnvT n -> EnvT n+extends bs env+        = foldl (flip extend) env bs+++-- | Set the function that knows the types of primitive things.+setPrimFun :: (n -> Maybe (Type n)) -> EnvT n -> EnvT n+setPrimFun f env+        = env { envtPrimFun = f }+++-- | Check if the type of a name is defined by the `envPrimFun`.+isPrim :: EnvT n -> n -> Bool+isPrim env n+        = isJust $ envtPrimFun env n+++-- | Convert a list of `Bind`s to an environment.+fromList :: Ord n => [Bind n] -> EnvT n+fromList bs+        = foldr extend empty bs+++-- | Convert a list of name and types into an environment+fromListNT :: Ord n => [(n, Type n)] -> EnvT n+fromListNT nts+ = fromList [BName n t | (n, t) <- nts]+++-- | Convert a map of names to types to a environment.+fromTypeMap :: Map n (Type n) -> EnvT n+fromTypeMap m+        = empty { envtMap = m}+++-- | Extract a `KindEnv` from an `EnvT`.+kindEnvOfEnvT :: Ord n => EnvT n -> Env.KindEnv n+kindEnvOfEnvT env+        = Env.empty+        { Env.envMap       = envtMap env+        , Env.envPrimFun   = \n -> envtPrimFun env n }+++-- | Combine two environments.+--   If both environments have a binding with the same name,+--   then the one in the second environment takes preference.+union :: Ord n => EnvT n -> EnvT n -> EnvT n+union env1 env2+        = EnvT       +        { envtMap          = envtMap          env1 `Map.union` envtMap          env2+        , envtStack        = envtStack        env2  ++ envtStack                env1+        , envtStackLength  = envtStackLength  env2  +  envtStackLength          env1+        , envtEquations    = envtEquations    env1 `Map.union` envtEquations    env2+        , envtCapabilities = envtCapabilities env1 `Map.union` envtCapabilities env2+        , envtPrimFun      = \n -> envtPrimFun env2 n `mplus` envtPrimFun env1 n }+++-- | Combine multiple environments,+--   with the latter ones taking preference.+unions :: Ord n => [EnvT n] -> EnvT n+unions envs+        = foldr union empty envs+++-- | Check whether a bound variable is present in an environment.+member :: Ord n => Bound n -> EnvT n -> Bool+member uu env+        = isJust $ lookup uu env+++-- | Check whether a binder is already present in the an environment.+--   This can only return True for named binders, not anonymous or primitive ones.+memberBind :: Ord n => Bind n -> EnvT n -> Bool+memberBind uu env+ = case uu of+        BName n _ -> Map.member n (envtMap env)+        _         -> False+++-- | Lookup a bound variable from an environment.+lookup :: Ord n => Bound n -> EnvT n -> Maybe (Type n)+lookup uu env+ = case uu of+        UName n +         ->      Map.lookup n (envtMap env) +         `mplus` envtPrimFun env n++        UIx i     -> P.lookup i (zip [0..] (envtStack env))+        UPrim n _ -> envtPrimFun env n+++-- | Lookup a bound name from an environment.+lookupName :: Ord n => n -> EnvT n -> Maybe (Type n)+lookupName n env+          = Map.lookup n (envtMap env)+++-- | Yield the total depth of the deBruijn stack.+depth :: EnvT n -> Int+depth env = envtStackLength env+++-- | Lift all free deBruijn indices in the environment by the given number of steps.+---+--  ISSUE #276: Delay lifting of indices in type environments.+--      The 'lift' function on type environments applies to every member of+--      the environment. We'd get better complexity by recording how many+--      levels all types should be lifted by, and only applying the real lift+--      function when the type is finally extracted.+--+lift :: Ord n => Int -> EnvT n -> EnvT n+lift n env+        = EnvT+        { envtMap          = Map.map (liftT n) (envtMap env)+        , envtStack        = map (liftT n) (envtStack env)+        , envtStackLength  = envtStackLength  env+        , envtEquations    = envtEquations    env+        , envtCapabilities = envtCapabilities env+        , envtPrimFun      = envtPrimFun      env }+
+ DDC/Core/Env/EnvX.hs view
@@ -0,0 +1,271 @@++-- | Environment of a type expression.+--+--   An environment contains the types +--     named bound variables,+--     named primitives, +--     and a deBruijn stack for anonymous variables.+--+module DDC.Core.Env.EnvX+        ( EnvX(..), EnvT.EnvT(..)++        -- * Construction+        , empty,        fromPrimEnvs+        , singleton+        , extendX,      extendsX+        , extendT,      extendsT+        , union,        unions++        -- * Conversion+        , fromList+        , fromListNT+        , fromTypeMap++        , kindEnvOfEnvX+        , typeEnvOfEnvX++        -- * Projections +        , depth+        , lookupT+        , lookupX,      lookupNameX+        , memberX,      memberBindX++        -- * Primitives+        , setPrimFun+        , isPrim++        -- * Lifting+        , lift)+where+import DDC.Type.Exp+import DDC.Type.Transform.BoundT+import Data.Maybe+import DDC.Type.DataDef                 (DataDefs)+import Data.Map                         (Map)+import Prelude                          hiding (lookup)+import DDC.Core.Env.EnvT                (EnvT)+import qualified DDC.Type.Env           as Env+import qualified DDC.Type.DataDef       as DataDef+import qualified DDC.Core.Env.EnvT      as EnvT+import qualified Data.Map.Strict        as Map+import qualified Prelude                as P+import Control.Monad+++-- | Environment of term expressions.+data EnvX n+        = EnvX+        { -- | Environment of type expressions.+          envxEnvT         :: EnvT n++          -- | Types of baked in, primitive names.+        , envxPrimFun      :: !(n -> Maybe (Type n))++          -- | Data type definitions.+        , envxDataDefs     :: !(DataDefs n)++          -- | Types of named variables and constructors.+        , envxMap          :: !(Map n (Type n))++          -- | Types of anonymous deBruijn variables.+        , envxStack        :: ![Type n] +        +          -- | The length of the above stack.+        , envxStackLength  :: !Int }+++-- | An empty environment.+empty :: EnvX n+empty   = EnvX+        { envxEnvT         = EnvT.empty+        , envxPrimFun      = \_ -> Nothing +        , envxDataDefs     = DataDef.emptyDataDefs+        , envxMap          = Map.empty+        , envxStack        = [] +        , envxStackLength  = 0 }+++-- | Build an `EnvX` from prim environments.+fromPrimEnvs +        :: Ord n +        => Env.KindEnv n        -- ^ Primitive kind environment.+        -> Env.TypeEnv n        -- ^ Primitive type environment.+        -> DataDefs n           -- ^ Primitive data type definitions.+        -> EnvX n++fromPrimEnvs kenv tenv defs+ = let  envt    = EnvT.empty +                { EnvT.envtPrimFun = Env.envPrimFun kenv }++        envx    = empty+                { envxEnvT         = envt+                , envxPrimFun      = Env.envPrimFun tenv +                , envxDataDefs     = defs }+   in   envx+++-- | Construct a singleton type environment.+singleton :: Ord n => Bind n -> EnvX n+singleton b+        = extendX b empty+++-------------------------------------------------------------------------------+-- | Extend an environment with a new binding.+--   Replaces bindings with the same name already in the environment.+extendX :: Ord n => Bind n -> EnvX n -> EnvX n+extendX bb env+ = case bb of+         BName n k -> env { envxMap         = Map.insert n k (envxMap env) }+         BAnon   k -> env { envxStack       = k : envxStack env +                          , envxStackLength = envxStackLength env + 1 }+         BNone{}   -> env+++-- | Extend an environment with a list of new bindings.+--   Replaces bindings with the same name already in the environment.+extendsX :: Ord n => [Bind n] -> EnvX n -> EnvX n+extendsX bs env+        = foldl (flip extendX) env bs+++-- | Extend the environment with the kind of a new type variable.+extendT :: Ord n => Bind n -> EnvX n -> EnvX n+extendT bb envx+ = envx { envxEnvT = EnvT.extend bb (envxEnvT envx) }+++-- | Extend the environment with some new type bindings.+extendsT :: Ord n => [Bind n] -> EnvX n -> EnvX n+extendsT bs env+        = foldl (flip extendT) env bs+++-------------------------------------------------------------------------------+-- | Set the function that knows the types of primitive things.+setPrimFun :: (n -> Maybe (Type n)) -> EnvX n -> EnvX n+setPrimFun f env+        = env { envxPrimFun = f }+++-- | Check if the type of a name is defined by the `envPrimFun`.+isPrim :: EnvX n -> n -> Bool+isPrim env n+        = isJust $ envxPrimFun env n+++-- | Convert a list of `Bind`s to an environment.+fromList :: Ord n => [Bind n] -> EnvX n+fromList bs+        = foldr extendX empty bs+++-- | Convert a list of name and types into an environment+fromListNT :: Ord n => [(n, Type n)] -> EnvX n+fromListNT nts+        = fromList [BName n t | (n, t) <- nts]+++-- | Convert a map of names to types to a environment.+fromTypeMap :: Map n (Type n) -> EnvX n+fromTypeMap m+        = empty { envxMap = m }+++-- | Extract a `KindEnv` from an EnvX.+kindEnvOfEnvX :: Ord n => EnvX n -> Env.KindEnv n+kindEnvOfEnvX env +        = EnvT.kindEnvOfEnvT $ envxEnvT env+++-- | Extract `TypeEnv` from an `EnvX.+typeEnvOfEnvX :: Ord n => EnvX n -> Env.TypeEnv n+typeEnvOfEnvX env+        = Env.empty+        { Env.envMap       = envxMap env+        , Env.envPrimFun   = \n -> envxPrimFun env n }+++-- | Combine two environments.+--   If both environments have a binding with the same name,+--   then the one in the second environment takes preference.+union :: Ord n => EnvX n -> EnvX n -> EnvX n+union env1 env2+        = EnvX       +        { envxEnvT         = envxEnvT          env1 `EnvT.union` envxEnvT        env2+        , envxPrimFun      = \n -> envxPrimFun env2 n `mplus`   envxPrimFun env1 n +        , envxDataDefs     = envxDataDefs      env1 `mappend`   envxDataDefs     env2+        , envxMap          = envxMap           env1 `Map.union` envxMap          env2+        , envxStack        = envxStack         env2  ++ envxStack                env1+        , envxStackLength  = envxStackLength   env2  +  envxStackLength          env1 }+++-- | Combine multiple environments,+--   with the latter ones taking preference.+unions :: Ord n => [EnvX n] -> EnvX n+unions envs+        = foldr union empty envs+++-- | Check whether a bound variable is present in an environment.+memberX :: Ord n => Bound n -> EnvX n -> Bool+memberX uu env+        = isJust $ lookupX uu env+++-- | Check whether a binder is already present in the an environment.+--   This can only return True for named binders, not anonymous or primitive ones.+memberBindX :: Ord n => Bind n -> EnvX n -> Bool+memberBindX uu env+ = case uu of+        BName n _ -> Map.member n (envxMap env)+        _         -> False+++-- | Lookup a bound variable from an environment.+lookupT :: Ord n => Bound n -> EnvX n -> Maybe (Kind n)+lookupT uu env+ = EnvT.lookup uu (envxEnvT env) +++-- | Lookup a bound variable from an environment.+lookupX :: Ord n => Bound n -> EnvX n -> Maybe (Type n)+lookupX uu env+ = case uu of+        UName n +         ->      Map.lookup n (envxMap env) +         `mplus` envxPrimFun env n++        UIx i     -> P.lookup i (zip [0..] (envxStack env))+        UPrim n _ -> envxPrimFun env n+++-- | Lookup a bound name from an environment.+lookupNameX :: Ord n => n -> EnvX n -> Maybe (Type n)+lookupNameX n env+          = Map.lookup n (envxMap env)+++-- | Yield the total depth of the deBruijn stack.+depth :: EnvX n -> Int+depth env = envxStackLength env+++-- | Lift all free deBruijn indices in the environment by the given number of steps.+---+--  ISSUE #276: Delay lifting of indices in type environments.+--      The 'lift' function on type environments applies to every member of+--      the environment. We'd get better complexity by recording how many+--      levels all types should be lifted by, and only applying the real lift+--      function when the type is finally extracted.+--+lift :: Ord n => Int -> EnvX n -> EnvX n+lift n env+        = EnvX+        { envxEnvT         = envxEnvT env+        , envxPrimFun      = envxPrimFun      env +        , envxDataDefs     = envxDataDefs     env+        , envxMap          = Map.map (liftT n) (envxMap env)+        , envxStack        = map (liftT n) (envxStack env)+        , envxStackLength  = envxStackLength  env }+
DDC/Core/Exp.hs view
@@ -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
DDC/Core/Exp/Annot.hs view
@@ -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.Exp.Simple.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.Exp.Simple.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.Exp.Simple.Compounds+import DDC.Type.Exp.Simple.Predicates+import DDC.Type.Exp
+ DDC/Core/Exp/Annot/AnT.hs view
@@ -0,0 +1,35 @@++module DDC.Core.Exp.Annot.AnT+        (AnT (..))+where+import DDC.Type.Exp+import DDC.Data.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"+++
+ DDC/Core/Exp/Annot/AnTEC.hs view
@@ -0,0 +1,49 @@++module DDC.Core.Exp.Annot.AnTEC+        ( AnTEC (..)+        , fromAnT)+where+import DDC.Type.Exp.Simple+import DDC.Data.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"+++
+ DDC/Core/Exp/Annot/Compounds.hs view
@@ -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.Exp.Simple.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.Exp.Simple.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 (Type 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
+ DDC/Core/Exp/Annot/Context.hs view
@@ -0,0 +1,150 @@++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.Core.Env.EnvX                (EnvX)+import qualified DDC.Core.Env.EnvX      as EnvX++data Context a n+        = Context+        { contextEnv    :: EnvX 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  { contextEnv    = EnvX.extendT b (contextEnv 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  { contextEnv    = EnvX.extendX b (contextEnv 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  { contextEnv    = EnvX.extendsX bs0 +                                $ EnvX.extendsT bs1+                                $ contextEnv 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  { contextEnv    = EnvX.extendsX (bsBefore ++ [b] ++ bsAfter)+                                        (contextEnv 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  { contextEnv    = EnvX.extendsX bs (contextEnv 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
+ DDC/Core/Exp/Annot/Ctx.hs view
@@ -0,0 +1,231 @@++module DDC.Core.Exp.Annot.Ctx+        ( Ctx (..)+        , isTopLetCtx+        , topOfCtx+        , takeEnclosingCtx+        , takeTopNameOfCtx+        , takeTopLetEnvNamesOfCtx+        , encodeCtx)+where+import DDC.Core.Exp.Annot.Exp+import DDC.Core.Env.EnvX                (EnvX)+import Data.Set                         (Set)+import DDC.Core.Env.EnvX                as EnvX+import qualified Data.Set               as Set+import qualified Data.Map.Strict        as Map+++-- | A one-hole context for `Exp`.+data Ctx a n+        -- | The top-level context.+        = CtxTop        +        { ctxEnvX       :: !(EnvX 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 -> EnvX n+topOfCtx ctx+ = case ctx of+        CtxTop env               -> env+        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 env+                 -> Set.fromList+                 $  Map.keys $ EnvX.envxMap env++                CtxLetLLet (CtxTop env) _ b xBody+                 -> Set.unions+                        [ Set.fromList $ Map.keys $ EnvX.envxMap env+                        , eatBind b+                        , eatExp xBody]++                CtxLetLRec (CtxTop env) _ bxsBefore b bxsAfter xBody+                 -> Set.unions+                        [ Set.fromList  $ Map.keys $ EnvX.envxMap env+                        , 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"+
+ DDC/Core/Exp/Annot/Exp.hs view
@@ -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 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 (Type 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
+ DDC/Core/Exp/Annot/Predicates.hs view
@@ -0,0 +1,162 @@++-- | Simple predicates on core expressions.+module DDC.Core.Exp.Annot.Predicates+        ( module DDC.Type.Exp.Simple.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.Exp.Simple.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+
+ DDC/Core/Exp/Annot/Pretty.hs view
@@ -0,0 +1,324 @@+{-# LANGUAGE TypeFamilies #-}++-- | Pretty printing for annotated expressions.+module DDC.Core.Exp.Annot.Pretty+        ( module DDC.Data.Pretty+        , PrettyMode (..))+where+import DDC.Core.Exp.Annot+import DDC.Type.Exp.Simple.Pretty       ()+import DDC.Data.Pretty+import Data.List+import Prelude                          hiding ((<$>))+++-- Exp --------------------------------------------------------------------------------------------+instance (Pretty n, Eq n) => Pretty (Exp a n) where+ data PrettyMode (Exp a n)+        = PrettyModeExp+        { modeExpLets           :: PrettyMode (Lets a n)+        , modeExpAlt            :: PrettyMode (Alt a n)+        +          -- Display types on primitive variables.+        , modeExpVarTypes       :: Bool++          -- Display types on primitive constructors.+        , modeExpConTypes       :: Bool+        +          -- Use 'letcase' for single alternative case expressions.+        , modeExpUseLetCase     :: Bool }+++ pprDefaultMode+        = PrettyModeExp+        { modeExpLets           = pprDefaultMode+        , modeExpAlt            = pprDefaultMode+        , modeExpConTypes       = False+        , modeExpVarTypes       = False+        , 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++        XVar  _ u       +         | modeExpVarTypes mode+         , Just t       <- takeTypeOfBound u+         -> parens $ ppr u <> text ":" <+> ppr t++         | otherwise+         -> ppr u++        XCon  _ dc+         | modeExpConTypes mode+         , Just t       <- takeTypeOfDaCon dc+         -> parens $ ppr dc <> text ":" <+> ppr t+        +         | otherwise+         -> ppr dc+        +        XLAM{}+         -> let Just (bs, xBody) = takeXLAMs xx+                groups = partitionBindsByType bs+            in  pprParen' (d > 1)+                 $  (cat $ map (pprBinderGroup (text "Λ")) groups)+                 <>  (if      isXLAM    xBody then empty+                      else if isXLam    xBody then line+                      else if isSimpleX xBody then space+                      else    line)+                 <>  pprX xBody++        XLam{}+         -> let Just (bs, xBody) = takeXLams xx+                groups = partitionBindsByType bs+            in  pprParen' (d > 1)+                 $  (cat $ map (pprBinderGroup (text "\955")) groups) +                 <> breakWhen (not $ isSimpleX xBody)+                 <> pprX xBody++        XApp _ x1 x2+         -> pprParen' (d > 10)+         $  pprModePrec mode 10 x1 +                <> nest 4 (breakWhen (not $ isSimpleX x2) +                          <> pprModePrec mode 11 x2)++        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++        XType    _ t    -> text "[" <> ppr t <> text "]"+        XWitness _ w    -> text "<" <> ppr w <> text ">"+++-- Pat --------------------------------------------------------------------------------------------+instance (Pretty n, Eq n) => Pretty (Pat n) where+ ppr pp+  = case pp of+        PDefault        -> text "_"+        PData u bs      -> ppr u <+> sep (map pprPatBind bs)+++-- | Pretty print a binder, +--   showing its type annotation only if it's not bottom.+pprPatBind :: (Eq n, Pretty n) => Bind n -> Doc+pprPatBind b+        | isBot (typeOfBind b)  = ppr $ binderOfBind b+        | otherwise             = parens $ ppr b+++-- Alt --------------------------------------------------------------------------------------------+instance (Pretty n, Eq n) => Pretty (Alt a n) where+ data PrettyMode (Alt a n)+        = PrettyModeAlt+        { modeAltExp            :: PrettyMode (Exp a n) }++ 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))+++-- DaCon ------------------------------------------------------------------------------------------+instance (Pretty n, Eq n) => Pretty (DaCon n (Type n)) where+ ppr dc+  = case dc of+        DaConUnit       -> text "()"+        DaConPrim  n _  -> ppr n+        DaConBound n    -> ppr n+++-- Cast -------------------------------------------------------------------------------------------+instance (Pretty n, Eq n) => Pretty (Cast a n) 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 (Pretty n, Eq n) => Pretty (Lets a n) where+ data PrettyMode (Lets a n)+        = PrettyModeLets+        { modeLetsExp           :: PrettyMode (Exp a n) +        , modeLetsSuppressTypes :: Bool }++ pprDefaultMode+        = PrettyModeLets+        { modeLetsExp           = pprDefaultMode +        , modeLetsSuppressTypes = False }++ pprModePrec mode _ lts+  = let pprX    = pprModePrec (modeLetsExp mode) 0+    in case lts of+        LLet b x+         -> let bHasType = not $ isBot (typeOfBind b)++                dBind    = if modeLetsSuppressTypes mode || (not bHasType)+                             then ppr (binderOfBind b)+                             else ppr b++            in  text "let"+                 <+> align (  (padL 7 dBind)+                           <>  nest (if bHasType then 2 else 6 )+                                ( breakWhen bHasType+                                <> text "=" <+> align (pprX x)))++        LRec bxs+         -> let pprLetRecBind (b, x)+                 =   ppr (binderOfBind b)+                 <>  text ":" <+> ppr (typeOfBind 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 . binderOfBind) bs))++        LPrivate bs Nothing bws+         -> text "private"+                <+> (hcat $ punctuate space (map (ppr . binderOfBind) bs))+                <+> text "with"+                <+> braces (cat $ punctuate (text "; ") $ map pprWitBind bws)++        LPrivate bs (Just parent) []+         -> text "extend"+                <+> ppr parent+                <+> text "using"+                <+> (hcat $ punctuate space (map (ppr . binderOfBind) bs))++        LPrivate bs (Just parent) bws+         -> text "extend"+                <+> ppr parent+                <+> text "using"+                <+> (hcat $ punctuate space (map (ppr . binderOfBind) bs))+                <+> text "with"+                <+> braces (cat $ punctuate (text "; ") $ map pprWitBind bws)+        ++-- | When we pretty print witness binders, +--   suppress the underscore when there is no name.+pprWitBind :: (Eq n, Pretty n) => Bind n -> Doc+pprWitBind b+ = case b of+        BNone t -> ppr t+        _       -> ppr b+++-- Witness ----------------------------------------------------------------------------------------+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)+        WType _ t       -> text "[" <> ppr t <> text "]"+++instance (Pretty n, Eq n) => Pretty (WiCon n) where+ ppr wc+  = case wc of+        WiConBound   u  _ -> ppr u+++-- Binder -----------------------------------------------------------------------------------------+pprBinder   :: Pretty n => Binder n -> Doc+pprBinder bb+ = case bb of+        RName v         -> ppr v+        RAnon           -> text "^"+        RNone           -> text "_"+++-- | Print a group of binders with the same type.+pprBinderGroup +        :: (Pretty n, Eq n) +        => Doc -> ([Binder n], Type n) -> Doc++pprBinderGroup lam (rs, t)+        =  lam +        <> parens ((hsep $ map pprBinder rs) <> text ":" <+> ppr t) +        <> dot+++-- Utils ------------------------------------------------------------------------------------------+breakWhen :: Bool -> Doc+breakWhen True   = line+breakWhen False  = space+++isSimpleX :: Exp a n -> Bool+isSimpleX xx+ = case xx of+        XVar{}          -> True+        XCon{}          -> True+        XType{}         -> True+        XWitness{}      -> True+        XApp _ x1 x2    -> isSimpleX x1 && isAtomX x2+        _               -> False+++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+
DDC/Core/Exp/DaCon.hs view
@@ -7,13 +7,12 @@         , takeNameOfDaCon         , takeTypeOfDaCon) where-import DDC.Type.Compounds-import DDC.Type.Exp+import DDC.Type.Exp.Simple import Control.DeepSeq   -- | Data constructors.-data DaCon n+data DaCon n t         -- | Baked in unit data constructor.         = DaConUnit @@ -30,7 +29,7 @@           daConName     :: !n             -- | Type of the data constructor.-        , daConType     :: !(Type n)+        , daConType     :: !t         }          -- | Data constructor that has a data type declaration.@@ -41,7 +40,7 @@         deriving (Show, Eq)  -instance NFData n => NFData (DaCon n) where+instance (NFData n, NFData t) => NFData (DaCon n t) where  rnf !dc   = case dc of         DaConUnit       -> ()@@ -51,7 +50,7 @@  -- | Take the name of data constructor, --   if there is one.-takeNameOfDaCon :: DaCon n -> Maybe n+takeNameOfDaCon :: DaCon n t -> Maybe n takeNameOfDaCon dc  = case dc of         DaConUnit       -> Nothing@@ -61,7 +60,7 @@  -- | Take the type annotation of a data constructor, --   if we know it locally.-takeTypeOfDaCon :: DaCon n -> Maybe (Type n)+takeTypeOfDaCon :: DaCon n (Type n) -> Maybe (Type n) takeTypeOfDaCon dc    = case dc of         DaConUnit       -> Just $ tUnit@@ -70,6 +69,6 @@   -- | The unit data constructor.-dcUnit  :: DaCon n+dcUnit  :: DaCon n t dcUnit  = DaConUnit
+ DDC/Core/Exp/Generic.hs view
@@ -0,0 +1,73 @@++module DDC.Core.Exp.Generic+        ( -- * Abstract Syntax+          -- ** Expressions+          GAnnot+        , GBind+        , GBound+        , GPrim++        , GExp          (..)+        , GAbs          (..)+        , GArg          (..)+        , GLets         (..)+        , GAlt          (..)+        , GPat          (..)+        , GCast         (..)+        , GWitness      (..)+        , GWiCon        (..)++        , pattern XLAM+        , pattern XLam++          ---------------------------------------+          -- * Predicates+        , module DDC.Type.Exp.Simple.Predicates++          -- ** Atoms+        , isXVar,  isXCon+        , isAtomX, isAtomR, isAtomW++          -- ** Abstractions+        , isXAbs, isXLAM, isXLam++          -- ** Applications+        , isXApp++          -- ** Let bindings+        , isXLet++          -- ** Patterns+        , isPDefault++          ---------------------------------------+          -- * Compounds+        , module DDC.Type.Exp.Simple.Compounds++          -- ** Abstractions+        , makeXAbs,     takeXAbs+        , makeXLAMs,    takeXLAMs+        , makeXLams,    takeXLams++          -- ** Applications+        , makeXApps,    takeXApps,      splitXApps+        , takeXConApps+        , takeXPrimApps++          -- ** Data Constructors+        , dcUnit+        , takeNameOfDaCon+        , takeTypeOfDaCon++          ---------------------------------------+          -- * Dictionaries+        , ShowLanguage)+where+import DDC.Core.Exp.Generic.Exp+import DDC.Core.Exp.Generic.Predicates+import DDC.Core.Exp.Generic.Compounds   +import DDC.Core.Exp.Generic.Pretty              ()+import DDC.Type.Exp.Simple.Compounds+import DDC.Type.Exp.Simple.Predicates++
+ DDC/Core/Exp/Generic/BindStruct.hs view
@@ -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.FreeX+import DDC.Core.Collect.BindStruct+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+
+ DDC/Core/Exp/Generic/Compounds.hs view
@@ -0,0 +1,147 @@+{-# 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.Exp.Simple.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.Exp.Simple.Compounds+import DDC.Type.Exp.Simple.Exp+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 (Type 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+
+ DDC/Core/Exp/Generic/Exp.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE TypeFamilies, UndecidableInstances #-}++-- | Generic term 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 term 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 (T.Type 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 (T.Type 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)+
+ DDC/Core/Exp/Generic/Predicates.hs view
@@ -0,0 +1,122 @@++-- | Simple predicates on core expressions.+module DDC.Core.Exp.Generic.Predicates+        ( module DDC.Type.Exp.Simple.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.Exp.Simple.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+
+ DDC/Core/Exp/Generic/Pretty.hs view
@@ -0,0 +1,297 @@+{-# 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.Exp.Simple      ()+import DDC.Type.Exp.Simple.Exp+import DDC.Data.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 (Type 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++
+ DDC/Core/Exp/Literal.hs view
@@ -0,0 +1,22 @@++module DDC.Core.Exp.Literal+        ( Literal       (..))+where+import Data.Text        (Text)+++-- | Types of literal values known to the compiler.+--+--   Note that literals are embedded in the name type of each fragment+--   rather than in the expression itself so that fragments can +--   choose which types of literals they support. +--+data Literal+        = LInt    Integer+        | LNat    Integer+        | LSize   Integer+        | LWord   Integer Int+        | LFloat  Double  Int+        | LChar   Char+        | LString Text+        deriving (Eq, Show)
− DDC/Core/Exp/Pat.hs 
@@ -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--
− DDC/Core/Exp/Simple.hs 
@@ -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-
DDC/Core/Exp/WiCon.hs view
@@ -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+++
DDC/Core/Fragment.hs view
@@ -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@@ -27,7 +31,6 @@ import DDC.Core.Module import DDC.Core.Exp import DDC.Core.Lexer-import DDC.Data.Token   -- | Carries all the information we need to work on a particular @@ -45,11 +48,11 @@                    -- | Lex module source into tokens,           --   given the source name and starting line number. -        , fragmentLexModule     :: String -> Int -> String -> [Token (Tok n)]+        , fragmentLexModule     :: String -> Int -> String -> [Located (Token n)]            -- | Lex expression source into tokens,           --   given the source name and starting line number.-        , fragmentLexExp        :: String -> Int -> String -> [Token (Tok n)]+        , fragmentLexExp        :: String -> Int -> String -> [Located (Token n)]            -- | Perform language fragment specific checks on a module.         , fragmentCheckModule   :: forall a. Module a n -> Maybe (err a)@@ -62,3 +65,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) }
DDC/Core/Fragment/Compliance.hs view
@@ -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)
DDC/Core/Fragment/Feature.hs view
@@ -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)+
DDC/Core/Fragment/Profile.hs view
@@ -2,16 +2,19 @@ -- | A fragment profile determines what features a program can use. module DDC.Core.Fragment.Profile         ( Profile (..)+        , mapFeaturesOfProfile         , zeroProfile          , Features(..)         , zeroFeatures         , setFeature) where+import DDC.Core.Exp.Literal import DDC.Core.Fragment.Feature 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  @@ -40,9 +43,23 @@            -- | 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))  +          -- | Convert a literal to a name,+          --   given the source position, literal value and whether+          --   the literal should be taken as a language primitive+          --   (with a trailing '#').+        , profileMakeLiteralName+                :: Maybe (SourcePos -> Literal -> Bool -> Maybe 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 +72,8 @@         , profilePrimKinds              = Env.empty         , profilePrimTypes              = Env.empty         , profileTypeIsUnboxed          = const False -        , profileNameIsHole             = Nothing }+        , profileNameIsHole             = Nothing +        , profileMakeLiteralName        = Nothing }   -- | A flattened set of features, for easy lookup.@@ -66,10 +84,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 +109,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 +133,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 }
DDC/Core/Lexer.hs view
@@ -8,23 +8,30 @@ -- module DDC.Core.Lexer         ( module DDC.Core.Lexer.Tokens-        , module DDC.Core.Lexer.Names+        , Located (..)            -- * Lexer         , lexModuleWithOffside         , lexExp) where+import DDC.Core.Lexer.Token.Builtin+import DDC.Core.Lexer.Token.Index+import DDC.Core.Lexer.Token.Keyword+import DDC.Core.Lexer.Token.Literal+import DDC.Core.Lexer.Token.Names+import DDC.Core.Lexer.Token.Operator+import DDC.Core.Lexer.Token.Symbol+ import DDC.Core.Lexer.Offside-import DDC.Core.Lexer.Comments-import DDC.Core.Lexer.Names import DDC.Core.Lexer.Tokens import DDC.Data.SourcePos-import DDC.Data.Token-import Data.Char-import Data.List+import Data.Text                                (Text)+import qualified System.IO.Unsafe               as System+import qualified Text.Lexer.Inchworm.Char       as I+import qualified Data.Text                      as Text  --- Module ---------------------------------------------------------------------+-- Module ----------------------------------------------------------------------------------------- -- | Lex a module and apply the offside rule. -- --   Automatically drop comments from the token stream along the way.@@ -33,17 +40,23 @@         :: FilePath     -- ^ Path to source file, for error messages.         -> Int          -- ^ Starting line number.         -> String       -- ^ String containing program text.-        -> [Token (Tok String)]+        -> [Located (Token String)]  lexModuleWithOffside sourceName lineStart str- = {-# SCC lexWithOffside #-}-        applyOffside [] []+ = applyOffside [] []         $ addStarts-        $ dropComments -        $ lexString sourceName lineStart str+        $ dropUnused+        $ lexText sourceName lineStart +        $ Text.pack str + where  dropUnused ts+         = case ts of+                []                              -> []+                Located _ (KM KComment{}) : ts' -> dropUnused ts'+                t : ts'                         -> t : dropUnused ts' --- Exp ------------------------------------------------------------------------++-- Exp -------------------------------------------------------------------------------------------- -- | Lex a string into tokens. -- --   Automatically drop comments from the token stream along the way.@@ -51,181 +64,129 @@ lexExp  :: FilePath     -- ^ Path to source file, for error messages.         -> Int          -- ^ Starting line number.         -> String       -- ^ String containing program text.-        -> [Token (Tok String)]+        -> [Located (Token String)]  lexExp sourceName lineStart str- = {-# SCC lexExp #-}-        dropNewLines-        $ dropComments-        $ lexString sourceName lineStart str+ = dropUnused+        $ lexText sourceName lineStart +        $ Text.pack str + where  dropUnused ts+         = case ts of+                []                              -> []+                Located _ (KM KComment{}) : ts' -> dropUnused ts'+                Located _ (KM KNewLine{}) : ts' -> dropUnused ts' +                t : ts'                         -> t : dropUnused ts' --- Generic ---------------------------------------------------------------------lexString :: String -> Int -> String -> [Token (Tok String)]-lexString sourceName lineStart str-        = lexWord lineStart 1 str- where -  lexWord :: Int -> Int -> String -> [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 -          lexUpto pat rest-           = case dropWhile (not . isPrefixOf pat) (tails rest) of-                (x:_)   -> x-                _       -> []+-- 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.+        -> [Located (Token String)] -          lexMore n rest-           = lexWord line (column + n) rest+lexText filePath nStart txt+ = let  (toks, locEnd, strLeftover)+         = System.unsafePerformIO+         $ I.scanListIO+                (I.Location nStart 1)+                 I.bumpLocationWithChar+                (Text.unpack txt)+                (scanner filePath) -     in case w of-        []               -> []        +        I.Location lineEnd colEnd = locEnd+        spEnd   = SourcePos filePath lineEnd colEnd -        -- Whitespace-        ' '  : w'        -> lexMore 1 w'-        '\t' : w'        -> lexMore 8 w'+   in   case strLeftover of+         []     -> toks+         str    -> toks ++ [Located spEnd (KErrorJunk (take 10 str))] -        -- 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 -        '-' : c : cs-         | isDigit c-         , (body, rest)         <- span isLitBody cs-         -> tokN (KLit ('-':c:body))    : lexMore (length (c:body)) rest+-- | Scanner for core tokens tokens.+type Scanner a+        = I.Scanner IO I.Location [Char] a -        -- Meta tokens-        '{'  : '-' : w'-         -> tokM KCommentBlockStart : lexMore 2 (lexUpto "-}" w') -        '-'  : '}' : w'-         -> tokM KCommentBlockEnd   : lexMore 2 w'--        '-'  : '-' : w'  -         -> let  (_junk, w'') = span (/= '\n') w'-            in   tokM KCommentLineStart  : lexMore 2 w''--        '\n' : w'        -> tokM KNewLine           : lexWord (line + 1) 1 w'--        -- Wrapper operator symbols.-        '(' : c : cs -         | isOpStart c-         , (body, ')' : w')     <- span isOpBody cs-         -> tokA (KOpVar (c : body))             : lexMore (2 + length (c : body)) w'--        -- The unit data constructor-        '(' : ')' : w'   -> tokA KDaConUnit      : lexMore 2 w'--        -- 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'--        -- 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'--        -- Debruijn indices-        '^'  : cs-         |  (ds, rest)   <- span isDigit cs-         ,  length ds >= 1-         -> tokA (KIndex (read ds))              : lexMore (1 + length ds) rest         +-------------------------------------------------------------------------------+-- | Scanner for source and core files.+--+--   The lexical structure for source and core is a bit different, +--   but close enough that there's no point writing a separate lexer yet.+--+scanner :: FilePath +        -> Scanner (Located (Token String)) -        -- 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'+scanner fileName+ = let+        stamp   :: (I.Location, a) -> Located a+        stamp (I.Location line col, token)+         = Located (SourcePos fileName line col) token+        {-# INLINE stamp #-} -        -- Operator symbols.-        c : cs-         |  isOpStart c-         ,  (body, rest)         <- span isOpBody cs-         -> tokA (KOp (c : body))                : lexMore (length (c : body)) rest-        -        -- Operator body symbols.-        '^'  : w'       -> tokA KHat             : lexMore 1 w'+        stamp'  :: (a -> b)+                -> (I.Location, a) -> Located b+        stamp' k (I.Location line col, token) +          = Located (SourcePos fileName line col) (k token)+        {-# INLINE stamp' #-} -        -- Bottoms-        name-         |  Just w'     <- stripPrefix "Pure"  name -         -> tokA KBotEffect   : lexMore 2 w'-         -         |  Just w'     <- stripPrefix "Empty" name -         -> tokA KBotClosure  : lexMore 2 w'+   in I.skip (\c -> c == ' ' || c == '\t')+        $ I.alts+        [ -- Newlines are scanned to their own tokens because+          -- the transform that manages the offside rule uses them.+          fmap stamp                    +           $ I.from     (\c -> case c of+                                '\n'        -> return $ KM KNewLine+                                _           -> Nothing) -        -- 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 socon   <- readSoConBuiltin s-                 = tokA (KSoConBuiltin socon)    : lexMore (length s) rest'+          -- Scan comments into their own tokens,+          -- these then get dropped by the dropComments function.+        , fmap (stamp' (KM . KComment)) $ I.scanHaskellCommentLine+        , fmap (stamp' (KM . KComment)) $ I.scanHaskellCommentBlock -                 | Just kicon   <- readKiConBuiltin s-                 = tokA (KKiConBuiltin kicon)    : lexMore (length s) rest'+          -- deBruijn indices.+          --   Needs to come before scanSymbol as '^' is also an operator.+        , fmap (stamp' (KA . KIndex))   $ scanIndex -                 | Just twcon   <- readTwConBuiltin s-                 = tokA (KTwConBuiltin twcon)    : lexMore (length s) rest'-                 -                 | Just tccon   <- readTcConBuiltin s-                 = tokA (KTcConBuiltin tccon)    : lexMore (length s) rest'-                 -                 | Just con     <- readCon s-                 = tokN (KCon con)               : lexMore (length s) rest'-               -                 | otherwise    -                 = [tok (KJunk [c])]-                 -            in  readNamedCon (c : body')+          -- Literal values.+        , fmap (stamp' (\(l, b) -> KA (KLiteral l b)))+           $ scanLiteral -        -- 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'+          -- Infix operators.+          --   Needs to come before scanSymbol because operators +          --   like "==" are parsed atomically rather than as+          --   two separate '=' symbols.+        , fmap (stamp' (KA . KOp))      $ scanInfixOperator  -                 | Just wc <- readWbConBuiltin s-                 = tokA (KWbConBuiltin wc) : lexMore (length s) rest'-         -                 | Just v  <- readVar s-                 = tokN (KVar v)           : lexMore (length s) rest'+          -- Prefix operators.+        , fmap (stamp' (KA . KOpVar))   $ scanPrefixOperator -                 | otherwise-                 = [tok (KJunk [c])]+          -- The unit value.+          --   Needs to come before scanSymbol because the "()"+          --   lexeme is parsed atomically rather than as+          --   separate '(' and ')' symbols.+        , fmap stamp+           $ I.froms    (Just 2) +                        (\ss -> if ss == "()"+                                then Just (KA $ KBuiltin $ BDaConUnit)+                                else Nothing) -            in  readNamedVar (c : body')+          -- Symbolic tokens like punctuation.+        , fmap (stamp' (KA . KSymbol))  $ scanSymbol -        -- Some unrecognised character.-        -- We still need to keep lexing as this may be in a comment.-        c : cs   -> (tok $ KJunk [c]) : lexMore 1 cs+          -- Named things.+          --   Keywords have the same lexical structure as variables as+          --   they all start with a lower-case letter. We need to check+          --   for keywords before accepting a variable.+        , fmap (stamp' (KA . KBuiltin)) $ scanBuiltin +        , fmap (stamp' (KA . KKeyword)) $ scanKeyword+        , fmap (stamp' (KN . KCon))     $ scanConName+        , fmap (stamp' (KN . KVar))     $ scanVarName+        ]
− DDC/Core/Lexer/Comments.hs 
@@ -1,64 +0,0 @@--module DDC.Core.Lexer.Comments-        ( dropComments-        , dropNewLines)-where-import DDC.Core.Lexer.Tokens-import DDC.Data.Token-import DDC.Data.SourcePos----- | Drop all the comments and newline tokens in this stream.-dropComments -        :: Eq n => [Token (Tok n)] -> [Token (Tok n)]--dropComments []      = []-dropComments (t@(Token tok sourcePos) : xs)- = case tok of-        KM KCommentLineStart -         -> dropComments $ dropWhile (\t' -> not $ isToken t' (KM KNewLine)) xs--        KM KCommentBlockStart -         -> dropComments $ dropCommentBlock sourcePos xs t--        _ -> t : dropComments xs----- | Drop block comments form a token stream.-dropCommentBlock -        :: Eq n-        => SourcePos            -- ^ Position of outer-most block comment start.-        -> [Token (Tok n)] -        -> Token (Tok n) -        -> [Token (Tok n)]--dropCommentBlock spStart [] _terr-        = [Token (KM KCommentUnterminated) spStart]--dropCommentBlock spStart (t@(Token tok _) : xs) terr- = case tok of-        -- enter into nested block comments.-        KM KCommentBlockStart-         -> dropCommentBlock spStart (dropCommentBlock spStart xs t) terr--        -- outer-most block comment has ended.-        KM KCommentBlockEnd-         -> xs--        _ -> dropCommentBlock spStart xs terr----- | Drop newline tokens from this list.-dropNewLines :: Eq n => [Token (Tok n)] -> [Token (Tok n)]-dropNewLines [] = []-dropNewLines (t:ts)-        | isToken t (KM KNewLine)-        = dropNewLines ts--        | otherwise-        = t : dropNewLines ts---isToken :: Eq n => Token (Tok n) -> Tok n -> Bool-isToken (Token tok _) tok2 = tok == tok2-
− DDC/Core/Lexer/Names.hs 
@@ -1,309 +0,0 @@--module DDC.Core.Lexer.Names-        ( -- * Keywords-          keywords--          -- * Builtin constructors-        , readSoConBuiltin-        , readKiConBuiltin-        , readTwConBuiltin-        , readTcConBuiltin-        , readWbConBuiltin--          -- * Variable names-        , isVarName-        , isVarStart-        , isVarBody-        , readVar--          -- * Constructor names-        , isConName-        , isConStart-        , isConBody-        , readCon--          -- * Operator names-        , isOpName-        , isOpStart-        , isOpBody--          -- * Literal names-        , isLitName-        , isLitStart-        , isLitBody)-where-import DDC.Core.Exp-import DDC.Core.Lexer.Tokens-import DDC.Data.ListUtils-import Data.Char-import Data.List----- | Textual keywords in the core language.-keywords :: [(String, Tok n)]-keywords- =      [ ("module",     KA KModule)-        , ("import",     KA KImport)-        , ("export",     KA KExport)-        , ("foreign",    KA KForeign)-        , ("type",       KA KType)-        , ("value",      KA KValue)-        , ("data",       KA KData)-        , ("in",         KA KIn)-        , ("of",         KA KOf) -        , ("letrec",     KA KLetRec)-        , ("letcase",    KA KLetCase)-        , ("private",    KA KPrivate)-        , ("extend",     KA KExtend)-        , ("using",      KA KUsing)-        , ("withregion", KA KWithRegion)-        , ("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) ]----- | Read a named sort constructor.-readSoConBuiltin :: String -> Maybe SoCon-readSoConBuiltin ss- = case ss of-        "Prop"          -> Just SoConProp-        "Comp"          -> Just SoConComp-        _               -> Nothing----- | Read a named kind constructor.-readKiConBuiltin :: String -> Maybe KiCon-readKiConBuiltin ss- = case ss of-        "Witness"       -> Just KiConWitness-        "Data"          -> Just KiConData-        "Region"        -> Just KiConRegion-        "Effect"        -> Just KiConEffect-        "Closure"       -> Just KiConClosure-        _               -> Nothing----- | Read a named witness type constructor.-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---readTwConWithArity :: String -> Maybe TwCon-readTwConWithArity ss- | Just n <- stripPrefix "Distinct" ss - , all isDigit n- - = Just (TwConDistinct $ read n)- | otherwise = Nothing- - --- | Read a builtin type constructor with a non-symbolic name.---   ie not '->'.-readTcConBuiltin :: String -> Maybe TcCon-readTcConBuiltin ss- = case ss of-        "Unit"          -> Just TcConUnit-        "S"             -> Just TcConSusp-        "Read"          -> Just TcConRead-        "HeadRead"      -> Just TcConHeadRead-        "DeepRead"      -> Just TcConDeepRead-        "Write"         -> Just TcConWrite-        "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 ---------------------------------------------------------------- | String is a variable name-isVarName :: String -> Bool-isVarName str- = case str of-     []          -> False-     c : cs -        | isVarStart c -        , and (map isVarBody cs)-        -> True-        -        | _ : _         <- cs-        , Just initCs   <- takeInit cs-        , isVarStart c-        , and (map isVarBody initCs)-        , last cs == '#'-        -> True--        | otherwise-        -> False----- | Charater can start a variable name.-isVarStart :: Char -> Bool-isVarStart c-        =  isLower c-        || c == '?'-        ---- | Character can be part of a variable body.-isVarBody  :: Char -> Bool-isVarBody c-        =  isUpper c -        || isLower c -        || isDigit c -        || c == '_' -        || c == '\'' -        || c == '$'----- | Read a named, user defined variable.-readVar :: String -> Maybe String-readVar ss-        | isVarName ss  = Just ss-        | otherwise     = Nothing----- Constructor names ------------------------------------------------------------- | String is a constructor name.-isConName :: String -> Bool-isConName str- = case str of-     []          -> False-     c : cs -        | isConStart c -        , and (map isConBody cs)-        -> True-        -        | _ : _         <- cs-        , Just initCs   <- takeInit cs-        , isConStart c-        , and (map isConBody initCs)-        , last cs == '#'-        -> True--        | otherwise-        -> False---- | Character can start a constructor name.-isConStart :: Char -> Bool-isConStart = isUpper----- | Charater can be part of a constructor body.-isConBody  :: Char -> Bool-isConBody c     -        =  isUpper c -        || isLower c -        || isDigit c -        || c == '_'-        ---- | Read a named, user defined `TcCon`.-readCon :: String -> Maybe String-readCon ss-        | isConName ss  = Just ss-        | otherwise     = Nothing----- Operator names ---------------------------------------------------------------- | String is the name of some operator.-isOpName :: String -> Bool-isOpName str- = case str of-        []      -> False-        c : cs-         | isOpStart c-         , and (map isOpBody cs)-         -> True--         | otherwise-         -> False----- | Character can start an operator.-isOpStart :: Char -> Bool-isOpStart c-        =  c == '~'     || c == '!'     || c == '@'     || c == '#'     -        || c == '$'     || c == '%'                     || c == '&'     -        || c == '*'     || c == '-'     || c == '+'     || c == '='-        || c == ':'                     || c == '/'     || c == '|'-        || c == '<'     || c == '>'----- | Character can be part of an operator body.-isOpBody :: Char -> Bool-isOpBody c-        =  c == '~'     || c == '!'     || c == '@'     || c == '#'     -        || c == '$'     || c == '%'     || c == '^'     || c == '&'     -        || c == '*'     || c == '-'     || c == '+'     || c == '='-        || c == ':'     || c == '?'     || c == '/'     || c == '|'-        || c == '<'     || c == '>'----- Literal names ----------------------------------------------------------------- | String is the name of a literal.-isLitName :: String -> Bool-isLitName str- = case str of-        []      -> False-        c : cs-         | isLitStart c-         , and (map isLitBody cs)-         -> True--         | otherwise-         -> False---- | Character can start a literal.-isLitStart :: Char -> Bool-isLitStart c-        =   isDigit c-        ||  c == '-'---- | Character can be part of a literal body.-isLitBody :: Char -> Bool-isLitBody c-        =  isDigit c-        || c == 'b' || c == 'o' || c == 'x'-        || c == 'w' || c == 'f' || c == 'i' -        || c == '.'-        || c == '#'-        || c == '\''-
DDC/Core/Lexer/Offside.hs view
@@ -7,13 +7,12 @@ where import DDC.Core.Lexer.Tokens import DDC.Data.SourcePos-import DDC.Data.Token   --------------------------------------------------------------------------------------------------- -- | Holds a real token or start symbol which is used to apply the offside rule. data Lexeme n-        = LexemeToken           (Token (Tok n))+        = LexemeToken           (Located (Token n))         | LexemeStartLine       Int          -- | Signal that we're starting a block in this column.@@ -31,6 +30,7 @@ type Context         = Int + -- | Apply the offside rule to this token stream. -- --    It should have been processed with addStarts first to add the@@ -45,48 +45,46 @@         => [Paren]              -- ^ What parenthesis we're inside.         -> [Context]            -- ^ Current layout context.         -> [Lexeme n]           -- ^ Input lexemes.-        -> [Token (Tok n)]+        -> [Located (Token n)]  -- Wait for the module header before we start applying the real offside rule.  -- This allows us to write 'module Name with letrec' all on the same line. applyOffside ps [] (LexemeToken t : ts) -        |   isToken t (KA KModule)+        |   isKeyword t EModule          || isKNToken t         = t : applyOffside ps [] ts + -- Enter into a top-level block in the module, and start applying the  -- 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 KLetRec)-         || isToken t1 (KA KWhere)-        = t1 : newCBra ls' -                : applyOffside (ParenBrace : ps) [n] ls'+        ,   isKeyword t1 EExport+         || isKeyword t1 EImport+         || isKeyword t1 ELetRec+         || isKeyword t1 EWhere+        = t1 : newCBra ls'      : applyOffside (ParenBrace : ps) [n] ls'          -- (import | export) (type | value) { ... }         | LexemeToken t1 : LexemeToken t2                  : LexemeStartBlock n : ls' <- ls-        , isToken t1 (KA KImport)   || isToken t1 (KA KExport)-        , isToken t2 (KA KType)     || isToken t2 (KA KValue)-        = t1 : t2 : newCBra ls'-                : applyOffside (ParenBrace : ps) [n] ls'+        , isKeyword t1 EImport   || isKeyword t1 EExport+        , isKeyword t2 EType     || isKeyword t2 EValue+        = 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)-        = t1 : t2 : t3 : t4 : newCBra ls' -                : applyOffside (ParenBrace : ps) [n] ls'-+        , isKeyword t1 EImport   || isKeyword t1 EExport+        , isKeyword t2 EForeign+        , isKeyword t4 EType     || isKeyword t4 ECapability  || isKeyword t4 EValue+        = t1 : t2 : t3 : t4 : newCBra ls' : applyOffside (ParenBrace : ps) [n] ls'  -- At top level without a context. -- Skip over everything until we get the 'with' in 'module Name with ...''@@ -142,7 +140,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@@ -151,12 +149,12 @@  -- push context for explicit open brace applyOffside ps ms -        (LexemeToken t@Token { tokenTok = KA KBraceBra } : ts)+        (LexemeToken t@(Located _ (KA (KSymbol SBraceBra))) : ts)         = t : applyOffside (ParenBrace : ps) (0 : ms) ts  -- pop context from explicit close brace applyOffside ps mm -        (LexemeToken t@Token { tokenTok = KA KBraceKet } : ts) +        (LexemeToken t@(Located _ (KA (KSymbol SBraceKet))) : ts)           -- make sure that explict open braces match explicit close braces         | 0 : ms                <- mm@@ -170,19 +168,19 @@  -- push context for explict open paren. applyOffside ps ms -        (LexemeToken t@Token { tokenTok = KA KRoundBra } : ts)+        (    LexemeToken t@(Located _ (KA (KSymbol SRoundBra))) : ts)         = t : applyOffside (ParenRound : ps) ms ts  -- force close of block on close paren. -- This partially handles the crazy (Note 5) rule from the Haskell98 standard. applyOffside (ParenBrace : ps) (m : ms)-        (lt@(LexemeToken Token { tokenTok = KA KRoundKet }) : ts)+        (lt@(LexemeToken   (Located _ (KA (KSymbol SRoundKet)))) : ts)  | m /= 0  = newCKet ts : applyOffside ps ms (lt : ts)  -- pop context for explicit close paren. applyOffside (ParenRound : ps) ms -        (LexemeToken t@Token { tokenTok = KA KRoundKet } : ts)+        (    LexemeToken t@(Located _ (KA (KSymbol SRoundKet))) : ts)         = t : applyOffside ps ms ts  -- pass over tokens.@@ -196,20 +194,27 @@         = newCKet [] : applyOffside ps ms []  +isKeyword (Located _ tok) k+ = case tok of+        KA (KKeyword k')        -> k == k'+        _                       -> False+++ -- addStarts -------------------------------------------------------------------------------------- -- | Add block and line start tokens to this stream. -- --   This is identical to the definition in the Haskell98 report, --   except that we also use multi-token starting strings like --   'imports' 'foreign' 'type'.-addStarts :: (Eq n, Show n) => [Token (Tok n)] -> [Lexeme n]+addStarts :: (Eq n, Show n) => [Located (Token n)] -> [Lexeme n] addStarts ts  = case dropNewLines ts of          -- If the first lexeme of a module is not '{' then start a new block.         (t1 : tsRest)-          |  not $ or $ map (isToken t1) [KA KBraceBra]-          -> LexemeStartBlock (tokenColumn t1) : addStarts' (t1 : tsRest)+          |  not $ or $ map (isToken t1) [KA (KSymbol SBraceBra)]+          -> LexemeStartBlock (columnOfLocated t1) : addStarts' (t1 : tsRest)            | otherwise           -> addStarts' (t1 : tsRest)@@ -218,7 +223,7 @@         []      -> []  -addStarts'  :: Eq n => [Token (Tok n)] -> [Lexeme n]+addStarts'  :: Eq n => [Located (Token n)] -> [Lexeme n] addStarts' ts         -- Block started at end of input.         | Just (ts1, ts2)       <- splitBlockStart ts@@ -231,27 +236,27 @@         --  insert a new one.         | Just (ts1, ts2)       <- splitBlockStart ts         , t2 : tsRest           <- dropNewLines ts2-        , not $ isToken t2 (KA KBraceBra)+        , not $ isToken t2 (KA (KSymbol SBraceBra))         = [LexemeToken t | t <- ts1]-                ++ [LexemeStartBlock (tokenColumn t2)]+                ++ [LexemeStartBlock (columnOfLocated t2)]                 ++ addStarts' (t2 : tsRest)          -- check for start of list         | t1 : ts'              <- ts-        , isToken t1 (KA KBraceBra)+        , isToken t1 (KA (KSymbol SBraceBra))         = LexemeToken t1    : addStarts' ts'          -- check for end of list         | t1 : ts'              <- ts-        , isToken t1 (KA KBraceKet)+        , isToken t1 (KA (KSymbol SBraceKet))         = LexemeToken t1    : addStarts' ts'          -- check for start of new line         | t1 : ts'              <- ts         , isToken t1 (KM KNewLine)         , t2 : tsRest   <- dropNewLines ts'-        , not $ isToken t2 (KA KBraceBra)-        = LexemeStartLine (tokenColumn t2) +        , not $ isToken t2 (KA (KSymbol SBraceBra))+        = LexemeStartLine (columnOfLocated t2)                  : addStarts' (t2 : tsRest)          -- eat up trailine newlines@@ -267,8 +272,9 @@         | otherwise         = [] + -- | Drop newline tokens at the front of this stream.-dropNewLines :: Eq n => [Token (Tok n)] -> [Token (Tok n)]+dropNewLines :: Eq n => [Located (Token n)] -> [Located (Token n)] dropNewLines []              = [] dropNewLines (t1:ts)         | isToken t1 (KM KNewLine)@@ -293,48 +299,80 @@  -- | Check if a token is one that starts a block of statements. splitBlockStart -        :: [Token (Tok n)] -        -> Maybe ([Token (Tok n)], [Token (Tok n)])+        :: [Located (Token n)] +        -> Maybe ([Located (Token n)], [Located (Token n)])  splitBlockStart toks   -- export type- |  t1@Token { tokenTok = KA KExport }  : t2@Token { tokenTok = KA KType }    : ts+ |  t1@(Located _ (KA (KKeyword EExport)))+  : t2@(Located _ (KA (KKeyword EType)))+  : ts  <- toks = Just ([t1, t2], ts)   -- export value- |  t1@Token { tokenTok = KA KExport }  : t2@Token { tokenTok = KA KValue }   : ts+ |  t1@(Located _ (KA (KKeyword EExport)))+  : t2@(Located _ (KA (KKeyword EValue)))+  : ts  <- toks = Just ([t1, t2], ts)   -- export foreign X value- |  t1@Token { tokenTok = KA KExport }  : t2@Token { tokenTok = KA KForeign }-  : t3                                  : t4@Token { tokenTok = KA KValue }   : ts+ |  t1@(Located _ (KA (KKeyword EExport)))+  : t2@(Located _ (KA (KKeyword EForeign)))+  : t3                                  +  : t4@(Located _ (KA (KKeyword EValue)))+  : ts  <- toks = Just ([t1, t2, t3, t4], ts)   -- import type- |  t1@Token { tokenTok = KA KImport }  : t2@Token { tokenTok = KA KType  }   : ts+ |  t1@(Located _ (KA (KKeyword EImport)))+  : t2@(Located _ (KA (KKeyword EType)))+  : ts  <- toks = Just ([t1, t2], ts)   -- import value- |  t1@Token { tokenTok = KA KImport }  : t2@Token { tokenTok = KA KValue }   : ts+ |  t1@(Located _ (KA (KKeyword EImport)))+  : t2@(Located _ (KA (KKeyword EValue)))+  : ts  <- toks = Just ([t1, t2], ts) + -- import data+ |  t1@(Located _ (KA (KKeyword EImport)))+  : t2@(Located _ (KA (KKeyword EData)))+  : 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+ |  t1@(Located _ (KA (KKeyword EImport)))+  : t2@(Located _ (KA (KKeyword EForeign)))+  : t3                                  +  : t4@(Located _ (KA (KKeyword EType)))+  : ts  <- toks = Just ([t1, t2, t3, t4], ts) + -- import foreign X capability+ |  t1@(Located _ (KA (KKeyword EImport)))+  : t2@(Located _ (KA (KKeyword EForeign)))+  : t3+  : t4@(Located _ (KA (KKeyword ECapability)))+  : 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    + |  t1@(Located _ (KA (KKeyword EImport)))+  : t2@(Located _ (KA (KKeyword EForeign)))+  : t3                                  +  : t4@(Located _ (KA (KKeyword EValue)))+  : ts      <- toks = Just ([t1, t2, t3, t4], ts)  - |  t1@Token { tokenTok = KA KDo }      : ts    <- toks = Just ([t1], ts)- |  t1@Token { tokenTok = KA KOf }      : ts    <- toks = Just ([t1], ts)- |  t1@Token { tokenTok = KA KLetRec }  : ts    <- toks = Just ([t1], ts)- |  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@(Located _ (KA (KKeyword EDo)))     : ts    <- toks = Just ([t1], ts)+ |  t1@(Located _ (KA (KKeyword EOf)))     : ts    <- toks = Just ([t1], ts)+ |  t1@(Located _ (KA (KKeyword ELetRec))) : ts    <- toks = Just ([t1], ts)+ |  t1@(Located _ (KA (KKeyword EWhere)))  : ts    <- toks = Just ([t1], ts)+ |  t1@(Located _ (KA (KKeyword EExport))) : ts    <- toks = Just ([t1], ts)+ |  t1@(Located _ (KA (KKeyword EImport))) : ts    <- toks = Just ([t1], ts)+ |  t1@(Located _ (KA (KKeyword EMatch)))  : ts    <- toks = Just ([t1], ts)   | otherwise                                               = Nothing@@ -342,49 +380,55 @@  -- Utils ------------------------------------------------------------------------------------------ -- | Test whether this wrapper token matches.-isToken :: Eq n => Token (Tok n) -> Tok n -> Bool-isToken (Token tok _) tok2 = tok == tok2+isToken :: Eq n => Located (Token n) -> Token n -> Bool+isToken (Located _ tok) tok2+        = tok == tok2   -- | Test whether this wrapper token matches.-isKNToken :: Eq n => Token (Tok n) -> Bool-isKNToken (Token (KN _) _)      = True+isKNToken :: Eq n => Located (Token n) -> Bool+isKNToken (Located _ (KN _))    = True isKNToken _                     = False   -- | When generating new source tokens, take the position from the first --   non-newline token in this list-newCBra :: [Lexeme n] -> Token (Tok n)+newCBra      :: [Lexeme n] -> Located (Token n) newCBra ts-        = (takeTok ts) { tokenTok = KA KBraceBra }+ = case takeTok ts of+        Located sp _    -> Located sp (KA (KSymbol SBraceBra))  -newCKet :: [Lexeme n] -> Token (Tok n)+newCKet      :: [Lexeme n] -> Located (Token n) newCKet ts-        = (takeTok ts) { tokenTok = KA KBraceKet }+ = case takeTok ts of+        Located sp _    -> Located sp (KA (KSymbol SBraceKet))  -newSemiColon :: [Lexeme n] -> Token (Tok n)-newSemiColon ts -        = (takeTok ts) { tokenTok = KA KSemiColon }+newSemiColon :: [Lexeme n] -> Located (Token n)+newSemiColon ts+ = case takeTok ts of+        Located sp _    -> Located sp (KA (KSymbol SSemiColon))   -- | This is injected by `applyOffside` when it finds an explit close --   brace in a position where it would close a synthetic one.-newOffsideClosingBrace :: [Lexeme n] -> Token (Tok n)+newOffsideClosingBrace :: [Lexeme n] -> Located (Token n) newOffsideClosingBrace ts-        = (takeTok ts) { tokenTok = KM KOffsideClosingBrace }+ = case takeTok ts of+        Located sp _    -> Located sp (KM KOffsideClosingBrace)  -takeTok :: [Lexeme n] -> Token (Tok n)+takeTok :: [Lexeme n] -> Located (Token n) takeTok []      - = Token (KJunk "") (SourcePos "" 0 0)+ = Located (SourcePos "" 0 0) (KErrorJunk "")   takeTok (l : ls)  = case l of-        LexemeToken (Token { tokenTok = KM KNewLine })+        LexemeToken (Located _ (KM KNewLine))          -> takeTok ls          LexemeToken t           -> t         LexemeStartLine  _      -> takeTok ls         LexemeStartBlock _      -> takeTok ls+
+ DDC/Core/Lexer/Token/Builtin.hs view
@@ -0,0 +1,111 @@++module DDC.Core.Lexer.Token.Builtin+        ( Builtin (..)+        , sayBuiltin+        , scanBuiltin+        , acceptBuiltin)+where+import DDC.Core.Lexer.Token.Names+import DDC.Core.Exp+import DDC.Data.Pretty+import Text.Lexer.Inchworm.Char+import qualified Data.List      as List+import qualified Data.Char      as Char+++-------------------------------------------------------------------------------+-- | Builtin name tokens.+data Builtin+        = BSoCon        SoCon+        | BKiCon        KiCon+        | BTwCon        TwCon+        | BTcCon        TcCon++        | BPure+        | BEmpty++        | BDaConUnit+        deriving (Eq, Show)+++-------------------------------------------------------------------------------+-- | Yield the string name of a Builtin.+sayBuiltin :: Builtin -> String+sayBuiltin bb+ = case bb of+        BSoCon sc       -> renderPlain $ ppr sc+        BKiCon ki       -> renderPlain $ ppr ki+        BTwCon kw       -> renderPlain $ ppr kw+        BTcCon tc       -> renderPlain $ ppr tc+        BPure           -> "Pure"+        BEmpty          -> "Empty"+        BDaConUnit      -> "()"+++-------------------------------------------------------------------------------+-- | Scanner for builtin names.+scanBuiltin   :: Scanner IO Location [Char] (Location, Builtin)+scanBuiltin+ = munchPred Nothing matchConName acceptBuiltin+++-- | Accept a builtin name.+acceptBuiltin :: String -> Maybe Builtin+acceptBuiltin str+ | Just cc      <- acceptTwConWithArity str+ = Just (BTwCon cc)++acceptBuiltin str+ = case str of+        -- Sort constructors.+        "Prop"          -> Just (BSoCon SoConProp)+        "Comp"          -> Just (BSoCon SoConComp)++        -- Kind constructors.+        "Witness"       -> Just (BKiCon KiConWitness)+        "Data"          -> Just (BKiCon KiConData)+        "Region"        -> Just (BKiCon KiConRegion)+        "Effect"        -> Just (BKiCon KiConEffect)+        "Closure"       -> Just (BKiCon KiConClosure)++        -- Witness type constructors.+        "Const"         -> Just (BTwCon TwConConst)+        "DeepConst"     -> Just (BTwCon TwConDeepConst)+        "Mutable"       -> Just (BTwCon TwConMutable)+        "DeepMutable"   -> Just (BTwCon TwConDeepMutable)+        "Purify"        -> Just (BTwCon TwConPure)+        "Disjoint"      -> Just (BTwCon TwConDisjoint)+        "Distinct"      -> Just (BTwCon (TwConDistinct 2))++        -- Type constructors.+        "Unit"          -> Just (BTcCon (TcConUnit))+        "S"             -> Just (BTcCon (TcConSusp))+        "Read"          -> Just (BTcCon (TcConRead))+        "HeadRead"      -> Just (BTcCon (TcConHeadRead))+        "DeepRead"      -> Just (BTcCon (TcConDeepRead))+        "Write"         -> Just (BTcCon (TcConWrite))+        "DeepWrite"     -> Just (BTcCon (TcConDeepWrite))+        "Alloc"         -> Just (BTcCon (TcConAlloc))+        "DeepAlloc"     -> Just (BTcCon (TcConDeepAlloc))++        -- Builtin types.+        "Pure"          -> Just BPure+        "Empty"         -> Just BEmpty++        -- Builtin values.+        "()"            -> Just BDaConUnit++        _               -> Nothing+++acceptTwConWithArity :: String -> Maybe TwCon+acceptTwConWithArity ss+ | Just n <- List.stripPrefix "Distinct" ss + , not $ null n+ , all Char.isDigit n+ = Just (TwConDistinct $ read n)++ | otherwise+ = Nothing+ +
+ DDC/Core/Lexer/Token/Index.hs view
@@ -0,0 +1,21 @@++module DDC.Core.Lexer.Token.Index+        (scanIndex)+where+import Text.Lexer.Inchworm.Char         as I+import qualified Data.Char              as Char+++-- | Scan a deBruijn index.+scanIndex   :: Scanner IO Location [Char] (I.Location, Int)+scanIndex+ = I.munchPred Nothing matchIndex acceptIndex+ where+        matchIndex 0 '^'        = True+        matchIndex 0 _          = False+        matchIndex _ c          = Char.isDigit c++        acceptIndex ('^': xs)+         | not $ null xs        = return (read xs)+        acceptIndex _           = Nothing+
+ DDC/Core/Lexer/Token/Keyword.hs view
@@ -0,0 +1,139 @@++module DDC.Core.Lexer.Token.Keyword+        ( Keyword (..)+        , sayKeyword+        , scanKeyword)+where+import Text.Lexer.Inchworm.Char+import DDC.Core.Lexer.Token.Names+++-------------------------------------------------------------------------------+-- | Keyword tokens.+data Keyword+        -- core keywords.+        = EModule+        | EImport+        | EExport+        | EForeign+        | EType+        | ECapability+        | EValue+        | EData+        | EWith+        | EWhere+        | EIn+        | ELet+        | ELetCase+        | ELetRec+        | EPrivate+        | EExtend+        | EUsing+        | ECase+        | EOf+        | EWeakEff+        | EWeakClo+        | EPurify+        | EForget+        | EBox+        | ERun++        -- sugar keywords.+        | EDo+        | EMatch+        | EIf+        | EThen+        | EElse+        | EOtherwise+        deriving (Eq, Show)+++-------------------------------------------------------------------------------+-- | Yield the string name of a keyword.+sayKeyword :: Keyword -> String+sayKeyword kw+ = case kw of+        -- core keywords.+        EBox            -> "box"+        ECapability     -> "capability"+        ECase           -> "case"+        EData           -> "data"+        EExport         -> "export"+        EExtend         -> "extend"+        EForeign        -> "foreign"+        EForget         -> "forget"+        EImport         -> "import"+        EIn             -> "in"+        ELet            -> "let"+        ELetCase        -> "letcase"+        ELetRec         -> "letrec"+        EModule         -> "module"+        EOf             -> "of"+        EPrivate        -> "private"+        EPurify         -> "purify"+        ERun            -> "run"+        EType           -> "type"+        EValue          -> "value"+        EWhere          -> "where"+        EWeakClo        -> "weakclo"+        EWeakEff        -> "weakeff"+        EWith           -> "with"+        EUsing          -> "using"++        -- sugar keywords+        EDo             -> "do"+        EElse           -> "else"+        EIf             -> "if"+        EMatch          -> "match"+        EOtherwise      -> "otherwise"+        EThen           -> "then"++++-------------------------------------------------------------------------------+-- | Scanner for a `Keyword`.+scanKeyword :: Scanner IO Location [Char] (Location, Keyword)+scanKeyword+ = munchPred Nothing matchVarName acceptKeyword++-- | Accept a keyword token.+acceptKeyword :: String -> Maybe Keyword+acceptKeyword str+ = case str of+        -- core keywords+        "box"           -> Just EBox+        "capability"    -> Just ECapability+        "case"          -> Just ECase+        "data"          -> Just EData+        "export"        -> Just EExport+        "extend"        -> Just EExtend+        "foreign"       -> Just EForeign+        "forget"        -> Just EForget+        "import"        -> Just EImport+        "in"            -> Just EIn+        "let"           -> Just ELet+        "letcase"       -> Just ELetCase+        "letrec"        -> Just ELetRec+        "module"        -> Just EModule+        "of"            -> Just EOf+        "private"       -> Just EPrivate+        "purify"        -> Just EPurify+        "run"           -> Just ERun+        "type"          -> Just EType+        "value"         -> Just EValue+        "where"         -> Just EWhere+        "weakclo"       -> Just EWeakClo+        "weakeff"       -> Just EWeakEff+        "with"          -> Just EWith+        "using"         -> Just EUsing++        -- sugar keywords+        "do"            -> Just EDo+        "else"          -> Just EElse+        "if"            -> Just EIf+        "match"         -> Just EMatch+        "otherwise"     -> Just EOtherwise+        "then"          -> Just EThen++        _               -> Nothing+
+ DDC/Core/Lexer/Token/Literal.hs view
@@ -0,0 +1,246 @@++module DDC.Core.Lexer.Token.Literal+        ( Literal       (..)+        , scanLiteral++        , isLitName+        , isLitStart+        , isLitBody++        , readLitInteger+        , readLitNat+        , readLitInt+        , readLitSize+        , readLitWordOfBits+        , readLitFloatOfBits+        , readBinary+        , readHex)+where+import DDC.Core.Exp.Literal+import Text.Lexer.Inchworm.Char+import qualified Data.Char              as Char+import qualified Data.List              as List+import qualified Data.Text              as Text+++-- Literal --------------------------------------------------------------------+scanLiteral   :: Scanner IO Location [Char] (Location, (Literal, Bool))+scanLiteral + = alts [ munchPred Nothing matchLiteral acceptLiteral++          -- Character literals with Haskell style escape codes.+        , do    (loc, c)    <- scanHaskellChar+                alts [ do _  <- satisfies (\c' -> c' == '#')+                          return (loc, (LChar  c, True))++                     , do return (loc, (LChar  c, False)) ]++          -- String literals with Haskell style escape codes.+        , do    (loc, str)  <- scanHaskellString +                alts [ do _ <- satisfies (\c -> c == '#')+                          return (loc, (LString (Text.pack str), True))++                     , do return (loc, (LString (Text.pack str), False))+                     ]+        ]+++-- | Match a literal character.+matchLiteral  :: Int -> Char -> Bool+matchLiteral 0 c = isLitStart c+matchLiteral _ c = isLitBody c+++-- | Accept a literal.+acceptLiteral :: String -> Maybe (Literal, Bool)+acceptLiteral str+ | ('#' : str') <- reverse str+ , Just lit     <- acceptLit  (reverse str')+ = Just (lit, True)++ | Just lit     <- acceptLit str+ = Just (lit, False)++ | otherwise+ = Nothing+ where acceptLit str'+        | Just i        <- readLitNat         str'      = Just (LNat   i)+        | Just i        <- readLitInt         str'      = Just (LInt   i)+        | Just i        <- readLitSize        str'      = Just (LSize  i)+        | Just (u, b)   <- readLitWordOfBits  str'      = Just (LWord  u b)+        | Just (f, b)   <- readLitFloatOfBits str'      = Just (LFloat f b)+        | otherwise                                     = Nothing+++-------------------------------------------------------------------------------+-- | String is the name of a literal.+isLitName :: String -> Bool+isLitName str+ = case str of+        []      -> False+        c : cs+         | isLitStart c+         , and (map isLitBody cs)+         -> True++         | otherwise+         -> False+++-- | Character can start a literal.+isLitStart :: Char -> Bool+isLitStart c+        =   Char.isDigit c+        ||  c == '-'+++-- | Character can be part of a literal body.+isLitBody :: Char -> Bool+isLitBody c+        =  Char.isDigit c+        || c == 'b' || c == 'o' || c == 'x'+        || c == 'w' || c == 'f' || c == 'i' || c == 's'+        || c == '.'+        || c == '#'+        || c == '\''++++-------------------------------------------------------------------------------+-- | Read a signed integer.+readLitInteger :: String -> Maybe Integer+readLitInteger []       = Nothing+readLitInteger str@(c:cs)+        | '-'           <- c+        , all Char.isDigit cs+        = Just $ read str++        | all Char.isDigit cs+        = Just $ read str+        +        | otherwise+        = Nothing+        ++-- | Read an integer with an explicit format specifier like @1234i@.+readLitNat :: String -> Maybe Integer+readLitNat str1+        | (ds, "")      <- List.span Char.isDigit str1+        , not  $ null ds+        = Just $ read ds++        | otherwise+        = Nothing+++-- | Read an integer literal with an explicit format specifier like @1234i@.+readLitInt :: String -> Maybe Integer+readLitInt str1+        | '-' : str2    <- str1+        , (ds, "i")     <- List.span Char.isDigit str2+        , not  $ null ds+        = Just $ negate $ read ds++        | (ds, "i")     <- List.span Char.isDigit str1+        , not  $ null ds+        = Just $ read ds++        | otherwise+        = Nothing+++-- | Read an size literal with an explicit format specifier like @1234s@.+readLitSize :: String -> Maybe Integer+readLitSize str1+        | '-' : str2    <- str1+        , (ds, "s")     <- List.span Char.isDigit str2+        , not  $ null ds+        = Just $ negate $ read ds++        | (ds, "s")     <- List.span Char.isDigit str1+        , not  $ null ds+        = Just $ read ds++        | otherwise+        = Nothing+++-- | Read a word with an explicit format speficier.+readLitWordOfBits :: String -> Maybe (Integer, Int)+readLitWordOfBits str1+        -- binary like 0b01001w32+        | Just str2     <- List.stripPrefix "0b" str1+        , (ds, str3)    <- List.span (\c -> c == '0' || c == '1') str2+        , not $ null ds+        , Just str4     <- List.stripPrefix "w" str3+        , (bs, "")      <- List.span Char.isDigit str4+        , not $ null bs+        , bits          <- read bs+        , length ds     <= bits+        = Just (readBinary ds, bits)++        -- hex like 0x0ffw32+        | Just str2     <- List.stripPrefix "0x" str1+        , (ds, str3)    <- List.span (\c -> elem c ['0' .. '9']+                                         || elem c ['A' .. 'F']+                                         || elem c ['a' .. 'f']) str2+        , not $ null ds+        , Just str4     <- List.stripPrefix "w" str3+        , (bs, "")      <- List.span Char.isDigit str4+        , not $ null bs+        , bits          <- read bs+        , length ds     <= bits+        = Just (readHex ds, bits)++        -- decimal like 1234w32+        | (ds, str2)    <- List.span Char.isDigit str1+        , not $ null ds+        , Just str3     <- List.stripPrefix "w" str2+        , (bs, "")      <- List.span Char.isDigit str3+        , not $ null bs+        = Just (read ds, read bs)++        | otherwise+        = Nothing+++-- | Read a float literal with an explicit format specifier like @123.00f32#@.+readLitFloatOfBits :: String -> Maybe (Double, Int)+readLitFloatOfBits str1+        | '-' : str2    <- str1+        , Just (d, bs)  <- readLitFloatOfBits str2+        = Just (negate d, bs)++        | (ds1, str2)   <- List.span Char.isDigit str1+        , not $ null ds1+        , Just str3     <- List.stripPrefix "." str2+        , (ds2, str4)   <- List.span Char.isDigit str3+        , not $ null ds2+        , Just str5     <- List.stripPrefix "f" str4+        , (bs, "")      <- List.span Char.isDigit str5+        , not $ null bs+        = Just (read (ds1 ++ "." ++ ds2), read bs)++        | otherwise+        = Nothing+++-- | Read a binary string as a number.+readBinary :: Num a => String -> a+readBinary digits+        = List.foldl' (\acc b -> if b then 2 * acc + 1 else 2 * acc) 0+        $ map (/= '0') digits+++-- | Read a hex string as a number.+readHex    :: (Enum a, Num a) => String -> a+readHex digits+        = List.foldl' (\acc d -> let Just v = lookup d table+                                 in  16 * acc + v) 0+        $ digits++ where table+        =  zip ['0' .. '9'] [0  .. 9]+        ++ zip ['a' .. 'f'] [10 .. 15]+        ++ zip ['A' .. 'F'] [10 .. 15]+
+ DDC/Core/Lexer/Token/Names.hs view
@@ -0,0 +1,141 @@++module DDC.Core.Lexer.Token.Names+        ( -- * Variable names+          scanVarName+        , matchVarName+        , acceptVarName+        , isVarName+        , isVarStart+        , isVarBody++          -- * Constructor names+        , scanConName+        , matchConName+        , acceptConName+        , isConName+        , isConStart+        , isConBody)+where+import Text.Lexer.Inchworm.Char+import DDC.Data.ListUtils+import qualified Data.Char      as Char+++-- Variable names ---------------------------------------------------------------------------------+-- | Scanner for variable anmes.+scanVarName   :: Scanner IO Location [Char] (Location, String)+scanVarName + = munchPred Nothing matchVarName acceptVarName+++-- | Match a variable name.+matchVarName :: Int -> Char -> Bool+matchVarName 0 c        = isVarStart c+matchVarName _ c        = isVarBody  c+++-- | Accept a variable name.+acceptVarName :: String -> Maybe String+acceptVarName ss+        | isVarName ss  = Just ss+        | otherwise     = Nothing+++-- | Check if this string is a variable name.+isVarName :: String -> Bool+isVarName str+ = case str of+     []          -> False+     c : cs +        |  isVarStart c +        ,  and (map isVarBody cs)+        -> True+        +        | _ : _         <- cs+        ,  Just initCs   <- takeInit cs+        ,  isVarStart c+        ,  and (map isVarBody initCs)+        ,  last cs == '#'+        -> True++        | otherwise+        -> False+++-- | Charater can start a variable name.+isVarStart :: Char -> Bool+isVarStart c+        =  Char.isLower c+        || c == '?'+        || c == '_'+        ++-- | Character can be part of a variable body.+isVarBody  :: Char -> Bool+isVarBody c+        =  Char.isUpper c +        || Char.isLower c +        || Char.isDigit c +        || c == '_' +        || c == '\'' +        || c == '$'+        || c == '#'+++-- Constructor names ------------------------------------------------------------------------------+-- | Scanner for constructor names.+scanConName   :: Scanner IO Location [Char] (Location, String)+scanConName + = munchPred Nothing matchConName acceptConName+++-- | Match a constructor name.+matchConName  :: Int -> Char -> Bool+matchConName 0 c        = isConStart c+matchConName _ c        = isConBody  c+++-- | Accept a constructor name.+acceptConName :: String -> Maybe String+acceptConName ss+        | isConName ss  = Just ss+        | otherwise     = Nothing+++-- | String is a constructor name.+isConName :: String -> Bool+isConName str+ = case str of+     []          -> False+     c : cs +        |  isConStart c +        ,  and (map isConBody cs)+        -> True+        +        | _ : _         <- cs+        ,  Just initCs   <- takeInit cs+        ,  isConStart c+        ,  and (map isConBody initCs)+        ,  last cs == '#'+        -> True++        | otherwise+        -> False+++-- | Character can start a constructor name.+isConStart :: Char -> Bool+isConStart +        = Char.isUpper+++-- | Charater can be part of a constructor body.+isConBody  :: Char -> Bool+isConBody c     +        =  Char.isUpper c +        || Char.isLower c +        || Char.isDigit c +        || c == '_'+        || c == '\''+        || c == '#'+
+ DDC/Core/Lexer/Token/Operator.hs view
@@ -0,0 +1,110 @@++module DDC.Core.Lexer.Token.Operator+        ( scanPrefixOperator+        , scanInfixOperator+        , acceptInfixOperator+        , isOpName+        , isOpStart+        , isOpBody)+where+import Text.Lexer.Inchworm.Char+import DDC.Core.Lexer.Unicode+import qualified Data.Set       as Set+import qualified Data.List      as List+++-------------------------------------------------------------------------------+-- | Scanner for operators used prefix.+scanPrefixOperator :: Scanner IO Location [Char] (Location, String)+scanPrefixOperator + = munchPred Nothing matchPrefixOperator acceptPrefixOperator+++-- | Patch a prefix operator name.+matchPrefixOperator :: Int -> Char -> Bool+matchPrefixOperator 0 c         = c == '('+matchPrefixOperator _ c         = isOpBody c || c == ')'+++-- | Accept a prefix operator name.+acceptPrefixOperator :: String -> Maybe String+acceptPrefixOperator str+        | '(' : cs1     <- str+        , c   : cs2     <- cs1+        , isOpStart c+        , (body , cs3)  <- List.span isOpBody cs2+        , ')' : []      <- cs3+        , not $ null (c : body)+        = Just (c : body)++        | otherwise+        = Nothing++++-------------------------------------------------------------------------------+-- | Scanner for operators used infix.+scanInfixOperator  :: Scanner IO Location [Char] (Location, String)+scanInfixOperator + = munchPred Nothing matchInfixOperator acceptInfixOperator+++-- | Match an operator name.+matchInfixOperator  :: Int -> Char -> Bool+matchInfixOperator 0 c       = isOpStart c+matchInfixOperator _ c       = isOpBody  c+++-- | Accept an operator name.+acceptInfixOperator :: String -> Maybe String+acceptInfixOperator str+ = case str of+        "="     -> Nothing+        "|"     -> Nothing+        "~>"    -> Nothing+        "->"    -> Nothing+        "<-"    -> Nothing+        "=>"    -> Nothing+        "/\\"   -> Nothing+        _       -> Just str+++-- | String is the name of some operator.+isOpName :: String -> Bool+isOpName str+ = case str of+        []      -> False+        c : cs+         | isOpStart c+         , and (map isOpBody cs)+         -> True++         | otherwise+         -> False+++-- | Character can start an operator.+isOpStart :: Char -> Bool+isOpStart c+        =  c == '~'     || c == '!'                     || c == '#'     +        || c == '$'     || c == '%'                     || c == '&'     +        || c == '*'     || c == '-'     || c == '+'     || c == '='+        || c == ':'                     || c == '/'     || c == '|'+        || c == '<'     || c == '>'+        || Set.member c unicodeOperatorsInfix+++-- | Character can be part of an operator body.+isOpBody :: Char -> Bool+isOpBody c+        =  c == '~'     || c == '!'                     || c == '#'     +        || c == '$'     || c == '%'                     || c == '&'     +        || c == '*'     || c == '-'     || c == '+'     || c == '='+        || c == ':'     || c == '?'     || c == '/'     || c == '|'+        || c == '<'     || c == '>'+        || c == '\\'+        || Set.member c unicodeOperatorsInfix++++
+ DDC/Core/Lexer/Token/Symbol.hs view
@@ -0,0 +1,166 @@++module DDC.Core.Lexer.Token.Symbol+        ( Symbol (..)+        , saySymbol+        , scanSymbol+        , acceptSymbol1+        , acceptSymbol2)+where+import Text.Lexer.Inchworm.Char+++-------------------------------------------------------------------------------+-- | Symbol tokens.+data Symbol+        -- Single char parenthesis+        = SRoundBra             -- ^ Like '('+        | SRoundKet             -- ^ Like ')'+        | SSquareBra            -- ^ Like '['+        | SSquareKet            -- ^ Like ']'+        | SBraceBra             -- ^ Like '{'+        | SBraceKet             -- ^ Like '}'++        -- Compound parenthesis+        | SSquareColonBra       -- ^ Like '[:'+        | SSquareColonKet       -- ^ Like ':]'+        | SBraceColonBra        -- ^ Like '{:'+        | SBraceColonKet        -- ^ Like ':}'++        -- Compound symbols.+        | SBigLambdaSlash       -- ^ Like '/\\'+        | SArrowTilde           -- ^ Like '~>'+        | SArrowDashRight       -- ^ Like '->'+        | SArrowDashLeft        -- ^ Like '<-'+        | SArrowEquals          -- ^ Like '=>'++        -- Other punctuation.+        | SAt                   -- ^ Like '@'+        | SHat                  -- ^ Like '^'+        | SDot                  -- ^ Like '.'+        | SBar                  -- ^ Like '|'+        | SComma                -- ^ Like ','+        | SEquals               -- ^ Like '='+        | SLambda               -- ^ Like 'λ'+        | SSemiColon            -- ^ Like ';'+        | SBackSlash            -- ^ Like '\\'+        | SBigLambda            -- ^ Like 'Λ'+        | SUnderscore           -- ^ Like '_'+        deriving (Eq, Show)+++-------------------------------------------------------------------------------+-- | Yield the string name of a symbol token.+saySymbol :: Symbol -> String+saySymbol pp+ = case pp of+        -- Single character symbols.+        SRoundBra               -> "("+        SRoundKet               -> ")"+        SSquareBra              -> "["+        SSquareKet              -> "]"+        SBraceBra               -> "{"+        SBraceKet               -> "}"+        +        -- Compound parenthesis.+        SSquareColonBra         -> "[:"+        SSquareColonKet         -> ":]"+        SBraceColonBra          -> "{:"+        SBraceColonKet          -> ":}"++        -- Compound symbols.+        SBigLambdaSlash         -> "/\\"+        SArrowTilde             -> "~>"+        SArrowDashRight         -> "->"+        SArrowDashLeft          -> "<-"+        SArrowEquals            -> "=>"++        -- Other punctuation.+        SAt                     -> "@"+        SHat                    -> "^"+        SDot                    -> "."+        SBar                    -> "|"+        SComma                  -> ","+        SEquals                 -> "="+        SLambda                 -> "λ"+        SSemiColon              -> ";"+        SBackSlash              -> "\\"+        SBigLambda              -> "Λ"+        SUnderscore             -> "_"+++-------------------------------------------------------------------------------+-- | Scanner for a `Symbol`.+scanSymbol :: Scanner IO Location [Char] (Location, Symbol)+scanSymbol+ = alt  (munchPred Nothing matchSymbol2 acceptSymbol2)+        (from      acceptSymbol1)+++-- | Match a potential symbol character.+matchSymbol2 :: Int -> Char -> Bool+matchSymbol2 0 c+ = case c of+        '['     -> True+        '{'     -> True+        ':'     -> True+        '/'     -> True+        '~'     -> True+        '-'     -> True+        '<'     -> True+        '='     -> True+        _       -> False++matchSymbol2 1 c+ = case c of+        ']'     -> True+        '}'     -> True+        ':'     -> True+        '\\'    -> True+        '>'     -> True+        '-'     -> True+        _       -> False++matchSymbol2 _ _+ = False+++-- | Accept a double character symbol.+acceptSymbol2 :: String -> Maybe Symbol+acceptSymbol2 ss+ = case ss of+        "[:"    -> Just SSquareColonBra+        ":]"    -> Just SSquareColonKet+        "{:"    -> Just SBraceColonBra+        ":}"    -> Just SBraceColonKet+        "/\\"   -> Just SBigLambdaSlash+        "~>"    -> Just SArrowTilde+        "->"    -> Just SArrowDashRight+        "<-"    -> Just SArrowDashLeft+        "=>"    -> Just SArrowEquals+        _       -> Nothing+++-- | Accept a single character symbol.+acceptSymbol1 :: Char -> Maybe Symbol+acceptSymbol1 c + = case c of+        '('     -> Just SRoundBra+        ')'     -> Just SRoundKet+        '['     -> Just SSquareBra+        ']'     -> Just SSquareKet+        '{'     -> Just SBraceBra+        '}'     -> Just SBraceKet+        'λ'     -> Just SLambda+        'Λ'     -> Just SBigLambda+        '\\'    -> Just SBackSlash+        '@'     -> Just SAt+        '^'     -> Just SHat+        '.'     -> Just SDot+        '|'     -> Just SBar+        ','     -> Just SComma+        '='     -> Just SEquals+        ';'     -> Just SSemiColon+        '_'     -> Just SUnderscore+        '→'     -> Just SArrowDashRight+        '←'     -> Just SArrowDashLeft+        _       -> Nothing
DDC/Core/Lexer/Tokens.hs view
@@ -1,25 +1,64 @@  module DDC.Core.Lexer.Tokens-        ( -- * Tokens-          Tok      (..)-        , renameTok-        , describeTok+        ( Located (..)+        , columnOfLocated -          -- * Meta Tokens-        , TokMeta  (..)-        , describeTokMeta+          -- * Tokens+        , Token         (..)      +        , TokenMeta     (..)      +        , TokenAtom     (..)      +        , TokenNamed    (..)     -          -- * Atomic Tokens-        , TokAtom  (..)-        , describeTokAtom+        , Keyword       (..)+        , Symbol        (..)+        , Builtin       (..)+        , Literal       (..) -          -- * Named Tokens-        , TokNamed (..)-        , describeTokNamed)+          -- ** Description+        , describeToken+        , describeTokenMeta+        , describeTokenAtom+        , describeTokenNamed+        , sayKeyword+        , saySymbol+        , sayBuiltin++          -- ** Renaming+        , renameToken++          -- ** Predicates+        , isVarName+        , isVarStart+        , isVarBody++        , isConName+        , isConStart+        , isConBody++        , isLitName+        , isLitStart+        , isLitBody++          -- ** Literal Reading+        , readLitInteger+        , readLitNat+        , readLitInt+        , readLitSize+        , readLitWordOfBits+        , readLitFloatOfBits+        , readBinary+        , readHex) where+import DDC.Data.SourcePos+import DDC.Core.Lexer.Token.Symbol+import DDC.Core.Lexer.Token.Keyword+import DDC.Core.Lexer.Token.Builtin+import DDC.Core.Lexer.Token.Literal+import DDC.Core.Lexer.Token.Names import DDC.Core.Pretty-import DDC.Core.Exp import Control.Monad+import Data.Text                (Text)+import qualified Data.Text      as T   -- TokenFamily ----------------------------------------------------------------@@ -32,6 +71,8 @@         | Keyword         | Constructor         | Index+        | Literal+        | Pragma   -- | Describe a token family, for parser error messages.@@ -42,62 +83,73 @@         Keyword         -> "keyword"         Constructor     -> "constructor"         Index           -> "index"+        Literal         -> "literal"+        Pragma          -> "pragma"  --- Tok ------------------------------------------------------------------------+-- Token ------------------------------------------------------------------------ -- | Tokens accepted by the core language parser.-data Tok n+data Token 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+        | KM    !TokenMeta          -- | Atomic tokens are keywords, punctuation and baked-in          --   constructor names.-        | KA    !TokAtom +        | KA    !TokenAtom           -- | A named token that is specific to the language fragment          --   (maybe it's a primop), or a user defined name.-        | KN    !(TokNamed n)+        | KN    !(TokenNamed n)         deriving (Eq, Show)   -- | Apply a function to all the names in a `Tok`.-renameTok+renameToken         :: Ord n2         => (n1 -> Maybe n2) -        -> Tok n1 -        -> Maybe (Tok n2)+        -> Token n1 +        -> Maybe (Token n2) -renameTok f kk+renameToken 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+        KN t    -> liftM KN $ renameTokenNamed f t   -- | Describe a token for parser error messages.-describeTok :: Pretty n => Tok n -> String-describeTok kk+describeToken :: Pretty n => Token n -> String+describeToken kk  = case kk of-        KJunk c         -> "character " ++ show c-        KM tm           -> describeTokMeta  tm-        KA ta           -> describeTokAtom  ta-        KN tn           -> describeTokNamed tn+        KErrorJunk c    -> "character " ++ show c+        KErrorUnterm _  -> "unterminated string"+        KM tm           -> describeTokenMeta  tm+        KA ta           -> describeTokenAtom  ta+        KN tn           -> describeTokenNamed tn   -- TokMeta -------------------------------------------------------------------- -- | Meta tokens contain out-of-band information that is  --   eliminated before parsing proper.-data TokMeta+data TokenMeta         = KNewLine-        | KCommentLineStart-        | KCommentBlockStart-        | KCommentBlockEnd +        -- | Comment string.+        | KComment String+         -- | This is injected by `dropCommentBlock` when it finds         --   an unterminated block comment.         | KCommentUnterminated@@ -109,13 +161,11 @@   -- | Describe a TokMeta, for lexer error messages.-describeTokMeta :: TokMeta -> String-describeTokMeta tm+describeTokenMeta :: TokenMeta -> String+describeTokenMeta tm  = case tm of         KNewLine                -> "new line"-        KCommentLineStart       -> "comment start"-        KCommentBlockStart      -> "block comment start"-        KCommentBlockEnd        -> "block comment end"+        KComment{}              -> "comment"         KCommentUnterminated    -> "unterminated block comment"         KOffsideClosingBrace    -> "closing brace" @@ -124,247 +174,79 @@ -- | Atomic tokens are keywords, punctuation and baked-in constructor names. --   They don't contain user-defined names or primops specific to the  --   language fragment.-data TokAtom-        ------------------------------------------        -- Parens-        = KRoundBra-        | KRoundKet-        | KSquareBra-        | KSquareKet-        | KBraceBra-        | KBraceKet--        ------------------------------------------        -- Compound parens-        | KSquareColonBra-        | KSquareColonKet-        | KBraceColonBra-        | KBraceColonKet--        ------------------------------------------        -- Operator symbols-        -- These can be used as part of an infix operator.-        | KOp     String        -- ^ Naked operator,   like in 1 + 2.-        | KOpVar  String        -- ^ Wrapped operator, like in (+) 1 2.-        -        ------------------------------------------        -- Operator body symbols.-        --   These can be used in an operator body, but cannot start an operator.-        -        -- Allowing '^' to start an operator causes problems in type signatures.-        --   We end up lexing a '^^^' operator with  '[^^^ : Int]'-        --   and a '^:' operator in                  '[^:Int]'-        | KHat--        ------------------------------------------        -- Punctuation symbols.-        --   These cannot be used as part of an infix operator.-        -        -- Allowing '.' in an operator conflicts with trailing big-lambdas.-        --   We end up lexing './' as an operator in '\(x:Int)./\(a : Data)'-        | KDot-        -        | KComma           -        | KSemiColon-        | KUnderscore-        | KBackSlash-        -        ------------------------------------------        -- Compound symbols.-        | KBigLambda--        ------------------------------------------        -- symbolic constructors-        | KArrowTilde-        | KArrowDash-        | KArrowDashLeft-        | KArrowEquals--        ------------------------------------------        -- bottoms-        | KBotEffect-        | KBotClosure--        ------------------------------------------        -- core keywords-        | KModule-        | KImport-        | KExport-        | KForeign-        | KType-        | KValue-        | KData-        | KWith-        | KWhere-        | KIn-        | KLet-        | KLetCase-        | KLetRec-        | KPrivate-        | KExtend-        | KUsing-        | KWithRegion-        | KCase-        | KOf-        | KWeakEff-        | KWeakClo-        | KPurify-        | KForget-        | KBox-        | KRun--        ------------------------------------------        -- sugar keywords-        | KDo-        | KMatch-        | KElse+data TokenAtom+        -- | Pragmas.+        = KPragma  Text -        ------------------------------------------        -- debruijn indices-        | KIndex Int+        -- | Symbols.+        | KSymbol  Symbol -        ------------------------------------------        -- builtin names -        --   sort constructors.-        | KSoConBuiltin SoCon+        -- | Keywords.+        | KKeyword Keyword -        --   kind constructors.-        | KKiConBuiltin KiCon+        -- | Builtin names.+        | KBuiltin Builtin -        --   witness type constructors.-        | KTwConBuiltin TwCon+        -- | Infix operators, like in 1 + 2.+        | KOp      String -        --   witness constructors.-        | KWbConBuiltin WbCon+        -- | Wrapped operator, like in (+) 1 2.+        | KOpVar   String        -        --   other builtin spec constructors.-        | KTcConBuiltin TcCon+        -- | Debrujn indices.+        | KIndex   Int -        --   the unit data constructor.-        | KDaConUnit+        -- | Literal values.+        | KLiteral +                Literal         -- Literal value.+                Bool            -- Trailing '#' prim specifier.         deriving (Eq, Show)   -- | Describe a `TokAtom`, for parser error messages.-describeTokAtom  :: TokAtom -> String-describeTokAtom ta- = let  (family, str)           = describeTokAtom' ta+describeTokenAtom  :: TokenAtom -> String+describeTokenAtom ta+ = let  (family, str)           = describeTokenAtom' ta    in   describeTokenFamily family ++ " " ++ show str -describeTokAtom' :: TokAtom -> (TokenFamily, String)-describeTokAtom' ta+describeTokenAtom' :: TokenAtom -> (TokenFamily, String)+describeTokenAtom' ta  = case ta of-        -- parens-        KRoundBra               -> (Symbol, "(")-        KRoundKet               -> (Symbol, ")")-        KSquareBra              -> (Symbol, "[")-        KSquareKet              -> (Symbol, "]")-        KBraceBra               -> (Symbol, "{")-        KBraceKet               -> (Symbol, "}")-        -        -- compound parens-        KSquareColonBra         -> (Symbol, "[:")-        KSquareColonKet         -> (Symbol, ":]")-        KBraceColonBra          -> (Symbol, "{:")-        KBraceColonKet          -> (Symbol, ":}")+        KPragma p       -> (Pragma,  "{-#" ++ T.unpack p ++ "#-}")+        KSymbol  ss     -> (Symbol,      saySymbol ss)+        KKeyword kw     -> (Keyword,     sayKeyword kw)+        KBuiltin bb     -> (Constructor, sayBuiltin bb)+        KOp      op     -> (Symbol, op)+        KOpVar   op     -> (Symbol, "(" ++ op ++ ")")+        KIndex   i      -> (Index,   "^" ++ show i)+        KLiteral l b    -> (Literal, show (l, b)) -        -- operator symbols-        KOp    op               -> (Symbol, op)-        KOpVar op               -> (Symbol, "(" ++ op ++ ")")-        -        -- operator body symbols-        KHat                    -> (Symbol, "^") -        -- punctuation symbols-        KDot                    -> (Symbol, ".")-        KComma                  -> (Symbol, ",")-        KSemiColon              -> (Symbol, ";")-        KUnderscore             -> (Symbol, "_")-        KBackSlash              -> (Symbol, "\\")-        KBigLambda              -> (Symbol, "/\\")--        -- symbolic constructors-        KArrowTilde             -> (Constructor, "~>")-        KArrowDash              -> (Constructor, "->")-        KArrowDashLeft          -> (Constructor, "<-")-        KArrowEquals            -> (Constructor, "=>")--        -- bottoms-        KBotEffect              -> (Constructor, "Pure")-        KBotClosure             -> (Constructor, "Empty")-        -        -- expression keywords-        KModule                 -> (Keyword, "module")-        KImport                 -> (Keyword, "import")-        KExport                 -> (Keyword, "export")-        KForeign                -> (Keyword, "foreign")-        KType                   -> (Keyword, "type")-        KValue                  -> (Keyword, "value")-        KData                   -> (Keyword, "data")-        KWith                   -> (Keyword, "with")-        KWhere                  -> (Keyword, "where")-        KIn                     -> (Keyword, "in")-        KLet                    -> (Keyword, "let")-        KLetCase                -> (Keyword, "letcase")-        KLetRec                 -> (Keyword, "letrec")-        KPrivate                -> (Keyword, "private")-        KExtend                 -> (Keyword, "extend")-        KUsing                  -> (Keyword, "using")-        KWithRegion             -> (Keyword, "withregion")-        KCase                   -> (Keyword, "case")-        KOf                     -> (Keyword, "of")-        KWeakEff                -> (Keyword, "weakeff")-        KWeakClo                -> (Keyword, "weakclo")-        KPurify                 -> (Keyword, "purify")-        KForget                 -> (Keyword, "forget")-        KBox                    -> (Keyword, "box")-        KRun                    -> (Keyword, "run")--        -- sugar keywords-        KDo                     -> (Keyword, "do")-        KMatch                  -> (Keyword, "match")-        KElse                   -> (Keyword, "else")--        -- debruijn indices-        KIndex i                -> (Index,   "^" ++ show i)--        -- 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, "()")-        - -- TokNamed ------------------------------------------------------------------- -- | A token with a user-defined name.-data TokNamed n+data TokenNamed n         = KCon n         | KVar n-        | KLit n         deriving (Eq, Show)   -- | Describe a `TokNamed`, for parser error messages.-describeTokNamed :: Pretty n => TokNamed n -> String-describeTokNamed tn+describeTokenNamed :: Pretty n => TokenNamed n -> String+describeTokenNamed tn  = case tn of         KCon n  -> renderPlain $ text "constructor" <+> (dquotes $ ppr n)         KVar n  -> renderPlain $ text "variable"    <+> (dquotes $ ppr n)-        KLit n  -> renderPlain $ text "literal"     <+> (dquotes $ ppr n)   -- | Apply a function to all the names in a `TokNamed`.-renameTokNamed +renameTokenNamed          :: Ord n2         => (n1 -> Maybe n2) -        -> TokNamed n1 -        -> Maybe (TokNamed n2)+        -> TokenNamed n1 +        -> Maybe (TokenNamed n2) -renameTokNamed f kk+renameTokenNamed f kk   = case kk of         KCon c           -> liftM KCon $ f c         KVar c           -> liftM KVar $ f c-        KLit c           -> liftM KLit $ f c
+ DDC/Core/Lexer/Unicode.hs view
@@ -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+        ]
DDC/Core/Load.hs view
@@ -31,19 +31,18 @@ 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-import DDC.Base.Pretty-import DDC.Data.Token+import DDC.Data.Pretty import DDC.Core.Fragment                        (Fragment)+import qualified DDC.Core.Env.EnvX              as EnvX import qualified DDC.Core.Fragment              as F import qualified DDC.Core.Parser                as C import qualified DDC.Core.Check                 as C-import qualified DDC.Type.Check                 as T-import qualified DDC.Type.Env                   as Env-import qualified DDC.Base.Parser                as BP+import qualified DDC.Control.Parser             as BP+import qualified Data.Map.Strict                as Map import Data.Map.Strict                          (Map) import System.Directory @@ -53,7 +52,7 @@ data Error n err         = ErrorRead       !String         | ErrorParser     !BP.ParseError-        | ErrorCheckType  !(T.Error n)      +        | ErrorCheckType  !(C.Error BP.SourcePos n)               | ErrorCheckExp   !(C.Error BP.SourcePos n)         | ErrorCompliance !(F.Error (C.AnTEC BP.SourcePos n) n)         | ErrorFragment   !(err (C.AnTEC BP.SourcePos n))@@ -140,7 +139,7 @@         => Fragment n err               -- ^ Language fragment definition.         -> FilePath                     -- ^ Path to source file for error messages.         -> Mode n                       -- ^ Type checker mode.-        -> [Token (Tok n)]              -- ^ Source tokens.+        -> [Located (Token n)]          -- ^ Source tokens.         -> ( Either (Error n err)                      (Module (C.AnTEC BP.SourcePos n) n)            , Maybe CheckTrace)@@ -156,7 +155,7 @@          -- Parse the tokens.         goParse toks                -         = case BP.runTokenParser describeTok sourceName +         = case BP.runTokenParser describeToken sourceName                          (C.pModule (C.contextOfProfile profile))                         toks of                 Left err        -> (Left (ErrorParser err),     Nothing)@@ -211,7 +210,7 @@                                 --   We add their exports to the environment.         -> FilePath             -- ^ Path to source file for error messages.         -> Mode n               -- ^ Type checker mode.-        -> [Token (Tok n)]      -- ^ Source tokens.+        -> [Located (Token n)]  -- ^ Source tokens.         -> ( Either (Error n err)                      (Exp (C.AnTEC BP.SourcePos n) n)            , Maybe CheckTrace)@@ -222,12 +221,19 @@         -- Type checker profile, kind and type environments.         profile = F.fragmentProfile fragment         config  = C.configOfProfile  profile-        kenv    = modulesExportTypes  modules $ profilePrimKinds profile-        tenv    = modulesExportValues modules $ profilePrimTypes profile+        +        envx    = modulesEnvX +                        (profilePrimKinds    profile)+                        (profilePrimTypes    profile)+                        (profilePrimDataDefs profile)+                        (Map.elems modules) +        kenv    = EnvX.kindEnvOfEnvX envx+        tenv    = EnvX.typeEnvOfEnvX envx+         -- Parse the tokens.         goParse toks                -         = case BP.runTokenParser describeTok sourceName +         = case BP.runTokenParser describeToken sourceName                          (C.pExp (C.contextOfProfile profile))                         toks of                 Left err              -> (Left (ErrorParser err),     Nothing)@@ -235,9 +241,9 @@          -- Check the kind of the type.         goCheckType x-         = case C.checkExp config kenv tenv x mode of+         = case C.checkExp config envx 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 @@ -274,7 +280,7 @@         => Fragment n err       -- ^ Language fragment definition.         -> Universe             -- ^ Universe this type is supposed to be in.         -> FilePath             -- ^ Path to source file for error messages.-        -> [Token (Tok n)]      -- ^ Source tokens.+        -> [Located (Token n)]  -- ^ Source tokens.         -> Either (Error n err)                    (Type n, Kind n) @@ -285,7 +291,7 @@          -- Parse the tokens.         goParse toks                -         = case BP.runTokenParser describeTok sourceName +         = case BP.runTokenParser describeToken sourceName                          (C.pType (C.contextOfProfile profile))                         toks of                 Left err  -> Left (ErrorParser err)@@ -293,7 +299,7 @@          -- Check the kind of the type.         goCheckType t-         = case T.checkType (T.configOfProfile profile) Env.empty uni t of+         = case C.checkType (C.configOfProfile profile) uni t of                 Left err      -> Left (ErrorCheckType err)                 Right (t', k) -> Right (t', k)         @@ -318,7 +324,7 @@         :: (Eq n, Ord n, Show n, Pretty n)         => Fragment n err       -- ^ Language fragment profile.         -> FilePath             -- ^ Path to source file for error messages.-        -> [Token (Tok n)]      -- ^ Source tokens.+        -> [Located (Token n)]  -- ^ Source tokens.         -> Either (Error n err)                    (Witness (AnT BP.SourcePos n) n, Type n) @@ -327,12 +333,18 @@  where  -- Type checker config, kind and type environments.         profile = F.fragmentProfile fragment         config  = C.configOfProfile profile-        kenv    = profilePrimKinds  profile-        tenv    = profilePrimTypes  profile +        env     = EnvX.fromPrimEnvs +                        (profilePrimKinds    profile)+                        (profilePrimTypes    profile)+                        (profilePrimDataDefs profile)++        kenv    = profilePrimKinds profile+        tenv    = profilePrimTypes profile+         -- Parse the tokens.         goParse toks                -         = case BP.runTokenParser describeTok sourceName +         = case BP.runTokenParser describeToken sourceName                  (C.pWitness (C.contextOfProfile profile))                  toks of                 Left err  -> Left (ErrorParser err)@@ -340,7 +352,7 @@          -- Check the kind of the type.         goCheckType w-         = case C.checkWitness config kenv tenv w of+         = case C.checkWitness config env w of                 Left err      -> Left (ErrorCheckExp err)                 Right (w', t) -> Right (w', t)
DDC/Core/Module.hs view
@@ -1,42 +1,67 @@- module DDC.Core.Module         ( -- * Modules           Module        (..)         , isMainModule-	, moduleKindEnv-        , moduleTypeEnv+        , moduleDataDefs+        , moduleTypeDefs+        , moduleKindEnv, moduleTypeEnv+        , moduleEnvT,    moduleEnvX+        , modulesEnvT,   modulesEnvX         , moduleTopBinds         , moduleTopBindTypes+        , mapTopBinds -	  -- * Module maps-	, ModuleMap-	, modulesExportTypes-	, modulesExportValues+          -- * Module maps+        , ModuleMap+        , modulesExportTypes+        , modulesExportValues           -- * Module Names-        , QualName      (..)         , ModuleName    (..)+        , readModuleName         , isMainModuleName+        , moduleNameMatchesPath+        +         -- * Qualified names.+        , QualName      (..) -        -- * Export Sources+         -- * 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)+import DDC.Core.Env.EnvT                (EnvT (EnvT))+import DDC.Core.Env.EnvX                (EnvX) import DDC.Type.Env                     as Env+import qualified DDC.Type.DataDef       as DataDef import qualified Data.Map.Strict        as Map import qualified Data.Set               as Set+import qualified DDC.Core.Env.EnvT      as EnvT+import qualified DDC.Core.Env.EnvX      as EnvX import Control.DeepSeq import Data.Maybe @@ -46,45 +71,65 @@ 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 (Type n))]            -- | Types of exported values.-        , moduleExportValues            :: ![(n, ExportSource n)]+        , moduleExportValues    :: ![(n, ExportSource n (Type 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 (Type 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 (Type n))] -          -- Local --------------------+          -- | Define imported values.+        , moduleImportValues    :: ![(n, ImportValue  n (Type n))]++          -- | Data defs imported from other modules.+        , moduleImportDataDefs  :: ![DataDef n]++          -- | Type defs imported from other modules.+        , moduleImportTypeDefs  :: ![(n, (Kind n, Type n))]++          -- Local defs ---------------           -- | Data types defined in this module.-        , moduleDataDefsLocal           :: ![DataDef n]+        , moduleDataDefsLocal   :: ![DataDef n] +          -- | Type definitions in this module.+        , moduleTypeDefsLocal   :: ![(n, (Kind n, Type 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 (moduleImportTypeDefs mm)+        `seq` rnf (moduleDataDefsLocal  mm)+        `seq` rnf (moduleTypeDefsLocal  mm)+        `seq` rnf (moduleBody           mm)   -- | Check if this is the `Main` module.@@ -94,12 +139,25 @@         $ 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 data type definitions visible in a module.+moduleTypeDefs :: Ord n => Module a n -> [(n, (Kind n, Type n))]+moduleTypeDefs mm+        = moduleImportTypeDefs mm ++ moduleTypeDefsLocal 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,9 +165,144 @@ 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]  +-- | Extract the top-level `EnvT` environment from a module.+--+--   This includes kinds for abstract types, data types, and type equations, +--   but not primitive types which are fragment specific.+--+moduleEnvT +        :: Ord n +        => KindEnv n    -- ^ Primitive kind environment.+        -> Module a n   -- ^ Module to extract environemnt from.+        -> EnvT n++moduleEnvT kenvPrim mm+ = EnvT+ { EnvT.envtEquations   +        = Map.unions+        [ Map.fromList [(n, t)  | (n, (_, t)) <- moduleImportTypeDefs mm]+        , Map.fromList [(n, t)  | (n, (_, t)) <- moduleTypeDefsLocal  mm]]++ , EnvT.envtCapabilities+        = Map.fromList [(n, typeOfImportCap ic) | (n, ic) <- moduleImportCaps mm]++ , EnvT.envtPrimFun+        = Env.envPrimFun kenvPrim++ , EnvT.envtMap         +        = let -- Kinds of imported foreign types.+              nksImportForeignType+                = Map.fromList [(n, kindOfImportType isrc) +                               | (n, isrc) <- moduleImportTypes mm]++              -- Kinds of imported data types.+              nksImportDataType+               = Map.fromList  [(dataDefTypeName def, kindOfDataDef def) +                               | def <- moduleImportDataDefs mm]++              -- Kinds of imported type defs.+              nksImportTypeDef+               = Map.fromList  [(n, k) | (n, (k, _)) <- moduleImportTypeDefs mm]++              -- Kinds of locally defined data types.+              nksLocalDataType+               = Map.fromList  [(dataDefTypeName def, kindOfDataDef def) +                               | def <- moduleImportDataDefs mm]++              -- Kinds of imported type defs.+              nksLocalTypeDef+               = Map.fromList  [(n, k) | (n, (k, _)) <- moduleTypeDefsLocal mm]++          in  -- Build a map of all the kinds, +              -- Where kinds of locally defined type shadow the imported ones.+              Map.unions+                [ nksImportForeignType+                , nksImportDataType+                , nksImportTypeDef+                , nksLocalDataType+                , nksLocalTypeDef ]++ , EnvT.envtStack       = []+ , EnvT.envtStackLength = 0++ }+++-- | Extract the top-level `EnvT` environment from several modules.+---+--   After unioning all the individual environments we reset the prim +--   function so we only have a single version of it.+modulesEnvT +        :: Ord n+        => KindEnv n    -- ^ Primitive kind environment.+        -> [Module a n] -- ^ Modules to build environment from.+        -> EnvT n++modulesEnvT kenv ms+        = (EnvT.unions $ map (moduleEnvT kenv) ms)+        { EnvT.envtPrimFun = Env.envPrimFun kenv }+++-- | Extract the top-level `EnvX` environment from a module.+moduleEnvX +        :: Ord n +        => KindEnv n    -- ^ Primitive kind environment.+        -> TypeEnv n    -- ^ Primitive type environment.+        -> DataDefs n   -- ^ Primitive data type definitions.+        -> Module a n   -- ^ Module to extract environemnt from.+        -> EnvX n++moduleEnvX kenvPrim tenvPrim dataDefs mm+ = EnvX.empty+ { EnvX.envxEnvT        = moduleEnvT kenvPrim mm+ , EnvX.envxPrimFun     = Env.envPrimFun tenvPrim ++ , EnvX.envxDataDefs    +        = DataDef.unionDataDefs dataDefs+        $ DataDef.unionDataDefs +                (DataDef.fromListDataDefs $ moduleImportDataDefs mm)+                (DataDef.fromListDataDefs $ moduleDataDefsLocal  mm)++ , EnvX.envxMap+        = Map.fromList +                [ (n, typeOfImportValue isrc)+                | (n, isrc) <- moduleImportValues mm ]+ }+++-- | Extract the top-level `EnvT` environment from several modules.+modulesEnvX+        :: Ord n+        => KindEnv n    -- ^ Primitive kind environment.+        -> TypeEnv n    -- ^ Primitive type environment.+        -> DataDefs n   -- ^ Primitive data type definitions.+        -> [Module a n] -- ^ Modules to build environment from.+        -> EnvX n++modulesEnvX kenv tenv defs ms+ = let  -- Base environment contains all the prims.+        --   We need to include this for the case when there are no+        --   provided modules, so the prims are still end up in the result.+        env0    = EnvX.fromPrimEnvs kenv tenv defs++        -- Build environments for each of the modules+        envs    = map (moduleEnvX kenv tenv defs) ms++        -- Union the above into a composite environment.+        env     = EnvX.unions (env0 : envs)++        -- The EnvX.unions function combines the prim funs so that+        -- if a lookup fails the primfun from the next module will +        -- be called, but as the primfuns in each module are identical+        -- we only need a single version.+        env'    = env+                { EnvX.envxPrimFun  = EnvX.envxPrimFun env0 }+   in   env'++ -- | Get the set of top-level value bindings in a module. moduleTopBinds :: Ord n => Module a n -> Set n moduleTopBinds mm@@ -142,11 +335,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 +389,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)-
+ DDC/Core/Module/Export.hs view
@@ -0,0 +1,46 @@++module DDC.Core.Module.Export+        ( ExportSource  (..)+        , takeTypeOfExportSource+        , mapTypeOfExportSource)+where+import Control.DeepSeq+++-- | Define thing exported from a module.+data ExportSource n t+        -- | A name defined in this module, with an explicit type.+        = ExportSourceLocal   +        { exportSourceLocalName         :: n +        , exportSourceLocalType         :: t }++        -- | 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 t) => NFData (ExportSource n t) 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 t -> Maybe t+takeTypeOfExportSource es+ = case es of+        ExportSourceLocal _ t           -> Just t+        ExportSourceLocalNoType{}       -> Nothing+++-- | Apply a function to any type in an ExportSource.+mapTypeOfExportSource :: (t -> t) -> ExportSource n t -> ExportSource n t+mapTypeOfExportSource f esrc+ = case esrc of+        ExportSourceLocal n t           -> ExportSourceLocal n (f t)+        ExportSourceLocalNoType n       -> ExportSourceLocalNoType n+
+ DDC/Core/Module/Import.hs view
@@ -0,0 +1,156 @@++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 Control.DeepSeq+++-- ImportType -------------------------------------------------------------------------------------+-- | Define a type being imported into a module.+data ImportType n t+        -- | 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 :: !t }++        -- | 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        :: !t }+        deriving Show+++instance (NFData n, NFData t) => NFData (ImportType n t) where+ rnf is+  = case is of+        ImportTypeAbstract k            -> rnf k+        ImportTypeBoxed    k            -> rnf k+++-- | Take the kind of an `ImportType`.+kindOfImportType :: ImportType n t -> t+kindOfImportType src+ = case src of+        ImportTypeAbstract k            -> k+        ImportTypeBoxed    k            -> k+++-- | Apply a function to the kind of an `ImportType`+mapKindOfImportType :: (t -> t) -> ImportType n t -> ImportType n t+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 t+        -- | 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  :: !t }+        deriving Show+++instance (NFData n, NFData t) => NFData (ImportCap n t) where+ rnf ii+  = case ii of+        ImportCapAbstract t     -> rnf t+++-- | Take the type of an `ImportCap`.+typeOfImportCap :: ImportCap n t -> t+typeOfImportCap ii+ = case ii of+        ImportCapAbstract t     -> t+++-- | Apply a function to the type in an `ImportCapability`.+mapTypeOfImportCap :: (t -> t) -> ImportCap n t -> ImportCap n t+mapTypeOfImportCap f ii+ = case ii of+        ImportCapAbstract t     -> ImportCapAbstract (f t)+++-- ImportValue ------------------------------------------------------------------------------------+-- | Define a foreign value being imported into a module.+data ImportValue n t+        -- | 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        :: !t++          -- | 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           :: !t }+        deriving Show+++instance (NFData n, NFData t) => NFData (ImportValue n t) 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 t -> t+typeOfImportValue src+ = case src of+        ImportValueModule _ _ t _       -> t+        ImportValueSea      _ t         -> t+++-- | Apply a function to the type in an ImportValue.+mapTypeOfImportValue :: (t -> t) -> ImportValue n t -> ImportValue n t+mapTypeOfImportValue f isrc+ = case isrc of+        ImportValueModule mn n t a      -> ImportValueModule mn n (f t) a+        ImportValueSea s t              -> ImportValueSea s (f t)+
+ DDC/Core/Module/Name.hs view
@@ -0,0 +1,85 @@++module DDC.Core.Module.Name+        ( ModuleName    (..)+        , readModuleName+        , isMainModuleName+        , moduleNameMatchesPath++        , QualName      (..))+where+import Data.Typeable+import Control.DeepSeq+import qualified Data.List              as List+import qualified System.FilePath        as System+++-- 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+++-- | Check whether a module name matches the given file path of the module.+--+--   If the module is named M1.M2.M3 then the file needs to be called+--   PATH/M1/M2/M3.EXT for some base PATH and extension EXT.+--+moduleNameMatchesPath :: FilePath -> ModuleName -> Bool+moduleNameMatchesPath filePath (ModuleName mnParts)+ = checkParts (reverse fsParts) (reverse mnParts)+ where+        -- Split out the directory parts from the filename.+        fsParts +                = map (\f -> case List.stripPrefix "/" (reverse f) of+                                Just f' -> reverse f'+                                Nothing -> f)+                $ System.splitPath +                $ System.dropExtension filePath++        -- Check that the directory parts match the module name parts.+        checkParts [] _     = True+        checkParts _  []    = True+        checkParts (f: fs) (m : ms)+         | f == m           = checkParts fs ms+         | otherwise        = 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+
DDC/Core/Parser.hs view
@@ -31,8 +31,8 @@         , pWitnessAtom            -- * Constructors-        , pCon, pConSP-        , pLit, pLitSP+        , pCon,         pConSP+        , pLit,         pLitSP            -- * Variables         , pIndex,       pIndexSP@@ -45,6 +45,7 @@         , pOpVarSP            -- * Raw Tokens+        , pSym,         pKey         , pTok,         pTokSP         , pTokAs)
DDC/Core/Parser/Base.hs view
@@ -4,45 +4,57 @@         , pModuleName         , pQualName         , pName-        , pWbCon,       pWbConSP         , pCon,         pConSP         , pLit,         pLitSP         , pIndex,       pIndexSP-        , pVar,         pVarSP+        , pVar,         pVarSP,         pVarNamedSP+        , pKey,         pSym         , pTok,         pTokSP         , pTokAs,       pTokAsSP         , pOpSP-        , pOpVarSP)+        , pOpVarSP+        , pPragmaSP) where-import DDC.Base.Pretty+import DDC.Data.Pretty import DDC.Core.Module-import DDC.Core.Exp import DDC.Core.Lexer.Tokens-import DDC.Base.Parser                  ((<?>), SourcePos)-import qualified DDC.Base.Parser        as P-+import DDC.Control.Parser               ((<?>), SourcePos)+import Data.Text                        (Text)+import qualified DDC.Control.Parser     as P  -- | A parser of core language tokens. type Parser n a-        = P.Parser (Tok n) a+        = P.Parser (Token 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 (KSymbol SDot))+        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 (KBuiltin (BSoCon c)))  = Just $ ModuleName [ renderPlain $ ppr c ]+        f (KA (KBuiltin (BKiCon c)))  = Just $ ModuleName [ renderPlain $ ppr c ]+        f (KA (KBuiltin (BTwCon c)))  = Just $ ModuleName [ renderPlain $ ppr c ]+        f (KA (KBuiltin (BTcCon c)))  = Just $ ModuleName [ renderPlain $ ppr c ]+        f _                       = Nothing++ -- | Parse a qualified variable or constructor name. pQualName :: Pretty n => Parser n (QualName n) pQualName  = do   mn      <- pModuleName-        pTok KDot+        pTok    (KSymbol SDot)         n       <- pName         return  $ QualName mn n @@ -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@@ -81,17 +79,17 @@   -- | Parse a literal.-pLit :: Parser n n+pLit :: Parser n (Literal, Bool) pLit    = P.pTokMaybe f- where  f (KN (KLit n)) = Just n-        f _             = Nothing+ where  f (KA (KLiteral l b)) = Just (l, b)+        f _                   = Nothing  --- | Parse a literal, with source position.-pLitSP :: Parser n (n, SourcePos)+-- | Parse a numeric literal, with source position.+pLitSP :: Parser n ((Literal, Bool), SourcePos) pLitSP  = P.pTokMaybeSP f- where  f (KN (KLit n)) = Just n-        f _             = Nothing+ where  f (KA (KLiteral l b)) = Just (l, b)+        f _                   = Nothing   -- | Parse a variable.@@ -110,6 +108,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@@ -140,23 +146,41 @@         f _                  = Nothing  +-- | Parse a pragma.+pPragmaSP :: Parser n (Text, SourcePos)+pPragmaSP = P.pTokMaybeSP f+ where  f (KA (KPragma txt))  = Just txt+        f _                   = Nothing++-------------------------------------------------------------------------------+-- | Parse a `Symbol`.+pSym :: Symbol  -> Parser n SourcePos+pSym ss = P.pTokSP (KA (KSymbol ss))+++-- | Parse a `Keyword`.+pKey :: Keyword -> Parser n SourcePos+pKey kw = P.pTokSP (KA (KKeyword kw))+++------------------------------------------------------------------------------- -- | Parse an atomic token.-pTok :: TokAtom -> Parser n ()+pTok   :: TokenAtom -> Parser n () pTok k     = P.pTok (KA k)   -- | Parse an atomic token, yielding its source position.-pTokSP :: TokAtom -> Parser n SourcePos+pTokSP :: TokenAtom -> Parser n SourcePos pTokSP k   = P.pTokSP (KA k)   -- | Parse an atomic token and return some value.-pTokAs :: TokAtom -> a -> Parser n a+pTokAs :: TokenAtom -> a -> Parser n a pTokAs k x = P.pTokAs (KA k) x   -- | Parse an atomic token and return source position and value.-pTokAsSP :: TokAtom -> a -> Parser n (a, SourcePos)+pTokAsSP :: TokenAtom -> a -> Parser n (a, SourcePos) pTokAsSP k x = P.pTokAsSP (KA k) x
DDC/Core/Parser/Context.hs view
@@ -3,32 +3,46 @@         ( Context (..)         , contextOfProfile) where+import DDC.Core.Exp.Literal import DDC.Core.Fragment+import DDC.Data.SourcePos   -- | 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  +          -- | Check whether the given fragment includes literals of this sort,+          --   and convert it to the appropriate primitive name.+        , contextMakeLiteralName+                :: Maybe (SourcePos -> Literal -> Bool -> Maybe n) } + -- | Slurp an initital `Context` from a language `Profile`.-contextOfProfile :: Profile n -> Context+contextOfProfile :: Profile n -> Context n contextOfProfile profile         = Context-        { contextTrackedEffects         = featuresTrackedEffects-                                        $ profileFeatures profile+        { contextTrackedEffects         +                = featuresTrackedEffects+                $ profileFeatures profile -        , contextTrackedClosures        = featuresTrackedClosures-                                        $ profileFeatures profile+        , contextTrackedClosures+                = featuresTrackedClosures+                $ profileFeatures profile -        , contextFunctionalEffects      = featuresFunctionalEffects-                                        $ profileFeatures profile+        , contextFunctionalEffects+                = featuresFunctionalEffects+                $ profileFeatures profile -        , contextFunctionalClosures     = featuresFunctionalClosures-                                        $ profileFeatures profile+        , contextFunctionalClosures+                = featuresFunctionalClosures+                $ profileFeatures profile++        , contextMakeLiteralName+                = profileMakeLiteralName profile         }
+ DDC/Core/Parser/DataDef.hs view
@@ -0,0 +1,84 @@++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.Control.Parser     as P+++pDataDef :: Ord n => Context n -> Parser n (DataDef n)+pDataDef c+ = do   pTokSP (KKeyword EData)+        nData   <- pName +        bsParam <- liftM concat $ P.many (pDataParam c)++        P.choice+         [ -- Data declaration with constructors that have explicit types.+           do   pKey EWhere+                pSym SBraceBra+                ctors      <- P.sepEndBy1 (pDataCtor c nData bsParam) +                                          (pSym SSemiColon)+                let ctors' = [ ctor { dataCtorTag = tag }+                                | ctor <- ctors+                                | tag  <- [0..] ]+                pSym SBraceKet+                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   pSym SRoundBra+        ns      <- P.many1 pName+        pTokSP (KOp ":")+        k       <- pType c+        pSym SRoundKet+        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 }+
DDC/Core/Parser/Exp.hs view
@@ -9,138 +9,96 @@         , 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 DDC.Control.Parser               ((<?>), SourcePos)+import qualified DDC.Control.Parser     as P+import qualified DDC.Type.Exp.Simple    as T+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 [ pSym SLambda,    pSym SBackSlash]         bs      <- liftM concat $ P.many1 (pBinds c)-        pTok KDot+        pSym    SDot         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 [ pSym SBigLambda, pSym SBigLambdaSlash]          bs      <- liftM concat $ P.many1 (pBinds c)-        pTok KDot+        pSym    SDot         xBody   <- pExp c         return  $ foldr (XLAM sp) xBody bs          -- let expression  , do   (lts, sp) <- pLetsSP c-        pTok    KIn+        pKey    EIn         x2      <- pExp c         return  $ XLet sp lts x2          -- do { STMTS }         --   Sugar for a let-expression.- , do   pTok    KDo-        pTok    KBraceBra+ , do   pKey    EDo+        pSym    SBraceBra         xx      <- pStmts c-        pTok    KBraceKet+        pSym    SBraceKet         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+ , do   sp      <- pKey ECase         x       <- pExp c-        pTok KOf -        pTok KBraceBra-        alts    <- P.sepEndBy1 (pAlt c) (pTok KSemiColon)-        pTok KBraceKet+        pKey    EOf+        pSym    SBraceBra+        alts    <- P.sepEndBy1 (pAlt c) (pSym SSemiColon)+        pSym    SBraceKet         return  $ XCase sp x alts          -- letcase PAT = EXP in EXP  , do   --  Sugar for a single-alternative case expression.-        sp      <- pTokSP KLetCase+        sp      <- pKey ELetCase         p       <- pPat c-        pTok (KOp "=")+        pSym    SEquals         x1      <- pExp c-        pTok KIn+        pKey    EIn         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+ , do   sp      <- pKey EWeakEff+        pSym    SSquareBra         t       <- pType c-        pTok KSquareKet-        pTok KIn+        pSym    SSquareKet+        pKey    EIn         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+ , do   sp      <- pKey EPurify         w       <- pWitness c-        pTok KIn+        pTok (KKeyword EIn)         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+ , do   sp      <- pKey EBox         x       <- pExp c         return  $ XCast sp CastBox x          -- run EXP- , do   sp      <- pTokSP KRun+ , do   sp      <- pKey ERun         x       <- pExp c         return  $ XCast sp CastRun x @@ -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,31 +124,31 @@   -- 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]- [ do   sp      <- pTokSP KSquareBra+ [ do   sp      <- pSym SSquareBra         t       <- pType c-        pTok KSquareKet+        pSym SSquareKet         return  [(XType sp t, sp)]          -- [: TYPE0 TYPE0 ... :]- , do   sp      <- pTokSP KSquareColonBra+ , do   sp      <- pSym SSquareColonBra         ts      <- P.many1 (pTypeAtom c)-        pTok KSquareColonKet+        pSym SSquareColonKet         return  [(XType sp t, sp) | t <- ts]                  -- {WITNESS}- , do   sp      <- pTokSP KBraceBra+ , do   sp      <- pSym SBraceBra         w       <- pWitness c-        pTok KBraceKet+        pSym SBraceKet         return  [(XWitness sp w, sp)]                          -- {: WITNESS0 WITNESS0 ... :}- , do   sp      <- pTokSP KBraceColonBra+ , do   sp      <- pSym SBraceColonBra         ws      <- P.many1 (pWitnessAtom c)-        pTok KBraceColonKet+        pSym SBraceColonKet         return  [(XWitness sp w, sp) | w <- ws]                          -- EXP0@@ -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,37 +169,40 @@ --   also returning source position. pExpAtomSP          :: Ord n -        => Context +        => Context n          -> Parser n (Exp SourcePos n, SourcePos)  pExpAtomSP c  = P.choice         -- (EXP2)- [ do   sp      <- pTokSP KRoundBra+ [ do   sp      <- pSym SRoundBra         t       <- pExp c-        pTok KRoundKet+        pSym    SRoundKet         return  (t, sp)           -- The unit data constructor.       - , do   sp              <- pTokSP KDaConUnit+ , do   sp        <- pTokSP (KBuiltin BDaConUnit)         return  (XCon sp dcUnit, sp)          -- Named algebraic constructors.- , do   (con, sp)       <- pConSP+ , do   (con, sp) <- pConSP         return  (XCon sp (DaConBound con), sp)          -- Literals.         --   The attached type is set to Bottom for now, which needs         --   to be filled in later by the Spread transform.- , do   (lit, sp)       <- pLitSP-        return  (XCon sp (DaConPrim lit (T.tBot T.kData)), sp)+ , do   ((lit, bPrim), sp) <- pLitSP+        let Just mkLit  = contextMakeLiteralName c+        case mkLit sp lit bPrim of+         Just name -> return  (XCon sp (DaConPrim name (T.tBot T.kData)), sp)+         Nothing   -> P.unexpected "literal"          -- Debruijn indices- , do   (i, sp)         <- pIndexSP+ , do   (i, sp)   <- pIndexSP         return  (XVar sp (UIx   i), sp)          -- Variables- , do   (var, sp)       <- pVarSP+ , do   (var, sp) <- pVarSP         return  (XVar sp (UName var), sp)  ] @@ -250,31 +211,34 @@  -- 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+        pSym    SArrowDashRight         x       <- pExp c         return  $ AAlt p x   -- Patterns. pPat    :: Ord n -        => Context -> Parser n (Pat n)+        => Context n -> Parser n (Pat n) pPat c  = P.choice- [      -- Wildcard-   do   pTok KUnderscore+ [      -- Wildcard Pattern: _+   do   pSym    SUnderscore         return  $ PDefault          -- LIT  , do   --  The attached type is set to Bottom for now, which needs         --  to be filled in later by the Spread transform.-        nLit    <- pLit-        return  $ PData (DaConPrim nLit (T.tBot T.kData)) []+        ((lit, bPrim), sp) <- pLitSP+        let Just mkLit  = contextMakeLiteralName c +        case mkLit sp lit bPrim of+         Just nLit      -> return  $ PData (DaConPrim nLit (T.tBot T.kData)) []+         _              -> P.unexpected "literal"          -- Unit- , do   pTok KDaConUnit+ , do   pTok    (KBuiltin BDaConUnit)         return  $ PData  dcUnit []          -- CON BIND BIND ...@@ -287,7 +251,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.@@ -295,11 +259,11 @@         return  [T.makeBindFromBinder b (T.tBot T.kData) | b <- bs]          -- Binder with type, wrapped in parens.- , do   pTok KRoundBra+ , do   pSym SRoundBra         bs      <- P.many1 pBinder         pTok (KOp ":")         t       <- pType c-        pTok KRoundKet+        pSym SRoundKet         return  [T.makeBindFromBinder b t | b <- bs]  ] @@ -308,21 +272,21 @@ -- | 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.-      do sp       <- pTokSP KLet+      do sp       <- pTokSP (KKeyword ELet)          (b1, x1) <- pLetBinding c          return (LLet b1 x1, sp)        -- recursive let.-    , do sp     <- pTokSP KLetRec+    , do sp       <- pTokSP (KKeyword ELetRec)          P.choice           -- Multiple bindings in braces-          [ do   pTok KBraceBra-                 lets    <- P.sepEndBy1 (pLetBinding c) (pTok KSemiColon)-                 pTok KBraceKet+          [ do   pSym SBraceBra+                 lets    <- P.sepEndBy1 (pLetBinding c) (pSym SSemiColon)+                 pSym SBraceKet                  return (LRec lets, sp)            -- A single binding without braces.@@ -332,11 +296,13 @@        -- Private region binding.       --   private BINDER+ (with { BINDER : TYPE ... })? in EXP-    , do sp     <- pTokSP KPrivate+    , do sp     <- pTokSP (KKeyword EPrivate)                    -- new private region names.          brs    <- P.manyTill pBinder -                $  P.try $ P.lookAhead $ P.choice [pTok KIn, pTok KWith]+                $  P.try $ P.lookAhead $ P.choice +                        [ pTok (KKeyword EIn)+                        , pTok (KKeyword EWith) ]           let bs =  map (flip T.makeBindFromBinder T.kRegion) brs @@ -346,16 +312,19 @@            -- Extend an existing region.       --   extend BINDER+ using TYPE (with { BINDER : TYPE ...})? in EXP-    , do sp     <- pTokSP KExtend+    , do sp     <- pTokSP (KKeyword EExtend)           -- parent region          t      <- pType c-         pTok KUsing+         pTok (KKeyword EUsing)           -- new private region names.          brs    <- P.manyTill pBinder                  $  P.try $ P.lookAhead -                         $ P.choice [pTok KUsing, pTok KWith, pTok KIn]+                         $ P.choice +                                [ pTok (KKeyword EUsing)+                                , pTok (KKeyword EWith)+                                , pTok (KKeyword EIn) ]           let bs =  map (flip T.makeBindFromBinder T.kRegion) brs          @@ -366,14 +335,14 @@           pLetWits :: Ord n -        => Context +        => Context n         -> [Bind n] -> Maybe (Type n)          -> Parser n (Lets SourcePos n)  pLetWits c bs mParent  = P.choice -    [ do   pTok KWith-           pTok KBraceBra+    [ do   pKey EWith+           pSym SBraceBra            wits    <- P.sepBy (P.choice                         [ -- Named witness binder.                           do  b    <- pBinder@@ -384,8 +353,8 @@                           -- Ambient witness binding, use for capabilities.                         , do  t    <- pTypeApp c                               return  $ BNone t ])-                      (pTok KSemiColon)-           pTok KBraceKet+                      (pSym SSemiColon)+           pSym SBraceKet            return (LPrivate bs mParent wits)          , do   return (LPrivate bs mParent [])@@ -395,7 +364,7 @@ -- | A binding for let expression. pLetBinding          :: Ord n -        => Context+        => Context n         -> Parser n ( Bind n                     , Exp SourcePos n) pLetBinding c@@ -404,9 +373,9 @@         P.choice          [ do   -- Binding with full type signature.                 --  BINDER : TYPE = EXP-                pTok (KOp ":")+                pTok    (KOp ":")                 t       <- pType c-                pTok (KOp "=")+                pSym    SEquals                 xBody   <- pExp c                  return  $ (T.makeBindFromBinder b t, xBody) @@ -416,7 +385,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 "=")+                pSym    SEquals                 xBody   <- pExp c                 let t   = T.tBot T.kData                 return  $ (T.makeBindFromBinder b t, xBody)@@ -433,7 +402,7 @@                         --   BINDER PARAM1 PARAM2 .. PARAMN : TYPE = EXP                         pTok (KOp ":")                         tBody   <- pType c-                        sp      <- pTokSP (KOp "=")+                        sp      <- pSym SEquals                         xBody   <- pExp c                          let x   = expOfParams sp ps xBody@@ -445,7 +414,7 @@                         -- but we can create lambda abstractions with the given                          -- parameter types.                         --  BINDER PARAM1 PARAM2 .. PARAMN = EXP-                 , do   sp      <- pTokSP (KOp "=")+                 , do   sp      <- pSym SEquals                         xBody   <- pExp c                          let x   = expOfParams sp ps xBody@@ -462,7 +431,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 +440,7 @@    --      P.try $      do  br      <- pBinder-        sp      <- pTokSP (KOp "=")+        sp      <- pSym SEquals         x1      <- pExp c         let t   = T.tBot T.kData         let b   = T.makeBindFromBinder br t@@ -483,9 +452,9 @@    --  as a function name in a non-binding statement.  , P.try $     do  p       <- pPat c-        sp      <- pTokSP KArrowDashLeft+        sp      <- pSym SArrowDashLeft         x1      <- pExp c-        pTok KElse+        pTok (KKeyword EElse)         x2      <- pExp c         return  $ StmtMatch sp p x1 x2 @@ -496,9 +465,9 @@   -- | 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)+ = do   stmts   <- P.sepEndBy1 (pStmt c) (pSym SSemiColon)         case makeStmts stmts of          Nothing -> P.unexpected "do-block must end with a statement"          Just x  -> return x
+ DDC/Core/Parser/ExportSpec.hs view
@@ -0,0 +1,84 @@++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.Type.Exp.Simple+import DDC.Data.Pretty+import Control.Monad+import qualified DDC.Control.Parser        as P+++-- An exported thing.+data ExportSpec n+        = ExportValue   n (ExportSource n (Type n))+++-- | Parse some export specifications.+pExportSpecs+        :: (Ord n, Pretty n)+        => Context n -> Parser n [ExportSpec n]++pExportSpecs c+ = do   pTok (KKeyword EExport)++        P.choice +         [      -- export value { (NAME :: TYPE)+ }+           do   P.choice [ do   pKey EValue+                                return ()+                         ,      return () ]++                pSym    SBraceBra+                specs   <- P.sepEndBy1 (pExportValue c)+                                       (pSym SSemiColon)+                pSym    SBraceKet +                return specs++                -- export foreign X value { (NAME :: TYPE)+ }+         , do   pKey    EForeign+                dst     <- liftM (renderIndent . ppr) pName+                pKey    EValue+                pSym    SBraceBra+                specs   <- P.sepEndBy1 (pExportForeignValue c dst) +                                       (pSym SSemiColon)+                pSym    SBraceKet+                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."+
+ DDC/Core/Parser/ImportSpec.hs view
@@ -0,0 +1,210 @@++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.Type.Exp.Simple+import DDC.Data.Pretty+import Control.Monad+import qualified DDC.Control.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+        -- | Foreign imported types.+        = ImportForeignType  n (ImportType   n (Type n))++        -- | Foreign imported capabilities.+        | ImportForeignCap   n (ImportCap    n (Type n))++        -- | Foreign imported values.+        | ImportForeignValue n (ImportValue  n (Type n))++        -- | Imported types from other modules.+        | ImportType         n (Kind n) (Type n)++        -- | Imported data declarations from other modules.+        | 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 (KKeyword EImport)++        P.choice+         [      -- data ...+           do   def     <- pDataDef c+                return  [ ImportData def ]++                -- type { (NAME :: KIND)+ }+         , do   P.choice [ do   pKey EType+                                return ()+                         ,      return () ]++                pSym    SBraceBra+                specs   <- P.sepEndBy1 (pImportType c)  (pSym SSemiColon)+                pSym    SBraceKet+                return specs++                -- value { (NAME :: TYPE)+ }+         , do   P.choice [ do   pKey EValue+                                return ()+                         ,      return () ]++                pSym SBraceBra+                specs   <- P.sepEndBy1 (pImportValue c) (pSym SSemiColon)+                pSym SBraceKet+                return specs++                -- foreign ...+         , do   pTok (KKeyword EForeign)+                src     <- liftM (renderIndent . ppr) pName++                P.choice+                 [      -- import foreign MODE type { (NAME : TYPE)+ }+                  do    pKey    EType+                        pSym    SBraceBra+                        sigs    <- P.sepEndBy1 (pImportForeignType c src)  (pSym SSemiColon)+                        pSym    SBraceKet+                        return  sigs+        +                        -- import foreign MODE capability { (NAME : TYPE)+ }+                 , do   pKey    ECapability+                        pSym    SBraceBra+                        sigs    <- P.sepEndBy1 (pImportForeignCap c src)   (pSym SSemiColon)+                        pSym    SBraceKet+                        return  sigs++                        -- import foreign MODE value { (NAME : TYPE)+ }+                 , do   pKey    EValue+                        pSym    SBraceBra+                        sigs    <- P.sepEndBy1 (pImportForeignValue c src) (pSym SSemiColon)+                        pSym    SBraceKet+                        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  $ ImportForeignType 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  $ ImportForeignType 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  $  ImportForeignCap n (ImportCapAbstract t)++        | otherwise+        = P.unexpected "import mode for foreign capability."+++---------------------------------------------------------------------------------------------------+-- | Parse a type import.+pImportType+        :: (Ord n, Pretty n)+        => Context n -> Parser n (ImportSpec n)++pImportType c+ = do   n       <- pName+        pTokSP  (KOp ":")+        k       <- pType c+        pSym    SEquals+        t       <- pType c+        return  $  ImportType n k t+++---------------------------------------------------------------------------------------------------+-- | 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  $ ImportForeignValue 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 name to be specified +                -- with foreign C imports and exports, rather than forcing+                -- the external name to be the same as the internal one.+                let symbol = renderIndent (ppr n)++                return  $ ImportForeignValue n (ImportValueSea symbol k)++        | otherwise+        = P.unexpected "import mode for foreign value."+
DDC/Core/Parser/Module.hs view
@@ -1,291 +1,157 @@-+{-# 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.Base.Pretty-import Control.Monad-import qualified DDC.Base.Parser        as P+import DDC.Core.Exp.Annot+import DDC.Data.Pretty+import Data.Char+import qualified Data.Map               as Map+import qualified Data.Text              as T+import qualified DDC.Control.Parser     as P  --- 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+ = do   sp      <- pTokSP (KKeyword EModule)         name    <- pModuleName -        -- Export definitions.-        tExports        <- liftM concat $ P.many (pExportSpecs c)+        -- Parse header declarations+        heads                   <- P.many (pHeadDecl c)+        let importSpecs_noArity = concat $ [specs  | HeadImportSpecs   specs <- heads ]+        let exportSpecs         = concat $ [specs  | HeadExportSpecs   specs <- heads ] -        -- Import definitions.-        tImports        <- liftM concat $ P.many (pImportSpecs c)+        let dataDefsLocal       = [def         | HeadDataDef     def       <- heads ]+        let typeDefsLocal       = [(n, (k, t)) | HeadTypeDef     n k t     <- 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 (ImportForeignValue n (ImportValueModule mn v t _))+                = ImportForeignValue 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 (KKeyword EWith)++                        -- LET;++                        lts  <- P.sepBy1 (pLetsSP c) (pTok (KKeyword EIn))+                        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]+                , moduleExportValues    = [(n, s)      | ExportValue n s        <- exportSpecs]+                , moduleImportTypes     = [(n, s)      | ImportForeignType  n s <- importSpecs]+                , moduleImportCaps      = [(n, s)      | ImportForeignCap   n s <- importSpecs]+                , moduleImportValues    = [(n, s)      | ImportForeignValue n s <- importSpecs]+                , moduleImportTypeDefs  = [(n, (k, t)) | ImportType  n k t      <- importSpecs]+                , moduleImportDataDefs  = [def         | ImportData  def        <- importSpecs]                 , moduleDataDefsLocal   = dataDefsLocal+                , moduleTypeDefsLocal   = typeDefsLocal                 , 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))+-- | Wrapper for a declaration that can appear in the module header.+data HeadDecl n+        -- | Import specifications.+        = HeadImportSpecs  [ImportSpec  n] +        -- | Export specifications.+        | HeadExportSpecs  [ExportSpec  n] --- | 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+        -- | Data type definitions.+        | HeadDataDef      (DataDef     n) -                -- ISSUE #327: Allow external symbol to be specified -                --             with foreign C imports and exports.-                return  (ExportValue n (ExportSourceLocal n k))+        -- | Type equations.+        | HeadTypeDef       n (Kind n) (Type n) -        | otherwise-        = P.unexpected "export mode for foreign value."+        -- | Arity pragmas.+        --   Number of type parameters, value parameters, and boxes for some super.+        | HeadPragmaArity  n Int Int Int  ------------------------------------------------------------------------------------------------------- | An imported foreign type or foreign value.-data ImportSpec n-        = ImportType    n (ImportSource n)-        | ImportValue   n (ImportSource n)-        +-- | Parse one of the declarations that can appear in a module header.+pHeadDecl :: (Ord n, Pretty n)+          => Context n -> Parser n (HeadDecl n) --- | Parse some import specs.-pImportSpecs    :: (Ord n, Pretty n)-                => Context -> Parser n [ImportSpec n]-pImportSpecs c- = do   pTok KImport+pHeadDecl ctx+ = P.choice +        [ do    imports <- pImportSpecs ctx+                return  $ HeadImportSpecs imports -        P.choice-         [      -- import type  { (NAME :: TYPE)+ }-           do   pTok KType-                pTok KBraceBra-                specs   <- P.sepEndBy1 (pImportType c) (pTok KSemiColon)-                pTok KBraceKet-                return specs+        , do    exports <- pExportSpecs ctx+                return  $ HeadExportSpecs exports  -                -- import value { (NAME :: TYPE)+ }-         , do   P.choice [ pTok KValue, return () ]-                pTok KBraceBra-                specs   <- P.sepEndBy1 (pImportValue c) (pTok KSemiColon)-                pTok KBraceKet-                return specs+        , do    def     <- pDataDef ctx+                return  $ HeadDataDef def -         , do   pTok KForeign-                src     <- liftM (renderIndent . ppr) pName+        , do    (n, k, t) <- pTypeDef ctx+                return  $ HeadTypeDef n k t -                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-                 ]-         ]+        , do    pHeadPragma ctx +        ]  --- | Parse a type import spec.-pImportType-        :: (Ord n, Pretty n)-        => Context -> Parser n (ImportSpec n)-pImportType c- = do   n       <- pName-        pTokSP (KOp ":")+-- | Parse a type equation.+pTypeDef :: Ord n => Context n -> Parser n (n, Kind n, Type n)+pTypeDef c+ = do   pKey    EType+        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."----- | Parse a value import spec.-pImportValue-        :: (Ord n, Pretty n)-        => Context -> Parser n (ImportSpec n)-pImportValue c- = do   n       <- pName-        pTokSP (KOp ":")+        pSym SEquals         t       <- pType c-        return  (ImportValue n (ImportSourceModule (ModuleName []) n t))----- | 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."----- DataDef -----------------------------------------------------------------------------------------pDataDef :: Ord n => Context -> 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 -> 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]+        pSym SSemiColon+        return  (n, k, t)  --- | 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--        return  $ DataCtor-                { dataCtorName          = n+-- | 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 -                -- Set tag to 0 for now. We fix this up in pDataDef above.-                , dataCtorTag           = 0-                -                , dataCtorFieldTypes    = tsArg-                , dataCtorResultType    = tResult -                , dataCtorTypeName      = nData -                , dataCtorTypeParams    = bsParam }+         -- The type and value arity of a super.+         ["ARITY", name, strTypes, strValues, strBoxes]+          |  all isDigit strTypes+          ,  all isDigit strValues+          ,  all isDigit strBoxes+          ,  Just makeLitName <- contextMakeLiteralName ctx+          ,  Just n           <- makeLitName sp (LString (T.pack name)) True+          -> return $ HeadPragmaArity n+                (read strTypes) (read strValues) (read strBoxes) +         _ -> P.unexpected $ "pragma " ++ "{-# " ++ T.unpack txt ++ "#-}"
DDC/Core/Parser/Param.hs view
@@ -9,10 +9,10 @@ import DDC.Core.Exp import DDC.Core.Parser.Type import DDC.Core.Parser.Context-import DDC.Core.Parser.Base             (Parser)+import DDC.Core.Parser.Base import DDC.Core.Lexer.Tokens-import qualified DDC.Base.Parser        as P-import qualified DDC.Type.Compounds     as T+import qualified DDC.Type.Exp.Simple    as T+import qualified DDC.Control.Parser     as P   -- | Specification of a function parameter.@@ -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,45 +98,45 @@ -- pBindParamSpecAnnot          :: Ord n -        => Context -> Parser n [ParamSpec n]+        => Context n -> Parser n [ParamSpec n]  pBindParamSpecAnnot c  = P.choice         -- Type parameter         -- [BIND1 BIND2 .. BINDN : TYPE]- [ do   pTok KSquareBra+ [ do   pSym SSquareBra         bs      <- P.many1 pBinder         pTok (KOp ":")         t       <- pType c-        pTok KSquareKet+        pSym SSquareKet         return  [ ParamType b                  | b <- zipWith T.makeBindFromBinder bs (repeat t)]          -- Witness parameter         -- {BIND : TYPE}- , do   pTok KBraceBra+ , do   pSym SBraceBra         b       <- pBinder         pTok (KOp ":")         t       <- pType c-        pTok KBraceKet+        pSym SBraceKet         return  [ ParamWitness $ T.makeBindFromBinder b t]          -- Value parameter with type annotations.         -- (BIND1 BIND2 .. BINDN : TYPE)          -- (BIND1 BIND2 .. BINDN : TYPE) { TYPE | TYPE }- , do   pTok KRoundBra+ , do   pSym SRoundBra         bs      <- P.many1 pBinder         pTok (KOp ":")         t       <- pType c-        pTok KRoundKet+        pSym SRoundKet          (eff, clo)           <- P.choice-                [ do    pTok KBraceBra+                [ do    pSym SBraceBra                         eff'    <- pType c-                        pTok (KOp "|")+                        pSym SBar                         clo'    <- pType c-                        pTok KBraceKet+                        pSym SBraceKet                         return  (eff', clo')                                  , do    return  (T.tBot T.kEffect, T.tBot T.kClosure) ]
DDC/Core/Parser/Type.hs view
@@ -12,16 +12,15 @@ import DDC.Core.Parser.Context import DDC.Core.Parser.Base import DDC.Core.Lexer.Tokens   -import DDC.Type.Exp-import DDC.Type.Compounds-import DDC.Base.Parser                  ((<?>))-import qualified DDC.Base.Parser        as P+import DDC.Type.Exp.Simple+import DDC.Control.Parser               ((<?>))+import qualified DDC.Control.Parser     as P import qualified DDC.Type.Sum           as TS   -- | Parse a type. pType   :: Ord n -        => Context -> Parser n (Type n)+        => Context n -> Parser n (Type n)  pType c    =      pTypeSum c@@ -31,7 +30,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 @@ -54,11 +53,11 @@                 return  $ RName v                          -- Anonymous binders.-        , do    pTok KHat+        , do    pSym    SHat                 return  $ RAnon                   -- Vacant binders.-        , do    pTok KUnderscore+        , do    pSym    SUnderscore                 return  $ RNone ]  <?> "a binder" @@ -66,17 +65,29 @@ -- | Parse a quantified type. pTypeForall          :: Ord n -        => Context -> Parser n (Type n)+        => Context n -> Parser n (Type n) pTypeForall c  = P.choice-         [ -- Universal quantification.+         [ -- Type abstraction.+           do   pSym SLambda+                bs      <- P.many1 pBinder+                pTok (KOp ":")+                k       <- pTypeSum c+                pSym SDot++                tBody    <- pTypeForall c++                return  $ foldr TAbs tBody +                        $ map (\b -> makeBindFromBinder b k) bs++           -- Universal quantification.            -- [v1 v1 ... vn : T1]. T2-           do   pTok KSquareBra+         , do   pSym SSquareBra                 bs      <- P.many1 pBinder                 pTok (KOp ":")                 k       <- pTypeSum c-                pTok KSquareKet-                pTok KDot+                pSym SSquareKet+                pSym SDot                  body    <- pTypeForall c @@ -91,40 +102,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+           do   pSym    SArrowTilde+                t2      <- pTypeForall c                 return  $ TApp (TApp (TCon (TyConKind KiConFun)) t1) t2             -- T1 => T2-         , do   pTok KArrowEquals-                t2      <- pTypeFun c+         , do   pSym    SArrowEquals+                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-+         , do   pSym    SArrowDashRight+                t2      <- pTypeForall c+                return $ t1 `tFun`   t2             -- Body type          , do   return t1 ]@@ -134,7 +130,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 +140,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,19 +154,12 @@            -- (->)         , 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+        , do    pSym SRoundBra                 t       <- pTypeSum c-                pTok KRoundKet+                pSym SRoundKet                 return t           -- Named type constructors@@ -190,8 +179,8 @@                 return  $ TCon tc                      -- Bottoms.-        , do    pTokAs KBotEffect  (tBot kEffect)-        , do    pTokAs KBotClosure (tBot kClosure)+        , do    pTokAs (KBuiltin BPure)  (tBot kEffect)+        , do    pTokAs (KBuiltin BEmpty) (tBot kClosure)                -- Bound occurrence of a variable.         --  We don't know the kind of this variable yet, so fill in the@@ -211,32 +200,32 @@ pSoCon :: Parser n SoCon pSoCon  =   P.pTokMaybe f         <?> "a sort constructor"- where f (KA (KSoConBuiltin c)) = Just c-       f _                      = Nothing + where f (KA (KBuiltin (BSoCon c))) = Just c+       f _                          = Nothing    -- | Parse a builtin kind constructor. pKiCon :: Parser n KiCon pKiCon  =   P.pTokMaybe f         <?> "a kind constructor"- where f (KA (KKiConBuiltin c)) = Just c-       f _                      = Nothing + where f (KA (KBuiltin (BKiCon c))) = Just c+       f _                          = Nothing    -- | Parse a builtin type constructor. pTcCon :: Parser n TcCon pTcCon  =   P.pTokMaybe f         <?> "a type constructor"- where f (KA (KTcConBuiltin c)) = Just c-       f _                      = Nothing + where f (KA (KBuiltin (BTcCon c))) = Just c+       f _                          = Nothing    -- | Parse a builtin witness type constructor. pTwCon :: Parser n TwCon pTwCon  =   P.pTokMaybe f         <?> "a witness constructor"- where f (KA (KTwConBuiltin c)) = Just c-       f _                      = Nothing+ where f (KA (KBuiltin (BTwCon c))) = Just c+       f _                          = Nothing   -- | Parse a user defined type constructor.
DDC/Core/Parser/Witness.hs view
@@ -9,38 +9,34 @@ import DDC.Core.Parser.Base import DDC.Core.Lexer.Tokens import DDC.Core.Exp-import DDC.Base.Parser                  ((<?>), SourcePos)-import qualified DDC.Base.Parser        as P-import qualified DDC.Type.Compounds     as T+import DDC.Control.Parser               ((<?>), SourcePos)+import qualified DDC.Control.Parser     as P+import qualified DDC.Type.Exp.Simple    as T import Control.Monad    -- | 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,14 +51,14 @@ -- | 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  [ -- [TYPE]-   do   sp      <- pTokSP KSquareBra+   do   sp      <- pSym SSquareBra         t       <- pType c-        pTok KSquareKet+        pSym    SSquareKet         return  (WType sp t, sp)     -- WITNESS@@ -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,24 +79,19 @@ --   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    -- (WITNESS)- [ do   sp      <- pTokSP KRoundBra+ [ do   sp      <- pSym SRoundBra         w       <- pWitness c-        pTok KRoundKet+        pSym SRoundKet         return  (w, sp)     -- 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
− DDC/Core/Predicates.hs 
@@ -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-
DDC/Core/Pretty.hs view
@@ -2,22 +2,23 @@  -- | Pretty printing for core modules and expressions. module DDC.Core.Pretty -        ( module DDC.Type.Pretty-        , module DDC.Base.Pretty+        ( module DDC.Type.Exp.Simple.Pretty+        , module DDC.Data.Pretty         , PrettyMode (..)-        , pprExportType-        , pprExportValue-        , pprImportType-        , pprImportValue)+        , pprExportType, pprExportValue+        , pprImportType, pprImportValue+        , pprDataDef,    pprDataCtor+        , pprTypeDef) where-import DDC.Core.Compounds-import DDC.Core.Predicates import DDC.Core.Module-import DDC.Core.Exp+import DDC.Core.Exp.Annot.Exp+import DDC.Core.Exp.Annot.Pretty+import DDC.Core.Exp.Annot.Compounds+import DDC.Type.Exp.Simple.Pretty import DDC.Type.DataDef-import DDC.Type.Pretty-import DDC.Base.Pretty+import DDC.Data.Pretty import Data.List+import Prelude          hiding ((<$>))   -- ModuleName -------------------------------------------------------------------------------------@@ -46,8 +47,12 @@         , moduleExportTypes     = exportTypes         , moduleExportValues    = exportValues         , moduleImportTypes     = importTypes+        , moduleImportCaps      = importCaps         , moduleImportValues    = importValues+        , moduleImportDataDefs  = importData+        , moduleImportTypeDefs  = importType         , moduleDataDefsLocal   = localData+        , moduleTypeDefsLocal   = localType         , moduleBody            = body }   = {-# SCC "ppr[Module]" #-}     let @@ -56,7 +61,7 @@         -- Exports --------------------         dExportTypes          | null $ exportTypes   = empty-         | otherwise            = (vcat $ map pprExportType  exportTypes)   <> line+         | otherwise            = (vcat $ map pprExportType  exportTypes)  <> line          dExportValues          | null $ exportValues  = empty@@ -65,8 +70,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@@ -76,90 +85,133 @@          | modeModuleSuppressImports mode           = empty          -         -- If there are no imports or exports then suppress printint.-         | null exportTypes, null exportValues, null importTypes, null importValues+         -- If there are no imports or exports then suppress printing.+         | 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)-                  ++        -- Type Definitions -----+        docsTypeImport+         | null importType = empty+         | otherwise+         = line <> vsep  (map (\i -> text "import" <+> pprTypeDef i) $ importType)++        docsTypeLocal+         | null localType  = empty+         | otherwise+         = line <> vsep  (map pprTypeDef localType)+         pprLts = pprModePrec (modeModuleLets mode) 0      in  text "module" <+> ppr name           <+> docsImportsExports-         <>  docsLocalData-         <>  text "with" <$$> (vcat $ map pprLts lts)+         <>  docsDataImport+         <>  docsDataLocal+         <>  docsTypeImport+         <>  docsTypeLocal+         <>  (case lts of+                []       -> empty+                [LRec[]] -> empty+                _        -> text "with" <$$> (vcat $ map pprLts lts))   -- Exports ---------------------------------------------------------------------------------------- -- | Pretty print an exported type definition.-pprExportType :: (Pretty n, Eq n) => (n, ExportSource n) -> Doc+pprExportType :: (Pretty n, Pretty t) => (n, ExportSource n t) -> Doc 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.-pprExportValue :: (Pretty n, Eq n) => (n, ExportSource n) -> Doc+pprExportValue :: (Pretty n, Pretty t) => (n, ExportSource n t) -> Doc 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, Pretty t) => (n, ImportType n t) -> 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, Pretty t) => (n, ImportCap n t) -> 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, Pretty t) => (n, ImportValue n t) -> 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 ---------------------------------------------------------------------------------------- instance (Pretty n, Eq n) => Pretty (DataDef n) where- pprPrec _ def-  = {-# SCC "ppr[DataDef]" #-}-      (text "data" -        <+> ppr (dataDefTypeName def)-        <+> hsep (map (parens . ppr) (dataDefParams def))+ pprPrec _ def = pprDataDef def+++-- | Pretty print a data type definition.+pprDataDef :: (Pretty n, Eq n) => DataDef n -> Doc+pprDataDef def+  =   (text "data" +        <+> hsep ( ppr (dataDefTypeName def)+                 : map (parens . ppr) (dataDefParams def))         <+> text "where"         <+>  lbrace)   <$> (case dataDefCtors def of@@ -169,357 +221,31 @@          Nothing          -> text "LARGE")-  <> line-  <> rbrace-  <> line+  <> line <> rbrace <> line   -- DataCtor --------------------------------------------------------------------------------------- instance (Pretty n, Eq n) => Pretty (DataCtor n) where- pprPrec _ ctor+ pprPrec _ def = pprDataCtor def+++-- | Pretty print a data constructor definition.+pprDataCtor :: (Pretty n, Eq n) => DataCtor n -> Doc+pprDataCtor ctor         =   ppr (dataCtorName ctor)         <+> text ":"         <+> (hsep $ punctuate (text " ->")                    $ (map (pprPrec 6) -                        (  dataCtorFieldTypes ctor+                        (   dataCtorFieldTypes ctor                         ++ [dataCtorResultType ctor])))    --- Exp ---------------------------------------------------------------------------------------------instance (Pretty n, Eq n) => Pretty (Exp a n) where- data PrettyMode (Exp a n)-        = PrettyModeExp-        { modeExpLets           :: PrettyMode (Lets a n)-        , modeExpAlt            :: PrettyMode (Alt a n)-        -          -- Display types on primitive variables.-        , modeExpVarTypes       :: Bool--          -- Display types on primitive constructors.-        , modeExpConTypes       :: Bool-        -          -- Use 'letcase' for single alternative case expressions.-        , modeExpUseLetCase     :: Bool }--- pprDefaultMode-        = PrettyModeExp-        { modeExpLets           = pprDefaultMode-        , modeExpAlt            = pprDefaultMode-        , modeExpConTypes       = False-        , modeExpVarTypes       = False-        , 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--        XVar  _ u       -         | modeExpVarTypes mode-         , Just t       <- takeTypeOfBound u-         -> parens $ ppr u <> text " : " <> ppr t--         | otherwise-         -> ppr u---        XCon  _ dc-         | modeExpConTypes mode-         , Just t       <- takeTypeOfDaCon dc-         -> parens $ ppr dc <> text " : " <> ppr t-        -         | otherwise-         -> ppr dc-        -        -        XLAM{}-         -> let Just (bs, xBody) = takeXLAMs xx-                groups = partitionBindsByType bs-            in  pprParen' (d > 1)-                 $  (cat $ map (pprBinderGroup (text "/\\")) groups)-                 <>  (if      isXLAM    xBody then empty-                      else if isXLam    xBody then line <> space-                      else if isSimpleX xBody then space-                      else    line)-                 <>  pprX xBody--        XLam{}-         -> let Just (bs, xBody) = takeXLams xx-                groups = partitionBindsByType bs-            in  pprParen' (d > 1)-                 $  (cat $ map (pprBinderGroup (text "\\")) groups) -                 <> breakWhen (not $ isSimpleX xBody)-                 <> pprX xBody--        XApp _ x1 x2-         -> pprParen' (d > 10)-         $  pprModePrec mode 10 x1 -                <> nest 4 (breakWhen (not $ isSimpleX x2) -                          <> pprModePrec mode 11 x2)--        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--        XType    _ t    -> text "[" <> ppr t <> text "]"-        XWitness _ w    -> text "<" <> ppr w <> text ">"----- Pat ---------------------------------------------------------------------------------------------instance (Pretty n, Eq n) => Pretty (Pat n) where- ppr pp-  = case pp of-        PDefault        -> text "_"-        PData u bs      -> ppr u <+> sep (map pprPatBind bs)----- | Pretty print a binder, ---   showing its type annotation only if it's not bottom.-pprPatBind :: (Eq n, Pretty n) => Bind n -> Doc-pprPatBind b-        | isBot (typeOfBind b)  = ppr $ binderOfBind b-        | otherwise             = parens $ ppr b----- Alt ---------------------------------------------------------------------------------------------instance (Pretty n, Eq n) => Pretty (Alt a n) where- data PrettyMode (Alt a n)-        = PrettyModeAlt-        { modeAltExp            :: PrettyMode (Exp a n) }-- 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))----- DaCon -------------------------------------------------------------------------------------------instance (Pretty n, Eq n) => Pretty (DaCon n) where- ppr dc-  = case dc of-        DaConUnit       -> text "()"-        DaConPrim  n _  -> ppr n-        DaConBound n    -> ppr n----- Cast --------------------------------------------------------------------------------------------instance (Pretty n, Eq n) => Pretty (Cast a n) where- ppr cc-  = case cc of-        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"--        CastRun-         -> text "run"----- Lets --------------------------------------------------------------------------------------------instance (Pretty n, Eq n) => Pretty (Lets a n) where- data PrettyMode (Lets a n)-        = PrettyModeLets-        { modeLetsExp           :: PrettyMode (Exp a n) -        , modeLetsSuppressTypes :: Bool }-- pprDefaultMode-        = PrettyModeLets-        { modeLetsExp           = pprDefaultMode -        , modeLetsSuppressTypes = False }-- pprModePrec mode _ lts-  = let pprX    = pprModePrec (modeLetsExp mode) 0-    in case lts of-        LLet b x-         -> let dBind = if  isBot (typeOfBind b)-                         || modeLetsSuppressTypes mode-                          then ppr (binderOfBind b)-                          else ppr b-            in  text "let"-                 <+> align (  dBind-                           <> nest 2 ( breakWhen (not $ isSimpleX x)-                                     <> text "=" <+> align (pprX x)))--        LRec bxs-         -> let pprLetRecBind (b, x)-                 =   ppr (binderOfBind b)-                 <+> text ":"-                 <+> ppr (typeOfBind 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 . binderOfBind) bs))--        LPrivate bs Nothing bws-         -> text "private"-                <+> (hcat $ punctuate space (map (ppr . binderOfBind) bs))-                <+> text "with"-                <+> braces (cat $ punctuate (text "; ") $ map pprWitBind bws)--        LPrivate bs (Just parent) []-         -> text "extend"-                <+> ppr parent-                <+> text "using"-                <+> (hcat $ punctuate space (map (ppr . binderOfBind) bs))--        LPrivate bs (Just parent) bws-         -> text "extend"-                <+> ppr parent-                <+> text "using"-                <+> (hcat $ punctuate space (map (ppr . binderOfBind) bs))-                <+> 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-pprWitBind b- = case b of-        BNone t -> ppr t-        _       -> ppr b----- Witness -----------------------------------------------------------------------------------------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 "]"---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 ------------------------------------------------------------------------------------------pprBinder   :: Pretty n => Binder n -> Doc-pprBinder bb- = case bb of-        RName v         -> ppr v-        RAnon           -> text "^"-        RNone           -> text "_"----- | Print a group of binders with the same type.-pprBinderGroup -        :: (Pretty n, Eq n) -        => Doc -> ([Binder n], Type n) -> Doc--pprBinderGroup lam (rs, t)-        =  lam -        <> parens ((hsep $ map pprBinder rs) <+> text ":" <+> ppr t) -        <> dot----- Utils -------------------------------------------------------------------------------------------breakWhen :: Bool -> Doc-breakWhen True   = line-breakWhen False  = space---isSimpleX :: Exp a n -> Bool-isSimpleX xx- = case xx of-        XVar{}          -> True-        XCon{}          -> True-        XType{}         -> True-        XWitness{}      -> True-        XApp _ x1 x2    -> isSimpleX x1 && isAtomX x2-        _               -> False---parens' :: Doc -> Doc-parens' d = lparen <> nest 1 d <> rparen-+-- TypeDef -----------------------------------------------------------------------------------------+-- | Pretty print a type definition.+pprTypeDef :: (Pretty n, Eq n) => (n, (Kind n, Type n)) -> Doc +pprTypeDef (n, (k, t))+ =  text "type" <+> ppr n +                <+> text ":" <+> ppr k+                <+> text "=" <+> ppr t+ <> semi <> line --- | Wrap a `Doc` in parens if the predicate is true.-pprParen' :: Bool -> Doc -> Doc-pprParen' b c- = if b then parens' c-        else c
− DDC/Core/Transform/Annotate.hs 
@@ -1,92 +0,0 @@--module DDC.Core.Transform.Annotate-        (Annotate (..))-where-import qualified DDC.Core.Exp.Annot     as A-import qualified DDC.Core.Exp.Simple    as S----- | Convert the `Simple` version of the AST to the `Annot` version,---   using a the provided default annotation value.-class Annotate  -        (c1 :: * -> * -> *) -        (c2 :: * -> * -> *) | c1 -> c2 - where- annotate :: a -> c1 a n -> c2 a n---instance Annotate S.Exp A.Exp where- annotate def xx-  = let down     = annotate def-    in case xx of-        S.XAnnot _ (S.XAnnot a x)       -> down (S.XAnnot a x)-        S.XAnnot a (S.XVar   u)         -> A.XVar      a u-        S.XAnnot a (S.XCon   dc)        -> A.XCon      a dc-        S.XAnnot a (S.XLAM   b x)       -> A.XLAM      a b   (down x)-        S.XAnnot a (S.XLam   b x)       -> A.XLam      a b   (down x)-        S.XAnnot a (S.XApp   x1 x2)     -> A.XApp      a     (down x1)  (down x2)-        S.XAnnot a (S.XLet   lts x)     -> A.XLet      a     (down lts) (down x)-        S.XAnnot a (S.XCase  x alts)    -> A.XCase     a     (down x)   (map down alts)-        S.XAnnot a (S.XCast  c x)       -> A.XCast     a     (down c)   (down x)-        S.XAnnot a (S.XType    t)       -> A.XType     a t-        S.XAnnot a (S.XWitness w)       -> A.XWitness  a (down w)--        S.XVar  u                       -> A.XVar      def u-        S.XCon  dc                      -> A.XCon      def dc-        S.XLAM  b x                     -> A.XLAM      def b (down x)-        S.XLam  b x                     -> A.XLam      def b (down x)-        S.XApp  x1 x2                   -> A.XApp      def   (down x1)  (down x2)-        S.XLet  lts x                   -> A.XLet      def   (down lts) (down x)-        S.XCase x alts                  -> A.XCase     def   (down x)   (map down alts)-        S.XCast c x                     -> A.XCast     def   (down c)   (down x)-        S.XType t                       -> A.XType     def t-        S.XWitness w                    -> A.XWitness  def (down w)---instance Annotate S.Cast A.Cast where- annotate def cc-  = 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---instance Annotate S.Lets A.Lets where- annotate def lts-  = let down    = annotate def-    in case lts of-        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)---instance Annotate S.Witness A.Witness where- annotate def wit-  = let down    = annotate def-    in case wit of-        S.WAnnot _ (S.WAnnot a x)       -> down (S.WAnnot a x)-        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--
+ DDC/Core/Transform/BoundT.hs view
@@ -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
+ DDC/Core/Transform/BoundX.hs view
@@ -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++
− DDC/Core/Transform/Deannotate.hs 
@@ -1,78 +0,0 @@--module DDC.Core.Transform.Deannotate-        (Deannotate(..))-where-import qualified DDC.Core.Exp.Annot     as A-import qualified DDC.Core.Exp.Simple    as S----- | Convert the `Annot` version of the AST to the `Simple` version,---   using the provided function to decide when to keep the annotation.-class Deannotate -        (c1 :: * -> * -> *)-        (c2 :: * -> * -> *) | c1 -> c2- where  - deannotate :: (a -> Maybe a) -> c1 a n -> c2 a n---instance Deannotate A.Exp S.Exp where- deannotate f xx-  = let down      = deannotate f -        wrap a x  = case f a of-                        Nothing -> x-                        Just a' -> S.XAnnot a' x-    in case xx of-        A.XVar  a u             -> wrap a (S.XVar u)-        A.XCon  a dc            -> wrap a (S.XCon dc)-        A.XLAM  a b x           -> wrap a (S.XLAM b (down x))-        A.XLam  a b x           -> wrap a (S.XLam b (down x))-        A.XApp  a x1 x2         -> wrap a (S.XApp   (down x1)  (down x2))-        A.XLet  a lts x2        -> wrap a (S.XLet   (down lts) (down x2))-        A.XCase a x alts        -> wrap a (S.XCase  (down x)   (map down alts))-        A.XCast a cc x          -> wrap a (S.XCast  (down cc)  (down x))-        A.XType a t             -> wrap a (S.XType t)-        A.XWitness a w          -> wrap a (S.XWitness (down w))---instance Deannotate A.Lets S.Lets where- deannotate f lts-  = let down    = deannotate f-    in case lts of-        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)---instance Deannotate A.Witness S.Witness where- deannotate f ww-  = let down     = deannotate f-        wrap a x = case f a of-                        Nothing -> x-                        Just a' -> S.WAnnot a' x-    in case ww of-        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)---instance Deannotate A.Cast S.Cast where- deannotate f cc-  = 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--
− DDC/Core/Transform/LiftT.hs 
@@ -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
− DDC/Core/Transform/LiftX.hs 
@@ -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--
DDC/Core/Transform/MapT.hs view
@@ -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+  +
DDC/Core/Transform/Reannotate.hs view
@@ -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 -                 exportKinds  exportTypes -                 importKinds  importTypes-                 dataDefsLocal+ reannotateM f+     (ModuleCore name isHeader+                 exportKinds   exportTypes +                 importKinds   importCaps   importTypes  importDataDefs importTypeDefs+                 dataDefsLocal typeDefsLocal                  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 importTypeDefs+                        dataDefsLocal typeDefsLocal+                        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
DDC/Core/Transform/Rename.hs view
@@ -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)
DDC/Core/Transform/SpreadX.hs view
@@ -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,60 @@ --------------------------------------------------------------------------------------------------- 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 $ spreadExportSourceT kenv)+                $ moduleExportTypes mm++        , moduleExportValues    +                = map (liftSnd $ spreadExportSourceT 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 $ spreadImportTypeT kenv tenv) +                $ moduleImportTypes mm++        , moduleImportCaps+                = map (liftSnd $ spreadImportCapX kenv tenv)+                $ moduleImportCaps mm++        , moduleImportValues    +                = map (liftSnd $ spreadImportValueX kenv tenv) +                $ moduleImportValues mm++        , moduleImportDataDefs  +                = map (spreadT kenv)+                $ moduleImportDataDefs mm++        , moduleImportTypeDefs+                = map (\(n, (k, t)) -> (n, (spreadT kenv k, spreadT kenv t)))+                $ moduleImportTypeDefs mm++        , moduleDataDefsLocal   +                = map (spreadT kenv)+                $ moduleDataDefsLocal mm   -        , moduleBody          = spreadX kenv tenv (moduleBody mm) }-        where liftSnd f (x, y) = (x, f y)+        , moduleTypeDefsLocal+                = map (\(n, (k, t)) -> (n, (spreadT kenv k, spreadT kenv t)))+                $ moduleTypeDefsLocal mm +        , moduleBody           +                 = spreadX kenv tenv+                 $ moduleBody mm +        } + ----------------------------------------------------------------------------------------------------instance SpreadT ExportSource where- spreadT kenv esrc+spreadExportSourceT kenv esrc   = case esrc of-        ExportSourceLocal n t+        ExportSourceLocal n t             -> ExportSourceLocal n (spreadT kenv t)          ExportSourceLocalNoType n@@ -50,27 +85,40 @@   ----------------------------------------------------------------------------------------------------instance SpreadX ImportSource where- spreadX kenv _tenv isrc+spreadImportTypeT 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) +---------------------------------------------------------------------------------------------------+spreadImportCapX kenv _tenv isrc+  = case isrc of+        ImportCapAbstract t+         -> ImportCapAbstract   (spreadT kenv t) + ---------------------------------------------------------------------------------------------------+spreadImportValueX 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 #-}     let down x = spreadX kenv tenv x     in case xx of         XVar a u        -> XVar a (down u)-        XCon a u        -> XCon a (down u)+        XCon a d        -> XCon a (spreadDaCon kenv tenv d)         XApp a x1 x2    -> XApp a (down x1) (down x2)          XLAM a b x@@ -94,8 +142,7 @@   ----------------------------------------------------------------------------------------------------instance SpreadX DaCon where- spreadX _kenv tenv dc+spreadDaCon _kenv tenv dc   = case dc of         DaConUnit                 -> dc@@ -123,9 +170,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 @@ -136,7 +181,7 @@   = let down x   = spreadX kenv tenv x     in case pat of         PDefault        -> PDefault-        PData u bs      -> PData (down u) (map down bs)+        PData u bs      -> PData (spreadDaCon kenv tenv u) (map down bs)   ---------------------------------------------------------------------------------------------------@@ -171,10 +216,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 +225,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)
DDC/Core/Transform/SubstituteTX.hs view
@@ -11,8 +11,8 @@         , substituteBoundTX) where import DDC.Core.Collect-import DDC.Core.Exp-import DDC.Type.Compounds+import DDC.Core.Exp.Annot.Exp+import DDC.Type.Exp.Simple import DDC.Type.Transform.SubstituteT import DDC.Type.Transform.Rename import Data.Maybe@@ -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)
DDC/Core/Transform/SubstituteWX.hs view
@@ -9,11 +9,11 @@         , 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.Type.Compounds+import DDC.Core.Transform.BoundX+import DDC.Type.Exp.Simple import Data.Maybe import qualified DDC.Type.Env   as Env import qualified Data.Set       as Set@@ -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)
DDC/Core/Transform/SubstituteXX.hs view
@@ -11,14 +11,14 @@         , substituteXArg         , substituteXArgs) where-import DDC.Core.Exp+import DDC.Core.Exp.Annot.Exp import DDC.Core.Collect-import DDC.Core.Transform.LiftX-import DDC.Type.Compounds+import DDC.Core.Transform.BoundX import DDC.Core.Transform.SubstituteWX import DDC.Core.Transform.SubstituteTX import DDC.Type.Transform.SubstituteT import DDC.Type.Transform.Rename+import DDC.Type.Exp.Simple import Data.Maybe import qualified DDC.Type.Env   as Env import qualified Data.Set       as Set@@ -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
− DDC/Core/Transform/Trim.hs 
@@ -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))]--        _                    -> []-
+ DDC/Data/Canned.hs view
@@ -0,0 +1,13 @@++module DDC.Data.Canned+        (Canned(..))+where++-- | This function has a show instance that prints \"CANNED\" for any contained+--   type. We use it to wrap functional fields in data types that we still want+--   to derive Show instances for.+data Canned a+        = Canned a++instance Show (Canned a) where+        show _ = "CANNED"
+ DDC/Data/Env.hs view
@@ -0,0 +1,174 @@++-- | Generic environment that handles both named and anonymous+--   de-bruijn binders.+module DDC.Data.Env+        ( -- * Types+          Bind   (..)+        , Bound  (..)+        , Env    (..)++          -- * Conversion+        , fromList+        , fromNameList+        , fromNameMap++          -- * Constructors+        , empty+        , singleton+        , extend,       extends+        , union,        unions++          -- * Lookup+        , member+        , lookup+        , lookupName,   lookupIx+        , depth)+where+import Data.Maybe+import Data.Map                         (Map)+import qualified Data.Map.Strict        as Map+import qualified Prelude                as P+import Prelude                          hiding (lookup)+++-------------------------------------------------------------------------------+-- | A binding occurrence of a variable.+data Bind n+        -- | No binding, or alternatively, bind a fresh name that has+        --   no bound uses.+        = BNone++        -- | Anonymous binder.+        | BAnon++        -- | Named binder.+        | BName !n+        deriving (Eq, Ord, Show)+++-- | A bound occurrence of a variable.+data Bound n+        -- | Index an anonymous binder.+        = UIx   !Int++        -- | Named variable.+        | UName !n+        deriving (Eq, Ord, Show)+++-- | Generic environment that maps a variable to a thing of type @a@. +data Env n a+        = Env+        { -- | Named things.+          envMap         :: !(Map n a)++          -- | Anonymous things.+        , envStack       :: ![a] +        +          -- | Length of the stack.+        , envStackLength :: !Int }+++-------------------------------------------------------------------------------+-- | Convert a list of `Bind`s to an environment.+fromList :: Ord n => [(Bind n, a)] -> Env n a+fromList bs+        = foldr (uncurry extend) empty bs+++-- | Convert a list of `Bind`s to an environment.+fromNameList :: Ord n => [(n, a)] -> Env n a+fromNameList bs+        = foldr (uncurry extend) empty +        $ [(BName n, x) | (n, x) <- bs ]+++-- | Convert a map of things to an environment.+fromNameMap :: Map n a -> Env n a+fromNameMap m+        = empty { envMap = m }+++---------------------------------------------------------------------------------+-- | An empty environment, with nothing in it.+empty :: Env n a+empty   = Env+        { envMap         = Map.empty+        , envStack       = [] +        , envStackLength = 0 }+++-- | Construct a singleton environment.+singleton :: Ord n => Bind n -> a -> Env n a+singleton b x+        = extend b x empty+++-- | Extend an environment with a new binding.+--   Replaces bindings with the same name already in the environment.+extend :: Ord n => Bind n -> a -> Env n a -> Env n a+extend bb x env+ = case bb of+         BNone{}        -> env++         BAnon          -> env { envStack       = x : envStack env +                               , envStackLength = envStackLength env + 1 }++         BName n        -> env { envMap         = Map.insert n x (envMap env) }+++-- | Extend an environment with a list of new bindings.+--   Replaces bindings with the same name already in the environment.+extends :: Ord n => [(Bind n, a)] -> Env n a -> Env n a+extends bs env+        = foldl (flip (uncurry extend)) env bs+++-- | Combine two environments.+--   If both environments have a binding with the same name,+--   then the one in the second environment takes preference.+union :: Ord n => Env n a -> Env n a -> Env n a+union env1 env2+        = Env  +        { envMap         = envMap env1 `Map.union` envMap env2+        , envStack       = envStack       env2  ++ envStack       env1+        , envStackLength = envStackLength env2  +  envStackLength env1 }+++-- | Combine multiple environments,+--   with the latter ones taking preference.+unions :: Ord n => [Env n a] -> Env n a+unions envs+        = foldr union empty envs+++-- | Check whether a bound variable is present in an environment.+member :: Ord n => Bound n -> Env n a -> Bool+member uu env+        = isJust $ lookup uu env+++-- | Lookup a bound variable from an environment.+lookup :: Ord n => Bound n -> Env n a -> Maybe a+lookup uu env+ = case uu of+        UIx i           -> P.lookup i (zip [0..] (envStack env))+        UName n         -> Map.lookup n (envMap env) +++-- | Lookup a value from the environment based on its name.+lookupName :: Ord n => n -> Env n a -> Maybe a+lookupName n env+        = Map.lookup n (envMap env)+++-- | Lookup a value from the environment based on its index.+lookupIx :: Ord n => Int -> Env n a -> Maybe a+lookupIx ix env+        = P.lookup ix (zip [0..] (envStack env))+++-- | Yield the total depth of the anonymous stack.+depth :: Env n a -> Int+depth env       = envStackLength env+
+ DDC/Data/ListUtils.hs view
@@ -0,0 +1,75 @@++-- | Replacements for unhelpful Haskell list functions.+--   If the standard versions are passed an empty list then we don't+--   get a proper source location.+module DDC.Data.ListUtils+        ( takeHead+        , takeTail+        , takeInit+        , takeMaximum+        , index+        , findDuplicates+        , stripSuffix)+where+import Data.List+import qualified Data.Set as Set+++-- | Take the head of a list, or `Nothing` if it's empty.+takeHead :: [a] -> Maybe a+takeHead xs+ = case xs of+        []      -> Nothing+        _       -> Just (head xs)+++-- | Take the tail of a list, or `Nothing` if it's empty.+takeTail :: [a] -> Maybe [a]+takeTail xs+ = case xs of+        []      -> Nothing+        _       -> Just (tail xs)+++-- | Take the init of a list, or `Nothing` if it's empty.+takeInit :: [a] -> Maybe [a]+takeInit xs+ = case xs of+        []      -> Nothing+        _       -> Just (init xs)+++-- | Take the maximum of a list, or `Nothing` if it's empty.+takeMaximum :: Ord a => [a] -> Maybe a+takeMaximum xs+ = case xs of+        []      -> Nothing+        _       -> Just (maximum xs)+++-- | Retrieve the element at the given index,+--   or `Nothing if it's not there.+index :: [a] -> Int -> Maybe a+index [] _              = Nothing+index (x : _)  0        = Just x+index (_ : xs) i        = index xs (i - 1)++++-- | Find the duplicate values in a list.+findDuplicates :: Ord n => [n] -> [n]+findDuplicates xx+ = go (Set.fromList xx) xx+ where  go _  []            = []+        go ss (x : xs)+         | Set.member x ss  =     go (Set.delete x ss) xs+         | otherwise        = x : go ss xs+++-- | Drops the given suffix from a list.+stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]+stripSuffix suff xx+ = case stripPrefix (reverse suff) (reverse xx) of+        Nothing -> Nothing+        Just xs -> Just $ reverse xs+
+ DDC/Data/Name.hs view
@@ -0,0 +1,25 @@++module DDC.Data.Name+        ( StringName   (..)+        , CompoundName (..))+where++class StringName n where+        -- | Produce a flat string from a name.+        --   The resulting string should be re-lexable as a bindable name.+        stringName      :: n -> String+++-- | Compound names can be extended to create new names.+--   This is useful when generating fresh names during program transformation.+class CompoundName n where+        -- | Build a new name based on the given one.+        extendName      :: n -> String -> n+        +        -- | Build a new name from the given string.+        newVarName      :: String -> n++        -- | Split the extension string from a name.+        splitName       :: n -> Maybe (n, String)++
+ DDC/Data/Pretty.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE TypeFamilies #-}++-- | Pretty printer utilities.+--+--   This is a re-export of Daan Leijen's pretty printer package (@wl-pprint@),+--   but with a `Pretty` class that includes a `pprPrec` function.+module DDC.Data.Pretty+        ( module Text.PrettyPrint.Leijen+        , Pretty(..)+        , pprParen+        , padL++        -- * Rendering+        , RenderMode (..)+        , render+        , renderPlain+        , renderIndent+        , putDoc, putDocLn)+where+import Data.Set                          (Set)+import qualified Data.Set                as Set+import qualified Text.PrettyPrint.Leijen as P+import Text.PrettyPrint.Leijen           +       hiding (Pretty(..), renderPretty, putDoc)++-- Utils ---------------------------------------------------------------------+-- | Wrap a `Doc` in parens if the predicate is true.+pprParen :: Bool -> Doc -> Doc+pprParen b c+ = if b then parens c+        else c+++-- Pretty Class --------------------------------------------------------------+class Pretty a where+ data PrettyMode a + pprDefaultMode :: PrettyMode a+ + ppr            :: a   -> Doc+ ppr            = pprPrec 0 ++ pprPrec        :: Int -> a -> Doc+ pprPrec p      = pprModePrec pprDefaultMode p++ pprModePrec    :: PrettyMode a -> Int -> a -> Doc+ pprModePrec _ _ x = ppr x++ +instance Pretty () where+ ppr = text . show++instance Pretty Bool where+ ppr = text . show++instance Pretty Int where+ ppr = text . show++instance Pretty Integer where+ ppr = text . show++instance Pretty Char where+ ppr = text . show++instance Pretty a => Pretty [a] where+ ppr xs  = encloseSep lbracket rbracket comma +         $ map ppr xs++instance Pretty a => Pretty (Set a) where+ ppr xs  = encloseSep lbracket rbracket comma +         $ map ppr $ Set.toList xs++instance (Pretty a, Pretty b) => Pretty (a, b) where+ ppr (a, b) = parens $ ppr a <> comma <> ppr b+++padL :: Int -> Doc -> Doc+padL n d+ = let  len     = length $ renderPlain d+        pad     = n - len+   in   if pad > 0+         then  d <> text (replicate pad ' ')+         else  d+++-- Rendering ------------------------------------------------------------------+-- | How to pretty print a doc.+data RenderMode+        -- | Render the doc with indenting.+        = RenderPlain++        -- | Render the doc without indenting.+        | RenderIndent+        deriving (Eq, Show)+++-- | Render a doc with the given mode.+render :: RenderMode -> Doc -> String+render mode doc+ = case mode of+        RenderPlain  -> eatSpace True $ displayS (renderCompact doc) ""+        RenderIndent -> displayS (P.renderPretty 0.8 100000 doc) ""++ where  eatSpace :: Bool -> String -> String+        eatSpace _    []        = []+        eatSpace True (c:cs)+         = case c of+                ' '     -> eatSpace True cs+                '\n'    -> eatSpace True cs+                _       -> c   : eatSpace False cs++        eatSpace False (c:cs)+         = case c of+                ' '     -> ' ' : eatSpace True cs+                '\n'    -> ' ' : eatSpace True cs+                _       -> c   : eatSpace False cs+++-- | Convert a `Doc` to a string without indentation.+renderPlain :: Doc -> String+renderPlain = render RenderPlain+++-- | Convert a `Doc` to a string with indentation+renderIndent :: Doc -> String+renderIndent = render RenderIndent+++-- | Put a `Doc` to `stdout` using the given mode.+putDoc :: RenderMode -> Doc -> IO ()+putDoc mode doc+        = putStr   $ render mode doc++-- | Put a `Doc` to `stdout` using the given mode.+putDocLn  :: RenderMode -> Doc -> IO ()+putDocLn mode doc+        = putStrLn $ render mode doc+++
+ DDC/Data/SourcePos.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE TypeFamilies #-}+module DDC.Data.SourcePos+        ( SourcePos             (..)+        , Located               (..)+        , sourcePosOfLocated+        , parsecSourcePosOfLocated+        , nameOfLocated+        , lineOfLocated+        , columnOfLocated+        , valueOfLocated)+where+import DDC.Data.Pretty+import Control.DeepSeq+import qualified Text.Parsec.Pos        as Parsec++-- | A position in a source file.        +--+--   If there is no file path then we assume that the input has been read+--   from an interactive session and display ''<interactive>'' when pretty printing.+data SourcePos +        = SourcePos+        { sourcePosSource       :: String+        , sourcePosLine         :: Int+        , sourcePosColumn       :: Int }+        deriving (Eq, Show)+++instance NFData SourcePos where+ rnf (SourcePos str l c)+  = rnf str `seq` rnf l `seq` rnf c+++instance Pretty SourcePos where+ -- Suppress printing of line and column number when they are both zero.+ -- File line numbers officially start from 1, so having 0 0 probably+ -- means this isn't real information.+ ppr (SourcePos source 0 0)+        = text $ source++ ppr (SourcePos source l c)     +        = text $ source ++ ":" ++ show l ++ ":" ++ show c+++-- | A located thing.+data Located a+        = Located !SourcePos !a+        deriving (Eq, Show)+++-- | Take the source position of a located thing.+sourcePosOfLocated :: Located a -> SourcePos+sourcePosOfLocated (Located sp _)       = sp+++-- | Take the parsec source position of a located thing.+parsecSourcePosOfLocated :: Located a -> Parsec.SourcePos+parsecSourcePosOfLocated+        (Located (SourcePos name l col) _)+        = Parsec.newPos name l col+++-- | Yield the source name of a located thing.+nameOfLocated :: Located a -> String+nameOfLocated (Located (SourcePos name _ _) _) = name+++-- | Yield the line number of a located thing.+lineOfLocated :: Located a -> Int+lineOfLocated (Located (SourcePos _ l _) _)    = l+++-- | Yield the column number of a located thing.+columnOfLocated :: Located a -> Int+columnOfLocated (Located (SourcePos _ _ c) _) = c+++-- | Yield the contained value of a located thing.+valueOfLocated  :: Located a -> a+valueOfLocated (Located _ x)    = x
− DDC/Type/Check.hs 
@@ -1,88 +0,0 @@--- | Check the kind of a type.-module DDC.Type.Check-        ( Config        (..)-        , configOfProfile--          -- * Checking types.-        , checkType-        , checkTypeM--          -- * Wrappers for specific universes.-        , checkSpec-        , kindOfSpec-        , sortOfKind--          -- * Kinds of Constructors-        , takeSortOfKiCon-        , kindOfTwCon-        , kindOfTcCon-        -          -- * Errors-        , Error         (..)-        , ErrorData     (..))-where-import DDC.Type.Check.Judge.Kind-import DDC.Type.Check.Context-import DDC.Type.Check.Error-import DDC.Type.Check.ErrorMessage      ()-import DDC.Type.Check.CheckCon-import DDC.Type.Check.Config-import DDC.Type.Universe-import DDC.Type.Exp-import DDC.Base.Pretty-import DDC.Type.Pretty                   ()-import DDC.Type.Env                      (KindEnv)-import DDC.Control.Monad.Check           (evalCheck)-import qualified DDC.Type.Env            as Env----- | Check a type in the given universe with the given environment---   Returns the updated type and its classifier (a kind or sort),---   depeding on the universe of the type being checked.-checkType  :: (Ord n, Show n, Pretty n)-           => Config n -> KindEnv n -> Universe -> Type n-           -> Either (Error n) (Type n, Type n)--checkType config env uni tt- = evalCheck (0, 0)- $ do   (t, k, _) <- checkTypeM config env emptyContext -                        uni tt Recon-        return (t, k)----- | Check a spec in the given environment, returning an error or its kind.-checkSpec  :: (Ord n, Show n, Pretty n) -           => Config n -> KindEnv n -> Type n-           -> Either (Error n) (Type n, Kind n)--checkSpec config env tt - = evalCheck (0, 0)- $ do   (t, k, _) <- checkTypeM config env emptyContext -                        UniverseSpec tt Recon-        return (t, k)----- | Check a spec in an empty environment, returning an error or its kind.-kindOfSpec-        :: (Ord n, Show n, Pretty n) -        => Config n -> Type n -        -> Either (Error n) (Kind n)--kindOfSpec config tt- = evalCheck (0, 0)- $ do   (_, k, _) <- checkTypeM config Env.empty emptyContext -                        UniverseSpec tt Recon-        return k----- | Check a kind in an empty environment, returning an error or its sort.-sortOfKind -        :: (Ord n, Show n, Pretty n)-        => Config n -> Kind n-        -> Either (Error n) (Sort n)--sortOfKind config tt- = evalCheck (0, 0)- $ do   (_, s, _) <- checkTypeM config Env.empty emptyContext -                        UniverseKind tt Recon-        return s
− DDC/Type/Check/Base.hs 
@@ -1,50 +0,0 @@--module DDC.Type.Check.Base-        ( CheckM-        , newExists-        , newPos--        , throw--        , module DDC.Type.Check.Context-        , module DDC.Type.Check.Error-        , module DDC.Type.Predicates-        , module DDC.Type.Compounds-        , module DDC.Type.Equiv-        , module DDC.Type.Exp-        , module DDC.Base.Pretty)-where-import DDC.Type.Check.Context-import DDC.Type.Check.Error-import DDC.Type.Predicates-import DDC.Type.Compounds-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)----- | The type checker monad.-type CheckM n   = G.CheckM (Int, Int) (Error n)----- | Allocate a new existential of sort Comp.---   Kind inference is only useful for type variables of kind Comp, ---   because we don't write functions that have polymorphic witness---   type variables.-newExists :: Sort n -> CheckM n (Exists n)-newExists s- = do   (ix, pos)       <- G.get-        G.put (ix + 1, pos)-        return  (Exists ix s)----- Allocate a new context stack position.-newPos  :: CheckM n Pos-newPos- = do   (ix, pos)       <- G.get-        G.put (ix, pos + 1)-        return  (Pos pos)--
− DDC/Type/Check/CheckCon.hs 
@@ -1,79 +0,0 @@--module DDC.Type.Check.CheckCon-        ( takeKindOfTyCon-        , takeSortOfKiCon-        , kindOfTwCon-        , kindOfTcCon)-where-import DDC.Type.Exp-import DDC.Type.Compounds----- | Take the kind of a `TyCon`, if there is one.-takeKindOfTyCon :: TyCon n -> Maybe (Kind n)-takeKindOfTyCon tt- = case tt of        -        -- Sorts don't have a higher classification.-        TyConSort    _   -> Nothing- -        TyConKind    kc  -> takeSortOfKiCon kc-        TyConWitness tc  -> Just $ kindOfTwCon tc-        TyConSpec    tc  -> Just $ kindOfTcCon tc-        TyConBound   _ k -> Just k-        TyConExists  _ k -> Just k----- | Take the superkind of an atomic kind constructor.------   Yields `Nothing` for the kind function (~>) as it doesn't have a sort---   without being fully applied.-takeSortOfKiCon :: KiCon -> Maybe (Sort n)-takeSortOfKiCon kc- = case kc of-        KiConFun        -> Nothing-        KiConData       -> Just sComp-        KiConRegion     -> Just sComp-        KiConEffect     -> Just sComp-        KiConClosure    -> Just sComp-        KiConWitness    -> Just sProp----- | Take the kind of a witness type constructor.-kindOfTwCon :: TwCon -> Kind n-kindOfTwCon tc- = 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-        TwConDistinct n -> (replicate n kRegion)      `kFuns` kWitness        ----- | Take the kind of a computation type constructor.-kindOfTcCon :: TcCon -> Kind n-kindOfTcCon tc- = 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-        TcConDeepRead   -> kData    `kFun` kEffect-        TcConWrite      -> kRegion  `kFun` kEffect-        TcConDeepWrite  -> kData    `kFun` kEffect-        TcConAlloc      -> kRegion  `kFun` kEffect-        TcConDeepAlloc  -> kData    `kFun` kEffect-        TcConUse        -> kRegion  `kFun` kClosure-        TcConDeepUse    -> kData    `kFun` kClosure--
− DDC/Type/Check/Config.hs 
@@ -1,76 +0,0 @@--module DDC.Type.Check.Config-        ( Config (..)-        , configOfProfile)-where-import DDC.Type.DataDef-import DDC.Type.Env                     (KindEnv, TypeEnv)-import qualified DDC.Core.Fragment      as F----- Config ------------------------------------------------------------------------ | Static configuration for the type checker.---   These fields don't change as we decend into the tree.------   The starting configuration should be converted from the profile that---   defines the language fragment you are checking. ---   See "DDC.Core.Fragment" and use `configOfProfile` below.-data Config n-        = Config-        { -- | Kinds of primitive types.-          configPrimKinds               :: KindEnv n--          -- | Types of primitive operators.-        , configPrimTypes               :: TypeEnv n--        -- | Data type definitions.-        , configDataDefs                :: DataDefs n  --          -- | Track effect type information.-        , configTrackedEffects          :: Bool--          -- | Track closure type information.-        , configTrackedClosures         :: Bool --          -- | Attach effect information to function types.-        , configFunctionalEffects       :: Bool--          -- | Attach closure information to function types.-        , configFunctionalClosures      :: Bool--          -- | 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) }------ | Convert a langage 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-        -        , 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--        , configNameIsHole         = F.profileNameIsHole profile }-        -
− DDC/Type/Check/Context.hs 
@@ -1,582 +0,0 @@--module DDC.Type.Check.Context-        ( Mode    (..)--        -- * Existentials-        , Exists  (..)-        , typeOfExists-        , takeExists--        , Elem    (..)-        , Role    (..)-        , Context (..)-        , emptyContext--        -- Positions-        , Pos     (..)-        , markContext-        , popToPos--        -- Pushing-        , pushType,   pushTypes, memberType-        , pushKind,   pushKinds, memberKind, memberKindBind-        , pushExists--        -- Lookup-        , lookupType-        , lookupKind-        , lookupExistsEq--        -- Existentials-        , locationOfExists-        , updateExists--        , applyContext-        , applySolved-        , effectSupported--        , liftTypes-        , lowerTypes)-where-import DDC.Type.Exp-import DDC.Type.Pretty-import DDC.Type.Transform.LiftT-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)----- Mode -------------------------------------------------------------------------- | What mode we're performing type checking/inference in.-data Mode n-        -- | Reconstruct the type of the expression, requiring type annotations-        --   on parameters  as well as type applications to already be present.-        = Recon-        -        -- | The ascending smoke of incense.-        --   Synthesise the type of the expression, producing unification-        --   variables for bidirectional type inference.-        --   -        | Synth--        -- | The descending tongue of flame.-        --   Check the type of an expression against this expected type, and-        --   unify expected types into unification variables for bidirecional-        --   type inference.-        | Check (Type n)-        deriving (Show, Eq)---instance (Eq n, Pretty n) => Pretty (Mode n) where- ppr mode-  = case mode of-        Recon   -> text "RECON"-        Synth   -> text "SYNTH"-        Check t -> text "CHECK" <+> parens (ppr t)----- Exists ------------------------------------------------------------------------ | An existential variable.-data Exists n-        = Exists !Int !(Kind n)-        deriving (Show)--instance Eq (Exists n) where- (==)   (Exists i1 _) (Exists i2 _)     = i1 == i2- (/=)   (Exists i1 _) (Exists i2 _)     = i1 /= i2---instance Ord (Exists n) where- compare (Exists i1 _) (Exists i2 _)-        = compare i1 i2---instance Pretty (Exists n) where- ppr (Exists i _) = text "?" <> ppr i----- | Wrap an existential variable into a type.-typeOfExists :: Exists n -> Type n-typeOfExists (Exists n k)-        = TCon (TyConExists n k)----- | Take an Exists from a type.-takeExists :: Type n -> Maybe (Exists n)-takeExists tt- = case tt of-        TCon (TyConExists n k)  -> Just (Exists n k)-        _                       -> Nothing----- Context ----------------------------------------------------------------------- | The type checker context.--- ---   Holds a position counter and a stack of elements. ---   The top of the stack is at the front of the list.----data Context n-        = Context -        { -- | Fresh name generator for context positions.-          contextGenPos         :: !Int--          -- | Fresh name generator for existential variables.-        , contextGenExists      :: !Int --          -- | The current context stack.-        , contextElems          :: ![Elem n] -        -          -- | Types of solved existentials.-          --   When solved constraints are popped from the main context stack-          --   they are added to this map. The map is used to fill in type -          --   annotations after type inference proper. It's not used as part-          --   of the main algorithm.-        , contextSolved         :: IntMap (Type n) }-        deriving Show---instance (Pretty n, Eq n) => Pretty (Context n) where- ppr (Context genPos genExists ls _solved)-  =   text "Context "-  <$> text "  genPos    = " <> int genPos-  <$> text "  genExists = " <> int genExists-  <$> indent 2 -        (vcat $ [int i  <> (indent 4 $ ppr l)-                        | l <- reverse ls-                        | i <- [0..]])----- Positions ---------------------------------------------------------------------- | A position in the type checker context.---   A position is used to record a particular position in the context stack,---   so that we can pop elements higher than it.-data Pos-        = Pos !Int-        deriving (Show, Eq)--instance Pretty Pos where- ppr (Pos p)-        = text "*" <> int p----- Elem -------------------------------------------------------------------------- | An element in the type checker context.-data Elem n-        -- | A context position marker.-        = ElemPos        !Pos--        -- | Kind of some variable.-        | ElemKind       !(Bind n) !Role--        -- | Type of some variable.-        | ElemType       !(Bind n)--        -- | Existential variable declaration-        | ElemExistsDecl !(Exists n)--        -- | Existential variable solved to some monotype.-        | ElemExistsEq   !(Exists n) !(Type n)-        deriving (Show, Eq)----- | The role of some type variable.-data Role-        -- | Concrete type variables are region variables that have been introduced-        --   in an enclosing lexical scope. All the capabilities for these will -        --   also be in the context.-        = RoleConcrete-        -        -- | Abstract type variables are the ones that are bound by type abstraction-        --   Inside the body of a type abstraction we can assume a region supports-        --   any given capability. We only need to worry about if it really does-        --   when we actually run the enclosed computation.-        | RoleAbstract-        deriving (Show, Eq)---instance (Pretty n, Eq n) => Pretty (Elem n) where- ppr ll-  = case ll of-        ElemPos p-         -> ppr p--        ElemKind b role  -         -> ppr (binderOfBind b) -                <+> text "::" -                <+> (ppr $ typeOfBind b)-                <+> text "@" <> ppr role--        ElemType b-         -> ppr (binderOfBind b)-                <+> text "::"-                <+> (ppr $ typeOfBind b)--        ElemExistsDecl i-         -> ppr i--        ElemExistsEq i t -         -> ppr i <+> text "=" <+> ppr t---instance Pretty Role where- ppr role-  = case role of-        RoleConcrete    -> text "Concrete"-        RoleAbstract    -> text "Abstract"----- Empty ------------------------------------------------------------------------- | An empty context.-emptyContext :: Context n-emptyContext -        = Context 0 0 [] IntMap.empty----- Push -------------------------------------------------------------------------- | Push the type of some value variable onto the context.-pushType  :: Bind n -> Context n -> Context n-pushType b ctx- = ctx { contextElems = ElemType b : contextElems ctx }----- | Push many types onto the context.-pushTypes :: [Bind n] -> Context n -> Context n-pushTypes bs ctx- = foldl (flip pushType) ctx bs----- | Push the kind of some type variable onto the context.-pushKind :: Bind n -> Role -> Context n -> Context n-pushKind b role ctx- = ctx { contextElems = ElemKind b role : contextElems ctx }----- | Push many kinds onto the context.-pushKinds :: [(Bind n, Role)] -> Context n -> Context n-pushKinds brs ctx- = foldl (\ctx' (b, r) -> pushKind b r ctx') ctx brs----- | Push an existential declaration onto the context.---   If this is not an existential then `error`.-pushExists :: Exists n -> Context n -> Context n-pushExists i ctx- = ctx { contextElems = ElemExistsDecl i : contextElems ctx }----- Mark / Pop -------------------------------------------------------------------- | Mark the context with a new position.-markContext :: Context n -> (Context n, Pos)-markContext ctx- = let  p       = contextGenPos ctx-        pos     = Pos p-   in   ( ctx   { contextGenPos = p + 1-                , contextElems  = ElemPos pos : contextElems ctx }-        , pos )----- | Pop elements from a context to get back to the given position.-popToPos :: Pos -> Context n -> Context n-popToPos pos ctx- = ctx { contextElems = go $ contextElems ctx }- where-        go []                  = []--        go (ElemPos pos' : ls)-         | pos' == pos          = ls-         | otherwise            = go ls--        go (_ : ls)             = go ls----- Lookup ------------------------------------------------------------------------ | Given a bound level-0 (value) variable, lookup its type (level-1) ---   from the context.-lookupType :: Eq n => Bound n -> Context n -> Maybe (Type n)-lookupType u ctx- = case u of-        UPrim{}         -> Nothing-        UName n         -> goName n    (contextElems ctx)-        UIx   ix        -> goIx   ix 0 (contextElems ctx)- where-        goName _n []    = Nothing-        goName n  (ElemType (BName n' t) : ls)-         | n == n'      = Just t-         | otherwise    = goName n ls-        goName  n (_ : ls)-         = goName n ls---        goIx _ix _d []  = Nothing-        goIx ix d  (ElemType (BAnon t) : ls)-         | ix == d      = Just t-         | otherwise    = goIx   ix (d + 1) ls-        goIx ix d  (_ : ls)-         = goIx ix d ls----- | Given a bound level-1 (type) variable, lookup its kind (level-2) from---   the context.-lookupKind :: Eq n => Bound n -> Context n -> Maybe (Kind n, Role)-lookupKind u ctx- = case u of-        UPrim{}         -> Nothing-        UName n         -> goName n    (contextElems ctx)-        UIx   ix        -> goIx   ix 0 (contextElems ctx)- where-        goName _n []    = Nothing-        goName n  (ElemKind (BName n' t) role : ls)-         | n == n'      = Just (t, role)-         | otherwise    = goName n ls-        goName  n (_ : ls)-         = goName n ls---        goIx _ix _d []  = Nothing-        goIx ix d  (ElemKind (BAnon t) role : ls)-         | ix == d      = Just (t, role)-         | otherwise    = goIx   ix (d + 1) ls-        goIx ix d  (_ : ls)-         = goIx ix d ls----- | Lookup the type bound to an existential, if any.-lookupExistsEq :: Exists n -> Context n -> Maybe (Type n)-lookupExistsEq i ctx- = go (contextElems ctx)- where  go []                           = Nothing-        go (ElemExistsEq i' t : _)-         | i == i'                      = Just t-        go (_ : ls)                     = go ls----- Member ------------------------------------------------------------------------ | See if this type variable is in the context.-memberType :: Eq n => Bound n -> Context n -> Bool-memberType u ctx = isJust $ lookupType u ctx----- | See if this kind variable is in the context.-memberKind :: Eq n => Bound n -> Context n -> Bool-memberKind u ctx = isJust $ lookupKind u ctx----- | See if the name on a named binder is in the contexts.---   Returns False for non-named binders.-memberKindBind :: Eq n => Bind n -> Context n -> Bool-memberKindBind b ctx- = case b of-        BName n _       -> memberKind (UName n) ctx-        _               -> False----- Existentials-------------------------------------------------------------------- | Get the numeric location of an existential in the context stack,---   or Nothing if it's not there. Returned value is relative to the TOP---   of the stack, so the top element has location 0.-locationOfExists -        :: Exists n-        -> Context n-        -> Maybe Int--locationOfExists x ctx- = go 0 (contextElems ctx)- where  go !_ix []      = Nothing-        -        go !ix (ElemExistsDecl x'   : moar)-         | x == x'      = Just ix-         | otherwise    = go (ix + 1) moar--        go !ix (ElemExistsEq   x' _ : moar)-         | x == x'      = Just ix-         | otherwise    = go (ix + 1) moar--        go !ix  (_ : moar)-         = go (ix + 1) moar----- | Update (solve) an existential in the context stack.------   If the existential is not part of the context then `Nothing`.-updateExists -        :: [Exists n]   -- ^ Other existential declarations to  add before the-                        --   updated one.-        -> Exists n     -- ^ Existential to update.-        -> Type n       -- ^ New monotype.-        -> Context n -        -> Maybe (Context n)--updateExists isMore iEx@(Exists iEx' _) tEx ctx- = case go $ contextElems ctx of-    Just elems'     -     -> Just $ ctx { contextElems  = elems'-                   , contextSolved = IntMap.insert iEx' tEx (contextSolved ctx) }-    Nothing -> Nothing- where-        go ll-         = case ll of-                l@ElemPos{}     : ls-                 | Just ls'     <- go ls        -> Just (l : ls')--                l@ElemKind{}    : ls   -                 | Just ls'     <- go ls        -> Just (l : ls')--                l@ElemType{}    : ls-                 | Just ls'     <- go ls        -> Just (l : ls')--                l@(ElemExistsDecl i) : ls-                 | i == iEx             -                 -> Just $ (ElemExistsEq i tEx : [ElemExistsDecl n' | n' <- isMore]) ++ ls--                 | Just ls'     <- go ls        -> Just (l : ls')--                l@ElemExistsEq{} : ls-                 | Just ls'     <- go ls        -> Just (l : ls')--                _ -> Just ll  -- Nothing----- Lifting ----------------------------------------------------------------------- | Lift free debruijn indices in types by the given number of levels.-liftTypes :: Ord n => Int -> Context n -> Context n-liftTypes n ctx- = ctx { contextElems = go $ contextElems ctx }- where-        go []                   = []-        go (ElemType b : ls)    = ElemType (liftT n b) : go ls-        go (l:ls)               = l : go ls----- Lowering ----------------------------------------------------------------------- | Lower free debruijn indices in types by the given number of levels.-lowerTypes :: Ord n => Int -> Context n -> Context n-lowerTypes n ctx- = ctx { contextElems = go $ contextElems ctx }- where-        go []                   = []-        go (ElemType b : ls)    = ElemType (lowerT n b) : go ls-        go (l:ls)               = l : go ls----- Apply ------------------------------------------------------------------------- | 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- = case tt of-        TVar{}          -> tt--        TCon (TyConExists i k)  -         |  Just t      <- lookupExistsEq (Exists i k) ctx-         -> applyContext ctx t--        TCon{}          -> tt--        TForall b t     -         -> let tb'     = applySolved ctx (typeOfBind b)-                b'      = replaceTypeOfBind tb' b-                t'      = applySolved ctx t-            in  TForall b' t'--        TApp t1 t2-         -> let t1'     = applySolved ctx t1-                t2'     = applySolved ctx t2-            in  TApp t1' t2'--        TSum ts         -         -> TSum $ Sum.fromList (Sum.kindOfSum ts) -                 $ map (applyContext ctx)-                 $ Sum.toList ts----- | 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- = case tt of-        TVar{}          -> tt--        TCon (TyConExists i k)-         | Just t       <- IntMap.lookup i (contextSolved ctx)-         -> applySolved ctx t--         | Just t       <- lookupExistsEq (Exists i k) ctx-         -> applySolved ctx t--        TCon {}         -> tt-        TForall b t-         -> let tb'     = applySolved ctx (typeOfBind b)     -                b'      = replaceTypeOfBind tb' b-                t'      = applySolved ctx t-             in TForall b' t'--        TApp t1 t2      -         -> let t1'     = applySolved ctx t1-                t2'     = applySolved ctx t2-            in  TApp t1' t2'--        TSum ts-         -> TSum $ Sum.fromList (Sum.kindOfSum ts)-                 $ map (applySolved ctx)-                 $ Sum.toList ts----- Support ----------------------------------------------------------------------- | Check whether this effect is supported by the given context.---   This is used when effects are treated as capabilities.------   The overall function can be passed a compound effect, ---    it returns `Nothing` if the effect is supported, ---    or `Just e`, where `e` is some unsuported atomic effect.----effectSupported -        :: Ord n -        => Effect n -        -> Context n -        -> Maybe (Effect n)--effectSupported eff ctx-        -- Check that all the components of a sum are supported.-        | TSum ts       <- eff-        = listToMaybe $ concat [ maybeToList $ effectSupported e ctx -                               | e <- Sum.toList ts ]--        -- Abstract effects are fine.-        --  We'll find out if it is really supported once it's instantiated.-        | 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-        = Nothing--        -- For an effect on a concrete region,-        --   the capability needs to be in the lexical environment.-        | TApp (TCon (TyConSpec tc)) _t2       <- eff-        , elem tc [TcConRead, TcConWrite, TcConAlloc]-        , elem (ElemType (BNone eff)) (contextElems ctx)-        = Nothing--        -- Abstract global effects are always supported.-        | TCon (TyConBound _ k)                <- eff-        , k == kEffect-        = Nothing--        | otherwise-        = Just eff
− DDC/Type/Check/Data.hs 
@@ -1,180 +0,0 @@--module DDC.Type.Check.Data-        (checkDataDefs)-where-import DDC.Type.Check.Error-import DDC.Type.Check.Config-import DDC.Type.Equiv-import DDC.Type.DataDef-import DDC.Base.Pretty-import Data.Maybe-import Data.Set                 (Set)-import qualified DDC.Type.Env   as Env-import qualified Data.Set       as Set-import qualified Data.Map       as Map------------------------------------------------------------------------------------ | Check some data type definitions.-checkDataDefs -        :: (Ord n, Show n, Pretty n)-        => Config n-        -> [DataDef n]-        -> ([ErrorData n], [DataDef n])--checkDataDefs config defs - = let-        -- Get the list of type and data constructors which the module-        -- cannot re-define locally.--        -- Primitive type constructors.-        primTypeCtors-                = Set.fromList-                $ Map.keys $ Env.envMap $ configPrimKinds config--        -- Primitive data type constructors-        primDataTypeCtors  -                = Set.fromList -                $ Map.keys $ dataDefsTypes $ configDataDefs config--        -- Primitive data constructors-        primDataCtors   -                = Set.fromList -                $ Map.keys $ dataDefsCtors $ configDataDefs config--   in   checkDataDefs' -                (Set.union primTypeCtors primDataTypeCtors)-                primDataCtors-                [] []-                defs---checkDataDefs'-        :: (Ord n, Show n, Pretty n)-        => Set n                -- ^ Names of existing data types.-        -> Set n                -- ^ Names of existing data constructor.-        -> [ErrorData n]        -- ^ Errors found so far.-        -> [DataDef n]          -- ^ Checked data defs.-        -> [DataDef n]          -- ^ Data defs still to check.-        -> ([ErrorData n], [DataDef n])--checkDataDefs' nsTypes nsCtors errs dsChecked ds- -- We've checked all the defs.- | []   <- ds- = (reverse errs, reverse dsChecked)- - -- Keep checking defs.- | d : ds' <- ds- = case checkDataDef nsTypes nsCtors d of--    -- There are errors in this def.-    Left errs' -     -> checkDataDefs'-                (Set.insert (dataDefTypeName d) nsTypes)-                (Set.fromList $ fromMaybe [] $ dataCtorNamesOfDataDef d)-                (errs ++ errs') dsChecked ds'--    -- This def is ok.-    Right d'   -     -> checkDataDefs'-                (Set.insert (dataDefTypeName d') nsTypes)-                (Set.fromList $ fromMaybe [] $ dataCtorNamesOfDataDef d)-                errs (d' : dsChecked) ds'-- | otherwise- = error "ddc-core.checkDataDefs: bogus warning suppression"----- DataDef ----------------------------------------------------------------------- | Check a data type definition.-checkDataDef -        :: (Ord n, Show n, Pretty n)-        => Set n                -- ^ Names of existing data types.-        -> Set n                -- ^ Names of existing data constructors.-        -> DataDef n            -- ^ Data type definition to check.-        -> Either [ErrorData n] (DataDef n)--checkDataDef nsTypes nsCtors def-        - -- Check the data type name is not already defined.- | Set.member (dataDefTypeName def) nsTypes- = Left [ErrorDataDupTypeName (dataDefTypeName def)]-- -- No data constructors to check.- | Nothing      <- dataDefCtors def- = Right def-- -- Check the data constructors.- | Just ctors   <- dataDefCtors def- = case checkDataCtors nsCtors [] def [] ctors of-        Left errs       -> Left errs-        Right ctors'    -> Right $ def { dataDefCtors = Just ctors' }-- | otherwise- = error "ddc-core.checkDataDef: bogus warning suppression"-- --- Ctors ------------------------------------------------------------------------- | Check the data constructor definitions from a single data type.-checkDataCtors-        :: (Ord n, Show n, Pretty n)-        => Set n                -- ^ Names of existing data constructors.-        -> [ErrorData n]        -- ^ Errors found so far.-        -> DataDef n            -- ^ The DataDef these constructors relate to.-        -> [DataCtor  n]        -- ^ Checked constructor defs.-        -> [DataCtor  n]        -- ^ Constructor defs still to check.-        -> Either [ErrorData n] [DataCtor n]--checkDataCtors nsCtors errs def csChecked cs- -- We've checked all the constructors and there were no errors.- | []   <- cs, []   <- errs- = Right (reverse csChecked)-- -- We've checked all the constructors and there were errors with some of them.- | []   <- cs- = Left  (reverse errs)-- -- Keep checking constructors.- | c : cs' <- cs- = case checkDataCtor nsCtors def c of-        Left  err -> checkDataCtors -                        (Set.insert (dataCtorName c) nsCtors)-                        (err : errs) def csChecked cs'-        -        Right c'  -> checkDataCtors -                        (Set.insert (dataCtorName c') nsCtors)-                        errs         def (c' : csChecked) cs'-- | otherwise- = error "ddc-core.checkDataCtors: bogus warning suppression"----- Ctor -------------------------------------------------------------------------- | Check a single data constructor definition.-checkDataCtor -        :: (Ord n, Show n, Pretty n)-        => Set n                -- ^ Names of existing data constructors.-        -> DataDef  n           -- ^ Def of data type for this constructor.-        -> DataCtor n           -- ^ Data constructor to check.-        -> Either (ErrorData n) (DataCtor n)--checkDataCtor nsCtors def ctor-        - -- Check the constructor name is not already defined.- | Set.member (dataCtorName ctor) nsCtors - = Left $ ErrorDataDupCtorName (dataCtorName ctor)-- -- Check that the constructor produces a value of the associated data type.- | not $ equivT (dataTypeOfDataDef def)   (dataCtorResultType ctor)- = Left $ ErrorDataWrongResult -                (dataCtorName ctor)-                (dataCtorResultType ctor) (dataTypeOfDataDef def)-- -- This constructor looks ok.- | otherwise- = Right ctor------
− DDC/Type/Check/Error.hs 
@@ -1,110 +0,0 @@---- | Errors produced when checking types.-module DDC.Type.Check.Error-        ( Error         (..)-        , ErrorData     (..))-where-import DDC.Type.Universe-import DDC.Type.Exp----- | Things that can go wrong when checking the kind of at type.-data Error n-        -- Generic Problems ----------------------        -- | Tried to check a type using the wrong universe, -        --   for example: asking for the kind of a kind.-        = ErrorUniverseMalfunction-        { errorType             :: Type n-        , errorUniverse         :: Universe }--        -- | Generic kind mismatch.-        | ErrorMismatch-        { errorUniverse         :: Universe-        , errorInferred         :: Type n-        , errorExpected         :: Type n-        , errorChecking         :: Type n }---        -- Variables -----------------------------        -- | An undefined type variable.-        | ErrorUndefined        -        { errorBound            :: Bound n }---        -- Constructors --------------------------        -- | Found an unapplied kind function constructor.-        | ErrorUnappliedKindFun --        -- | Found a naked sort constructor.-        | ErrorNakedSort-        { errorSort             :: Sort n }--        -- | An undefined type constructor.-        | ErrorUndefinedTypeCtor-        { errorBound            :: Bound n }---        -- Applications --------------------------        -- | A type application where the thing being applied is not a function.-        | ErrorAppNotFun-        { errorChecking         :: Type n-        , errorFunType          :: Type n-        , errorFunTypeKind      :: Kind n-        , errorArgType          :: Type n }--        -- | A type application where the parameter and argument kinds don't match.-        | ErrorAppArgMismatch   -        { errorChecking         :: Type n-        , errorFunType          :: Type n-        , errorFunKind          :: Kind n-        , errorArgType          :: Type n-        , errorArgKind          :: Kind n }--        -- | A witness implication where the premise or conclusion has an-        --   invalid kind.-        | ErrorWitnessImplInvalid-        { errorChecking         :: Type n-        , errorLeftType         :: Type n-        , errorLeftKind         :: Kind n-        , errorRightType        :: Type n-        , errorRightKind        :: Kind n }---        -- Quantifiers ---------------------------        -- | A forall where the body does not have data or witness kind.-        | ErrorForallKindInvalid-        { errorChecking         :: Type n-        , errorBody             :: Type n-        , errorKind             :: Kind n }---        -- Sums ----------------------------------        -- | A type sum where the components have differing kinds.-        | ErrorSumKindMismatch-        { errorKindExpected     :: Kind n-        , errorTypeSum          :: TypeSum n-        , errorKinds            :: [Kind n] }-        -        -- | A type sum that does not have effect or closure kind.-        | ErrorSumKindInvalid-        { errorCheckingSum      :: TypeSum n-        , errorKind             :: Kind n }-        deriving Show----- | Things that can go wrong when checking data type definitions.-data ErrorData n-        -- | A duplicate data type constructor name.-        = ErrorDataDupTypeName -        { errorDataDupTypeName          :: n }--        -- | A duplicate data constructor name.-        | ErrorDataDupCtorName-        { errorDataCtorName             :: n }--        -- | A data constructor with the wrong result type.-        | ErrorDataWrongResult-        { errorDataCtorName             :: n-        , errorDataCtorResultActual     :: Type n-        , errorDataCtorResultExpected   :: Type n }-        deriving Show
− DDC/Type/Check/ErrorMessage.hs 
@@ -1,121 +0,0 @@---- | Errors produced when checking types.-module DDC.Type.Check.ErrorMessage where-import DDC.Type.Check.Error-import DDC.Type.Universe-import DDC.Type.Compounds-import DDC.Type.Pretty---instance (Eq n, Show n, Pretty n) => Pretty (Error n) where- ppr err-  = case err of-        -- Generic Problems ----------------------        ErrorUniverseMalfunction t u-         -> vcat [ text "Universe malfunction."-                 , text "               Type: " <> ppr t-                 , text " is not in universe: " <> ppr u ]--        ErrorMismatch uni tInferred tExpected tt-         -> let (thing, thing')   -                 = case uni of-                        UniverseSpec    -> ("Kind", "kind")-                        UniverseKind    -> ("Sort", "sort")-                        _               -> ("Type", "type")-            in vcat -                [ text thing <+> text "mismatch."-                , text "                Expected"-                        <+> text thing' <> text ":"    <+> ppr tExpected-                , text " does not match inferred"-                        <+> text thing' <> text ":"    <+> ppr tInferred-                , empty-                , text "with: "                         <> align (ppr tt) ]---        -- Variables -----------------------------        ErrorUndefined u-         -> text "Undefined type variable: " <> ppr u---        -- Constructors --------------------------        ErrorUnappliedKindFun -         -> text "Can't take sort of unapplied kind function constructor."--        ErrorNakedSort s-         -> text "Can't check a naked sort: " <> ppr s-                -        ErrorUndefinedTypeCtor u-         -> text "Undefined type constructor: " <> ppr u---        -- Applications --------------------------        ErrorAppNotFun tt t1 k1 t2-         -> vcat [ text "Type function used in application has invalid kind."-                 , text "    In application: "          <> ppr tt-                 , text " cannot apply type: "          <> ppr t1-                 , text "           of kind: "          <> ppr k1-                 , text "           to type: "          <> ppr t2 ]- -        ErrorAppArgMismatch tt tFn kFn tArg kArg-         -> vcat [ text "Kind mismatch in type application."-                 , text "    In application: "          <> ppr tt-                 , text " cannot apply type: "          <> ppr tFn-                 , text "         with kind: "          <> ppr kFn-                 , text "       to argument: "          <> ppr tArg-                 , text "         with kind: "          <> ppr kArg ]         ---        ErrorWitnessImplInvalid tt t1 k1 t2 k2-         -> vcat [ text "Invalid args for witness implication."-                 , text "            left type: " <> ppr t1-                 , text "             has kind: " <> ppr k1-                 , text "           right type: " <> ppr t2-                 , text "             has kind: " <> ppr k2 -                 , text "        when checking: " <> ppr tt ]---        -- Quantifiers ---------------------------        ErrorForallKindInvalid tt t k-         -> vcat [ text "Invalid kind for body of quantified type."-                 , text "        the body type: " <> ppr t-                 , text "             has kind: " <> ppr k-                 , text "  but it must be Data or Prop" -                 , text "        when checking: " <> ppr tt ]---        -- Sums ---------------------------------                    -        ErrorSumKindMismatch k ts ks-         -> vcat $ [ text "Kind mismatch in type sum."-                 , text " found multiple types: " <> ppr ts-                 , text " with differing kinds: " <> ppr ks ]-                 ++ (if k /= tBot sComp-                        then [text "        expected kind: " <> ppr k ]-                        else [])-                -        ErrorSumKindInvalid ts k-         -> vcat [ text "Invalid kind for type sum."-                 , text "         the type sum: " <> ppr ts-                 , text "             has kind: " <> ppr k-                 , text "  but it must be Effect or Closure" ]---instance (Eq n, Show n, Pretty n) => Pretty (ErrorData n) where- ppr err-  = case err of-        ErrorDataDupTypeName n-         -> vcat [ text "Duplicate data type definition."-                 , text "  A constructor with name: " <> ppr n-                 , text "  is already defined." ]--        ErrorDataDupCtorName n-         -> vcat [ text "Duplicate data constructor definition."-                 , text "  A constructor with name: " <> ppr n-                 , text "  is already defined." ]---        ErrorDataWrongResult n tActual tExpected-         -> vcat [ text "Invalid result type for data constructor."-                 , text "       The data constructor: " <> ppr n-                 , text "            has result type: " <> ppr tActual-                 , text "  but the enclosing type is: " <> ppr tExpected ]-
− DDC/Type/Check/Judge/Eq.hs 
@@ -1,79 +0,0 @@--module DDC.Type.Check.Judge.Eq-        (makeEq)-where-import DDC.Type.Check.Config-import DDC.Type.Check.Base----- | Make two types equivalent to each other,---   or throw the provided error if this is not possible.-makeEq  :: (Eq n, Ord n, Pretty n)-        => Config n-        -> Context n-        -> Type n-        -> Type n-        -> Error n-        -> CheckM n (Context n)--makeEq config ctx0 tL tR err-- -- EqLSolve- | Just iL <- takeExists tL- , not $ isTExists tR- = do   let Just ctx1   = updateExists [] iL tR ctx0-        return ctx1-- -- EqRSolve- | Just iR <- takeExists tR- , not $ isTExists tL- = do   let Just ctx1   = updateExists [] iR tL ctx0-        return ctx1-- -- EqLReach- --  Both types are existentials, and the left is bound earlier in the stack.- --  CAREFUL: The returned location is relative to the top of the stack,- --           hence we need lL > lR here.- | Just iL <- takeExists tL,    Just lL <- locationOfExists iL ctx0- , Just iR <- takeExists tR,    Just lR <- locationOfExists iR ctx0- , lL > lR- = do   let Just ctx1   = updateExists [] iR tL ctx0-        return ctx1-- -- EqRReach- --  Both types are existentials, and the right is bound earlier in the stack.- --  CAREFUL: The returned location is relative to the top of the stack,- --           hence we need lR > lL here.- | Just iL <- takeExists tL,    Just lL <- locationOfExists iL ctx0- , Just iR <- takeExists tR,    Just lR <- locationOfExists iR ctx0- , lR > lL- = do   let Just ctx1   = updateExists [] iL tR ctx0-        return ctx1-- -- EqVar- | TVar u1      <- tL- , TVar u2      <- tR- , u1 == u2- =      return ctx0-- -- EqCon- | TCon tc1     <- tL- , TCon tc2     <- tR- , equivTyCon tc1 tc2- =      return ctx0-- -- EqApp- | 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--        return ctx2-- -- Error- | otherwise- =      throw err-
− DDC/Type/Check/Judge/Kind.hs 
@@ -1,636 +0,0 @@-module DDC.Type.Check.Judge.Kind-        (checkTypeM)-where-import DDC.Type.DataDef-import DDC.Type.Check.Context-import DDC.Type.Check.Error-import DDC.Type.Check.ErrorMessage      ()-import DDC.Type.Check.CheckCon-import DDC.Type.Check.Config-import DDC.Type.Check.Base-import DDC.Type.Check.Judge.Eq-import DDC.Type.Universe-import Data.List-import Control.Monad-import DDC.Type.Pretty                   ()-import DDC.Type.Env                      (KindEnv)-import qualified DDC.Type.Sum            as TS-import qualified DDC.Type.Env            as Env-import qualified Data.Map                as Map----- | Check a type returning its kind, or a kind returning its sort.------   The unverse of the thing to check is directly specified, and if the ---   thing is not actually in this universe they you'll get an error.------   We track what universe the provided kind is in for defence against---   transform bugs. Types like ([a : [b : Data]. b]. a -> a), should not be---   accepted by the source parser, but may be created by bogus program---   transformations. Quantifiers cannot be used at the kind level, so it's ---   better to fail early.-------   Note that when comparing kinds, we can just use plain equality---   (==) instead of equivT. This is because kinds do not contain quantifiers---   that need to be compared up to alpha-equivalence, nor do they contain---   crushable components terms.----checkTypeM -        :: (Ord n, Show n, Pretty n) -        => Config n             -- ^ Type checker configuration.-        -> KindEnv n            -- ^ Top-level kind environment.-        -> Context n            -- ^ Local context.-        -> Universe             -- ^ What universe the type to check is in.-        -> Type n               -- ^ The type to check (can be a Spec or Kind)-        -> Mode n               -- ^ Type checker mode.-        -> CheckM n -                ( Type n-                , Kind n-                , Context n)---- Variables -------------------------------------checkTypeM config env ctx0 uni tt@(TVar u) mode-- -- Kind holes.- --   This is some kind that we were explicitly told to infer,- --   so make a new existential for it.- | UniverseKind         <- uni- , Just n               <- takeNameOfBound u- , Just isHole          <- configNameIsHole config- , isHole n- = case mode of-        -- We don't infer kind holes in recon mode.-        -- The program should have complete kind annotations.-        Recon-         -> do  throw $ ErrorUndefined u--        -- Synthesised kinds are assumed to have sort Comp.-        Synth-         -> do  i        <- newExists sComp-                let t    = typeOfExists i-                let ctx' = pushExists i ctx0-                return (t, sComp, ctx')--        -- We have an expected sort for the existential,-        -- so use that.-        Check sExpected-         -> do  i        <- newExists sExpected-                let t    = typeOfExists i-                let ctx' = pushExists i ctx0-                return (t, sExpected, ctx')-- -- Spec holes.- --   This is some spec that we were explicitly told to infer,- --   so make an existential for it.- | UniverseSpec         <- uni- , Just n               <- takeNameOfBound u- , Just isHole          <- configNameIsHole config- , isHole n- = case mode of-        -- We don't infer spec holes in recon mode.-        -- The program should have complete spec annotations.-        Recon-         -> do  throw $ ErrorUndefined u--        -- Synthesised types could have an arbitrary kind, -        -- so we need to make two existentials.-        Synth-         -> do  iK       <- newExists sComp-                let k    =  typeOfExists iK-                let ctx1 =  pushExists iK ctx0--                iT       <- newExists k-                let t    =  typeOfExists iT-                let ctx2 =  pushExists iT ctx1--                return  (t, k, ctx2)--        -- We have an expected kind for the existential,-        -- so use that.-        Check kExpected-         -> do  iT       <- newExists kExpected-                let t    =  typeOfExists iT-                let ctx1 =  pushExists iT ctx0-                return  (t, kExpected, ctx1)--- -- Some variable defined in an environment, - -- or a primitive variable with its kind directly attached.- | UniverseSpec          <- uni- = let  -        -- Get the actual kind of the variable,-        -- according to the kind environment.-        getActual-         -- A variable in the local environment.-         | Just (k, _role) <- lookupKind u ctx0-         = return k--         -- A variable in the global environment.-         | Just k          <- Env.lookup u env-         = return k--         -- A primitive type variable with its kind directly attached, but where-         -- the variable is not also in the kind environment. This is a hack used-         -- for static used for static region variables in the evaluator.-         -- We make them constructors rather than variables so that we don't need-         -- to have a data constructor definition for each one.-         | UPrim _ k       <- u-         = return k--         -- Type variable is no where to be found.-         | otherwise-         = throw $ ErrorUndefined u--   in do-        kActual <- getActual-        let 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--                return (tt, kActual', ctx1)- -         _ ->   return (tt, kActual', ctx0)-- -- Type variables are not a part of this universe.- | otherwise- = throw $ ErrorUniverseMalfunction tt uni----- Constructors ----------------------------------checkTypeM config env ctx0 uni tt@(TCon tc) mode- = let  -        -- Get the actual kind of the constructor, -        -- according to the constructor definition.-        getActual-         -- Sort constructors don't have a higher classification.-         -- We should never try to check these.-         | TyConSort _           <- tc-         , UniverseSort          <- uni-         = throw $ ErrorNakedSort tt--         -- Baked-in kind constructors.-         -- We can't sort-check a naked kind function constructor because-         -- the sort of a fully applied one depends on the argument kind.-         | TyConKind kc          <- tc-         , UniverseKind          <- uni-         = case takeSortOfKiCon kc of-                Just s   -> return (tt, s)-                Nothing  -> throw $ ErrorUnappliedKindFun--         -- Baked-in witness type constructors.-         | TyConWitness tcw      <- tc-         , UniverseSpec          <- uni-         = return (tt, kindOfTwCon tcw)--         -- Baked-in spec type constructors.-         | TyConSpec    tcc      <- tc-         , UniverseSpec          <- uni-         = return (tt, kindOfTcCon tcc)--         -- Fragment specific, or user defined constructors.-         | TyConBound u k        <- tc-         = case u of-            UName n-             -- User defined data type constructors must be in the set of-             -- data defs. Attach the real kind why we're here.-             | Just def         <- Map.lookup n -                                $  dataDefsTypes $ configDataDefs config-             , UniverseSpec     <- uni-             -> let k'   = kindOfDataType def-                in  return (TCon (TyConBound u k'), k')--             -- The kinds of abstract imported type constructors are in the-             -- global kind environment.-             | Just k'          <- Env.lookupName n env-             , UniverseSpec     <- uni-             -> return (TCon (TyConBound u k'), k')--             -- We don't have a type for this constructor.-             | otherwise-             -> throw $ ErrorUndefinedTypeCtor u--            -- The kinds of primitive type constructors are directly attached.-            UPrim{} -> return (tt, k)--            -- Type constructors are always defined at top-level and not-            -- by anonymous debruijn binding.-            UIx{}   -> throw $ ErrorUndefinedTypeCtor u--         -- Existentials can be either in the Spec or Kind universe,-         -- and their kinds/sorts are directly attached.-         | TyConExists _ t       <- tc-         , uni == UniverseSpec || uni == UniverseKind-         = return (tt, t)--         -- Whatever constructor we were given wasn't in the expected universe.-         | otherwise-         = throw $ ErrorUniverseMalfunction tt uni- in do-        -- Get the actual kind/sort of the constructor according to the -        -- constructor definition.-        (tt', kActual)  <- getActual-        let 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-                 ctx1   <- makeEq config ctx0 kActual' kExpected'-                        $  ErrorMismatch uni  kActual' kExpected' tt-                 return (tt', kActual', ctx1)--         -- In Recon and Synth mode just return the actual kind.-         _ ->    return (tt', kActual', ctx0)----- Quantifiers -----------------------------------checkTypeM config kenv ctx0 uni@UniverseSpec -        tt@(TForall b1 t2) mode- = case mode of-    Recon-     -> do-        -- Check the binder is well sorted.-        let t1  = typeOfBind b1-        _       <- checkTypeM config kenv ctx0 UniverseKind t1 Recon--        -- Check the body with the binder in scope.-        let (ctx1, pos1) = markContext ctx0-        let ctx2         = pushKind b1 RoleAbstract ctx1-        (t2', k2, ctx3) <- checkTypeM config kenv ctx2 UniverseSpec t2 Recon--        -- The body must have kind Data or Witness.-        let k2'         = applyContext ctx3 k2-        when ( not (isDataKind k2')-            && not (isWitnessKind k2'))-         $ throw $ ErrorForallKindInvalid tt t2 k2'--        -- Pop the quantified type off the context.-        let ctx_cut      = popToPos pos1 ctx3--        return (TForall b1 t2', k2', ctx_cut)--    Synth-     -> do-        -- Synthesise a sort for the binder.-        let k1  = typeOfBind b1-        (k1', _s1, ctx1) <- checkTypeM config kenv ctx0 UniverseKind k1 Synth-                -        let b1' = replaceTypeOfBind k1' b1--        -- Check the body with the binder in scope.-        let (ctx2, pos1) = markContext ctx1-        let ctx3         = pushKind b1' RoleAbstract ctx2-        (t2', k2, ctx4) <- checkTypeM config kenv ctx3 UniverseSpec t2 Synth--        -- 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'', ctx5)-         <- if isTExists k2'-             then do-                ctx5    <- makeEq config ctx4 k2' kData-                        $  ErrorMismatch uni  k2' kData tt-                return (applyContext ctx5 k2', ctx5)--             else do-                return (k2', ctx4)--        -- The above horror show needs to have worked.-        when ( not (isDataKind k2'')-            && not (isWitnessKind k2''))-         $ throw $ ErrorForallKindInvalid tt t2 k2''--        -- Pop the quantified type off the context.-        let ctx_cut      = popToPos pos1 ctx5--        return (TForall b1' t2', k2'', ctx_cut)--    Check kExpected -     -> do-        -- Synthesise a sort for the binder.-        let k1  = typeOfBind b1-        (k1', _s1, ctx1) <- checkTypeM config kenv ctx0 UniverseKind k1 Synth--        let b1' = replaceTypeOfBind k1' b1--        -- Check the body with the binder in scope.-        let (ctx2, pos1) = markContext ctx1-        let ctx3         = pushKind b1' RoleAbstract ctx2-        (t2', k2, ctx4) <- checkTypeM config kenv ctx3 UniverseSpec t2 Synth--        -- In Check mode if *both* the current kind of the body and the expected-        -- 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'', ctx5)-         <- if isTExists k2' && isTExists kExpected-             then do-                ctx'    <- makeEq config ctx4 k2' kExpected-                        $  ErrorMismatch uni  k2' kExpected tt--                ctx5    <- makeEq config ctx' k2' kData -                        $  ErrorMismatch uni  k2' kData  tt-                return (applyContext ctx5 k2', ctx5)--             else do-                ctx5    <- makeEq config ctx4 k2' kExpected-                        $  ErrorMismatch uni  k2' kExpected tt-                return (applyContext ctx5 k2', ctx4)--        -- The above horror show needs to have worked.-        when ( not (isDataKind k2'')-            && not (isWitnessKind k2''))-         $ throw $ ErrorForallKindInvalid tt t2 k2'--        -- Pop the quantified type off the context.-        let ctx_cut      = popToPos pos1 ctx5--        return (TForall b1' t2', k2'', ctx_cut)----- Applications ------------------------------------ Applications of the kind function constructor are handled directly--- because the constructor doesn't have a sort by itself.--- The sort of a kind function is the sort of the result.-checkTypeM config kenv ctx0 uni@UniverseKind -        tt@(TApp (TApp (TCon (TyConKind KiConFun)) k1) k2) mode- = case mode of-    Recon-     -> do-        _               <- checkTypeM config kenv ctx0 uni k1 Recon-        (_, s2, _)      <- checkTypeM config kenv ctx0 uni k2 Recon-        return  (tt, s2, ctx0)--    Synth-     -> do-        (k1',  _, ctx1) <- checkTypeM config kenv ctx0 uni k1 Synth-        (k2', s2, ctx2) <- checkTypeM config kenv ctx1 uni k2 Synth-        return  (kFun k1' k2', s2, ctx2)--    Check sExpected-     -> do-        (k1',  _, ctx1) <- checkTypeM config kenv ctx0 uni k1 Synth-        (k2', s2, ctx2) <- checkTypeM config kenv ctx1 uni k2 (Check sExpected)-        return  (kFun k1' k2', s2, ctx2)----- The implication constructor is overloaded and can have the--- following kinds:---   (=>) :: @ ~> @ ~> @,  for witness constructors.---   (=>) :: @ ~> * ~> *,  for functions that take witnesses.-checkTypeM config env ctx0 uni@UniverseSpec -        tt@(TApp (TApp tC@(TCon (TyConWitness TwConImpl)) t1) t2) mode- = case mode of-    Recon-     -> do-        (t1', k1, ctx1) <- checkTypeM config env ctx0 uni t1 Recon-        (t2', k2, ctx2) <- checkTypeM config env ctx1 uni t2 Recon--        let tt' = TApp (TApp tC t1') t2'--        if      isWitnessKind k1 && isWitnessKind k2-         then     return (tt', kWitness, ctx2)-        else if isWitnessKind k1 && isDataKind k2-         then     return (tt', kData, ctx2)-        else    throw $ ErrorWitnessImplInvalid tt t1 k1 t2 k2--    Synth-     -> do-        (t1', _k1, ctx1) <- checkTypeM config env ctx0 uni t1 Synth-        (t2', k2,  ctx2) <- checkTypeM config env ctx1 uni t2 Synth--        return (tImpl t1' t2', k2, ctx2)--    Check kExpected-     -> do-        (t1', _k1, ctx1) <- checkTypeM config env ctx0 uni t1 Synth-        (t2', k2,  ctx2) <- checkTypeM config env ctx1 uni t2 (Check kExpected)--        return (tImpl t1' t2', k2, ctx2)----- General type application.-checkTypeM config kenv ctx0 UniverseSpec -        tt@(TApp tFn tArg) mode- = case mode of-    Recon-     -> do-        -- Check the kind of the functional part.-        (tFn',  kFn,  ctx1) -         <- checkTypeM config kenv ctx0 UniverseSpec tFn Recon-        -        -- Check the kind of the argument.-        (tArg', kArg, ctx2) -         <- checkTypeM config kenv ctx1 UniverseSpec tArg Recon--        -- The kind of the parameter must match that of the argument-        case kFn of-         TApp (TApp (TCon (TyConKind KiConFun)) kParam) kBody-           |  equivT kParam kArg-           -> return (tApp tFn' tArg', kBody, ctx2)--           | otherwise-           -> throw $ ErrorAppArgMismatch tt tFn' kFn tArg' kArg--         _ -> throw $ ErrorAppNotFun tt tFn' kFn tArg'--    Synth-     -> do-        -- Synthesise a kind for the functional part.-        (tFn', kFn, ctx1) -         <- checkTypeM config kenv ctx0 UniverseSpec tFn Synth--        -- Apply the argument to the function.-        (kResult, tArg', ctx2)-         <- synthTAppArg config kenv ctx1-                tFn' (applyContext ctx1 kFn )-                tArg--        return (TApp tFn' tArg', kResult, ctx2)--    Check kExpected-     -> do-        -- Synthesise a kind for the overall type.-        (t1', k1, ctx1) -         <- 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--        return (t1', k1', ctx2)----- Sums ------------------------------------------checkTypeM config kenv ctx0 UniverseSpec tt@(TSum ss) mode- = case mode of-    Recon-     -> do   -        -- Check all the elements,-        --  threading the context from left to right.-        (ts', ks, ctx1) -                <- checkTypesM config kenv ctx0 UniverseSpec Recon-                $  TS.toList ss--        -- Check that all the types in the sum have the same kind.-        let kExpect = TS.kindOfSum ss-        k'      <- case nub ks of     -                     []     -> return $ TS.kindOfSum ss-                     [k]    -> return k-                     _      -> throw $ ErrorSumKindMismatch kExpect ss ks--        -- Check that the kind of the elements is a valid one.-        -- Only effects and closures can be summed.-        if (k' == kEffect || k' == kClosure)-         then return (TSum (TS.fromList k' ts'), k', ctx1)-         else throw $ ErrorSumKindInvalid ss k'--    Synth-     -> do-        -- Synthesise a kind for all the elements,-        --  threading the context from left to right.-        (ts, ks, ctx1)-                <- checkTypesM config kenv ctx0 UniverseSpec Synth-                $  TS.toList ss--        case ks of-         -- Force all elements to have the same kind as the first one.-         -- Note that (TS.kindOfSum ts) will be Bot in an unannotated program,-         -- so we can't use that directly.-         k : _ksMore-          -> do -                (ts'', _, ctx2)-                 <- checkTypesM config kenv ctx1 UniverseSpec (Check k) ts--                let 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-         -- then default it to Effect kind. This shouldn't happen in a well formed-         -- program, but might in a generated one.-         [] |  isBot (TS.kindOfSum ss)-            -> return   ( TSum (TS.fromList kEffect [])-                        , kEffect, ctx0)-            | otherwise-            -> return   ( TSum (TS.empty (TS.kindOfSum ss))-                        , TS.kindOfSum ss, ctx0)--    Check kExpected-     -> do-        -- Synthesise a kind for the overall type.-        (t1', k1, ctx1)-                <- 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-        ctx2    <- makeEq config ctx1         k1' kExpected'-                $  ErrorMismatch UniverseSpec k1' kExpected' tt--        return  (t1', k1, ctx2)----- Whatever type we were given wasn't in the specified universe.-checkTypeM _ _ _ uni tt _mode-        = throw $ ErrorUniverseMalfunction tt uni------------------------------------------------------------------------------------- | Like `checkTypeM` but do several, chaining the contexts appropriately.-checkTypesM -        :: (Ord n, Show n, Pretty n) -        => Config n             -- ^ Type checker configuration.-        -> KindEnv n            -- ^ Top-level kind environment.-        -> Context n            -- ^ Local context.-        -> Universe             -- ^ What universe the types to check are in.-        -> Mode n               -- ^ Type checker mode.-        -> [Type n]             -- ^ The types to check.-        -> CheckM n -                ( [Type n]-                , [Kind n]-                , Context n)--checkTypesM _ _ ctx0 _ _ []- = return ([], [], ctx0)--checkTypesM config kenv ctx0 uni mode (t : ts)- = do   (t',  k',  ctx1)  <- checkTypeM  config kenv ctx0 uni t mode-        (ts', ks', ctx')  <- checkTypesM config kenv ctx1 uni mode ts-        return  (t' : ts', k' : ks', ctx')------------------------------------------------------------------------------------- | Synthesise the type of a kind function applied to its argument.-synthTAppArg-        :: (Show n, Ord n, Pretty n)-        => Config n-        -> KindEnv n-        -> Context n-        -> Type n               -- Type function.-        -> Kind n               -- Kind of functional part.-        -> Type n               -- Type argument.-        -> CheckM n-                ( Kind n        -- Kind of result.-                , Type n        -- Checked type argument.-                , Context n)    -- Result context. --synthTAppArg config kenv ctx0 tFn kFn tArg-- | Just iFn     <- takeExists kFn- = do  -        -- New existential for the kind of the function parameter.-        iParam          <- newExists sComp-        let kParam      = typeOfExists iParam--        -- New existential for the kind of the function body-        iBody           <- newExists sComp-        let kBody       = typeOfExists iBody--        -- Update the context with the new constraint.-        let Just ctx1   = updateExists [iBody, iParam] iFn -                                (kFun kParam kBody) ctx0--        -- Check the argument under the new context.-        (tArg', _kArg, ctx2)-         <- checkTypeM config kenv ctx1 UniverseSpec tArg (Check kParam)--        return (kBody, tArg', ctx2)--- | TApp (TApp (TCon (TyConKind KiConFun)) kParam) kBody <- kFn- = do   -        -- The kind of the argument must match the parameter kind-        (tArg', _kArg, ctx1) -         <- checkTypeM config kenv ctx0 UniverseSpec tArg (Check kParam)--        return (kBody, tArg', ctx1)-- | otherwise- = throw $ ErrorAppNotFun (TApp tFn tArg) tFn kFn tArg ----- [Note: Defaulting the kind of quantified types]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- For expressions like:---   /\a. \(x : [b : Data]. a). ()---  --- The kind of 'a' must be Data because 'x' is used as a parameter of a function --- abstraction. If the kind of the body of a quantified type is unconstrained --- then we default it to data.------ Although the types of witness constructors have quantified types, --- those types are primitive, so we never need to do type inference for them.--- There aren't any cases where defaulting the kind of a quantified type to --- Data would be the wrong thing to do.---
− DDC/Type/Collect.hs 
@@ -1,190 +0,0 @@---- | Collecting sets of variables and constructors.-module DDC.Type.Collect-        ( freeT-        , freeVarsT--        , FreeVarConT (..)--        , collectBound-        , collectBinds-        , BindTree   (..)-        , BindWay    (..)-        , BindStruct (..)--        , BoundLevel (..)-        , isBoundExpWit-        , boundLevelOfBindWay-        , bindDefT)-where-import DDC.Type.Exp-import DDC.Type.Collect.FreeT-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-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-        -- | An abstract binding expression.-        = BindDef BindWay    [Bind n] [BindTree n]--        -- | Use of a variable.-        | BindUse BoundLevel (Bound n)--        -- | Use of a constructor.-        | BindCon BoundLevel (Bound n) (Maybe (Kind n))-        deriving (Eq, Show)----- | Describes how a variable was bound.-data BindWay-        = BindForall-        | BindLAM-        | BindLam-        | BindLet-        | BindLetRec-        | BindLetRegions-        | BindLetRegionWith-        | BindCasePat-        deriving (Eq, Show)----- | What level this binder is at.-data BoundLevel-        = BoundSpec-        | BoundExp-        | BoundWit-        deriving (Eq, Show)----- | Check if a boundlevel is expression or witness-isBoundExpWit :: BoundLevel -> Bool-isBoundExpWit BoundExp = True-isBoundExpWit BoundWit = True-isBoundExpWit _        = False----- | Get the `BoundLevel` corresponding to a `BindWay`.-boundLevelOfBindWay :: BindWay -> BoundLevel-boundLevelOfBindWay way- = case way of-        BindForall              -> BoundSpec-        BindLAM                 -> BoundSpec-        BindLam                 -> BoundExp-        BindLet                 -> BoundExp-        BindLetRec              -> BoundExp-        BindLetRegions          -> BoundSpec-        BindLetRegionWith       -> BoundExp-        BindCasePat             -> BoundExp----- BindStruct ------------------------------------------------------------------class BindStruct (c :: * -> *) where- slurpBindTree :: c n -> [BindTree n]---instance BindStruct Type where- slurpBindTree tt-  = case tt of-        TVar u          -> [BindUse BoundSpec u]-        TCon tc         -> slurpBindTree tc-        TForall b t     -> [bindDefT BindForall [b] [t]]-        TApp t1 t2      -> slurpBindTree t1 ++ slurpBindTree t2-        TSum ts         -> concatMap slurpBindTree $ Sum.toList ts---instance BindStruct TyCon where- slurpBindTree tc-  = case tc of-        TyConBound u k  -> [BindCon BoundSpec u (Just k)]-        _               -> []----- | Helper for constructing the `BindTree` for a type binder.-bindDefT :: BindStruct c-         => BindWay -> [Bind n] -> [c n] -> BindTree n-bindDefT way bs xs-        = BindDef way bs $ concatMap slurpBindTree xs
− DDC/Type/Collect/FreeT.hs 
@@ -1,57 +0,0 @@--module DDC.Type.Collect.FreeT-        ( FreeVarConT(..)-        , freeVarsT)-where-import DDC.Type.Exp-import Data.Set                 (Set)-import DDC.Type.Env             (KindEnv)-import qualified DDC.Type.Env   as Env-import qualified DDC.Type.Sum   as Sum-import qualified Data.Set       as Set----- | Collect the free type variables in a type.-freeVarsT -        :: Ord n-        => KindEnv n -> Type n-        -> Set (Bound n)-freeVarsT kenv tt- = fst $ freeVarConT kenv tt---class FreeVarConT (c :: * -> *) where-  -- | Collect the free type variables and constructors used in a thing.-  freeVarConT -        :: Ord n -        => KindEnv n -> c n -        -> (Set (Bound n), Set (Bound n))---instance FreeVarConT Type where- freeVarConT kenv tt-  = case tt of-        TVar u  -         -> if Env.member u kenv-                then (Set.empty, Set.empty)-                else (Set.singleton u, Set.empty)--        TCon tc-         | TyConBound u _ <- tc -> (Set.empty, Set.singleton u)-         | otherwise            -> (Set.empty, Set.empty)--        TForall b t-         -> freeVarConT (Env.extend b kenv) t--        TApp t1 t2-         -> let (vs1, cs1)      = freeVarConT kenv t1-                (vs2, cs2)      = freeVarConT kenv t2-            in  ( Set.union vs1 vs2-                , Set.union cs1 cs2)--        TSum ts-         -> let (vss, css)      = unzip $ map (freeVarConT kenv) -                                $ Sum.toList ts-            in  (Set.unions vss, Set.unions css)--
− DDC/Type/Compounds.hs 
@@ -1,649 +0,0 @@-{-# OPTIONS -fno-warn-missing-signatures #-}-module DDC.Type.Compounds-        (  -- * Binds-          takeNameOfBind-        , typeOfBind-        , replaceTypeOfBind-        -          -- * Binders-        , binderOfBind-        , makeBindFromBinder-        , partitionBindsByType-        -          -- * Bounds-        , takeNameOfBound-        , takeTypeOfBound-        , boundMatchesBind-        , namedBoundMatchesBind-        , takeSubstBoundOfBind-        , takeSubstBoundsOfBinds-        , replaceTypeOfBound--          -- * Kinds-        , kFun-        , kFuns-        , takeKFun-        , takeKFuns-        , takeKFuns'-        , takeResultKind--         -- * Quantifiers-        , tForall,  tForall'-        , tForalls, tForalls'-        , takeTForalls,  eraseTForalls--          -- * Sums-        , tBot-        , tSum--          -- * Applications-        , tApp,          ($:)-        , tApps,         takeTApps-        , takeTyConApps-        , takePrimTyConApps-        , takeDataTyConApps-        , takePrimeRegion--          -- * Functions-        , tFun,         tFunOfList-        , tFunPE,       tFunOfListPE-        , tFunEC-        , takeTFun,     takeTFunEC-        , takeTFunArgResult-        , takeTFunWitArgResult-        , takeTFunAllArgResult-        , arityOfType--          -- * Suspensions-        , tSusp--          -- * Implications-        , tImpl--          -- * Units-        , tUnit--          -- * Variables-        , tIx-        , takeTExists--          -- * Sort construction-        , sComp, sProp--          -- * Kind construction-        , kData, kRegion, kEffect, kClosure, kWitness--          -- * Effect type constructors-        , tRead,        tDeepRead,      tHeadRead-        , 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-import qualified DDC.Type.Sum   as Sum----- Binds ------------------------------------------------------------------------- | Take the variable name of a bind.---   If this is an anonymous binder then there won't be a name.-takeNameOfBind  :: Bind n -> Maybe n-takeNameOfBind bb- = case bb of-        BName n _       -> Just n-        BAnon   _       -> Nothing-        BNone   _       -> Nothing----- | Take the type of a bind.-typeOfBind :: Bind n -> Type n-typeOfBind bb- = case bb of-        BName _ t       -> t-        BAnon   t       -> t-        BNone   t       -> t----- | Replace the type of a bind with a new one.-replaceTypeOfBind :: Type n -> Bind n -> Bind n-replaceTypeOfBind t bb- = case bb of-        BName n _       -> BName n t-        BAnon   _       -> BAnon t-        BNone   _       -> BNone t----- Binders ----------------------------------------------------------------------- | Take the binder of a bind.-binderOfBind :: Bind n -> Binder n-binderOfBind bb- = case bb of-        BName n _       -> RName n-        BAnon _         -> RAnon-        BNone _         -> RNone----- | Make a bind from a binder and its type.-makeBindFromBinder :: Binder n -> Type n -> Bind n-makeBindFromBinder bb t- = case bb of-        RName n         -> BName n t-        RAnon           -> BAnon t-        RNone           -> BNone t----- | Make lists of binds that have the same type.-partitionBindsByType :: Eq n => [Bind n] -> [([Binder n], Type n)]-partitionBindsByType [] = []-partitionBindsByType (b:bs)- = let  t       = typeOfBind b-        bsSame  = takeWhile (\b' -> typeOfBind b' == t) bs-        rs      = map binderOfBind (b:bsSame)-   in   (rs, t) : partitionBindsByType (drop (length bsSame) bs)----- Bounds ------------------------------------------------------------------------ | Take the name of bound variable.---   If this is a deBruijn index then there won't be a name.-takeNameOfBound :: Bound n -> Maybe n-takeNameOfBound uu- = case uu of-        UName n         -> Just n-        UPrim n _       -> Just n-        UIx{}           -> Nothing----- | Get the attached type of a `Bound`, if any.-takeTypeOfBound :: Bound n -> Maybe (Type n)-takeTypeOfBound uu- = case uu of-        UName{}         -> Nothing-        UPrim _ t       -> Just t-        UIx{}           -> Nothing----- | Check whether a bound maches a bind.---    `UName`    and `BName` match if they have the same name.---    @UIx 0 _@  and @BAnon _@ always match.---   Yields `False` for other combinations of bounds and binds.-boundMatchesBind :: Eq n => Bound n -> Bind n -> Bool-boundMatchesBind u b- = case (u, b) of-        (UName n1, BName n2 _)  -> n1 == n2-        (UIx 0,    BAnon _)     -> True-        _                       -> False----- | Check whether a named bound matches a named bind. ---   Yields `False` if they are not named or have different names.-namedBoundMatchesBind :: Eq n => Bound n -> Bind n -> Bool-namedBoundMatchesBind u b- = case (u, b) of-        (UName n1, BName n2 _)  -> n1 == n2-        _                       -> False----- | Convert a `Bind` to a `Bound`, ready for substitution.---   ---   Returns `UName` for `BName`, @UIx 0@ for `BAnon` ---   and `Nothing` for `BNone`, because there's nothing to substitute.-takeSubstBoundOfBind :: Bind n -> Maybe (Bound n)-takeSubstBoundOfBind bb- = case bb of-        BName n _       -> Just $ UName n -        BAnon _         -> Just $ UIx 0 -        BNone _         -> Nothing----- | Convert some `Bind`s to `Bounds`-takeSubstBoundsOfBinds :: [Bind n] -> [Bound n]-takeSubstBoundsOfBinds bs- = go 1 bs- where  go _level []               = []-        go level (BName n _ : bs') = UName n           : go level bs'-        go level (BAnon _   : bs') = UIx (len - level) : go (level + 1) bs'-        go level (BNone _   : bs') =                     go level bs'--        len = length [ () | BAnon _ <- bs]----- | If this `Bound` is a `UPrim` then replace it's embedded type with a new---   one, otherwise return it unharmed.-replaceTypeOfBound :: Type n -> Bound n -> Bound n-replaceTypeOfBound t uu- = case uu of-        UName{}         -> uu-        UPrim n _       -> UPrim n t-        UIx{}           -> uu----- Variables --------------------------------------------------------------------- | Construct a deBruijn index.-tIx :: Kind n -> Int -> Type n-tIx _ i         = TVar (UIx i)----- Existentials ------------------------------------------------------------------ | Take an existential variable from a type.-takeTExists :: Type n -> Maybe Int-takeTExists tt- = case tt of-        TCon (TyConExists n _)  -> Just n-        _                       -> Nothing----- Applications ------------------------------------------------------------------ | Construct an empty type sum.-tBot :: Kind n -> Type n-tBot k          = TSum $ Sum.empty k----- | Construct a type application.-tApp, ($:) :: Type n -> Type n -> Type n-tApp            = TApp-($:)            = TApp---- | Construct a sequence of type applications.-tApps   :: Type n -> [Type n] -> Type n-tApps t1 ts     = foldl TApp t1 ts----- | Flatten a sequence ot type applications into the function part and---   arguments, if any.-takeTApps   :: Type n -> [Type n]-takeTApps tt- = case tt of-        TApp t1 t2      -> takeTApps t1 ++ [t2]-        _               -> [tt]----- | Flatten a sequence of type applications, returning the type constructor---   and arguments, if there is one.-takeTyConApps :: Type n -> Maybe (TyCon n, [Type n])-takeTyConApps tt- = case takeTApps tt of-        TCon tc : args  -> Just $ (tc, args)-        _               -> Nothing----- | Flatten a sequence of type applications, returning the type constructor---   and arguments, if there is one. Only accept primitive type constructors.-takePrimTyConApps :: Type n -> Maybe (n, [Type n])-takePrimTyConApps tt- = case takeTApps tt of-        TCon tc : args  -         | TyConBound (UPrim n _) _     <- tc-         -> Just (n, args)--        _ -> Nothing----- | Flatten a sequence of type applications, returning the type constructor---   and arguments, if there is one. Only accept data type constructors.-takeDataTyConApps :: Type n -> Maybe (TyCon n, [Type n])-takeDataTyConApps tt- = case takeTApps tt of-        TCon tc : args  -         | TyConBound (UName{}) k       <- tc-         , TCon (TyConKind KiConData)   <- takeResultKind k-         -> Just (tc, args)--        _ -> Nothing----- | Take the prime region variable of a data type.---   This corresponds to the region the outermost constructor is allocated into.-takePrimeRegion :: Type n -> Maybe (Type n)-takePrimeRegion tt- = case takeTApps tt of-        TCon _ : tR@(TVar _) : _-          -> Just tR--        _ -> Nothing----- Foralls ----------------------------------------------------------------------- | Build an anonymous type abstraction, with a single parameter.-tForall :: Kind n -> (Type n -> Type n) -> Type n-tForall k f-        = TForall (BAnon k) (f (TVar (UIx 0)))---- | Build an anonymous type abstraction, with a single parameter.---   Starting the next index from the given value.-tForall' :: Int -> Kind n -> (Type n -> Type n) -> Type n-tForall' ix k f-        = TForall (BAnon k) (f (TVar (UIx ix)))----- | Build an anonymous type abstraction, with several parameters.---   Starting the next index from the given value.-tForalls  :: [Kind n] -> ([Type n] -> Type n) -> Type n-tForalls ks f- = let  bs      = [BAnon k | k <- ks]-        us      = map (\i -> TVar (UIx i)) [0 .. (length ks - 1)]-   in   foldr TForall (f $ reverse us) bs----- | Build an anonymous type abstraction, with several parameters.---   Starting the next index from the given value.-tForalls'  :: Int -> [Kind n] -> ([Type n] -> Type n) -> Type n-tForalls' ix ks f- = let  bs      = [BAnon k | k <- ks]-        us      = map (\i -> TVar (UIx i)) [ix .. ix + (length ks - 1)]-   in   foldr TForall (f $ reverse us) bs----- | Split nested foralls from the front of a type, ---   or `Nothing` if there was no outer forall.-takeTForalls :: Type n -> Maybe ([Bind n], Type n)-takeTForalls tt- = let  go bs (TForall b t) = go (b:bs) t-        go bs t             = (reverse bs, t)-   in   case go [] tt of-         ([], _)        -> Nothing-         (bs, body)     -> Just (bs, body)----- | Erase all `TForall` quantifiers from a type.-eraseTForalls :: Ord n => Type n -> Type n-eraseTForalls tt- = case tt of-        TVar{}          -> tt-        TCon{}          -> tt-        TForall _ t     -> eraseTForalls t-        TApp t1 t2      -> TApp (eraseTForalls t1) (eraseTForalls t2)-        TSum ts         -> TSum $ Sum.fromList (Sum.kindOfSum ts) -                                $ map eraseTForalls $ Sum.toList ts----- Sums ------------------------------------------------------------------------tSum :: Ord n => Kind n -> [Type n] -> Type n-tSum k ts-        = TSum (Sum.fromList k ts)----- Unit ------------------------------------------------------------------------tUnit :: Type n-tUnit           = TCon (TyConSpec TcConUnit)----- Function Constructors --------------------------------------------------------- | Construct a kind function.-kFun :: Kind n -> Kind n -> Kind n-kFun k1 k2      = ((TCon $ TyConKind KiConFun)`TApp` k1) `TApp` k2-infixr `kFun`----- | Construct some kind functions.-kFuns :: [Kind n] -> Kind n -> Kind n-kFuns []     k1    = k1-kFuns (k:ks) k1    = k `kFun` kFuns ks k1----- | Destruct a kind function-takeKFun :: Kind n -> Maybe (Kind n, Kind n)-takeKFun kk- = case kk of-        TApp (TApp (TCon (TyConKind KiConFun)) k1) k2   -                -> Just (k1, k2)-        _       -> Nothing----- | Destruct a chain of kind functions into the arguments-takeKFuns :: Kind n -> ([Kind n], Kind n)-takeKFuns kk- = case kk of-        TApp (TApp (TCon (TyConKind KiConFun)) k1) k2-          |  (ks, k2') <- takeKFuns k2-          -> (k1 : ks, k2')--        _ -> ([], kk)----- | Like `takeKFuns`, but return argument and return kinds in the same list.-takeKFuns' :: Kind n -> [Kind n]-takeKFuns' kk -        | (ks, k1) <- takeKFuns kk-        = ks ++ [k1]----- | Take the result kind of a kind function, or return the same kind---   unharmed if it's not a kind function.-takeResultKind :: Kind n -> Kind n-takeResultKind kk- = case kk of-        TApp (TApp (TCon (TyConKind KiConFun)) _) k2-                -> takeResultKind k2-        _       -> kk----- Function types ---------------------------------------------------------------- | Construct a pure function type.-tFun      :: Type n -> Type n -> Type n-tFun t1 t2-        = (TCon $ TyConSpec TcConFun)  `tApps` [t1, t2]-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 pure and empty function from a list containing the ---   parameter and return type. Yields `Nothing` if the list is empty.-tFunOfList :: [Type n] -> Maybe (Type n)-tFunOfList ts-  = case reverse ts of-        []      -> Nothing-        (t : tsArgs)       -         -> let tFuns' []             = t-                tFuns' (t' : ts')     = t' `tFun` tFuns' ts'-            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-        TApp (TApp (TCon (TyConSpec TcConFun)) t1) t2-         -> 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)----- | Destruct the type of a function,---   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-        TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2-         ->  let (twsMore, tvsMore, tResult) = takeTFunWitArgResult t2-             in  (t1 : twsMore, tvsMore, tResult)--        _ -> let (tvsMore, tResult)          = takeTFunArgResult tt-             in  ([], tvsMore, tResult)----- | Destruct the type of a possibly polymorphic function---   returning all kinds of quantifiers, witness arguments, ---   and value arguments in the order they appear, along with ---   the type of the result.-takeTFunAllArgResult :: Type n -> ([Type n], Type n)-takeTFunAllArgResult tt- = case tt of-        TVar{}          -> ([], tt)-        TCon{}          -> ([], tt)--        TForall b t     -         -> let (tsMore, tResult)       = takeTFunAllArgResult t-            in  (typeOfBind b : tsMore, tResult)--        TApp (TApp (TCon (TyConSpec TcConFun)) t1) t2-         -> 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)--        _ -> ([], tt)----- | Determine the arity of an expression by looking at its type.---   Count all the function arrows, and foralls.------   This assumes the type is in prenex form, meaning that all the quantifiers---   are at the front.-arityOfType :: Type n -> Int-arityOfType tt- = case tt of-        TForall _ t     -> 1 + arityOfType t-        t               -> length $ fst $ takeTFunArgResult t----- Implications ------------------------------------------------------------------ | Construct a witness implication type.-tImpl :: Type n -> Type n -> Type n-tImpl t1 t2      -        = ((TCon $ TyConWitness TwConImpl) `tApp` t1) `tApp` t2-infixr `tImpl`----- Suspensions -----------------------------------------------------------------tSusp  :: Effect n -> Type n -> Type n-tSusp tE tA-        = (TCon $ TyConSpec TcConSusp) `tApp` tE `tApp` tA----- Level 3 constructors (sorts) ------------------------------------------------sComp           = TCon $ TyConSort SoConComp-sProp           = TCon $ TyConSort SoConProp----- Level 2 constructors (kinds) ------------------------------------------------kData           = TCon $ TyConKind KiConData-kRegion         = TCon $ TyConKind KiConRegion-kEffect         = TCon $ TyConKind KiConEffect-kClosure        = TCon $ TyConKind KiConClosure-kWitness        = TCon $ TyConKind KiConWitness----- Level 1 constructors (witness and computation types) --------------------------- Effect type constructors-tRead           = tcCon1 TcConRead-tHeadRead       = tcCon1 TcConHeadRead-tDeepRead       = tcCon1 TcConDeepRead-tWrite          = tcCon1 TcConWrite-tDeepWrite      = tcCon1 TcConDeepWrite-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--twCon2 tc ts    = tApps (TCon $ TyConWitness tc) ts----- | Build a nullary type constructor of the given kind.-tConData0 :: n -> Kind n -> Type n-tConData0 n k   = TCon (TyConBound (UName n) k)----- | Build a type constructor application of one argumnet.-tConData1 :: n -> Kind n -> Type n -> Type n-tConData1 n k t1 = TApp (TCon (TyConBound (UName n) k)) t1-
DDC/Type/DataDef.hs view
@@ -11,7 +11,6 @@         -- * Data type definition table         , DataDefs   (..)         -         , DataMode   (..)         , emptyDataDefs         , insertDataDef@@ -26,7 +25,7 @@         , typeOfDataCtor) where import DDC.Type.Exp-import DDC.Type.Compounds+import DDC.Type.Exp.Simple.Compounds import Data.Map                         (Map) import qualified Data.Map.Strict        as Map import Data.Maybe@@ -212,6 +211,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 +224,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 +250,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`
DDC/Type/Env.hs view
@@ -22,6 +22,7 @@          -- * Conversion         , fromList+        , fromListNT         , fromTypeMap          -- * Projections @@ -36,13 +37,10 @@         , isPrim          -- * Lifting-        , wrapTForalls--        -- * Wrapping         , 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)@@ -128,6 +126,12 @@         = foldr extend empty bs  +-- | Convert a list of name and types into an environment+fromListNT :: Ord n => [(n, Type n)] -> Env n+fromListNT nts+ = fromList [BName n t | (n, t) <- nts]++ -- | Convert a map of names to types to a environment. fromTypeMap :: Map n (Type n) -> Env n fromTypeMap m@@ -183,7 +187,8 @@ -- | Lookup a bound name from an environment. lookupName :: Ord n => n -> Env n -> Maybe (Type n) lookupName n env-        = Map.lookup n (envMap env)+        =       Map.lookup n (envMap env)+        `mplus` (envPrimFun env n)   -- | Yield the total depth of the deBruijn stack.@@ -206,15 +211,4 @@         , envStack       = map (liftT n) (envStack env)         , envStackLength = envStackLength env         , envPrimFun     = envPrimFun     env }----- | Wrap locally bound (non primitive) variables defined in an environment---   around a type as new foralls.-wrapTForalls :: Ord n => Env n -> Type n -> Type n-wrapTForalls env tBody- = let  bsNamed = [BName b t | (b, t) <- Map.toList $ envMap env ]-        bsAnon  = [BAnon t   | t <- envStack env]-        -        tInner  = foldr TForall tBody (reverse bsAnon)-   in   foldr TForall tInner bsNamed
− DDC/Type/Equiv.hs 
@@ -1,138 +0,0 @@--module DDC.Type.Equiv-        ( equivT-        , equivWithBindsT-        , equivTyCon)-where-import DDC.Type.Transform.Crush-import DDC.Type.Compounds-import DDC.Type.Bind-import DDC.Type.Exp-import qualified DDC.Type.Sum   as Sum----- | Check equivalence of types.------   Checks equivalence up to alpha-renaming, as well as crushing of effects---   and trimming of closures.---  ---   * Return `False` if we find any free variables.------   * We assume the types are well-kinded, so that the type annotations on---     bound variables match the binders. If this is not the case then you get---     an indeterminate result.----equivT  :: Ord n => Type n -> Type n -> Bool-equivT t1 t2-        = equivWithBindsT [] [] t1 t2---- | Like `equivT` but take the initial stacks of type binders.-equivWithBindsT-        :: Ord n-        => [Bind n]-        -> [Bind n]-        -> Type n-        -> Type n-        -> Bool--equivWithBindsT stack1 stack2 t1 t2- = let  t1'     = unpackSumT $ crushSomeT t1-        t2'     = unpackSumT $ crushSomeT 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)-         | Nothing      <- getBindType stack1 u1-         , Nothing      <- getBindType stack2 u2-         , u1 == u2     -> checkBounds u1 u2 True--	 -- 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-         , ix1 == ix2-         -> checkBounds u1 u2 -         $  equivWithBindsT stack1 stack2 t1a t2a--         | otherwise-         -> checkBounds u1 u2-         $  False--        -- Constructor names must be equal.-        (TCon tc1,        TCon tc2)-         -> equivTyCon tc1 tc2--        -- Push binders on the stack as we enter foralls.-        (TForall b11 t12, TForall b21 t22)-         |  equivT  (typeOfBind b11) (typeOfBind b21)-         -> equivWithBindsT-                (b11 : stack1)-                (b21 : stack2)-                t12 t22--        -- Decend into applications.-        (TApp t11 t12,    TApp t21 t22)-         -> equivWithBindsT stack1 stack2 t11 t21-         && equivWithBindsT stack1 stack2 t12 t22-        -        -- Sums are equivalent if all of their components are.-        (TSum ts1,        TSum ts2)-         -> let ts1'      = Sum.toList ts1-                ts2'      = Sum.toList ts2--                -- If all the components of the sum were in the element-                -- arrays then they come out of Sum.toList sorted-                -- and we can compare corresponding pairs.-                checkFast = and $ zipWith (equivWithBindsT stack1 stack2) ts1' ts2'--                -- If any of the components use a higher kinded type variable-                -- like (c : % ~> !) then they won't nessesarally be sorted,-                -- so we need to do this slower O(n^2) check.-                -- Make sure to get the bind stacks the right way around here.-                checkSlow = and [ or (map (equivWithBindsT stack1 stack2 t1c) ts2') -                                | t1c <- ts1' ]-                         && and [ or (map (equivWithBindsT stack2 stack1 t2c) ts1') -                                | t2c <- ts2' ]--            in  (length ts1' == length ts2')-            &&  (checkFast || checkSlow)--        (_, _)  -> False----- | If we have a UName and UPrim with the same name then these won't match---   even though they pretty print the same. This will only happen due to ---   a compiler bugs, but is very confusing when it does, so we check for---   this case explicitly.-checkBounds :: Eq n => Bound n -> Bound n -> a -> a-checkBounds u1 u2 x- = case (u1, u2) of-        (UName n2, UPrim n1 _)-         | n1 == n2     -> die--        (UPrim n1 _, UName n2)-         | n1 == n2     -> die--        _               -> x- where-  die   = error $ unlines-        [ "DDC.Type.Equiv"-        , "  Found a primitive and non-primitive bound variable with the same name."]----- | Unpack single element sums into plain types.-unpackSumT :: Type n -> Type n-unpackSumT (TSum ts)-	| [t]   <- Sum.toList ts = t-unpackSumT tt			 = tt----- 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-equivTyCon tc1 tc2- = case (tc1, tc2) of  -        (TyConBound u1 _, TyConBound u2 _) -> u1  == u2-        _                                  -> tc1 == tc2-
DDC/Type/Exp.hs view
@@ -14,6 +14,6 @@         , Bind     (..)         , Bound    (..)) where-import DDC.Type.Exp.Base-import DDC.Type.Exp.NFData      ()+import DDC.Type.Exp.Simple.Exp+import DDC.Type.Exp.Simple.NFData       ()
− DDC/Type/Exp/Base.hs 
@@ -1,277 +0,0 @@--module DDC.Type.Exp.Base where-import Data.Array-import Data.Map.Strict  (Map)-import Data.Set         (Set)----- Bind -------------------------------------------------------------------------- | A variable binder.-data Binder n-        = RNone-        | RAnon-        | RName !n-        deriving Show----- | A variable binder with its type.-data Bind n-        -- | A variable with no uses in the body doesn't need a name.-        = BNone     !(Type n)--        -- | Nameless variable on the deBruijn stack.-        | BAnon     !(Type n)--        -- | Named variable in the environment.-        | BName n   !(Type n)-        deriving Show------ | A bound occurrence of a variable, with its type.------   If variable hasn't been annotated with its real type then this ---   can be `tBot` (an empty sum).--data Bound n-        -- | Nameless variable that should be on the deBruijn stack.-        = UIx   !Int   --        -- | Named variable that should be in the environment.-        | UName !n--        -- | Named primitive that has its type attached to it.-        --   The types of primitives must be closed.-        | UPrim !n !(Type n)-        deriving Show----- Types ------------------------------------------------------------------------- | A value type, kind, or sort.------   We use the same data type to represent all three universes, as they have---  a similar algebraic structure.----data Type n-        -- | Variable.-        = TVar    !(Bound n)--        -- | Constructor.-        | TCon    !(TyCon n)--        -- | Abstraction.-        | TForall !(Bind  n) !(Type  n)-        -        -- | Application.-        | TApp    !(Type  n) !(Type  n)--        -- | Least upper bound.-        | TSum    !(TypeSum n)-        deriving Show---type Sort    n = Type n-type Kind    n = Type n-type Region  n = Type n-type Effect  n = Type n-type Closure n = Type n----- Type Sums --------------------------------------------------------------------- | A least upper bound of several types.--- ---   We keep type sums in this normalised format instead of joining them---   together with a binary operator (like @(+)@). This makes sums easier to work---   with, as a given sum type often only has a single physical representation.-data TypeSum n-        = TypeSumBot-        { typeSumKind           :: !(Kind n) }--        | TypeSumSet-        { -- | The kind of the elements in this sum.-          typeSumKind           :: !(Kind n)--          -- | Where we can see the outer constructor of a type, its argument-          --   is inserted into this array. This handles common cases like-          --   Read, Write, Alloc effects.-        , typeSumElems          :: !(Array TyConHash (Set (TypeSumVarCon n)))--          -- | A map for named type variables.-        , typeSumBoundNamed     :: !(Map n   (Kind n))--          -- | A map for anonymous type variables.-        , typeSumBoundAnon      :: !(Map Int (Kind n))--          -- | Types that can't be placed in the other fields go here.-          -- -          --   INVARIANT: this list doesn't contain more `TSum`s.-        , typeSumSpill          :: ![Type n] }-        deriving Show-        ---- | Hash value used to insert types into the `typeSumElems` array of a `TypeSum`.-data TyConHash -        = TyConHash !Int-        deriving (Eq, Show, Ord, Ix)----- | Wraps a variable or constructor that can be added the `typeSumElems` array.-data TypeSumVarCon n-        = TypeSumVar !(Bound n)-        | TypeSumCon !(Bound n) !(Kind n)-        deriving Show----- TyCon ------------------------------------------------------------------------- | Kind, type and witness constructors.------   These are grouped to make it easy to determine the universe that they---   belong to.--- -data TyCon n-        -- | (level 3) Builtin Sort constructors.-        = TyConSort     !SoCon--        -- | (level 2) Builtin Kind constructors.-        | TyConKind     !KiCon--        -- | (level 1) Builtin Spec constructors for the types of witnesses.-        | TyConWitness  !TwCon--        -- | (level 1) Builtin Spec constructors for types of other kinds.-        | TyConSpec     !TcCon--        -- | User defined type constructor.-        | TyConBound    !(Bound n) !(Kind n)--        -- | An existentially quantified name, with its kind.-        --   Used during type checking, but not accepted in source programs.-        | TyConExists   !Int       !(Kind n)-        deriving Show----- | Sort constructor.-data SoCon-        -- | Sort of witness kinds.-        = SoConProp                -- 'Prop'--        -- | Sort of computation kinds.-        | SoConComp                -- 'Comp'-        deriving (Eq, Show)----- | Kind constructor.-data KiCon-        -- | Function kind constructor.-        --   This is only well formed when it is fully applied.-        = KiConFun              -- (~>)--        -- Witness kinds -------------------------        -- | Kind of witnesses.-        | KiConWitness          -- 'Witness :: Prop'--        -- Computation kinds ----------------------        -- | Kind of data values.-        | KiConData             -- 'Data    :: Comp'--        -- | Kind of regions.-        | KiConRegion           -- 'Region  :: Comp'--        -- | Kind of effects.-        | KiConEffect           -- 'Effect  :: Comp'--        -- | Kind of closures.-        | KiConClosure          -- 'Closure :: Comp'-        deriving (Eq, Show)----- | Witness type constructors.-data TwCon-        -- Witness implication.-        = TwConImpl             -- :: '(=>) :: Witness ~> Data'--        -- | 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--        -- | Constancy of material regions in some type-        | TwConDeepConst        -- :: Data    ~> Witness--        -- | Mutability of some region.-        | TwConMutable          -- :: Region  ~> Witness--        -- | Mutability of material regions in some type.-        | TwConDeepMutable      -- :: Data    ~> Witness--        -- | 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)----- | Other constructors at the spec level.-data TcCon-        -- Data type constructors ----------------        -- | The unit data type constructor is baked in.-        = TcConUnit             -- 'Unit :: Data'--        -- | 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'--        -- Effect type constructors --------------        -- | Read of some region.-        | TcConRead             -- :: 'Region ~> Effect'--        -- | Read the head region in a data type.-        | TcConHeadRead         -- :: 'Data   ~> Effect'--        -- | Read of all material regions in a data type.-        | TcConDeepRead         -- :: 'Data   ~> Effect'-        -        -- | Write of some region.-        | TcConWrite            -- :: 'Region ~> Effect'--        -- | Write to all material regions in some data type.-        | TcConDeepWrite        -- :: 'Data   ~> Effect'-        -        -- | Allocation into some region.-        | TcConAlloc            -- :: 'Region ~> Effect'--        -- | 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)
+ DDC/Type/Exp/Flat.hs view
@@ -0,0 +1,7 @@++module DDC.Type.Exp.Flat+        ( module DDC.Type.Exp.Flat.Exp+        , module DDC.Type.Exp.Flat.Pretty)+where+import DDC.Type.Exp.Flat.Exp+import DDC.Type.Exp.Flat.Pretty
+ DDC/Type/Exp/Flat/Exp.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE TypeFamilies #-}+module DDC.Type.Exp.Flat.Exp +        ( module DDC.Type.Exp.Generic.Exp+        , Flat(..)+        , Type, TyCon)+where+import DDC.Type.Exp.Generic.Exp+import Data.Text                (Text)++data Flat       +        = Flat+        deriving Show+        ++type Type       = GType  Flat+type TyCon      = GTyCon Flat++type instance GTAnnot    Flat   = ()+type instance GTBindVar  Flat   = Text+type instance GTBoundVar Flat   = Text+type instance GTBindCon  Flat   = Text+type instance GTBoundCon Flat   = Text+type instance GTPrim     Flat   = Text+
+ DDC/Type/Exp/Flat/Pretty.hs view
@@ -0,0 +1,13 @@++module DDC.Type.Exp.Flat.Pretty+        (module DDC.Type.Exp.Generic.Pretty)+where+import DDC.Type.Exp.Generic.Pretty+import DDC.Data.Pretty+import Data.Text                (Text)+import qualified Data.Text      as T+++instance Pretty Text where+ ppr tt = text $ T.unpack tt+
+ DDC/Type/Exp/Generic.hs view
@@ -0,0 +1,42 @@++module DDC.Type.Exp.Generic+        ( -- * Abstract Syntax+          -- ** Type Families+          GTAnnot+        , GTBindVar, GTBoundVar+        , GTBindCon, GTBoundCon+        , GTPrim++          -- ** Core Syntax+        , GType (..), GTyCon (..)++          -- ** Syntactic Sugar+        , pattern TFun+        , pattern TUnit+        , pattern TVoid+        , pattern TBot+        , pattern TPrim++          -- * Compounds+          -- ** Type Applications+        , makeTApps,    takeTApps++          -- ** Function Types+        , makeTFun,     makeTFuns+        , takeTFun,     takeTFuns,      takeTFuns'++          -- ** Forall Types+        , makeTForall,  takeTForall++          -- ** Exists Types+        , makeTExists,  takeTExists++          -- * Type Classes+        , Binding       (..)+        , Anon          (..)+        , ShowGType)+where+import DDC.Type.Exp.Generic.Exp+import DDC.Type.Exp.Generic.Binding+import DDC.Type.Exp.Generic.Compounds+
+ DDC/Type/Exp/Generic/Binding.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE TypeFamilies #-}+module DDC.Type.Exp.Generic.Binding +        ( Binding       (..)+        , Anon          (..))+where+import DDC.Type.Exp.Generic.Exp+++-- Binding --------------------------------------------------------------------+-- | Class of languages that include name binding.+class Binding l where++ -- | Get the bound occurrence that matches the given binding occurrence.+ boundOfBind      :: l -> GTBindVar l -> GTBoundVar l++ -- | Check if the given bound occurence matches a binding occurrence.+ boundMatchesBind :: l -> GTBindVar l -> GTBoundVar l -> Bool+++-- Anon -----------------------------------------------------------------------+-- | Class of languages that support anonymous binding.+class Anon l where+ + -- | Evaluate a function given a new anonymous binding and matching+ --   bound occurrence.+ withBinding  :: l -> (GTBindVar l -> GTBoundVar l -> a) -> a+ withBinding l f   =  withBindings l 1 (\[b] [u] -> f b u)++ withBindings :: l -> Int -> ([GTBindVar l] -> [GTBoundVar l] -> a) -> a
+ DDC/Type/Exp/Generic/Compounds.hs view
@@ -0,0 +1,261 @@+{-# OPTIONS -fno-warn-missing-signatures #-}+module DDC.Type.Exp.Generic.Compounds+        ( -- * Destructors+          takeTCon+        , takeTVar+        , takeTAbs+        , takeTApp++          -- * Type Applications+        , makeTApps,    takeTApps++          -- * Function Types+        , makeTFun,     makeTFuns,      makeTFuns',     (~>)+        , takeTFun,     takeTFuns,      takeTFuns'++          -- * Forall Types+        , makeTForall,  makeTForalls +        , takeTForall++          -- * Exists Types+        , makeTExists,  takeTExists++          -- * Union types+        , takeTUnion+        , makeTUnions,  takeTUnions+        , splitTUnionsOfKind)+where+import DDC.Type.Exp.Generic.Exp+import DDC.Type.Exp.Generic.Binding+++-- Destructors ----------------------------------------------------------------+-- | Take a type constructor, looking through annotations.+takeTCon :: GType l -> Maybe (GTyCon l)+takeTCon tt+ = case tt of+        TAnnot _ t      -> takeTCon t+        TCon   tc       -> Just tc+        _               -> Nothing+++-- | Take a type variable, looking through annotations.+takeTVar :: GType l -> Maybe (GTBoundVar l)+takeTVar tt+ = case tt of+        TAnnot _ t      -> takeTVar t+        TVar u          -> Just u+        _               -> Nothing+++-- | Take a type abstraction, looking through annotations.+takeTAbs :: GType l -> Maybe (GTBindVar l, GType l, GType l)+takeTAbs tt+ = case tt of+        TAnnot _ t      -> takeTAbs t+        TAbs b k t      -> Just (b, k, t)+        _               -> Nothing+++-- | Take a type application, looking through annotations.+takeTApp :: GType l -> Maybe (GType l, GType l)+takeTApp tt+ = case tt of+        TAnnot _ t      -> takeTApp t+        TApp t1 t2      -> Just (t1, t2)+        _               -> Nothing+++-- Type Applications ----------------------------------------------------------+-- | Construct a sequence of type applications.+makeTApps :: GType l -> [GType l] -> GType l+makeTApps t1 ts     = foldl TApp t1 ts+++-- | Flatten a sequence of type applications into the function part and+--   arguments, if any.+takeTApps :: GType l -> [GType l]+takeTApps tt+ = case takeTApp tt of+        Just (t1, t2) -> takeTApps t1 ++ [t2]+        _             -> [tt]+++-- Function Types -------------------------------------------------------------+-- | Construct a function type with the given parameter and result type.+makeTFun :: GType l -> GType l -> GType l+makeTFun t1 t2           = TFun t1 t2+infixr `makeTFun`++(~>) = makeTFun+infixr ~>++-- | Like `makeFun` but taking a list of parameter types.+makeTFuns :: [GType l] -> GType l -> GType l+makeTFuns []     t1     = t1+makeTFuns (t:ts) t1     = t `makeTFun` makeTFuns ts t1+++-- | Like `makeTFuns` but taking the parameter and return types as a list.+makeTFuns' :: [GType l] -> Maybe (GType l)+makeTFuns' []           = Nothing+makeTFuns' [_]          = Nothing+makeTFuns' ts+ = let (tR : tAs)       = reverse ts+   in  Just $ makeTFuns (reverse tAs) tR+++-- | Destruct a function type into its parameter and result types,+--   returning `Nothing` if this isn't a function type.+takeTFun :: GType l -> Maybe (GType l, GType l)+takeTFun tt+        | Just (t1f, t2)               <- takeTApp tt+        , Just (TCon TyConFun, t1)     <- takeTApp t1f+        = Just (t1, t2)++        | otherwise+        = Nothing+++-- | Destruct a function type into into all its parameters and result type,+--   returning an empty parameter list if this isn't a function type.+takeTFuns :: GType l -> ([GType l], GType l)+takeTFuns tt+ = case takeTFun tt of+        Just (t1, t2)+          |  (ts, t2') <- takeTFuns t2+          -> (t1 : ts, t2')++        _ -> ([], tt)+++-- | Like `takeFuns`, but yield the parameter and return types in the same list.+takeTFuns' :: GType l -> [GType l]+takeTFuns' tt+ = let  (ts, t1) = takeTFuns tt+   in   ts ++ [t1]+++-- Forall types ---------------------------------------------------------------+-- | Construct a forall quantified type using an anonymous binder.+makeTForall :: Anon l  => l -> GType l -> (GType l -> GType l) -> GType l+makeTForall l k makeBody+        =  withBinding l $ \b u +        -> TApp (TCon (TyConForall k)) (TAbs b k (makeBody (TVar u)))+++-- | Construct a forall quantified type using some anonymous binders.+makeTForalls :: Anon l => l -> [GType l] -> ([GType l] -> GType l) -> GType l+makeTForalls l ks makeBody+        = withBindings l (length ks) $ \bs us +        -> foldr (\(k, b) t -> TApp (TCon (TyConForall k)) (TAbs b k t))+                        (makeBody $ reverse $ map TVar us)+                        (zip ks bs)+++-- | Destruct a forall quantified type, if this is one.+--+--   The kind we return comes from the abstraction rather than the+--   Forall constructor.+takeTForall :: GType l -> Maybe (GType l, GTBindVar l, GType l)+takeTForall tt+        | Just (t1, t2)         <- takeTApp tt+        , Just (TyConForall _)  <- takeTCon t1+        , Just (b, k, t)        <- takeTAbs t2+        = Just (k, b, t)++        | otherwise+        = Nothing+++-- Exists types ---------------------------------------------------------------+-- | Construct an exists quantified type using an anonymous binder.+makeTExists :: Anon l => l -> GType l -> (GType l -> GType l) -> GType l+makeTExists l k makeBody+        =  withBinding l $ \b u +        -> TApp (TCon (TyConExists k)) (TAbs b k (makeBody (TVar u)))+++-- | Destruct an exists quantified type, if this is one.+--   +--   The kind we return comes from the abstraction rather than the+--   Exists constructor. +takeTExists :: GType l -> Maybe (GType l, GTBindVar l, GType l)+takeTExists tt+        | Just (t1, t2)         <- takeTApp tt+        , Just (TyConExists _)  <- takeTCon t1+        , Just (b, k, t)        <- takeTAbs t2+        = Just (k, b, t)++        | otherwise     +        = Nothing+++-- Bot Types ------------------------------------------------------------------+-- | Take a bottom type, looking through annotations.+takeTBot :: GType l -> Maybe (GType l)+takeTBot tt+ = case tt of+        TAnnot _ t              -> takeTBot t+        TCon (TyConBot k)       -> Just k+        _                       -> Nothing+++-- Union types ------------------------------------------------------------------+-- | Take the kind, left and right types from a union type.+takeTUnion :: GType l -> Maybe (GType l, GType l, GType l)+takeTUnion tt+        | Just (ts1, t2)        <- takeTApp tt+        , Just (ts,  t1)        <- takeTApp ts1+        , Just (TyConUnion k)   <- takeTCon ts+        = Just (k, t1, t2)++        | otherwise+        = Nothing+++-- | Make a union type from a kind and list of component types.+makeTUnions :: GType l -> [GType l] -> GType l+makeTUnions k tss+ = case tss of+        []              -> TBot k+        [t1]            -> t1+        (t1 : ts)       -> foldr (TUnion k) t1 ts+++-- | Split a union type into its components.+--    If this is not a union, or is an ill kinded union then Nothing.+takeTUnions :: Eq (GType l) => GType l -> Maybe (GType l, [GType l])+takeTUnions tt+        | Just k                <- takeTBot tt+        = Just (k, [])++        | Just (k, t1, t2)      <- takeTUnion tt+        , Just ts1              <- splitTUnionsOfKind k t1+        , Just ts2              <- splitTUnionsOfKind k t2+        = Just (k, ts1 ++ ts2)++        | otherwise+        = Nothing+++-- | Split a union of the given kind into its components.+--    When we split a sum we need to check that the kind attached+--    to the sum type constructor is the one that we were expecting,+--    otherwise we risk splitting ill-kinded sums without noticing it.+splitTUnionsOfKind :: Eq (GType l) => GType l -> GType l -> Maybe [GType l]+splitTUnionsOfKind k t+        | Just k'             <- takeTBot t+        = if k == k'+                then    return []+                else    Nothing++        | Just (k', t1, t2)   <- takeTUnion t+        = if k == k'+                then do t1s     <- splitTUnionsOfKind k t1+                        t2s     <- splitTUnionsOfKind k t2+                        return  $  t1s ++ t2s+                else    Nothing++        | otherwise+        = Just [t]
+ DDC/Type/Exp/Generic/Exp.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE TypeFamilies, UndecidableInstances #-}++-- Generic type expression representation.+module DDC.Type.Exp.Generic.Exp +        ( -- * Type Families+          GTAnnot+        , GTBindVar, GTBoundVar+        , GTBindCon, GTBoundCon+        , GTPrim++          -- * Abstract Syntax+        , GType         (..)+        , GTyCon        (..)++          -- * Syntactic Sugar+        , pattern TApp2+        , pattern TApp3+        , pattern TApp4+        , pattern TApp5++        , pattern TVoid+        , pattern TUnit+        , pattern TFun+        , pattern TBot+        , pattern TUnion+        , pattern TPrim++          -- * Classes+        , ShowGType)+where+++---------------------------------------------------------------------------------------------------+-- Type functions associated with the language AST.++-- | Yield the type of annotations.+type family GTAnnot    l++-- | Yield the type of binding occurrences of variables.+type family GTBindVar  l++-- | Yield the type of bound occurrences of variables.+type family GTBoundVar l++-- | Yield the type of binding occurrences of constructors.+type family GTBindCon  l++-- | Yield the type of bound occurrences of constructors.+type family GTBoundCon l++-- | Yield the type of primitive type names.+type family GTPrim     l+++---------------------------------------------------------------------------------------------------+-- | Generic type expression representation.+data GType l+        -- | An annotated type.+        = TAnnot     !(GTAnnot l) (GType l)++        -- | Type constructor or literal.+        | TCon       !(GTyCon l)++        -- | Type variable.+        | TVar       !(GTBoundVar l)++        -- | Type abstracton.+        | TAbs       !(GTBindVar l) (GType l) (GType l)++        -- | Type application.+        | TApp       !(GType l) (GType l)+++-- | Applcation of a type to two arguments.+pattern TApp2 t0 t1 t2          = TApp (TApp t0 t1) t2++-- | Applcation of a type to three arguments.+pattern TApp3 t0 t1 t2 t3       = TApp (TApp (TApp t0 t1) t2) t3++-- | Applcation of a type to four arguments.+pattern TApp4 t0 t1 t2 t3 t4    = TApp (TApp (TApp (TApp t0 t1) t2) t3) t4++-- | Applcation of a type to five arguments.+pattern TApp5 t0 t1 t2 t3 t4 t5 = TApp (TApp (TApp (TApp (TApp t0 t1) t2) t3) t4) t5+++deriving instance+        ( Eq (GTAnnot l),   Eq (GTyCon l)+        , Eq (GTBindVar l), Eq (GTBoundVar l))+        => Eq (GType l)+++---------------------------------------------------------------------------------------------------+-- | Wrapper for primitive constructors that adds the ones+--   common to SystemFω based languages.+data GTyCon l+        -- | The void constructor.+        = TyConVoid++        -- | The unit constructor.+        | TyConUnit++        -- | The function constructor.+        | TyConFun++        -- | Take the least upper bound at the given kind.+        | TyConUnion  !(GType l)++        -- | The least element of the given kind.+        | TyConBot    !(GType l)++        -- | The universal quantifier with a parameter of the given kind.+        | TyConForall !(GType l)++        -- | The existential quantifier with a parameter of the given kind.+        | TyConExists !(GType l)++        -- | Primitive constructor.+        | TyConPrim   !(GTPrim l)++        -- | Bound constructor.+        | TyConBound  !(GTBoundCon l)+++deriving instance +        (Eq (GType l), Eq (GTPrim l), Eq (GTBoundCon l))+        => Eq (GTyCon l)+++---------------------------------------------------------------------------------------------------+-- | Representation of the void type.+pattern TVoid           = TCon TyConVoid++-- | Representation of the unit type.+pattern TUnit           = TCon TyConUnit++-- | Representation of the function type.+pattern TFun t1 t2      = TApp (TApp (TCon TyConFun) t1) t2++-- | Representation of the bottom type at a given kind.+pattern TBot k          = TCon (TyConBot k)++-- | Representation of a union of two types.+pattern TUnion k t1 t2  = TApp (TApp (TCon (TyConUnion k)) t1) t2++-- | Representation of primitive type constructors.+pattern TPrim   p       = TCon (TyConPrim p)+++---------------------------------------------------------------------------------------------------+-- | Synonym for show constraints of all language types.+type ShowGType l+        = ( Show l+          , Show (GTAnnot   l)+          , Show (GTBindVar l), Show (GTBoundVar l)+          , Show (GTBindCon l), Show (GTBoundCon l)+          , Show (GTPrim    l))++deriving instance ShowGType l => Show (GType  l)+deriving instance ShowGType l => Show (GTyCon l)+
+ DDC/Type/Exp/Generic/NFData.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE UndecidableInstances #-}++module DDC.Type.Exp.Generic.NFData where+import DDC.Type.Exp.Generic.Exp+import Control.DeepSeq+++type NFDataLanguage l+        = ( NFData l+          , NFData (GTAnnot l)+          , NFData (GTBindVar l), NFData (GTBoundVar l)+          , NFData (GTBindCon l), NFData (GTBoundCon l)+          , NFData (GTPrim l))+++instance NFDataLanguage l => NFData (GType l) where+ rnf xx+  = case xx of+        TAnnot a t      -> rnf a  `seq` rnf t+        TCon   tc       -> rnf tc+        TVar   bv       -> rnf bv+        TAbs   bv k t   -> rnf bv `seq` rnf k `seq` rnf t+        TApp   t1 t2    -> rnf t1 `seq` rnf t2+++instance NFDataLanguage l => NFData (GTyCon l) where+ rnf xx+  = case xx of+        TyConUnit       -> ()+        TyConVoid       -> ()+        TyConFun        -> ()+        TyConUnion  t   -> rnf t+        TyConBot    t   -> rnf t+        TyConForall t   -> rnf t+        TyConExists t   -> rnf t+        TyConPrim   p   -> rnf p+        TyConBound  bc  -> rnf bc+
+ DDC/Type/Exp/Generic/Predicates.hs view
@@ -0,0 +1,16 @@++-- | Predicates on type expressions.+module DDC.Type.Exp.Generic.Predicates+        (isAtomT)+where+import DDC.Type.Exp.Generic.Exp+++-- | Check whether a type is a `TVar` or `TCon`.+isAtomT :: GType l -> Bool+isAtomT tt+ = case tt of+        TAnnot _ t      -> isAtomT t+        TCon{}          -> True+        TVar{}          -> True+        _               -> False
+ DDC/Type/Exp/Generic/Pretty.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TypeFamilies, UndecidableInstances #-}++module DDC.Type.Exp.Generic.Pretty+        ( PrettyConfig+        , pprRawT+        , pprRawPrecT+        , pprRawC)+where+import DDC.Type.Exp.Generic.Exp+import DDC.Data.Pretty+++-- | Synonym for pretty constraints on the configurable types.+type PrettyConfig l+      = ( Pretty (GTAnnot   l)+        , Pretty (GTBindVar l), Pretty (GTBoundVar l)+        , Pretty (GTBindCon l), Pretty (GTBoundCon l)+        , Pretty (GTPrim    l))+++-- | Pretty print a type using the generic, raw syntax.+pprRawT     :: PrettyConfig l => GType l -> Doc+pprRawT tt = pprRawPrecT 0 tt+++-- | Like `pprRawT`, but take the initial precedence.+pprRawPrecT :: PrettyConfig l => Int -> GType l -> Doc+pprRawPrecT d tt+ = case tt of+        TAnnot a t+         ->  braces (ppr a) +         <+> pprRawT t++        TCon c   -> pprRawC c+        TVar u   -> ppr u++        TAbs b k t +         -> pprParen (d > 1) +         $  text "λ" <> ppr b <> text ":" <+> pprRawT k <> text "." <+> pprRawT t++        TApp t1 t2+         -> pprParen (d > 10)+         $  pprRawT t1 <+> pprRawPrecT 11 t2+++-- | Pretty print a type constructor using the generic, raw syntax.+pprRawC :: PrettyConfig l => GTyCon l -> Doc+pprRawC cc+  = case cc of+        TyConFun        -> text "→"+        TyConUnit       -> text "1"+        TyConVoid       -> text "0"+        TyConUnion  k   -> text "∨" <> braces (pprRawT k)+        TyConBot    k   -> text "⊥" <> braces (pprRawT k)+        TyConForall k   -> text "∀" <> braces (pprRawT k)+        TyConExists k   -> text "∃" <> braces (pprRawT k)+        TyConPrim   p   -> ppr p+        TyConBound  u   -> ppr u+
− DDC/Type/Exp/NFData.hs 
@@ -1,82 +0,0 @@--module DDC.Type.Exp.NFData where-import DDC.Type.Exp.Base-import Control.DeepSeq---instance NFData n => NFData (Binder n) where- rnf bb-  = case bb of-        RNone   -> ()-        RAnon   -> ()-        RName n -> rnf n---instance NFData n => NFData (Bind n) where- rnf bb-  = case bb of-        BNone t         -> rnf t-        BAnon t         -> rnf t-        BName n t       -> rnf n `seq` rnf t---instance NFData n => NFData (Bound n) where- rnf uu-  = case uu of-        UIx   i         -> rnf i-        UName n         -> rnf n-        UPrim u t       -> rnf u `seq` rnf t---instance NFData n => NFData (Type n) where- rnf tt-  = case tt of-        TVar u          -> rnf u-        TCon tc         -> rnf tc-        TForall b t     -> rnf b  `seq` rnf t-        TApp    t1 t2   -> rnf t1 `seq` rnf t2-        TSum    ts      -> rnf ts---instance NFData n => NFData (TypeSum n) where- rnf !ts-  = case ts of-        TypeSumBot{}-         -> rnf (typeSumKind ts)--        TypeSumSet{}    -         ->    rnf (typeSumKind       ts)-         `seq` rnf (typeSumElems      ts)-         `seq` rnf (typeSumBoundNamed ts)-         `seq` rnf (typeSumBoundAnon  ts)-         `seq` rnf (typeSumSpill      ts)---instance NFData TyConHash where- rnf (TyConHash i)-  = rnf i---instance NFData n => NFData (TypeSumVarCon n) where- rnf ts-  = case ts of-        TypeSumVar u            -> rnf u-        TypeSumCon u k          -> rnf u `seq` rnf k-        --instance NFData n => NFData (TyCon n) where- rnf tc-  = case tc of-        TyConSort    con        -> rnf con-        TyConKind    con        -> rnf con-        TyConWitness con        -> rnf con-        TyConSpec    con        -> rnf con-        TyConBound   con k      -> rnf con `seq` rnf k-        TyConExists  n   k      -> rnf n   `seq` rnf k---instance NFData SoCon-instance NFData KiCon-instance NFData TwCon-instance NFData TcCon-
+ DDC/Type/Exp/Pretty.hs view
@@ -0,0 +1,51 @@++module DDC.Type.Exp.Pretty where+import DDC.Type.Exp.TyCon+import DDC.Data.Pretty+++instance Pretty SoCon where+ ppr sc +  = case sc of+        SoConComp       -> text "Comp"+        SoConProp       -> text "Prop"+++instance Pretty KiCon where+ ppr kc+  = case kc of+        KiConFun        -> text "(~>)"+        KiConData       -> text "Data"+        KiConRegion     -> text "Region"+        KiConEffect     -> text "Effect"+        KiConClosure    -> text "Closure"+        KiConWitness    -> text "Witness"+++instance Pretty TwCon where+ ppr tw+  = case tw of+        TwConImpl       -> text "(=>)"+        TwConPure       -> text "Purify"+        TwConConst      -> text "Const"+        TwConDeepConst  -> text "DeepConst"+        TwConMutable    -> text "Mutable"+        TwConDeepMutable-> text "DeepMutable"+        TwConDistinct n -> text "Distinct" <> ppr n+        TwConDisjoint   -> text "Disjoint"+        ++instance Pretty TcCon where+ ppr tc +  = case tc of+        TcConUnit       -> text "Unit"+        TcConFun        -> text "(->)"+        TcConSusp       -> text "S"+        TcConRead       -> text "Read"+        TcConHeadRead   -> text "HeadRead"+        TcConDeepRead   -> text "DeepRead"+        TcConWrite      -> text "Write"+        TcConDeepWrite  -> text "DeepWrite"+        TcConAlloc      -> text "Alloc"+        TcConDeepAlloc  -> text "DeepAlloc"+
+ DDC/Type/Exp/Simple.hs view
@@ -0,0 +1,176 @@++module DDC.Type.Exp.Simple+        ( -------------------------------------------------+          -- * Abstract Syntax+          -- ** Types+          Type          (..)+        , TypeSum       (..)+        , TyConHash     (..)+        , TypeSumVarCon (..)++          -- ** Binding+        , Binder        (..)+        , Bind          (..)+        , Bound         (..)++          -- ** Constructors+        , TyCon         (..)+        , SoCon         (..)+        , KiCon         (..)+        , TwCon         (..)+        , TcCon         (..)++          -- ** Aliases+        , Sort, Kind+        , Region, Effect, Closure+++          -------------------------------------------------+          -- * Predicates+        , -- ** Binders+          isBNone+        , isBAnon+        , isBName++          -- ** Atoms+        , isTVar+        , isBot+        , isAtomT+        , isTExists++          -- ** Kinds+        , isDataKind+        , isRegionKind+        , isEffectKind+        , isClosureKind+        , isWitnessKind++          -- ** Data Types+        , isAlgDataType+        , isWitnessType+        , isConstWitType+        , isMutableWitType+        , isDistinctWitType++          -- ** Effect Types+        , isReadEffect+        , isWriteEffect+        , isAllocEffect+        , isSomeReadEffect+        , isSomeWriteEffect+        , isSomeAllocEffect++        ---------------------------------------------------+          -- * Relations+          -- ** Equivalence+        , equivT+        , equivWithBindsT+        , equivTyCon++          -- ** Subsumption+        , subsumesT++        ---------------------------------------------------+          -- * Transforms+          -- ** Crushing+        , crushSomeT+        , crushEffect++        ---------------------------------------------------+          -- * Compounds+          -- ** Binds+        , takeNameOfBind+        , typeOfBind+        , replaceTypeOfBind+        +          -- ** Binders+        , binderOfBind+        , makeBindFromBinder+        , partitionBindsByType+        +          -- ** Bounds+        , takeNameOfBound+        , takeTypeOfBound+        , boundMatchesBind+        , namedBoundMatchesBind+        , takeSubstBoundOfBind+        , takeSubstBoundsOfBinds+        , replaceTypeOfBound++          -- ** Sorts+        , sComp, sProp++          -- ** Kinds+        , kData, kRegion, kEffect, kClosure, kWitness+        , kFun+        , kFuns+        , takeKFun+        , takeKFuns+        , takeKFuns'+        , takeResultKind++         -- ** Quantifiers+        , tForall,  tForall'+        , tForalls, tForalls'+        , takeTForalls,  eraseTForalls++          -- ** Sums+        , tBot+        , tSum++          -- ** Applications+        , tApp,          ($:)+        , tApps,         takeTApps+        , takeTyConApps+        , takePrimTyConApps+        , takeDataTyConApps+        , takePrimeRegion++          -- ** Functions+        , tFun+        , tFunOfList+        , tFunOfParamResult+        , takeTFun+        , takeTFunArgResult+        , takeTFunWitArgResult+        , takeTFunAllArgResult+        , arityOfType+        , dataArityOfType++          -- ** Suspensions+        , tSusp+        , takeTSusp+        , takeTSusps++          -- ** Implications+        , tImpl++          -- ** Units+        , tUnit++          -- ** Variables+        , tIx+        , takeTExists++          -- ** Effect types+        , tRead,        tDeepRead,      tHeadRead+        , tWrite,       tDeepWrite+        , tAlloc,       tDeepAlloc++          -- ** Witness types+        , tPure+        , tConst,       tDeepConst+        , tMutable,     tDeepMutable+        , tDistinct+        , tConData0,    tConData1)+where+import DDC.Type.Exp.Simple.Exp+import DDC.Type.Exp.Simple.NFData       ()+import DDC.Type.Exp.Simple.Pretty       ()+import DDC.Type.Exp.Simple.Predicates+import DDC.Type.Exp.Simple.Compounds+import DDC.Type.Exp.Simple.Equiv+import DDC.Type.Exp.Simple.Subsumes+++
+ DDC/Type/Exp/Simple/Compounds.hs view
@@ -0,0 +1,663 @@+{-# OPTIONS -fno-warn-missing-signatures #-}+module DDC.Type.Exp.Simple.Compounds+        (  -- * Binds+          takeNameOfBind+        , typeOfBind+        , replaceTypeOfBind+        +          -- * Binders+        , binderOfBind+        , makeBindFromBinder+        , partitionBindsByType+        +          -- * Bounds+        , takeNameOfBound+        , takeTypeOfBound+        , boundMatchesBind+        , namedBoundMatchesBind+        , takeSubstBoundOfBind+        , takeSubstBoundsOfBinds+        , replaceTypeOfBound++          -- * Kinds+        , kFun,         kFuns+        , takeKFun+        , takeKFuns,    takeKFuns'+        , takeResultKind++         -- * Quantifiers+        , tForall,      tForall'+        , tForalls,     tForalls'+        , takeTForalls, eraseTForalls++          -- * Sums+        , tBot+        , tSum++          -- * Applications+        , tApp,          ($:)+        , tApps,         takeTApps+        , takeTyConApps+        , takePrimTyConApps+        , takeDataTyConApps+        , takePrimeRegion++          -- * Functions+        , tFun+        , tFunOfList+        , tFunOfParamResult+        , takeTFun+        , takeTFunArgResult+        , takeTFunWitArgResult+        , takeTFunAllArgResult+        , arityOfType+        , dataArityOfType++          -- * Suspensions+        , tSusp+        , takeTSusp+        , takeTSusps++          -- * Implications+        , tImpl++          -- * Units+        , tUnit++          -- * Variables+        , tIx+        , takeTExists++          -- * Sort construction+        , sComp, sProp++          -- * Kind construction+        , kData, kRegion, kEffect, kClosure, kWitness++          -- * Effect type constructors+        , tRead,        tDeepRead,      tHeadRead+        , tWrite,       tDeepWrite+        , tAlloc,       tDeepAlloc++          -- * Witness type constructors+        , tPure+        , tConst,       tDeepConst+        , tMutable,     tDeepMutable+        , tDistinct++          -- * Type constructor wrappers.+        , tConData0,    tConData1)+where+import DDC.Type.Exp+import qualified DDC.Type.Sum   as Sum+++-- Binds ----------------------------------------------------------------------+-- | Take the variable name of a bind.+--   If this is an anonymous binder then there won't be a name.+takeNameOfBind  :: Bind n -> Maybe n+takeNameOfBind bb+ = case bb of+        BName n _       -> Just n+        BAnon   _       -> Nothing+        BNone   _       -> Nothing+++-- | Take the type of a bind.+typeOfBind :: Bind n -> Type n+typeOfBind bb+ = case bb of+        BName _ t       -> t+        BAnon   t       -> t+        BNone   t       -> t+++-- | Replace the type of a bind with a new one.+replaceTypeOfBind :: Type n -> Bind n -> Bind n+replaceTypeOfBind t bb+ = case bb of+        BName n _       -> BName n t+        BAnon   _       -> BAnon t+        BNone   _       -> BNone t+++-- Binders --------------------------------------------------------------------+-- | Take the binder of a bind.+binderOfBind :: Bind n -> Binder n+binderOfBind bb+ = case bb of+        BName n _       -> RName n+        BAnon _         -> RAnon+        BNone _         -> RNone+++-- | Make a bind from a binder and its type.+makeBindFromBinder :: Binder n -> Type n -> Bind n+makeBindFromBinder bb t+ = case bb of+        RName n         -> BName n t+        RAnon           -> BAnon t+        RNone           -> BNone t+++-- | Make lists of binds that have the same type.+partitionBindsByType :: Eq n => [Bind n] -> [([Binder n], Type n)]+partitionBindsByType [] = []+partitionBindsByType (b:bs)+ = let  t       = typeOfBind b+        bsSame  = takeWhile (\b' -> typeOfBind b' == t) bs+        rs      = map binderOfBind (b:bsSame)+   in   (rs, t) : partitionBindsByType (drop (length bsSame) bs)+++-- Bounds ---------------------------------------------------------------------+-- | Take the name of bound variable.+--   If this is a deBruijn index then there won't be a name.+takeNameOfBound :: Bound n -> Maybe n+takeNameOfBound uu+ = case uu of+        UName n         -> Just n+        UPrim n _       -> Just n+        UIx{}           -> Nothing+++-- | Get the attached type of a `Bound`, if any.+takeTypeOfBound :: Bound n -> Maybe (Type n)+takeTypeOfBound uu+ = case uu of+        UName{}         -> Nothing+        UPrim _ t       -> Just t+        UIx{}           -> Nothing+++-- | Check whether a bound maches a bind.+--    `UName`    and `BName` match if they have the same name.+--    @UIx 0 _@  and @BAnon _@ always match.+--   Yields `False` for other combinations of bounds and binds.+boundMatchesBind :: Eq n => Bound n -> Bind n -> Bool+boundMatchesBind u b+ = case (u, b) of+        (UName n1, BName n2 _)  -> n1 == n2+        (UIx 0,    BAnon _)     -> True+        _                       -> False+++-- | Check whether a named bound matches a named bind. +--   Yields `False` if they are not named or have different names.+namedBoundMatchesBind :: Eq n => Bound n -> Bind n -> Bool+namedBoundMatchesBind u b+ = case (u, b) of+        (UName n1, BName n2 _)  -> n1 == n2+        _                       -> False+++-- | Convert a `Bind` to a `Bound`, ready for substitution.+--   +--   Returns `UName` for `BName`, @UIx 0@ for `BAnon` +--   and `Nothing` for `BNone`, because there's nothing to substitute.+takeSubstBoundOfBind :: Bind n -> Maybe (Bound n)+takeSubstBoundOfBind bb+ = case bb of+        BName n _       -> Just $ UName n +        BAnon _         -> Just $ UIx 0 +        BNone _         -> Nothing+++-- | Convert some `Bind`s to `Bounds`+takeSubstBoundsOfBinds :: [Bind n] -> [Bound n]+takeSubstBoundsOfBinds bs+ = go 1 bs+ where  go _level []               = []+        go level (BName n _ : bs') = UName n           : go level bs'+        go level (BAnon _   : bs') = UIx (len - level) : go (level + 1) bs'+        go level (BNone _   : bs') =                     go level bs'++        len = length [ () | BAnon _ <- bs]+++-- | If this `Bound` is a `UPrim` then replace it's embedded type with a new+--   one, otherwise return it unharmed.+replaceTypeOfBound :: Type n -> Bound n -> Bound n+replaceTypeOfBound t uu+ = case uu of+        UName{}         -> uu+        UPrim n _       -> UPrim n t+        UIx{}           -> uu+++-- Variables ------------------------------------------------------------------+-- | Construct a deBruijn index.+tIx :: Kind n -> Int -> Type n+tIx _ i         = TVar (UIx i)+++-- Existentials ---------------------------------------------------------------+-- | Take an existential variable from a type.+takeTExists :: Type n -> Maybe Int+takeTExists tt+ = case tt of+        TCon (TyConExists n _)  -> Just n+        _                       -> Nothing+++-- Applications ---------------------------------------------------------------+-- | Construct an empty type sum.+tBot :: Kind n -> Type n+tBot k = TSum $ Sum.empty k+++-- | Construct a type application.+tApp, ($:) :: Type n -> Type n -> Type n+tApp   = TApp+($:)   = TApp+++-- | Construct a sequence of type applications.+tApps   :: Type n -> [Type n] -> Type n+tApps t1 ts     = foldl TApp t1 ts+++-- | Flatten a sequence ot type applications into the function part and+--   arguments, if any.+takeTApps   :: Type n -> [Type n]+takeTApps tt+ = case tt of+        TApp t1 t2      -> takeTApps t1 ++ [t2]+        _               -> [tt]+++-- | Flatten a sequence of type applications, returning the type constructor+--   and arguments, if there is one.+takeTyConApps :: Type n -> Maybe (TyCon n, [Type n])+takeTyConApps tt+ = case takeTApps tt of+        TCon tc : args  -> Just $ (tc, args)+        _               -> Nothing+++-- | Flatten a sequence of type applications, returning the type constructor+--   and arguments, if there is one. Only accept primitive type constructors.+takePrimTyConApps :: Type n -> Maybe (n, [Type n])+takePrimTyConApps tt+ = case takeTApps tt of+        TCon tc : args  +         | TyConBound (UPrim n _) _ <- tc +          -> Just (n, args)+        _ -> Nothing+++-- | Flatten a sequence of type applications, returning the type constructor+--   and arguments, if there is one. Only accept data type constructors.+takeDataTyConApps :: Type n -> Maybe (TyCon n, [Type n])+takeDataTyConApps tt+ = case takeTApps tt of+        TCon tc : args  +         | TyConBound (UName{}) k       <- tc+         , TCon (TyConKind KiConData)   <- takeResultKind k+          -> Just (tc, args)+        _ -> Nothing+++-- | Take the prime region variable of a data type.+--   This corresponds to the region the outermost constructor is allocated into.+takePrimeRegion :: Type n -> Maybe (Type n)+takePrimeRegion tt+ = case takeTApps tt of+        TCon _ : tR@(TVar _) : _+          -> Just tR+        _ -> Nothing+++-- Foralls --------------------------------------------------------------------+-- | Build an anonymous type abstraction, with a single parameter.+tForall :: Kind n -> (Type n -> Type n) -> Type n+tForall k f+        = TForall (BAnon k) (f (TVar (UIx 0)))++-- | Build an anonymous type abstraction, with a single parameter.+--   Starting the next index from the given value.+tForall' :: Int -> Kind n -> (Type n -> Type n) -> Type n+tForall' ix k f+        = TForall (BAnon k) (f (TVar (UIx ix)))+++-- | Build an anonymous type abstraction, with several parameters.+--   Starting the next index from the given value.+tForalls  :: [Kind n] -> ([Type n] -> Type n) -> Type n+tForalls ks f+ = let  bs      = [BAnon k | k <- ks]+        us      = map (\i -> TVar (UIx i)) [0 .. (length ks - 1)]+   in   foldr TForall (f $ reverse us) bs+++-- | Build an anonymous type abstraction, with several parameters.+--   Starting the next index from the given value.+tForalls'  :: Int -> [Kind n] -> ([Type n] -> Type n) -> Type n+tForalls' ix ks f+ = let  bs      = [BAnon k | k <- ks]+        us      = map (\i -> TVar (UIx i)) [ix .. ix + (length ks - 1)]+   in   foldr TForall (f $ reverse us) bs+++-- | Split nested foralls from the front of a type, +--   or `Nothing` if there was no outer forall.+takeTForalls :: Type n -> Maybe ([Bind n], Type n)+takeTForalls tt+ = let  go bs (TForall b t) = go (b:bs) t+        go bs t             = (reverse bs, t)+   in   case go [] tt of+         ([], _)        -> Nothing+         (bs, body)     -> Just (bs, body)+++-- | Erase all `TForall` quantifiers from a type.+eraseTForalls :: Ord n => Type n -> Type n+eraseTForalls tt+ = case tt of+        TVar{}          -> tt+        TCon{}          -> tt+        TAbs{}          -> tt+        TApp t1 t2      -> TApp (eraseTForalls t1) (eraseTForalls t2)+        TForall _ t     -> eraseTForalls t+        TSum ts         -> TSum $ Sum.fromList (Sum.kindOfSum ts) +                                $ map eraseTForalls $ Sum.toList ts+++-- Sums -----------------------------------------------------------------------+tSum :: Ord n => Kind n -> [Type n] -> Type n+tSum k ts = TSum (Sum.fromList k ts)+++-- Unit -----------------------------------------------------------------------+-- | The unit type.+tUnit :: Type n+tUnit = TCon (TyConSpec TcConUnit)+++-- Function Constructors ------------------------------------------------------+-- | Construct a kind function.+kFun :: Kind n -> Kind n -> Kind n+kFun k1 k2      = ((TCon $ TyConKind KiConFun)`TApp` k1) `TApp` k2+infixr `kFun`+++-- | Construct some kind functions.+kFuns :: [Kind n] -> Kind n -> Kind n+kFuns []     k1    = k1+kFuns (k:ks) k1    = k `kFun` kFuns ks k1+++-- | Destruct a kind function+takeKFun :: Kind n -> Maybe (Kind n, Kind n)+takeKFun kk+ = case kk of+        TApp (TApp (TCon (TyConKind KiConFun)) k1) k2   +                -> Just (k1, k2)+        _       -> Nothing+++-- | Destruct a chain of kind functions into the arguments+takeKFuns :: Kind n -> ([Kind n], Kind n)+takeKFuns kk+ = case kk of+        TApp (TApp (TCon (TyConKind KiConFun)) k1) k2+          |  (ks, k2') <- takeKFuns k2+          -> (k1 : ks, k2')++        _ -> ([], kk)+++-- | Like `takeKFuns`, but return argument and return kinds in the same list.+takeKFuns' :: Kind n -> [Kind n]+takeKFuns' kk +        | (ks, k1) <- takeKFuns kk+        = ks ++ [k1]+++-- | Take the result kind of a kind function, or return the same kind+--   unharmed if it's not a kind function.+takeResultKind :: Kind n -> Kind n+takeResultKind kk+ = case kk of+        TApp (TApp (TCon (TyConKind KiConFun)) _) k2+                -> takeResultKind k2+        _       -> kk+++-- Function types -------------------------------------------------------------+-- | Construct a pure function type.+tFun      :: Type n -> Type n -> Type n+tFun t1 t2+        = (TCon $ TyConSpec TcConFun)  `tApps` [t1, t2]+infixr `tFun`+++-- | 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 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+        []      -> Nothing+        (t : tsArgs)       +         -> let tFuns' []             = t+                tFuns' (t' : ts')     = t' `tFun` tFuns' ts'+            in  Just $ tFuns' (reverse tsArgs)+++-- | Yield the argument and result type of a function type.+takeTFun :: Type n -> Maybe (Type n, Type n)+takeTFun tt+ = case tt of+        TApp (TApp (TCon (TyConSpec TcConFun)) t1) t2+          -> Just (t1, t2)+        _ -> Nothing+++-- | Destruct the type of a function, returning just the argument and result types.+takeTFunArgResult :: Type n -> ([Type n], Type n)+takeTFunArgResult tt+ = case tt of+        TApp (TApp (TCon (TyConSpec TcConFun)) t1) t2+          -> let (tsMore, tResult) = takeTFunArgResult t2+             in  (t1 : tsMore, tResult)+        _ -> ([], tt)+++-- | Destruct the type of a function,+--   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@.+takeTFunWitArgResult :: Type n -> ([Type n], [Type n], Type n)+takeTFunWitArgResult tt+ = case tt of+        TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2+         ->  let (twsMore, tvsMore, tResult) = takeTFunWitArgResult t2+             in  (t1 : twsMore, tvsMore, tResult)++        _ -> let (tvsMore, tResult)          = takeTFunArgResult tt+             in  ([], tvsMore, tResult)+++-- | Destruct the type of a possibly polymorphic function+--   returning all kinds of quantifiers, witness arguments, +--   and value arguments in the order they appear, along with +--   the type of the result.+takeTFunAllArgResult :: Type n -> ([Type n], Type n)+takeTFunAllArgResult tt+ = case tt of+        TVar{}          -> ([], tt)+        TCon{}          -> ([], tt)++        TForall b t     +         -> let (tsMore, tResult)       = takeTFunAllArgResult t+            in  (typeOfBind b : tsMore, tResult)++        TApp (TApp (TCon (TyConSpec TcConFun)) t1) 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)++        _ -> ([], tt)+++-- | Determine the arity of an expression by looking at its type.+--   Count all the function arrows, and foralls.+--+--   This assumes the type is in prenex form, meaning that all the quantifiers+--   are at the front.+arityOfType :: Type n -> Int+arityOfType tt+ = case tt of+        TForall _ t     -> 1 + arityOfType t+        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+tImpl t1 t2      +        = ((TCon $ TyConWitness TwConImpl) `tApp` t1) `tApp` t2+infixr `tImpl`+++-- 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) -----------------------------------------------+-- | Sort of kinds of computational types.+sComp           = TCon $ TyConSort SoConComp++-- | Sort of kinds of propositional types.+sProp           = TCon $ TyConSort SoConProp+++-- Level 2 constructors (kinds) -----------------------------------------------+-- | Kind of data types.+kData           = TCon $ TyConKind KiConData++-- | Kind of region types.+kRegion         = TCon $ TyConKind KiConRegion++-- | Kind of effect types.+kEffect         = TCon $ TyConKind KiConEffect++-- | Kind of closure types.+kClosure        = TCon $ TyConKind KiConClosure++-- | Kind of witness types.+kWitness        = TCon $ TyConKind KiConWitness+++-- Level 1 constructors (witness and computation types) -----------------------+-- Effect type constructors+-- | Read effect type constructor.+tRead           = tcCon1 TcConRead++-- | Head Read effect type constructor.+tHeadRead       = tcCon1 TcConHeadRead++-- | Deep Read effect type constructor.+tDeepRead       = tcCon1 TcConDeepRead++-- | Write effect type  constructor.+tWrite          = tcCon1 TcConWrite++-- | Deep Write effect type constructor.+tDeepWrite      = tcCon1 TcConDeepWrite++-- | Alloc effect type constructor. +tAlloc          = tcCon1 TcConAlloc++-- | Deep Alloc effect type constructor.+tDeepAlloc      = tcCon1 TcConDeepAlloc++-- Witness type constructors.+-- | Pure witness type constructor.+tPure           = twCon1 TwConPure++-- | Const witness type constructor.+tConst          = twCon1 TwConConst++-- | Deep Const witness type constructor.+tDeepConst      = twCon1 TwConDeepConst++-- | Mutable witness type constructor.+tMutable        = twCon1 TwConMutable++-- | Deep Mutable witness type constructor.+tDeepMutable    = twCon1 TwConDeepMutable++-- | Distinct witness type constructor.+tDistinct n     = twCon2 (TwConDistinct n)++-- | Wrap a computation type constructor applied to a single argument.+tcCon1 tc t     = (TCon $ TyConSpec    tc) `tApp` t++-- | Wrap a witness type constructor applied to a single argument.+twCon1 tc t     = (TCon $ TyConWitness tc) `tApp` t++-- | Wrap a witness type constructor applied to two arguments.+twCon2 tc ts    = tApps (TCon $ TyConWitness tc) ts++-- | Build a nullary type constructor of the given kind.+tConData0 :: n -> Kind n -> Type n+tConData0 n k   = TCon (TyConBound (UName n) k)++-- | Build a type constructor application of one argumnet.+tConData1 :: n -> Kind n -> Type n -> Type n+tConData1 n k t1 = TApp (TCon (TyConBound (UName n) k)) t1+
+ DDC/Type/Exp/Simple/Equiv.hs view
@@ -0,0 +1,339 @@++module DDC.Type.Exp.Simple.Equiv+        ( equivT+        , equivWithBindsT+        , equivTyCon++        , crushHeadT+        , crushSomeT+        , crushEffect)+where+import DDC.Type.Exp.Simple.Predicates+import DDC.Type.Exp.Simple.Compounds+import DDC.Type.Exp.Simple.Exp+import DDC.Type.Bind+import qualified DDC.Type.Sum           as Sum+import qualified Data.Map.Strict        as Map++import DDC.Core.Env.EnvT                (EnvT)+import qualified DDC.Core.Env.EnvT      as EnvT+++---------------------------------------------------------------------------------------------------+-- | Check equivalence of types.+--+--   Checks equivalence up to alpha-renaming, as well as crushing of effects+--   and trimming of closures.+--  +--   * Return `False` if we find any free variables.+--+--   * We assume the types are well-kinded, so that the type annotations on+--     bound variables match the binders. If this is not the case then you get+--     an indeterminate result.+--+equivT  :: Ord n +        => EnvT n -> Type n -> Type n -> Bool++equivT env t1 t2+        = equivWithBindsT env [] [] t1 t2++-- | Like `equivT` but take the initial stacks of type binders.+equivWithBindsT+        :: Ord n+        => EnvT n       -- ^ Environment of types.+        -> [Bind n]     -- ^ Stack of binders for first type.+        -> [Bind n]     -- ^ Stack of binders for second type.+        -> Type n       -- ^ First type to compare.+        -> Type n       -- ^ Second type to compare.+        -> Bool++equivWithBindsT env stack1 stack2 t1 t2+ = let  t1'     = unpackSumT $ crushSomeT env t1+        t2'     = unpackSumT $ crushSomeT env 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)+         | Nothing         <- getBindType stack1 u1+         , Nothing         <- getBindType stack2 u2+         , u1 == u2        -> checkBounds u1 u2 True++         -- 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+         , ix1 == ix2+         -> checkBounds u1 u2 +         $  equivWithBindsT env stack1 stack2 t1a t2a++         | otherwise+         -> checkBounds u1 u2+         $  False++        -- Lookup type equations.+        (TCon (TyConBound (UName n) _), _)+         | Just t1'' <- Map.lookup n (EnvT.envtEquations env)+         -> equivWithBindsT env stack1 stack2 t1'' t2'++        (_, TCon (TyConBound (UName n) _))+         | Just t2'' <- Map.lookup n (EnvT.envtEquations env)+         -> equivWithBindsT env stack1 stack2 t1' t2''++        -- Constructor names must be equal.+        (TCon tc1,        TCon tc2)+         -> equivTyCon tc1 tc2++        -- Push binders on the stack as we enter foralls.+        (TForall b11 t12, TForall b21 t22)+         |  equivT  env (typeOfBind b11) (typeOfBind b21)+         -> equivWithBindsT env+                (b11 : stack1)+                (b21 : stack2)+                t12 t22++        -- Decend into applications.+        (TApp t11 t12,    TApp t21 t22)+         -> equivWithBindsT env stack1 stack2 t11 t21+         && equivWithBindsT env stack1 stack2 t12 t22+        +        -- Sums are equivalent if all of their components are.+        (TSum ts1,        TSum ts2)+         -> let ts1'      = Sum.toList ts1+                ts2'      = Sum.toList ts2++                -- If all the components of the sum were in the element+                -- arrays then they come out of Sum.toList sorted+                -- and we can compare corresponding pairs.+                checkFast = and $ zipWith (equivWithBindsT env stack1 stack2) ts1' ts2'++                -- If any of the components use a higher kinded type variable+                -- like (c : % ~> !) then they won't nessesarally be sorted,+                -- so we need to do this slower O(n^2) check.+                -- Make sure to get the bind stacks the right way around here.+                checkSlow = and [ or (map (equivWithBindsT env stack1 stack2 t1c) ts2') +                                | t1c <- ts1' ]++                         && and [ or (map (equivWithBindsT env stack2 stack1 t2c) ts1') +                                | t2c <- ts2' ]++            in  (length ts1' == length ts2')+            &&  (checkFast || checkSlow)++        (_, _)  -> False+++-- | If we have a UName and UPrim with the same name then these won't match+--   even though they pretty print the same. This will only happen due to +--   a compiler bugs, but is very confusing when it does, so we check for+--   this case explicitly.+checkBounds :: Eq n => Bound n -> Bound n -> a -> a+checkBounds u1 u2 x+ = case (u1, u2) of+        (UName n2, UPrim n1 _)+         | n1 == n2     -> die++        (UPrim n1 _, UName n2)+         | n1 == n2     -> die++        _               -> x+ where+  die   = error $ unlines+        [ "DDC.Type.Equiv"+        , "  Found a primitive and non-primitive bound variable with the same name."]+++-- | Unpack single element sums into plain types.+unpackSumT :: Type n -> Type n+unpackSumT (TSum ts)+        | [t]   <- Sum.toList ts = t+unpackSumT tt                    = tt+++-- 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+equivTyCon tc1 tc2+ = case (tc1, tc2) of  +        (TyConBound u1 _, TyConBound u2 _) -> u1  == u2+        _                                  -> tc1 == tc2++++---------------------------------------------------------------------------------------------------+-- | Crush effects in the given type.+crushHeadT :: Ord n => EnvT n -> Type n -> Type n+crushHeadT env tt+ = case tt of+        TCon (TyConBound (UName n) _)+         -> case Map.lookup n (EnvT.envtEquations env) of+                Nothing  -> tt+                Just tt' -> crushHeadT env tt'++        TCon{}  -> tt++        TVar{}  -> tt++        TAbs{}  -> tt++        TApp t1 t2+         -> let t1'     = crushHeadT env t1+                t2'     = crushHeadT env t2+            in  TApp t1' t2'++        TForall{} -> tt++        TSum{}    -> tt+++-- | 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 => EnvT n -> Type n -> Type n+crushSomeT env tt+ = case tt of+        TApp (TCon tc) _+         -> case tc of+                TyConSpec TcConDeepRead  -> crushEffect env tt+                TyConSpec TcConDeepWrite -> crushEffect env tt+                TyConSpec TcConDeepAlloc -> crushEffect env 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 => EnvT n -> Effect n -> Effect n+crushEffect env tt+ = {-# SCC crushEffect #-}+   case tt of+        TVar{}          -> tt++        TCon{}          -> tt++        TApp{}+         |  or [equivT env tt t | (_, t) <- Map.toList $ EnvT.envtCapabilities env]+         -> tSum kEffect []++        TAbs b t+         -> TAbs b $ crushEffect env t++        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 env $ 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 env $ 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 env $ TSum $ Sum.fromList kEffect effs++             _ -> tt++         | otherwise+         -> TApp (crushEffect env t1) (crushEffect env t2)++        TForall b t+         -> TForall b $ crushEffect env t++        TSum ts         +         -> TSum+          $ Sum.fromList (Sum.kindOfSum ts)   +          $ map (crushEffect env)+          $ Sum.toList ts+++-- | 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.+-}
+ DDC/Type/Exp/Simple/Exp.hs view
@@ -0,0 +1,182 @@++module DDC.Type.Exp.Simple.Exp+        ( Binder        (..)+        , Bind          (..)+        , Bound         (..)+        , Type          (..)+        , Sort+        , Kind+        , Region+        , Effect+        , Closure+        , TypeSum       (..)+        , TyConHash     (..)+        , TypeSumVarCon (..)+        , TyCon         (..)+        , SoCon         (..)+        , KiCon         (..)+        , TwCon         (..)+        , TcCon         (..))+where+import DDC.Type.Exp.TyCon+import Data.Array+import Data.Map.Strict  (Map)+import Data.Set         (Set)+++-- Binder ---------------------------------------------------------------------+data Binder n+        = RNone+        | RAnon+        | RName !n+        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.+        = BNone     !(Type n)++        -- | Nameless variable on the deBruijn stack.+        | BAnon     !(Type n)++        -- | Named variable in the environment.+        | BName n   !(Type n)+        deriving Show++++-- | A bound occurrence of a variable, with its type.+--+--   If variable hasn't been annotated with its real type then this +--   can be `tBot` (an empty sum).++data Bound n+        -- | Nameless variable that should be on the deBruijn stack.+        = UIx   !Int   ++        -- | Named variable that should be in the environment.+        | UName !n++        -- | Named primitive that has its type attached to it.+        --   The types of primitives must be closed.+        | UPrim !n !(Type n)+        deriving Show+++-- Types ----------------------------------------------------------------------+-- | A value type, kind, or sort.+--+--   We use the same data type to represent all three universes, as they have+--   a similar algebraic structure.+--+data Type n+        -- | Constructor.+        = TCon    !(TyCon n)++        -- | Variable.+        | TVar    !(Bound n)++        -- | Abstraction.+        | TAbs    !(Bind  n) !(Type  n)+        +        -- | Application.+        | TApp    !(Type  n) !(Type  n)++        -- | Universal Quantification.+        | TForall !(Bind  n) !(Type  n)++        -- | Least upper bound.+        | TSum    !(TypeSum n)+        deriving Show+++-- | Sorts are types at level 3.+type Sort    n = Type n++-- | Kinds are types at level 2+type Kind    n = Type n++-- | Alias for region types.+type Region  n = Type n++-- | Alias for effect types.+type Effect  n = Type n++-- | Alias for closure types.+type Closure n = Type n+++-- Type Sums ------------------------------------------------------------------+-- | A least upper bound of several types.+-- +--   We keep type sums in this normalised format instead of joining them+--   together with a binary operator (like @(+)@). This makes sums easier to work+--   with, as a given sum type often only has a single physical representation.+data TypeSum n+        = TypeSumBot+        { typeSumKind           :: !(Kind n) }++        | TypeSumSet+        { -- | The kind of the elements in this sum.+          typeSumKind           :: !(Kind n)++          -- | Where we can see the outer constructor of a type, its argument+          --   is inserted into this array. This handles common cases like+          --   Read, Write, Alloc effects.+        , typeSumElems          :: !(Array TyConHash (Set (TypeSumVarCon n)))++          -- | A map for named type variables.+        , typeSumBoundNamed     :: !(Map n   (Kind n))++          -- | A map for anonymous type variables.+        , typeSumBoundAnon      :: !(Map Int (Kind n))++          -- | Types that can't be placed in the other fields go here.+          -- +          --   INVARIANT: this list doesn't contain more `TSum`s.+        , typeSumSpill          :: ![Type n] }+        deriving Show+        ++-- | Hash value used to insert types into the `typeSumElems` array of a `TypeSum`.+data TyConHash +        = TyConHash !Int+        deriving (Eq, Show, Ord, Ix)+++-- | Wraps a variable or constructor that can be added the `typeSumElems` array.+data TypeSumVarCon n+        = TypeSumVar !(Bound n)+        | TypeSumCon !(Bound n) !(Kind n)+        deriving Show+++-- TyCon ----------------------------------------------------------------------+-- | Kind, type and witness constructors.+--+--   These are grouped to make it easy to determine the universe that they+--   belong to.+-- +data TyCon n+        -- | (level 3) Builtin Sort constructors.+        = TyConSort     !SoCon++        -- | (level 2) Builtin Kind constructors.+        | TyConKind     !KiCon++        -- | (level 1) Builtin Spec constructors for the types of witnesses.+        | TyConWitness  !TwCon++        -- | (level 1) Builtin Spec constructors for types of other kinds.+        | TyConSpec     !TcCon++        -- | User defined type constructor.+        | TyConBound    !(Bound n) !(Kind n)++        -- | An existentially quantified name, with its kind.+        --   Used during type checking, but not accepted in source programs.+        | TyConExists   !Int       !(Kind n)+        deriving Show+
+ DDC/Type/Exp/Simple/NFData.hs view
@@ -0,0 +1,77 @@++module DDC.Type.Exp.Simple.NFData where+import DDC.Type.Exp.Simple.Exp+import Control.DeepSeq+++instance NFData n => NFData (Binder n) where+ rnf bb+  = case bb of+        RNone   -> ()+        RAnon   -> ()+        RName n -> rnf n+++instance NFData n => NFData (Bind n) where+ rnf bb+  = case bb of+        BNone t         -> rnf t+        BAnon t         -> rnf t+        BName n t       -> rnf n `seq` rnf t+++instance NFData n => NFData (Bound n) where+ rnf uu+  = case uu of+        UIx   i         -> rnf i+        UName n         -> rnf n+        UPrim u t       -> rnf u `seq` rnf t+++instance NFData n => NFData (Type n) where+ rnf tt+  = case tt of+        TVar u          -> rnf u+        TCon tc         -> rnf tc+        TAbs    b t     -> rnf b  `seq` rnf t+        TApp    t1 t2   -> rnf t1 `seq` rnf t2+        TForall b t     -> rnf b  `seq` rnf t+        TSum    ts      -> rnf ts+++instance NFData n => NFData (TypeSum n) where+ rnf !ts+  = case ts of+        TypeSumBot{}+         -> rnf (typeSumKind ts)++        TypeSumSet{}    +         ->    rnf (typeSumKind       ts)+         `seq` rnf (typeSumElems      ts)+         `seq` rnf (typeSumBoundNamed ts)+         `seq` rnf (typeSumBoundAnon  ts)+         `seq` rnf (typeSumSpill      ts)+++instance NFData TyConHash where+ rnf (TyConHash i)+  = rnf i+++instance NFData n => NFData (TypeSumVarCon n) where+ rnf ts+  = case ts of+        TypeSumVar u            -> rnf u+        TypeSumCon u k          -> rnf u `seq` rnf k+        ++instance NFData n => NFData (TyCon n) where+ rnf tc+  = case tc of+        TyConSort    _          -> ()+        TyConKind    _          -> ()+        TyConWitness _          -> ()+        TyConSpec    _          -> ()+        TyConBound   con k      -> rnf con `seq` rnf k+        TyConExists  n   k      -> rnf n   `seq` rnf k+
+ DDC/Type/Exp/Simple/Predicates.hs view
@@ -0,0 +1,263 @@++-- | Predicates on type expressions.+module DDC.Type.Exp.Simple.Predicates+        ( -- * Binders+          isBNone+        , isBAnon+        , isBName++          -- * Atoms+        , isTVar+        , isBot+        , isAtomT+        , isTExists++          -- * Kinds+        , isDataKind+        , isRegionKind+        , isEffectKind+        , isClosureKind+        , isWitnessKind++          -- * Data Types+        , isAlgDataType+        , isWitnessType+        , isConstWitType+        , isMutableWitType+        , isDistinctWitType+        , isFunishTCon++          -- * Effect Types+        , isReadEffect+        , isWriteEffect+        , isAllocEffect+        , isSomeReadEffect+        , isSomeWriteEffect+        , isSomeAllocEffect)+where+import DDC.Type.Exp+import DDC.Type.Exp.Simple.Compounds+import Data.Maybe+import qualified DDC.Type.Sum   as T+++-- Binders --------------------------------------------------------------------+isBNone :: Bind n -> Bool+isBNone bb+ = case bb of+        BNone{} -> True+        _       -> False++isBAnon :: Bind n -> Bool+isBAnon bb+ = case bb of+        BAnon{} -> True+        _       -> False++isBName :: Bind n -> Bool+isBName bb+ = case bb of+        BName{} -> True+        _       -> False+++-- Atoms ----------------------------------------------------------------------+-- | Check whether a type is a `TVar`+isTVar :: Type n -> Bool+isTVar tt+ = case tt of+        TVar{}          -> True+        _               -> False++-- | Test if some type is an empty TSum+isBot :: Type n -> Bool+isBot tt+        | TSum ss       <- tt+        , []            <- T.toList ss+        = True+        +        | otherwise     = False+++-- | Check whether a type is a `TVar`, `TCon` or is Bottom.+isAtomT :: Type n -> Bool+isAtomT tt+ = case tt of+        TVar{}          -> True+        TCon{}          -> True+        _               -> isBot tt+++-- | Check whether this type is an existential variable.+isTExists :: Type n -> Bool+isTExists tt+ = isJust $ takeTExists tt+++-- Kinds ----------------------------------------------------------------------+-- | Check if some kind is the data kind.+isDataKind :: Kind n -> Bool+isDataKind tt+ = case tt of+        TCon (TyConKind KiConData)    -> True+        _                             -> False+++-- | Check if some kind is the region kind.+isRegionKind :: Region n -> Bool+isRegionKind tt+ = case tt of+        TCon (TyConKind KiConRegion)  -> True+        _                             -> False+++-- | Check if some kind is the effect kind.+isEffectKind :: Kind n -> Bool+isEffectKind tt+ = case tt of+        TCon (TyConKind KiConEffect)  -> True+        _                             -> False+++-- | Check if some kind is the closure kind.+isClosureKind :: Kind n -> Bool+isClosureKind tt+ = case tt of+        TCon (TyConKind KiConClosure) -> True+        _                             -> False+++-- | Check if some kind is the witness kind.+isWitnessKind :: Kind n -> Bool+isWitnessKind tt+ = case tt of+        TCon (TyConKind KiConWitness) -> True+        _                             -> False+++-- Data Types -----------------------------------------------------------------+-- | Check whether this type is that of algebraic data.+--+--   It needs to have an explicit data constructor out the front,+--   and not a type variable. The constructor must not be the function+--   constructor, and must return a value of kind '*'.+---+--   The function constructor (->) also has this result kind,+--   but it is in `TyConComp`, so is easy to ignore.+isAlgDataType :: Eq n => Type n -> Bool+isAlgDataType tt+        | Just (tc, _)   <- takeTyConApps tt+        , TyConBound _ k <- tc+        = takeResultKind k == kData++        | otherwise+        = False++-- | Check whether type is a witness constructor+isWitnessType :: Eq n => Type n -> Bool+isWitnessType tt+ = case takeTyConApps tt of+        Just (TyConWitness _, _) -> True+        _                        -> False+        ++-- | Check whether this is the type of a @Const@ witness.+isConstWitType :: Eq n => Type n -> Bool+isConstWitType tt+ = case takeTyConApps tt of+        Just (TyConWitness TwConConst, _) -> True+        _                                 -> False+++-- | Check whether this is the type of a @Mutable@ witness.+isMutableWitType :: Eq n => Type n -> Bool+isMutableWitType tt+ = case takeTyConApps tt of+        Just (TyConWitness TwConMutable, _) -> True+        _                                   -> False+++-- | Check whether this is the type of a @Distinct@ witness.+isDistinctWitType :: Eq n => Type n -> Bool+isDistinctWitType tt+ = case takeTyConApps tt of+        Just (TyConWitness (TwConDistinct _), _) -> True+        _                                        -> False+        ++-- | Check if this is the TyFun or KiFun constructor.+isFunishTCon :: Type n -> Bool+isFunishTCon tt+ = case tt of+        TCon (TyConSpec TcConFun)               -> True+        TCon (TyConKind KiConFun)               -> True+        _                                       -> False+++-- Effects --------------------------------------------------------------------+-- | Check whether this is an atomic read effect.+isReadEffect :: Effect n -> Bool+isReadEffect eff+ = case eff of+        TApp (TCon (TyConSpec TcConRead)) _     -> True+        _                                       -> False+++-- | Check whether this is an atomic write effect.+isWriteEffect :: Effect n -> Bool+isWriteEffect eff+ = case eff of+        TApp (TCon (TyConSpec TcConWrite)) _    -> True+        _                                       -> False+++-- | Check whether this is an atomic alloc effect.+isAllocEffect :: Effect n -> Bool+isAllocEffect eff+ = case eff of+        TApp (TCon (TyConSpec TcConAlloc)) _    -> True+        _                                       -> False+++-- | Check whether an effect is some sort of read effect.+--   Matches @Read@ @HeadRead@ and @DeepRead@.+isSomeReadEffect :: Effect n -> Bool+isSomeReadEffect tt+ = case tt of+        TApp (TCon (TyConSpec con)) _+         -> case con of+                TcConRead       -> True+                TcConHeadRead   -> True+                TcConDeepRead   -> True+                _               -> False++        _                       -> False+++-- | Check whether an effect is some sort of allocation effect.+--   Matches @Alloc@ and @DeepAlloc@+isSomeWriteEffect :: Effect n -> Bool+isSomeWriteEffect tt+ = case tt of+        TApp (TCon (TyConSpec con)) _+         -> case con of+                TcConWrite      -> True+                TcConDeepWrite  -> True+                _               -> False++        _                       -> False+++-- | Check whether an effect is some sort of allocation effect.+--   Matches @Alloc@ and @DeepAlloc@+isSomeAllocEffect :: Effect n -> Bool+isSomeAllocEffect tt+ = case tt of+        TApp (TCon (TyConSpec con)) _+         -> case con of+                TcConAlloc      -> True+                TcConDeepAlloc  -> True+                _               -> False++        _                       -> False+
+ DDC/Type/Exp/Simple/Pretty.hs view
@@ -0,0 +1,144 @@++module DDC.Type.Exp.Simple.Pretty +        (module DDC.Data.Pretty)+where+import DDC.Type.Exp.Simple.Exp+import DDC.Type.Exp.Simple.Predicates+import DDC.Type.Exp.Simple.Compounds+import DDC.Type.Exp.Pretty              ()+import DDC.Data.Pretty+import qualified DDC.Type.Sum           as Sum+++-- Bind -----------------------------------------------------------------------+instance (Pretty n, Eq n) => Pretty (Bind n) where+ ppr bb+  = case bb of+        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+ ppr bb+  = case bb of+        RName v         -> ppr v+        RAnon           -> text "^"+        RNone           -> text "_"+++-- | Pretty print a binder, adding spaces after names.+--   The RAnon and None binders don't need spaces, as they're single symbols.+pprBinderSep   :: Pretty n => Binder n -> Doc+pprBinderSep bb+ = case bb of+        RName v         -> ppr v+        RAnon           -> text "^"+        RNone           -> text "_"+++-- | Print a group of binders with the same type.+pprBinderGroup :: (Pretty n, Eq n) => ([Binder n], Type n) -> Doc+pprBinderGroup (rs, t)+        =  (brackets $ (sep $ map pprBinderSep rs) <> text ":" <+> ppr t) +        <> dot+++-- Bound ----------------------------------------------------------------------+instance (Pretty n, Eq n) => Pretty (Bound n) where+ ppr nn+  = case nn of+        UName n        -> ppr n+        UPrim n _      -> ppr n+        UIx i          -> text "^" <> ppr i+++-- Type -----------------------------------------------------------------------+instance (Pretty n, Eq n) => Pretty (Type n) where+ pprPrec d tt+  = case tt of+        -- Standard types.+        TCon tc    -> ppr tc++        TVar b     -> ppr b++        -- Generic abstraction.+        TAbs b t       +         -> pprParen (d > 5)+         $  text "λ" <> ppr b <> dot <+> ppr t++        -- Full application of function constructors are printed infix.+        TApp (TApp (TCon (TyConKind KiConFun)) k1) k2+         -> pprParen (d > 5)+         $  ppr k1 <+> text "~>" <+> ppr k2++        TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2+         -> pprParen (d > 5)+         $  pprPrec 6 t1 <+> text "=>" </> pprPrec 5 t2++        -- Pure function.+        TApp (TApp (TCon (TyConSpec TcConFun)) t1) t2+         -> pprParen (d > 5)+         $  pprPrec 6 t1 <+> text "->" </> pprPrec 5 t2+ +        TApp t1 t2+         -> pprParen (d > 10)+         $  ppr t1 <+> pprPrec 11 t2+                  +        TForall b t+         | Just (bsMore, tBody) <- takeTForalls t+         -> let groups  = partitionBindsByType (b:bsMore)+            in  pprParen (d > 5) +                 $ (cat $ map pprBinderGroup groups) <> ppr tBody+                        +         | otherwise+         -> pprParen (d > 5)+          $ brackets (ppr b) <> dot <> ppr t++        TSum ts+         | isBot tt, isEffectKind  $ Sum.kindOfSum ts+         -> text "Pure"++         | isBot tt, isClosureKind $ Sum.kindOfSum ts +         -> text "Empty"++         | isBot tt, isDataKind    $ Sum.kindOfSum ts +         -> text "Bot"++         | [TCon{}] <- Sum.toList ts+         -> ppr ts++         | isBot tt, otherwise  +         -> parens $ text "Bot: " <> ppr (Sum.kindOfSum ts)+         +         | otherwise+         -> pprParen (d > 9) $  ppr ts+++instance (Pretty n, Eq n) => Pretty (TypeSum n) where+ ppr ss+  = case Sum.toList ss of+      [] | isEffectKind  $ Sum.kindOfSum ss -> text "Pure"+         | isClosureKind $ Sum.kindOfSum ss -> text "Empty"+         | isDataKind    $ Sum.kindOfSum ss -> text "Bot"++         | otherwise+         -> parens $ text "Bot: " <> ppr (Sum.kindOfSum ss)+         +      ts  -> sep $ punctuate (text " +") (map ppr ts)+++instance (Eq n, Pretty n) => Pretty (TyCon n) where+ ppr tt+  = case tt of+        TyConSort sc    -> ppr sc+        TyConKind kc    -> ppr kc+        TyConWitness tc -> ppr tc+        TyConSpec tc    -> ppr tc+        TyConBound u _  -> ppr u+        TyConExists n _ -> text "?" <> int n+
+ DDC/Type/Exp/Simple/Subsumes.hs view
@@ -0,0 +1,26 @@+module DDC.Type.Exp.Simple.Subsumes+        (subsumesT)+where+import DDC.Type.Exp.Simple.Equiv+import DDC.Type.Exp.Simple.Predicates+import DDC.Type.Exp.Simple.Exp+import DDC.Core.Env.EnvT        (EnvT)+import qualified DDC.Type.Sum   as Sum+++-- | Check whether the first type subsumes the second.+--+--   Both arguments are converted to sums, and we check that every+--   element of the second sum is equivalent to an element in the first.+--+--   This only works for well formed types of effect and closure kind.+--   Other types will yield `False`.+subsumesT :: Ord n => EnvT n -> Kind n -> Type n -> Type n -> Bool+subsumesT env k t1 t2+        | isEffectKind k+        , ts1 <- Sum.singleton k $ crushEffect env t1+        , ts2 <- Sum.singleton k $ crushEffect env t2+        = and $ [ Sum.elem t ts1 | t <- Sum.toList ts2 ]++        | otherwise+        = False
+ DDC/Type/Exp/TyCon.hs view
@@ -0,0 +1,102 @@++module DDC.Type.Exp.TyCon where+++-- | Sort constructor.+data SoCon+        -- | Sort of witness kinds.+        = SoConProp                -- 'Prop'++        -- | Sort of computation kinds.+        | SoConComp                -- 'Comp'+        deriving (Eq, Ord, Show)+++-- | Kind constructor.+data KiCon+        -- | Function kind constructor.+        --   This is only well formed when it is fully applied.+        = KiConFun              -- (~>)++        -- Witness kinds ------------------------+        -- | Kind of witnesses.+        | KiConWitness          -- 'Witness :: Prop'++        -- Computation kinds ---------------------+        -- | Kind of data values.+        | KiConData             -- 'Data    :: Comp'++        -- | Kind of regions.+        | KiConRegion           -- 'Region  :: Comp'++        -- | Kind of effects.+        | KiConEffect           -- 'Effect  :: Comp'++        -- | Kind of closures.+        | KiConClosure          -- 'Closure :: Comp'+        deriving (Eq, Ord, Show)+++-- | Witness type constructors.+data TwCon+        -- Witness implication.+        = TwConImpl             -- :: '(=>) :: Witness ~> Data'++        -- | Purity of some effect.+        | TwConPure             -- :: Effect  ~> Witness++        -- | Constancy of some region.+        | TwConConst            -- :: Region  ~> Witness++        -- | Constancy of material regions in some type+        | TwConDeepConst        -- :: Data    ~> Witness++        -- | Mutability of some region.+        | TwConMutable          -- :: Region  ~> Witness++        -- | Mutability of material regions in some type.+        | TwConDeepMutable      -- :: Data    ~> Witness++        -- | Distinctness of some n regions+        | TwConDistinct Int     -- :: Data    ~> [Region] ~> Witness+        +        -- | Non-interfering effects are disjoint. Used for rewrite rules.+        | TwConDisjoint         -- :: Effect  ~> Effect ~> Witness+        deriving (Eq, Ord, Show)+++-- | Other constructors at the spec level.+data TcCon+        -- Data type constructors ---------------+        -- | The unit data type constructor is baked in.+        = TcConUnit             -- 'Unit :: Data'++        -- | Pure function.+        | TcConFun              -- '(->)' :: Data ~> Data ~> Data++        -- | A suspended computation.+        | TcConSusp             -- 'S     :: Effect ~> Data ~> Data'++        -- Effect type constructors -------------+        -- | Read of some region.+        | TcConRead             -- :: 'Region ~> Effect'++        -- | Read the head region in a data type.+        | TcConHeadRead         -- :: 'Data   ~> Effect'++        -- | Read of all material regions in a data type.+        | TcConDeepRead         -- :: 'Data   ~> Effect'+        +        -- | Write of some region.+        | TcConWrite            -- :: 'Region ~> Effect'++        -- | Write to all material regions in some data type.+        | TcConDeepWrite        -- :: 'Data   ~> Effect'+        +        -- | Allocation into some region.+        | TcConAlloc            -- :: 'Region ~> Effect'++        -- | Allocation into all material regions in some data type.+        | TcConDeepAlloc        -- :: 'Data   ~> Effect'+        deriving (Eq, Ord, Show)+
− DDC/Type/Predicates.hs 
@@ -1,253 +0,0 @@---- | Predicates on type expressions.-module DDC.Type.Predicates-        ( -- * Binders-          isBNone-        , isBAnon-        , isBName--          -- * Atoms-        , isTVar-        , isBot-        , isAtomT-        , isTExists--          -- * Kinds-        , isDataKind-        , isRegionKind-        , isEffectKind-        , isClosureKind-        , isWitnessKind--          -- * Data Types-        , isAlgDataType-        , isWitnessType-        , isConstWitType-        , isMutableWitType-        , isDistinctWitType--          -- * Effect Types-        , isReadEffect-        , isWriteEffect-        , isAllocEffect-        , isSomeReadEffect-        , isSomeWriteEffect-        , isSomeAllocEffect)-where-import DDC.Type.Exp-import DDC.Type.Compounds-import Data.Maybe-import qualified DDC.Type.Sum   as T----- Binders ---------------------------------------------------------------------isBNone :: Bind n -> Bool-isBNone bb- = case bb of-        BNone{} -> True-        _       -> False--isBAnon :: Bind n -> Bool-isBAnon bb- = case bb of-        BAnon{} -> True-        _       -> False--isBName :: Bind n -> Bool-isBName bb- = case bb of-        BName{} -> True-        _       -> False----- Atoms ------------------------------------------------------------------------- | Check whether a type is a `TVar`-isTVar :: Type n -> Bool-isTVar tt- = case tt of-        TVar{}          -> True-        _               -> False---- | Test if some type is an empty TSum-isBot :: Type n -> Bool-isBot tt-        | TSum ss       <- tt-        , []            <- T.toList ss-        = True-        -        | otherwise     = False----- | Check whether a type is a `TVar`, `TCon` or is Bottom.-isAtomT :: Type n -> Bool-isAtomT tt- = case tt of-        TVar{}          -> True-        TCon{}          -> True-        _               -> isBot tt----- | Check whether this type is an existential variable.-isTExists :: Type n -> Bool-isTExists tt- = isJust $ takeTExists tt----- Kinds ------------------------------------------------------------------------- | Check if some kind is the data kind.-isDataKind :: Kind n -> Bool-isDataKind tt- = case tt of-        TCon (TyConKind KiConData)    -> True-        _                             -> False----- | Check if some kind is the region kind.-isRegionKind :: Region n -> Bool-isRegionKind tt- = case tt of-        TCon (TyConKind KiConRegion)  -> True-        _                             -> False----- | Check if some kind is the effect kind.-isEffectKind :: Kind n -> Bool-isEffectKind tt- = case tt of-        TCon (TyConKind KiConEffect)  -> True-        _                             -> False----- | Check if some kind is the closure kind.-isClosureKind :: Kind n -> Bool-isClosureKind tt- = case tt of-        TCon (TyConKind KiConClosure) -> True-        _                             -> False----- | Check if some kind is the witness kind.-isWitnessKind :: Kind n -> Bool-isWitnessKind tt- = case tt of-        TCon (TyConKind KiConWitness) -> True-        _                             -> False----- Data Types -------------------------------------------------------------------- | Check whether this type is that of algebraic data.------   It needs to have an explicit data constructor out the front,---   and not a type variable. The constructor must not be the function---   constructor, and must return a value of kind '*'.-------   The function constructor (->) also has this result kind,---   but it is in `TyConComp`, so is easy to ignore.-isAlgDataType :: Eq n => Type n -> Bool-isAlgDataType tt-        | Just (tc, _)   <- takeTyConApps tt-        , TyConBound _ k <- tc-        = takeResultKind k == kData--        | otherwise-        = False---- | Check whether type is a witness constructor-isWitnessType :: Eq n => Type n -> Bool-isWitnessType tt- = case takeTyConApps tt of-	Just (TyConWitness _, _) -> True-	_			 -> False-	---- | Check whether this is the type of a @Const@ witness.-isConstWitType :: Eq n => Type n -> Bool-isConstWitType tt- = case takeTyConApps tt of-        Just (TyConWitness TwConConst, _) -> True-        _                                 -> False----- | Check whether this is the type of a @Mutable@ witness.-isMutableWitType :: Eq n => Type n -> Bool-isMutableWitType tt- = case takeTyConApps tt of-        Just (TyConWitness TwConMutable, _) -> True-        _                                   -> False----- | Check whether this is the type of a @Distinct@ witness.-isDistinctWitType :: Eq n => Type n -> Bool-isDistinctWitType tt- = case takeTyConApps tt of-        Just (TyConWitness (TwConDistinct _), _) -> True-        _                                        -> False-	---- Effects ----------------------------------------------------------------------- | Check whether this is an atomic read effect.-isReadEffect :: Effect n -> Bool-isReadEffect eff- = case eff of-        TApp (TCon (TyConSpec TcConRead)) _     -> True-        _                                       -> False----- | Check whether this is an atomic write effect.-isWriteEffect :: Effect n -> Bool-isWriteEffect eff- = case eff of-        TApp (TCon (TyConSpec TcConWrite)) _    -> True-        _                                       -> False----- | Check whether this is an atomic alloc effect.-isAllocEffect :: Effect n -> Bool-isAllocEffect eff- = case eff of-        TApp (TCon (TyConSpec TcConAlloc)) _    -> True-        _                                       -> False----- | Check whether an effect is some sort of read effect.---   Matches @Read@ @HeadRead@ and @DeepRead@.-isSomeReadEffect :: Effect n -> Bool-isSomeReadEffect tt- = case tt of-        TApp (TCon (TyConSpec con)) _-         -> case con of-                TcConRead       -> True-                TcConHeadRead   -> True-                TcConDeepRead   -> True-                _               -> False--        _                       -> False----- | Check whether an effect is some sort of allocation effect.---   Matches @Alloc@ and @DeepAlloc@-isSomeWriteEffect :: Effect n -> Bool-isSomeWriteEffect tt- = case tt of-        TApp (TCon (TyConSpec con)) _-         -> case con of-                TcConWrite      -> True-                TcConDeepWrite  -> True-                _               -> False--        _                       -> False----- | Check whether an effect is some sort of allocation effect.---   Matches @Alloc@ and @DeepAlloc@-isSomeAllocEffect :: Effect n -> Bool-isSomeAllocEffect tt- = case tt of-        TApp (TCon (TyConSpec con)) _-         -> case con of-                TcConAlloc      -> True-                TcConDeepAlloc  -> True-                _               -> False--        _                       -> False-
− DDC/Type/Pretty.hs 
@@ -1,203 +0,0 @@--module DDC.Type.Pretty -        (module DDC.Base.Pretty)-where-import DDC.Type.Exp-import DDC.Type.Predicates-import DDC.Type.Compounds-import DDC.Base.Pretty-import qualified DDC.Type.Sum           as Sum----- Bind ------------------------------------------------------------------------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----- Binder ----------------------------------------------------------------------instance Pretty n => Pretty (Binder n) where- ppr bb-  = case bb of-        RName v         -> ppr v-        RAnon           -> text "^"-        RNone           -> text "_"----- | Pretty print a binder, adding spaces after names.---   The RAnon and None binders don't need spaces, as they're single symbols.-pprBinderSep   :: Pretty n => Binder n -> Doc-pprBinderSep bb- = case bb of-        RName v         -> ppr v-        RAnon           -> text "^"-        RNone           -> text "_"----- | Print a group of binders with the same type.-pprBinderGroup :: (Pretty n, Eq n) => ([Binder n], Type n) -> Doc-pprBinderGroup (rs, t)-        =  (brackets $ (sep $ map pprBinderSep rs) <+> text ":"  <+> ppr t) -        <> dot----- Bound -----------------------------------------------------------------------instance (Pretty n, Eq n) => Pretty (Bound n) where- ppr nn-  = case nn of-        UName n        -> ppr n-        UPrim n _      -> ppr n-        UIx i          -> text "^" <> ppr i----- Type ------------------------------------------------------------------------instance (Pretty n, Eq n) => Pretty (Type n) where- pprPrec d tt-  = case tt of-        -- Full application of function constructors are printed infix.-        TApp (TApp (TCon (TyConKind KiConFun)) k1) k2-         -> pprParen (d > 5)-         $  ppr k1 <+> text "~>" <+> ppr k2--        TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2-         -> pprParen (d > 5)-         $  pprPrec 6 t1 <+> text "=>" </> pprPrec 5 t2--        -- Pure function.-        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-        TVar b     -> ppr b--        TForall b t-         | Just (bsMore, tBody) <- takeTForalls t-         -> let groups  = partitionBindsByType (b:bsMore)-            in  pprParen (d > 5) -                 $ (cat $ map pprBinderGroup groups) <> ppr tBody-                        -         | otherwise-         -> pprParen (d > 5)-                $ brackets (ppr b) <> dot <> ppr t--        TApp t1 t2-         -> pprParen (d > 10)-         $  ppr t1 <+> pprPrec 11 t2--        TSum ts-         | isBot tt, isEffectKind  $ Sum.kindOfSum ts-         -> text "Pure"--         | isBot tt, isClosureKind $ Sum.kindOfSum ts -         -> text "Empty"--         | isBot tt, isDataKind    $ Sum.kindOfSum ts -         -> text "Bot"--         | [TCon{}] <- Sum.toList ts-         -> ppr ts--         | isBot tt, otherwise  -         -> parens $ text "Bot : " <> ppr (Sum.kindOfSum ts)-         -         | otherwise-         -> pprParen (d > 9) $  ppr ts---instance (Pretty n, Eq n) => Pretty (TypeSum n) where- ppr ss-  = case Sum.toList ss of-      [] | isEffectKind  $ Sum.kindOfSum ss -> text "Pure"-         | isClosureKind $ Sum.kindOfSum ss -> text "Empty"-         | isDataKind    $ Sum.kindOfSum ss -> text "Bot"--         | otherwise-         -> parens $ text "Bot : " <> ppr (Sum.kindOfSum ss)-         -      ts  -> sep $ punctuate (text " +") (map ppr ts)----- TyCon -----------------------------------------------------------------------instance (Eq n, Pretty n) => Pretty (TyCon n) where- ppr tt-  = case tt of-        TyConSort sc    -> ppr sc-        TyConKind kc    -> ppr kc-        TyConWitness tc -> ppr tc-        TyConSpec tc    -> ppr tc-        TyConBound u _  -> ppr u-        TyConExists n _ -> text "?" <> int n---instance Pretty SoCon where- ppr sc -  = case sc of-        SoConComp       -> text "Comp"-        SoConProp       -> text "Prop"---instance Pretty KiCon where- ppr kc-  = case kc of-        KiConFun        -> text "(~>)"-        KiConData       -> text "Data"-        KiConRegion     -> text "Region"-        KiConEffect     -> text "Effect"-        KiConClosure    -> text "Closure"-        KiConWitness    -> text "Witness"---instance Pretty TwCon where- ppr tw-  = 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"-        --instance Pretty TcCon where- ppr tc -  = case tc of-        TcConUnit       -> text "Unit"-        TcConFun        -> text "(->)"-        TcConFunEC      -> text "(->)"-        TcConSusp       -> text "S"-        TcConRead       -> text "Read"-        TcConHeadRead   -> text "HeadRead"-        TcConDeepRead   -> text "DeepRead"-        TcConWrite      -> text "Write"-        TcConDeepWrite  -> text "DeepWrite"-        TcConAlloc      -> text "Alloc"-        TcConDeepAlloc  -> text "DeepAlloc"-        TcConUse        -> text "Use"-        TcConDeepUse    -> text "DeepUse"--
− DDC/Type/Subsumes.hs 
@@ -1,32 +0,0 @@-module DDC.Type.Subsumes-        (subsumesT)-where-import DDC.Type.Exp-import DDC.Type.Predicates-import DDC.Type.Transform.Crush-import DDC.Type.Transform.Trim-import qualified DDC.Type.Sum   as Sum-import Control.Monad----- | Check whether the first type subsumes the second.------   Both arguments are converted to sums, and we check that every---   element of the second sum is equivalent to an element in the first.------   This only works for well formed types of effect and closure kind.---   Other types will yield `False`.-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-        = and $ [ Sum.elem t ts1 | t <- Sum.toList ts2 ]--        | otherwise-        = False
DDC/Type/Sum.hs view
@@ -74,10 +74,7 @@         TVar (UPrim n _) -> Map.member n (typeSumBoundNamed ts)         TCon{}           -> L.elem t (typeSumSpill ts) -        -- Foralls can't be a part of well-kinded sums.-        --  Just check whether the types are strucutrally equal-        --  without worring about alpha-equivalence.-        TForall{}        -> L.elem t (typeSumSpill ts)+        TAbs{}           -> L.elem t (typeSumSpill ts)          TApp (TCon _) _          |  Just (h, vc) <- takeSumArrayElem t@@ -86,6 +83,11 @@          TApp{}           -> L.elem t (typeSumSpill ts)  +        -- Foralls can't be a part of well-kinded sums.+        --  Just check whether the types are strucutrally equal+        --  without worring about alpha-equivalence.+        TForall{}        -> L.elem t (typeSumSpill ts)+         -- Treat bottom effect and closures as always         -- being part of the sum.         TSum ts1@@ -110,12 +112,10 @@         TVar (UName n)  -> ts { typeSumBoundNamed = Map.insert n k (typeSumBoundNamed ts) }         TVar (UIx   i)  -> ts { typeSumBoundAnon  = Map.insert i k (typeSumBoundAnon  ts) }         TVar (UPrim n _)-> ts { typeSumBoundNamed = Map.insert n k (typeSumBoundNamed ts) }+         TCon{}          -> ts { typeSumSpill      = L.nub $ t : typeSumSpill ts } -        -- Foralls can't be part of well-kinded sums.-        --  Just add them to the splill lists so that we can still-        --  pretty print such mis-kinded types.-        TForall{}        -> ts { typeSumSpill      = L.nub $ t : typeSumSpill ts }+        TAbs{}          -> ts { typeSumSpill      = L.nub $ t : typeSumSpill ts }          TApp (TCon _) _          |  Just (h, vc)  <- takeSumArrayElem t@@ -125,6 +125,11 @@                 else ts { typeSumElems = (typeSumElems ts) // [(h, Set.insert vc tsThere)] }                  TApp{}           -> ts { typeSumSpill      = L.nub $ t : typeSumSpill ts }++        -- Foralls can't be part of well-kinded sums.+        --  Just add them to the splill lists so that we can still+        --  pretty print such mis-kinded types.+        TForall{}        -> ts { typeSumSpill      = L.nub $ t : typeSumSpill ts }                  TSum ts'         -> foldr insert ts (toList ts') @@ -138,14 +143,17 @@         TVar (UIx   i)  -> ts { typeSumBoundAnon  = Map.delete i (typeSumBoundAnon  ts) }         TVar (UPrim n _)-> ts { typeSumBoundNamed = Map.delete n (typeSumBoundNamed ts) }         TCon{}          -> ts { typeSumSpill      = L.delete t (typeSumSpill ts) }-        TForall{}       -> ts { typeSumSpill      = L.delete t (typeSumSpill ts) }++        TAbs{}          -> ts { typeSumSpill      = L.delete t (typeSumSpill ts) }                  TApp (TCon _) _          | Just (h, vc) <- takeSumArrayElem t          , tsThere      <- typeSumElems ts ! h          -> ts { typeSumElems = (typeSumElems ts) // [(h, Set.delete vc tsThere)] }          -        TApp{}          -> ts { typeSumSpill       = L.delete t (typeSumSpill ts) }+        TApp{}          -> ts { typeSumSpill      = L.delete t (typeSumSpill ts) }++        TForall{}       -> ts { typeSumSpill      = L.delete t (typeSumSpill ts) }                  TSum ts'        -> foldr delete ts (toList ts') @@ -217,8 +225,6 @@         TcConWrite      -> Just $ TyConHash 2         TcConDeepWrite  -> Just $ TyConHash 3         TcConAlloc      -> Just $ TyConHash 4-        TcConUse        -> Just $ TyConHash 5-        TcConDeepUse    -> Just $ TyConHash 6         _               -> Nothing  @@ -239,8 +245,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 +316,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)
+ DDC/Type/Transform/BoundT.hs view
@@ -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.Simple.Exp+import DDC.Type.Exp.Simple.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+        TAbs    b t     -> TAbs    b (mapBoundAtDepthT f (d + countBAnons [b]) t)+        TApp t1 t2      -> TApp      (mapBoundAtDepthT f d t1) (mapBoundAtDepthT f d t2)+        TForall b t     -> TForall b (mapBoundAtDepthT f (d + countBAnons [b]) t)+        TSum ss         -> TSum      (mapBoundAtDepthT f d 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+
− DDC/Type/Transform/Crush.hs 
@@ -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.--}
− DDC/Type/Transform/LiftT.hs 
@@ -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-
DDC/Type/Transform/Rename.hs view
@@ -18,8 +18,7 @@         -- * Rewriting bound occurences         , use1,  use0) where-import DDC.Type.Compounds-import DDC.Type.Exp+import DDC.Type.Exp.Simple import Data.List import Data.Set                         (Set) import qualified DDC.Type.Sum           as Sum@@ -40,14 +39,21 @@     let down    = renameWith      in case tt of         TVar u          -> TVar (use1 sub u)+         TCon{}          -> tt +        TAbs b t+         -> let (sub1, b')      = bind1 sub b+                t'              = down  sub1 t+            in  TAbs b' t'++        TApp t1 t2      -> TApp (down sub t1) (down sub t2)+         TForall b t          -> let (sub1, b')      = bind1 sub b                 t'              = down  sub1 t             in  TForall b' t' -        TApp t1 t2      -> TApp (down sub t1) (down sub t2)         TSum ts         -> TSum (down sub ts)
DDC/Type/Transform/SpreadT.hs view
@@ -26,11 +26,16 @@         TVar u          -> TVar $ spreadT kenv u         TCon tc         -> TCon $ spreadT kenv tc +        TAbs b t+         -> let b'      = spreadT kenv b+            in  TAbs b' $ spreadT (Env.extend b' kenv) t++        TApp t1 t2      -> TApp (spreadT kenv t1) (spreadT kenv t2)+         TForall b t          -> let b'      = spreadT kenv b             in  TForall b' $ spreadT (Env.extend b' kenv) t -        TApp t1 t2      -> TApp (spreadT kenv t1) (spreadT kenv t2)         TSum ss         -> TSum (spreadT kenv ss)
DDC/Type/Transform/SubstituteT.hs view
@@ -11,13 +11,10 @@         , pushBinds         , substBound) 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.Core.Collect+import DDC.Type.Transform.BoundT import DDC.Type.Transform.Rename-import DDC.Type.Exp+import DDC.Type.Exp.Simple import Data.Maybe import qualified DDC.Type.Sum   as Sum import qualified DDC.Type.Env   as Env@@ -25,7 +22,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 +55,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 +78,29 @@  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{}         -> tt -                TCon (TyConSpec TcConDeepWrite) -                  -> crushEffect      (TApp t1 (down t2))+         TVar u'+          -> case substBound stack u u' of+                Left  u'' -> TVar u''+                Right n   -> liftT n t -                TCon (TyConSpec TcConDeepAlloc) -                  -> crushEffect      (TApp t1 (down t2))+         TAbs b tBody+          | namedBoundMatchesBind u b -> tt+          | otherwise+          -> let -- Substitute into the annotation on the binder.+                 bSub            = down b -                -- 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)))+                 -- Push bind onto stack, and anonymise to avoid capture.+                 (stack', b')    = pushBind fns stack bSub+                +                 -- Substitute into body.+                 tBody'          = substituteWithT u t fns stack' tBody -                _ -> TApp (down t1) (down t2)+             in  TAbs b' tBody' -         TSum ss        -          -> TSum (down ss)+         TApp t1 t2+          -> TApp (down t1) (down t2)           TForall b tBody           | namedBoundMatchesBind u b -> tt@@ -114,7 +108,7 @@           -> 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.                  (stack', b')    = pushBind fns stack bSub                                   -- Substitute into body.@@ -122,10 +116,7 @@               in  TForall b' tBody' -         TVar u'-          -> case substBound stack u u' of-                Left  u'' -> TVar u''-                Right n   -> liftT n t+         TSum ss        -> TSum (down ss)                   instance SubstituteT TypeSum where
− DDC/Type/Transform/Trim.hs 
@@ -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.--}-
DDC/Type/Universe.hs view
@@ -1,22 +1,26 @@  module DDC.Type.Universe         ( Universe(..)+        , universeUp         , universeFromType3         , universeFromType2         , universeFromType1         , universeOfType) where import DDC.Type.Exp-import DDC.Base.Pretty+import DDC.Data.Pretty import DDC.Type.Env             as Env import qualified DDC.Type.Sum   as T   -- | Universes of the Disciple Core language. data Universe +        -- | A numbered universe (levels 4..)+        = UniverseLevel Int+         -- | (level 3). The universe of sorts.         --   Sorts classify kinds.-        = UniverseSort+        | UniverseSort          -- | (level 2). The universe of kinds.         --   Kinds classify specifications.@@ -48,6 +52,7 @@ instance Pretty Universe where  ppr u   = case u of+        UniverseLevel i -> text "Universe" <> int i         UniverseSort    -> text "Sort"         UniverseKind    -> text "Kind"         UniverseSpec    -> text "Spec"@@ -55,6 +60,18 @@         UniverseData    -> text "Data"  +-- | Take the next highest universe of the given one.+universeUp :: Universe -> Universe+universeUp uu+ = case uu of+        UniverseLevel n -> UniverseLevel (n + 1)+        UniverseSort    -> UniverseLevel 4+        UniverseKind    -> UniverseSort+        UniverseSpec    -> UniverseKind+        UniverseWitness -> UniverseSpec+        UniverseData    -> UniverseSpec++ -- | Given the type of the type of the type of some thing (up three levels), --   yield the universe of the original thing, or `Nothing` it was badly formed. universeFromType3 :: Type n -> Maybe Universe@@ -71,6 +88,7 @@ universeFromType2 tt  = case tt of         TVar _                  -> Nothing+         TCon (TyConSort _)      -> Just UniverseSpec          TCon (TyConKind kc)     @@ -83,8 +101,10 @@         TCon TyConSpec{}        -> Nothing         TCon TyConBound{}       -> Nothing         TCon TyConExists{}      -> Nothing-        TForall _ _             -> Nothing++        TAbs{}                  -> Nothing         TApp _ t2               -> universeFromType2 t2+        TForall{}               -> Nothing         TSum _                  -> Nothing  @@ -104,14 +124,15 @@                  TCon (TyConSpec TcConUnit) -> Just UniverseData         TCon (TyConSpec TcConFun)  -> Just UniverseData-        TCon (TyConSpec TcConFunEC)-> Just UniverseData         TCon (TyConSpec TcConSusp) -> Just UniverseData         TCon (TyConSpec _)         -> Nothing                  TCon (TyConBound  _ k)     -> universeFromType2 k         TCon (TyConExists _ k)     -> universeFromType2 k-        TForall b t2               -> universeFromType1 (Env.extend b kenv) t2++        TAbs b t2                  -> universeFromType1 (Env.extend b kenv) t2         TApp t1 _                  -> universeFromType1 kenv t1+        TForall b t2               -> universeFromType1 (Env.extend b kenv) t2         TSum _                     -> Nothing  @@ -135,8 +156,10 @@         TCon (TyConSpec _)      -> Just UniverseSpec         TCon (TyConBound  _ k)  -> universeFromType1 kenv k         TCon (TyConExists _ k)  -> universeFromType1 kenv k-        TForall b t2            -> universeOfType (Env.extend b kenv) t2++        TAbs b t2               -> universeOfType (Env.extend b kenv) t2         TApp _ t2               -> universeOfType kenv t2+        TForall b t2            -> universeOfType (Env.extend b kenv) t2         TSum ss                 -> universeFromType1 kenv (T.kindOfSum ss)
+ DDC/Version.hs view
@@ -0,0 +1,8 @@++module DDC.Version where++splash  :: String+splash  = "The Disciplined Disciple Compiler, version " ++ version++version :: String+version = "0.4.3"
LICENSE view
@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2014 The Disciplined Disciple Compiler Strike Force+Copyrite (K) 2007-2016 The Disciplined Disciple Compiler Strike Force All rights reversed.  Permission is hereby granted, free of charge, to any person obtaining a copy
ddc-core.cabal view
@@ -1,5 +1,5 @@ Name:           ddc-core-Version:        0.4.1.3+Version:        0.4.3.1 License:        MIT License-file:   LICENSE Author:         The Disciplined Disciple Compiler Strike Force@@ -11,43 +11,61 @@ 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,-        array           >= 0.4 && < 0.6,-        deepseq         == 1.3.*,+        base            >= 4.6   && < 4.10,+        array           >= 0.4   && < 0.6,+        deepseq         >= 1.3   && < 1.5,         containers      == 0.5.*,         directory       == 1.2.*,-        transformers    == 0.4.*,-        mtl             == 2.2.*,-        ddc-base        == 0.4.1.*+        text            >= 1.0   && < 1.3,+        transformers    == 0.5.*,+        mtl             >= 2.2   && < 2.3,+        inchworm        >= 1.0.2 && < 1.1,+        filepath        >= 1.4.1 && < 1.5,+        wl-pprint       >= 1.2   && < 1.3,+        parsec          >= 3.1   && < 3.2    Exposed-modules:-        DDC.Core.Annot.AnT-        DDC.Core.Annot.AnTEC+        DDC.Control.Check+        DDC.Control.Panic+        DDC.Control.Parser -        DDC.Core.Compounds.Annot-        DDC.Core.Compounds.Simple+        DDC.Core.Collect.Support+        DDC.Core.Collect.BindStruct+        DDC.Core.Collect.FreeT+        DDC.Core.Collect.FreeX +        DDC.Core.Env.EnvT+        DDC.Core.Env.EnvX++        DDC.Core.Exp.Annot.AnT+        DDC.Core.Exp.Annot.AnTEC+        DDC.Core.Exp.Annot.Context+        DDC.Core.Exp.Annot.Ctx+               +        DDC.Core.Exp.Generic.BindStruct+         DDC.Core.Exp.Annot-        DDC.Core.Exp.Simple+        DDC.Core.Exp.Generic+        DDC.Core.Exp.Literal         -        DDC.Core.Lexer.Names+        DDC.Core.Lexer.Offside         DDC.Core.Lexer.Tokens+        DDC.Core.Lexer.Unicode         -        DDC.Core.Transform.Annotate-        DDC.Core.Transform.Deannotate-        DDC.Core.Transform.LiftT-        DDC.Core.Transform.LiftX+        DDC.Core.Transform.BoundT+        DDC.Core.Transform.BoundX         DDC.Core.Transform.MapT         DDC.Core.Transform.Reannotate         DDC.Core.Transform.Rename@@ -55,42 +73,79 @@         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.Data.Canned+        DDC.Data.Env+        DDC.Data.ListUtils+        DDC.Data.Name+        DDC.Data.Pretty+        DDC.Data.SourcePos++        DDC.Type.Exp.Flat.Exp+        DDC.Type.Exp.Flat.Pretty++        DDC.Type.Exp.Generic.Binding+        DDC.Type.Exp.Generic.Compounds+        DDC.Type.Exp.Generic.Exp+        DDC.Type.Exp.Generic.NFData+        DDC.Type.Exp.Generic.Predicates+        DDC.Type.Exp.Generic.Pretty++        DDC.Type.Exp.Simple.Compounds+        DDC.Type.Exp.Simple.Equiv+        DDC.Type.Exp.Simple.Exp+        DDC.Type.Exp.Simple.Predicates+        DDC.Type.Exp.Simple.Subsumes++        DDC.Type.Exp.Flat+        DDC.Type.Exp.Generic+        DDC.Type.Exp.Pretty+        DDC.Type.Exp.Simple+        DDC.Type.Exp.TyCon++        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-        DDC.Type.Collect-        DDC.Type.Compounds         DDC.Type.DataDef         DDC.Type.Env-        DDC.Type.Equiv         DDC.Type.Exp-        DDC.Type.Predicates-        DDC.Type.Subsumes         DDC.Type.Sum         DDC.Type.Universe +        DDC.Version++   Other-modules:+        DDC.Core.Check.Context.Apply+        DDC.Core.Check.Context.Base+        DDC.Core.Check.Context.Effect+        DDC.Core.Check.Context.Elem+        DDC.Core.Check.Context.Mode++        DDC.Core.Check.Error.ErrorData+        DDC.Core.Check.Error.ErrorDataMessage+        DDC.Core.Check.Error.ErrorExp+        DDC.Core.Check.Error.ErrorExpMessage+        DDC.Core.Check.Error.ErrorType+        DDC.Core.Check.Error.ErrorTypeMessage++        DDC.Core.Check.Judge.Kind.TyCon+         DDC.Core.Check.Judge.Type.AppT         DDC.Core.Check.Judge.Type.AppX         DDC.Core.Check.Judge.Type.Base@@ -104,80 +159,92 @@         DDC.Core.Check.Judge.Type.Sub         DDC.Core.Check.Judge.Type.VarCon         DDC.Core.Check.Judge.Type.Witness-        DDC.Core.Check.Judge.Eq++        DDC.Core.Check.Judge.DataDefs+        DDC.Core.Check.Judge.EqT         DDC.Core.Check.Judge.Inst+        DDC.Core.Check.Judge.Kind+        DDC.Core.Check.Judge.Module         DDC.Core.Check.Judge.Sub+        DDC.Core.Check.Judge.Witness+         DDC.Core.Check.Base+        DDC.Core.Check.Config+        DDC.Core.Check.Context         DDC.Core.Check.Error-        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.Annot.Exp+        DDC.Core.Exp.Annot.Compounds+        DDC.Core.Exp.Annot.Predicates+        DDC.Core.Exp.Annot.Pretty++        DDC.Core.Exp.Generic.Exp+        DDC.Core.Exp.Generic.Compounds+        DDC.Core.Exp.Generic.Predicates+        DDC.Core.Exp.Generic.Pretty++        DDC.Core.Exp.DaCon                 DDC.Core.Exp.WiCon++        DDC.Core.Fragment.Compliance+        DDC.Core.Fragment.Error+        DDC.Core.Fragment.Feature+        DDC.Core.Fragment.Profile++        DDC.Core.Lexer.Token.Builtin+        DDC.Core.Lexer.Token.Index+        DDC.Core.Lexer.Token.Keyword+        DDC.Core.Lexer.Token.Literal+        DDC.Core.Lexer.Token.Names+        DDC.Core.Lexer.Token.Operator+        DDC.Core.Lexer.Token.Symbol         +        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.Core.Fragment.Compliance-        DDC.Core.Fragment.Error-        DDC.Core.Fragment.Feature-        DDC.Core.Fragment.Profile--        DDC.Core.Lexer.Comments-        DDC.Core.Lexer.Offside--        DDC.Type.Check.Judge.Eq-        DDC.Type.Check.Judge.Kind-        DDC.Type.Check.Base-        DDC.Type.Check.CheckCon-        DDC.Type.Check.Config-        DDC.Type.Check.Context-        DDC.Type.Check.Data-        DDC.Type.Check.Error-        DDC.Type.Check.ErrorMessage-        -        DDC.Type.Collect.FreeT-        DDC.Type.Pretty--        DDC.Type.Exp.Base-        DDC.Type.Exp.NFData+        DDC.Type.Exp.Simple.NFData+        DDC.Type.Exp.Simple.Pretty -                     GHC-options:         -Wall         -fno-warn-orphans-        -fno-warn-missing-signatures         -fno-warn-unused-do-bind         -fno-warn-missing-methods+        -fno-warn-missing-signatures+        -fno-warn-missing-pattern-synonym-signatures+        -fno-warn-redundant-constraints    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