packages feed

ddc-core 0.2.1.2 → 0.4.3.1

raw patch · 176 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/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,17 +1,100 @@---- | Type checker for the Disciple core language.+-- | Type checker for the Disciple Core language.+-- +--   The functions in this module do not check for language fragment compliance.+--   This needs to be done separately via "DDC.Core.Fragment".+-- module DDC.Core.Check-        ( -- * Checking Expressions-          checkExp,     typeOfExp+        ( -- * Configuration+          Config(..)+        , configOfProfile +          -- * Type checker trace+        , CheckTrace (..)++          -- * Checking Modules+        , checkModule+        +          -- * Checking Types+        , checkType,    checkTypeM+        , checkSpec+        , kindOfSpec+        , sortOfKind++          -- * Checking Expressions+        , 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.CheckExp-import DDC.Core.Check.CheckWitness+import DDC.Core.Check.Exp+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
@@ -0,0 +1,124 @@++module DDC.Core.Check.Base+        ( -- Things defined in this module.+          Config (..)+        , configOfProfile++        , CheckM+        , newExists+        , newPos+        , applyContext+        , applySolved++        , CheckTrace (..)+        , ctrace++          -- Things defined elsewhere.+        , throw, runCheck, evalCheck+        , EnvX,  EnvT, TypeEnv, KindEnv+        , Set+        , module DDC.Core.Check.Error+        , module DDC.Core.Collect+        , module DDC.Core.Pretty+        , module DDC.Core.Exp.Annot+        , module DDC.Core.Check.Context++        , module DDC.Type.DataDef+        , module DDC.Type.Universe+        , 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.Pretty+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.Universe+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.Maybe+import Data.Set                         (Set)+import qualified Data.Set               as Set+import qualified DDC.Control.Check      as G+import Prelude                          hiding ((<$>))+++-- | Type checker monad.+--   Used to manage type errors.+type CheckM a n+        = G.CheckM (CheckTrace, Int, Int) (Error a n)++-- | Allocate a new existential.+newExists :: Kind n -> CheckM a n (Exists n)+newExists k+ = do   (tr, ix, pos)       <- G.get+        G.put (tr, ix + 1, pos)+        return  (Exists ix k)+++-- | Allocate a new context stack position.+newPos :: CheckM a n Pos+newPos+ = do   (tr, ix, pos)       <- G.get+        G.put (tr, ix, pos + 1)+        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+        = CheckTrace+        { checkTraceDoc :: Doc }++instance Pretty CheckTrace where+ ppr ct = checkTraceDoc ct++instance Monoid CheckTrace where+ mempty = CheckTrace empty++ mappend ct1 ct2+        = CheckTrace+        { checkTraceDoc = checkTraceDoc ct1 <> checkTraceDoc ct2 }+++-- | Append a doc to the checker trace.+ctrace :: Doc -> CheckM a n ()+ctrace doc'+ = do   (tr, ix, pos)       <- G.get+        let tr' = tr { checkTraceDoc = checkTraceDoc tr <$> doc' }+        G.put (tr', ix, pos)+        return  ()+
− DDC/Core/Check/CheckExp.hs 
@@ -1,946 +0,0 @@---- | Type checker for the Disciple Core language.-module DDC.Core.Check.CheckExp-        ( checkExp-        , typeOfExp-        , CheckM-        , checkExpM-        , TaggedClosure(..))-where-import DDC.Core.DataDef-import DDC.Core.Predicates-import DDC.Core.Compounds-import DDC.Core.Exp-import DDC.Core.Pretty-import DDC.Core.Collect-import DDC.Core.Check.Error-import DDC.Core.Check.CheckWitness-import DDC.Core.Check.TaggedClosure-import DDC.Type.Transform.SubstituteT-import DDC.Type.Transform.Crush-import DDC.Type.Transform.Trim-import DDC.Type.Transform.Instantiate-import DDC.Type.Transform.LiftT-import DDC.Type.Transform.LowerT-import DDC.Type.Equiv-import DDC.Type.Universe-import DDC.Type.Compounds-import DDC.Type.Predicates-import DDC.Type.Sum                     as Sum-import DDC.Type.Env                     (Env)-import DDC.Type.Check.Monad             (result, throw)-import DDC.Base.Pretty                  ()-import Data.Set                         (Set)-import qualified DDC.Type.Env           as Env-import qualified DDC.Type.Check         as T-import qualified Data.Set               as Set-import qualified Data.Map               as Map-import Control.Monad-import Data.List                        as L-import Data.Maybe----- Wrappers ---------------------------------------------------------------------- | Type check an expression. ------   If it's good, you get a new version with types attached to all the bound---   variables, as well its the type, effect and closure. ------   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 `typeOfExp` on any open subterm.-checkExp -        :: (Ord n, Pretty n)-        => DataDefs n           -- ^ Data type definitions.-        -> Env n                -- ^ Kind environment.-        -> Env n                -- ^ Type environment.-        -> Exp a n              -- ^ Expression to check.-        -> Either (Error a n)-                  ( Exp a n-                  , Type n-                  , Effect n-                  , Closure n)--checkExp defs kenv tenv xx - = result- $ do   (xx', t, effs, clos) <- checkExpM defs kenv tenv xx-        return  ( xx'-                , t-                , TSum effs-                , closureOfTaggedSet clos)----- | Like `checkExp`, but check in an empty environment,---   and only return the value type of an expression.------   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 `checkExp` above.----typeOfExp -        :: (Ord n, Pretty n)-        => DataDefs n-        -> Exp a n-        -> Either (Error a n) (Type n)-typeOfExp defs xx - = case checkExp defs Env.empty Env.empty xx of-        Left err           -> Left err-        Right (_, t, _, _) -> Right t----- checkExp ---------------------------------------------------------------------- | Like `checkExp` but using the `CheckM` monad to handle errors.-checkExpM -        :: (Ord n, Pretty n)-        => DataDefs n           -- ^ Data type definitions.-        -> Env n                -- ^ Kind environment.-        -> Env n                -- ^ Type environment.-        -> Exp a n              -- ^ Expression to check.-        -> CheckM a n -                ( Exp a n-                , Type n-                , TypeSum n-                , Set (TaggedClosure n))--checkExpM defs kenv tenv xx- = checkExpM' defs kenv tenv xx-{-} = do (xx', t, eff, clo) <- checkExpM' defs kenv tenv xx-      trace (pretty $ vcat -                [ text "checkExpM:  " <+> ppr xx -                , text "        ::  " <+> ppr t -                , text "        :!: " <+> ppr eff-                , text "        :$: " <+> ppr clo-                , text ""])-         $ return (xx', t, eff, clo)--}---- variables -------------------------------------checkExpM' _defs _kenv tenv (XVar a u)- = do   let tBound      = typeOfBound u-        let mtEnv       = Env.lookup u tenv--        let mkResult-             -- When annotation on the bound is bot,-             --  then use the type from the environment.-             | Just tEnv    <- mtEnv-             , isBot tBound-             = return tEnv--             -- The bound has an explicit type annotation,-             --  which matches the one from the environment.-             -- -             --  When the bound is a deBruijn index we need to lift the-             --  annotation on the original binder through any lambdas-             --  between the binding occurrence and the use.-             | Just tEnv    <- mtEnv-             , UIx i _      <- u-             , equivT tBound (liftT (i + 1) tEnv) -             = return tBound--             -- The bound has an explicit type annotation,-             --  which matches the one from the environment.-             | Just tEnv    <- mtEnv-             , equivT tBound tEnv-             = return tEnv--             -- The bound has an explicit type annotation,-             --  which does not match the one from the environment.-             --  This shouldn't happen because the parser doesn't add non-bot-             --  annotations to bound variables.-             | Just tEnv    <- mtEnv-             = throw $ ErrorVarAnnotMismatch u tEnv--             -- Variable not in environment, so use annotation.-             --  This happens when checking open terms.-             | otherwise-             = return tBound-        -        tResult  <- mkResult--        return  ( XVar a u -                , tResult-                , Sum.empty kEffect-                , Set.singleton -                        $ taggedClosureOfValBound -                        $ replaceTypeOfBound tResult u)----- constructors ----------------------------------checkExpM' defs _kenv _tenv xx@(XCon a u)-        | UName n _     <- u-        = case Map.lookup n (dataDefsCtors defs) of-           Nothing -> throw $ ErrorUndefinedCtor xx-           Just _  -            -> return  -                  ( XCon a u-                  , typeOfBound u-                  , Sum.empty kEffect-                  , Set.empty)--        | UPrim{}       <- u-        = return  ( XCon a u-                  , typeOfBound u-                  , Sum.empty kEffect-                  , Set.empty)--        -- Constructors can't be locally bound.-        | otherwise-        = throw $ ErrorMalformedExp xx----- application --------------------------------------- value-type application.-checkExpM' defs kenv tenv xx@(XApp a x1 (XType t2))- = do   (x1', t1, effs1, clos1) <- checkExpM  defs kenv tenv x1-        k2                      <- checkTypeM defs kenv t2-        case t1 of-         TForall b11 t12-          | typeOfBind b11 == k2-          -> return ( XApp a x1' (XType t2)  -                    , substituteT b11 t2 t12-                    , substituteT b11 t2 effs1-                    , clos1 `Set.union` taggedClosureOfTyArg t2)--          | otherwise   -> throw $ ErrorAppMismatch xx (typeOfBind b11) t2-         _              -> throw $ ErrorAppNotFun   xx t1 t2----- value-witness application.-checkExpM' defs kenv tenv xx@(XApp a x1 (XWitness w2))- = do   (x1', t1, effs1, clos1) <- checkExpM     defs kenv tenv x1-        t2                      <- checkWitnessM defs kenv tenv w2-        case t1 of-         TApp (TApp (TCon (TyConWitness TwConImpl)) t11) t12-          | t11 `equivT` t2   -          -> return ( XApp a x1' (XWitness w2)-                    , t12-                    , effs1-                    , clos1)--          | otherwise   -> throw $ ErrorAppMismatch xx t11 t2-         _              -> throw $ ErrorAppNotFun   xx t1 t2-                 ---- value-value application.-checkExpM' defs kenv tenv xx@(XApp a x1 x2)- = do   (x1', t1, effs1, clos1)    <- checkExpM defs kenv tenv x1-        (x2', t2, effs2, clos2)    <- checkExpM defs kenv tenv x2--        -- Note: we don't need to use the closure of the function because-        --       all of its components will already be part of clos1 above.-        case t1 of-         TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFun)) t11) eff) _clo) t12-          | t11 `equivT` t2   -          , effs    <- Sum.fromList kEffect  [eff]-          -> return ( XApp a x1' x2'-                    , t12-                    , effs1 `Sum.union` effs2 `Sum.union` effs-                    , clos1 `Set.union` clos2)--          | otherwise   -> throw $ ErrorAppMismatch xx t11 t2-         _              -> throw $ ErrorAppNotFun xx t1 t2----- spec abstraction ------------------------------checkExpM' defs kenv tenv xx@(XLAM a b1 x2)- = do   let t1          = typeOfBind b1-        _               <- checkTypeM defs kenv t1--        -- Check the body-        let kenv'         = Env.extend b1 kenv-        let tenv'         = Env.lift   1  tenv-        (x2', t2, e2, c2) <- checkExpM  defs kenv' tenv' x2-        k2                <- checkTypeM defs kenv' t2--        when (Env.memberBind b1 kenv)-         $ throw $ ErrorLamShadow xx b1--        -- The body of a spec abstraction must be pure.-        when (e2 /= Sum.empty kEffect)-         $ throw $ ErrorLamNotPure xx (TSum e2)--        -- The body of a spec abstraction must have data kind.-        when (not $ isDataKind k2)-         $ throw $ ErrorLamBodyNotData xx b1 t2 k2--        -- Mask closure terms due to locally bound region vars.-        let c2_cut      = Set.fromList-                        $ mapMaybe (cutTaggedClosureT b1)-                        $ Set.toList c2--        return ( XLAM a b1 x2'-               , TForall b1 t2-               , Sum.empty kEffect-               , c2_cut)-         ---- function abstractions -------------------------checkExpM' defs kenv tenv xx@(XLam a b1 x2)- = do   let t1               =  typeOfBind b1-        k1                   <- checkTypeM defs kenv t1--        -- Check the body.-        let tenv'            =  Env.extend b1 tenv-        (x2', t2, e2, c2)    <- checkExpM  defs kenv tenv' x2   -        k2                   <- checkTypeM defs kenv t2--        -- The form of the function constructor depends on what universe the -        -- binder is in.-        case universeFromType2 k1 of-         Just UniverseData-          |  not $ isDataKind k1     -> throw $ ErrorLamBindNotData xx t1 k1-          |  not $ isDataKind k2     -> throw $ ErrorLamBodyNotData xx b1 t2 k2 -          |  otherwise-          -> let -                 -- Cut closure terms due to locally bound value vars.-                 -- This also lowers deBruijn indices in un-cut closure terms.-                 c2_cut  = Set.fromList-                         $ mapMaybe (cutTaggedClosureX b1)-                         $ Set.toList c2--                 -- 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-                 --  allready checked that.-                 Just c2_captured-                  = trimClosure $ closureOfTaggedSet c2_cut--             in  return ( XLam a b1 x2'-                        , tFun t1 (TSum e2) c2_captured t2-                        , Sum.empty kEffect-                        , c2_cut) --         Just UniverseWitness-          | e2 /= Sum.empty kEffect  -> throw $ ErrorLamNotPure     xx (TSum e2)-          | not $ isDataKind k2      -> throw $ ErrorLamBodyNotData xx b1 t2 k2-          | otherwise                -          -> return ( XLam a b1 x2'-                    , tImpl t1 t2-                    , Sum.empty kEffect-                    , c2)--         _ -> throw $ ErrorMalformedType xx k1----- let ---------------------------------------------checkExpM' defs kenv tenv xx@(XLet a (LLet mode b11 x12) x2)- = do   -- Check the right of the binding.-        (x12', t12, effs12, clo12)  -         <- checkExpM defs kenv tenv x12--        -- Check binder annotation against the type we inferred for the right.-        (b11', k11')    -         <- checkLetBindOfTypeM xx defs kenv tenv t12 b11--        -- The right of the binding should have data kind.-        when (not $ isDataKind k11')-         $ throw $ ErrorLetBindingNotData xx b11' k11'-          -        -- Check the body expression.-        let tenv1  = Env.extend b11' tenv-        (x2', t2, effs2, c2)    <- checkExpM defs kenv tenv1 x2--        -- The body should have data kind.-        k2 <- checkTypeM defs kenv t2-        when (not $ isDataKind k2)-         $ throw $ ErrorLetBodyNotData xx t2 k2--        -- Mask closure terms due to locally bound value vars.-        let c2_cut      = Set.fromList-                        $ mapMaybe (cutTaggedClosureX b11')-                        $ Set.toList c2--        -- Check purity and emptiness for lazy bindings.-        (case mode of-          LetStrict     -> return ()-          LetLazy _-           -> do let eff12' = TSum effs12-                 when (not $ isBot eff12')-                  $ throw $ ErrorLetLazyNotPure xx b11 eff12'--                 let clo12' = closureOfTaggedSet clo12-                 when (not $ isBot clo12')-                  $ throw $ ErrorLetLazyNotEmpty xx b11 clo12')--        -- Check region witness for lazy bindings.-        (case mode of-          LetStrict     -> return ()--          -- Type of lazy binding has no head region, like Unit and (->).-          LetLazy Nothing-           -> do case takeDataTyConApps t12 of-                  Just (_tc, t1 : _)-                   ->  do k1 <- checkTypeM defs kenv t1-                          when (isRegionKind k1)-                           $ throw $ ErrorLetLazyNoWitness xx b11 t12--                  _ -> return ()--          -- Type of lazy binding might have a head region,-          -- so we need a Lazy witness for it.-          LetLazy (Just wit)-           -> do tWit        <- checkWitnessM defs kenv tenv wit-                 let tWitExp =  case takeDataTyConApps t12 of-                                 Just (_tc, tR : _ts) -> tLazy tR-                                 _                    -> tHeadLazy t12--                 when (not $ equivT tWit tWitExp)-                  $ throw $ ErrorLetLazyWitnessTypeMismatch -                                 xx b11 tWit t12 tWitExp)-                                     --        return ( XLet a (LLet mode b11' x12') x2'-               , t2-               , effs12 `Sum.union` effs2-               , clo12  `Set.union` c2_cut)----- letrec ------------------------------------------checkExpM' defs kenv tenv xx@(XLet a (LRec bxs) xBody)- = do   -        let (bs, xs)    = unzip bxs--        -- Check all the annotations.-        ks              <- mapM (checkTypeM defs kenv) -                        $  map typeOfBind bs--        -- Check all the annots have data kind.-        zipWithM_ (\b k-         -> when (not $ isDataKind k)-                $ throw $ ErrorLetBindingNotData xx b k)-                bs ks--        -- All right hand sides need to be lambdas.-        forM_ xs $ \x -         -> when (not $ (isXLam x || isXLAM x))-                $ throw $ ErrorLetrecBindingNotLambda xx x--        -- All variables are in scope in all right hand sides.-        let tenv'       = Env.extends bs tenv--        -- Check the right hand sides.-        (xsRight', tsRight, _effssBinds, clossBinds) -                <- liftM unzip4 $ mapM (checkExpM defs kenv tenv') xs--        -- Check annots on binders against inferred types of the bindings.-        zipWithM_ (\b t-                -> if not $ equivT (typeOfBind b) t-                        then throw $ ErrorLetMismatch xx b t-                        else return ())-                bs tsRight--        -- Check the body expression.-        (xBody', tBody, effsBody, closBody) -                <- checkExpM defs kenv tenv' xBody--        -- The body type must have data kind.-        kBody   <- checkTypeM defs kenv tBody-        when (not $ isDataKind kBody)-         $ throw $ ErrorLetBodyNotData xx tBody kBody--        -- Cut closure terms due to locally bound value vars.-        -- This also lowers deBruijn indices in un-cut closure terms.-        let clos_cut -                = Set.fromList-                $ mapMaybe (cutTaggedClosureXs bs)-                $ Set.toList -                $ Set.unions (closBody : clossBinds)--        return  ( XLet a (LRec (zip bs xsRight')) xBody'-                , tBody-                , effsBody-                , clos_cut)----- letregion ---------------------------------------checkExpM' defs kenv tenv xx@(XLet a (LLetRegion b bs) x)- = case takeSubstBoundOfBind b of-     Nothing     -> checkExpM defs kenv tenv x-     Just u-      -> do-        -- Check the type on the region binder.-        let k   = typeOfBind b-        checkTypeM defs kenv k--        -- The binder must have region kind.-        when (not $ isRegionKind k)-         $ throw $ ErrorLetRegionNotRegion xx b k--        -- We can't shadow region binders because we might have witnesses-        -- in the environment that conflict with the ones created here.-        when (Env.memberBind b kenv)-         $ throw $ ErrorLetRegionRebound xx b-        -        -- Check the witness types.-        let kenv'       = Env.extend b kenv-        let tenv'       = Env.lift 1 tenv-        mapM_ (checkTypeM defs kenv') $ map typeOfBind bs--        -- Check that the witnesses bound here are for the region,-        -- and they don't conflict with each other.-        checkWitnessBindsM xx u bs--        -- Check the body expression.-        let tenv2       = Env.extends bs tenv'-        (xBody', tBody, effs, clo)  <- checkExpM defs kenv' tenv2 x--        -- The body type must have data kind.-        kBody           <- checkTypeM defs kenv' tBody-        when (not $ isDataKind kBody)-         $ throw $ ErrorLetBodyNotData xx tBody kBody--        -- The bound region variable cannot be free in the body type.-        let fvsT         = freeT Env.empty tBody-        when (Set.member u fvsT)-         $ throw $ ErrorLetRegionFree xx b tBody-        -        -- Delete effects on the bound region from the result.-        let effs'       = Sum.delete (tRead  (TVar u))-                        $ Sum.delete (tWrite (TVar u))-                        $ Sum.delete (tAlloc (TVar u))-                        $ effs--        -- Delete the bound region variable from the closure.-        -- Mask closure terms due to locally bound region vars.-        let c2_cut      = Set.fromList-                        $ mapMaybe (cutTaggedClosureT b)-                        $ Set.toList clo--        return  ( XLet a (LLetRegion b bs) xBody'-                , lowerT 1 tBody-                , lowerT 1 effs'-                , c2_cut)----- withregion ------------------------------------checkExpM' defs kenv tenv xx@(XLet a (LWithRegion u) x)- = do   -- Check the type on the region handle.-        let k   = typeOfBound u-        checkTypeM defs kenv k--        -- The handle must have region kind.-        when (not $ isRegionKind k)-         $ throw $ ErrorWithRegionNotRegion xx u k-        -        -- Check the body expression.-        (xBody', tBody, effs, clo) -               <- checkExpM defs kenv tenv x--        -- The body type must have data kind.-        kBody  <- checkTypeM defs kenv tBody-        when (not $ isDataKind kBody)-         $ throw $ ErrorLetBodyNotData xx tBody kBody-        -        -- Delete effects on the bound region from the result.-        let tu          = TCon $ TyConBound u-        let effs'       = Sum.delete (tRead  tu)-                        $ Sum.delete (tWrite tu)-                        $ Sum.delete (tAlloc tu)-                        $ effs-        -        -- Delete the bound region handle from the closure.-        let clo_masked  = Set.delete (GBoundRgnCon u) clo--        return  ( XLet a (LWithRegion u) xBody'-                , tBody-                , effs'-                , clo_masked)-                ---- case expression -------------------------------checkExpM' defs kenv tenv xx@(XCase a xDiscrim alts)- = do-        -- Check the discriminant.-        (xDiscrim', tDiscrim, effsDiscrim, closDiscrim) -         <- checkExpM defs kenv tenv xDiscrim--        -- Split the type into the type constructor names and type parameters.-        -- Also check that it's algebraic data, and not a function or effect-        -- type etc. -        (nTyCon, tsArgs)-         <- case takeTyConApps tDiscrim of-                Just (tc, ts)-                 | TyConBound (UName n t) <- tc-                 , takeResultKind t == kData-                 -> return (n, ts)-                      -                 | TyConBound (UPrim n t) <- tc-                 , takeResultKind t == kData-                 -> return (n, ts)--                _ -> throw $ ErrorCaseDiscrimNotAlgebraic xx tDiscrim--        -- Get the mode of the data type, -        --   this tells us how many constructors there are.-        mode    -         <- case lookupModeOfDataType nTyCon defs of-             Nothing -> throw $ ErrorCaseDiscrimTypeUndeclared xx tDiscrim-             Just m  -> return m--        -- Check the alternatives.-        (alts', ts, effss, closs)     -                <- liftM unzip4-                $  mapM (checkAltM xx defs kenv tenv tDiscrim tsArgs) alts--        -- There must be at least one alternative-        when (null ts)-         $ throw $ ErrorCaseNoAlternatives xx--        -- All alternative result types must be identical.-        let (tAlt : _)  = ts-        forM_ ts $ \tAlt' -         -> when (not $ equivT tAlt tAlt') -             $ throw $ ErrorCaseAltResultMismatch xx tAlt tAlt'--        -- Check for overlapping alternatives.-        let pats                = [p | AAlt p _ <- alts]-        let psDefaults          = filter isPDefault pats-        let nsCtorsMatched      = mapMaybe takeCtorNameOfAlt alts--        -- Alts overlapping because there are multiple defaults.-        when (length psDefaults > 1)-         $ throw $ ErrorCaseOverlapping xx--        -- Alts overlapping because the same ctor is used multiple times.-        when (length (nub nsCtorsMatched) /= length nsCtorsMatched )-         $ throw $ ErrorCaseOverlapping xx--        -- Check for alts overlapping because a default is not last.-        -- Also check there is at least one alternative.-        (case pats of-          [] -> throw $ ErrorCaseNoAlternatives xx--          _  |  or $ map isPDefault $ init pats -             -> throw $ ErrorCaseOverlapping xx--             |  otherwise-             -> return ())--        -- Check the alternatives are exhaustive.-        (case mode of--          -- Small types have some finite number of constructors.-          DataModeSmall nsCtors-           -- If there is a default alternative then we've covered all the-           -- possibiliies. We know this we've also checked for overlap.-           | any isPDefault [p | AAlt p _ <- alts]-           -> return ()--           -- Look for unmatched constructors.-           | nsCtorsMissing <- nsCtors \\ nsCtorsMatched-           , not $ null nsCtorsMissing-           -> throw $ ErrorCaseNonExhaustive xx nsCtorsMissing--           -- All constructors were matched.-           | otherwise -           -> return ()--          -- Large types have an effectively infinite number of constructors-          -- (like integer literals), so there needs to be a default alt.-          DataModeLarge -           | any isPDefault [p | AAlt p _ <- alts] -> return ()-           | otherwise  -           -> throw $ ErrorCaseNonExhaustiveLarge xx)--        let effsMatch    -                = Sum.singleton kEffect -                $ crushEffect $ tHeadRead tDiscrim--        return  ( XCase a xDiscrim' alts'-                , tAlt-                , Sum.unions kEffect (effsDiscrim : effsMatch : effss)-                , Set.unions         (closDiscrim : closs) )----- type cast ---------------------------------------- Weaken an effect, adding in the given terms.-checkExpM' defs kenv tenv xx@(XCast a c@(CastWeakenEffect eff) x1)- = do   -        -- Check the effect term.-        kEff    <- checkTypeM defs kenv eff-        when (not $ isEffectKind kEff)-         $ throw $ ErrorMaxeffNotEff xx eff kEff--        -- Check the body.-        (x1', t1, effs, clo)    <- checkExpM defs kenv tenv x1--        return  ( XCast a c x1'-                , t1-                , Sum.insert eff effs-                , clo)----- Weaken a closure, adding in the given terms.-checkExpM' defs kenv tenv xx@(XCast a c@(CastWeakenClosure clo2) x1)- = do   -        -- Check the closure term.-        kClo    <- checkTypeM defs kenv clo2-        when (not $ isClosureKind kClo)-         $ throw $ ErrorMaxcloNotClo xx clo2 kClo--        -- The closure supplied to weakclo can only contain Use terms-        -- of region variables.-        clos2-         <- case taggedClosureOfWeakClo clo2 of-             Nothing     -> throw $ ErrorMaxcloMalformed xx clo2-             Just clos2' -> return clos2'--        -- Check the body.-        (x1', t1, effs, clos)   <- checkExpM defs kenv tenv x1--        return  ( XCast a c x1'-                , t1-                , effs-                , Set.union clos clos2)----- Purify an effect, given a witness that it is pure.-checkExpM' defs kenv tenv xx@(XCast a c@(CastPurify w) x1)- = do   tW                   <- checkWitnessM defs kenv tenv w-        (x1', t1, effs, clo) <- checkExpM     defs kenv tenv x1-                -        effs' <- case tW of-                  TApp (TCon (TyConWitness TwConPure)) effMask-                    -> return $ Sum.delete effMask effs-                  _ -> throw  $ ErrorWitnessNotPurity xx w tW--        return  ( XCast a c x1'-                , t1-                , effs'-                , clo)----- Forget a closure, given a witness that it is empty.-checkExpM' defs kenv tenv xx@(XCast a c@(CastForget w) x1)- = do   tW                    <- checkWitnessM defs kenv tenv w-        (x1', t1, effs, clos) <- checkExpM     defs kenv tenv x1--        clos' <- case tW of-                  TApp (TCon (TyConWitness TwConEmpty)) cloMask-                    -> return $ maskFromTaggedSet -                                        (Sum.singleton kClosure cloMask)-                                        clos--                  _ -> throw $ ErrorWitnessNotEmpty xx w tW--        return  ( XCast a c x1'-                , t1-                , effs-                , clos')----- Type and witness expressions can only appear as the arguments --- to  applications.-checkExpM' _defs _kenv _tenv xx@(XType _)-        = throw $ ErrorNakedType xx --checkExpM' _defs _kenv _tenv xx@(XWitness _)-        = throw $ ErrorNakedWitness xx------------------------------------------------------------------------------------- | Check a case alternative.-checkAltM -        :: (Pretty n, Ord n) -        => Exp a n              -- ^ Whole case expression, for error messages.-        -> DataDefs n           -- ^ Data type definitions.-        -> Env n                -- ^ Kind environment.-        -> Env n                -- ^ Type environment.-        -> Type n               -- ^ Type of discriminant.-        -> [Type n]             -- ^ Args to type constructor of discriminant.-        -> Alt a n              -- ^ Alternative to check.-        -> CheckM a n -                ( Alt a n-                , Type n-                , TypeSum n-                , Set (TaggedClosure n))--checkAltM _xx defs kenv tenv _tDiscrim _tsArgs (AAlt PDefault xBody)- = do   (xBody', tBody, effBody, cloBody)-                <- checkExpM defs kenv tenv xBody--        return  ( AAlt PDefault xBody'-                , tBody-                , effBody-                , cloBody)--checkAltM xx defs kenv tenv tDiscrim tsArgs (AAlt (PData uCon bsArg) xBody)- = do   -        -- 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.-        let tCtor       = typeOfBound uCon-        tCtor_inst      -         <- case instantiateTs tCtor tsArgs of-             Nothing -> throw $ ErrorCaseCannotInstantiate xx tDiscrim tCtor-             Just t  -> return t-        -        -- Split the constructor type into the field and result types.-        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 $ ErrorCaseDiscrimTypeMismatch xx tDiscrim tResult--        -- There must be at least as many fields as variables in the pattern.-        -- It's ok to bind less fields than provided by the constructor.-        when (length tsFields_ctor < length bsArg)-         $ throw $ ErrorCaseTooManyBinders xx uCon -                        (length tsFields_ctor)-                        (length bsArg)--        -- 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        <- zipWithM (mergeAnnot xx)-                            (map typeOfBind bsArg)-                            tsFields_ctor        --        -- Extend the environment with the field types.-        let bsArg'      = zipWith replaceTypeOfBind tsFields bsArg-        let tenv'       = Env.extends bsArg' tenv-        -        -- Check the body in this new environment.-        (xBody', tBody, effsBody, closBody)-                <- checkExpM defs kenv tenv' xBody--        -- 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--        return  ( AAlt (PData uCon bsArg') xBody'-                , tBody-                , effsBody-                , closBody_cut)----- | Merge a type annotation on a pattern field with a type we get by---   instantiating the constructor type.-mergeAnnot :: Eq n => Exp a n -> Type n -> Type n -> CheckM a n (Type n)-mergeAnnot xx tAnnot tActual-        -- Annotation is bottom, so just use the real type.-        | isBot tAnnot      = return tActual--        -- Annotation matches actual type, all good.-        | tAnnot == tActual = return tActual--        -- Annotation does not match actual type.-        | otherwise       -        = throw $ ErrorCaseFieldTypeMismatch xx tAnnot tActual------------------------------------------------------------------------------------- | Check the set of witness bindings bound in a letregion for conflicts.-checkWitnessBindsM :: Ord n => Exp a n -> Bound n -> [Bind n] -> CheckM a n ()-checkWitnessBindsM xx nRegion bsWits- = mapM_ (checkWitnessBindM xx nRegion bsWits) bsWits---checkWitnessBindM -        :: Ord n -        => Exp a n-        -> Bound n              -- ^ Region variable bound in the letregion.-        -> [Bind n]             -- ^ Other witness bindings in the same set.-        -> Bind  n              -- ^ The witness binding to check.-        -> CheckM a n ()--checkWitnessBindM xx uRegion bsWit bWit- = let btsWit   -        = [(typeOfBind b, b) | b <- bsWit]--       -- Check the argument of a witness type is for the region we're-       -- introducing here.-       checkWitnessArg t-        = case t of-            TVar u'-             | uRegion /= u'    -> throw $ ErrorLetRegionWitnessOther xx uRegion bWit-             | otherwise        -> return ()--            TCon (TyConBound u')-             | uRegion /= u'    -> throw $ ErrorLetRegionWitnessOther xx uRegion bWit-             | otherwise        -> return ()--            -- The parser should ensure the right of a witness is a -            -- constructor or variable.-            _ -> throw $ ErrorLetRegionWitnessInvalid xx bWit--   in  case typeOfBind bWit of-        TApp (TCon (TyConWitness TwConGlobal))  t2-         -> checkWitnessArg t2--        TApp (TCon (TyConWitness TwConConst))   t2-         | Just bConflict <- L.lookup (tMutable t2) btsWit-         -> throw $ ErrorLetRegionWitnessConflict xx bWit bConflict-         | otherwise    -> checkWitnessArg t2--        TApp (TCon (TyConWitness TwConMutable)) t2-         | Just bConflict <- L.lookup (tConst t2)   btsWit-         -> throw $ ErrorLetRegionWitnessConflict xx bWit bConflict-         | otherwise    -> checkWitnessArg t2--        TApp (TCon (TyConWitness TwConLazy))    t2-         | Just bConflict <- L.lookup (tManifest t2)  btsWit-         -> throw $ ErrorLetRegionWitnessConflict xx bWit bConflict-         | otherwise    -> checkWitnessArg t2--        TApp (TCon (TyConWitness TwConManifest))  t2-         | Just bConflict <- L.lookup (tLazy t2)    btsWit-         -> throw $ ErrorLetRegionWitnessConflict xx bWit bConflict-         | otherwise    -> checkWitnessArg t2--        _ -> throw $ ErrorLetRegionWitnessInvalid xx bWit------------------------------------------------------------------------------------- | Check a type in the exp checking monad.-checkTypeM :: (Ord n, Pretty n) -           => DataDefs n -           -> Env n -           -> Type n -           -> CheckM a n (Kind n)--checkTypeM defs kenv tt- = case T.checkType defs kenv tt of-        Left err        -> throw $ ErrorType err-        Right k         -> return k------------------------------------------------------------------------------------- | Check the type annotation of a let bound variable against the type---   inferred for the right of the binding.---   If the annotation is Bot then we just replace the annotation,---   otherwise it must match that for the right of the binding.-checkLetBindOfTypeM -        :: (Eq n, Ord n, Pretty n) -        => Exp a n -        -> DataDefs n           -- Data type definitions.-        -> Env n                -- Kind environment. -        -> Env n                -- Type environment.-        -> Type n -        -> Bind n -        -> CheckM a n (Bind n, Kind n)--checkLetBindOfTypeM xx defs kenv _tenv tRight b-        -- If the annotation is Bot then just replace it.-        | isBot (typeOfBind b)-        = do    k       <- checkTypeM defs kenv tRight-                return  ( replaceTypeOfBind tRight b -                        , k)--        -- The type of the binder must match that of the right of the binding.-        | not $ equivT (typeOfBind b) tRight-        = throw $ ErrorLetMismatch xx b tRight--        | otherwise-        = do    k       <- checkTypeM defs kenv (typeOfBind b)-                return (b, k)-
− DDC/Core/Check/CheckWitness.hs 
@@ -1,212 +0,0 @@---- | Type checker for witness expressions.-module DDC.Core.Check.CheckWitness-        ( checkWitness-        , typeOfWitness-        , typeOfWiCon-        , typeOfWbCon--        , CheckM-        , checkWitnessM)-where-import DDC.Core.DataDef-import DDC.Core.Exp-import DDC.Core.Pretty-import DDC.Core.Check.Error-import DDC.Core.Check.ErrorMessage      ()-import DDC.Type.Transform.SubstituteT-import DDC.Type.Compounds-import DDC.Type.Predicates-import DDC.Type.Equiv-import DDC.Type.Transform.LiftT-import DDC.Type.Sum                     as Sum-import DDC.Type.Env                     (Env)-import DDC.Type.Check.Monad             (result, throw)-import DDC.Base.Pretty                  ()-import qualified DDC.Type.Env           as Env-import qualified DDC.Type.Check         as T-import qualified DDC.Type.Check.Monad   as G----- | Type checker monad. ---   Used to manage type errors.-type CheckM a n   = G.CheckM (Error a n)----- 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.----checkWitness-        :: (Ord n, Pretty n)-        => DataDefs n           -- ^ Data type definitions.-        -> Env n                -- ^ Kind Environment.-        -> Env n                -- ^ Type Environment.-        -> Witness n            -- ^ Witness to check.-        -> Either (Error a n) (Type n)--checkWitness defs kenv tenv xx-        = result $ checkWitnessM defs kenv tenv 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, Pretty n) -        => DataDefs n-        -> Witness n -        -> Either (Error a n) (Type n)--typeOfWitness defs ww -        = result -        $ checkWitnessM defs Env.empty Env.empty ww------------------------------------------------------------------------------------ | Like `checkWitness` but using the `CheckM` monad to manage errors.-checkWitnessM -        :: (Ord n, Pretty n)-        => DataDefs n           -- ^ Data type definitions.-        -> Env n                -- ^ Kind environment.-        -> Env n                -- ^ Type environment.-        -> Witness n            -- ^ Witness to check.-        -> CheckM a n (Type n)--checkWitnessM _defs _kenv tenv (WVar u)- = do   let tBound      = typeOfBound u-        let mtEnv       = Env.lookup u tenv--        let mkResult-             -- When annotation on the bound is bot,-             --  then use the type from the environment.-             | Just tEnv    <- mtEnv-             , isBot tBound-             = return tEnv--             -- The bound has an explicit type annotation,-             --  which matches the one from the environment.-             -- -             --  When the bound is a deBruijn index we need to lift the-             --  annotation on the original binder through any lambdas-             --  between the binding occurrence and the use.-             | Just tEnv    <- mtEnv-             , UIx i _      <- u-             , equivT tBound (liftT (i + 1) tEnv) -             = return tBound--             -- The bound has an explicit type annotation,-             --  which matches the one from the environment.-             | Just tEnv    <- mtEnv-             , equivT tBound tEnv-             = return tEnv--             -- The bound has an explicit type annotation,-             --  which does not match the one from the environment.-             --  This shouldn't happen because the parser doesn't add non-bot-             --  annotations to bound variables.-             | Just tEnv    <- mtEnv-             = throw $ ErrorVarAnnotMismatch u tEnv--             -- Variable not in environment, so use annotation.-             --  This happens when checking open terms.-             | otherwise-             = return tBound-        -        tResult  <- mkResult-        return tResult---checkWitnessM _defs _kenv _tenv (WCon wc)- = return $ typeOfWiCon wc--  --- value-type application-checkWitnessM defs kenv tenv ww@(WApp w1 (WType t2))- = do   t1      <- checkWitnessM  defs kenv tenv w1-        k2      <- checkTypeM     defs kenv t2-        case t1 of-         TForall b11 t12-          |  typeOfBind b11 == k2-          -> return $ substituteT b11 t2 t12--          | otherwise   -> throw $ ErrorWAppMismatch ww (typeOfBind b11) k2-         _              -> throw $ ErrorWAppNotCtor  ww t1 t2---- witness-witness application-checkWitnessM defs kenv tenv ww@(WApp w1 w2)- = do   t1      <- checkWitnessM defs kenv tenv w1-        t2      <- checkWitnessM defs kenv tenv w2-        case t1 of-         TApp (TApp (TCon (TyConWitness TwConImpl)) t11) t12-          |  t11 == t2   -          -> return t12--          | otherwise   -> throw $ ErrorWAppMismatch ww t11 t2-         _              -> throw $ ErrorWAppNotCtor  ww t1 t2---- witness joining-checkWitnessM defs kenv tenv ww@(WJoin w1 w2)- = do   t1      <- checkWitnessM defs kenv tenv w1-        t2      <- checkWitnessM defs kenv tenv w2-        case (t1, t2) of-         (  TApp (TCon (TyConWitness TwConPure)) eff1-          , TApp (TCon (TyConWitness TwConPure)) eff2)-          -> return $ TApp (TCon (TyConWitness TwConPure))-                           (TSum $ Sum.fromList kEffect  [eff1, eff2])--         (  TApp (TCon (TyConWitness TwConEmpty)) clo1-          , TApp (TCon (TyConWitness TwConEmpty)) clo2)-          -> return $ TApp (TCon (TyConWitness TwConEmpty))-                           (TSum $ Sum.fromList kClosure [clo1, clo2])--         _ -> throw $ ErrorCannotJoin ww w1 t1 w2 t2---- embedded types-checkWitnessM defs kenv _tenv (WType t)- = checkTypeM defs kenv t-        ---- | Take the type of a witness constructor.-typeOfWiCon :: WiCon n -> Type n-typeOfWiCon wc- = case wc of-    WiConBuiltin wb -> typeOfWbCon wb-    WiConBound u    -> typeOfBound u----- | 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)----- checkType --------------------------------------------------------------------- | Check a type in the exp checking monad.-checkTypeM -        :: (Ord n, Pretty n) -        => DataDefs n -        -> Env n -        -> Type n -        -> CheckM a n (Kind n)--checkTypeM defs kenv tt- = case T.checkType defs kenv tt of-        Left err        -> throw $ ErrorType err-        Right k         -> return k-
+ 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,313 +1,17 @@ -- | Errors produced when checking core expressions. module DDC.Core.Check.Error-        (Error(..))+        ( Error         (..)+        , ErrorType     (..)+        , ErrorData     (..)) where-import DDC.Core.Exp-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-        -- | Found a kind error when checking a type.-        = ErrorType-        { errorTypeError        :: T.Error n }--        -- | Found a malformed expression, -        --   and we don't have a more specific diagnosis.-        | ErrorMalformedExp-        { errorChecking         :: Exp a n }--        -- | Found a malformed type,-        --   and we don't have a more specific diagnosis.-        | ErrorMalformedType-        { errorChecking         :: Exp a n-        , errorType             :: Type n }--        -- | Found a naked `XType` that wasn't the argument of an application.-        | ErrorNakedType-        { errorChecking         :: Exp a n }--        -- | Found a naked `XWitness` that wasn't the argument of an application.-        | ErrorNakedWitness-        { errorChecking         :: Exp a n }--        -- Var ---------------------------------------------        -- | A bound occurrence of a variable who's type annotation does not match-        --   the corresponding annotation in the environment.-        | ErrorVarAnnotMismatch-        { errorBound            :: Bound n-        , errorTypeEnv          :: Type n }--        -- Con ---------------------------------------------        -- | A data constructor that wasn't in the set of data definitions.-        | ErrorUndefinedCtor-        { errorChecking         :: Exp a n }--        -- Application -------------------------------------        -- | A function application where the parameter and argument don't match.-        | ErrorAppMismatch-        { errorChecking         :: Exp a n-        , errorParamType        :: Type n-        , errorArgType          :: Type n }--        -- | Tried to apply something that is not a function.-        | ErrorAppNotFun-        { errorChecking         :: Exp a n-        , errorNotFunType       :: Type n-        , errorArgType          :: Type n }---        -- Lambda ------------------------------------------        -- | A type abstraction that tries to shadow a type variable that is-        --   already in the environment.-        | ErrorLamShadow-        { errorChecking         :: Exp a n -        , errorBind             :: Bind n }--        -- | A type or witness abstraction where the body has a visible side effect.-        | ErrorLamNotPure-        { errorChecking         :: Exp a n-        , errorEffect           :: Effect n }--        -- | A value function where the parameter does not have data kind.-        | ErrorLamBindNotData-        { errorChecking         :: Exp a n -        , errorType             :: Type n-        , errorKind             :: Kind n }--        -- | An abstraction where the body does not have data kind.-        | ErrorLamBodyNotData-        { errorChecking         :: Exp a n-        , errorBind             :: Bind n-        , errorType             :: Type n-        , errorKind             :: Kind n }---        -- Let ---------------------------------------------        -- | A let-expression where the type of the binder does not match the right-        --   of the binding.-        | ErrorLetMismatch-        { 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-        { errorChecking         :: Exp a n-        , errorBind             :: Bind n-        , errorKind             :: Kind n }--        -- | A let-expression where the body does not have data kind.-        | ErrorLetBodyNotData-        { errorChecking         :: Exp a n-        , errorType             :: Type n-        , errorKind             :: Kind n }---        -- Let Lazy ----------------------------------------        -- | A lazy let binding that has a visible side effect.-        | ErrorLetLazyNotPure-        { errorChecking         :: Exp a n-        , errorBind             :: Bind n-        , errorEffect           :: Effect n }--        -- | A lazy let binding with a non-empty closure.-        | ErrorLetLazyNotEmpty-        { errorChecking         :: Exp a n-        , errorBind             :: Bind n-        , errorClosure          :: Closure n }--        -- | A lazy let binding without a witness that binding is in a lazy region.-        | ErrorLetLazyNoWitness-        { errorChecking         :: Exp a n-        , errorBind             :: Bind n-        , errorType             :: Type n }--        -- | A lazy let binding where the witness has the wrong type.-        | ErrorLetLazyWitnessTypeMismatch -        { errorChecking          :: Exp a n-        , errorBind              :: Bind n-        , errorWitnessTypeHave   :: Type n-        , errorBindType          :: Type n-        , errorWitnessTypeExpect :: Type n }---        -- Letrec ------------------------------------------        -- | A recursive let-expression where the right of the binding is not-        --   a lambda abstraction.-        | ErrorLetrecBindingNotLambda-        { errorChecking         :: Exp a n -        , errorExp              :: Exp a n }---        -- Letregion ---------------------------------------        -- | A letregion-expression where the bound variable does not have-        --   region kind.-        | ErrorLetRegionNotRegion-        { errorChecking         :: Exp a n-        , errorBind             :: Bind n-        , errorKind             :: Kind n }--        -- | A letregion-expression that tried to shadow a pre-existing named-        --   region variable.-        | ErrorLetRegionRebound-        { errorChecking         :: Exp a n-        , errorBind             :: Bind n }--        -- | A letregion-expression where the bound region variable is free in-        --  the type of the body.-        | ErrorLetRegionFree-        { errorChecking         :: Exp a n-        , errorBind             :: Bind n-        , errorType             :: Type n }--        -- | A letregion-expression that tried to create a witness with an -        --   invalid type.-        | ErrorLetRegionWitnessInvalid-        { errorChecking         :: Exp a n-        , errorBind             :: Bind n }--        -- | A letregion-expression that tried to create conflicting witnesses.-        | ErrorLetRegionWitnessConflict-        { 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.-        | ErrorLetRegionWitnessOther-        { errorChecking         :: Exp a n-        , errorBoundRegion      :: Bound n-        , errorBindWitness      :: Bind  n }--        -- | A withregion-expression where the handle does not have region kind.-        | ErrorWithRegionNotRegion-        { errorChecking         :: Exp a n-        , errorBound            :: Bound n-        , errorKind             :: Kind n }---        -- Witnesses ---------------------------------------        -- | A witness application where the argument type does not match-        --   the parameter type.-        | ErrorWAppMismatch-        { errorWitness          :: Witness n-        , errorParamType        :: Type n-        , errorArgType          :: Type n }--        -- | Tried to perform a witness application with a non-witness.-        | ErrorWAppNotCtor-        { errorWitness          :: Witness n-        , errorNotFunType       :: Type n-        , errorArgType          :: Type n }--        -- | An invalid witness join.-        | ErrorCannotJoin-        { errorWitness          :: Witness n-        , errorWitnessLeft      :: Witness n-        , errorTypeLeft         :: Type n-        , errorWitnessRight     :: Witness n-        , errorTypeRight        :: Type n }--        -- | A witness provided for a purify cast that does not witness purity.-        | ErrorWitnessNotPurity-        { errorChecking         :: Exp a n-        , errorWitness          :: Witness n-        , errorType             :: Type n }--        -- | A witness provided for a forget cast that does not witness emptiness.-        | ErrorWitnessNotEmpty-        { errorChecking         :: Exp a n-        , errorWitness          :: Witness n-        , errorType             :: Type n }---        -- Case Expressions --------------------------------        -- | A case-expression where the discriminant type is not algebraic.-        | ErrorCaseDiscrimNotAlgebraic-        { errorChecking         :: Exp a n-        , errorTypeDiscrim      :: Type n }--        -- | A case-expression where the discriminant type is not in our set-        --   of data type declarations.-        | ErrorCaseDiscrimTypeUndeclared-        { errorChecking         :: Exp a n -        , errorTypeDiscrim      :: Type n }--        -- | A case-expression with no alternatives.-        | ErrorCaseNoAlternatives-        { errorChecking         :: Exp a n }--        -- | A case-expression where the alternatives don't cover all the-        --   possible data constructors.-        | ErrorCaseNonExhaustive-        { 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-        { errorChecking         :: Exp a n }--        -- | A case-expression with overlapping alternatives.-        | ErrorCaseOverlapping-        { errorChecking         :: Exp a n }--        -- | A case-expression where one of the patterns has too many binders.-        | ErrorCaseTooManyBinders-        { errorChecking         :: Exp a n-        , errorCtorBound        :: Bound n-        , errorCtorFields       :: Int-        , errorPatternFields    :: Int }--        -- | A case-expression where the pattern types could not be instantiated-        --   with the arguments of the discriminant type.-        | ErrorCaseCannotInstantiate-        { errorChecking         :: Exp a n-        , errorTypeCtor         :: Type n-        , errorTypeDiscrim      :: Type n }--        -- | A case-expression where the type of the discriminant does not match-        --   the type of the pattern.-        | ErrorCaseDiscrimTypeMismatch-        { errorChecking         :: Exp a n-        , errorTypeDiscrim      :: Type n-        , errorTypePattern      :: Type n }+import DDC.Core.Check.Error.ErrorExp+import DDC.Core.Check.Error.ErrorExpMessage   () -        -- | A case-expression where the annotation on a pattern variable binder-        --   does not match the field type of the constructor.-        | ErrorCaseFieldTypeMismatch-        { errorChecking         :: Exp a n-        , errorTypeAnnot        :: Type n-        , errorTypeField        :: Type n }+import DDC.Core.Check.Error.ErrorType+import DDC.Core.Check.Error.ErrorTypeMessage  () -        -- | A case-expression where the result types of the alternatives are not-        --   identical.-        | ErrorCaseAltResultMismatch-        { errorChecking         :: Exp a n-        , errorAltType1         :: Type n-        , errorAltType2         :: Type n }+import DDC.Core.Check.Error.ErrorData+import DDC.Core.Check.Error.ErrorDataMessage  ()  -        -- Casts -------------------------------------------        -- | A maxeff-cast where the type provided does not have effect kind.-        | ErrorMaxeffNotEff-        { errorChecking         :: Exp a n-        , errorEffect           :: Effect n-        , errorKind             :: Kind n }--        -- | A maxclo-cast where the type provided does not have closure kind.-        | ErrorMaxcloNotClo-        { errorChecking         :: Exp a n-        , errorClosure          :: Closure n-        , errorKind             :: Kind n }--        -- | A maxclo-case where the closure provided is malformed. -        --   It can only contain `Use` terms.-        | ErrorMaxcloMalformed-        { errorChecking         :: Exp a n -        , errorClosure          :: Closure 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,350 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--- | 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---instance (Pretty n, Eq n) => Pretty (Error a n) where- ppr err-  = case err of-        ErrorType err'  -> ppr err'--        ErrorMalformedExp xx-         -> vcat [ text "Malformed expression: "        <> align (ppr xx) ]-        -        ErrorMalformedType xx tt-         -> vcat [ text "Found malformed type: "        <> ppr tt-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorNakedType xx-         -> vcat [ text "Found naked type in core program."-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorNakedWitness xx-         -> vcat [ text "Found naked witness in core program."-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        -- Variable ----------------------------------------        ErrorVarAnnotMismatch u t-         -> vcat [ text "Type mismatch in annotation."-                 , text "             Variable: "       <> ppr u-                 , text "       has annotation: "       <> (ppr $ typeOfBound u)-                 , text " which conflicts with: "       <> ppr t-                 , text "     from environment." ]---        -- Constructor -------------------------------------        ErrorUndefinedCtor xx-         -> vcat [ text "Undefined data constructor: "  <> ppr xx ]---        -- Application -------------------------------------        ErrorAppMismatch xx t1 t2-         -> vcat [ text "Type mismatch in application." -                 , text "     Function expects: "       <> ppr t1-                 , text "      but argument is: "       <> ppr t2-                 , empty-                 , text "with: "                        <> align (ppr xx) ]-         -        ErrorAppNotFun xx t1 t2-         -> vcat [ text "Cannot apply non-function"-                 , text "              of type: "       <> ppr t1-                 , text "  to argument of type: "       <> ppr t2 -                 , empty-                 , text "with: "                        <> align (ppr xx) ]---        -- Lambda ------------------------------------------        ErrorLamShadow xx b-         -> vcat [ text "Cannot shadow named spec variable."-                 , text "  binder: "                    <> ppr b-                 , text "  is already in the environment."-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLamNotPure xx eff-         -> vcat [ text "Impure type abstraction"-                 , text "           has effect: "       <> ppr eff-                 , empty-                 , text "with: "                        <> align (ppr xx) ]-                 -        -        ErrorLamBindNotData xx t1 k1-         -> vcat [ text "Function parameter does not have data kind."-                 , text "    The function parameter:"   <> ppr t1-                 , text "                  has kind: "  <> ppr k1-                 , text "            but it must be: *"-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLamBodyNotData xx b1 t2 k2-         -> vcat [ 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: *"-                 , empty-                 , text "with: "                        <> align (ppr xx) ]---        -- Let ---------------------------------------------        ErrorLetMismatch xx b t-         -> vcat [ 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 xx b k-         -> vcat [ 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: * "-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLetBodyNotData xx t k-         -> vcat [ 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: * "-                 , empty-                 , text "with: "                        <> align (ppr xx) ]---        -- Let Lazy ----------------------------------------        ErrorLetLazyNotEmpty xx b clo-         -> vcat [ text "Lazy let binding is not empty."-                 , text "      The binding for: "       <> ppr (binderOfBind b)-                 , text "          has closure: "       <> ppr clo-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLetLazyNotPure xx b eff-         -> vcat [ text "Lazy let binding is not pure."-                 , text "      The binding for: "       <> ppr (binderOfBind b)-                 , text "           has effect: "       <> ppr eff-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLetLazyNoWitness xx b t-         -> vcat [ text "Lazy let binding has no witness but the bound value may have a head region."-                 , text "      The binding for: "       <> ppr (binderOfBind b)-                 , text "             Has type: "       <> ppr t-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLetLazyWitnessTypeMismatch xx b tWitGot tBind tWitExp-         -> vcat [ text "Unexpected witness type in lazy let binding."-                 , text "          The binding for: "   <> ppr (binderOfBind b)-                 , text "    has a witness of type: "   <> ppr tWitGot-                 , text "           but is type is: "   <> ppr tBind-                 , text " so the witness should be: "   <> ppr tWitExp -                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        -- Letrec ------------------------------------------        ErrorLetrecBindingNotLambda xx x-         -> vcat [ text "Letrec can only bind lambda abstractions."-                 , text "      This is not one: "       <> ppr x-                 , empty-                 , text "with: "                        <> align (ppr xx) ]---        -- Letregion ---------------------------------------        ErrorLetRegionNotRegion xx b k-         -> vcat [ text "Letregion binder does not have region kind."-                 , text "        Region binder: "       <> ppr b-                 , text "             has kind: "       <> ppr k-                 , text "       but is must be: %" -                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLetRegionRebound xx b-         -> vcat [ text "Region variable shadows existing one."-                 , text "           Region variable: "  <> ppr b-                 , text "     is already in environment"-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLetRegionFree xx b t-         -> vcat [ text "Region variable escapes scope of letregion."-                 , text "       The region variable: "  <> ppr b-                 , text "  is free in the body type: "  <> ppr t-                 , empty-                 , text "with: "                        <> align (ppr xx) ]-        -        ErrorLetRegionWitnessInvalid xx b-         -> vcat [ text "Invalid witness type with letregion."-                 , text "          The witness: "       <> ppr b-                 , text "  cannot be created with a letregion"-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLetRegionWitnessConflict xx b1 b2-         -> vcat [ text "Conflicting witness types with letregion."-                 , text "      Witness binding: "       <> ppr b1-                 , text "       conflicts with: "       <> ppr b2 -                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorLetRegionWitnessOther xx b1 b2-         -> vcat [ text "Witness type is not for bound region."-                 , text "      letregion binds: "       <> ppr b1-                 , text "  but witness type is: "       <> ppr b2-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorWithRegionNotRegion xx u k-         -> vcat [ 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: %"-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        -- Witnesses ---------------------------------------        ErrorWAppMismatch ww t1 t2-         -> vcat [ text "Type mismatch in witness application."-                 , text "  Constructor expects: "       <> ppr t1-                 , text "      but argument is: "       <> ppr t2-                 , empty-                 , text "with: "                        <> align (ppr ww) ]--        ErrorWAppNotCtor ww t1 t2-         -> vcat [ 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 ww w1 t1 w2 t2-         -> vcat [ 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 xx w t-         -> vcat [ 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 xx w t-         -> vcat [ 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 --------------------------------        ErrorCaseDiscrimNotAlgebraic xx tDiscrim-         -> vcat [ text "Discriminant of case expression is not algebraic data."-                 , text "     Discriminant type: "      <> ppr tDiscrim-                 , empty-                 , text "with: "                        <> align (ppr xx) ]-        -        ErrorCaseDiscrimTypeUndeclared xx tDiscrim-         -> vcat [ text "Type of discriminant does not have a data declaration."-                 , text "     Discriminant type: "      <> ppr tDiscrim-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorCaseNoAlternatives xx-         -> vcat [ text "Case expression does not have any alternatives."-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorCaseNonExhaustive xx ns-         -> vcat [ text "Case alternatives are non-exhaustive."-                 , text " Constructors not matched: "   -                        <> (sep $ punctuate comma $ map ppr ns)-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorCaseNonExhaustiveLarge xx-         -> vcat [ text "Case alternatives are non-exhaustive."-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorCaseOverlapping xx-         -> vcat [ text "Case alternatives are overlapping."-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorCaseTooManyBinders xx uCtor iCtorFields iPatternFields-         -> vcat [ 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 xx tCtor tDiscrim-         -> vcat [ text "Cannot instantiate constructor type with discriminant type args."-                 , text " Either the constructor has an invalid type,"-                 , text " or the type of the discriminant does not match the type of the pattern."-                 , text "      Constructor type: "      <> ppr tCtor-                 , text "     Discriminant type: "      <> ppr tDiscrim-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorCaseDiscrimTypeMismatch xx tDiscrim tPattern-         -> vcat [ text "Discriminant type does not match result of pattern type."-                 , text "     Discriminant type: "      <> ppr tDiscrim-                 , text "          Pattern type: "      <> ppr tPattern-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorCaseFieldTypeMismatch xx tAnnot tField-         -> vcat [ 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 xx t1 t2-         -> vcat [ 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 -------------------------------------------        ErrorMaxeffNotEff xx eff k-         -> vcat [ text "Type provided for a 'maxeff' does not have effect kind."-                 , text "           Type: "             <> ppr eff-                 , text "       has kind: "             <> ppr k-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorMaxcloNotClo xx clo k-         -> vcat [ text "Type provided for a 'maxclo' does not have closure kind."-                 , text "           Type: "             <> ppr clo-                 , text "       has kind: "             <> ppr k-                 , empty-                 , text "with: "                        <> align (ppr xx) ]--        ErrorMaxcloMalformed xx clo-         -> vcat [ text "Type provided for a 'maxclo' is malformed."-                 , text "        Closure: "             <> ppr clo-                 , text " can only contain 'Use' terms."-                 , empty-                 , text "with: "                        <> align (ppr xx) ]-
+ DDC/Core/Check/Exp.hs view
@@ -0,0 +1,171 @@+-- | Type checker for the Disciple Core language.+--+--   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+--      resulting program can be checked by the standard bottom-up algorithm.+--    * Allow explicit hole '?' annotations to indicate a type or kind+--      that should be inferred.+--+module DDC.Core.Check.Exp+        ( -- * Checker configuation.+          Config (..)++          -- * Pure checking.+        , AnTEC         (..)+        , Mode          (..)+        , Demand        (..)+        , Context+        , emptyContext+        , checkExp+        , typeOfExp++          -- * Monadic checking.+        , Table         (..)+        , makeTable+        , CheckM+        , checkExpM+        , CheckTrace    (..))+where+import DDC.Core.Check.Judge.Type.VarCon+import DDC.Core.Check.Judge.Type.LamT+import DDC.Core.Check.Judge.Type.LamX+import DDC.Core.Check.Judge.Type.AppT+import DDC.Core.Check.Judge.Type.AppX+import DDC.Core.Check.Judge.Type.Let+import DDC.Core.Check.Judge.Type.LetPrivate+import DDC.Core.Check.Judge.Type.Case+import DDC.Core.Check.Judge.Type.Cast+import DDC.Core.Check.Judge.Type.Witness+import DDC.Core.Check.Judge.Type.Base+import DDC.Core.Transform.MapT+++-- Wrappers -------------------------------------------------------------------+-- | Type check an expression.+--+--   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+--   kind and type environment.+--+checkExp+        :: (Show a, Ord n, Show n, Pretty n)+        => Config n                     -- ^ Static configuration.+        -> EnvX n                       -- ^ Environment of expression.+        -> Mode n                       -- ^ Check mode.+        -> Demand                       -- ^ Demand placed on the expression.+        -> Exp a n                      -- ^ Expression to check.+        -> ( Either (Error a n)         --   Type error message.+                    ( Exp (AnTEC a n) n --   Expression with type annots+                    , Type n            --   Type of expression.+                    , Effect n)         --   Effect of expression.+           , CheckTrace)                --   Type checker debug trace.++checkExp !config !env !mode !demand !xx+ = (result, ct)+ where+  ((ct, _, _), result)+   = runCheck (mempty, 0, 0)+   $ do+        -- Check the expression, using the monadic checking function.+        (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 _ x0)+             = do t0' <- applySolved ctx t0+                  e0' <- applySolved ctx e0+                  return $ AnTEC t0' e0' (tBot kClosure) x0++        xx_solved <- mapT (applySolved ctx) xx'+        xx_annot  <- reannotateM applyToAnnot xx_solved++        -- Also apply the final context to the overall type,+        -- effect and closure of the expression.+        t'      <- applySolved ctx t+        e'      <- applySolved ctx $ TSum effs++        return  (xx_annot, t', e')+++-- | Like `checkExp`, but only return the value type of an expression.+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 !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 a, Show n, Pretty n, Ord n)+        => Table a n                    -- ^ Static config.+        -> Context n                    -- ^ Input context.+        -> Mode n                       -- ^ Check mode.+        -> 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+                , Context n)            -- Output context.++-- Dispatch to the checker table based on what sort of AST node we're at.+checkExpM !table !ctx !mode !demand !xx + = case xx of+    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 -> Table a n+makeTable config+        = Table+        { tableConfig           = config+        , tableCheckExp         = checkExpM+        , tableCheckVarCon      = checkVarCon+        , tableCheckAppT        = checkAppT+        , tableCheckAppX        = checkAppX+        , tableCheckLamT        = checkLamT+        , tableCheckLamX        = checkLamX+        , tableCheckLet         = checkLet+        , tableCheckLetPrivate  = checkLetPrivate+        , tableCheckCase        = checkCase+        , 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/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
@@ -0,0 +1,171 @@++module DDC.Core.Check.Judge.Inst+        (makeInst)+where+import DDC.Core.Check.Base+++-- | Make the left type an instantiation of the right type,+--   or throw the provided error if this is not possible.+makeInst :: (Eq n, Ord n, Pretty n)+        => Config n+        -> a+        -> Context n+        -> Type n+        -> Type n+        -> Error a n+        -> CheckM a n (Context n)++makeInst !config !a !ctx0 !tL !tR !err++ -- InstLSolve+ | Just iL <- takeExists tL+ , not $ isTExists tR+ = do   let Just ctx1   = updateExists [] iL tR ctx0++        ctrace  $ vcat+                [ text "**  InstLSolve"+                , text "    LEFT:  " <> ppr tL+                , text "    RIGHT: " <> ppr tR+                , indent 4 $ ppr ctx0+                , indent 4 $ ppr ctx1+                , empty ]++        return ctx1+++ -- InstLReach+ --  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 "**  InstLReach"+                , text "    LEFT:  " <> ppr tL+                , text "    RIGHT: " <> ppr tR+                , indent 4 $ ppr ctx0+                , indent 4 $ ppr ctx1+                , empty ]++        return ctx1++ -- InstRReach+ --  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 "**  InstRReach"+                , text "    LEFT:  " <> ppr tL+                , text "    RIGHT: " <> ppr tR+                , indent 4 $ ppr ctx0+                , indent 4 $ ppr ctx1+                , empty ]++        return ctx1+++ -- InstLArr+ --  Left is an existential, right is a function arrow.+ | Just iL              <- takeExists tL+ , Just (tR1, tR2)      <- takeTFun tR+ = do+        -- Make new existentials to match the function type and parameter.+        iL1     <- newExists kData+        let tL1 =  typeOfExists iL1++        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++        -- Substitute into tR2+        tR2'    <- applyContext ctx2 tR2++        -- Instantiate the return type.+        ctx3    <- makeInst config a ctx2 tL2 tR2' err++        ctrace  $ vcat+                [ text "**  InstLArr"+                , text "    LEFT:  " <> ppr tL+                , text "    RIGHT: " <> ppr tR+                , indent 4 $ ppr ctx0+                , indent 4 $ ppr ctx3+                , empty ]++        return ctx3+++ -- InstRSolve+ | Just iR <- takeExists tR+ , not $ isTExists tL+ = do   let Just ctx1   = updateExists [] iR tL ctx0++        ctrace  $ vcat+                [ text "**  InstRSolve"+                , text "    LEFT:  " <> ppr tL+                , text "    RIGHT: " <> ppr tR+                , indent 4 $ ppr ctx0+                , indent 4 $ ppr ctx1+                , empty ]++        return ctx1+++ -- InstRArr+ --  Left is an function arrow, and right is an existential.+ | Just (tL1, tL2)      <- takeTFun tL+ , Just iR              <- takeExists tR+ = do+        -- Make new existentials to match the function type and parameter.+        iR1     <- newExists kData+        let tR1 =  typeOfExists iR1++        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++        -- Substitute into tL2+        tL2'    <- applyContext ctx2 tL2++        -- Instantiate the return type.+        ctx3    <- makeInst config a ctx2 tL2' tR2 err++        ctrace  $ vcat+                [ text "**  InstRArr"+                , text "    LEFT:  " <> ppr tL+                , text "    RIGHT: " <> ppr tR+                , indent 4 $ ppr ctx0+                , indent 4 $ ppr ctx3+                , empty ]++        return ctx3++ -- Error+ | otherwise+ = do+        ctrace  $ vcat+                [ text "DDC.Core.Check.Exp.Inst.inst: no match"+                , text "  LEFT:  " <> ppr tL+                , text "  RIGHT: " <> ppr tR+                , indent 2 $ ppr ctx0+                , empty ]++        throw err
+ 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
@@ -0,0 +1,415 @@++module DDC.Core.Check.Judge.Sub+        (makeSub)+where+import DDC.Type.Transform.SubstituteT+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                     -- ^ 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 x0 xL tL tR err++ -- 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 "**  Sub_SynL"+                , text "    tL:  " <> ppr tL+                , text "    tL': " <> ppr tL'+                , text "    tR:  " <> ppr tR+                , empty ]++        makeSub config a ctx0 x0 xL tL' tR err+++ -- 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 "**  Sub_SynR"+                , text "    tL:  " <> ppr tL+                , text "    tR:  " <> ppr tR +                , text "    tR': " <> ppr tR+                , empty ]++        makeSub config a ctx0 x0 xL tL tR' err+++ -- 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+        ctrace  $ vcat+                [ text "**  Sub_ExVar"+                , text "    tL: " <> ppr tL+                , text "    tR: " <> ppr tR+                , text "    xL: " <> ppr xL+                , indent 4 $ ppr ctx0+                , empty ]++        return  ( xL+                , Sum.empty kEffect+                , ctx0)+++ -- SubInstL+ --   Left is an existential.+ | isTExists tL+ = do   ctx1    <- makeInst config a ctx0 tR tL err++        ctrace  $ vcat+                [ 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+                , Sum.empty kEffect+                , ctx1)+++ -- SubInstR+ --   Right is an existential.+ | isTExists tR+ = do   ctx1    <- makeInst config a ctx0 tL tR err++        ctrace  $ vcat+                [ 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+                , Sum.empty kEffect+                , ctx1)+++ -- 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+        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 "*<  Sub_Arr"+                , indent 4 $ ppr ctx0+                , indent 4 $ ppr ctx1+                , indent 4 $ ppr ctx2+                , empty ]++        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 ]++        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+        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 "*<  Sub_App"+                , indent 4 $ ppr ctx0+                , indent 4 $ ppr ctx1+                , indent 4 $ ppr ctx2+                , empty ]++        return  ( xL+                , Sum.empty kEffect+                , ctx2)+++ -- 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+        -- Make a new existential to instantiate the quantified+        -- variable and substitute it into the body.+        iA        <- newExists (typeOfBind b)+        let tA    = typeOfExists iA+        let t1'   = substituteT b tA t1++        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. 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         =  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 "*<  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 ]++        return  ( xL2+                , effs3+                , 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 ]++        -- 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 "**  Sub_Fail"+                , text "    tL: " <> ppr tL+                , text "    tR: " <> ppr tR+                , empty ]++        throw err+
+ DDC/Core/Check/Judge/Type/AppT.hs view
@@ -0,0 +1,161 @@++module DDC.Core.Check.Judge.Type.AppT+        (checkAppT)+where+import DDC.Core.Check.Judge.Type.Sub+import DDC.Core.Check.Judge.Type.Base+++-- | Check a spec application.+checkAppT :: Checker a n++checkAppT !table !ctx0 Recon demand+        xx@(XApp aApp xFn (XType aArg tArg))+ = do   +        let config      = tableConfig table++        -- Check the functional expression.+        (xFn', tFn, effsFn, ctx1)+         <- tableCheckExp table table ctx0 Recon demand xFn++        -- Check the argument.+        (tArg', kArg, ctx2)+         <- checkTypeM    config ctx1 UniverseSpec tArg Recon++        -- Determine the type of the result.+        --  The function must have a quantified type, which we then instantiate+        --  with the type argument.+        tResult+         <- case tFn of+                TForall b11 t12+                 | typeOfBind b11 == kArg+                 -> return $ substituteT b11 tArg' t12++                 | otherwise+                 ->  throw $ ErrorAppMismatch aApp xx (typeOfBind b11) tArg'++                _ -> throw $ ErrorAppNotFun   aApp xx tFn++        -- We don't need to substitute into the effect of x1 (effs1)+        -- because the body of a type abstraction is required to be pure.++        -- We don't need to substitute into the closure either, because+        -- the bound type variable is not visible outside the abstraction.+        -- 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)  (tBot kClosure) aApp+        let aArg' = AnTEC kArg    (tBot kEffect) (tBot kClosure) aArg+        let xx'   = XApp aApp' xFn' (XType aArg' tArg')++        ctrace  $ vcat+                [ text "* APP Recon"+                , text "      xx : " <+> ppr xx+                , text "      xx': " <+> ppr xx'+                , text "      tFn: " <+> ppr tFn+                , text "     tArg: " <+> ppr tArg+                , text "  tResult: " <+> ppr tResult+                , indent 2 $ ppr ctx2+                , empty ]++        returnX aApp+                (\z -> XApp z xFn' (XType aArg' tArg'))+                tResult effsFn ctx2++checkAppT !table !ctx0 (Synth {}) demand +        xx@(XApp aApp xFn (XType aArg tArg))+ = do+        -- Check the functional expression.+        (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 tFn' tArg++        -- Build an annotated version of the type application.+        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')++        ctrace  $ vcat+                [ text "* APP Synth"+                , text "      xx : " <+> ppr xx+                , text "      xx': " <+> ppr xx'+                , text "      tFn: " <+> ppr tFn+                , text "     tArg: " <+> ppr tArg+                , text "  tResult: " <+> ppr tResult+                , indent 2 $ ppr ctx2+                , empty ]++        returnX aApp+                (\z -> XApp z xFn' (XType aArg' tArg'))+                tResult effsFn ctx2+++checkAppT !table !ctx0 (Check tExpected) demand +        xx@(XApp aApp _ (XType _ _)) + =      checkSub table aApp ctx0 demand xx tExpected++checkAppT _ _ _ _ _+ = error "ddc-core.checkAppT: no match"+++-------------------------------------------------------------------------------+-- | Synthesise the type of a polymorphic function applied to its type argument.+synthAppArgT+        :: (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.+        -> Type n               -- Type of functional expression.+        -> Type n               -- Type argument.+        -> CheckM a n+                ( Type n        -- Type of result+                , Type n        -- Checked type argument.+                , Kind n        -- Kind of type argument.+                , Context n)    -- Result context++synthAppArgT table a xx ctx0 tFn tArg++ -- Rule (AppT Synth exists)+ --  Functional type is an existential.+ --+ --  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:+ --+ --    Env0[?2, ?1, ?0 = [a : ?1]. ?2] |- t2 <= ?1 -| Env1+ --   -----------------------------------------------------+ --      Env0[?0] |- ?0 * t2 => ?2 [t2/a] -| Env1+ --+ --  .. but we can't represent the (?2 [t2/a]) part. This is an inherent+ --  limitation of our type inference algorithm.+ --+ | Just _               <- takeExists tFn+ = do   throw $ ErrorAppCannotInferPolymorphic a xx+++ -- Rule (AppT Synth Forall)+ --  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++        -- The kind of the argument must match the annotation on the quantifier.+        (tArg', kArg, ctx1)+         <- checkTypeM config ctx0 UniverseSpec tArg+                (Check (typeOfBind b11))++        -- Instantiate the type of the function with the type argument.+        let tResult = substituteT b11 tArg' t12++        return (tResult, tArg', kArg, ctx1)+++ | otherwise+ = throw $ ErrorAppNotFun a xx tFn+
+ DDC/Core/Check/Judge/Type/AppX.hs view
@@ -0,0 +1,334 @@++module DDC.Core.Check.Judge.Type.AppX+        (checkAppX)+where+import DDC.Core.Check.Judge.Type.Sub+import DDC.Core.Check.Judge.Type.Base+import qualified DDC.Type.Sum   as Sum+++-------------------------------------------------------------------------------+-- | Check a value expression application.+checkAppX :: Checker a n++checkAppX !table !ctx+        Recon demand+        xx@(XApp a xFn xArg)+ = do+        -- Check the functional expression.+        (xFn',  tFn,  effsFn, ctx1)+         <- tableCheckExp table table ctx  Recon demand xFn++        -- Check the argument.+        (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)+              |  equivT (contextEnvT ctx2) tParam tArg+              -> return (tResult, effs)++              | 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]++        returnX a+                (\z -> XApp z xFn' xArg')+                tResult effsResult+                ctx2+++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, ctx1)+         <- tableCheckExp table table ctx0 mode demand xFn++        -- Substitute context into synthesised type.+        tFn' <- applyContext ctx1 tFn++        -- Synth a type for the function applied to its argument.+        (xResult, tResult, esResult, ctx2)+         <- synthAppArg table a xx+                ctx1 demand isScope+                xFn' tFn' effsFn xArg++        ctrace  $ vcat+                [ 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 ]++        return  (xResult, tResult, esResult, ctx2)+++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++        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 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.+        -> 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 application.+                , Type n             -- Type of result.+                , TypeSum n          -- Effect of result.+                , Context n)         -- Result context.++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+        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++        -- New existential for the type of the function result.+        iA2      <- newExists kData+        let tA2  = typeOfExists iA2++        -- Update the context with the new constraint.+        let Just ctx1 = updateExists [iA2, iA1] iFn (tFun tA1 tA2) ctx0++        -- Check the argument under the new context.+        (xArg', _, effsArg, ctx2)+         <- tableCheckExp table table ctx1 (Check tA1) DemandRun xArg++        -- Effect and closure of the overall function application.+        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"+                , 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  (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. 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   =  pushExistsScope iA isScope ctx0++        -- Instantiate the type of the function with the new existential.+        let tBody' =  substituteT b tA tBody++        -- Add the missing type application.+        --  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) (tBot kClosure) a+        let aArg   = AnTEC (typeOfBind b) (tBot kEffect) (tBot kClosure) a+        let xFnTy  = XApp aFn xFn (XType aArg tA)++        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.+        (xResult, tResult, esResult, ctx2)+         <- synthAppArg table a xx ctx1 demand isScope xFnTy tBody' effsFn xArg++        -- Result expression.+        ctrace  $ vcat+                [ 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  (xResult, tResult, esResult, ctx2)+++ -- Rule (App Synth Fun)+ --  Function already has a concrete function type.+ | Just (tParam, tResult)   <- takeTFun tFn+ = 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, esArg, ctx1)+         <- tableCheckExp table table ctx0 (Check tParam) DemandRun xArg++        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.+        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+             -- the current context to it as above should not change this.+             Nothing+              -> error "ddc-core.synthAppArg: unexpected type of function."+++        -- 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 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  (xExpRun, tExpRun, esExpRun, ctx1)+++ -- Applied expression is not a function.+ | otherwise+ =      throw $ ErrorAppNotFun a xx tFn+++-------------------------------------------------------------------------------+-- | Split a function-ish type into its parts.+--   This works for implications, as well as the function constructor+--   with and without a latent effect.+splitFunType :: Type n -> Maybe (Type n, Effect n, Closure n, Type n)+splitFunType tt+ = case tt of+        TApp (TApp (TCon (TyConWitness TwConImpl)) t11) t12+          -> Just (t11, tBot kEffect, tBot kClosure, t12)++        TApp (TApp (TCon (TyConSpec TcConFun)) t11) t12+          -> Just (t11, tBot kEffect, tBot kClosure, t12)++        _ -> Nothing+
+ DDC/Core/Check/Judge/Type/Base.hs view
@@ -0,0 +1,199 @@++module DDC.Core.Check.Judge.Type.Base+        ( Checker+        , Demand (..)+        , Table  (..)+        , returnX+        , runForDemand+        , isHoleT+        , checkTypeM+        , checkBindM++        , module DDC.Core.Check.Judge.Inst+        , module DDC.Core.Check.Judge.Sub+        , 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.Exp.Annot.AnTEC++        , module DDC.Type.Transform.SubstituteT+        , module DDC.Type.Transform.Instantiate+        , module DDC.Type.Transform.BoundT)+where+import DDC.Core.Check.Judge.Inst+import DDC.Core.Check.Judge.Sub+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.Exp.Annot.AnTEC++import DDC.Core.Check.Judge.Kind+import DDC.Type.Transform.SubstituteT+import DDC.Type.Transform.Instantiate+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 a, Show n, Ord n, Pretty n)+        => Table a n                    -- ^ Static configuration.+        -> Context n                    -- ^ Input context.+        -> 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.+                , Context n)            -- Output context.+++-- | Table of environment things that do not change during type checking+--+--   We've got the static config,+--    global kind and type environments,+--    and a type checking function for each node of the AST.+--+--   We split the type checker into separate functions and dispatch them+--   via this table so we can handle each AST node in a separate module,+--   while avoiding the explicit mutual recursion. If the functions were+--   explicitly mutually recursive then we'd need to write GHC boot modules,+--   which is annoying.+--+data Table a n+        = Table+        { tableConfig           :: Config n+        , tableCheckExp         :: Checker a n+        , tableCheckVarCon      :: Checker a n+        , tableCheckAppT        :: Checker a n+        , tableCheckAppX        :: Checker a n+        , tableCheckLamT        :: Checker a n+        , tableCheckLamX        :: Checker a n+        , tableCheckLet         :: Checker a n+        , tableCheckLetPrivate  :: Checker a n+        , tableCheckCase        :: 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+        => a                            -- ^ Annotation for the returned expression.+        -> (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.+        -> Context n                    -- ^ Input context.+        -> 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)+                , Context n)            -- Output context.++returnX !a !f !t !es !ctx+ = let  e       = TSum es+   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
@@ -0,0 +1,541 @@++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 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 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+        -- throw an unhelpful error if there are no alternatives.+        when (null alts)+         $ throw $ ErrorCaseNoAlternatives a xx++        -- Decide what mode to use when checking the discriminant.+        (modeDiscrim, ctx1)+         <- takeDiscrimCheckModeFromAlts table a ctx0 mode alts++        -- Check the discriminant.+        --   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.+        (mDataMode, tsArgs)+         <- case takeTyConApps tDiscrim' of+             Just (tc, ts)+              -- The unit data type.+              | TyConSpec TcConUnit         <- tc+              -> return ( Just (DataModeSmall [])+                        , [] )++              -- User defined or imported data types.+              | TyConBound (UName nTyCon) _ <- tc+              , Just dataType  <- Map.lookup nTyCon $ dataDefsTypes dataDefs+              , k              <- kindOfDataType dataType+              , takeResultKind k == kData+              -> return ( lookupModeOfDataType nTyCon dataDefs+                        , ts )++              -- Primitive data types.+              | TyConBound (UPrim nTyCon _) k <- tc+              , takeResultKind k == kData+              -> return ( lookupModeOfDataType nTyCon dataDefs+                        , ts )++             _ -> throw $ ErrorCaseScrutineeNotAlgebraic a xx tDiscrim++        -- Get the mode of the data type,+        --   this tells us how many constructors there are.+        dataMode+         <- case mDataMode of+             Nothing -> throw $ ErrorCaseScrutineeTypeUndeclared a xx tDiscrim+             Just m  -> return m++        -- If we're doing bidirectional checking then we don't infer a separate+        -- type for each alternative. Instead, pass down the same existential.+        (modeAlts, ctx3)+         <- case mode of+                Recon   -> return (mode, ctx2)+                Check{} -> return (mode, ctx2)+                Synth{}+                 -> do  iA       <- newExists kData+                        let tA   = typeOfExists iA+                        let ctx3 = pushExists iA ctx2+                        return (Check tA, ctx3)++        -- Check the alternatives.+        (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+        --   unifify against, but with Recon and Check modes we might get+        --   a different type for each alternative.+        tsAlts'         <- mapM (applyContext ctx4) tsAlts+        let tAlt : _    =  tsAlts'+        forM_ tsAlts' $ \tAlt'+         -> when (not $ equivT (contextEnvT ctx4) tAlt tAlt')+          $ throw $ ErrorCaseAltResultMismatch a xx tAlt tAlt'++        -- Check for overlapping alternatives.+        checkAltsOverlapping a xx alts++        -- Check that alternatives are exhaustive.+        checkAltsExhaustive a xx dataMode alts++        -- 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+                , indent 2 $ ppr ctx0+                , indent 2 $ ppr ctx1+                , indent 2 $ ppr ctx2+                , indent 2 $ ppr ctx4+                , empty ]++        returnX a+                (\z -> XCase z xDiscrim' alts')+                tAlt+                (Sum.fromList kEffect [effTotal])+                ctx4++checkCase _ _ _ _ _+        = error "ddc-core.checkCase: no match"+++---------------------------------------------------------------------------------------------------+-- | Decide what type checker mode to use when checking the discriminant+--   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+--   the expected type when checking the discriminant.+--+takeDiscrimCheckModeFromAlts+        :: Ord n+        => Table a n          -- ^ Checker table.+        -> a                  -- ^ Annotation for error messages.+        -> Context n          -- ^ Current context.+        -> Mode n             -- ^ Mode for checking enclosing case expression.+        -> [Alt a n]          -- ^ Alternatives in the case expression.+        -> CheckM a n+                ( Mode n+                , Context n)++takeDiscrimCheckModeFromAlts table a ctx mode alts+ | Recon        <- mode+ = return (Recon, ctx)++ | otherwise+ = do   -- Get the result type associated with each of the patterns.+        -- NOTE: We don't bother checking the result types match here.+        --       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 ctx a) pats++        case tsPats of+         -- We only have a default pattern,+         -- so will need to synthesise the type of the discrim without+         -- an expected type.+         []+          -> return (Synth [], ctx)++         -- We have at least one non-default pattern, which we can use to+         -- determine how many existentials are needed to instantiate+         -- the quantifiers of its type.+         tPat : _+          | Just (bs, tBody) <- takeTForalls tPat+          , Check tExpect    <- mode+          , Just  iExpect    <- takeExists tExpect+          -> do+                -- existentials for all of the type parameters.+                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)+++---------------------------------------------------------------------------------------------------+-- | Check some case alternatives.+checkAltsM+        :: (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.+                , Context n)++checkAltsM !table !a !xx !tDiscrim !tsArgs !mode !demand !alts0 !ctx+ = checkAltsM1 alts0 ctx++ where+  -- Whether we're doing bidirectional type inference.+  bidir+   = case mode of+        Recon   -> False+        _       -> True++  -- Check all the alternatives monadically.+  checkAltsM1 [] ctx0+   =    return ([], [], [], ctx0)++  checkAltsM1 (alt : alts) ctx0+   = do (alt',  tAlt,  eAlt, ctx1)+         <- checkAltM   alt ctx0++        (alts', tsAlts, esAlts, ctx2)+         <- checkAltsM1 alts ctx1++        return  ( alt'  : alts'+                , tAlt  : tsAlts+                , eAlt  : esAlts+                , ctx2)++  -- Check a single alternative.+  checkAltM   (AAlt PDefault xBody) !ctx0+   = do+        -- Check the right of the alternative.+        (xBody', tBody, effBody, ctx1)+                <- tableCheckExp table table ctx0 mode demand xBody++        return  ( AAlt PDefault xBody'+                , tBody+                , effBody+                , ctx1)++  checkAltM alt@(AAlt (PData dc bsArg) xBody) !ctx0+   = 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 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+         <- 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)+                = 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 (contextEnvT ctx0) tDiscrim tResult)+         $ throw $ ErrorCaseScrutineeTypeMismatch a xx+                        tDiscrim tResult++        -- There must be at least as many fields as variables in the pattern.+        -- It's ok to bind less fields than provided by the constructor.+        when (length tsFields_ctor < length bsArg)+         $ throw $ ErrorCaseTooManyBinders a xx dc+                        (length tsFields_ctor) (length bsArg)++        -- 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++        -- Extend the environment with the field types.+        let bsArg'  = zipWith replaceTypeOfBind tsFields bsArg+        let ctxArg  = pushTypes bsArg' ctx1++        -- Check the body in this new environment.+        let (ctxBody, posArg) = markContext ctxArg+        (xBody', tBody, effsBody, ctxBody')+                <- tableCheckExp table table ctxBody mode demand xBody++        tBody'  <- applyContext ctxBody' tBody++        -- Pop the argument types from the context.+        let ctx_cut     = popToPos posArg ctxBody'++        ctrace  $ vcat+                [ text "*<  Alt"+                , ppr alt+                , text "  MODE:   " <+> ppr mode+                , text "  tBody': " <+> ppr tBody'+                , ppr ctx0+                , ppr ctxBody+                , ppr ctx_cut+                , empty ]++        -- We're returning the new context for kicks,+        -- 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+                , ctx_cut)+++-- Fields -----------------------------------------------------------------------------------------+-- | Check the inferred type for a field against any annotation for it.+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+                ( [Type n]      --   Final types for each field.+                , Context n)    --   Result context.++checkFieldAnnots table bidir a xx tts ctx0+ = case tts of+        [] -> return ([], ctx0)+        (tActual, tAnnot) : tts'+           -> 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+        = return (tActual, ctx)++        -- With bidirectional checking, annotations on fields can refine the+        -- inferred type for the overall expression.+        | bidir+        = do    -- Check the type of the annotation.+                let config      = tableConfig table+                (tAnnot', _, ctx2) +                        <- checkTypeM config ctx UniverseSpec tAnnot (Synth [])++                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 (contextEnvT ctx) tActual tAnnot+        = return (tAnnot, ctx)++        -- Annotation does not match actual type.+        | 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+--   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+        => 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 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 $ contextDataDefs ctx+         -> return $ Just $ typeOfDataCtor ctor++         | otherwise+         -> throw  $ ErrorUndefinedCtor a $ XCon a dc++ctorTypeOfPat _table _ctx _a PDefault+ = return Nothing+++-- | Get the data type associated with a pattern,+--   or Nothing for the default pattern.+--+--   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+        => 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 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+                TForall b t        -> eat (bs ++ [b]) t+                TApp{}+                 |  Just (_t1, t2) <- takeTFun tt+                 -> eat bs t2+                _                  -> foldr TForall tt bs+++---------------------------------------------------------------------------------------------------+-- | Check for overlapping alternatives,+--   and throw an error in the `CheckM` monad if there are any.+checkAltsOverlapping+        :: Eq n+        => a                    -- ^ Annotation for error messages.+        -> Exp a n              -- ^ Expression for error messages.+        -> [Alt a n]            -- ^ Alternatives to check.+        -> CheckM a n ()++checkAltsOverlapping a xx alts+ = do   let pats                = [p | AAlt p _ <- alts]+        let psDefaults          = filter isPDefault pats+        let nsCtorsMatched      = mapMaybe takeCtorNameOfAlt alts++        -- Alts were overlapping because there are multiple defaults.+        when (length psDefaults > 1)+         $ throw $ ErrorCaseOverlapping a xx++        -- Alts were overlapping because the same ctor is used multiple times.+        when (length (nub nsCtorsMatched) /= length nsCtorsMatched )+         $ throw $ ErrorCaseOverlapping a xx++        -- Check for alts overlapping because a default is not last.+        -- Also check there is at least one alternative.+        case pats of+          [] -> throw $ ErrorCaseNoAlternatives a xx++          _  |  Just patsInit <- takeInit pats+             ,  or $ map isPDefault $ patsInit+             -> throw $ ErrorCaseOverlapping a xx++             |  otherwise+             -> return ()+++---------------------------------------------------------------------------------------------------+-- | Check that the alternatives are exhaustive,+--   and throw and error in the `CheckM` monad if they're not.+checkAltsExhaustive+        :: Eq n+        => a                -- ^ Annotation for error messages.+        -> Exp a n          -- ^ Expression for error messages.+        -> DataMode n       -- ^ Mode of data type.+                            --   Tells us how many data constructors to expect.+        -> [Alt a n]        -- ^ Alternatives to check.+        -> CheckM a n ()++checkAltsExhaustive a xx mode alts+ = do   let nsCtorsMatched      = mapMaybe takeCtorNameOfAlt alts++        -- Check that alternatives are exhaustive.+        case mode of++          -- Small types have some finite number of constructors.+          DataModeSmall nsCtors+           -- If there is a default alternative then we've covered all the+           -- possibiliies. We know this we've also checked for overlap.+           | any isPDefault [p | AAlt p _ <- alts]+           -> return ()++           -- Look for unmatched constructors.+           | nsCtorsMissing <- nsCtors \\ nsCtorsMatched+           , not $ null nsCtorsMissing+           -> throw $ ErrorCaseNonExhaustive a xx nsCtorsMissing++           -- All constructors were matched.+           | otherwise+           -> return ()++          -- Large types have an effectively infinite number of constructors+          -- (like integer literals), so there needs to be a default alt.+          DataModeLarge+           | any isPDefault [p | AAlt p _ <- alts] -> return ()+           | otherwise+           -> throw $ ErrorCaseNonExhaustiveLarge a xx+
+ DDC/Core/Check/Judge/Type/Cast.hs view
@@ -0,0 +1,238 @@++module DDC.Core.Check.Judge.Type.Cast+        ( 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+++checkCast :: Checker a n++-- WeakenEffect ---------------------------------------------------------------+-- Weaken the effect of an expression.+checkCast !table !ctx0 +        mode _demand+        xx@(XCast a (CastWeakenEffect eff) x1)+ = do   let config      = tableConfig  table++        -- Check the effect term.+        (eff', kEff, ctx1)+         <- checkTypeM config ctx0 UniverseSpec eff+          $ case mode of+                Recon   -> Recon+                Synth{} -> Check kEffect+                Check{} -> Check kEffect++        -- Check the body.+        (x1', t1, effs, ctx2)+         <- tableCheckExp table table ctx1 mode DemandNone x1++        -- The effect term must have Effect kind.+        when (not $ isEffectKind kEff)+         $ throw $ ErrorWeakEffNotEff a xx eff' kEff++        let c'     = CastWeakenEffect eff'+        let effs'  = Sum.insert eff' effs++        returnX a (\z -> XCast z c' x1')+                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+        mode _demand +        xx@(XCast a (CastPurify w) x1)+ = do   let config      = tableConfig table++        -- Check the witness.+        (w', tW)  <- checkWitnessM config ctx w+        let wTEC  = reannotate fromAnT w'++        -- Check the body.+        (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+                  TApp (TCon (TyConWitness TwConPure)) effMask+                    -> return $ Sum.delete effMask effs+                  _ -> throw  $ ErrorWitnessNotPurity a xx w tW++        let c'  = CastPurify wTEC+        returnX a (\z -> XCast z c' x1')+                t1 effs' ctx1+++-- Box ------------------------------------------------------------------------+-- Box a computation,+-- capturing its effects in a computation type.+checkCast !table ctx0 +        mode _demand +        xx@(XCast a CastBox x1)+ = case mode of+    Check tExpected+     -> do+        let config      = tableConfig table++        -- Check the body.+        (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).+        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'+        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) ctx2++    -- Recon and Synth mode.+    _+     -> do+        -- Check the body.+        (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_crush, t1]++        returnX a (\z -> XCast z CastBox x1')+                tS (Sum.empty kEffect) ctx1+++-- Run ------------------------------------------------------------------------+-- Run a suspended computation,+-- releasing its effects into the environment.+checkCast !table !ctx0 mode _demand+        xx@(XCast a CastRun xBody)+ = case mode of+    Recon+     -> do+        -- Check the body.+        (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+                -- this effect.+                let config      = tableConfig table+                checkEffectSupported config a xx ctx0 eff2++                returnX a+                        (\z -> XCast z CastRun xBody')+                        tResult+                        (Sum.union effs (Sum.singleton kEffect eff2))+                        ctx1++         _ -> throw $ ErrorRunNotSuspension a xx tBody++    Synth{}+     -> do+        -- Synthesize a type for the body.+        (xBody', tBody, effs, ctx1)+         <- tableCheckExp table table ctx0+                mode DemandNone xBody++        -- Run the body,+        -- which needs to have been resolved to a computation type.+        tBody'  <- applyContext ctx1 tBody+        (tResult, effsSusp, ctx2)+         <- synthRunSusp table a xx ctx1 tBody'++        returnX a+                (\z -> XCast z CastRun xBody')+                tResult+                (Sum.union effs (Sum.singleton kEffect effsSusp))+                ctx2++    Check tExpected+     -> checkSub table a ctx0 DemandNone xx tExpected++checkCast _ _ _ _ _+        = error "ddc-core.checkCast: no match"+++-------------------------------------------------------------------------------+-- | Synthesize the type of a run computation.+synthRunSusp+        :: (Show n, Ord n, Pretty n)+        => Table a n+        -> a                    -- Annot for error messages.+        -> Exp a n              -- Cast expression for error messages.+        -> Context n            -- Current context.+        -> Type n               -- Type of suspended computation.+        -> CheckM a n+                ( Type n        -- Type of result value.+                , Effect n      -- Effects unleashed by running the computation.+                , Context n)    -- Result context.++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+ -- by the context.+ | Just _iFn     <- takeExists tt+ =      throw $ ErrorRunCannotInfer a xx++ -- Rule (Run Synth Susp)+ | TApp (TApp (TCon (TyConSpec TcConSusp)) eff) tResult <- tt+ = do+        -- Check that the context has the capability to support this effect.+        let config      = tableConfig table+        checkEffectSupported config a xx ctx0 eff++        return (tResult, eff, ctx0)++ -- Run expression is not a suspension.+ | otherwise+ =      throw $ ErrorRunNotSuspension a xx tt+++-- Support --------------------------------------------------------------------+-- | Check if the provided effect is supported by the context,+--   if not then throw an error.+checkEffectSupported+        :: (Show n, Ord n)+        => Config n             -- ^ Static config.+        -> a                    -- ^ Annotation for error messages.+        -> Exp a n              -- ^ Expression for error messages.+        -> Context n            -- ^ Input context.+        -> Effect n             -- ^ Effect to check+        -> CheckM a n ()++checkEffectSupported _config a xx ctx eff+ = case effectSupported ctx eff of+        Nothing         -> return ()+        Just effBad     -> throw $ ErrorRunNotSupported a xx effBad++
+ DDC/Core/Check/Judge/Type/DaCon.hs view
@@ -0,0 +1,56 @@++module DDC.Core.Check.Judge.Type.DaCon+        (checkDaConM)+where+import DDC.Core.Check.Judge.Type.Base+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 (Type n)     -- ^ Data constructor to check.+        -> CheckM a n (Type n)++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.+    --+    -- The mode field in the data type declaration says what to expect.+    --    If the mode is 'Small' the data constructor needs to be listed,+    --    If the mode is 'Large' (like Int) there are too many to enumerate.+    --+    -- The type of the constructor needs to be attached so we can determine+    --  what data type it belongs to.+    DaConPrim { daConName        = nCtor+              , daConType        = t }+     -> let  tResult = snd $ takeTFunArgResult $ eraseTForalls t+        in case liftM fst $ takeTyConApps tResult of+            Just (TyConBound u _)+                | Just nType     <- takeNameOfBound u+                , Just dataType  <- Map.lookup nType $ dataDefsTypes $ contextDataDefs ctx+                -> case dataTypeMode dataType of+                    DataModeSmall nsCtors+                        | L.elem nCtor nsCtors -> return t+                        | otherwise            -> throw $ ErrorUndefinedCtor a xx++                    DataModeLarge   -> return t++            _ -> throw $ ErrorUndefinedCtor a xx++    -- 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 $ contextDataDefs ctx) of+         Just ctor       -> return $ typeOfDataCtor ctor+         Nothing         -> throw $ ErrorUndefinedCtor a xx+
+ DDC/Core/Check/Judge/Type/LamT.hs view
@@ -0,0 +1,256 @@++module DDC.Core.Check.Judge.Type.LamT+        (checkLamT)+where+import DDC.Core.Check.Judge.Type.Sub+import DDC.Core.Check.Judge.Type.Base+import qualified DDC.Type.Sum   as Sum+++-- Check a spec abstraction.+checkLamT :: Checker a n+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."+++-- 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 xx          = XLAM a b1 x2++        -- Check the parameter ------------------+        -- If the bound variable is named then it cannot shadow+        -- shadow others in the environment.+        when (memberKindBind b1 ctx0)+         $ throw $ ErrorLamShadow a xx b1++        -- The parameter must have an explict kind annotation.+        let kA  = typeOfBind b1+        when (isHoleT config kA)+         $ throw $ ErrorLAMParamUnannotated a xx++        -- Check the kind annotation is well-sorted.+        (kA', sA, ctxA)+         <- checkTypeM config ctx0 UniverseKind kA Recon++        let b1'         = replaceTypeOfBind kA' b1++        -- The kind annotation must have sort Comp or Prop.+        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++        -- 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 ctx5 UniverseSpec t2 Recon++        -- The type of the body must have data kind.+        when (not $ isDataKind k2)+         $ throw $ ErrorLamBodyNotData a xx b1 t2' k2++        -- The body of a spec abstraction must be pure.+        when (e2 /= Sum.empty kEffect)+         $ throw $ ErrorLamNotPure a xx UniverseSpec (TSum e2)++        -- 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'++        ctrace  $ vcat+                [ text "* LAM Recon"+                , indent 2 $ ppr (XLAM a b1' x2)+                , text "  OUT: " <> ppr tResult+                , indent 2 $ ppr ctx0+                , indent 2 $ ppr ctx_cut+                , empty ]++        returnX a+                (\z -> XLAM z b1' x2')+                tResult (Sum.empty kEffect) ctx_cut+++checkLAM !table !ctx0 a b1 x2 (Synth {})+ = do   let config      = tableConfig table+        let xx          = XLAM a b1 x2++        -- Check the parameter ------------------+        -- If the bound variable is named then it cannot shadow+        -- shadow others in the environment.+        when (memberKindBind b1 ctx0)+         $ throw $ ErrorLamShadow a xx b1++        -- If the annotation is missing then make a new existential for it.+        let kA  = typeOfBind b1+        (kA', sA, ctxA)+         <- 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 ctx0 UniverseKind kA (Synth [])++        let b1'         = replaceTypeOfBind kA' b1++        -- The kind annotation must have sort Comp or Prop.+        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++        -- 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.+        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)++        -- 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++        ctrace  $ vcat+                [ text "* LAM Synth"+                , indent 2 $ ppr (XLAM a b1' x2)+                , text "  OUT: " <> ppr tResult+                , indent 2 $ ppr ctx0+                , indent 2 $ ppr ctx_cut+                , empty ]++        returnX a+                (\z -> XLAM z b1' x2')+                tResult (Sum.empty kEffect) ctx_cut+++checkLAM !table !ctx0 a b1 x2 (Check (TForall b tBody))+ = do   let config      = tableConfig table+        let xx          = XLAM a b1 x2++        -- Check the parameter ------------------+        -- If the bound variable is named then it cannot shadow+        -- shadow others in the environment.+        when (memberKindBind b1 ctx0)+         $ throw $ ErrorLamShadow a xx b1++        -- If we have an expected kind for the parameter then it needs+        -- to be the same as any existing annotation.+        let kParam      = typeOfBind b1+        let kExpected   = typeOfBind b++        -- 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 (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 isHoleT config kExpected+              then do+                checkTypeM config ctx0 UniverseKind kParam    (Synth [])++              else do+                checkTypeM config ctx0 UniverseKind kExpected (Synth [])++        let b1' = replaceTypeOfBind kA' b1++        -- The kind annotation must have sort Comp or Prop.+        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++        -- As the names used on the spec abstraction and quantifier are+        -- probably different, we use the binder name to instantiate+        -- the expected type.+        tBody_skol+         <- case takeSubstBoundOfBind b1 of+                Nothing -> return tBody+                Just u1 -> return $ substituteT b (TVar u1) tBody++        -- 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 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)++        -- Apply context to synthesised type.+        -- 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.+        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++        ctrace  $ vcat+                [ text "* LAM"+                , indent 2 $ ppr (XLAM a b1' x2)+                , text "  OUT: " <> ppr tResult+                , indent 2 $ ppr ctx0+                , indent 2 $ ppr ctx_cut+                , empty ]++        returnX a+                (\z -> XLAM z b1' x2')+                tResult (Sum.empty kEffect) ctx_cut++checkLAM table ctx0 a b1 x2 (Check tExpected)+ = checkSub table a ctx0 DemandNone (XLAM a b1 x2) tExpected+
+ DDC/Core/Check/Judge/Type/LamX.hs view
@@ -0,0 +1,452 @@++module DDC.Core.Check.Judge.Type.LamX+        (checkLamX)+where+import DDC.Core.Check.Judge.Type.Sub+import DDC.Core.Check.Judge.Type.Base+import qualified DDC.Type.Sum   as Sum+++-- | Check a lambda abstraction.+checkLamX :: Checker a n++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."+++-- 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 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 ctx UniverseSpec t1 Recon+        let b1'         = replaceTypeOfBind t1' b1++        -- Check the body -----------------------+        -- Reconstruct a type for the body, under the extended environment.+        let (ctx', pos1) = markContext ctx+        let ctx1         = pushType b1 ctx'++        -- 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 ctx2 UniverseSpec t2 Recon+        when (not $ isDataKind k2)+         $ 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.+        (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+        ctrace  $ vcat+                [ text "*>  Lam SYNTH"+                , text "    in  bind = " <+> ppr b1+                , empty ]++        let config      = tableConfig table+        let xx          = XLam a b1 x2++        -- Check the parameter ------------------+        let t1          = typeOfBind b1++        -- If there isn't an existing annotation then make an existential.+        (b1', t1', k1, ctx1)+         <- 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+                let t1'  = typeOfExists i1+                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 ctx UniverseSpec t1 (Synth [])+                let b1' = replaceTypeOfBind t1' b1+                return (b1', t1', k1, ctx1)++        -- 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,+        -- 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.+        --   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).+        --   We know \x. can't bind a witness here.+        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#). ()"+        k1'     <- applyContext ctx5 k1+        (k1'', ctx6)+         <- if isTExists k1'+             then do+                ctx6    <- makeEqT config ctx5 k1' kData+                        $  ErrorMismatch a     k1' kData xx++                k1''    <- applyContext ctx6 k1'++                return (k1'', ctx6)++             else do+                return (k1', ctx5)++        -- 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.+        (xAbs', tAbs)+         <- makeFunction +                config a (XLam a b1' x2)+                b1' t1' k1''+                x2' t2' e2_crush++        ctrace  $ vcat+                [ text "*<  Lam SYNTH"+                , text "    in  bind = " <+> ppr b1+                , text "    out type = " <+> ppr tAbs+                , indent 4 $ ppr ctx+                , indent 4 $ ppr ctx_cut+                , empty ]++        return  ( xAbs'+                , tAbs+                , Sum.empty kEffect+                , ctx_cut)+++-- When checking type type of a lambda abstraction against an existing+--   functional type we allow the formal paramter to be missing its+--   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   +        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 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    <- 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'++        -- 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).+        --   We know \x. can't bind a witness here.+        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 ctx3 UniverseSpec t1' (Synth [])+        k1'             <- applyContext ctx3 k1+        (k1'', ctx4)+         <- if isTExists k1'+             then do+                ctx4    <- makeEqT config ctx3 k1' kData+                        $  ErrorMismatch a     k1' kData xx++                k1''    <- applyContext ctx4 k1'++                return (k1'', ctx4)++             else do+                return (k1', ctx3)+++        -- 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.+        (xAbs', tAbs)+         <- makeFunction+                config a (XLam a b1' x2)+                b1' t1' k1'' +                x2' t2  e2+++        -- 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 ]++        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)+ = do   ctrace  $ vcat+                [ text "*>  Lam Check (not function)" ]++        checkSub table a ctx DemandNone (XLam a b1 x2) tExpected+++-------------------------------------------------------------------------------+-- | 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.+--+--   For data abstractions, the way the effect and closure is handled+--   is set by the Config, which depends on the specific language fragment+--   that we're checking.+--+makeFunction+        :: (Show n, Ord 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)++makeFunction config a xx bParam tParam kParam xBody tBody eBody+ | isTExists kParam+ = throw $ ErrorLamBindBadKind a xx tParam kParam++ | not (kParam == kData) && not (kParam == kWitness)+ = throw $ ErrorLamBindBadKind a xx tParam kParam++ | otherwise+ = do+        -- Get the universe the parameter value belongs to.+        let Just uniParam    = universeFromType2 kParam++        -- 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 eBody++        -- Data abstraction where the function constructor for the language+        -- fragment does not suport latent effects or closures.+        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 (  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)++        -- 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++                -- 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
@@ -0,0 +1,500 @@++module DDC.Core.Check.Judge.Type.Let+        (checkLet)+where+import DDC.Core.Check.Judge.Type.Base+import qualified DDC.Type.Sum   as Sum+import Data.List                as L+++---------------------------------------------------------------------------------------------------+checkLet :: Checker a n++-- let --------------------------------------------+checkLet !table !ctx0 mode demand xx@(XLet a lts xBody)+ | case lts of+        LLet{}  -> True+        LRec{}  -> True+        _       -> False++ = 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+                = case mode of+                        Recon   -> False+                        Check{} -> True+                        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.+        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.+        (tBodyChecked, kBody, ctx3)+         <- checkTypeM config ctx2 UniverseSpec tBody+         $  case mode of+                Recon   -> Recon+                _       -> Check kData++        kBody' <- applyContext ctx3 kBody+        when (not $ isDataKind kBody')+         $ throw $ ErrorLetBodyNotData a xx tBody kBody'++        tBody' <- applyContext ctx3 tBodyChecked++        -- 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 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 " <> 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' 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"+++---------------------------------------------------------------------------------------------------+-- | Check some let bindings,+--   and push their binders onto the context.+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.+                , Pos                   --   Context position with bindings pushed.+                , Context n)            --   Output context.++checkLetsM !bidir xx !table !ctx0 !demand (LLet b xBind)++ -- Reconstruct the type of a non-recursive let-binding.+ | False  <- bidir+ = do+        let config      = tableConfig table+        let a           = annotOfExp xx++        -- Reconstruct the type of the binding.+        (xBind', tBind, effsBind, ctx1)+         <- tableCheckExp table table ctx0 Recon demand xBind++        -- The kind of the binding must be Data.+        (_, 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 (contextEnvT ctx0) (typeOfBind b) tBind+                then return ()+                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++        -- Push the binder on the context.+        let (ctx2, pos1) =  markContext ctx1+        let ctx3         =  pushType b' ctx2++        return  ( LLet b' xBind'+                , [b']+                , 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+        let config      = tableConfig 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+        (mode, ctx1)+         <- if isBot tAnnot+             -- There is no annotation on the binder.+             then return (Synth [], ctx0)++             -- Check the type annotation on the binder,+             -- expecting the kind to be Data.+             else do+                (tAnnot', _kAnnot, ctx1)+                 <- 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_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 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_run+                , [b']+                , effs_run+                , pos1, ctx4)+++-- letrec ---------------------------------------+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 table a xx xs++        -- 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 demand (zip bs' xs)++        let (bs'', xsRight')+                = unzip results++        return  ( LRec (zip bs'' xsRight')+                , bs''+                , Sum.empty kEffect+                , pos1, ctx4)+++-- others ---------------------------------------+-- The dispatcher should only call checkLet with LLet and LRec AST nodes,+-- so we should not see the others here.+checkLetsM _ _ _ _ _ _+        = error "ddc-core.checkLetsM: no match"+++---------------------------------------------------------------------------------------------------+-- | Check the annotations on a group of recursive binders.+checkRecBinds+        :: (Pretty n, Show n, Ord n)+        => Table a n+        -> Bool                         -- ^ Use bidirectional checking.+        -> a                            -- ^ Annotation for error messages.+        -> Exp a n                      -- ^ Expression for error messages.+        -> Context n                    -- ^ Original context.+        -> [Bind n]                     -- ^ Input binding group.+        -> CheckM a n+                ( [Bind n]              --   Result binding group.+                ,  Context n)           --   Output context.++checkRecBinds table bidir a xx ctx0 bs0+ = go bs0 ctx0+ where+        go [] ctx+         = return ([], ctx)++        go (b : bs) ctx+         = do   (b', ctx')      <- checkRecBind b ctx+                (moar, ctx'')   <- go bs ctx'+                return (b' : moar, ctx'')++        config  = tableConfig  table++        checkRecBind b ctx+         = case bidir of+            False+             -> 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 ctx UniverseSpec b Recon++                -- The type on the binder must have kind Data.+                when (not $ isDataKind k)+                 $ throw $ ErrorLetBindingNotData a xx b' k++                return (b', ctx')++            True+             -- Recursive let-binding is missing a type annotation,+             -- so make a new existential.+             | isBot (typeOfBind b)+             -> do i        <- newExists kData+                   let t    = typeOfExists i+                   let ctx' = pushExists i ctx+                   let b'   = replaceTypeOfBind t b+                   return (b', ctx')++             -- Recursive let-binding has a type annotation,+             -- so check it, expecting it to have kind Data.+             | otherwise+             -> do+                (b0, _k, ctx1)+                 <- checkBindM config ctx UniverseSpec b (Check kData)++                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+        :: (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+                ( [ ( Bind n                   -- Result bindiner.+                    , Exp (AnTEC a n) n)]      -- Result expression.+                , Context n)++checkRecBindExps table False a ctx0 demand bxs0+ = go bxs0 ctx0+ where+        go [] ctx+         = return ([], ctx)++        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.+                (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 (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++                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 ]++                -- 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.+                (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++                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.+checkNoDuplicateBindings+        :: Eq n+        => a                    -- ^ Annotation for error messages.+        -> Exp a n              -- ^ Expression for error messages.+        -> [Bind n]             -- ^ List of bindings to check.+        -> CheckM a n ()++checkNoDuplicateBindings a xx bs+ = case duplicates $ filter isBName bs of+        []    -> return ()+        b : _ -> throw $ ErrorLetrecRebound a xx b+++-- | Take elements of a list that have more than once occurrence.+duplicates :: Eq a => [a] -> [a]+duplicates []           = []+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+        :: 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 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
@@ -0,0 +1,246 @@++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.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 mode demand+        xx@(XLet a (LPrivate bsRgn mtParent bsWit) x)++ = case takeSubstBoundsOfBinds bsRgn of+    []   -> tableCheckExp table table ctx Recon demand x++    us   -> do+        let config      = tableConfig 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', _, _)+         <- liftM unzip3+         $  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)+         $ throw $ ErrorLetRegionsNotRegion a xx bsRgn ksRgn++        -- We can't shadow region binders because we might have witnesses+        -- in the environment that conflict with the ones created here.+        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', _, _)+         <- liftM unzip3+         $  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 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, ctx4)+          <- tableCheckExp table table ctx3 (Synth []) demand x++        -- The body type must have data kind.+        (tBody4, kBody4, ctx5)+          <- checkTypeM config ctx4 UniverseSpec tBody3+          $  case mode of+                Recon   -> Recon+                _       -> Check kData++        tBody5      <- applyContext ctx5 tBody4+        kBody5      <- applyContext ctx5 kBody4+        TSum effs5  <- applyContext ctx5 (TSum effs3)+        when (not $ isDataKind kBody5)+         $ throw $ ErrorLetBodyNotData a xx tBody5 kBody5++        -- The final body type.+        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+                -- private/extend construct ends.+                Just tParent+                 -> do  return $ foldl  (\t b -> substituteTX b tParent t)+                                        tBody5 bsRgn++                -- 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.+                _+                 -> do  let fvsT         = freeT Env.empty tBody5+                        when (any (flip Set.member fvsT) us)+                         $ 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+                -- the parent.+                Just tParent+                  -> return $ (lowerT depth $ foldl delEff effs5 us)+                           `Sum.union` (Sum.singleton kEffect (tAlloc tParent))++                -- 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++        -- 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 ctx6++        returnX a+                (\z -> XLet z (LPrivate bsRgn mtParent bsWit) xBody3)+                tBody_final' effs_cut ctx_cut+++checkLetPrivate _ _ _ _ _+        = error "ddc-core.checkLetPrivate: no match"+++-------------------------------------------------------------------------------+-- | Check the set of witness bindings bound in a letregion for conflicts.+checkWitnessBindsM+        :: (Show n, Ord n)+        => Config n             -- ^ Type checker config.+        -> a                    -- ^ Annotation for error messages.+        -> 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 !ctx !xx !uRegions !bsWit+ = mapM_ checkWitnessBindM  bsWit+ where+        -- Check if some type variable or constructor is already in the+        -- environment. NOTE: The constructor case is for region handles+        -- when using the Eval fragment.+        inEnv tt+         = case tt of+             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+             -> throw $ ErrorLetRegionsWitnessOther a xx uRegions bWit+             | otherwise -> return ()++            TCon (TyConBound u' _)+             | all (/= u') uRegions+             -> throw $ ErrorLetRegionsWitnessOther a xx uRegions bWit+             | otherwise -> return ()++            -- 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 TwConConst))    t2+             | Just bConflict <- L.lookup (tMutable t2) btsWit+             -> throw $ ErrorLetRegionWitnessConflict a xx bWit bConflict+             | otherwise    -> checkWitnessArg bWit t2++            TApp (TCon (TyConWitness TwConMutable))  t2+             | Just bConflict <- L.lookup (tConst 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+             | t1 /= t2  -> mapM_ (checkWitnessArg bWit) [t1, t2]+             | otherwise -> throw $ ErrorLetRegionWitnessInvalid a xx bWit++            (takeTyConApps -> Just (TyConWitness (TwConDistinct _), ts))+             -> mapM_ (checkWitnessArg bWit) ts++            TApp (TCon (TyConSpec TcConRead))  t2+             | configEffectCapabilities config+             -> checkWitnessArg bWit t2++            TApp (TCon (TyConSpec TcConWrite)) t2+             | configEffectCapabilities config+             -> checkWitnessArg bWit t2++            TApp (TCon (TyConSpec TcConAlloc)) t2+             | configEffectCapabilities config+             -> checkWitnessArg bWit t2++            _ -> throw $ ErrorLetRegionWitnessInvalid a xx bWit+++
+ DDC/Core/Check/Judge/Type/Sub.hs view
@@ -0,0 +1,168 @@++module DDC.Core.Check.Judge.Type.Sub+        (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 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.+        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 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+                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
@@ -0,0 +1,144 @@++module DDC.Core.Check.Judge.Type.VarCon+        (checkVarCon)+where+import DDC.Core.Check.Judge.Type.DaCon+import DDC.Core.Check.Judge.Type.Sub+import DDC.Core.Check.Judge.Type.Base+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 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 demand xx tExpect++        _ -> do ctrace  $ vcat+                        [ 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)+                        ctx++ -- Look in the global environment.+ | 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 demand xx tExpect++        _ -> do ctrace  $ vcat+                        [ text "**  Var Global"+                        , indent 4 $ ppr xx+                        , text "    tVar: " <> ppr t+                        , indent 4 $ ppr ctx+                        , empty ]++                returnX a+                        (\z -> XVar z u)+                        t+                        (Sum.empty kEffect)+                        ctx++ -- Can't find this variable name in the environment.+ | otherwise+ = throw $ ErrorUndefinedVar a u UniverseData+++-- constructors ---------------------------------+-- Recon or Synth the type of a constructor.+checkVarCon !table !ctx mode@Recon _demand xx@(XCon a dc) + = do   let config      = tableConfig table++        -- Lookup the type of the constructor from the environment.+        tCtor           <- checkDaConType config ctx a dc++        ctrace  $ vcat+                [ text "**  Con"+                , text "    MODE: " <> ppr mode+                , indent 4 $ ppr xx+                , text "    tCon: " <> ppr tCtor+                , indent 4 $ ppr ctx+                , empty ]++        -- Type of the data constructor.+        returnX a+                (\z -> XCon z dc)+                tCtor+                (Sum.empty kEffect)+                ctx+++-- 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"+                , text "    MODE: " <> ppr mode+                , indent 4 $ ppr xx+                , text "    tCon: " <> ppr tCtor+                , indent 4 $ ppr ctx+                , empty ]++        -- Type of the data constructor.+        returnX a+                (\z -> XCon z dc)+                tCtor+                (Sum.empty kEffect)+                ctx+++-- others ---------------------------------------+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
@@ -0,0 +1,26 @@++module DDC.Core.Check.Judge.Type.Witness+        (checkWit)+where+import DDC.Core.Check.Judge.Witness+import DDC.Core.Check.Judge.Type.Base+import qualified DDC.Type.Sum           as Sum+++checkWit :: Checker a n+checkWit !table !ctx _mode _demand +        (XWitness a w1)+ = do   let config      = tableConfig table++        -- Check the witness.+        (w1', t1)       <- checkWitnessM config ctx w1+        let w1TEC = reannotate fromAnT w1'++        returnX a+                (\z -> XWitness z w1TEC)+                t1+                (Sum.empty kEffect)+                ctx++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/TaggedClosure.hs 
@@ -1,223 +0,0 @@--module DDC.Core.Check.TaggedClosure-        ( TaggedClosure(..)-        , closureOfTagged-        , closureOfTaggedSet-        , taggedClosureOfValBound-        , taggedClosureOfTyArg-        , taggedClosureOfWeakClo-        , maskFromTaggedSet-        , cutTaggedClosureX-        , cutTaggedClosureXs-        , cutTaggedClosureT)-where-import DDC.Type.Transform.LowerT-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 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 LowerT TaggedClosure where- lowerAtDepthT n d cc-  = let down = lowerAtDepthT n 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))----- | 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) -        => Bound n  -> TaggedClosure n--taggedClosureOfValBound u-        = GBoundVal u -        $ Sum.singleton kClosure -        $ (let clo = tDeepUse $ typeOfBound u-           in  fromMaybe clo (trimClosure clo))----- | Yield the tagged closure of a type argument.-taggedClosureOfTyArg -        :: (Ord n, Pretty n) -        => Type n -> Set (TaggedClosure n)--taggedClosureOfTyArg tt- = case tt of-        TVar u-         |   isRegionKind (typeOfBound u)-         ->  Set.singleton $ GBoundRgnVar u--        TCon (TyConBound u)-         |   isRegionKind (typeOfBound u)-         ->  Set.singleton $ GBoundRgnCon u--        _ -> 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 $ GBoundRgnVar 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))) 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/Collect.hs view
@@ -1,253 +1,25 @@  -- | Collecting sets of variables and constructors. module DDC.Core.Collect-        ( freeT+        ( -- * Free Variables+          freeT,        freeVarsT         , freeX-        , collectBound-        , collectSpecBinds)-where-import DDC.Type.Compounds-import DDC.Core.Exp-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----- 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- = case tt of-        BindDef way bs ts-         |  BoundExpWit <- boundLevelOfBindWay way-         ,  tenv'       <- Env.extends bs tenv-         -> Set.unions $ map (freeOfTreeX tenv') ts--        BindDef _ _ ts-         -> Set.unions $ map (freeOfTreeX  tenv) ts--        BindUse BoundExpWit u-         | Env.member u tenv -> 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 binders in a thing.-collectSpecBinds :: (BindStruct c, Ord n) => c n -> [Bind n]-collectSpecBinds -        = concatMap collectSpecBindsOfTree . slurpBindTree-        --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--        _ -> []------------------------------------------------------------------------------------- | 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)-        deriving (Eq, Show)----- | Describes how a variable was bound.-data BindWay-        = BindForall-        | BindLAM-        | BindLam-        | BindLet-        | BindLetRec-        | BindLetRegion-        | BindLetRegionWith-        | BindCasePat-        deriving (Eq, Show)----- | What level this binder is at.-data BoundLevel-        = BoundSpec-        | BoundExpWit-        deriving (Eq, Show)----- | Get the `BoundLevel` corresponding to a `BindWay`.-boundLevelOfBindWay :: BindWay -> BoundLevel-boundLevelOfBindWay way- = case way of-        BindForall              -> BoundSpec-        BindLAM                 -> BoundSpec-        BindLam                 -> BoundExpWit-        BindLet                 -> BoundExpWit-        BindLetRec              -> BoundExpWit-        BindLetRegion           -> BoundSpec-        BindLetRegionWith       -> BoundExpWit-        BindCasePat             -> BoundExpWit----- 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    -> [BindCon BoundSpec u]-        _               -> []---instance BindStruct (Exp a) where- slurpBindTree xx-  = case xx of-        XVar _ u        -> [BindUse BoundExpWit u]-        XCon _ u        -> [BindCon BoundExpWit u]-        XApp _ x1 x2    -> slurpBindTree x1 ++ slurpBindTree x2-        XLAM _ b x      -> [bindDefT BindLAM [b] [x]]-        XLam _ b x      -> [bindDefX BindLam [b] [x]]      --        XLet _ (LLet m b x1) x2-         -> slurpBindTree m-         ++ slurpBindTree x1-         ++ [bindDefX BindLet [b] [x2]]--        XLet _ (LRec bxs) x2-         -> [bindDefX BindLetRec -                     (map fst bxs) -                     (map snd bxs ++ [x2])]-        -        XLet _ (LLetRegion b bs) x2-         -> [ BindDef  BindLetRegion [b]-             [bindDefX BindLetRegionWith bs [x2]]]--        XLet _ (LWithRegion u) x2-         -> BindUse BoundExpWit 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 LetMode where- slurpBindTree mm-  = case mm of-        LetLazy (Just w) -> slurpBindTree w-        _                -> []---instance BindStruct Cast where- slurpBindTree cc-  = case cc of-        CastWeakenEffect eff    -> slurpBindTree eff-        CastWeakenClosure clo   -> slurpBindTree clo-        CastPurify w            -> slurpBindTree w-        CastForget w            -> slurpBindTree w---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 where- slurpBindTree ww-  = case ww of-        WVar u          -> [BindUse BoundExpWit 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----- | 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+          -- * Bounds and Binds+        , collectBound+        , collectBinds +          -- * Abstract Binding Structures+        , BindTree      (..)+        , BindWay       (..)+        , BoundLevel    (..)+        , BindStruct    (..) +          -- * Support+        , Support       (..)+        , SupportX      (..))+where+import DDC.Core.Collect.FreeX+import DDC.Core.Collect.FreeT+import DDC.Core.Collect.BindStruct+import DDC.Core.Collect.Support
+ 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/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
@@ -0,0 +1,221 @@++module DDC.Core.Collect.Support+        ( Support       (..)+        , SupportX      (..)+        , supportEnvFlags)+where+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.Maybe+import Data.Monoid              ((<>))++---------------------------------------------------------------------------------------------------+data Support n+        = Support+        { -- | Type constructors used in the expression.+          supportTyCon          :: Set (Bound n)++          -- | Type constructors used in the argument of a value-type application.+        , supportTyConXArg      :: Set (Bound n)++          -- | Free spec variables in an expression.+        , supportSpVar          :: Set (Bound n)++          -- | Type constructors used in the argument of a value-type application.+        , supportSpVarXArg      :: Set (Bound n)++          -- | Free witness variables in an expression.+          --   (from the Witness universe)+        , supportWiVar          :: Set (Bound n)++          -- | Free value variables in an expression.+          --   (from the Data universe)+        , supportDaVar          :: Set (Bound n) }+        deriving Show+++instance Ord n => Monoid (Support n) where+ mempty = Support+        { supportTyCon          = Set.empty+        , supportTyConXArg      = Set.empty+        , supportSpVar          = Set.empty+        , supportSpVarXArg      = Set.empty+        , supportWiVar          = Set.empty+        , supportDaVar          = Set.empty }++ mappend sp1 sp2+        = Support+        { supportTyCon          = Set.unions [supportTyCon sp1,     supportTyCon sp2]+        , supportTyConXArg      = Set.unions [supportTyConXArg sp1, supportTyConXArg sp2]+        , supportSpVar          = Set.unions [supportSpVar sp1,     supportSpVar sp2]+        , supportSpVarXArg      = Set.unions [supportSpVarXArg sp1, supportSpVarXArg sp2]+        , supportWiVar          = Set.unions [supportWiVar sp1,     supportWiVar sp2]+        , 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+        => KindEnv n -> TypeEnv n+        -> c n+        -> Support n+++instance SupportX Type where+ support kenv _tenv t+  = let (fvs1, tcs)     = freeVarConT kenv t+    in  mempty  { supportTyCon  = tcs+                , supportSpVar  = fvs1 }+++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+ support kenv tenv xx+  = case xx of+        XVar _ u        +         | Env.member u tenv    -> mempty+         | otherwise            -> mempty { supportDaVar = Set.singleton u}++        XCon{}                  +         -> mempty++        XLAM _ b x+         -> support kenv tenv b +         <> support (Env.extend b kenv) tenv x++        XLam _ b x+         -> support kenv tenv b+         <> support kenv (Env.extend b tenv) x++        XApp _ x1 x2+         -> let s1              = support kenv tenv x1 +                s2              = support kenv tenv x2+            in  mappend s1 s2++        XLet _a lts x2+         -> let s1              = support kenv tenv lts+                (bs1, bs0)      = bindsOfLets lts+                kenv'           = Env.extends bs1 kenv+                tenv'           = Env.extends bs0 tenv+                s2              = support kenv' tenv' x2+            in  mappend s1 s2++        XCase _ x1 alts+         -> let s1              = support kenv tenv x1+                ss              = mconcat $ map (support kenv tenv) alts+            in  mappend s1 ss++        XCast _ c1 x2+         -> let s1              = support kenv tenv c1+                s2              = support kenv tenv x2+            in  mappend s1 s2++        XType _ t +         -> let sup = support kenv tenv t+            in  sup { supportTyConXArg  = supportTyCon sup+                    , supportSpVarXArg  = supportSpVar sup }++        XWitness _ w    -> support kenv tenv w+++instance SupportX (Alt a) where+ support kenv tenv aa+  = case aa of+        AAlt PDefault x+         -> support kenv tenv x++        AAlt (PData _dc bs0) x+         -> let tenv'   = Env.extends bs0 tenv+            in  support kenv tenv' x+++instance SupportX (Witness a) where+ support kenv tenv ww+  = case ww of+        WVar _ u+         | Env.member u tenv    -> mempty+         | otherwise            -> mempty { supportWiVar = Set.singleton u }++        WCon{}+         -> mempty++        WApp _ w1 w2+         -> support kenv tenv w1+         <> support kenv tenv w2++        WType _ t+         -> support kenv tenv t+++instance SupportX (Cast a) where+ support kenv tenv cc+  = case cc of+        CastWeakenEffect eff+         -> support kenv tenv eff++        CastPurify w+         -> support kenv tenv w++        CastBox+         -> mempty++        CastRun+         -> mempty+         ++instance SupportX (Lets a) where+ support kenv tenv lts+  = case lts of+        LLet b x+         -> support kenv tenv b+         <> support kenv (Env.extend b tenv) x++        LRec bxs+         -> (mconcat $ map (support kenv tenv) $ map fst bxs)+         <> (let tenv' = Env.extends (map fst bxs) tenv+             in  mconcat $ map (support kenv tenv') $ map snd bxs)++        LPrivate bs t2 ws+         -> (mconcat $ map (support kenv tenv) bs)+         <> (mconcat $ map (support kenv tenv) $ maybeToList t2)+         <> (let kenv' = Env.extends bs kenv+             in  mconcat $ map (support kenv' tenv) ws)+++instance SupportX Bind where+ support kenv tenv b+  = support kenv tenv +  $ typeOfBind b++
− DDC/Core/Compounds.hs 
@@ -1,172 +0,0 @@---- | Utilities for constructing and destructing compound expressions.-module DDC.Core.Compounds -        ( -- * Lets-          bindsOfLets-        , specBindsOfLets-        , valwitBindsOfLets--          -- * Patterns-        , bindsOfPat--          -- * Lambdas-        , makeXLAMs, takeXLAMs-        , makeXLams, takeXLams-        , takeXLamFlags-        , makeXLamFlags--          -- * Applications-        , makeXApps-        , takeXApps-        , takeXConApps-        , takeXPrimApps--          -- * Alternatives-        , takeCtorNameOfAlt)-where-import DDC.Type.Compounds-import DDC.Core.Exp----- | Take the binds of a `Lets`.-bindsOfLets :: Lets a n -> [Bind n]-bindsOfLets ll- = case ll of-        LLet _ b _        -> [b]-        LRec bxs          -> map fst bxs-        LLetRegion   b bs -> b : bs-        LWithRegion{}     -> []----- | Like `bindsOfLets` but only take the type binders.-specBindsOfLets :: Lets a n -> [Bind n]-specBindsOfLets ll- = case ll of-        LLet _ _ _       -> []-        LRec _           -> []-        LLetRegion b _   -> [b]-        LWithRegion{}    -> []----- | Like `bindsOfLets` but only take the value and witness binders.-valwitBindsOfLets :: Lets a n -> [Bind n]-valwitBindsOfLets ll- = case ll of-        LLet _ b _       -> [b]-        LRec bxs         -> map fst bxs-        LLetRegion _ bs  -> bs-        LWithRegion{}    -> []----- | Take the binds of a `Pat`.-bindsOfPat :: Pat n -> [Bind n]-bindsOfPat pp- = case pp of-        PDefault          -> []-        PData _ bs        -> bs----- Lambdas ------------------------------------------------------------------------ | Make some nested type lambda abstractions.-makeXLAMs :: a -> [Bind n] -> Exp a n -> Exp a n-makeXLAMs a bs x-        = foldr (XLAM a) x (reverse bs)----- | Split nested value and 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 value or witness lambda abstractions.-makeXLams :: a -> [Bind n] -> Exp a n -> Exp a n-makeXLams a bs x-        = foldr (XLam a) x (reverse bs)----- | 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)----- | 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)----- | 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----- Applications ------------------------------------------------------------------ | Build sequence of type applications.-makeXApps   :: a -> Exp a n -> [Exp a n] -> Exp a n-makeXApps a t1 ts     = foldl (XApp a) t1 ts----- | Flatten an application into the function parts and arguments, if any.-takeXApps   :: Exp a n -> [Exp a n]-takeXApps xx- = case xx of-        XApp _ x1 x2    -> takeXApps 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 takeXApps 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 (Bound n, [Exp a n])-takeXConApps xx- = case takeXApps xx of-        XCon _ u : xs   -> Just (u, xs)-        _               -> Nothing----- 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 u _) _      -> takeNameOfBound u-        _                       -> Nothing---
− DDC/Core/DataDef.hs 
@@ -1,135 +0,0 @@---- | Algebraic data type definitions.-module DDC.Core.DataDef-        ( DataDef    (..)--        -- * Data type definition table-        , DataDefs   (..)-        , DataMode   (..)-        , DataType   (..)-        , DataCtor   (..)--        , emptyDataDefs-        , insertDataDef-        , fromListDataDefs-        , lookupModeOfDataType)-where-import DDC.Type.Exp-import Data.Map                 (Map)-import qualified Data.Map       as Map-import Data.Maybe-import Control.Monad----- | The definition of a single data type.-data DataDef n-        = DataDef-        { -- | Name of the data type.-          dataDefTypeName       :: n--          -- | Kinds of type parameters.-        , dataDefParamKinds     :: [Kind n]--          -- | Constructors of the data type, or Nothing if there are-          --   too many to list (like with `Int`).-        , dataDefCtors          :: Maybe [(n, [Type n])] }------ DataDefs ---------------------------------------------------------------------- | A table of data type definitions,---   unpacked into type and data constructors so we can find them easily.-data DataDefs n-        = DataDefs-        { dataDefsTypes :: Map n (DataType n)-        , dataDefsCtors :: Map n (DataCtor n) }----- | The mode of a data type records how many data constructors there are.---   This can be set to 'Large' for large primitive types like Int and Float.---   In this case we don't ever expect them all to be enumerated---   as case alternatives.-data DataMode n-        = DataModeSmall [n]-        | DataModeLarge----- | Describes a data type constructor, used in the `DataDefs` table.-data DataType n-        = DataType -        { -- | Name of data type constructor.-          dataTypeName       :: n--          -- | Kinds of type parameters to constructor.-        , dataTypeParamKinds :: [Kind n]--          -- | Names of data constructors of this data type,-          --   or `Nothing` if it has infinitely many constructors.-        , dataTypeMode       :: DataMode n }----- | Describes a data constructor, used in the `DataDefs` table.-data DataCtor n-        = DataCtor-        { -- | Name of data constructor.-          dataCtorName       :: n--          -- | Field types of constructor.-        , dataCtorFieldTypes :: [Type n]--          -- | Name of result type of constructor.-        , dataCtorTypeName   :: n }------ | An empty table of data type definitions.-emptyDataDefs :: DataDefs n-emptyDataDefs-        = DataDefs-        { dataDefsTypes = Map.empty-        , dataDefsCtors = Map.empty }----- | Insert a data type definition into some DataDefs.-insertDataDef  :: Ord n => DataDef  n -> DataDefs n -> DataDefs n-insertDataDef (DataDef nType ks mCtors) dataDefs- = let  defType = DataType-                { dataTypeName       = nType-                , dataTypeParamKinds = ks-                , dataTypeMode       = defMode }--        defMode = case mCtors of-                   Nothing    -> DataModeLarge-                   Just ctors -> DataModeSmall (map fst ctors)--        makeDefCtor (nCtor, tsFields)-                = DataCtor-                { dataCtorName       = nCtor-                , dataCtorFieldTypes = tsFields-                , dataCtorTypeName   = nType }--        defCtors = case mCtors of-                    Nothing  -> Nothing-                    Just cs  -> Just $ map makeDefCtor cs--   in   dataDefs-         { dataDefsTypes = Map.insert nType defType (dataDefsTypes dataDefs)-         , dataDefsCtors = Map.union (dataDefsCtors dataDefs)-                         $ Map.fromList [(n, def) | def@(DataCtor n _ _) -                                          <- concat $ maybeToList defCtors] }----- | Build a `DataDefs` table from a list of `DataDef`-fromListDataDefs :: Ord n => [DataDef n] -> DataDefs n-fromListDataDefs defs-        = foldr insertDataDef emptyDataDefs defs------ | Yield the list of data constructor names for some data type, ---   or `Nothing` for large types with too many constructors to list.-lookupModeOfDataType :: Ord n => n -> DataDefs n -> Maybe (DataMode n)-lookupModeOfDataType n defs-        = liftM dataTypeMode $ Map.lookup n (dataDefsTypes defs)--
+ 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,198 +1,6 @@  -- | Abstract syntax for the Disciple core language. module DDC.Core.Exp -        ( module DDC.Type.Exp--          -- * Computation expressions-        , Exp     (..)-        , Cast    (..)-        , Lets    (..)-        , LetMode (..)-        , Alt     (..)-        , Pat     (..)-                        -          -- * Witnesses expressions-        , Witness (..)-        , WiCon   (..)-        , WbCon   (..))+        ( module DDC.Core.Exp.Annot.Exp ) where-import DDC.Type.Exp-import DDC.Type.Sum             ()----- Values ------------------------------------------------------------------------ | Well-typed expressions live in the Data universe, and their types always---   have kind '*'. --- ---   Expressions do something useful at runtime, and might diverge or cause---   side effects.-data Exp a n-        -- | Value variable   or primitive operation.-        = XVar  a  (Bound n)--        -- | Data constructor or literal.-        | XCon  a  (Bound 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 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 n)-        deriving (Eq, Show)----- | Type casts.-data Cast n-        -- | Weaken the effect of an expression.-        = CastWeakenEffect  (Effect n)-        -        -- | Weaken the closure of an expression.-        | CastWeakenClosure (Closure n)--        -- | Purify the effect of an expression.-        | CastPurify (Witness n)--        -- | Hide sharing of the closure of an expression.-        | CastForget (Witness n)-        deriving (Eq, Show)----- | Possibly recursive bindings.-data Lets a n-        -- | Non-recursive expression binding.-        = LLet    (LetMode n) (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.-        | LLetRegion  (Bind n) [Bind n]-        -        -- | Holds a region handle during evaluation.-        | LWithRegion (Bound n)-        deriving (Eq, Show)----- | Describes how a let binding should be evaluated.-data LetMode n-        -- | Evaluate binding before substituting the result.-        = LetStrict--        -- | Use lazy evaluation. -        --   The witness shows that the head region of the bound expression-        --   can contain thunks (is lazy), or Nothing if there is no head region.-        | LetLazy (Maybe (Witness n))-        deriving (Eq, Show)----- | Case alternatives.-data Alt a n-        = AAlt (Pat n) (Exp a n)-        deriving (Eq, Show)----- | Pattern matching.-data Pat n-        -- | The default pattern always succeeds.-        = PDefault-        -        -- | Match a data constructor and bind its arguments.-        | PData (Bound n) [Bind n]-        deriving (Eq, Show)-        ---- Witness ----------------------------------------------------------------------- | When a witness exists in the program it guarantees that a---   certain property of the program is true.-data Witness n-        -- | Witness variable.-        = WVar  (Bound n)-        -        -- | Witness constructor.-        | WCon  (WiCon n)-        -        -- | Witness application.-        | WApp  (Witness n) (Witness n)--        -- | Joining of witnesses.-        | WJoin (Witness n) (Witness n)--        -- | Type can appear as the argument of an application.-        | WType (Type n)-        deriving (Eq, Show)----- | 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.-        | WiConBound (Bound n)-        deriving (Eq, Show)----- | 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-        deriving (Eq, Show)-+import DDC.Core.Exp.Annot.Exp
+ DDC/Core/Exp/Annot.hs view
@@ -0,0 +1,123 @@++module DDC.Core.Exp.Annot+        ( +         ---------------------------------------+         -- * Abstract Syntax+          module DDC.Type.Exp++         -- ** Expressions+        , Exp           (..)+        , Lets          (..)+        , Alt           (..)+        , Pat           (..)+        , Cast          (..)++          -- ** Witnesses+        , Witness       (..)++          -- ** Data Constructors+        , DaCon         (..)++          -- ** Witness Constructors+        , WiCon         (..)++          ---------------------------------------+          -- * 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++          ---------------------------------------+          -- * 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.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
@@ -0,0 +1,74 @@++module DDC.Core.Exp.DaCon +        ( DaCon (..)++        -- * Compounds+        , dcUnit+        , takeNameOfDaCon+        , takeTypeOfDaCon)+where+import DDC.Type.Exp.Simple+import Control.DeepSeq+++-- | Data constructors.+data DaCon n t+        -- | Baked in unit data constructor.+        = DaConUnit++        -- | Primitive data constructor used for literals and baked-in+        --   constructors. +        --+        --   The type of the constructor needs to be attached to handle the+        --   case where there are too many constructors in the data type to list, +        --   like for Int literals. In this case we determine what data type+        --   it belongs to from the attached type of the data constructor.+        --   +        | DaConPrim+        { -- | Name of the data constructor.+          daConName     :: !n ++          -- | Type of the data constructor.+        , daConType     :: !t+        }++        -- | Data constructor that has a data type declaration.+        | DaConBound+        { -- | Name of the data constructor.+          daConName     :: !n+        }+        deriving (Show, Eq)+++instance (NFData n, NFData t) => NFData (DaCon n t) where+ rnf !dc+  = case dc of+        DaConUnit       -> ()+        DaConPrim  n t  -> rnf n `seq` rnf t+        DaConBound n    -> rnf n+++-- | Take the name of data constructor,+--   if there is one.+takeNameOfDaCon :: DaCon n t -> Maybe n+takeNameOfDaCon dc+ = case dc of+        DaConUnit       -> Nothing+        DaConPrim{}     -> Just $ daConName dc+        DaConBound{}    -> Just $ daConName dc+++-- | Take the type annotation of a data constructor,+--   if we know it locally.+takeTypeOfDaCon :: DaCon n (Type n) -> Maybe (Type n)+takeTypeOfDaCon dc  + = case dc of+        DaConUnit       -> Just $ tUnit+        DaConPrim{}     -> Just $ daConType dc+        DaConBound{}    -> Nothing+++-- | The unit data constructor.+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/WiCon.hs view
@@ -0,0 +1,27 @@++module DDC.Core.Exp.WiCon+        ( WiCon  (..))+where+import DDC.Type.Exp+import DDC.Type.Sum     ()+import Control.DeepSeq+++-- | Witness constructors.+data WiCon n+        -- | 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)+++-- NFData ---------------------------------------------------------------------+instance NFData n => NFData (WiCon n) where+ rnf wi+  = case wi of+        WiConBound   u t        -> rnf u `seq` rnf t++++
+ DDC/Core/Fragment.hs view
@@ -0,0 +1,76 @@++-- | 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 Tetra@ and @Disciple Core Salt@.+module DDC.Core.Fragment+        ( -- * Langauge fragments+          Fragment      (..)+        , mapProfileOfFragment++        , Profile       (..)+        , mapFeaturesOfProfile+        , zeroProfile++          -- * Fragment features+        , Feature       (..)+        , Features      (..)+        , zeroFeatures+        , setFeature++        -- * Compliance+        , complies+        , compliesWithEnvs+        , Complies+        , Error         (..))+where+import DDC.Core.Fragment.Feature+import DDC.Core.Fragment.Compliance+import DDC.Core.Fragment.Error+import DDC.Core.Fragment.Profile+import DDC.Core.Module+import DDC.Core.Exp+import DDC.Core.Lexer+++-- | Carries all the information we need to work on a particular +--   fragment of the Disciple Core language.+data Fragment n (err :: * -> *)+        = Fragment+        { -- | Language profile for this fragment.+          fragmentProfile       :: Profile n++          -- | File extension to use when dumping modules in this fragment.+        , fragmentExtension     :: String++          -- | Read a name.+        , fragmentReadName      :: String -> Maybe n+        +          -- | Lex module source into tokens,+          --   given the source name and starting line number. +        , fragmentLexModule     :: String -> Int -> String -> [Located (Token n)]++          -- | Lex expression source into tokens,+          --   given the source name and starting line number.+        , fragmentLexExp        :: String -> Int -> String -> [Located (Token n)]++          -- | Perform language fragment specific checks on a module.+        , fragmentCheckModule   :: forall a. Module a n -> Maybe (err a)++          -- | Perform language fragment specific checks on an expression.+        , fragmentCheckExp      :: forall a. Exp a n    -> Maybe (err a) }+++instance Show (Fragment n err) where+ 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
@@ -0,0 +1,381 @@++module DDC.Core.Fragment.Compliance+        ( complies+        , compliesWithEnvs+        , Complies)+where+import DDC.Core.Fragment.Feature+import DDC.Core.Fragment.Profile+import DDC.Core.Fragment.Error+import DDC.Core.Module+import DDC.Core.Exp.Annot+import Control.Monad+import Data.Maybe+import DDC.Type.Env                     (Env)+import Data.Set                         (Set)+import qualified DDC.Type.Env           as Env+import qualified Data.Set               as Set+++-- | Check whether a core thing complies with a language fragment profile.+complies +        :: (Ord n, Show n, Complies c)+        => Profile n            -- ^ Fragment profile giving the supported+                                --   language features and primitive operators.+        -> c a n                -- ^ The thing to check.+        -> Maybe (Error a n)++complies profile thing+ = compliesWithEnvs profile+        (profilePrimKinds profile)+        (profilePrimTypes profile)+        thing+++-- | Like `complies` but with some starting environments.+compliesWithEnvs+        :: (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)++compliesWithEnvs profile kenv tenv thing+ = let  merr    = result +                $ compliesX profile +                        kenv tenv+                        contextTop thing+   in   case merr of+         Left err -> Just err+         Right _  -> Nothing++++-- Complies -------------------------------------------------------------------+-- | Class of things we can check language fragment compliance for.+class Complies (c :: * -> * -> *) where+ -- Check compliance of a well typed term with a language profile.+ -- If it is not well typed then this can return a bad result.+ compliesX+        :: (Ord n, Show n)+        => Profile n            -- ^ Fragment profile giving the supported+                                --   language features and primitive operators.+        -> Env n                -- ^ Starting Kind environment.+        -> Env n                -- ^ Starting Type environment.+        -> Context+        -> c a n +        -> CheckM a n+                (Set n, Set n)  -- Used type and value names.+++instance Complies Module where+ compliesX profile kenv tenv context mm+  = do  let bs          = [ BName n (typeOfImportValue isrc) +                                | (n, isrc) <- moduleImportValues mm ]+        let tenv'       = Env.extends bs tenv+        compliesX profile kenv tenv' context (moduleBody mm)+++-- We'll mark type vars that only appear in types of binders as unused.+instance Complies Exp where+ compliesX profile kenv tenv context xx+  = let has f   = f $ profileFeatures profile+        ok      = return (Set.empty, Set.empty)+    in case xx of++        -- variables ----------------------------+        XVar _ u@(UName n)+         |  not $ Env.member u tenv+         ,  not $ has featuresUnboundLevel0Vars +         -> throw $ ErrorUndefinedVar n++         |  args        <- fromMaybe 0 $ contextFunArgs context+         ,  Just t      <- Env.lookup u tenv+         ,  arity       <- arityOfType t+         ,  args >= 1 && args < arity+         ,  not $ has featuresPartialApplication+         -> throw $ ErrorUnsupported PartialApplication++         | otherwise+         ->     return (Set.empty, Set.singleton n)++        XVar _ u@(UPrim n t)+         |  not $ Env.member u (profilePrimTypes profile)+         -> throw $ ErrorUndefinedPrim n++         |  args        <- fromMaybe 0 $ contextFunArgs context+         ,  arity       <- arityOfType t+         ,  args < arity+         ,  not $ has featuresPartialPrims+         -> throw $ ErrorUnsupported PartialPrims++         | otherwise+         -> return (Set.empty, Set.empty)++        XVar{}          -> ok++        -- constructors -------------------------+        XCon{}          -> ok++        -- spec binders -------------------------+        XLAM _ b x+         | contextAbsBody context+         , not $ has featuresNestedFunctions+         -> throw $ ErrorUnsupported NestedFunctions++         | otherwise+         -> do  +                -- If the body isn't another lambda then remember+                -- that we've entered into a function.+                let context'+                     | isXLAM x || isXLam x = context+                     | otherwise            = setBody context++                (tUsed, vUsed)  <- compliesX profile +                                        (Env.extend b kenv) tenv +                                        context' x++                tUsed'          <- checkBind profile kenv b tUsed+                return (tUsed', vUsed)++        -- value and witness abstraction --------+        XLam _ b x+         | contextAbsBody context+         , not $ has featuresNestedFunctions+         -> throw $ ErrorUnsupported NestedFunctions++         | otherwise+         -> do  +                -- If the body isn't another lambda then remember+                -- that we've entered into a function.+                let context'+                     | isXLAM x || isXLam x = context+                     | otherwise            = setBody context++                (tUsed, vUsed)  <- compliesX profile +                                        kenv (Env.extend b tenv)+                                        context' x++                vUsed'          <- checkBind profile tenv b vUsed+                return (tUsed, vUsed')+       +        -- application --------------------------+        XApp _ x1 (XType _ t2)+         | profileTypeIsUnboxed profile t2+         , Nothing      <- takeXPrimApps xx+         -> throw $ ErrorUnsupported UnboxedInstantiation++         | otherwise+         -> do  checkFunction profile x1+                compliesX     profile kenv tenv (addArg context) x1++        XApp _ x1 XWitness{}+         -> do  checkFunction profile x1+                compliesX     profile kenv tenv (addArg context) x1++        XApp _ x1 x2+         -> do  checkFunction profile x1+                (tUsed1, vUsed1) <- compliesX profile kenv tenv (addArg context) x1+                (tUsed2, vUsed2) <- compliesX profile kenv tenv context x2+                return  ( Set.union tUsed1 tUsed2+                        , Set.union vUsed1 vUsed2)++        -- let ----------------------------------+        XLet _ (LLet b1 x1) x2+         -> do  let tenv'        = Env.extend b1 tenv+                (tUsed1, vUsed1) <- compliesX profile kenv tenv  (reset context) x1+                (tUsed2, vUsed2) <- compliesX profile kenv tenv' (reset context) x2+                vUsed2'          <- checkBind profile tenv b1 vUsed2++                return  ( Set.union tUsed1 tUsed2+                        , Set.union vUsed1 vUsed2')++        XLet _ (LRec bxs) x2+         -> do  let (bs, xs)    = unzip bxs+                let tenv'       = Env.extends bs tenv++                (tUseds1, vUseds1) +                 <- liftM unzip+                 $  mapM (compliesX profile kenv tenv' (reset context)) +                         xs++                (tUsed2,  vUsed2) <- compliesX profile kenv tenv' (reset context) x2+                let tUseds        = Set.unions (tUsed2 : tUseds1)+                let vUseds        = Set.unions (vUsed2 : vUseds1)++                vUseds'           <- checkBinds profile tenv bs vUseds+                return (tUseds, vUseds')++        XLet _ (LPrivate rs _ bs) x2+         -> do  (tUsed2, vUsed2) +                 <- compliesX profile   (Env.extends rs  kenv) +                                        (Env.extends bs tenv) +                                        (reset context) x2+                return (tUsed2, vUsed2)++        -- case ---------------------------------+        XCase _ x1 alts+         -> do  (tUsed1,  vUsed1)  +                 <- compliesX profile kenv tenv (reset context) x1++                (tUseds2, vUseds2) <- liftM unzip +                                   $  mapM (compliesX profile kenv tenv (reset context)) alts++                return  ( Set.unions $ tUsed1 : tUseds2+                        , Set.unions $ vUsed1 : vUseds2)+++        -- cast ---------------------------------+        XCast _ _ x     -> compliesX profile kenv tenv (reset context) x++        -- type and witness ---------------------+        XType    _ t    -> throw $ ErrorNakedType    t+        XWitness _ w    -> throw $ ErrorNakedWitness w+++instance Complies Alt where+ compliesX profile kenv tenv context aa+  = case aa of+        AAlt PDefault x+         -> do  (tUsed1, vUsed1)  <- compliesX profile kenv tenv +                                        (reset context) x+                return  (tUsed1, vUsed1)++        AAlt (PData _ bs) x+         -> do  (tUsed1, vUsed1) <- compliesX profile kenv (Env.extends bs tenv) +                                        (reset context) x+                vUsed1'          <- checkBinds profile tenv bs vUsed1 +                return (tUsed1, vUsed1')+++-- Bind -----------------------------------------------------------------------+-- | Check for compliance violations at a binding site.+checkBind +        :: Ord n +        => Profile n            -- ^ The current language profile.+        -> Env n                -- ^ The current environment+        -> Bind n               -- ^ The binder at this site.+        -> Set n                -- ^ Names used under the binder.+        -> CheckM a n (Set n)   -- ^ Names used above the binder.++checkBind profile env bb used+ = let has f   = f $ profileFeatures profile+   in case bb of+        BName n _+         | not $ Set.member n used+         , not $ has featuresUnusedBindings +         -> throw $ ErrorUnusedBind n++         | Env.memberBind bb env+         , not $ has featuresNameShadowing +         -> throw $ ErrorShadowedBind n++         | otherwise+         -> return $ Set.delete n used++        BAnon{}+         | not $ has featuresDebruijnBinders+         -> throw $ ErrorUnsupported DebruijnBinders++        _ -> return used+++-- | Check for compliance violations at a binding site.+--   The binders must all be at the same level.+checkBinds +        :: Ord n  +        => Profile n +        -> Env n  -> [Bind n] -> Set n +        -> CheckM a n (Set n)++checkBinds profile env bs used+ = case bs of+        []              -> return used+        (b : bs')        +         -> do  used'   <- checkBinds profile env bs' used+                checkBind profile env b used'+++-- Function -------------------------------------------------------------------+-- | Check the function part of an application.+checkFunction :: Profile n -> Exp a n -> CheckM a n ()+checkFunction profile xx + = let  has f   = f $ profileFeatures profile+        ok       = return ()+   in case xx of+        XVar{}  -> ok+        XCon{}  -> ok+        XApp{}  -> ok+        XCast{} -> ok+        _+         | has featuresGeneralApplication -> return ()+         | otherwise    -> throw $ ErrorUnsupported GeneralApplication+++-- Context --------------------------------------------------------------------+data Context+        = Context+        { contextAbsBody        :: Bool +        , contextFunArgs        :: Maybe Int }+        deriving (Eq, Show)+++-- | The top level context, used at the top-level scope of a module.+contextTop :: Context+contextTop+        = Context+        { contextAbsBody        = False+        , contextFunArgs        = Nothing }+++-- | Record that we've entered into an abstraction body.+setBody :: Context -> Context+setBody context = context { contextAbsBody = True }+++-- | Record that the expression is being directly applied to an argument.+addArg  :: Context -> Context+addArg context+ = case contextFunArgs context of+        Nothing         -> context { contextFunArgs = Just 1 }+        Just args       -> context { contextFunArgs = Just (args + 1) }+++-- | Reset the argument counter of a context.+reset   :: Context -> Context+reset context   = context { contextFunArgs = Nothing } +++-- Monad ----------------------------------------------------------------------+-- | Compliance checking monad.+data CheckM a n x+        = CheckM (Either (Error a n) x)+++instance Functor (CheckM s err) where+ fmap   = liftM+++instance Applicative (CheckM s err) where+ (<*>)  = ap+ pure   = return+++instance Monad (CheckM a n) where+ return x   = CheckM (Right x)+ (>>=) m f  +  = case m of+          CheckM (Left err)     -> CheckM (Left err)+          CheckM (Right x)      -> f x+++-- | Throw an error in the monad.+throw :: Error a n -> CheckM a n x+throw e       = CheckM $ Left e+++-- | Take the result from a check monad.+result :: CheckM a n x -> Either (Error a n) x+result (CheckM r)       = r
+ DDC/Core/Fragment/Error.hs view
@@ -0,0 +1,59 @@++module DDC.Core.Fragment.Error+        (Error(..))+where+import DDC.Core.Fragment.Feature+import DDC.Core.Exp+import DDC.Core.Pretty+++-- | Language fragment compliance violations.+data Error a n+        -- | Found an unsupported language feature.+        = ErrorUnsupported      !Feature++        -- | Found an undefined primitive operator.+        | ErrorUndefinedPrim    !n ++        -- | Found an unbound variable.+        | ErrorUndefinedVar     !n++        -- | Found a variable binder that shadows another one at a higher scope,+        --   but the profile doesn't permit this.+        | ErrorShadowedBind     !n++        -- | Found a bound variable with no uses,+        --   but the profile doesn't permit this.+        | ErrorUnusedBind       !n++        -- | Found a naked type that isn't used as a function argument.+        | ErrorNakedType        !(Type    n)++        -- | Found a naked witness that isn't used as a function argument.+        | ErrorNakedWitness     !(Witness a n)+        deriving Show+++instance (Pretty n, Eq n) => Pretty (Error a n) where+ ppr err+  = case err of+        ErrorUnsupported feature+         -> vcat [ text "Unsupported feature: " <> text (show feature) ]++        ErrorUndefinedPrim n+         -> vcat [ text "Undefined primitive: " <> ppr n ]++        ErrorUndefinedVar n+         -> vcat [ text "Undefined variable: " <> ppr n ]++        ErrorShadowedBind n+         -> vcat [ text "Binding shadows existing name: " <> ppr n ]++        ErrorUnusedBind n+         -> vcat [ text "Bound name is not used: " <> ppr n ]++        ErrorNakedType t+         -> vcat [ text "Naked type is not a function argument: " <> ppr t]++        ErrorNakedWitness w+         -> vcat [ text "Naked witness is not a function argument: " <> ppr w ]
+ DDC/Core/Fragment/Feature.hs view
@@ -0,0 +1,76 @@++module DDC.Core.Fragment.Feature+        (Feature(..))+where+++-- | Language feature supported by a fragment.+data Feature+        -- Type system features ---------------------------+        -- | Track effect type information.+        = TrackedEffects++        -- | Track closure type information.+        | TrackedClosures++        -- | Attach latent effects to function types.+        | FunctionalEffects++        -- | Attach latent closures to function types.+        | FunctionalClosures++        -- | 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++        -- | Partially applied functions+        | PartialApplication++        -- | Function application where the thing being applied+        --   is not a variable.+        --   Most backend languages (like LLVM) don't support this.+        | GeneralApplication++        -- | Nested function bindings.+        --   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.+        | DebruijnBinders++        -- | Allow data and witness vars without binding occurrences if+        --   they are annotated directly with their types. This lets+        --   us work with open terms.+        | UnboundLevel0Vars++        -- | Allow non-primitive functions to be instantiated at unboxed types.+        --   Our existing backends can't handle this, because boxed and unboxed+        --   objects have different representations.+        | UnboxedInstantiation++        -- Sanity -----------------------------------------+        -- | Allow name shadowing.+        | NameShadowing++        -- | Allow unused named data and witness bindings.+        | UnusedBindings++        -- | Allow unused named matches.+        | UnusedMatches+        deriving (Eq, Ord, Show)+
+ DDC/Core/Fragment/Profile.hs view
@@ -0,0 +1,149 @@++-- | 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+++-- | The fragment profile describes the language features and +--   primitive operators available in the language.+data Profile n+        = Profile+        { -- | The name of this profile.+          profileName                   :: !String++          -- | Permitted language features.+        , profileFeatures               :: !Features++          -- | Primitive data type declarations.+        , profilePrimDataDefs           :: !(DataDefs n)++          -- | Kinds of primitive types.+        , profilePrimKinds              :: !(KindEnv n)++          -- | Types of primitive operators.+        , profilePrimTypes              :: !(TypeEnv n)++          -- | Check whether a type is an unboxed type.+          --   Some fragments limit how these can be used.+        , profileTypeIsUnboxed          :: !(Type n -> Bool) ++          -- | Check whether some name represents a hole that needs+          --   to be filled in by the type checker.+        , 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.+zeroProfile :: Profile n+zeroProfile+        = Profile+        { profileName                   = "Zero"+        , profileFeatures               = zeroFeatures+        , profilePrimDataDefs           = emptyDataDefs+        , profilePrimKinds              = Env.empty+        , profilePrimTypes              = Env.empty+        , profileTypeIsUnboxed          = const False +        , profileNameIsHole             = Nothing +        , profileMakeLiteralName        = Nothing }+++-- | A flattened set of features, for easy lookup.+data Features +        = Features+        { featuresTrackedEffects        :: Bool+        , featuresTrackedClosures       :: Bool+        , 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+        , featuresNameShadowing         :: Bool+        , featuresUnusedBindings        :: Bool+        , featuresUnusedMatches         :: Bool+        }+++-- | An emtpy feature set, with all flags set to `False`.+zeroFeatures :: Features+zeroFeatures+        = Features+        { featuresTrackedEffects        = False+        , featuresTrackedClosures       = False+        , 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+        , featuresNameShadowing         = False+        , featuresUnusedBindings        = False+        , featuresUnusedMatches         = False }+++-- | Set a language `Flag` in the `Profile`.+setFeature :: Feature -> Bool -> Features -> Features+setFeature feature val features+ = case feature of+        TrackedEffects          -> features { featuresTrackedEffects       = val }+        TrackedClosures         -> features { featuresTrackedClosures      = val }+        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 }+        NameShadowing           -> features { featuresNameShadowing        = val }+        UnusedBindings          -> features { featuresUnusedBindings       = val }+        UnusedMatches           -> features { featuresUnusedMatches        = val }+
+ DDC/Core/Lexer.hs view
@@ -0,0 +1,192 @@++-- | Reference lexer for core langauge parser. Slow but Simple.+--+--   The lexers here all use 'String' in place of a real name type.+--   After applying these functions to the program text, we need+--   to use `renameTok` tok convert the strings in `TokNamed` tokens+--   into the name type specific to the langauge fragment to be parsed.+--+module DDC.Core.Lexer+        ( module DDC.Core.Lexer.Tokens+        , 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.Tokens+import DDC.Data.SourcePos+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 -----------------------------------------------------------------------------------------+-- | Lex a module and apply the offside rule.+--+--   Automatically drop comments from the token stream along the way.+--+lexModuleWithOffside +        :: FilePath     -- ^ Path to source file, for error messages.+        -> Int          -- ^ Starting line number.+        -> String       -- ^ String containing program text.+        -> [Located (Token String)]++lexModuleWithOffside sourceName lineStart str+ = applyOffside [] []+        $ addStarts+        $ 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 --------------------------------------------------------------------------------------------+-- | Lex a string into tokens.+--+--   Automatically drop comments from the token stream along the way.+--+lexExp  :: FilePath     -- ^ Path to source file, for error messages.+        -> Int          -- ^ Starting line number.+        -> String       -- ^ String containing program text.+        -> [Located (Token String)]++lexExp 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 ----------------------------------------------------------------------------------------+-- 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)]++lexText filePath nStart txt+ = let  (toks, locEnd, strLeftover)+         = System.unsafePerformIO+         $ I.scanListIO+                (I.Location nStart 1)+                 I.bumpLocationWithChar+                (Text.unpack txt)+                (scanner filePath)++        I.Location lineEnd colEnd = locEnd+        spEnd   = SourcePos filePath lineEnd colEnd++   in   case strLeftover of+         []     -> toks+         str    -> toks ++ [Located spEnd (KErrorJunk (take 10 str))]+++-- | Scanner for core tokens tokens.+type Scanner a+        = I.Scanner IO I.Location [Char] a+++-------------------------------------------------------------------------------+-- | 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))++scanner fileName+ = let+        stamp   :: (I.Location, a) -> Located a+        stamp (I.Location line col, token)+         = Located (SourcePos fileName line col) token+        {-# INLINE stamp #-}++        stamp'  :: (a -> b)+                -> (I.Location, a) -> Located b+        stamp' k (I.Location line col, token) +          = Located (SourcePos fileName line col) (k token)+        {-# INLINE stamp' #-}++   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)++          -- 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++          -- deBruijn indices.+          --   Needs to come before scanSymbol as '^' is also an operator.+        , fmap (stamp' (KA . KIndex))   $ scanIndex++          -- Literal values.+        , fmap (stamp' (\(l, b) -> KA (KLiteral l b)))+           $ scanLiteral++          -- Infix operators.+          --   Needs to come before scanSymbol because operators +          --   like "==" are parsed atomically rather than as+          --   two separate '=' symbols.+        , fmap (stamp' (KA . KOp))      $ scanInfixOperator ++          -- Prefix operators.+        , fmap (stamp' (KA . KOpVar))   $ scanPrefixOperator++          -- 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)++          -- Symbolic tokens like punctuation.+        , fmap (stamp' (KA . KSymbol))  $ scanSymbol++          -- 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/Offside.hs view
@@ -0,0 +1,434 @@++-- | Apply the offside rule to a token stream to add braces.+module DDC.Core.Lexer.Offside+        ( Lexeme        (..)+        , applyOffside+        , addStarts)+where+import DDC.Core.Lexer.Tokens+import DDC.Data.SourcePos+++---------------------------------------------------------------------------------------------------+-- | Holds a real token or start symbol which is used to apply the offside rule.+data Lexeme n+        = LexemeToken           (Located (Token n))+        | LexemeStartLine       Int++        -- | Signal that we're starting a block in this column.+        | LexemeStartBlock      Int+        deriving (Eq, Show)+++-- | Parenthesis that we're currently inside. +data Paren+        = ParenRound+        | ParenBrace+        deriving Show++-- | What column number the current layout context started in.+type Context+        = Int+++-- | Apply the offside rule to this token stream.+--+--    It should have been processed with addStarts first to add the+--    LexemeStartLine/LexemeStartLine tokens.+--+--    Unlike the definition in the Haskell 98 report, we explicitly track+--    which parenthesis we're inside. We use these to partly implement+--    the layout rule that says we much check for entire parse errors to+--    perform the offside rule.+applyOffside +        :: (Eq n, Show n)+        => [Paren]              -- ^ What parenthesis we're inside.+        -> [Context]            -- ^ Current layout context.+        -> [Lexeme n]           -- ^ Input lexemes.+        -> [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) +        |   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 MODE type'+--      'import foreign MODE capability'+--      'import foreign MODE value'+applyOffside ps [] ls+        | LexemeToken t1 +                : (LexemeStartBlock n) : ls' <- 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+        , 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 | capability | value) { ... }+        | LexemeToken t1 : LexemeToken t2 : LexemeToken t3 : LexemeToken t4+                : LexemeStartBlock n : ls' <- 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 ...''+applyOffside ps [] (LexemeStartLine _  : ts)+        = applyOffside ps [] ts ++applyOffside ps [] (LexemeStartBlock _ : ts)+        = applyOffside ps [] ts+++-- line start+applyOffside ps mm@(m : ms) (t@(LexemeStartLine n) : ts)+        -- add semicolon to get to the next statement in this block+        | m == n+        = newSemiColon ts : applyOffside ps mm ts++        -- end a block+        | n <= m +        = case ps of+                -- Closed a block that we're inside, ok.+                ParenBrace : ps'+                  -> newCKet ts : applyOffside ps' ms (t : ts)++                -- We're supposed to close the block we're inside, but we're +                -- still inside an open '(' context. Just keep passing the+                -- tokens through, and let the parser give its error when +                -- it gets to it.+                ParenRound : _+                  -> applyOffside ps ms ts++                -- We always push an element of the layout context+                -- at the same time as a paren context, so this shouldn't happen.+                _ -> error $ "ddc-core: paren / layout context mismatch."++        -- indented continuation of this statement+        | otherwise+        = applyOffside ps mm ts+++-- block start+applyOffside ps mm@(m : ms) (LexemeStartBlock n : ts)+        -- enter into a nested context+        | n > m+        = newCBra ts : applyOffside (ParenBrace : ps) (n : m : ms) ts ++        -- new context starts less than the current one.+        --  This should never happen, +        --    provided addStarts works.+        | tNext : _    <- dropNewLinesLexeme ts+        = error $ "ddc-core: layout error on " ++ show tNext ++ "."++        -- new context cannot be less indented than outer one+        --  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."++        -- an empty block+        | otherwise+        = newCBra ts : newCKet ts : applyOffside ps mm (LexemeStartLine n : ts)+++-- push context for explicit open brace+applyOffside ps ms +        (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@(Located _ (KA (KSymbol SBraceKet))) : ts) ++        -- make sure that explict open braces match explicit close braces+        | 0 : ms                <- mm+        , ParenBrace : ps'      <- ps+        = t : applyOffside ps' ms ts++        -- nup+        | _tNext : _     <- dropNewLinesLexeme ts+        = [newOffsideClosingBrace ts]+++-- push context for explict open paren.+applyOffside ps ms +        (    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   (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@(Located _ (KA (KSymbol SRoundKet))) : ts)+        = t : applyOffside ps ms ts++-- pass over tokens.+applyOffside ps ms (LexemeToken t : ts) +        = t : applyOffside ps ms ts++applyOffside _ [] []        = []++-- close off remaining contexts once we've reached the end of the stream.+applyOffside ps (_ : ms) []    +        = 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) => [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 (KSymbol SBraceBra)]+          -> LexemeStartBlock (columnOfLocated t1) : addStarts' (t1 : tsRest)++          | otherwise+          -> addStarts' (t1 : tsRest)++        -- empty file+        []      -> []+++addStarts'  :: Eq n => [Located (Token n)] -> [Lexeme n]+addStarts' ts+        -- Block started at end of input.+        | Just (ts1, ts2)       <- splitBlockStart ts+        , []                    <- dropNewLines ts2+        = [LexemeToken t | t <- ts1] +                ++ [LexemeStartBlock 0]++        -- Standard block start.+        --  If there is not an open brace after a block start sequence then+        --  insert a new one.+        | Just (ts1, ts2)       <- splitBlockStart ts+        , t2 : tsRest           <- dropNewLines ts2+        , not $ isToken t2 (KA (KSymbol SBraceBra))+        = [LexemeToken t | t <- ts1]+                ++ [LexemeStartBlock (columnOfLocated t2)]+                ++ addStarts' (t2 : tsRest)++        -- check for start of list+        | t1 : ts'              <- ts+        , isToken t1 (KA (KSymbol SBraceBra))+        = LexemeToken t1    : addStarts' ts'++        -- check for end of list+        | t1 : ts'              <- ts+        , 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 (KSymbol SBraceBra))+        = LexemeStartLine (columnOfLocated t2) +                : addStarts' (t2 : tsRest)++        -- eat up trailine newlines+        | t1 : ts'              <- ts+        , isToken t1 (KM KNewLine)+        = addStarts' ts'++        -- a regular token+        | t1 : ts'              <- ts+        = LexemeToken t1    : addStarts' ts'++        -- end of input+        | otherwise+        = []+++-- | Drop newline tokens at the front of this stream.+dropNewLines :: Eq n => [Located (Token n)] -> [Located (Token n)]+dropNewLines []              = []+dropNewLines (t1:ts)+        | isToken t1 (KM KNewLine)+        = dropNewLines ts++        | otherwise+        = t1 : ts+++-- | Drop newline tokens at the front of this stream.+dropNewLinesLexeme :: Eq n => [Lexeme n] -> [Lexeme n]+dropNewLinesLexeme ll+ = case ll of+        []                      -> []+        LexemeToken t1 : ts+         |  isToken t1 (KM KNewLine)+         -> dropNewLinesLexeme ts++        l : ls+         -> l : dropNewLinesLexeme ls+++-- | Check if a token is one that starts a block of statements.+splitBlockStart +        :: [Located (Token n)] +        -> Maybe ([Located (Token n)], [Located (Token n)])++splitBlockStart toks++ -- export type+ |  t1@(Located _ (KA (KKeyword EExport)))+  : t2@(Located _ (KA (KKeyword EType)))+  : ts+ <- toks = Just ([t1, t2], ts)++ -- export value+ |  t1@(Located _ (KA (KKeyword EExport)))+  : t2@(Located _ (KA (KKeyword EValue)))+  : ts+ <- toks = Just ([t1, t2], ts)++ -- export foreign X value+ |  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@(Located _ (KA (KKeyword EImport)))+  : t2@(Located _ (KA (KKeyword EType)))+  : ts+ <- toks = Just ([t1, t2], ts)++ -- import value+ |  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@(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@(Located _ (KA (KKeyword EImport)))+  : t2@(Located _ (KA (KKeyword EForeign)))+  : t3                                  +  : t4@(Located _ (KA (KKeyword EValue)))+  : ts    + <- toks = Just ([t1, t2, t3, t4], 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+++-- Utils ------------------------------------------------------------------------------------------+-- | Test whether this wrapper token matches.+isToken :: Eq n => Located (Token n) -> Token n -> Bool+isToken (Located _ tok) tok2+        = tok == tok2+++-- | Test whether this wrapper token matches.+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] -> Located (Token n)+newCBra ts+ = case takeTok ts of+        Located sp _    -> Located sp (KA (KSymbol SBraceBra))+++newCKet      :: [Lexeme n] -> Located (Token n)+newCKet ts+ = case takeTok ts of+        Located sp _    -> Located sp (KA (KSymbol SBraceKet))+++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] -> Located (Token n)+newOffsideClosingBrace ts+ = case takeTok ts of+        Located sp _    -> Located sp (KM KOffsideClosingBrace)+++takeTok :: [Lexeme n] -> Located (Token n)+takeTok []      + = Located (SourcePos "" 0 0) (KErrorJunk "") ++takeTok (l : ls)+ = case l of+        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
@@ -0,0 +1,252 @@++module DDC.Core.Lexer.Tokens+        ( Located (..)+        , columnOfLocated++          -- * Tokens+        , Token         (..)      +        , TokenMeta     (..)      +        , TokenAtom     (..)      +        , TokenNamed    (..)    ++        , Keyword       (..)+        , Symbol        (..)+        , Builtin       (..)+        , Literal       (..)++          -- ** 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 Control.Monad+import Data.Text                (Text)+import qualified Data.Text      as T+++-- TokenFamily ----------------------------------------------------------------+-- | The family of a token.+--   This is used to help generate parser error messages,+--   so we can say ''the constructor Cons''+--             and ''the keyword case'' etc.+data TokenFamily+        = Symbol+        | Keyword+        | Constructor+        | Index+        | Literal+        | Pragma+++-- | Describe a token family, for parser error messages.+describeTokenFamily :: TokenFamily -> String+describeTokenFamily tf+ = case tf of+        Symbol          -> "symbol"+        Keyword         -> "keyword"+        Constructor     -> "constructor"+        Index           -> "index"+        Literal         -> "literal"+        Pragma          -> "pragma"+++-- Token ------------------------------------------------------------------------+-- | Tokens accepted by the core language parser.+data Token n+        -- | Some junk symbol that isn't part of the language.+        = 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    !TokenMeta++        -- | Atomic tokens are keywords, punctuation and baked-in +        --   constructor names.+        | KA    !TokenAtom ++        -- | A named token that is specific to the language fragment +        --   (maybe it's a primop), or a user defined name.+        | KN    !(TokenNamed n)+        deriving (Eq, Show)+++-- | Apply a function to all the names in a `Tok`.+renameToken+        :: Ord n2+        => (n1 -> Maybe n2) +        -> Token n1 +        -> Maybe (Token n2)++renameToken f kk+ = case kk of+        KErrorJunk s +         -> Just $ KErrorJunk s++        KErrorUnterm s+          -> Just $ KErrorUnterm s++        KM t    -> Just $ KM t+        KA t    -> Just $ KA t+        KN t    -> liftM KN $ renameTokenNamed f t+++-- | Describe a token for parser error messages.+describeToken :: Pretty n => Token n -> String+describeToken kk+ = case kk of+        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 TokenMeta+        = KNewLine++        -- | Comment string.+        | KComment String++        -- | This is injected by `dropCommentBlock` when it finds+        --   an unterminated block comment.+        | KCommentUnterminated++        -- | This is injected by `applyOffside` when it finds an explit close+        --   brace in a position where it would close a synthetic one.+        | KOffsideClosingBrace+        deriving (Eq, Show)+++-- | Describe a TokMeta, for lexer error messages.+describeTokenMeta :: TokenMeta -> String+describeTokenMeta tm+ = case tm of+        KNewLine                -> "new line"+        KComment{}              -> "comment"+        KCommentUnterminated    -> "unterminated block comment"+        KOffsideClosingBrace    -> "closing brace"+++-- TokAtom --------------------------------------------------------------------+-- | 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 TokenAtom+        -- | Pragmas.+        = KPragma  Text++        -- | Symbols.+        | KSymbol  Symbol++        -- | Keywords.+        | KKeyword Keyword++        -- | Builtin names.+        | KBuiltin Builtin++        -- | Infix operators, like in 1 + 2.+        | KOp      String++        -- | Wrapped operator, like in (+) 1 2.+        | KOpVar   String       ++        -- | Debrujn indices.+        | KIndex   Int++        -- | Literal values.+        | KLiteral +                Literal         -- Literal value.+                Bool            -- Trailing '#' prim specifier.+        deriving (Eq, Show)+++-- | Describe a `TokAtom`, for parser error messages.+describeTokenAtom  :: TokenAtom -> String+describeTokenAtom ta+ = let  (family, str)           = describeTokenAtom' ta+   in   describeTokenFamily family ++ " " ++ show str++describeTokenAtom' :: TokenAtom -> (TokenFamily, String)+describeTokenAtom' ta+ = case ta of+        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))+++-- TokNamed -------------------------------------------------------------------+-- | A token with a user-defined name.+data TokenNamed n+        = KCon n+        | KVar n+        deriving (Eq, Show)+++-- | Describe a `TokNamed`, for parser error messages.+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)+++-- | Apply a function to all the names in a `TokNamed`.+renameTokenNamed +        :: Ord n2+        => (n1 -> Maybe n2) +        -> TokenNamed n1 +        -> Maybe (TokenNamed n2)++renameTokenNamed f kk+  = case kk of+        KCon c           -> liftM KCon $ f c+        KVar c           -> liftM KVar $ 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
@@ -0,0 +1,358 @@+{-# LANGUAGE UndecidableInstances #-}++-- | \"Loading\" refers to the combination of parsing and type checking.+--   This is the easiest way to turn source tokens into a type-checked +--   abstract syntax tree.+module DDC.Core.Load+        ( C.AnTEC       (..)+        , Error         (..)+        , Mode          (..)+        , CheckTrace    (..)++        -- * Loading modules+        , loadModuleFromFile+        , loadModuleFromString+        , loadModuleFromTokens+        +        -- * Loading expressions+        , loadExpFromString+        , loadExpFromTokens+        +        -- * Loading types+        , loadTypeFromString+        , loadTypeFromTokens++        -- * Loading witnesses+        , loadWitnessFromString+        , loadWitnessFromTokens)+where+import DDC.Core.Transform.SpreadX+import DDC.Core.Fragment.Profile+import DDC.Core.Lexer.Tokens+import DDC.Core.Check                           (Mode(..), CheckTrace)+import DDC.Core.Exp+import DDC.Core.Exp.Annot.AnT                   (AnT)+import DDC.Type.Transform.SpreadT+import DDC.Type.Universe+import DDC.Core.Module+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.Control.Parser             as BP+import qualified Data.Map.Strict                as Map+import Data.Map.Strict                          (Map)+import System.Directory+++-- Error ------------------------------------------------------------------------------------------+-- | Things that can go wrong when loading a core thing.+data Error n err+        = ErrorRead       !String+        | ErrorParser     !BP.ParseError+        | 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))+++instance ( Eq n, Show n, Pretty n+         , Pretty (err (C.AnTEC BP.SourcePos n)))+        => Pretty (Error n err) where+ ppr err+  = case err of+        ErrorRead str+         -> vcat [ text "While reading."+                 , indent 2 $ text str ]++        ErrorParser     err'    +         -> vcat [ text "While parsing."+                 , indent 2 $ ppr err' ]++        ErrorCheckType  err'+         -> vcat [ text "When checking type."+                 , indent 2 $ ppr err' ]++        ErrorCheckExp   err'    +         -> vcat [ text "When checking expression."+                 , indent 2 $ ppr err' ]++        ErrorCompliance err'    +         -> vcat [ text "During fragment compliance check."+                 , indent 2 $ ppr err' ]++        ErrorFragment err'+         -> vcat [ text "During fragment specific check."+                 , indent 2 $ ppr err' ]+++-- Module -----------------------------------------------------------------------------------------+-- | Parse and type check a core module from a file.+loadModuleFromFile +        :: (Eq n, Ord n, Show n, Pretty n)+        => Fragment n err               -- ^ Language fragment definition.+        -> FilePath                     -- ^ File containing source code.+        -> Mode n                       -- ^ Type checker mode.+        -> IO ( Either (Error n err)+                       (Module (C.AnTEC BP.SourcePos n) n)+              , Maybe CheckTrace)++loadModuleFromFile fragment filePath mode+ = do   +        -- Check whether the file exists.+        exists  <- doesFileExist filePath+        if not exists +         then return ( Left $ ErrorRead $ "No such file '" ++ filePath ++ "'"+                     , Nothing)+         else do+                -- Read the source file.+                src     <- readFile filePath++                -- Lex the source.+                let toks = (F.fragmentLexModule fragment) filePath 1 src++                return $ loadModuleFromTokens fragment filePath mode toks+++-- | Parse and type check a core module from a string.+loadModuleFromString+        :: (Eq n, Ord n, Show n, Pretty n)+        => Fragment n err               -- ^ Language fragment definition.+        -> FilePath                     -- ^ Path to source file for error messages.+        -> Int                          -- ^ Starting line number for error messages.+        -> Mode n                       -- ^ Type checker mode.+        -> String                       -- ^ Program text.+        -> ( Either (Error n err) +                    (Module (C.AnTEC BP.SourcePos n) n)+           , Maybe CheckTrace)++loadModuleFromString fragment filePath lineStart mode src+ = do   let toks = F.fragmentLexModule fragment filePath lineStart src+        loadModuleFromTokens fragment filePath mode toks+++-- | Parse and type check a core module from some tokens.+loadModuleFromTokens+        :: (Eq n, Ord n, Show n, Pretty n)+        => Fragment n err               -- ^ Language fragment definition.+        -> FilePath                     -- ^ Path to source file for error messages.+        -> Mode n                       -- ^ Type checker mode.+        -> [Located (Token n)]          -- ^ Source tokens.+        -> ( Either (Error n err) +                    (Module (C.AnTEC BP.SourcePos n) n)+           , Maybe CheckTrace)++loadModuleFromTokens fragment sourceName mode toks'+ = goParse toks'+ where  +        -- Type checker config kind and type environments.+        profile = F.fragmentProfile fragment+        config  = C.configOfProfile profile+        kenv    = profilePrimKinds  profile+        tenv    = profilePrimTypes  profile++        -- Parse the tokens.+        goParse toks                +         = case BP.runTokenParser describeToken sourceName +                        (C.pModule (C.contextOfProfile profile))+                        toks of+                Left err        -> (Left (ErrorParser err),     Nothing)+                Right mm        -> goCheckType (spreadX kenv tenv mm)++        -- Check that the module is type well-typed.+        goCheckType mm+         = case C.checkModule config mm mode of+                (Left err,  ct) -> (Left (ErrorCheckExp err),   Just ct)+                (Right mm', ct) -> goCheckCompliance ct mm'++        -- Check that the module compiles with the language fragment.+        goCheckCompliance ct mm+         = case F.complies profile mm of+                Just err        -> (Left (ErrorCompliance err), Just ct)+                Nothing         -> goCheckFragment ct mm++        -- Perform fragment specific checks.+        goCheckFragment ct mm+         = case F.fragmentCheckModule fragment mm of+                Just err        -> (Left (ErrorFragment err),   Just ct)+                Nothing         -> (Right mm,                   Just ct)+++-- Exp --------------------------------------------------------------------------------------------+-- | Parse and type-check and expression from a string.+loadExpFromString+        :: (Eq n, Ord n, Show n, Pretty n)+        => Fragment n err       -- ^ Language fragment definition.+        -> Map ModuleName (Module (C.AnTEC () n) n)+                                -- ^ Other modules currently in scope.+                                --   We add their exports to the environment.+        -> FilePath             -- ^ Path to source file for error messages.+        -> Mode n               -- ^ Type checker mode.+        -> String               -- ^ Source string.+        -> ( Either (Error n err) +                    (Exp (C.AnTEC BP.SourcePos n) n)+           , Maybe CheckTrace)++loadExpFromString fragment modules sourceName mode src+ = do  let toks = F.fragmentLexExp fragment sourceName 1 src+       loadExpFromTokens fragment modules sourceName mode toks+++-- | Parse and check an expression+--   returning it along with its spec, effect and closure+loadExpFromTokens+        :: (Eq n, Ord n, Show n, Pretty n)+        => Fragment n err       -- ^ Language fragment definition.+        -> Map ModuleName (Module (C.AnTEC () n) n)+                                -- ^ Other modules currently in scope.+                                --   We add their exports to the environment.+        -> FilePath             -- ^ Path to source file for error messages.+        -> Mode n               -- ^ Type checker mode.+        -> [Located (Token n)]  -- ^ Source tokens.+        -> ( Either (Error n err) +                    (Exp (C.AnTEC BP.SourcePos n) n)+           , Maybe CheckTrace)++loadExpFromTokens fragment modules sourceName mode toks'+ = goParse toks'+ where  +        -- Type checker profile, kind and type environments.+        profile = F.fragmentProfile fragment+        config  = C.configOfProfile  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 describeToken sourceName +                        (C.pExp (C.contextOfProfile profile))+                        toks of+                Left err              -> (Left (ErrorParser err),     Nothing)+                Right t               -> goCheckType (spreadX kenv tenv t)++        -- Check the kind of the type.+        goCheckType x+         = case C.checkExp config envx mode C.DemandNone x of+            (Left err, ct)            -> (Left  (ErrorCheckExp err),  Just ct)+            (Right (x', _, _), ct)    -> goCheckCompliance ct x'++        -- Check that the module compiles with the language fragment.+        goCheckCompliance ct x +         = case F.compliesWithEnvs profile kenv tenv x of+            Just err                  -> (Left (ErrorCompliance err), Just ct)+            Nothing                   -> goCheckFragment ct x++        -- Perform fragment specific checks.+        goCheckFragment ct x+         = case F.fragmentCheckExp fragment x of+            Just err                  -> (Left (ErrorFragment err),   Just ct)+            Nothing                   -> (Right x,                    Just ct)+++-- Type -------------------------------------------------------------------------------------------+-- | Parse and check a type from a string, returning it along with its kind.+loadTypeFromString+        :: (Eq n, Ord n, Show n, Pretty n)+        => Fragment n err       -- ^ Language fragment definition.+        -> Universe             -- ^ Universe this type is supposed to be in.+        -> FilePath             -- ^ Path to source file for error messages.+        -> String               -- ^ Source string.+        -> Either (Error n err) +                  (Type n, Kind n)++loadTypeFromString fragment uni sourceName str+ = do  let toks = F.fragmentLexExp fragment sourceName 1 str+       loadTypeFromTokens fragment uni sourceName toks+++-- | Parse and check a type from some tokens, returning it along with its kind.+loadTypeFromTokens+        :: (Eq n, Ord n, Show n, Pretty n)+        => Fragment n err       -- ^ Language fragment definition.+        -> Universe             -- ^ Universe this type is supposed to be in.+        -> FilePath             -- ^ Path to source file for error messages.+        -> [Located (Token n)]  -- ^ Source tokens.+        -> Either (Error n err) +                  (Type n, Kind n)++loadTypeFromTokens fragment uni sourceName toks'+ = goParse toks'+ where  +        profile = F.fragmentProfile fragment++        -- Parse the tokens.+        goParse toks                +         = case BP.runTokenParser describeToken sourceName +                        (C.pType (C.contextOfProfile profile))+                        toks of+                Left err  -> Left (ErrorParser err)+                Right t   -> goCheckType (spreadT (profilePrimKinds profile) t)++        -- Check the kind of the type.+        goCheckType t+         = case C.checkType (C.configOfProfile profile) uni t of+                Left err      -> Left (ErrorCheckType err)+                Right (t', k) -> Right (t', k)+        ++-- Witness ----------------------------------------------------------------------------------------+-- | Parse and check a witness from a string, returning it along with its kind.+loadWitnessFromString+        :: (Eq n, Ord n, Show n, Pretty n)+        => Fragment n err       -- ^ Language fragment profile.+        -> FilePath             -- ^ Path to source file for error messages.+        -> String               -- ^ Source string.+        -> Either (Error n err) +                  (Witness (AnT BP.SourcePos n) n, Type n)++loadWitnessFromString fragment sourceName str+ = do  let toks = F.fragmentLexExp fragment sourceName 1 str+       loadWitnessFromTokens fragment sourceName toks+++-- | Parse and check a witness from some tokens, returning it along with its type.+loadWitnessFromTokens+        :: (Eq n, Ord n, Show n, Pretty n)+        => Fragment n err       -- ^ Language fragment profile.+        -> FilePath             -- ^ Path to source file for error messages.+        -> [Located (Token n)]  -- ^ Source tokens.+        -> Either (Error n err) +                  (Witness (AnT BP.SourcePos n) n, Type n)++loadWitnessFromTokens fragment sourceName toks'+ = goParse toks'+ where  -- Type checker config, kind and type environments.+        profile = F.fragmentProfile fragment+        config  = C.configOfProfile profile++        env     = EnvX.fromPrimEnvs +                        (profilePrimKinds    profile)+                        (profilePrimTypes    profile)+                        (profilePrimDataDefs profile)++        kenv    = profilePrimKinds profile+        tenv    = profilePrimTypes profile++        -- Parse the tokens.+        goParse toks                +         = case BP.runTokenParser describeToken sourceName +                (C.pWitness (C.contextOfProfile profile)) +                toks of+                Left err  -> Left (ErrorParser err)+                Right t   -> goCheckType (spreadX kenv tenv t)++        -- Check the kind of the type.+        goCheckType w+         = case C.checkWitness config env w of+                Left err      -> Left (ErrorCheckExp err)+                Right (w', t) -> Right (w', t)+
+ DDC/Core/Module.hs view
@@ -0,0 +1,392 @@+module DDC.Core.Module+        ( -- * Modules+          Module        (..)+        , isMainModule+        , moduleDataDefs+        , moduleTypeDefs+        , moduleKindEnv, moduleTypeEnv+        , moduleEnvT,    moduleEnvX+        , modulesEnvT,   modulesEnvX+        , moduleTopBinds+        , moduleTopBindTypes+        , mapTopBinds++          -- * Module maps+        , ModuleMap+        , modulesExportTypes+        , modulesExportValues++         -- * Module Names+        , ModuleName    (..)+        , readModuleName+        , isMainModuleName+        , moduleNameMatchesPath+        +         -- * Qualified names.+        , QualName      (..)++         -- * Export Definitions+        , ExportSource  (..)+        , takeTypeOfExportSource+        , mapTypeOfExportSource++         -- * Import Definitions+         -- ** Import Types+        , ImportType    (..)+        , kindOfImportType+        , mapKindOfImportType++         -- ** Import Capabilities+        , ImportCap     (..)+        , typeOfImportCap+        , mapTypeOfImportCap++         -- ** Import Types+        , ImportValue   (..)+        , typeOfImportValue+        , mapTypeOfImportValue)+where+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+++-- Module -----------------------------------------------------------------------------------------+-- | A module can be mutually recursive with other modules.+data Module a n+        = ModuleCore+        { -- | Name of this module.+          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 (Type n))]++          -- | Types of exported values.+        , moduleExportValues    :: ![(n, ExportSource n (Type n))]++          -- Imports ------------------+          -- | Define imported types.+        , moduleImportTypes     :: ![(n, ImportType   n (Type n))]++          -- | Define imported capabilities.+        , moduleImportCaps      :: ![(n, ImportCap    n (Type n))]++          -- | 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]++          -- | 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)+        }+        deriving (Show, Typeable)+++instance (NFData a, NFData n) => NFData (Module a n) where+ rnf !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.+isMainModule :: Module a n -> Bool+isMainModule mm+        = isMainModuleName +        $ 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 (kindOfImportType isrc) | (n, isrc) <- moduleImportTypes mm]+++-- | Get the top-level type environment of a module,+--   from its imported values.+moduleTypeEnv :: Ord n => Module a n -> TypeEnv n+moduleTypeEnv mm+        = Env.fromList +        $ [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+ = go (moduleBody mm)+ where  go xx+         = case xx of+                XLet _ (LLet (BName n _) _) x2    +                 -> Set.insert n (go x2)++                XLet _ (LLet _ _) x2    +                 -> go x2++                XLet _ (LRec bxs) x2    +                 ->     Set.fromList (mapMaybe takeNameOfBind $ map fst bxs)+                 `Set.union` go x2++                _ -> Set.empty+++-- | Get a map of named top-level bindings to their types.+moduleTopBindTypes :: Ord n => Module a n -> Map n (Type n)+moduleTopBindTypes mm+ = go Map.empty (moduleBody mm)+ where  go acc xx+         = case xx of+                XLet _ (LLet (BName n t) _) x2+                  -> go (Map.insert n t acc) x2++                XLet _ (LLet _ _) x2+                  -> go acc x2++                XLet _ (LRec 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 +        = Map ModuleName (Module a n)+++-- | Add the kind environment exported by all these modules to the given one.+modulesExportTypes :: Ord n => ModuleMap a n -> KindEnv n -> KindEnv n+modulesExportTypes mods base+ = let  envOfModule m+         = Env.fromList+         $ [BName n t   |  (n, Just t) +                        <- map (liftSnd takeTypeOfExportSource) $ moduleExportTypes m]++        liftSnd f (x, y) = (x, f y)++   in   Env.unions $ base : (map envOfModule $ Map.elems mods)+         ++-- | Add the type environment exported by all these modules to the given one.+modulesExportValues :: Ord n => ModuleMap a n -> TypeEnv n -> TypeEnv n+modulesExportValues mods base+ = let  envOfModule m+         = Env.fromList+         $ [BName n t   | (n, Just t)+                        <- map (liftSnd takeTypeOfExportSource) $ moduleExportValues m] ++        liftSnd f (x, y) = (x, f y)++   in   Env.unions $ base : (map envOfModule $ Map.elems mods)+
+ 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
@@ -1,631 +1,59 @@ -- | Core language parser. module DDC.Core.Parser-        ( module DDC.Base.Parser-        , Parser-        , pExp-        , pWitness)-        -where-import DDC.Core.Exp-import DDC.Core.Parser.Tokens-import DDC.Base.Parser                  ((<?>))-import DDC.Type.Parser                  (pTok)-import qualified DDC.Base.Parser        as P-import qualified DDC.Type.Compounds     as T-import qualified DDC.Type.Parser        as T-import Control.Monad.Error----- | A parser of core language tokens.-type Parser n a-        = P.Parser (Tok n) a----- Expressions ------------------------------------------------------------------- | Parse a core language expression.-pExp    :: Ord n => Parser n (Exp () n)-pExp - = P.choice-        -- Level-0 lambda abstractions-        -- \(x1 x2 ... : TYPE) (y1 y2 ... : TYPE) ... . EXP- [ do   pTok KBackSlash--        bs      <- liftM concat-                $  P.many1 -                $  do   pTok KRoundBra-                        bs'     <- P.many1 T.pBinder-                        pTok KColon-                        t       <- T.pType-                        pTok KRoundKet-                        return (map (\b -> T.makeBindFromBinder b t) bs')--        pTok KDot-        xBody   <- pExp-        return  $ foldr (XLam ()) xBody bs--        -- Level-1 lambda abstractions.-        -- /\(x1 x2 ... : TYPE) (y1 y2 ... : TYPE) ... . EXP- , do   pTok KBigLambda--        bs      <- liftM concat-                $  P.many1 -                $  do   pTok KRoundBra-                        bs'     <- P.many1 T.pBinder-                        pTok KColon-                        t       <- T.pType-                        pTok KRoundKet-                        return (map (\b -> T.makeBindFromBinder b t) bs')--        pTok KDot-        xBody   <- pExp-        return  $ foldr (XLAM ()) xBody bs---        -- let expression- , do   pTok KLet-        (mode1, b1, x1)  <- pLetBinding-        pTok KIn-        x2              <- pExp-        return  $ XLet () (LLet mode1 b1 x1) x2---        -- letrec expression- , do   pTok KLetRec--        P.choice-         -- Multiple bindings in braces-         [ do   pTok KBraceBra-                lets    <- P.sepEndBy1 pLetRecBinding (pTok KSemiColon)-                pTok KBraceKet-                pTok KIn-                x       <- pExp-                return  $ XLet () (LRec lets) x--         -- A single binding without braces.-         , do   ll      <- pLetRecBinding-                pTok KIn-                x       <- pExp-                return  $ XLet () (LRec [ll]) x-         ]      ---        -- Local region binding.-        --   letregion BINDER with { BINDER : TYPE ... } in EXP-        --   letregion BINDER in EXP- , do   pTok KLetRegion-        br      <- T.pBinder-        let b   = T.makeBindFromBinder br T.kRegion--        P.choice -         [ do   pTok KWith-                pTok KBraceBra-                wits    <- P.sepBy-                           (do  w       <- pVar-                                pTok KColon-                                t       <- T.pTypeApp-                                return  (BName w t))-                           (pTok KSemiColon)-                pTok KBraceKet-                pTok KIn-                x       <- pExp -                return  $ XLet () (LLetRegion b wits) x --         , do   pTok KIn-                x       <- pExp-                return $ XLet ()  (LLetRegion b []) x ]---        -- withregion CON in EXP- , do   pTok KWithRegion-        n       <- pVar-        pTok KIn-        x       <- pExp-        let u   = UName n (T.tBot T.kRegion)-        return  $ XLet () (LWithRegion u) x---        -- case EXP of { ALTS }- , do   pTok KCase-        x       <- pExp-        pTok KOf -        pTok KBraceBra-        alts    <- P.sepEndBy1 pAlt (pTok KSemiColon)-        pTok KBraceKet-        return  $ XCase () x alts---        -- weakeff [TYPE] in EXP- , do   pTok KWeakEff-        pTok KSquareBra-        t       <- T.pType-        pTok KSquareKet-        pTok KIn-        x       <- pExp-        return  $ XCast () (CastWeakenEffect t) x---        -- weakclo [TYPE] in EXP- , do   pTok KWeakClo-        pTok KSquareBra-        t       <- T.pType-        pTok KSquareKet-        pTok KIn-        x       <- pExp-        return  $ XCast () (CastWeakenClosure t) x---        -- purify <WITNESS> in EXP- , do   pTok KPurify-        pTok KAngleBra-        w       <- pWitness-        pTok KAngleKet-        pTok KIn-        x       <- pExp-        return  $ XCast () (CastPurify w) x---        -- forget <WITNESS> in EXP- , do   pTok KForget-        pTok KAngleBra-        w       <- pWitness-        pTok KAngleKet-        pTok KIn-        x       <- pExp-        return  $ XCast () (CastForget w) x--        -- APP- , do   pExpApp- ]-- <?> "an expression"----- Applications.-pExpApp :: Ord n => Parser n (Exp () n)-pExpApp -  = do  x1      <- pExp0-        -        P.choice-         [ do   xs  <- liftM concat $ P.many1 pArgs-                return  $ foldl (XApp ()) x1 xs--         ,      return x1]-- <?> "an expression or application"----- Comp, Witness or Spec arguments.-pArgs   :: Ord n => Parser n [Exp () n]-pArgs - = P.choice-        -- [TYPE]- [ do   pTok KSquareBra-        t       <- T.pType -        pTok KSquareKet-        return  [XType t]--        -- [: TYPE0 TYPE0 ... :]- , do   pTok KSquareColonBra-        ts      <- P.many1 T.pTypeAtom-        pTok KSquareColonKet-        return  $ map XType ts-        -        -- <WITNESS>- , do   pTok KAngleBra-        w       <- pWitness-        pTok KAngleKet-        return  [XWitness w]-                -        -- <: WITNESS0 WITNESS0 ... :>- , do   pTok KAngleColonBra-        ws      <- P.many1 pWitnessAtom-        pTok KAngleColonKet-        return  $ map XWitness ws-                -        -- EXP0- , do   x       <- pExp0-        return  [x]- ]- <?> "a type, witness or expression argument"----- Atomics-pExp0   :: Ord n => Parser n (Exp () n)-pExp0 - = P.choice-        -- (EXP2)- [ do   pTok KRoundBra-        t       <- pExp-        pTok KRoundKet-        return  $ t-        -        -- Named constructors- , do   con     <- pCon-        return  $ XCon () (UName con (T.tBot T.kData)) --        -- Literals- , do   lit     <- pLit-        return  $ XCon () (UName lit (T.tBot T.kData))--        -- Debruijn indices- , do   i       <- T.pIndex-        return  $ XVar () (UIx   i   (T.tBot T.kData))--        -- Variables- , do   var     <- pVar-        return  $ XVar () (UName var (T.tBot T.kData)) - ]-- <?> "a variable, constructor, or parenthesised type"----- Case alternatives.-pAlt    :: Ord n => Parser n (Alt () n)-pAlt- = do   p       <- pPat-        pTok KArrowDash-        x       <- pExp-        return  $ AAlt p x----- Patterns.-pPat    :: Ord n => Parser n (Pat n)-pPat- = P.choice- [      -- Wildcard-   do   pTok KUnderscore-        return  $ PDefault--        -- LIT- , do   nLit    <- pLit-        return  $ PData (UName nLit (T.tBot T.kData)) []--        -- CON BIND BIND ...- , do   nCon    <- pCon -        bs      <- P.many pBindPat-        return  $ PData (UName nCon (T.tBot T.kData)) bs]----- Binds in patterns can have no type annotation,--- or can have an annotation if the whole thing is in parens.-pBindPat :: Ord n => Parser n (Bind n)-pBindPat - = P.choice-        -- Plain binder.- [ do   b       <- T.pBinder-        return  $ T.makeBindFromBinder b (T.tBot T.kData)--        -- Binder with type, wrapped in parens.- , do   pTok KRoundBra-        b       <- T.pBinder-        pTok KColon-        t       <- T.pType-        pTok KRoundKet-        return  $ T.makeBindFromBinder b t- ]----- Bindings ---------------------------------------------------------------------- | A binding for let expression.-pLetBinding :: Ord n => Parser n (LetMode n, Bind n, Exp () n)-pLetBinding - = do   b       <- T.pBinder--        P.choice-         [ do   -- Binding with full type signature.-                --  BINDER : TYPE = EXP-                pTok KColon-                t       <- T.pType-                mode    <- pLetMode-                pTok KEquals-                xBody   <- pExp--                return  $ (mode, T.makeBindFromBinder b t, xBody) ---         , do   -- Non-function binding with no type signature.-                -- 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-                mode    <- pLetMode-                pTok KEquals-                xBody   <- pExp-                let t   = T.tBot T.kData-                return  $ (mode, T.makeBindFromBinder b t, xBody)---         , do   -- Binding using function syntax.-                ps      <- liftM concat -                        $  P.many pBindParamSpec -        -                P.choice-                 [ do   -- Function syntax with a return type.-                        -- We can make the full type sig for the let-bound variable.-                        --   BINDER PARAM1 PARAM2 .. PARAMN : TYPE = EXP-                        pTok KColon-                        tBody   <- T.pType-                        mode    <- pLetMode-                        pTok KEquals-                        xBody   <- pExp--                        let x   = expOfParams () ps xBody-                        let t   = funTypeOfParams ps tBody-                        return  (mode, T.makeBindFromBinder b t, x)--                        -- Function syntax with no return type.-                        -- We can't make the type sig for the let-bound variable,-                        -- but we can create lambda abstractions with the given -                        -- parameter types.-                        --  BINDER PARAM1 PARAM2 .. PARAMN = EXP-                 , do   mode    <- pLetMode-                        pTok KEquals-                        xBody   <- pExp--                        let x   = expOfParams () ps xBody-                        let t   = T.tBot T.kData-                        return  (mode, T.makeBindFromBinder b t, x) ]-         ]---- | Parse a let mode specifier.---   Only allow the lazy specifier with non-recursive bindings.---   We don't support value recursion, so the right of all recursive---   bindings must be explicit lambda abstractions anyway, so there's ---   no point suspending them.-pLetMode :: Ord n => Parser n (LetMode n)-pLetMode- = do   P.choice-                -- lazy <WITNESS>-         [ do   pTok KLazy--                P.choice-                 [ do   pTok KAngleBra-                        w       <- pWitness-                        pTok KAngleKet-                        return  $ LetLazy (Just w)-                 -                 , do   return  $ LetLazy Nothing ]--         , do   return  $ LetStrict ]----- | Letrec bindings must have a full type signature, ---   or use function syntax with a return type so that we can make one.-pLetRecBinding :: Ord n => Parser n (Bind n, Exp () n)-pLetRecBinding - = do   b       <- T.pBinder--        P.choice-         [ do   -- Binding with full type signature.-                --  BINDER : TYPE = EXP-                pTok KColon-                t       <- T.pType-                pTok KEquals-                xBody   <- pExp--                return  $ (T.makeBindFromBinder b t, xBody) ---         , do   -- Binding using function syntax.-                --  BINDER PARAM1 PARAM2 .. PARAMN : TYPE = EXP-                ps      <- liftM concat -                        $  P.many pBindParamSpec -        -                pTok KColon-                tBody   <- T.pType-                let t   = funTypeOfParams ps tBody--                pTok KEquals-                xBody   <- pExp-                let x   = expOfParams () ps xBody--                return  (T.makeBindFromBinder b t, x) ]----- | Parse a parameter specification.------       [BIND1 BIND2 .. BINDN : TYPE]---   or  (BIND : TYPE)---   or  (BIND : TYPE) { EFFECT | CLOSURE }----pBindParamSpec :: Ord n => Parser n [ParamSpec n]-pBindParamSpec- = P.choice-        -- Type parameter-        -- [BIND1 BIND2 .. BINDN : TYPE]- [ do   pTok KSquareBra-        bs      <- P.many1 T.pBinder-        pTok KColon-        t       <- T.pType-        pTok KSquareKet-        return  [ ParamType b -                | b <- zipWith T.makeBindFromBinder bs (repeat t)]---        -- Witness parameter-        -- <BIND : TYPE>- , do   pTok KAngleBra-        b       <- T.pBinder-        pTok KColon-        t       <- T.pType-        pTok KAngleKet-        return  [ ParamWitness $ T.makeBindFromBinder b t]--        -- Value parameter-        -- (BIND : TYPE) -        -- (BIND : TYPE) { TYPE | TYPE }- , do   pTok KRoundBra-        b       <- T.pBinder-        pTok KColon-        t       <- T.pType-        pTok KRoundKet--        (eff, clo) -         <- P.choice-                [ do    pTok KBraceBra-                        eff'    <- T.pType-                        pTok KBar-                        clo'    <- T.pType-                        pTok KBraceKet-                        return  (eff', clo')-                -                , do    return  (T.tBot T.kEffect, T.tBot T.kClosure) ]-                --        return  $ [ParamValue (T.makeBindFromBinder b t) eff clo]- ]----- | Specification of a function parameter.---   We can determine the contribution to the type of the function, ---   as well as its expression based on the parameter.-data ParamSpec n-        = ParamType    (Bind n)-        | ParamWitness (Bind n)-        | ParamValue   (Bind n) (Type n) (Type n)-+        ( Parser+        , Context       (..)+        , contextOfProfile --- | Build the type of a function from specifications of its parameters,---   and the type of the body.-funTypeOfParams -        :: [ParamSpec n]        -- ^ Spec of parameters.-        -> Type n               -- ^ Type of body.-        -> Type n               -- ^ Type of whole function.+          -- * Types+        , pType+        , pTypeApp+        , pTypeAtom -funTypeOfParams [] tBody        = tBody-funTypeOfParams (p:ps) tBody- = case p of-        ParamType  b    -         -> TForall b -                $ funTypeOfParams ps tBody+        -- * Modules+        , pModule+        , pModuleName -        ParamWitness b-         -> T.tImpl (T.typeOfBind b)-                $ funTypeOfParams ps tBody+        -- * Expressions+        , pExp+        , pExpApp+        , pExpAtom -        ParamValue b eff clo-         -> T.tFun (T.typeOfBind b) eff clo -                $ funTypeOfParams ps tBody+        -- * Function Parameters+        , ParamSpec(..)+        , funTypeOfParams+        , expOfParams+        , pBindParamSpecAnnot+        , pBindParamSpec +          -- * Witnesses+        , pWitness+        , pWitnessApp+        , pWitnessAtom --- | Build the expression of a function from specifications of its parameters,---   and the expression for the body.-expOfParams -        :: a-        -> [ParamSpec n]        -- ^ Spec of parameters.-        -> Exp a n              -- ^ Body of function.-        -> Exp a n              -- ^ Expression of whole function.+          -- * Constructors+        , pCon,         pConSP+        , pLit,         pLitSP -expOfParams _ [] xBody            = xBody-expOfParams a (p:ps) xBody- = case p of-        ParamType b     -         -> XLAM a b $ expOfParams a ps xBody+          -- * Variables+        , pIndex,       pIndexSP+        , pVar,         pVarSP+        , pBinder+        , pName         -        ParamWitness b-         -> XLam a b $ expOfParams a ps xBody--        ParamValue b _ _-         -> XLam a b $ expOfParams a ps xBody------ Witnesses --------------------------------------------------------------------- | Parse a witness expression.-pWitness :: Ord n  => Parser n (Witness n)-pWitness = pWitnessJoin----- Witness Joining-pWitnessJoin :: Ord n => Parser n (Witness n)-pWitnessJoin -   -- WITNESS  or  WITNESS & WITNESS- = do   w1      <- pWitnessApp-        P.choice -         [ do   pTok KAmpersand-                w2      <- pWitnessJoin-                return  (WJoin w1 w2)--         , do   return w1 ]----- Applications-pWitnessApp :: Ord n => Parser n (Witness n)-pWitnessApp -  = do  (x:xs)  <- P.many1 pWitnessArg-        return  $ foldl WApp x xs-- <?> "a witness expression or application"----- Function argument-pWitnessArg :: Ord n => Parser n (Witness n)-pWitnessArg - = P.choice- [ -- [TYPE]-   do   pTok KSquareBra-        t       <- T.pType-        pTok KSquareKet-        return  $ WType t--   -- WITNESS- , do   pWitnessAtom ]----- Atomics-pWitnessAtom :: Ord n => Parser n (Witness n)-pWitnessAtom - = P.choice-   -- (WITNESS)- [ do    pTok KRoundBra-         w       <- pWitness-         pTok KRoundKet-         return  $ w--   -- Named constructors- , do   con     <- pCon-        return  $ WCon (WiConBound $ UName con (T.tBot T.kWitness)) --   -- Baked-in witness constructors.- , do    wb     <- pWbCon-         return $ WCon (WiConBuiltin wb)--                -   -- Debruijn indices- , do    i       <- T.pIndex-         return  $ WVar (UIx   i   (T.tBot T.kWitness))--   -- Variables- , do    var     <- pVar-         return  $ WVar (UName var (T.tBot T.kWitness)) ]-- <?> "a witness"------------------------------------------------------------------------------------- | Parse a builtin named `WiCon`-pWbCon :: Parser n WbCon-pWbCon  = P.pTokMaybe f- where  f (KA (KWbConBuiltin wb)) = Just wb-        f _                       = Nothing----- | Parse a variable name-pVar :: Parser n n-pVar    = P.pTokMaybe f- where  f (KN (KVar n)) = Just n-        f _             = Nothing----- | Parse a constructor name-pCon :: Parser n n-pCon    = P.pTokMaybe f- where  f (KN (KCon n)) = Just n-        f _             = Nothing-+          -- * Infix operators+        , pOpSP+        , pOpVarSP --- | Parse a literal-pLit :: Parser n n-pLit    = P.pTokMaybe f- where  f (KN (KLit n)) = Just n-        f _             = Nothing+          -- * Raw Tokens+        , pSym,         pKey+        , pTok,         pTokSP+        , pTokAs) +where+import DDC.Core.Parser.Base+import DDC.Core.Parser.Context+import DDC.Core.Parser.Witness+import DDC.Core.Parser.Type+import DDC.Core.Parser.Exp+import DDC.Core.Parser.Module+import DDC.Core.Parser.Param
+ DDC/Core/Parser/Base.hs view
@@ -0,0 +1,186 @@++module DDC.Core.Parser.Base+        ( Parser+        , pModuleName+        , pQualName+        , pName+        , pCon,         pConSP+        , pLit,         pLitSP+        , pIndex,       pIndexSP+        , pVar,         pVarSP,         pVarNamedSP+        , pKey,         pSym+        , pTok,         pTokSP+        , pTokAs,       pTokAsSP+        , pOpSP+        , pOpVarSP+        , pPragmaSP)+where+import DDC.Data.Pretty+import DDC.Core.Module+import DDC.Core.Lexer.Tokens+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 (Token n) a+++-- | Parse a module name.                               +pModuleName :: Pretty n => Parser n ModuleName+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    (KSymbol SDot)+        n       <- pName+        return  $ QualName mn n+++-- | Parse a constructor or variable name.+pName :: Parser n n+pName   = P.choice [pCon, pVar]+++-- | Parse a constructor name.+pCon    :: Parser n n+pCon    = P.pTokMaybe f+ where  f (KN (KCon n)) = Just n+        f _             = Nothing+++-- | Parse a constructor name.+pConSP    :: Parser n (n, SourcePos)+pConSP    = P.pTokMaybeSP f+ where  f (KN (KCon n)) = Just n+        f _             = Nothing+++-- | Parse a literal.+pLit :: Parser n (Literal, Bool)+pLit    = P.pTokMaybe f+ where  f (KA (KLiteral l b)) = Just (l, b)+        f _                   = Nothing+++-- | Parse a numeric literal, with source position.+pLitSP :: Parser n ((Literal, Bool), SourcePos)+pLitSP  = P.pTokMaybeSP f+ where  f (KA (KLiteral l b)) = Just (l, b)+        f _                   = Nothing+++-- | Parse a variable.+pVar :: Parser n n+pVar    =   P.pTokMaybe f+        <?> "a variable"+ where  f (KN (KVar n))         = Just n+        f _                     = Nothing+++-- | Parse a variable, with source position.+pVarSP :: Parser n (n, SourcePos)+pVarSP  =   P.pTokMaybeSP f+        <?> "a variable"+ where  f (KN (KVar n))         = Just n+        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+        <?> "an index"+ where  f (KA (KIndex i))       = Just i+        f _                     = Nothing+++-- | Parse a deBruijn index, with source position.+pIndexSP :: Parser n (Int, SourcePos)+pIndexSP  =   P.pTokMaybeSP f+        <?> "an index"+ where  f (KA (KIndex i))       = Just i+        f _                     = Nothing+++-- | Parse an infix operator.+pOpSP    :: Parser n (String, SourcePos)+pOpSP    = P.pTokMaybeSP f+ where  f (KA (KOp str))  = Just str+        f _               = Nothing+++-- | Parse an infix operator used as a variable.+pOpVarSP :: Parser n (String, SourcePos)+pOpVarSP = P.pTokMaybeSP f+ where  f (KA (KOpVar str))  = Just str+        f _                  = Nothing+++-- | Parse a pragma.+pPragmaSP :: Parser n (Text, SourcePos)+pPragmaSP = P.pTokMaybeSP f+ where  f (KA (KPragma txt))  = Just txt+        f _                   = Nothing++-------------------------------------------------------------------------------+-- | Parse 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   :: TokenAtom -> Parser n ()+pTok k     = P.pTok (KA k)+++-- | Parse an atomic token, yielding its source position.+pTokSP :: TokenAtom -> Parser n SourcePos+pTokSP k   = P.pTokSP (KA k)+++-- | Parse an atomic token and return some value.+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 :: TokenAtom -> a -> Parser n (a, SourcePos)+pTokAsSP k x = P.pTokAsSP (KA k) x++
+ DDC/Core/Parser/Context.hs view
@@ -0,0 +1,48 @@++module DDC.Core.Parser.Context +        ( 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 n+        = Context+        { contextTrackedEffects         :: Bool +        , contextTrackedClosures        :: Bool+        , contextFunctionalEffects      :: 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 n+contextOfProfile profile+        = Context+        { contextTrackedEffects         +                = featuresTrackedEffects+                $ profileFeatures profile++        , contextTrackedClosures+                = featuresTrackedClosures+                $ profileFeatures profile++        , contextFunctionalEffects+                = featuresFunctionalEffects+                $ 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
@@ -0,0 +1,498 @@++-- | Core language parser.+module DDC.Core.Parser.Exp+        ( pExp+        , pExpApp+        , pExpAtom,     pExpAtomSP+        , pLetsSP+        , pType+        , pTypeApp+        , pTypeAtom)+where+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.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 n -> Parser n (Exp SourcePos n)+pExp c+ = P.choice+        -- Level-0 lambda abstractions+        -- (λBIND.. . EXP) or (\BIND.. . EXP)+ [ do   sp      <- P.choice [ pSym SLambda,    pSym SBackSlash]+        bs      <- liftM concat $ P.many1 (pBinds c)+        pSym    SDot+        xBody   <- pExp c+        return  $ foldr (XLam sp) xBody bs++        -- Level-1 lambda abstractions.+        -- (ΛBINDS.. . EXP) or (/\BIND.. . EXP)+ , do   sp      <- P.choice [ pSym SBigLambda, pSym SBigLambdaSlash] +        bs      <- liftM concat $ P.many1 (pBinds c)+        pSym    SDot+        xBody   <- pExp c+        return  $ foldr (XLAM sp) xBody bs++        -- let expression+ , do   (lts, sp) <- pLetsSP c+        pKey    EIn+        x2      <- pExp c+        return  $ XLet sp lts x2++        -- do { STMTS }+        --   Sugar for a let-expression.+ , do   pKey    EDo+        pSym    SBraceBra+        xx      <- pStmts c+        pSym    SBraceKet+        return  $ xx++        -- case EXP of { ALTS }+ , do   sp      <- pKey ECase+        x       <- pExp c+        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      <- pKey ELetCase+        p       <- pPat c+        pSym    SEquals+        x1      <- pExp c+        pKey    EIn+        x2      <- pExp c+        return  $ XCase sp x1 [AAlt p x2]++        -- weakeff [TYPE] in EXP+ , do   sp      <- pKey EWeakEff+        pSym    SSquareBra+        t       <- pType c+        pSym    SSquareKet+        pKey    EIn+        x       <- pExp c+        return  $ XCast sp (CastWeakenEffect t) x++        -- purify WITNESS in EXP+ , do   sp      <- pKey EPurify+        w       <- pWitness c+        pTok (KKeyword EIn)+        x       <- pExp c+        return  $ XCast sp (CastPurify w) x++        -- box EXP+ , do   sp      <- pKey EBox+        x       <- pExp c+        return  $ XCast sp CastBox x++        -- run EXP+ , do   sp      <- pKey ERun+        x       <- pExp c+        return  $ XCast sp CastRun x++        -- APP+ , do   pExpApp c+ ]++ <?> "an expression"+++-- | Parse a function application.+pExpApp :: Ord n => Context n -> Parser n (Exp SourcePos n)+pExpApp c+  = do  (x1, _)        <- pExpAtomSP c+        +        P.choice+         [ do   xs  <- liftM concat $ P.many1 (pArgSPs c)+                return  $ foldl (\x (x', sp) -> XApp sp x x') x1 xs++         ,      return x1]++ <?> "an expression or application"+++-- Comp, Witness or Spec arguments.+pArgSPs :: Ord n => Context n -> Parser n [(Exp SourcePos n, SourcePos)]+pArgSPs c+ = P.choice+        -- [TYPE]+ [ do   sp      <- pSym SSquareBra+        t       <- pType c+        pSym SSquareKet+        return  [(XType sp t, sp)]++        -- [: TYPE0 TYPE0 ... :]+ , do   sp      <- pSym SSquareColonBra+        ts      <- P.many1 (pTypeAtom c)+        pSym SSquareColonKet+        return  [(XType sp t, sp) | t <- ts]+        +        -- {WITNESS}+ , do   sp      <- pSym SBraceBra+        w       <- pWitness c+        pSym SBraceKet+        return  [(XWitness sp w, sp)]+                +        -- {: WITNESS0 WITNESS0 ... :}+ , do   sp      <- pSym SBraceColonBra+        ws      <- P.many1 (pWitnessAtom c)+        pSym SBraceColonKet+        return  [(XWitness sp w, sp) | w <- ws]+                +        -- EXP0+ , do   (x, sp)  <- pExpAtomSP c+        return  [(x, sp)]+ ]+ <?> "a type, witness or expression argument"+++-- | Parse a variable, constructor or parenthesised expression.+pExpAtom   :: Ord n => Context n -> Parser n (Exp SourcePos n)+pExpAtom c+ = do   (x, _) <- pExpAtomSP c+        return x+++-- | Parse a variable, constructor or parenthesised expression,+--   also returning source position.+pExpAtomSP +        :: Ord n +        => Context n +        -> Parser n (Exp SourcePos n, SourcePos)++pExpAtomSP c+ = P.choice+        -- (EXP2)+ [ do   sp      <- pSym SRoundBra+        t       <- pExp c+        pSym    SRoundKet+        return  (t, sp)+ +        -- The unit data constructor.       + , do   sp        <- pTokSP (KBuiltin BDaConUnit)+        return  (XCon sp dcUnit, sp)++        -- Named algebraic constructors.+ , 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, 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+        return  (XVar sp (UIx   i), sp)++        -- Variables+ , do   (var, sp) <- pVarSP+        return  (XVar sp (UName var), sp)+ ]++ <?> "a variable, constructor, or parenthesised type"+++-- Alt --------------------------------------------------------------------------------------------+-- Case alternatives.+pAlt    :: Ord n => Context n -> Parser n (Alt SourcePos n)+pAlt c+ = do   p       <- pPat c+        pSym    SArrowDashRight+        x       <- pExp c+        return  $ AAlt p x+++-- Patterns.+pPat    :: Ord n +        => Context n -> Parser n (Pat n)+pPat c+ = P.choice+ [      -- 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.+        ((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    (KBuiltin BDaConUnit)+        return  $ PData  dcUnit []++        -- CON BIND BIND ...+ , do   nCon    <- pCon +        bs      <- liftM concat $ P.many (pBinds c)+        return  $ PData (DaConBound nCon) bs]+++-- Binds in patterns can have no type annotation,+-- or can have an annotation if the whole thing is in parens.+pBinds+        :: Ord n +        => Context n -> Parser n [Bind n]+pBinds c+ = P.choice+        -- Plain binder.+ [ do   bs      <- P.many1 pBinder+        return  [T.makeBindFromBinder b (T.tBot T.kData) | b <- bs]++        -- Binder with type, wrapped in parens.+ , do   pSym SRoundBra+        bs      <- P.many1 pBinder+        pTok (KOp ":")+        t       <- pType c+        pSym SRoundKet+        return  [T.makeBindFromBinder b t | b <- bs]+ ]+++-- Bindings ---------------------------------------------------------------------------------------+-- | Parse some `Lets`, also returning the source position where they+--   started.+pLetsSP :: Ord n +        => Context n -> Parser n (Lets SourcePos n, SourcePos)+pLetsSP c+ = P.choice+    [ -- non-recursive let.+      do sp       <- pTokSP (KKeyword ELet)+         (b1, x1) <- pLetBinding c+         return (LLet b1 x1, sp)++      -- recursive let.+    , do sp       <- pTokSP (KKeyword ELetRec)+         P.choice+          -- Multiple bindings in braces+          [ do   pSym SBraceBra+                 lets    <- P.sepEndBy1 (pLetBinding c) (pSym SSemiColon)+                 pSym SBraceKet+                 return (LRec lets, sp)++          -- A single binding without braces.+          , do   ll      <- pLetBinding c+                 return (LRec [ll], sp)+          ]      ++      -- Private region binding.+      --   private BINDER+ (with { BINDER : TYPE ... })? in EXP+    , do sp     <- pTokSP (KKeyword EPrivate)+         +         -- new private region names.+         brs    <- P.manyTill pBinder +                $  P.try $ P.lookAhead $ P.choice +                        [ pTok (KKeyword EIn)+                        , pTok (KKeyword EWith) ]++         let bs =  map (flip T.makeBindFromBinder T.kRegion) brs++         -- witness types.+         r      <- pLetWits c bs Nothing+         return (r, sp)+    +      -- Extend an existing region.+      --   extend BINDER+ using TYPE (with { BINDER : TYPE ...})? in EXP+    , do sp     <- pTokSP (KKeyword EExtend)++         -- parent region+         t      <- pType c+         pTok (KKeyword EUsing)++         -- new private region names.+         brs    <- P.manyTill pBinder +                $  P.try $ P.lookAhead +                         $ P.choice +                                [ pTok (KKeyword EUsing)+                                , pTok (KKeyword EWith)+                                , pTok (KKeyword EIn) ]++         let bs =  map (flip T.makeBindFromBinder T.kRegion) brs+         +         -- witness types+         r      <- pLetWits c bs (Just t)+         return (r, sp)+    ]+    +    +pLetWits :: Ord n +        => Context n+        -> [Bind n] -> Maybe (Type n) +        -> Parser n (Lets SourcePos n)++pLetWits c bs mParent+ = P.choice +    [ do   pKey EWith+           pSym SBraceBra+           wits    <- P.sepBy (P.choice+                        [ -- Named witness binder.+                          do  b    <- pBinder+                              pTok (KOp ":")+                              t    <- pTypeApp c+                              return  $ T.makeBindFromBinder b t+                        +                          -- Ambient witness binding, use for capabilities.+                        , do  t    <- pTypeApp c+                              return  $ BNone t ])+                      (pSym SSemiColon)+           pSym SBraceKet+           return (LPrivate bs mParent wits)+    +    , do   return (LPrivate bs mParent [])+    ]+++-- | A binding for let expression.+pLetBinding +        :: Ord n +        => Context n+        -> Parser n ( Bind n+                    , Exp SourcePos n)+pLetBinding c+ = do   b       <- pBinder++        P.choice+         [ do   -- Binding with full type signature.+                --  BINDER : TYPE = EXP+                pTok    (KOp ":")+                t       <- pType c+                pSym    SEquals+                xBody   <- pExp c++                return  $ (T.makeBindFromBinder b t, xBody) +++         , do   -- Non-function binding with no type signature.+                -- 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+                pSym    SEquals+                xBody   <- pExp c+                let t   = T.tBot T.kData+                return  $ (T.makeBindFromBinder b t, xBody)+++         , do   -- Binding using function syntax.+                ps      <- liftM concat +                        $  P.many (pBindParamSpec c)+        +                P.choice+                 [ do   -- Function syntax with a return type.+                        -- We can make the full type sig for the let-bound+                        -- variable.+                        --   BINDER PARAM1 PARAM2 .. PARAMN : TYPE = EXP+                        pTok (KOp ":")+                        tBody   <- pType c+                        sp      <- pSym SEquals+                        xBody   <- pExp c++                        let x   = expOfParams sp ps xBody+                        let t   = funTypeOfParams c ps tBody+                        return  (T.makeBindFromBinder b t, x)++                        -- Function syntax with no return type.+                        -- We can't make the type sig for the let-bound variable,+                        -- but we can create lambda abstractions with the given +                        -- parameter types.+                        --  BINDER PARAM1 PARAM2 .. PARAMN = EXP+                 , do   sp      <- pSym SEquals+                        xBody   <- pExp c++                        let x   = expOfParams sp ps xBody+                        let t   = T.tBot T.kData+                        return  (T.makeBindFromBinder b t, x) ]+         ]+++-- Stmt -------------------------------------------------------------------------------------------+data Stmt n+        = StmtBind  SourcePos (Bind n) (Exp SourcePos n)+        | StmtMatch SourcePos (Pat n)  (Exp SourcePos n) (Exp SourcePos n)+        | StmtNone  SourcePos (Exp SourcePos n)+++-- | Parse a single statement.+pStmt :: Ord n => Context n -> Parser n (Stmt n)+pStmt c+ = P.choice+ [ -- BINDER = EXP ;+   -- We need the 'try' because a VARIABLE binders can also be parsed+   --   as a function name in a non-binding statement.+   --  +   P.try $ +    do  br      <- pBinder+        sp      <- pSym SEquals+        x1      <- pExp c+        let t   = T.tBot T.kData+        let b   = T.makeBindFromBinder br t+        return  $ StmtBind sp b x1++   -- PAT <- EXP else EXP;+   -- Sugar for a case-expression.+   -- We need the 'try' because the PAT can also be parsed+   --  as a function name in a non-binding statement.+ , P.try $+    do  p       <- pPat c+        sp      <- pSym SArrowDashLeft+        x1      <- pExp c+        pTok (KKeyword EElse)+        x2      <- pExp c+        return  $ StmtMatch sp p x1 x2++        -- EXP+ , do   x               <- pExp c+        return  $ StmtNone (annotOfExp x) x+ ]+++-- | Parse some statements.+pStmts :: Ord n => Context n -> Parser n (Exp SourcePos n)+pStmts c+ = 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+++-- | Make an expression from some statements.+makeStmts :: [Stmt n] -> Maybe (Exp SourcePos n)+makeStmts ss+ = case ss of+        [StmtNone _ x]    +         -> Just x++        StmtNone sp x1 : rest+         | Just x2      <- makeStmts rest+         -> Just $ XLet sp (LLet (BNone (T.tBot T.kData)) x1) x2++        StmtBind sp b x1 : rest+         | Just x2      <- makeStmts rest+         -> Just $ XLet sp (LLet b x1) x2++        StmtMatch sp p x1 x2 : rest+         | Just x3      <- makeStmts rest+         -> Just $ XCase sp x1 +                 [ AAlt p x3+                 , AAlt PDefault x2]++        _ -> Nothing+
+ 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/Lexer.hs 
@@ -1,293 +0,0 @@---- | Reference lexer for core langauge parser. Slow but Simple.-module DDC.Core.Parser.Lexer-        ( -- * Constructors-          isConName, isConStart, isConBody-        , readTwConBuiltin-        , readTcConBuiltin-        , readWbConBuiltin-        , readCon-        -          -- * Variables-        , isVarName, isVarStart, isVarBody-        , readVar--          -- * Lexer-        , lexExp)-where-import DDC.Base.Lexer-import DDC.Core.Exp-import DDC.Core.Parser.Tokens-import Data.Char----- WbCon names ------------------------------------------------------------------- | Read a `WbCon`.-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----- | Textual keywords in the core language.-keywords :: [(String, Tok n)]-keywords- =      [ ("in",         KA KIn)-        , ("of",         KA KOf) -        , ("letrec",     KA KLetRec)-        , ("letregion",  KA KLetRegion)-        , ("withregion", KA KWithRegion)-        , ("let",        KA KLet)-        , ("lazy",       KA KLazy)-        , ("case",       KA KCase)-        , ("purify",     KA KPurify)-        , ("forget",     KA KForget)-        , ("weakeff",    KA KWeakEff)-        , ("weakclo",    KA KWeakClo)-        , ("with",       KA KWith)-        , ("where",      KA KWhere) ]------------------------------------------------------------------------------------- | Lex a string into tokens.----lexExp :: Int -> String -> [Token (Tok String)]-lexExp lineStart str- = lexWord lineStart 1 str- where --  lexWord :: Int -> Int -> String -> [Token (Tok String)]-  lexWord line column w-   = let  tok t = Token t (SourcePos Nothing line column)-          tokA  = tok . KA-          tokN  = tok . KN--          lexMore n rest-           = lexWord line (column + n) rest--     in case w of-        []               -> []        --        ' '  : w'        -> lexMore 1 w'-        '\t' : w'        -> lexMore 8 w'-        '\n' : w'        -> lexWord (line + 1) 1 w'---        -- The unit data constructor-        '(' : ')' : w'   -> tokN (KCon "()")     : lexMore 2 w'--        -- Compound Parens-        '['  : ':' : w'  -> tokA KSquareColonBra : lexMore 2 w'-        ':'  : ']' : w'  -> tokA KSquareColonKet : lexMore 2 w'-        '<'  : ':' : w'  -> tokA KAngleColonBra  : lexMore 2 w'-        ':'  : '>' : w'  -> tokA KAngleColonKet  : lexMore 2 w'--        -- Function Constructors-        '~'  : '>'  : w' -> tokA KArrowTilde     : lexMore 2 w'-        '-'  : '>'  : w' -> tokA KArrowDash      : lexMore 2 w'-        '='  : '>'  : w' -> tokA KArrowEquals    : lexMore 2 w'--        -- Compound symbols-        ':'  : ':'  : w' -> tokA KColonColon     : lexMore 2 w'-        '/'  : '\\' : 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         --        -- 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'-        '<'  : w'       -> tokA KAngleBra        : lexMore 1 w'-        '>'  : w'       -> tokA KAngleKet        : lexMore 1 w'            --        -- Punctuation-        '.'  : w'       -> tokA KDot             : lexMore 1 w'-        '|'  : w'       -> tokA KBar             : lexMore 1 w'-        '^'  : w'       -> tokA KHat             : lexMore 1 w'-        '+'  : w'       -> tokA KPlus            : lexMore 1 w'-        ':'  : w'       -> tokA KColon           : lexMore 1 w'-        ','  : w'       -> tokA KComma           : lexMore 1 w'-        '\\' : w'       -> tokA KBackSlash       : lexMore 1 w'-        ';'  : w'       -> tokA KSemiColon       : lexMore 1 w'-        '_'  : w'       -> tokA KUnderscore      : lexMore 1 w'-        '='  : w'       -> tokA KEquals          : lexMore 1 w'-        '&'  : w'       -> tokA KAmpersand       : lexMore 1 w'-        '-'  : w'       -> tokA KDash            : lexMore 1 w'-        -        -- Bottoms-        '!' : '0' : w'  -> tokA KBotEffect       : lexMore 2 w'-        '$' : '0' : w'  -> tokA KBotClosure      : lexMore 2 w'--        -- Sort Constructors-        '*' : '*' : w'  -> tokA KSortComp        : lexMore 2 w'-        '@' : '@' : w'  -> tokA KSortProp        : lexMore 2 w'        --        -- Kind Constructors-        '*' : w'        -> tokA KKindValue       : lexMore 1 w'-        '%' : w'        -> tokA KKindRegion      : lexMore 1 w'-        '!' : w'        -> tokA KKindEffect      : lexMore 1 w'-        '$' : w'        -> tokA KKindClosure     : lexMore 1 w'-        '@' : w'        -> tokA KKindWitness     : lexMore 1 w'-        -        -- Literal values-        c : cs-         | isDigit c-         , (body, rest)         <- span isDigit cs-         -> tokN (KLit (c:body))                 : lexMore (length (c:body)) rest-        -        -- Named Constructors-        c : cs-         | isConStart c-         , (body,  rest)        <- span isConBody cs-         , (body', rest')       <- case rest of-                                        '#' : rest'     -> (body ++ "#", rest')-                                        _               -> (body, rest)-         -> let readNamedCon s-                 | 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')--        -- Keywords, Named Variables and Witness constructors-        c : cs-         | isVarStart c-         , (body,  rest)        <- span isVarBody cs-         -> let readNamedVar s-                 | Just t <- lookup s keywords-                 = tok t                   : lexMore (length s) rest--                 | Just wc      <- readWbConBuiltin s-                 = tokA (KWbConBuiltin wc) : lexMore (length s) rest-         -                 | Just v       <- readVar s-                 = tokN (KVar v)           : lexMore (length s) rest--                 | otherwise-                 = [tok (KJunk c)]--            in  readNamedVar (c : body)--        -- Error-        c : _   -> [tok $ KJunk c]-        ---- TyCon 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-        , isConStart c-        , and (map isConBody (init cs))-        , 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 `TwCon`. -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-        "Pure"          -> Just TwConPure-        "Empty"         -> Just TwConEmpty-        _               -> Nothing----- | Read a builtin `TcCon` with a non-symbolic name, ---   ie not '->'.-readTcConBuiltin :: String -> Maybe TcCon-readTcConBuiltin ss- = case ss of-        "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 named, user defined `TcCon`.------   We won't know its kind, so fill this in with the Bottom element for ---   computatation kinds (**0).-readCon :: String -> Maybe String-readCon ss-        | isConName ss  = Just ss-        | otherwise     = Nothing----- TyVar names ------------------------------------------------------------------- | String is a variable name.-isVarName :: String -> Bool-isVarName []     = False-isVarName (c:cs) = isVarStart c && (and $ map isVarBody cs)----- | Charater can start a variable name.-isVarStart :: Char -> Bool-isVarStart = isLower-        ---- | Character can be part of a variable body.-isVarBody  :: Char -> Bool-isVarBody c-        = isUpper c || isLower c || isDigit c || c == '_' || c == '\''----- | Read a named, user defined variable.-readVar :: String -> Maybe String-readVar ss-        | isVarName ss  = Just ss-        | otherwise     = Nothing-
+ DDC/Core/Parser/Module.hs view
@@ -0,0 +1,157 @@+{-# OPTIONS -fno-warn-unused-binds #-}+module DDC.Core.Parser.Module+        (pModule)+where+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.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+++-- | Parse a core module.+pModule :: (Ord n, Pretty n) +        => Context n+        -> Parser n (Module P.SourcePos n)+pModule c+ = do   sp      <- pTokSP (KKeyword EModule)+        name    <- pModuleName++        -- Parse header declarations+        heads                   <- P.many (pHeadDecl c)+        let importSpecs_noArity = concat $ [specs  | HeadImportSpecs   specs <- heads ]+        let exportSpecs         = concat $ [specs  | HeadExportSpecs   specs <- heads ]++        let dataDefsLocal       = [def         | HeadDataDef     def       <- heads ]+        let typeDefsLocal       = [(n, (k, t)) | HeadTypeDef     n k t     <- heads ]++        -- 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 ]++        let attachAritySpec (ImportForeignValue n (ImportValueModule mn v t _))+                = ImportForeignValue n (ImportValueModule mn v t (Map.lookup n importArities))++            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        <- 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 }+++---------------------------------------------------------------------------------------------------+-- | Wrapper for a declaration that can appear in the module header.+data HeadDecl n+        -- | Import specifications.+        = HeadImportSpecs  [ImportSpec  n]++        -- | Export specifications.+        | HeadExportSpecs  [ExportSpec  n]++        -- | Data type definitions.+        | HeadDataDef      (DataDef     n)++        -- | Type equations.+        | HeadTypeDef       n (Kind n) (Type n)++        -- | Arity pragmas.+        --   Number of type parameters, value parameters, and boxes for some super.+        | HeadPragmaArity  n Int Int Int+++-- | Parse one of the declarations that can appear in a module header.+pHeadDecl :: (Ord n, Pretty n)+          => Context n -> Parser n (HeadDecl n)++pHeadDecl ctx+ = P.choice +        [ do    imports <- pImportSpecs ctx+                return  $ HeadImportSpecs imports++        , do    exports <- pExportSpecs ctx+                return  $ HeadExportSpecs exports ++        , do    def     <- pDataDef ctx+                return  $ HeadDataDef def++        , do    (n, k, t) <- pTypeDef ctx+                return  $ HeadTypeDef n k t++        , do    pHeadPragma ctx +        ]+++-- | 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+        pSym SEquals+        t       <- pType c+        pSym SSemiColon+        return  (n, k, t)+++-- | Parse one of the pragmas that can appear in the module header.+pHeadPragma :: Context n -> Parser n (HeadDecl n)+pHeadPragma ctx+ = do   (txt, sp)      <- pPragmaSP+        case words $ T.unpack txt of++         -- 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
@@ -0,0 +1,152 @@++module DDC.Core.Parser.Param+        ( ParamSpec     (..)+        , funTypeOfParams+        , expOfParams+        , pBindParamSpecAnnot+        , pBindParamSpec )+where+import DDC.Core.Exp+import DDC.Core.Parser.Type+import DDC.Core.Parser.Context+import DDC.Core.Parser.Base+import DDC.Core.Lexer.Tokens+import qualified DDC.Type.Exp.Simple    as T+import qualified DDC.Control.Parser     as P+++-- | Specification of a function parameter.+--   We can determine the contribution to the type of the function, +--   as well as its expression based on the parameter.+data ParamSpec n+        = ParamType    (Bind n)+        | ParamWitness (Bind n)+        | ParamValue   (Bind n) (Type n) (Type n)+++-- | Build the expression of a function from specifications of its parameters,+--   and the expression for the body.+expOfParams +        :: a+        -> [ParamSpec n]        -- ^ Spec of parameters.+        -> Exp a n              -- ^ Body of function.+        -> Exp a n              -- ^ Expression of whole function.++expOfParams _ [] xBody            = xBody+expOfParams a (p:ps) xBody+ = case p of+        ParamType b     +         -> XLAM a b $ expOfParams a ps xBody+        +        ParamWitness b+         -> XLam a b $ expOfParams a ps xBody++        ParamValue b _ _+         -> XLam a b $ expOfParams a ps xBody+++-- | Build the type of a function from specifications of its parameters,+--   and the type of the body.+funTypeOfParams +        :: Context n+        -> [ParamSpec n]        -- ^ Spec of parameters.+        -> Type n               -- ^ Type of body.+        -> Type n               -- ^ Type of whole function.++funTypeOfParams _ [] tBody        + = tBody++funTypeOfParams c (p:ps) tBody+ = case p of+        ParamType  b    +         -> TForall b +                $ funTypeOfParams c ps tBody++        ParamWitness b+         -> T.tImpl (T.typeOfBind b)+                $ funTypeOfParams c ps tBody++        ParamValue b _eff _clo+         -> T.tFun (T.typeOfBind b)+                $ funTypeOfParams c ps tBody+++-- | Parse a function parameter specification,+--   with an optional type (or kind) annotation.+pBindParamSpec+        :: Ord n+        => Context n -> Parser n [ParamSpec n]++pBindParamSpec c+ = P.choice+ [      -- Value (or type) binder with a type (or kind) annotation.+        pBindParamSpecAnnot c++        -- Value binder without type annotations.+  , do  b       <- pBinder+        return  $  [ ParamValue (T.makeBindFromBinder b (T.tBot T.kData))+                                (T.tBot T.kEffect) (T.tBot T.kClosure) ]+ ]+++-- | Parse a function parameter specification,+--   requiring a full type (or kind) annotation.+---+--       [BIND1 BIND2 .. BINDN : TYPE]+--   or  (BIND : TYPE)+--   or  (BIND : TYPE) { EFFECT | CLOSURE }+--+pBindParamSpecAnnot +        :: Ord n +        => Context n -> Parser n [ParamSpec n]++pBindParamSpecAnnot c+ = P.choice+        -- Type parameter+        -- [BIND1 BIND2 .. BINDN : TYPE]+ [ do   pSym SSquareBra+        bs      <- P.many1 pBinder+        pTok (KOp ":")+        t       <- pType c+        pSym SSquareKet+        return  [ ParamType b +                | b <- zipWith T.makeBindFromBinder bs (repeat t)]++        -- Witness parameter+        -- {BIND : TYPE}+ , do   pSym SBraceBra+        b       <- pBinder+        pTok (KOp ":")+        t       <- pType c+        pSym SBraceKet+        return  [ ParamWitness $ T.makeBindFromBinder b t]++        -- Value parameter with type annotations.+        -- (BIND1 BIND2 .. BINDN : TYPE) +        -- (BIND1 BIND2 .. BINDN : TYPE) { TYPE | TYPE }+ , do   pSym SRoundBra+        bs      <- P.many1 pBinder+        pTok (KOp ":")+        t       <- pType c+        pSym SRoundKet++        (eff, clo) +         <- P.choice+                [ do    pSym SBraceBra+                        eff'    <- pType c+                        pSym SBar+                        clo'    <- pType c+                        pSym SBraceKet+                        return  (eff', clo')+                +                , do    return  (T.tBot T.kEffect, T.tBot T.kClosure) ]+        +        let bLast : bsInit +                = reverse bs++        return  $  [ ParamValue (T.makeBindFromBinder b     t) +                                (T.tBot T.kEffect) (T.tBot T.kClosure)+                        | b <- reverse bsInit]+                ++ [ ParamValue (T.makeBindFromBinder bLast t) eff clo]+ ]+
− DDC/Core/Parser/Tokens.hs 
@@ -1,263 +0,0 @@--module DDC.Core.Parser.Tokens-        ( Tok      (..)-        , describeTok-        , renameTok--        , TokAtom  (..)-        , describeTokAtom--        , TokNamed (..)-        , describeTokNamed)-where-import DDC.Core.Pretty-import DDC.Core.Exp----- TokenFamily ------------------------------------------------------------------- | The family of a token.---   This is used to help generate parser error messages,---   so we can say ''the constructor Cons''---             and ''the keyword case'' etc.-data TokenFamily-        = Symbol-        | Keyword-        | Constructor-        | Index-        | Variable----- | Describe a token family, for parser error messages.-describeTokenFamily :: TokenFamily -> String-describeTokenFamily tf- = case tf of-        Symbol          -> "symbol"-        Keyword         -> "keyword"-        Constructor     -> "constructor"-        Index           -> "index"-        Variable        -> "variable"----- Tok --------------------------------------------------------------------------- | Tokens accepted by the core language parser.-data Tok n-        -- Some junk symbol that isn't part of the language.-        = KJunk Char--        -- An atomic token.-        | KA    !TokAtom --        -- A named token.-        | KN    !(TokNamed n)-        deriving (Eq, Show)----- | Describe a token for parser error messages.-describeTok :: Pretty n => Tok n -> String-describeTok kk- = case kk of-        KJunk c         -> "character " ++ show c-        KA ta           -> describeTokAtom  ta-        KN tn           -> describeTokNamed tn----- | Apply a function to all the names in a `Tok`.-renameTok-        :: Ord n2-        => (n1 -> n2) -> Tok n1 -> Tok n2--renameTok f kk- = case kk of-        KJunk s -> KJunk s-        KA t    -> KA t-        KN t    -> KN $ renameTokNamed f t----- TokAtom ----------------------------------------------------------------------- | Atomic tokens, that don't contain user-defined names.-data TokAtom-        -- parens-        = KRoundBra-        | KRoundKet-        | KSquareBra-        | KSquareKet-        | KBraceBra-        | KBraceKet-        | KAngleBra-        | KAngleKet--        -- compound parens-        | KSquareColonBra-        | KSquareColonKet-        | KAngleColonBra-        | KAngleColonKet--        -- punctuation-        | KDot-        | KBar-        | KHat-        | KPlus-        | KColon-        | KComma-        | KBackSlash-        | KSemiColon-        | KUnderscore-        | KEquals-        | KAmpersand-        | KDash-        | KColonColon-        | KBigLambda--        -- symbolic constructors-        | KSortComp-        | KSortProp-        | KKindValue-        | KKindRegion-        | KKindEffect-        | KKindClosure-        | KKindWitness-        | KArrowTilde-        | KArrowDash-        | KArrowEquals--        -- bottoms-        | KBotEffect-        | KBotClosure--        -- expression keywords-        | KWith-        | KWhere-        | KIn-        | KLet-        | KLazy-        | KLetRec-        | KLetRegion-        | KWithRegion-        | KCase-        | KOf-        | KWeakEff-        | KWeakClo-        | KPurify-        | KForget--        -- debruijn indices-        | KIndex Int--        -- builtin names-        | KTwConBuiltin TwCon-        | KWbConBuiltin WbCon-        | KTcConBuiltin TcCon-        deriving (Eq, Show)----- | Describe a `TokAtom`, for parser error messages.-describeTokAtom  :: TokAtom -> String-describeTokAtom ta- = let  (family, str)           = describeTokAtom' ta-   in   describeTokenFamily family ++ " " ++ show str--describeTokAtom' :: TokAtom -> (TokenFamily, String)-describeTokAtom' ta- = case ta of-        -- parens-        KRoundBra               -> (Symbol, "(")-        KRoundKet               -> (Symbol, ")")-        KSquareBra              -> (Symbol, "[")-        KSquareKet              -> (Symbol, "]")-        KBraceBra               -> (Symbol, "{")-        KBraceKet               -> (Symbol, "}")-        KAngleBra               -> (Symbol, "<")-        KAngleKet               -> (Symbol, ">")--        -- compound parens-        KSquareColonBra         -> (Symbol, "[:")-        KSquareColonKet         -> (Symbol, ":]")-        KAngleColonBra          -> (Symbol, "<:")-        KAngleColonKet          -> (Symbol, ":>")--        -- punctuation-        KDot                    -> (Symbol, ".")-        KBar                    -> (Symbol, "|")-        KHat                    -> (Symbol, "^")-        KPlus                   -> (Symbol, "+")-        KColon                  -> (Symbol, ":")-        KComma                  -> (Symbol, ",")-        KBackSlash              -> (Symbol, "\\")-        KSemiColon              -> (Symbol, ";")-        KUnderscore             -> (Symbol, "_")-        KEquals                 -> (Symbol, "=")-        KAmpersand              -> (Symbol, "&")-        KDash                   -> (Symbol, "-")-        KColonColon             -> (Symbol, "::")-        KBigLambda              -> (Symbol, "/\\")--        -- symbolic constructors-        KSortComp               -> (Constructor, "**")-        KSortProp               -> (Constructor, "@@")-        KKindValue              -> (Constructor, "*")-        KKindRegion             -> (Constructor, "%")-        KKindEffect             -> (Constructor, "!")-        KKindClosure            -> (Constructor, "$")-        KKindWitness            -> (Constructor, "@")-        KArrowTilde             -> (Constructor, "~>")-        KArrowDash              -> (Constructor, "->")-        KArrowEquals            -> (Constructor, "=>")--        -- bottoms-        KBotEffect              -> (Constructor, "!0")-        KBotClosure             -> (Constructor, "!$")--        -- expression keywords-        KWith                   -> (Keyword, "with")-        KWhere                  -> (Keyword, "where")-        KIn                     -> (Keyword, "in")-        KLet                    -> (Keyword, "let")-        KLazy                   -> (Keyword, "lazy")-        KLetRec                 -> (Keyword, "letrec")-        KLetRegion              -> (Keyword, "letregion")-        KWithRegion             -> (Keyword, "withregion")-        KCase                   -> (Keyword, "case")-        KOf                     -> (Keyword, "of")-        KWeakEff                -> (Keyword, "weakeff")-        KWeakClo                -> (Keyword, "weakclo")-        KPurify                 -> (Keyword, "purify")-        KForget                 -> (Keyword, "forget")-        -        -- debruijn indices-        KIndex i                -> (Index,   "^" ++ show i)--        -- builtin names-        KTwConBuiltin tw        -> (Constructor, renderPlain $ ppr tw)-        KWbConBuiltin wi        -> (Constructor, renderPlain $ ppr wi)-        KTcConBuiltin tc        -> (Constructor, renderPlain $ ppr tc)----- TokNamed ---------------------------------------------------------------------- | A token witn a user-defined name.-data TokNamed 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- = 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 -        :: Ord n2-        => (n1 -> n2) -> TokNamed n1 -> TokNamed n2--renameTokNamed f kk-  = case kk of-        KCon c           -> KCon $ f c-        KVar c           -> KVar $ f c-        KLit c           -> KLit $ f c-
+ DDC/Core/Parser/Type.hs view
@@ -0,0 +1,238 @@++-- | Parser for type expressions.+module DDC.Core.Parser.Type+        ( pType+        , pTypeAtom+        , pTypeApp+        , pBinder+        , pIndex+        , pTok+        , pTokAs)+where+import DDC.Core.Parser.Context+import DDC.Core.Parser.Base+import DDC.Core.Lexer.Tokens   +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 n -> Parser n (Type n)++pType c  + =      pTypeSum c+ <?> "a type"+++--  | Parse a type sum.+pTypeSum +        :: Ord n +        => Context n -> Parser n (Type n)+pTypeSum c+ = do   t1      <- pTypeForall c+        P.choice +         [ -- Type sums.+           -- T2 + T3+           do   pTok (KOp "+")+                t2      <- pTypeSum c+                return  $ TSum $ TS.fromList (tBot sComp) [t1, t2]+                +         , do   return t1 ]+ <?> "a type"+++-- | Parse a binder.+pBinder :: Ord n => Parser n (Binder n)+pBinder+ = P.choice+        -- Named binders.+        [ do    v       <- pVar+                return  $ RName v+                +        -- Anonymous binders.+        , do    pSym    SHat+                return  $ RAnon +        +        -- Vacant binders.+        , do    pSym    SUnderscore+                return  $ RNone ]+ <?> "a binder"+++-- | Parse a quantified type.+pTypeForall +        :: Ord n +        => Context n -> Parser n (Type n)+pTypeForall c+ = P.choice+         [ -- 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   pSym SSquareBra+                bs      <- P.many1 pBinder+                pTok (KOp ":")+                k       <- pTypeSum c+                pSym SSquareKet+                pSym SDot++                body    <- pTypeForall c++                return  $ foldr TForall body +                        $ map (\b -> makeBindFromBinder b k) bs++           -- Body type+         , do   pTypeFun c]+ <?> "a type"+++-- | Parse a function type.+pTypeFun +        :: Ord n +        => Context n -> Parser n (Type n)++pTypeFun c+ = do   t1      <- pTypeApp c+        P.choice +         [ -- T1 ~> T2+           do   pSym    SArrowTilde+                t2      <- pTypeForall c+                return  $ TApp (TApp (TCon (TyConKind KiConFun)) t1) t2++           -- T1 => T2+         , do   pSym    SArrowEquals+                t2      <- pTypeForall c+                return  $ TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2++           -- T1 -> T2+         , do   pSym    SArrowDashRight+                t2      <- pTypeForall c+                return $ t1 `tFun`   t2++           -- Body type+         , do   return t1 ]+ <?> "an atomic type or type application"+++-- | Parse a type application.+pTypeApp +        :: Ord n +        => Context n -> Parser n (Type n)+pTypeApp c+ = do   (t:ts)  <- P.many1 (pTypeAtom c)+        return  $  foldl TApp t ts+ <?> "an atomic type or type application"+++-- | Parse a variable, constructor or parenthesised type.+pTypeAtom +        :: Ord n +        => Context n -> Parser n (Type n)+pTypeAtom c+ = P.choice+        -- (~>) and (=>) and (->) and (TYPE2)+        [ -- (~>)+          do    pTok (KOpVar "~>")+                return (TCon $ TyConKind KiConFun)++          -- (=>)+        , do    pTok (KOpVar "=>")+                return (TCon $ TyConWitness TwConImpl)++          -- (->)+        , do    pTok (KOpVar "->")+                return (TCon $ TyConSpec TcConFun)++        -- (TYPE2)+        , do    pSym SRoundBra+                t       <- pTypeSum c+                pSym SRoundKet+                return t ++        -- Named type constructors+        , do    so      <- pSoCon+                return  $ TCon (TyConSort so)++        , do    ki      <- pKiCon+                return  $ TCon (TyConKind ki)++        , do    tc      <- pTcCon+                return  $ TCon (TyConSpec tc)++        , do    tc      <- pTwCon+                return  $ TCon (TyConWitness tc)++        , do    tc      <- pTyConNamed+                return  $ TCon tc+            +        -- Bottoms.+        , 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+        --  field with the bottom element of computation kinds. This isn't+        --  really part of the language, but makes sense implentation-wise.+        , do    v       <- pVar+                return  $  TVar (UName v)++        , do    i       <- pIndex+                return  $  TVar (UIx i)+        ]+ <?> "an atomic type"+++-------------------------------------------------------------------------------+-- | Parse a builtin sort constructor.+pSoCon :: Parser n SoCon+pSoCon  =   P.pTokMaybe f+        <?> "a sort constructor"+ 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 (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 (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 (KBuiltin (BTwCon c))) = Just c+       f _                          = Nothing+++-- | Parse a user defined type constructor.+pTyConNamed :: Parser n (TyCon n)+pTyConNamed  +        =   P.pTokMaybe f+        <?> "a type constructor"+ where  f (KN (KCon n))          = Just (TyConBound (UName n) (tBot kData))+        f _                      = Nothing+
+ DDC/Core/Parser/Witness.hs view
@@ -0,0 +1,104 @@++module DDC.Core.Parser.Witness+        ( pWitness+        , pWitnessApp+        , pWitnessAtom) +where+import DDC.Core.Parser.Type+import DDC.Core.Parser.Context+import DDC.Core.Parser.Base+import DDC.Core.Lexer.Tokens+import DDC.Core.Exp+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 n -> Parser n (Witness SourcePos n)+pWitness c = pWitnessJoin c+++-- | Parse a witness join.+pWitnessJoin +        :: Ord n +        => Context n -> Parser n (Witness SourcePos n)+pWitnessJoin c+   -- WITNESS  or  WITNESS & WITNESS+ = do   w1      <- pWitnessApp c+        P.choice +         [ do   return w1 ]+++-- | Parse a witness application.+pWitnessApp +        :: Ord n +        => Context n -> Parser n (Witness SourcePos n)++pWitnessApp c+  = do  (x:xs)  <- P.many1 (pWitnessArgSP c)+        let x'  = fst x+        let sp  = snd x+        let xs' = map fst xs+        return  $ foldl (WApp sp) x' xs'++ <?> "a witness expression or application"+++-- | Parse a witness argument.+pWitnessArgSP +        :: Ord n +        => Context n -> Parser n (Witness SourcePos n, SourcePos)++pWitnessArgSP c+ = P.choice+ [ -- [TYPE]+   do   sp      <- pSym SSquareBra+        t       <- pType c+        pSym    SSquareKet+        return  (WType sp t, sp)++   -- WITNESS+ , do   pWitnessAtomSP c ]++++-- | Parse a variable, constructor or parenthesised witness.+pWitnessAtom   +        :: Ord n +        => Context n -> Parser n (Witness SourcePos n)++pWitnessAtom c   +        = liftM fst (pWitnessAtomSP c)+++-- | Parse a variable, constructor or parenthesised witness,+--   also returning source position.+pWitnessAtomSP +        :: Ord n +        => Context n -> Parser n (Witness SourcePos n, SourcePos)++pWitnessAtomSP c+ = P.choice+   -- (WITNESS)+ [ do   sp      <- pSym SRoundBra+        w       <- pWitness c+        pSym SRoundKet+        return  (w, sp)++   -- Named constructors+ , do   (con, sp) <- pConSP+        return  (WCon sp (WiConBound (UName con) (T.tBot T.kWitness)), sp)+                +   -- Debruijn indices+ , do   (i, sp) <- pIndexSP+        return  (WVar sp (UIx   i), sp)++   -- Variables+ , do   (var, sp) <- pVarSP+        return  (WVar sp (UName var), sp) ]++ <?> "a witness"
− DDC/Core/Predicates.hs 
@@ -1,97 +0,0 @@---- | Simple predicates on core expressions.-module DDC.Core.Predicates-        ( -- * Atoms-          isXVar,  isXCon-        , isAtomW, isAtomX--          -- * Lambdas-        , isXLAM, isXLam-        , isLambdaX--          -- * Applications-        , isXApp--          -- * 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 a witness is a `WVar` or `WCon`.-isAtomW :: Witness n -> Bool-isAtomW ww- = case ww of-        WVar{}          -> True-        WCon{}          -> 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----- 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----- Patterns ---------------------------------------------------------------------- | Check whether an alternative is a `PDefault`.-isPDefault :: Pat n -> Bool-isPDefault PDefault     = True-isPDefault _            = False-
DDC/Core/Pretty.hs view
@@ -1,237 +1,251 @@--- | Pretty printing for core expressions.+{-# LANGUAGE TypeFamilies #-}++-- | 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+        , pprDataDef,    pprDataCtor+        , pprTypeDef) where-import DDC.Core.Exp-import DDC.Core.Compounds-import DDC.Core.Predicates-import DDC.Type.Pretty-import DDC.Type.Compounds-import DDC.Type.Predicates-import DDC.Base.Pretty+import DDC.Core.Module+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.Data.Pretty+import Data.List+import Prelude          hiding ((<$>))  --- Binder ------------------------------------------------------------------------ | 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 "_"+-- ModuleName -------------------------------------------------------------------------------------+instance Pretty ModuleName where+ ppr (ModuleName parts)+        = text $ intercalate "." parts  --- | 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 ((cat $ map pprBinderSep rs) <+> text ":" <+> ppr t) <> dot+-- Module -----------------------------------------------------------------------------------------+instance (Pretty n, Eq n) => Pretty (Module a n) where+ data PrettyMode (Module a n)+        = PrettyModeModule+        { modeModuleLets                :: PrettyMode (Lets a n)+        , modeModuleSuppressImports     :: Bool +        , modeModuleSuppressExports     :: Bool } + pprDefaultMode+        = PrettyModeModule+        { modeModuleLets                = pprDefaultMode+        , modeModuleSuppressImports     = False+        , modeModuleSuppressExports     = False } --- Exp -------------------------------------------------------------------------instance (Pretty n, Eq n) => Pretty (Exp a n) where- pprPrec d xx-  = case xx of-        XVar  _ u       -> ppr u-        XCon  _ tc      -> ppr tc+ pprModePrec mode _+        ModuleCore +        { moduleName            = name+        , moduleExportTypes     = exportTypes+        , moduleExportValues    = exportValues+        , moduleImportTypes     = importTypes+        , moduleImportCaps      = importCaps+        , moduleImportValues    = importValues+        , moduleImportDataDefs  = importData+        , moduleImportTypeDefs  = importType+        , moduleDataDefsLocal   = localData+        , moduleTypeDefsLocal   = localType+        , moduleBody            = body }+  = {-# SCC "ppr[Module]" #-}+    let +        (lts, _)                = splitXLets body         -        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)-                 <>  ppr xBody--        XLam{}-         -> let Just (bs, xBody) = takeXLams xx-                groups = partitionBindsByType bs-            in  pprParen' (d > 1)-                 $  (cat $ map (pprBinderGroup (text "\\")) groups) -                 <> breakWhen (not $ isSimpleX xBody)-                 <> ppr xBody+        -- Exports --------------------+        dExportTypes+         | null $ exportTypes   = empty+         | otherwise            = (vcat $ map pprExportType  exportTypes)  <> line -        XApp _ x1 x2-         -> pprParen' (d > 10)-         $  pprPrec 10 x1 -                <> nest 4 (breakWhen (not $ isSimpleX x2) -                           <> pprPrec 11 x2)+        dExportValues+         | null $ exportValues  = empty+         | otherwise            = (vcat $ map pprExportValue exportValues) <> line -        XLet _ lts x-         ->  pprParen' (d > 2)-         $   ppr lts <+> text "in"-         <$> ppr x+        -- Imports --------------------+        dImportTypes+         | null $ importTypes   = empty+         | otherwise            = (vcat $ map pprImportType  importTypes)  <> line -        XCase _ x alts-         -> pprParen' (d > 2) -         $  (nest 2 $ text "case" <+> ppr x <+> text "of" <+> lbrace <> line-                <> (vcat $ punctuate semi $ map ppr alts))-         <> line -         <> rbrace+        dImportCaps+         | null $ importCaps    = empty+         | otherwise            = (vcat $ map pprImportCap   importCaps)   <> line -        XCast _ cc x-         ->  pprParen' (d > 2)-         $   ppr cc <+> text "in"-         <$> ppr x+        dImportValues+         | null $ importValues  = empty+         | otherwise            = (vcat $ map pprImportValue importValues) <> line -        XType    t      -> text "[" <> ppr t <> text "]"-        XWitness w      -> text "<" <> ppr w <> text ">"+        docsImportsExports+         -- If we're suppressing imports, then don't print it.+         | modeModuleSuppressImports mode +         = empty+         +         -- 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 <> dImportCaps <> dImportValues+                +        -- Data Definitions -----+        docsDataImport+         | null importData = empty+         | otherwise+         = line <> vsep  (map (\i -> text "import" <+> ppr i) $ importData) --- 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)+        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) --- | 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+        docsTypeLocal+         | null localType  = empty+         | otherwise+         = line <> vsep  (map pprTypeDef localType) +        pprLts = pprModePrec (modeModuleLets mode) 0 --- Alt -------------------------------------------------------------------------instance (Pretty n, Eq n) => Pretty (Alt a n) where- ppr (AAlt p x)-  = ppr p <+> nest 1 (line <> nest 3 (text "->" <+> ppr x))+    in  text "module" <+> ppr name +         <+> docsImportsExports+         <>  docsDataImport+         <>  docsDataLocal+         <>  docsTypeImport+         <>  docsTypeLocal+         <>  (case lts of+                []       -> empty+                [LRec[]] -> empty+                _        -> text "with" <$$> (vcat $ map pprLts lts))  --- Cast ------------------------------------------------------------------------instance (Pretty n, Eq n) => Pretty (Cast n) where- ppr cc-  = case cc of-        CastWeakenEffect  eff   -         -> text "weakeff" <+> brackets (ppr eff)--        CastWeakenClosure clo-         -> text "weakclo" <+> brackets (ppr clo)--        CastPurify w-         -> text "purify"  <+> angles   (ppr w)+-- Exports ----------------------------------------------------------------------------------------+-- | Pretty print an exported type definition.+pprExportType :: (Pretty n, Pretty t) => (n, ExportSource n t) -> Doc+pprExportType (n, esrc)+ = case esrc of+        ExportSourceLocal _n k+         -> text "export type" <+> padL 10 (ppr n) <+> text ":" <+> ppr k <> semi -        CastForget w-         -> text "forget"  <+> angles   (ppr w)+        ExportSourceLocalNoType _n +         -> text "export type" <+> padL 10 (ppr n) <> semi  --- Lets ------------------------------------------------------------------------instance (Pretty n, Eq n) => Pretty (Lets a n) where- ppr lts-  = case lts of-        LLet m b x-         -> let dBind = if isBot (typeOfBind b)-                          then ppr (binderOfBind b)-                          else ppr b-            in  text "let"-                 <+> align (  dBind <> ppr m-                           <> nest 2 ( breakWhen (not $ isSimpleX x)-                                     <> text "=" <+> align (ppr x)))+-- | Pretty print an exported value definition.+pprExportValue :: (Pretty n, Pretty t) => (n, ExportSource n t) -> Doc+pprExportValue (n, esrc)+ = case esrc of+        ExportSourceLocal _n t+         -> text "export value" <+> padL 10 (ppr n) <+> text ":" <+> ppr t <> semi -        LRec bxs-         -> let pprLetRecBind (b, x)-                 =   ppr (binderOfBind b)-                 <+> text ":"-                 <+> ppr (typeOfBind b)-                 <>  nest 2 (  breakWhen (not $ isSimpleX x)-                            <> text "=" <+> align (ppr x))-        -           in   (nest 2 $ text "letrec"-                  <+> lbrace -                  <>  (  line -                      <> (vcat $ punctuate (semi <> line)-                               $ map pprLetRecBind bxs)))-                <$> rbrace+        ExportSourceLocalNoType _n+         -> text "export value" <+> padL 10 (ppr n) <> semi  -        LLetRegion b []-         -> text "letregion"-                <+> ppr (binderOfBind b)--        LLetRegion b bs-         -> text "letregion"-                <+> ppr (binderOfBind b)-                <+> text "with"-                <+> braces (cat $ punctuate (text "; ") $ map ppr bs)+-- Imports ----------------------------------------------------------------------------------------+-- | Pretty print a type import.+pprImportType :: (Pretty n, Pretty t) => (n, ImportType n t) -> Doc+pprImportType (n, isrc)+ = case isrc of+        ImportTypeAbstract k+         -> text "import foreign abstract type" <> line+         <> indent 8 (ppr n <+> text ":" <+> ppr k <> semi)+         <> line -        LWithRegion b-         -> text "withregion"-                <+> ppr b+        ImportTypeBoxed k+         -> text "import foreign boxed type" <> line+         <> indent 8 (ppr n <+> text ":" <+> ppr k <> semi)+         <> line  -instance (Pretty n, Eq n) => Pretty (LetMode n) where- ppr lm-  = case lm of-        LetStrict        -> empty-        LetLazy Nothing  -> text " lazy"-        LetLazy (Just w) -> text " lazy <" <> ppr w <> text ">"+-- | 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  --- Witness ---------------------------------------------------------------------instance (Pretty n, Eq n) => Pretty (Witness n) where- pprPrec d ww-  = case ww of-        WVar n          -> ppr n-        WCon wc         -> ppr wc+-- | Pretty print a value import.+pprImportValue :: (Pretty n, Pretty t) => (n, ImportValue n t) -> Doc+pprImportValue (n, isrc)+ = case isrc of+        ImportValueModule _mn _nSrc t Nothing+         ->        text "import value" <+> padL 10 (ppr n) <+> text ":" <+> ppr t <> semi -        WApp w1 w2-         -> pprParen (d > 10) (ppr w1 <+> pprPrec 11 w2)-         -        WJoin w1 w2-         -> pprParen (d > 9)  (ppr w1 <+> text "&" <+> ppr w2)+        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 ] -        WType t         -> text "[" <> ppr t <> text "]"+        ImportValueSea _var t+         -> text "import foreign c value" <> line+         <> indent 8 (padL 15 (ppr n) <+> text ":" <+> ppr t <> semi)+         <> line  -instance (Pretty n, Eq n) => Pretty (WiCon n) where- ppr wc-  = case wc of-        WiConBuiltin wb -> ppr wb-        WiConBound   u  -> ppr u+-- DataDef ----------------------------------------------------------------------------------------+instance (Pretty n, Eq n) => Pretty (DataDef n) where+ pprPrec _ def = pprDataDef def  -instance Pretty WbCon where- ppr wb-  = case wb of-        WbConPure       -> text "pure"-        WbConEmpty      -> text "empty"-        WbConUse        -> text "use"-        WbConRead       -> text "read"-        WbConAlloc      -> text "alloc"-+-- | 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+        Just ctors+         -> indent 8+          $ vcat [ ppr ctor <> semi | ctor <- ctors] --- Utils -----------------------------------------------------------------------breakWhen :: Bool -> Doc-breakWhen True   = line-breakWhen False  = space+        Nothing+         -> text "LARGE")+  <> line <> rbrace <> line  -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+-- DataCtor ---------------------------------------------------------------------------------------+instance (Pretty n, Eq n) => Pretty (DataCtor n) where+ pprPrec _ def = pprDataCtor def  -parens' :: Doc -> Doc-parens' d = lparen <> nest 1 d <> rparen+-- | 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+                        ++ [dataCtorResultType ctor])))+   +-- 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/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/LiftW.hs 
@@ -1,116 +0,0 @@---- | Lift deBruijn indices in witnesses.-module DDC.Core.Transform.LiftW-        (LiftW(..))-where-import DDC.Core.Exp---class LiftW (c :: * -> *) where- -- | Lift indices that are at least a the given depth by some number- --   of levels- liftAtDepthW-        :: forall n. Ord n-        => Int          -- ^ Number of levels to lift.-        -> Int          -- ^ Current binding depth.-        -> c n          -- ^ Lift witness variable indices in this thing.-        -> c n- - -- | Wrapper for `liftAtDepthX` that starts at depth 0.       - liftW  :: forall n. Ord n-        => Int          -- ^ Number of levels to lift.-        -> c n          -- ^ Lift witness variable indices in this thing.-        -> c n-        - liftW n xx  = liftAtDepthW n 0 xx-  --instance LiftW Bound where- liftAtDepthW n d uu-  = case uu of-        UName{}         -> uu-        UPrim{}         -> uu-        UIx i t -         | d <= i       -> UIx (i + n) t-         | otherwise    -> uu---instance LiftW (Exp a) where- liftAtDepthW n d xx-  = let down = liftAtDepthW n d-    in case xx of-        XVar{}          -> xx-        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 (liftAtDepthW n (d + 1) x)-         -        XLet a lets x   -         -> let (lets', levels) = liftAtDepthXLets n d lets -            in  XLet a lets' (liftAtDepthW n (d + levels) x)--        XCase a x alts  -> XCase a (down x) (map down alts)-        XCast a cc x    -> XCast a cc (down x)-        XType{}         -> xx-        XWitness w      -> XWitness (down w)-         --instance LiftW LetMode where- liftAtDepthW n d m-  = case m of-        LetStrict        -> m-        LetLazy Nothing  -> m-        LetLazy (Just w) -> LetLazy (Just $ liftAtDepthW n d w)---instance LiftW (Alt a) where- liftAtDepthW n d (AAlt p x)-  = case p of-	PDefault -         -> AAlt PDefault (liftAtDepthW n d x)--	PData _ bs -         -> let d' = d + countBAnons bs-	    in  AAlt p (liftAtDepthW n d' x)---instance LiftW Witness where- liftAtDepthW n d ww-  = let down = liftAtDepthW n d-    in case ww of-        WVar  u         -> WVar (down u)-        WCon{}          -> ww-        WApp  w1 w2     -> WApp  (down w1) (down w2)-        WJoin w1 w2     -> WJoin (down w1) (down w2)-        WType{}         -> ww-        --liftAtDepthXLets-        :: forall a n. Ord n-        => Int             -- ^ 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--liftAtDepthXLets n d lts- = case lts of-        LLet m b x-         -> let m'  = liftAtDepthW n d m-                inc = countBAnons [b]-                x'  = liftAtDepthW n (d+inc) x-            in  (LLet m' b x', inc)--        LRec bs-         -> let inc = countBAnons (map fst bs)-                bs' = map (\(b,e) -> (b, liftAtDepthW n (d+inc) e)) bs-            in  (LRec bs', inc)--        LLetRegion _b bs -> (lts, countBAnons bs)-        LWithRegion _    -> (lts, 0)---countBAnons = length . filter isAnon- where	isAnon (BAnon _) = True-	isAnon _	 = False--
− DDC/Core/Transform/LiftX.hs 
@@ -1,96 +0,0 @@---- | Lift deBruijn indices in expressions.-module DDC.Core.Transform.LiftX-        (LiftX(..))-where-import DDC.Core.Exp---class LiftX (c :: * -> *) where- -- | Lift indices that are at least the given depth by some number- --   of levels.- liftAtDepthX-        :: forall n. Ord n-        => Int          -- ^ Number of levels to lift.-        -> Int          -- ^ Current binding depth.-        -> c n          -- ^ Lift expression indices in this thing.-        -> c n- - -- | Wrapper for `liftAtDepthX` that starts at depth 0.       - liftX  :: forall n. Ord n-        => Int          -- ^ Number of levels to lift.-        -> c n          -- ^ Lift expression indices in this thing.-        -> c n-        - liftX n xx  = liftAtDepthX n 0 xx-  --instance LiftX Bound where- liftAtDepthX n d uu-  = case uu of-        UName{}         -> uu-        UPrim{}         -> uu-        UIx i t -         | d <= i       -> UIx (i + n) t-         | otherwise    -> uu---instance LiftX (Exp a) where- liftAtDepthX n d xx-  = let down = liftAtDepthX n d-    in case xx of-        XVar a u        -> XVar a (down 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 (liftAtDepthX n (d + 1) x)-         -        XLet a lets x   -         -> let (lets', levels) = liftAtDepthXLets n d lets -            in  XLet a lets' (liftAtDepthX n (d + levels) x)--        XCase a x alts  -> XCase a (down x) (map down alts)-        XCast a cc x    -> XCast a cc (down x)-        XType{}         -> xx-        XWitness{}      -> xx-         --instance LiftX (Alt a) where- liftAtDepthX n d (AAlt p x)-  = case p of-	PDefault -         -> AAlt PDefault (liftAtDepthX n d x)--	PData _ bs -         -> let d' = d + countBAnons bs-	    in  AAlt p (liftAtDepthX n d' x)-        --liftAtDepthXLets-        :: forall a n. Ord n-        => Int             -- ^ 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--liftAtDepthXLets n d lts- = case lts of-        LLet m b x-         -> let inc = countBAnons [b]-                x'  = liftAtDepthX n (d+inc) x-            in  (LLet m b x', inc)--        LRec bs-         -> let inc = countBAnons (map fst bs)-                bs' = map (\(b,e) -> (b, liftAtDepthX n (d+inc) e)) bs-            in  (LRec bs', inc)--        LLetRegion _b bs -> (lts, countBAnons bs)-        LWithRegion _    -> (lts, 0)---countBAnons = length . filter isAnon- where	isAnon (BAnon _) = True-	isAnon _	 = False--
+ DDC/Core/Transform/MapT.hs view
@@ -0,0 +1,117 @@++module DDC.Core.Transform.MapT+        (mapT)+where+import DDC.Core.Exp.Annot.Exp++type  MAPT m c n +        = (Type n -> m (Type n)) -> c n -> m (c n)+++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 :: forall n. MAPT m c n+++instance Monad m => MapT m (Exp a) where+ mapT :: forall n. MAPT  m (Exp a) n+ mapT f xx+  = let down :: forall (c :: * -> *). (Monad m, MapT m c) => c n -> m (c n)+        down = mapT f+    in case xx of  +        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 Monad m => MapT m (Lets a) where+ mapT :: forall n. MAPT m (Lets a) n+ mapT f lts+  = 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+         -> 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 :: 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+++instance Monad m => MapT m Pat where+ mapT :: forall n. MAPT m Pat n+ mapT f pat+  = let down :: forall (c :: * -> *). (Monad m, MapT m c) => c n -> m (c n)+        down =  mapT f+    in case pat of+        PDefault        -> pure PDefault+        PData dc bs     -> PData dc <$> mapM down bs+++instance Monad m => MapT m (Witness a) where+ mapT :: forall n. MAPT m (Witness a) n+ mapT f ww+  = 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{}          -> pure ww+        WApp  a w1 w2   -> WApp  a <$> down w1 <*> down w2+        WType a t       -> WType a <$> f t+++instance Monad m => MapT m (Cast a) where+ mapT :: forall n. MAPT m  (Cast a) n+ mapT f cc+  = let down :: forall (c :: * -> *). (Monad m, MapT m c) => c n -> m (c n)+        down =  mapT f+    in case cc of+        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
@@ -0,0 +1,92 @@++module DDC.Core.Transform.Reannotate+        (Reannotate (..))+where+import DDC.Core.Module+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 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+ reannotateM f+     (ModuleCore name isHeader+                 exportKinds   exportTypes +                 importKinds   importCaps   importTypes  importDataDefs importTypeDefs+                 dataDefsLocal typeDefsLocal+                 body)++  = do  body'   <- reannotateM f body+        return  $  ModuleCore name isHeader+                        exportKinds  exportTypes+                        importKinds  importCaps   importTypes  importDataDefs importTypeDefs+                        dataDefsLocal typeDefsLocal+                        body'+++instance Reannotate Exp where+ reannotateM f xx+  = let down x   = reannotateM f x+    in case xx of+        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+ reannotateM f xx+  = let down x  = reannotateM f x+    in case xx of+        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+ reannotateM f aa+  = case aa of+        AAlt w x                -> AAlt w <$> reannotateM f x+++instance Reannotate Cast where+ reannotateM f cc+  = let down x  = reannotateM f x+    in case cc of+        CastWeakenEffect eff    -> pure $ CastWeakenEffect eff+        CastPurify w            -> CastPurify <$> down w+        CastBox                 -> pure CastBox+        CastRun                 -> pure CastRun+++instance Reannotate Witness where+ reannotateM f ww+  = let down x = reannotateM f x+    in case ww of+        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
@@ -0,0 +1,32 @@++module DDC.Core.Transform.Rename+        ( Rename(..)++        -- * Substitution states+        , Sub(..)++        -- * Binding stacks+        , BindStack(..)+        , pushBind+        , pushBinds+        , substBound++        -- * Rewriting binding occurences+        , bind1, bind1s, bind0, bind0s++        -- * Rewriting bound occurences+        , use1,  use0)+where+import DDC.Core.Exp.Annot.Exp+import DDC.Type.Transform.Rename+++instance Rename (Witness a) where+ renameWith sub ww+  = let down x   = renameWith x+    in case ww of+        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)+        WType a t       -> WType a (down sub t)+
DDC/Core/Transform/SpreadX.hs view
@@ -1,12 +1,11 @@ --- | Spread type annotations from binders and the environment into bound---   occurrences of variables and constructors. module DDC.Core.Transform.SpreadX         (SpreadX(..)) where-import DDC.Core.Exp-import DDC.Core.Compounds+import DDC.Core.Module+import DDC.Core.Exp.Annot import DDC.Type.Transform.SpreadT+import Control.Monad import DDC.Type.Env                     (Env) import qualified DDC.Type.Env           as Env @@ -22,12 +21,104 @@          => Env n -> Env n -> c n -> c n  +---------------------------------------------------------------------------------------------------+instance SpreadX (Module a) where+ spreadX kenv tenv mm@ModuleCore{}+  = 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 $ 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+  +        , moduleTypeDefsLocal+                = map (\(n, (k, t)) -> (n, (spreadT kenv k, spreadT kenv t)))+                $ moduleTypeDefsLocal mm++        , moduleBody           +                 = spreadX kenv tenv+                 $ moduleBody mm +        }+++---------------------------------------------------------------------------------------------------+spreadExportSourceT kenv esrc+  = case esrc of+        ExportSourceLocal n t   +         -> ExportSourceLocal n (spreadT kenv t)++        ExportSourceLocalNoType n+         -> ExportSourceLocalNoType n+++---------------------------------------------------------------------------------------------------+spreadImportTypeT kenv _tenv isrc+  = case isrc of+        ImportTypeAbstract t+         -> ImportTypeAbstract (spreadT kenv t)++        ImportTypeBoxed t+         -> ImportTypeBoxed    (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 -  = let down = spreadX kenv tenv +  = {-# 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@@ -44,30 +135,56 @@                 tenv'   = Env.extends (valwitBindsOfLets lts') tenv             in  XLet a lts' (spreadX kenv' tenv' x)          -        XCase a x alts  -> XCase a  (down x) (map down alts)-        XCast a c x     -> XCast a  (down c) (down x)-        XType t         -> XType    (spreadT kenv t)-        XWitness w      -> XWitness (down w)+        XCase a x alts  -> XCase    a (down x) (map down alts)+        XCast a c x     -> XCast    a (down c) (down x)+        XType a t       -> XType    a (spreadT kenv t)+        XWitness a w    -> XWitness a (down w)  -instance SpreadX Cast where+---------------------------------------------------------------------------------------------------+spreadDaCon _kenv tenv dc+  = case dc of+        DaConUnit       +         -> dc++        DaConPrim n t+         -> let u | Env.isPrim tenv n   = UPrim n t+                  | otherwise           = UName n++            in  case Env.lookup u tenv of+                 Just t' -> dc { daConType = t' }+                 Nothing -> dc++        DaConBound n+         | Env.isPrim tenv n+         , Just t'      <- Env.lookup (UPrim n (tBot kData)) tenv+         -> DaConPrim n t'++         | otherwise+         -> DaConBound n+++---------------------------------------------------------------------------------------------------+instance SpreadX (Cast a) where  spreadX kenv tenv cc-  = let down = spreadX kenv tenv +  = let down x = spreadX kenv tenv x     in case cc of-        CastWeakenEffect eff  -> CastWeakenEffect  (spreadT kenv eff)-        CastWeakenClosure clo -> CastWeakenClosure (spreadT kenv clo)-        CastPurify w          -> CastPurify        (down w)-        CastForget w          -> CastForget        (down w)+        CastWeakenEffect eff    -> CastWeakenEffect  (spreadT kenv eff)+        CastPurify w            -> CastPurify        (down w)+        CastBox                 -> CastBox+        CastRun                 -> CastRun  +--------------------------------------------------------------------------------------------------- instance SpreadX Pat where  spreadX kenv tenv pat-  = let down    = spreadX kenv tenv+  = 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)  +--------------------------------------------------------------------------------------------------- instance SpreadX (Alt a) where  spreadX kenv tenv alt   = case alt of@@ -77,11 +194,13 @@             in  AAlt p' (spreadX kenv tenv' x)  +--------------------------------------------------------------------------------------------------- instance SpreadX (Lets a) where  spreadX kenv tenv lts-  = let down = spreadX kenv tenv+  = let down x = spreadX kenv tenv x     in case lts of-        LLet m b x       -> LLet (down m) (down b) (down x)+        LLet b x         +         -> LLet (down b) (down x)                  LRec bxs          -> let (bs, xs) = unzip bxs@@ -90,43 +209,40 @@                 xs'      = map (spreadX kenv tenv') xs              in LRec (zip bs' xs') -        LLetRegion b bs-         -> let b'       = spreadT kenv b-                kenv'    = Env.extend b' kenv+        LPrivate b mT bs+         -> let b'       = map (spreadT kenv) b+                mT'      = liftM (spreadT kenv) mT+                kenv'    = Env.extends b' kenv                 bs'      = map (spreadX kenv' tenv) bs-            in  LLetRegion b' bs'--        LWithRegion b-         -> LWithRegion (spreadX kenv tenv b)---instance SpreadX LetMode where- spreadX kenv tenv lm-  = case lm of-        LetStrict        -> LetStrict-        LetLazy Nothing  -> LetLazy Nothing-        LetLazy (Just w) -> LetLazy (Just $ spreadX kenv tenv w)+            in  LPrivate b' mT' bs'  -instance SpreadX Witness where+---------------------------------------------------------------------------------------------------+instance SpreadX (Witness a) where  spreadX kenv tenv ww   = let down = spreadX kenv tenv      in case ww of-        WCon  wc         -> WCon  (down wc)-        WVar  u          -> WVar  (down u)-        WApp  w1 w2      -> WApp  (down w1) (down w2)-        WJoin w1 w2      -> WJoin (down w1) (down w2)-        WType t1         -> WType (spreadT kenv t1)+        WCon  a wc       -> WCon  a (down wc)+        WVar  a u        -> WVar  a (down u)+        WApp  a w1 w2    -> WApp  a (down w1) (down w2)+        WType a t1       -> WType a (spreadT kenv t1)  +--------------------------------------------------------------------------------------------------- instance SpreadX WiCon where  spreadX kenv tenv wc-  = let down = spreadX kenv tenv-    in case wc of-        WiConBound u     -> WiConBound (down u)-        WiConBuiltin{}   -> wc+  = case wc of+        WiConBound (UName n) _+         -> case Env.envPrimFun tenv n of+                Nothing -> wc+                Just t  +                 -> let t'      = spreadT kenv t+                    in  WiConBound (UPrim n t') t' +        _                -> wc ++--------------------------------------------------------------------------------------------------- instance SpreadX Bind where  spreadX kenv _tenv bb   = case bb of@@ -135,18 +251,19 @@         BNone t          -> BNone (spreadT kenv t)  +--------------------------------------------------------------------------------------------------- instance SpreadX Bound where  spreadX kenv tenv uu   | Just t'     <- Env.lookup uu tenv   = case uu of-        UIx ix _         -> UIx ix t'-        UPrim n _        -> UPrim n t'+        UIx ix          -> UIx   ix -        UName n _+        UName n          -> if Env.isPrim tenv n                   then UPrim n (spreadT kenv t')-                 else UName n (spreadT kenv t')+                 else UName n -  | otherwise   = uu        +        UPrim n _       -> UPrim n t' +  | otherwise   = uu
DDC/Core/Transform/SubstituteTX.hs view
@@ -3,20 +3,22 @@ -- --   If a binder would capture a variable then it is anonymized --   to deBruijn form.+-- module DDC.Core.Transform.SubstituteTX-        ( substituteTX+        ( SubstituteTX(..)+        , substituteTX         , substituteTXs-        , substituteBoundTX-        , SubstituteTX(..))+        , 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.Rewrite+import DDC.Type.Transform.Rename import Data.Maybe import qualified Data.Set               as Set import qualified DDC.Type.Env           as Env+import Control.Monad   -- | Substitute a `Type` for the `Bound` corresponding to some `Bind` in a thing.@@ -64,9 +66,10 @@  instance SubstituteTX (Exp a) where   substituteWithTX tArg sub xx-  = let down    = substituteWithTX tArg+  = {-# SCC substituteWithTX #-}+    let down x   = substituteWithTX tArg x     in case xx of-        XVar a u        -> XVar a (down sub u)+        XVar a u        -> XVar a u         XCon{}          -> xx         XApp a x1 x2    -> XApp a (down sub x1) (down sub x2) @@ -80,12 +83,11 @@                 x'              = down  sub1 x             in  XLam a b' x' -        XLet a (LLet m b x1) x2-         -> let m'              = down  sub  m-                x1'             = down  sub  x1+        XLet a (LLet b x1) x2+         -> let x1'             = down  sub  x1                 (sub1, b')      = bind0 sub  (down sub b)                 x2'             = down  sub1 x2-            in  XLet a (LLet m' b' x1') x2'+            in  XLet a (LLet b' x1') x2'          XLet a (LRec bxs) x2          -> let (bs, xs)        = unzip  bxs@@ -94,33 +96,22 @@                 x2'             = down sub1 x2             in  XLet a (LRec (zip bs' xs')) x2' -        XLet a (LLetRegion b bs) x2-         -> let (sub1, b')      = bind1  sub  b+        XLet a (LPrivate b mT bs) x2+         -> let mT'             = liftM (down sub) mT+                (sub1, b')      = bind1s sub  b                 (sub2, bs')     = bind0s sub1 (map (down sub1) bs)                 x2'             = down   sub2 x2-            in  XLet a (LLetRegion b' 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 t         -> XType    (down sub t)-        XWitness w      -> XWitness (down sub w)-+            in  XLet a (LPrivate b' mT' bs') x2' -instance SubstituteTX LetMode where- substituteWithTX tArg sub lm-  = let down    = substituteWithTX tArg-    in case lm of-        LetStrict         -> lm-        LetLazy Nothing   -> lm-        LetLazy (Just w)  -> LetLazy (Just $ down sub w)+        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)+        XWitness a w    -> XWitness a (down sub w)   instance SubstituteTX (Alt a) where  substituteWithTX tArg sub aa-  = let down = substituteWithTX tArg+  = let down x = substituteWithTX tArg x     in case aa of         AAlt PDefault xBody          -> AAlt PDefault $ down sub xBody@@ -131,35 +122,29 @@             in  AAlt (PData uCon bs') x'  -instance SubstituteTX Cast where+instance SubstituteTX (Cast a) where  substituteWithTX tArg sub cc-  = let down    = substituteWithTX tArg+  = let down x   = substituteWithTX tArg x     in case cc of         CastWeakenEffect eff    -> CastWeakenEffect  (down sub eff)-        CastWeakenClosure clo   -> CastWeakenClosure (down sub clo)         CastPurify w            -> CastPurify        (down sub w)-        CastForget w            -> CastForget        (down sub w)+        CastBox                 -> CastBox+        CastRun                 -> CastRun  -instance SubstituteTX Witness where+instance SubstituteTX (Witness a) where  substituteWithTX tArg sub ww-  = let down    = substituteWithTX tArg+  = let down x   = substituteWithTX tArg x     in case ww of-        WVar u                  -> WVar  (down sub u)+        WVar  a u               -> WVar  a u         WCon{}                  -> ww-        WApp  w1 w2             -> WApp  (down sub w1) (down sub w2)-        WJoin w1 w2             -> WJoin (down sub w1) (down sub w2)-        WType t                 -> WType (down sub t)+        WApp  a w1 w2           -> WApp  a (down sub w1) (down sub w2)+        WType a t               -> WType a (down sub t)   instance SubstituteTX Bind where  substituteWithTX tArg sub bb   = replaceTypeOfBind (substituteWithTX tArg sub (typeOfBind bb))  bb---instance SubstituteTX Bound where- substituteWithTX tArg sub uu-  = replaceTypeOfBound (substituteWithTX tArg sub (typeOfBound uu)) uu   instance SubstituteTX Type where
DDC/Core/Transform/SubstituteWX.hs view
@@ -3,26 +3,28 @@ -- --   If a binder would capture a variable then it is anonymized --   to deBruijn form.+-- module DDC.Core.Transform.SubstituteWX         ( SubstituteWX(..)         , substituteWX         , substituteWXs) where-import DDC.Core.Exp+import DDC.Core.Exp.Annot.Exp import DDC.Core.Collect-import DDC.Core.Transform.LiftW-import DDC.Type.Compounds-import DDC.Type.Rewrite+import DDC.Core.Transform.Rename+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+import Control.Monad  --- | Wrapper for `substituteWithW` that determines the set of free names in the+-- | Wrapper for `substituteWithWX` that determines the set of free names in the --   type being substituted, and starts with an empty binder stack. substituteWX          :: (Ord n, SubstituteWX c) -        => Bind n -> Witness n -> c n -> c n+        => Bind n -> Witness a n -> c a n -> c a n  substituteWX b wArg xx  | Just u       <- takeSubstBoundOfBind b@@ -52,31 +54,28 @@  | otherwise    = xx   --- | Wrapper for `substituteW` to substitute multiple things.+-- | Wrapper for `substituteWithWX` to substitute multiple things. substituteWXs          :: (Ord n, SubstituteWX c) -        => [(Bind n, Witness n)] -> c n -> c n+        => [(Bind n, Witness a n)] -> c a n -> c a n substituteWXs bts x         = foldr (uncurry substituteWX) x bts  -class SubstituteWX (c :: * -> *) where-- -- | Substitute a witness 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.+-------------------------------------------------------------------------------+class SubstituteWX (c :: * -> * -> *) where  substituteWithWX-        :: forall n. Ord n-        => Witness n -> Sub n -> c n -> c n+        :: forall a n. Ord n+        => Witness a n -> Sub n -> c a n -> c a n  -instance SubstituteWX (Exp a) where +instance SubstituteWX Exp where   substituteWithWX wArg sub xx-  = let down    = substituteWithWX wArg-        into    = rewriteWith+  = {-# SCC substituteWithWX #-}+    let down s x   = substituteWithWX wArg s x+        into s x   = renameWith s x     in case xx of-        XVar a u        -> XVar a (into sub u)+        XVar a u        -> XVar a u         XCon{}          -> xx         XApp a x1 x2    -> XApp a (down sub x1) (down sub x2) @@ -90,12 +89,11 @@                 x'              = down  sub1 x             in  XLam a b' x' -        XLet a (LLet m b x1) x2-         -> let m'              = down  sub  m-                x1'             = down  sub  x1+        XLet a (LLet b x1) x2+         -> let x1'             = down  sub  x1                 (sub1, b')      = bind0 sub  b                 x2'             = down  sub1 x2-            in  XLet a (LLet m' b' x1') x2'+            in  XLet a (LLet b' x1') x2'          XLet a (LRec bxs) x2          -> let (bs, xs)        = unzip  bxs@@ -104,34 +102,22 @@                 x2'             = down sub1 x2             in  XLet a (LRec (zip bs' xs')) x2' -        XLet a (LLetRegion b bs) x2-         -> let (sub1, b')      = bind1  sub  b+        XLet a (LPrivate b mT bs) x2+         -> let (sub1, b')      = bind1s sub b                 (sub2, bs')     = bind0s sub1 bs                 x2'             = down   sub2 x2-            in  XLet a (LLetRegion b' 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 t         -> XType    (into sub t)-        XWitness w      -> XWitness (down sub w)--+                mT'             = liftM (into sub) mT+            in  XLet a (LPrivate b' mT' bs') x2' -instance SubstituteWX LetMode where- substituteWithWX wArg sub lm-  = let down = substituteWithWX wArg-    in case lm of-        LetStrict        -> lm-        LetLazy Nothing  -> LetLazy Nothing-        LetLazy (Just w) -> LetLazy (Just (down sub w))+        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)+        XWitness a w            -> XWitness a (down sub w)  -instance SubstituteWX (Alt a) where+instance SubstituteWX Alt where  substituteWithWX wArg sub aa-  = let down = substituteWithWX wArg+  = let down s x = substituteWithWX wArg s x     in case aa of         AAlt PDefault xBody          -> AAlt PDefault $ down sub xBody@@ -144,39 +130,38 @@  instance SubstituteWX Cast where  substituteWithWX wArg sub cc-  = let down    = substituteWithWX wArg-        into    = rewriteWith+  = let down s x = substituteWithWX wArg s x+        into s x = renameWith s x     in case cc of         CastWeakenEffect eff    -> CastWeakenEffect  (into sub eff)-        CastWeakenClosure clo   -> CastWeakenClosure (into sub clo)         CastPurify w            -> CastPurify        (down sub w)-        CastForget w            -> CastForget        (down sub w)+        CastBox                 -> CastBox+        CastRun                 -> CastRun   instance SubstituteWX Witness where  substituteWithWX wArg sub ww-  = let down    = substituteWithWX wArg-        into    = rewriteWith+  = let down s x = substituteWithWX wArg s x+        into s x = renameWith s x     in case ww of-        WVar u+        WVar a u          -> case substW wArg sub u of-                Left u'  -> WVar (into sub u')+                Left u'  -> WVar a u'                 Right w  -> w          WCon{}                  -> ww-        WApp  w1 w2             -> WApp  (down sub w1) (down sub w2)-        WJoin w1 w2             -> WJoin (down sub w1) (down sub w2)-        WType t                 -> WType (into sub t)+        WApp  a w1 w2           -> WApp  a (down sub w1) (down sub w2)+        WType a t               -> WType a (into sub t)   -- | Rewrite or substitute into a witness variable.-substW  :: Ord n => Witness n -> Sub n -> Bound n -        -> Either (Bound n) (Witness n)+substW  :: Ord n => Witness a n -> Sub n -> Bound n +        -> Either (Bound n) (Witness a n)  substW wArg sub u   = case substBound (subStack0 sub) (subBound sub) u of-        Left  u'                -> Left (rewriteWith sub u')+        Left  u'                -> Left u'         Right n  -         | not $ subShadow0 sub -> Right (liftW n wArg)-         | otherwise            -> Left (rewriteWith sub u)+         | not $ subShadow0 sub -> Right (liftX n wArg)+         | otherwise            -> Left  u
DDC/Core/Transform/SubstituteXX.hs view
@@ -3,6 +3,7 @@ -- --   If a binder would capture a variable then it is anonymized --   to deBruijn form.+-- module DDC.Core.Transform.SubstituteXX         ( SubstituteXX(..)         , substituteXX@@ -10,17 +11,18 @@         , 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.Rewrite+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+import Control.Monad   -- | Wrapper for `substituteWithX` that determines the set of free names in the@@ -41,7 +43,7 @@         , subConflict1                   = Set.fromList                 $  (mapMaybe takeNameOfBound $ Set.toList $ freeT Env.empty xArg) -                ++ (mapMaybe takeNameOfBind  $ collectSpecBinds xArg)+                ++ (mapMaybe takeNameOfBind  $ fst $ collectBinds xArg)            -- Rewrite level-0 binders that have the same name as any           -- of the free variables in the expression to substitute.@@ -71,19 +73,19 @@ --   Perform type substitution for an `XType`  --    and witness substitution for an `XWitness` substituteXArg -        :: (Ord n, SubstituteXX c, SubstituteWX (c a), SubstituteTX (c a))+        :: (Ord n, SubstituteXX c, SubstituteWX c, SubstituteTX (c a))         => Bind n -> Exp a n -> c a n -> c a n  substituteXArg b arg x  = case arg of-        XType t         -> substituteTX  b t x-        XWitness w      -> substituteWX  b w x+        XType    _ t    -> substituteTX  b t x+        XWitness _ w    -> substituteWX  b w x         _               -> substituteXX  b arg x   -- | Wrapper for `substituteXArgs` to substitute multiple arguments. substituteXArgs-        :: (Ord n, SubstituteXX c, SubstituteWX (c a), SubstituteTX (c a))+        :: (Ord n, SubstituteXX c, SubstituteWX c, SubstituteTX (c a))         => [(Bind n, Exp a n)] -> c a n -> c a n  substituteXArgs bas x@@ -99,12 +101,13 @@  instance SubstituteXX Exp where   substituteWithXX xArg sub xx-  = let down    = substituteWithXX xArg-        into    = rewriteWith+  = {-# SCC substituteWithXX #-}+    let down s x   = substituteWithXX xArg s x+        into s x   = renameWith s x     in case xx of         XVar a u          -> case substX xArg sub u of-                Left  u' -> XVar a (into sub u')+                Left  u' -> XVar a u'                 Right x  -> x          XCon{}           -> xx@@ -120,12 +123,11 @@                 x'              = down  sub1 x             in  XLam a b' x' -        XLet a (LLet m b x1) x2-         -> let m'              = into  sub  m-                x1'             = down  sub  x1+        XLet a (LLet b x1) x2+         -> let x1'             = down  sub  x1                 (sub1, b')      = bind0 sub  b                 x2'             = down  sub1 x2-            in  XLet a (LLet m' b' x1') x2'+            in  XLet a (LLet b' x1') x2'          XLet a (LRec bxs) x2          -> let (bs, xs)        = unzip  bxs@@ -134,24 +136,22 @@                 x2'             = down sub1 x2             in  XLet a (LRec (zip bs' xs')) x2' -        XLet a (LLetRegion b bs) x2-         -> let (sub1, b')      = bind1  sub  b+        XLet a (LPrivate b mT bs) x2+         -> let mT'             = liftM (into sub) mT+                (sub1, b')      = bind1s sub  b                 (sub2, bs')     = bind0s sub1 bs                 x2'             = down   sub2 x2-            in  XLet a (LLetRegion b' bs') x2'--        XLet a (LWithRegion uR) x2-         -> XLet a (LWithRegion uR) (down sub x2)+            in  XLet a (LPrivate b' mT' bs') x2' -        XCase a x1 alts -> XCase a  (down sub x1) (map (down sub) alts)-        XCast a cc x1   -> XCast a  (into sub cc) (down sub x1)-        XType t         -> XType    (into sub t)-        XWitness w      -> XWitness (into sub w)+        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)+        XWitness a w            -> XWitness a (into sub w)    instance SubstituteXX Alt where  substituteWithXX xArg sub aa-  = let down = substituteWithXX xArg+  = let down s x = substituteWithXX xArg s x     in case aa of         AAlt PDefault xBody          -> AAlt PDefault $ down sub xBody@@ -162,15 +162,25 @@             in  AAlt (PData uCon bs') x'  +instance SubstituteXX Cast where+ substituteWithXX _xArg sub cc+  = let into s x = renameWith s x+    in case cc of+        CastWeakenEffect eff    -> CastWeakenEffect  (into sub eff)+        CastPurify w            -> CastPurify (into sub w)+        CastBox                 -> CastBox+        CastRun                 -> CastRun++ -- | Rewrite or substitute into an expression variable. substX  :: Ord n => Exp a n -> Sub n -> Bound n          -> Either (Bound n) (Exp a n)  substX xArg sub u   = case substBound (subStack0 sub) (subBound sub) u of-        Left  u'                -> Left (rewriteWith sub u')+        Left  u'                -> Left u'         Right n            | not $ subShadow0 sub -> Right (liftX n xArg)-         | otherwise            -> Left (rewriteWith sub u)+         | otherwise            -> Left  u
+ 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/Bind.hs view
@@ -0,0 +1,31 @@++module DDC.Type.Bind+        (getBindType)+where+import DDC.Type.Exp+++-- | Lookup the type of a bound thing from the binder stack.+--   The binder stack contains the binders of all the `TForall`s we've+--   entered under so far.+getBindType :: Eq n => [Bind n] -> Bound n -> Maybe (Int, Type n)+getBindType bs' u'+ = go 0 u' bs'+ where  go n u (BName n1 t : bs)+         | UName n2     <- u+         , n1 == n2     = Just (n, t)++         | otherwise    = go (n + 1) u bs++        go n (UIx i)    (BAnon t   : bs)+         | i < 0        = Nothing+         | i == 0       = Just (n, t)+         | otherwise    = go (n + 1) (UIx (i - 1)) bs++        go n u          (BAnon _   : bs)+         | otherwise    = go (n + 1) u bs++        go n u (BNone _   : bs)+         = go (n + 1) u bs++        go _ _ []       = Nothing
− DDC/Type/Check.hs 
@@ -1,209 +0,0 @@--- | Check the kind of a type.-module DDC.Type.Check-        ( -- * Kinds of Types-          checkType-        , kindOfType--          -- * Kinds of Constructors-        , takeSortOfKiCon-        , kindOfTwCon-        , kindOfTcCon-        -          -- * Errors-        , Error(..))-where-import DDC.Type.Check.CheckError-import DDC.Type.Check.CheckCon-import DDC.Type.Compounds-import DDC.Type.Predicates-import DDC.Type.Transform.LiftT-import DDC.Core.DataDef-import DDC.Type.Exp-import DDC.Base.Pretty-import Data.List-import Control.Monad-import DDC.Type.Check.Monad             (throw, result)-import DDC.Type.Pretty                  ()-import DDC.Type.Env                     (Env)-import qualified DDC.Type.Sum           as TS-import qualified DDC.Type.Env           as Env-import qualified DDC.Type.Check.Monad   as G-import qualified Data.Map               as Map----- | The type checker monad.-type CheckM n   = G.CheckM (Error n)----- Wrappers ---------------------------------------------------------------------- | Check a type in the given environment, returning an error or its kind.-checkType  :: (Ord n, Pretty n) -           => DataDefs n -           -> Env n -           -> Type n -           -> Either (Error n) (Kind n)--checkType defs env tt -        = result $ checkTypeM defs env tt----- | Check a type in an empty environment, returning an error or its kind.-kindOfType :: (Ord n, Pretty n) -           => DataDefs n-           -> Type n -           -> Either (Error n) (Kind n)--kindOfType defs tt-        = result $ checkTypeM defs Env.empty tt----- checkType --------------------------------------------------------------------- | Check a type, returning its kind.-------   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, Pretty n) -        => DataDefs n-        -> Env n-        -> Type n -        -> CheckM n (Kind n)--checkTypeM defs env tt-        = -- trace (pretty $ text "checkTypeM:" <+> ppr tt) $-          checkTypeM' defs env tt---- Variables -------------------checkTypeM' _defs env (TVar u)- = do   let tBound      = typeOfBound u-        let mtEnv       = Env.lookup u env--        let mkResult-                -- If the annot is Bot then just use the type-                -- from the environment.-                | Just tEnv     <- mtEnv-                , isBot tBound-                = return tEnv--                -- The bound has an explicit type annotation,-                --  which matches the one from the environment.-                -- -                --  When the bound is a deBruijn index we need to lift the-                --  annotation on the original binder through any lambdas-                --  between the binding occurrence and the use.-                | Just tEnv    <- mtEnv-                , UIx i _      <- u-                , tBound == liftT (i + 1) tEnv-                = return tBound--                -- The bound has an explicit type annotation,-                --   that matches the one from the environment.-                | Just tEnv     <- mtEnv-                , tBound == tEnv-                = return tBound--                -- The bound has an explicit type annotation,-                --  that does not match the one from the environment. -                | Just tEnv     <- mtEnv-                = throw $ ErrorVarAnnotMismatch u tEnv--                -- Type variables must be in the environment.-                | _             <- mtEnv-                = throw $ ErrorUndefined u--        mkResult---- Constructors ----------------checkTypeM' defs _env tt@(TCon tc)- = case tc of-        -- Sorts don't have a higher classification.-        TyConSort _      -> throw $ ErrorNakedSort tt--        -- Can't sort check a naked kind function-        -- because the sort depends on the argument kinds.-        TyConKind kc-         -> case takeSortOfKiCon kc of-                Just s   -> return s-                Nothing  -> throw $ ErrorUnappliedKindFun--        TyConWitness tcw -> return $ kindOfTwCon tcw-        TyConSpec    tcc -> return $ kindOfTcCon tcc--        -- User defined type constructors need to be in the set of data defs.-        TyConBound    u  -         -> case u of-                UName n _-                 | Just _ <- Map.lookup n (dataDefsTypes defs)-                 -> return $ typeOfBound u--                 | otherwise-                 -> throw $ ErrorUndefinedCtor u--                UPrim{} -> return $ typeOfBound u-                UIx{}   -> error "sorry"----- Quantifiers -----------------checkTypeM' defs env tt@(TForall b1 t2)- = do   _       <- checkTypeM defs env (typeOfBind b1)-        k2      <- checkTypeM defs (Env.extend b1 env) t2--        -- The body must have data or witness kind.-        when (  (not $ isDataKind k2)-             && (not $ isWitnessKind k2))-         $ throw $ ErrorForallKindInvalid tt t2 k2--        return k2---- Applications ------------------ Applications of the kind function constructor are handled directly--- because the constructor doesn't have a sort by itself.-checkTypeM' defs env (TApp (TApp (TCon (TyConKind KiConFun)) k1) k2)- = do   _       <- checkTypeM defs env k1-        s2      <- checkTypeM defs env k2-        return  s2---- The implication constructor is overloaded and can have the--- following kinds:---   (=>) :: @ ~> @ ~> @,  for witness implication.---   (=>) :: @ ~> * ~> *,  for a context.-checkTypeM' defs env tt@(TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2)- = do   k1      <- checkTypeM defs env t1-        k2      <- checkTypeM defs env t2-        if      isWitnessKind k1 && isWitnessKind k2-         then     return kWitness-        else if isWitnessKind k1 && isDataKind k2-         then     return kData-        else    throw $ ErrorWitnessImplInvalid tt t1 k1 t2 k2---- Type application.-checkTypeM' defs env tt@(TApp t1 t2)- = do   k1      <- checkTypeM defs env t1-        k2      <- checkTypeM defs env t2-        case k1 of-         TApp (TApp (TCon (TyConKind KiConFun)) k11) k12-          | k11 == k2   -> return k12-          | otherwise   -> throw $ ErrorAppArgMismatch tt k1 k2-                  -         _              -> throw $ ErrorAppNotFun tt t1 k1 t2 k2---- Sums ------------------------checkTypeM' defs env (TSum ts)- = do   ks      <- mapM (checkTypeM defs env) $ TS.toList ts--        -- Check that all the types in the sum have a single kind, -        -- and return that kind.-        k <- case nub ks of     -                 []     -> return $ TS.kindOfSum ts-                 [k]    -> return k-                 _      -> throw $ ErrorSumKindMismatch -                                        (TS.kindOfSum ts) ts 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 k-         else throw $ ErrorSumKindInvalid ts k-
− DDC/Type/Check/CheckCon.hs 
@@ -1,73 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}-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   u  -> Just $ typeOfBound u----- | 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----- | Take the kind of a computation type constructor.-kindOfTcCon :: TcCon -> Kind n-kindOfTcCon tc- = case tc of-        TcConFun        -> [kData, kEffect, kClosure, kData] `kFuns` 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/CheckError.hs 
@@ -1,141 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--- | Errors produced when checking types.-module DDC.Type.Check.CheckError-        (Error(..))-where-import DDC.Type.Exp-import DDC.Type.Compounds-import DDC.Type.Pretty----- Error --------------------------------------------------------------------------------------------- | Type errors.-data Error n--        -- | An undefined type variable.-        = ErrorUndefined        -        { errorBound            :: Bound n }--        -- | An undefined type constructor.-        | ErrorUndefinedCtor-        { errorBound            :: Bound n }--        -- | The kind annotation on the variables does not match the one in the environment.-        | ErrorVarAnnotMismatch-        { errorBound            :: Bound n-        , errorTypeEnv          :: Type n }--        -- | Found a naked sort constructor.-        | ErrorNakedSort-        { errorSort             :: Sort n }--        -- | Found an unapplied kind function constructor.-        | ErrorUnappliedKindFun --        -- | A type application where the parameter and argument kinds don't match.-        | ErrorAppArgMismatch   -        { errorChecking         :: Type n-        , errorParamKind        :: Kind n-        , errorArgKind          :: Kind n }--        -- | 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-        , errorArgTypeKind      :: Kind n }--        -- | 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 }--        -- | A forall where the body does not have data or witness kind.-        | ErrorForallKindInvalid-        { errorChecking         :: Type n-        , errorBody             :: Type n-        , errorKind             :: 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 }-        deriving Show---instance (Eq n, Pretty n) => Pretty (Error n) where- ppr err-  = case err of-        ErrorUndefined u-         -> text "Undefined type variable:  " <> ppr u--        ErrorUndefinedCtor u-         -> text "Undefined type constructor:  " <> ppr u--        ErrorUnappliedKindFun -         -> text "Can't take sort of unapplied kind function constructor."-        -        ErrorNakedSort s-         -> text "Can't check a naked sort: " <> ppr s-        -        ErrorVarAnnotMismatch u t-         -> vcat [ text "Type mismatch in annotation."-                 , text "             Variable: "       <> ppr u-                 , text "       has annotation: "       <> (ppr $ typeOfBound u)-                 , text " which conflicts with: "       <> ppr t-                 , text "     from environment." ]- -        ErrorAppArgMismatch tt t1 t2-         -> vcat [ text "Core type mismatch in application."-                 , text "             type: " <> ppr t1-                 , text "   does not match: " <> ppr t2-                 , text "   in application: " <> ppr tt ]-         -        ErrorAppNotFun tt t1 k1 t2 k2-         -> vcat [ text "Core type mismatch in application."-                 , text "     cannot apply type: " <> ppr t2-                 , text "               of kind: " <> ppr k2-                 , text "  to non-function type: " <> ppr t1-                 , text "               of kind: " <> ppr k1-                 , text "         in appliction: " <> ppr tt]-                -        ErrorSumKindMismatch k ts ks-         -> vcat -              $  [ text "Core type mismatch in 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 ! or $" ]--        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 * or @" -                 , text "        when checking: " <> ppr tt ]-        -        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 ]-
− DDC/Type/Check/Monad.hs 
@@ -1,28 +0,0 @@--module DDC.Type.Check.Monad-        ( CheckM (..)-        , throw-        , result)-where---- | Type checking monad.-data CheckM err a-        = CheckM (Either err a)--instance Monad (CheckM err) where- return x   = CheckM (Right x)- (>>=) m f  -  = case m of-          CheckM (Left err)     -> CheckM (Left err)-          CheckM (Right x)      -> f x--          --- | Throw a type error in the monad.-throw :: err -> CheckM err a-throw e       = CheckM $ Left e----- | Take the result from a check monad.-result :: CheckM err a -> Either err a-result (CheckM r)       = r-
− DDC/Type/Compounds.hs 
@@ -1,425 +0,0 @@-{-# OPTIONS -fno-warn-missing-signatures #-}-module DDC.Type.Compounds-        ( -- * Binds-          takeNameOfBind-        , typeOfBind-        , replaceTypeOfBind-        -          -- * Binders-        , binderOfBind-        , makeBindFromBinder-        , partitionBindsByType-        -          -- * Bounds-        , typeOfBound-        , takeNameOfBound-        , replaceTypeOfBound-        , boundMatchesBind-        , namedBoundMatchesBind-        , takeSubstBoundOfBind--          -- * Type structure-        , tIx-        , tApp,          ($:)-        , tApps,         takeTApps-        , takeTyConApps, takeDataTyConApps-        , tForall-        , tForalls,      takeTForalls-        , tBot-        , tSum--          -- * Function type construction-        , kFun-        , kFuns,        takeKFun-        , takeKFuns,    takeKFuns',     takeResultKind-        , tFun,         takeTFun,       takeTFunArgResult-        , tFunPE-        , tImpl--          -- * 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-        , 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 type of a bound variable.-typeOfBound :: Bound n -> Type n-typeOfBound uu- = case uu of-        UName _ t       -> t-        UPrim _ t       -> t-        UIx   _ t       -> t----- | 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----- | Replace the type of a bound with a new one.-replaceTypeOfBound :: Type n -> Bound n -> Bound n-replaceTypeOfBound t uu- = case uu of-        UName n _       -> UName n t-        UPrim n _       -> UPrim n t-        UIx   i _       -> UIx   i t----- | 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 `Bound` to a `Bind`, 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 t       -> Just $ UName n t-        BAnon t         -> Just $ UIx 0 t-        BNone _         -> Nothing----- Variables --------------------------------------------------------------------- | Construct a deBruijn index.-tIx :: Kind n -> Int -> Type n-tIx k i         = TVar (UIx i k)----- 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 data type constructors.-takeDataTyConApps :: Type n -> Maybe (TyCon n, [Type n])-takeDataTyConApps tt- = case takeTApps tt of-        TCon tc : args  -         | TyConBound (UName _ t)       <- tc-         , TCon (TyConKind KiConData)   <- takeResultKind t-         -> Just (tc, args)--         | TyConBound (UPrim _ t)       <- tc-         , TCon (TyConKind KiConData)   <- takeResultKind t-         -> Just (tc, args)--        _ -> 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 k)))----- | Build an anonymous type abstraction, with several parameters.-tForalls  :: [Kind n] -> ([Type n] -> Type n) -> Type n-tForalls ks f- = let  bs      = [BAnon k | k <- ks]-        us      = reverse [TVar (UIx n  k) | k <- ks | n <- [0..]]-   in   foldr TForall (f 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)----- Sums ------------------------------------------------------------------------tSum :: Ord n => Kind n -> [Type n] -> Type n-tSum k ts-        = TSum (Sum.fromList k ts)----- 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----- | Construct a value type function, ---   with the provided effect and closure.-tFun    :: Type n -> Effect n -> Closure n -> Type n -> Type n-tFun t1 eff clo t2-        = (TCon $ TyConSpec TcConFun) `tApps` [t1, eff, clo, t2]--infixr `tFun`----- | Destruct the type of a value function.-takeTFun :: Type n -> Maybe (Type n, Effect n, Closure n, Type n)-takeTFun tt- = case tt of-        TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFun)) t1) eff) clo) t2-         ->  Just (t1, eff, clo, t2)-        _ -> Nothing----- | Destruct the type of a value function, returning just the argument---   and result types.-takeTFunArgResult :: Type n -> ([Type n], Type n)-takeTFunArgResult tt- = case tt of-        TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFun)) t1) _eff) _clo) t2-          -> let (tsMore, tResult) = takeTFunArgResult t2-             in  (t1 : tsMore, tResult)--        _ -> ([], tt)----- | Construct a pure and empty value type function.-tFunPE  :: Type n -> Type n -> Type n-tFunPE t1 t2    = tFun t1 (tBot kEffect) (tBot kClosure) t2----- | Construct a witness implication type.-tImpl :: Type n -> Type n -> Type n-tImpl t1 t2      -        = ((TCon $ TyConWitness TwConImpl) `tApp` t1) `tApp` t2--infixr `tImpl`----- 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-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----- | 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
@@ -0,0 +1,273 @@++-- | Algebraic data type definitions.+module DDC.Type.DataDef+        ( DataDef    (..)+        , kindOfDataDef+        , dataTypeOfDataDef+        , dataCtorNamesOfDataDef+        , makeDataDefAlg+        , makeDataDefAbs++        -- * Data type definition table+        , DataDefs   (..)+        +        , DataMode   (..)+        , emptyDataDefs+        , insertDataDef+        , unionDataDefs+        , fromListDataDefs+        +        , DataType   (..)+        , kindOfDataType+        , lookupModeOfDataType++        , DataCtor   (..)+        , typeOfDataCtor)+where+import DDC.Type.Exp+import DDC.Type.Exp.Simple.Compounds+import Data.Map                         (Map)+import qualified Data.Map.Strict        as Map+import Data.Maybe+import Control.Monad+import Control.DeepSeq+++---------------------------------------------------------------------------------------------------+-- | The definition of a single data type.+data DataDef n+        = DataDef+        { -- | Name of the data type.+          dataDefTypeName       :: !n++          -- | Binders for type parameters.+        , dataDefParams         :: ![Bind n]++          -- | Constructors of the data type, +          --   or Nothing if the data type is algbraic but there are too many +          --      constructors to list (like with `Int`).+        , dataDefCtors          :: !(Maybe [DataCtor n]) ++          -- | Whether the data type is algebraic.+          --   These can be deconstructed with 'case' expressions.+        , dataDefIsAlgebraic    :: Bool }+        deriving Show+++instance NFData n => NFData (DataDef n) where+ rnf !def+        =       rnf (dataDefTypeName    def)+        `seq`   rnf (dataDefParams      def)+        `seq`   rnf (dataDefCtors       def)+        `seq`   rnf (dataDefIsAlgebraic def)+++-- | Get the kind of the type constructor defined by a `DataDef`.+kindOfDataDef :: DataDef n -> Kind n+kindOfDataDef def+ = let  ksParam = map typeOfBind $ dataDefParams def+   in   kFuns ksParam kData+   ++-- | Get the type associated with a data definition, +--   that is, the type produced by the constructors.+dataTypeOfDataDef :: DataDef n -> Type n+dataTypeOfDataDef def+ = let  usParam = takeSubstBoundsOfBinds $ dataDefParams def+        ksParam = map typeOfBind $ dataDefParams def+        tc      = TyConBound (UName (dataDefTypeName def))+                             (kFuns ksParam kData)+   in   tApps (TCon tc) (map TVar usParam)+++-- | Get the list of data constructor names that this type defines,+--   or Nothing if there are too many to list.+dataCtorNamesOfDataDef :: DataDef n -> Maybe [n]+dataCtorNamesOfDataDef def+ = case dataDefCtors def of+        Nothing         -> Nothing +        Just ctors      -> Just $ map dataCtorName ctors+++-- | Shortcut for constructing a `DataDef` for an algebraic type.+--+--   Values of algebraic type can be deconstructed with case-expressions.+makeDataDefAlg +        :: n            -- ^ Name of data type.+        -> [Bind n]     -- ^ Type parameters.+        -> Maybe [(n, [Type n])]        +                        -- ^ Constructor names and field types,+                        --      or `Nothing` if there are too many to list.+        -> DataDef n++makeDataDefAlg nData bsParam Nothing +        = DataDef+        { dataDefTypeName       = nData+        , dataDefParams         = bsParam+        , dataDefCtors          = Nothing +        , dataDefIsAlgebraic    = True }++makeDataDefAlg nData bsParam (Just ntsField)+ = let  usParam = takeSubstBoundsOfBinds bsParam+        ksParam = map typeOfBind bsParam+        tc      = TyConBound (UName nData) +                             (kFuns ksParam kData)++        tResult = tApps (TCon tc) (map TVar usParam)+   +        ctors   = [ DataCtor n tag tsField tResult nData bsParam+                            | tag          <- [0..]+                            | (n, tsField) <- ntsField] +   in   DataDef+        { dataDefTypeName       = nData+        , dataDefParams         = bsParam+        , dataDefCtors          = Just ctors +        , dataDefIsAlgebraic    = True }+  ++-- | Shortcut for constructing a `DataDef` for an abstract type.+--+--   Values of abstract type cannot be deconstructed with case-expressions.+makeDataDefAbs :: n -> [Bind n] -> DataDef n+makeDataDefAbs nData bsParam+ = DataDef+        { dataDefTypeName       = nData+        , dataDefParams         = bsParam+        , dataDefCtors          = Just []+        , dataDefIsAlgebraic    = False }+++-- DataDefs ---------------------------------------------------------------------------------------+-- | A table of data type definitions,+--   unpacked into type and data constructors so we can find them easily.+data DataDefs n+        = DataDefs+        { dataDefsTypes :: !(Map n (DataType n))+        , dataDefsCtors :: !(Map n (DataCtor n)) }+        deriving Show+++-- | The mode of a data type records how many data constructors there are.+--   This can be set to 'Large' for large primitive types like Int and Float.+--   In this case we don't ever expect them all to be enumerated+--   as case alternatives.+data DataMode n+        = DataModeSmall ![n]+        | DataModeLarge+        deriving Show+++-- | Describes a data type constructor, used in the `DataDefs` table.+data DataType n+        = DataType +        { -- | Name of data type constructor.+          dataTypeName       :: !n++          -- | Kinds of type parameters to constructor.+        , dataTypeParams     :: ![Bind n]++          -- | Names of data constructors of this data type,+          --   or `Nothing` if it has infinitely many constructors.+        , dataTypeMode       :: !(DataMode n) ++          -- | Whether the data type is algebraic.+        , dataTypeIsAlgebraic :: Bool }+        deriving Show+++-- | Describes a data constructor, used in the `DataDefs` table.+data DataCtor n+        = DataCtor+        { -- | Name of data constructor.+          dataCtorName        :: !n++          -- | Tag of constructor (order in data type declaration)+        , dataCtorTag         :: !Integer++          -- | Field types of constructor.+        , dataCtorFieldTypes  :: ![Type n]++          -- | Result type of constructor.+        , dataCtorResultType  :: !(Type n)++          -- | Name of result type of constructor.+        , dataCtorTypeName    :: !n ++          -- | Parameters of data type +        , dataCtorTypeParams :: ![Bind n] }+        deriving Show+++-- | Get the type of `DataCtor`+typeOfDataCtor :: DataCtor n -> Type n+typeOfDataCtor ctor+ = let  Just t   = tFunOfList (  dataCtorFieldTypes ctor +                              ++ [dataCtorResultType ctor] )+   in   foldr TForall t (dataCtorTypeParams ctor)+++instance NFData n => NFData (DataCtor n) where+ rnf (DataCtor n t fs tR nT bsParam)+  = 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+        = DataDefs+        { dataDefsTypes = Map.empty+        , 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+ = let  defType = DataType+                { dataTypeName        = nType+                , dataTypeParams      = bsParam+                , dataTypeMode        = defMode +                , dataTypeIsAlgebraic = isAlg }++        defMode = case mCtors of+                   Nothing    -> DataModeLarge+                   Just ctors -> DataModeSmall (map dataCtorName ctors)++   in   dataDefs+         { dataDefsTypes = Map.insert nType defType (dataDefsTypes dataDefs)+         , dataDefsCtors = Map.union (dataDefsCtors dataDefs)+                         $ Map.fromList [(n, def) +                                | def@(DataCtor n _ _ _ _ _) <- concat $ maybeToList mCtors ]}+++-- | Build a `DataDefs` table from a list of `DataDef`+fromListDataDefs :: Ord n => [DataDef n] -> DataDefs n+fromListDataDefs defs+        = foldr insertDataDef emptyDataDefs defs+++-- | Yield the list of data constructor names for some data type, +--   or `Nothing` for large types with too many constructors to list.+lookupModeOfDataType :: Ord n => n -> DataDefs n -> Maybe (DataMode n)+lookupModeOfDataType n defs+        = liftM dataTypeMode $ Map.lookup n (dataDefsTypes defs)+++-- | Get the kind of the type constructor defined by a `DataDef`.+kindOfDataType :: DataType n -> Kind n+kindOfDataType def+ = let  ksParam = map typeOfBind $ dataTypeParams def+   in   kFuns ksParam kData+
DDC/Type/Env.hs view
@@ -8,24 +8,44 @@ -- module DDC.Type.Env         ( Env(..)+        , SuperEnv+        , KindEnv+        , TypeEnv++        -- * Construction         , empty-        , extend,       extends-        , setPrimFun,   isPrim-        , fromList+        , singleton+        , extend+        , extends         , union-        , member,       memberBind-        , lookup,       lookupName+        , unions++        -- * Conversion+        , fromList+        , fromListNT+        , fromTypeMap++        -- * Projections          , depth-        , lift-        , wrapTForalls)+        , member+        , memberBind+        , lookup+        , lookupName++        -- * Primitives+        , setPrimFun+        , isPrim++        -- * Lifting+        , 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)-import qualified Data.Map       as Map-import qualified Prelude        as P+import Data.Map                         (Map)+import Prelude                          hiding (lookup)+import qualified Data.Map.Strict        as Map+import qualified Prelude                as P import Control.Monad  @@ -33,18 +53,28 @@ data Env n         = Env         { -- | Types of named binders.-          envMap         :: Map n (Type n)+          envMap         :: !(Map n (Type n))            -- | Types of anonymous deBruijn binders.-        , envStack       :: [Type n] +        , envStack       :: ![Type n]                     -- | The length of the above stack.-        , envStackLength :: Int+        , envStackLength :: !Int            -- | Types of baked in, primitive names.-        , envPrimFun     :: n -> Maybe (Type n) }+        , envPrimFun     :: !(n -> Maybe (Type n)) }  +-- | Type synonym to improve readability.+type SuperEnv n = Env n++-- | Type synonym to improve readability.+type KindEnv n  = Env n++-- | Type synonym to improve readability.+type TypeEnv n  = Env n++ -- | An empty environment. empty :: Env n empty   = Env@@ -54,6 +84,12 @@         , envPrimFun     = \_ -> Nothing }  +-- | Construct a singleton type environment.+singleton :: Ord n => Bind n -> Env 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 -> Env n -> Env n@@ -90,6 +126,18 @@         = 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+        = empty { envMap = m}++ -- | Combine two environments. --   If both environments have a binding with the same name, --   then the one in the second environment takes preference.@@ -102,6 +150,13 @@         , envPrimFun     = \n -> envPrimFun env2 n `mplus` envPrimFun env1 n }  +-- | Combine multiple environments,+--   with the latter ones taking preference.+unions :: Ord n => [Env n] -> Env n+unions envs+        = foldr union empty envs++ -- | Check whether a bound variable is present in an environment. member :: Ord n => Bound n -> Env n -> Bool member uu env@@ -121,21 +176,19 @@ lookup :: Ord n => Bound n -> Env n -> Maybe (Type n) lookup uu env  = case uu of-        UName n _+        UName n           ->      Map.lookup n (envMap env)           `mplus` envPrimFun env n -        UIx i _ -         -> P.lookup i (zip [0..] (envStack env))--        UPrim n _-         -> envPrimFun env n+        UIx i           -> P.lookup i (zip [0..] (envStack env))+        UPrim n _       -> envPrimFun env n   -- | 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.@@ -144,8 +197,13 @@   -- | Lift all free deBruijn indices in the environment by the given number of steps.---   TODO: Delay this, only lift when we extract the final type.---         will also need to update the 'member' function.+---+--  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 -> Env n -> Env n lift n env         = Env@@ -153,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,149 +0,0 @@--module DDC.Type.Equiv-        (equivT)-where-import DDC.Type.Exp-import DDC.Type.Compounds-import DDC.Type.Transform.Crush-import DDC.Type.Transform.Trim-import DDC.Base.Pretty-import Data.Maybe-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, Pretty n) => Type n -> Type n -> Bool-equivT t1 t2-        = equivT' [] 0 [] 0 t1 t2---equivT' :: (Ord n, Pretty n)-        => [Bind n] -> Int-        -> [Bind n] -> Int-        -> Type n   -> Type n-        -> Bool--equivT' stack1 depth1 stack2 depth2 t1 t2- = let  t1'     = unpackSumT $ crushSomeT t1-        t2'     = unpackSumT $ crushSomeT t2-   in case (t1', t2') of-        (TVar u1,         TVar u2)-         -- Bound variables are name-equivalent.-         | u1 == u2     -> True--         -- Variables aren't name equivalent, -         -- but would be equivalent if we renamed them.-         | depth1 == depth2-         , Just (ix1, t1a)   <- getBindType stack1 u1-         , Just (ix2, t2a)   <- getBindType stack2 u2-         , ix1 == ix2-         -> equivT' stack1 depth1 stack2 depth2 t1a t2a--        -- Constructor names must be equal.-        (TCon tc1,        TCon tc2)-         -> tc1 == tc2--        -- Push binders on the stack as we enter foralls.-        (TForall b11 t12, TForall b21 t22)-         |  equivT  (typeOfBind b11) (typeOfBind b21)-         -> equivT' (b11 : stack1) (depth1 + 1) -                    (b21 : stack2) (depth2 + 1) -                    t12 t22--        -- Decend into applications.-        (TApp t11 t12,    TApp t21 t22)-         -> equivT' stack1 depth1 stack2 depth2 t11 t21-         && equivT' stack1 depth1 stack2 depth2 t12 t22-        -        -- Sums are equivalent if all of their components are.-        (TSum ts1,        TSum ts2)-         -> let ts1'      = Sum.toList ts1-                ts2'      = Sum.toList ts2-                equiv     = equivT' stack1 depth1 stack2 depth2--                -- 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 equiv 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.-                checkSlow = and [ or (map (equiv t1c) ts2') | t1c <- ts1' ]-                         && and [ or (map (equiv t2c) ts1') | t2c <- ts2' ]--            in  (length ts1' == length ts2')-            &&  (checkFast || checkSlow)--        (_, _)  -> False----- | Unpack single element sums into plain types.-unpackSumT :: Type n -> Type n-unpackSumT (TSum ts)-        | [t]   <- Sum.toList ts = t-unpackSumT tt                     = 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, Pretty n) => Type n -> Type n-crushSomeT tt- = 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----- | Lookup the type of a bound thing from the binder stack.---   The binder stack contains the binders of all the `TForall`s we've---   entered under so far.-getBindType :: Eq n => [Bind n] -> Bound n -> Maybe (Int, Type n)-getBindType bs' u- = go 0 bs'- where  go n (BName n1 t : bs)-         | UName n2 _   <- u-         , n1 == n2     = Just (n, t)-         | otherwise    = go (n + 1) bs---        go n (BAnon t   : bs)-         | UIx i _      <- u-         , i == 0       = Just (n, t)--         | UIx i _      <- u-         , i < 0        = Nothing--         | otherwise    = go (n + 1) bs---        go n (BNone _   : bs)-         = go (n + 1) bs--        go _ []         = Nothing-
DDC/Type/Exp.hs view
@@ -1,10 +1,7 @@  module DDC.Type.Exp         ( -- * Types, Kinds, and Sorts-          Binder   (..)-        , Bind     (..)-        , Bound    (..)-        , Type     (..)+          Type     (..)         , Kind,    Sort         , Region,  Effect, Closure         , TypeSum  (..),   TyConHash(..), TypeSumVarCon(..)@@ -12,260 +9,11 @@         , SoCon    (..)         , KiCon    (..)         , TwCon    (..)-        , TcCon    (..))+        , TcCon    (..)+        , Binder   (..)+        , Bind     (..)+        , Bound    (..)) where-import Data.Array-import Data.Map         (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 (Type n)    --        -- | Named variable that should be in the environment.-        | UName n   (Type n)--        -- | Named primitive that is not bound in the environment.-        --   Prims aren't every counted as being free.-        | 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-        = TypeSum-        { -- | 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)-        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 and primitive constructors.-        | TyConBound   (Bound n)-        deriving Show----- | Sort constructor.-data SoCon-        -- | Sort of witness kinds.-        = SoConProp                -- '@@'--        -- | Sort of computation kinds.-        | SoConComp                -- '**'-        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          -- '@ :: @@'--        -- Computation kinds ----------------------        -- | Kind of data values.-        | KiConData             -- '* :: **'--        -- | Kind of regions.-        | KiConRegion           -- '% :: **'--        -- | Kind of effects.-        | KiConEffect           -- '! :: **'--        -- | Kind of closures.-        | KiConClosure          -- '$ :: **'-        deriving (Eq, Show)----- | Witness type constructors.-data TwCon-        -- Witness implication.-        = TwConImpl             -- :: '(=>) :: * ~> *'--        -- | Purity of some effect.-        | TwConPure             -- :: ! ~> @--        -- | Emptiness of some closure.-        | TwConEmpty            -- :: $ ~> @--        -- | Globalness of some region.-        | TwConGlobal           -- :: % ~> @--        -- | Globalness of material regions in some type.-        | TwConDeepGlobal       -- :: * ~> @-        -        -- | Constancy of some region.-        | TwConConst            -- :: % ~> @--        -- | Constancy of material regions in some type-        | TwConDeepConst        -- :: * ~> @--        -- | Mutability of some region.-        | TwConMutable          -- :: % ~> @--        -- | Mutability of material regions in some type.-        | TwConDeepMutable      -- :: * ~> @--        -- | Laziness of some region.-        | TwConLazy             -- :: % ~> @--        -- | Laziness of the primary region in some type.-        | TwConHeadLazy         -- :: * ~> @--        -- | Manifestness of some region (not lazy).-        | TwConManifest         -- :: % ~> @-        deriving (Eq, Show)----- | Other constructors at the spec level.-data TcCon-        -- Data type constructors ----------------        -- | The function type constructor is baked in so we -        --   represent it separately.-        = TcConFun              -- '(->) :: * ~> * ~> ! ~> $ ~> *'--        -- Effect type constructors --------------        -- | Read of some region.-        | TcConRead             -- :: '% ~> !'--        -- | Read the head region in a data type.-        | TcConHeadRead         -- :: '* ~> !'--        -- | Read of all material regions in a data type.-        | TcConDeepRead         -- :: '* ~> !'-        -        -- | Write of some region.-        | TcConWrite            -- :: '% ~> !'--        -- | Write to all material regions in some data type.-        | TcConDeepWrite        -- :: '* ~> !'-        -        -- | Allocation into some region.-        | TcConAlloc            -- :: '% ~> !'--        -- | Allocation into all material regions in some data type.-        | TcConDeepAlloc        -- :: '* ~> !'-        -        -- Closure type constructors -------------        -- | Region is captured in a closure.-        | TcConUse              -- :: '% ~> $'-        -        -- | All material regions in a data type are captured in a closure.-        | TcConDeepUse          -- :: '* ~> $'-        deriving (Eq, Show)+import DDC.Type.Exp.Simple.Exp+import DDC.Type.Exp.Simple.NFData       ()
+ 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/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/Parser.hs 
@@ -1,236 +0,0 @@---- | Parser for type expressions.-module DDC.Type.Parser-        ( module DDC.Base.Parser-        , Parser-        , pType, pTypeAtom, pTypeApp-        , pBinder-        , pIndex-        , pTok, pTokAs)-where-import DDC.Core.Parser.Tokens   -import DDC.Type.Exp-import DDC.Type.Compounds-import DDC.Base.Parser                  ((<?>))-import qualified DDC.Base.Parser        as P-import qualified DDC.Type.Sum           as TS----- | Parser of type tokens.-type Parser n a-        = P.Parser (Tok n) a----- | Top level parser for types.-pType   :: Ord n => Parser n (Type n)-pType   = pTypeSum- <?> "a type"-----  | Parse a type sum.-pTypeSum :: Ord n => Parser n (Type n)-pTypeSum - = do   t1      <- pTypeForall-        P.choice -         [ -- Type sums.-           -- T2 + T3-           do   pTok KPlus-                t2      <- pTypeSum-                return  $ TSum $ TS.fromList (tBot sComp) [t1, t2]-                -         , do   return t1 ]- <?> "a type"----- | Parse a binder.-pBinder :: Ord n => Parser n (Binder n)-pBinder- = P.choice-        -- Named binders.-        [ do    v       <- pVar-                return  $ RName v-                -        -- Anonymous binders.-        , do    pTok KHat-                return  $ RAnon -        -        -- Vacant binders.-        , do    pTok KUnderscore-                return  $ RNone ]- <?> "a binder"----- | Parse a quantified type.-pTypeForall :: Ord n => Parser n (Type n)-pTypeForall- = P.choice-         [ -- Universal quantification.-           -- [v1 v1 ... vn : T1]. T2-           do   pTok KSquareBra-                bs      <- P.many1 pBinder-                pTok KColon-                k       <- pTypeSum-                pTok KSquareKet-                pTok KDot--                body    <- pTypeForall--                return  $ foldr TForall body -                        $ map (\b -> makeBindFromBinder b k) bs--           -- Body type-         , do   pTypeFun]- <?> "a type"----- | Parse a function type.-pTypeFun :: Ord n => Parser n (Type n)-pTypeFun- = do   t1      <- pTypeApp-        P.choice -         [ -- T1 ~> T2-           do   pTok KArrowTilde-                t2      <- pTypeFun-                return  $ TApp (TApp (TCon (TyConKind KiConFun)) t1) t2--           -- T1 => T2-         , do   pTok KArrowEquals-                t2      <- pTypeFun-                return  $ TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2--           -- T1 -> T2-         , do   pTok KArrowDash-                t2      <- pTypeFun-                return  $ t1 `tFunPE` t2--           -- T1 -(TSUM | TSUM)> t2-         , do   pTok KDash-                pTok KRoundBra-                eff     <- pTypeSum-                pTok KBar-                clo     <- pTypeSum-                pTok KRoundKet-                pTok KAngleKet-                t2      <- pTypeFun-                return  $ tFun t1 eff clo t2---           -- Body type-         , do   return t1 ]- <?> "an atomic type or type application"----- | Parse a type application.-pTypeApp :: Ord n => Parser n (Type n)-pTypeApp  - = do   (t:ts)  <- P.many1 pTypeAtom-        return  $  foldl TApp t ts- <?> "an atomic type or type application"----- | Parse a variable, constructor or parenthesised type.-pTypeAtom :: Ord n => Parser n (Type n)-pTypeAtom  - = P.choice-        -- (~>) and (=>) and (->) and (TYPE2)-        [ do    pTok KRoundBra-                P.choice-                 [ do   pTok KArrowTilde-                        pTok KRoundKet-                        return (TCon $ TyConKind KiConFun)--                 , do   pTok KArrowEquals-                        pTok KRoundKet-                        return (TCon $ TyConWitness TwConImpl)--                 , do   pTok KArrowDash-                        pTok KRoundKet-                        return (TCon $ TyConSpec TcConFun)--                 , do   t       <- pTypeSum-                        pTok KRoundKet-                        return t -                 ]--        -- Named type constructors-        , do    tc      <- pTcCon-                return  $ TCon (TyConSpec tc)--        , do    tc      <- pTwCon-                return  $ TCon (TyConWitness tc)--        , do    tc      <- pTyConNamed-                return  $ TCon tc--        -- Symbolic constructors.-        , do    pTokAs KSortComp    (TCon $ TyConSort SoConComp)-        , do    pTokAs KSortProp    (TCon $ TyConSort SoConProp) -        , do    pTokAs KKindValue   (TCon $ TyConKind KiConData)-        , do    pTokAs KKindRegion  (TCon $ TyConKind KiConRegion) -        , do    pTokAs KKindEffect  (TCon $ TyConKind KiConEffect) -        , do    pTokAs KKindClosure (TCon $ TyConKind KiConClosure) -        , do    pTokAs KKindWitness (TCon $ TyConKind KiConWitness) -            -        -- Bottoms.-        , do    pTokAs KBotEffect  (tBot kEffect)-        , do    pTokAs KBotClosure (tBot kClosure)-      -        -- Bound occurrence of a variable.-        --  We don't know the kind of this variable yet, so fill in the-        --  field with the bottom element of computation kinds. This isn't-        --  really part of the language, but makes sense implentation-wise.-        , do    v       <- pVar-                return  $  TVar (UName v (tBot sComp))--        , do    i       <- pIndex-                return  $  TVar (UIx (fromIntegral i) (tBot sComp))-        ]- <?> "an atomic type"------------------------------------------------------------------------------------- | Parse a builtin `TcCon`-pTcCon :: Parser n TcCon-pTcCon  =   P.pTokMaybe f-        <?> "a type constructor"- where f (KA (KTcConBuiltin c)) = Just c-       f _                      = Nothing ---- | Parse a builtin `TwCon`-pTwCon :: Parser n TwCon-pTwCon  =   P.pTokMaybe f-        <?> "a witness constructor"- where f (KA (KTwConBuiltin c)) = Just c-       f _                      = Nothing---- | Parse a user `TcCon`-pTyConNamed :: Parser n (TyCon n)-pTyConNamed  -        =   P.pTokMaybe f-        <?> "a type constructor"- where  f (KN (KCon n))          = Just (TyConBound (UName n (tBot kData)))-        f _                      = Nothing---- | Parse a variable.-pVar :: Parser n n-pVar    =   P.pTokMaybe f-        <?> "a variable"- where  f (KN (KVar n))         = Just n-        f _                     = Nothing---- | Parse a deBruijn index-pIndex :: Parser n Int-pIndex  =   P.pTokMaybe f-        <?> "an index"- where  f (KA (KIndex i))       = Just i-        f _                     = Nothing---- | Parse an atomic token.-pTok :: TokAtom -> Parser n ()-pTok k     = P.pTok (KA k)----- | Parse an atomic token and return some value.-pTokAs :: TokAtom -> a -> Parser n a-pTokAs k x = P.pTokAs (KA k) x-
− DDC/Type/Predicates.hs 
@@ -1,98 +0,0 @@---- | Predicates on type expressions.-module DDC.Type.Predicates-        ( isBot-        , isAtomT-        , isDataKind-        , isRegionKind-        , isEffectKind-        , isClosureKind-        , isWitnessKind-        , isAlgDataType)-where-import DDC.Type.Exp-import DDC.Type.Compounds-import qualified DDC.Type.Sum   as T----- Atoms ------------------------------------------------------------------------- | 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----- 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 '*'.---- Algebraic data types are all built from constructors--- that have '*' as their result 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 u  <- tc-        = takeResultKind (typeOfBound u) == kData--        | otherwise-        = False-
− DDC/Type/Pretty.hs 
@@ -1,182 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}-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--stage   = "DDC.Type.Pretty"---- 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 t       -> parens (ppr n <> text ":" <> ppr t)-        UName n _       -> ppr n---        UPrim n _       -> ppr n---        UIx i t         -> parens (text "^" <> ppr i <> text ":" <> ppr t)-        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--        TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFun)) 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     -         -> ppr (Sum.kindOfSum ts) <> text "0"-         -         | 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 "!0"-         | isClosureKind $ Sum.kindOfSum ss -> text "$0"-         | isDataKind    $ Sum.kindOfSum ss -> text "*0"-         | otherwise     -> error $ stage ++ ": malformed sum"-         -      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---instance Pretty SoCon where- ppr sc -  = case sc of-        SoConComp       -> text "**"-        SoConProp       -> text "@@"---instance Pretty KiCon where- ppr kc-  = case kc of-        KiConFun        -> text "(~>)"-        KiConData       -> text "*"-        KiConRegion     -> text "%"-        KiConEffect     -> text "!"-        KiConClosure    -> text "$"-        KiConWitness    -> text "@"---instance Pretty TwCon where- ppr tw-  = case tw of-        TwConImpl       -> text "(=>)"-        TwConPure       -> text "Pure"-        TwConEmpty      -> text "Empty"-        TwConGlobal     -> text "Global"-        TwConDeepGlobal -> text "DeepGlobal"-        TwConConst      -> text "Const"-        TwConDeepConst  -> text "DeepConst"-        TwConMutable    -> text "Mutable"-        TwConDeepMutable-> text "DeepMutable"-        TwConLazy       -> text "Lazy"-        TwConHeadLazy   -> text "HeadLazy"-        TwConManifest   -> text "Manifest"-        --instance Pretty TcCon where- ppr tc -  = case tc of-        TcConFun        -> text "(->)"-        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/Rewrite.hs 
@@ -1,264 +0,0 @@---- | Rewriting of variable binders to anonymous form to avoid capture.-module DDC.Type.Rewrite-        ( Rewrite(..)-        , Sub(..)-        , BindStack(..)-        , pushBind-        , pushBinds-        , substBound--        , bind1, bind0, bind0s-        , use1,  use0)-where-import DDC.Core.Exp-import DDC.Type.Compounds-import Data.List-import Data.Set                         (Set)-import qualified DDC.Type.Sum           as Sum-import qualified Data.Set               as Set----- | Substitution state.---   Keeps track of the binders in the environment that have been rewrittten---   to avoid variable capture or spec binder shadowing.-data Sub n-        = Sub-        { -- | Bound variable that we're substituting for.-          subBound      :: Bound n--          -- | We've decended past a binder that shadows the one that we're-          --   substituting for. We're no longer substituting, but still may-          --   need to anonymise variables in types. -          --   This can only happen for level-0 named binders.-        , subShadow0    :: Bool --          -- | Level-1 names that need to be rewritten to avoid capture.-        , subConflict1  :: Set n--          -- | Level-0 names that need to be rewritten to avoid capture.-        , subConflict0  :: Set n --          -- | Rewriting stack for level-1 names.-        , subStack1     :: BindStack n--          -- | Rewriting stack for level-0 names.-        , subStack0     :: BindStack n  }----- | Stack of anonymous binders that we've entered under during substitution. -data BindStack n-        = BindStack-        { -- | Holds anonymous binders that were already in the program,-          --   as well as named binders that are being rewritten to anonymous ones.-          --   In the resulting expression all these binders will be anonymous.-          stackBinds    :: [Bind n]--          -- | Holds all binders, independent of whether they are being rewritten or not.-        , stackAll      :: [Bind n] --          -- | Number of `BAnon` in `stackBinds`.-        , stackAnons    :: Int--          -- | Number of `BName` in `stackBinds`.-        , stackNamed    :: Int }----- | Push several binds onto the bind stack,---   anonymyzing them if need be to avoid variable capture.-pushBinds :: Ord n => Set n -> BindStack n -> [Bind n]  -> (BindStack n, [Bind n])-pushBinds fns stack bs-        = mapAccumL (pushBind fns) stack bs----- | Push a bind onto a bind stack, ---   anonymizing it if need be to avoid variable capture.-pushBind-        :: Ord n-        => Set n                  -- ^ Names that need to be rewritten.-        -> BindStack n            -- ^ Current bind stack.-        -> Bind n                 -- ^ Bind to push.-        -> (BindStack n, Bind n)  -- ^ New stack and possibly anonymised bind.--pushBind fns bs@(BindStack stack env dAnon dName) bb- = case bb of-        -- Push already anonymous bind on stack.-        BAnon t                 -         -> ( BindStack (BAnon t   : stack) (BAnon t : env) (dAnon + 1) dName-            , BAnon t)-            -        -- If the binder needs to be rewritten then push the original name on the-        -- 'stackBinds' to remember this.-        BName n t-         | Set.member n fns     -         -> ( BindStack (BName n t : stack) (BAnon t : env)  dAnon       (dName + 1)-            , BAnon t)--         | otherwise-         -> ( BindStack stack               (BName n t : env) dAnon dName-            , bb)--        -- Binder was a wildcard.-        _ -> (bs, bb)------ | Compare a `Bound` against the one we're substituting for.-substBound-        :: Ord n-        => BindStack n      -- ^ Current Bind stack during substitution.-        -> Bound n          -- ^ Bound we're substituting for.-        -> Bound n          -- ^ Bound we're looking at now.-        -> Either -                (Bound n)   --   Bound doesn't match, but replace with this one.-                Int         --   Bound matches, drop the thing being substituted and -                            --   and lift indices this many steps.--substBound (BindStack binds _ dAnon dName) u u'-        -- Bound name matches the one that we're substituting for.-        | UName n1 _   <- u-        , UName n2 _   <- u'-        , n1 == n2-        = Right (dAnon + dName)--        -- Bound index matches the one that we're substituting for.-        | UIx  i1 _     <- u-        , UIx  i2 _     <- u'-        , i1 + dAnon == i2 -        = Right (dAnon + dName)--        -- The Bind for this name was rewritten to avoid variable capture,-        -- so we also have to update the bound occurrence.-        | UName _ t     <- u'-        , Just ix       <- findIndex (boundMatchesBind u') binds-        = Left $ UIx ix t--        -- Bound index doesn't match, but lower this index by one to account-        -- for the removal of the outer binder.-        | UIx  i2 t     <- u'-        , i2 > dAnon-        , cutOffset     <- case u of-                                UIx{}   -> 1-                                _       -> 0-        = Left $ UIx (i2 + dName - cutOffset) t--        -- Some name that didn't match.-        | otherwise-        = Left u'------------------------------------------------------------------------------------- | Push a level-1 binder on the rewrite stack.-bind1 :: Ord n => Sub n -> Bind n -> (Sub n, Bind n)-bind1 sub b - = let  (stackT', b')     = pushBind (subConflict1 sub) (subStack1 sub) b-   in   (sub { subStack1  = stackT' }, b')----- | Push a level-0 binder on the rewrite stack.-bind0 :: Ord n => Sub n -> Bind n -> (Sub n, Bind n)-bind0 sub b - = let  b1                  = rewriteWith sub b-        (stackX', b2)       = pushBind (subConflict0 sub) (subStack0 sub) b1-   in   ( sub { subStack0   = stackX'-              , subShadow0  =  subShadow0 sub -                            || namedBoundMatchesBind (subBound sub) b2 }-        , b2)----- | Push some level-0 binders on the rewrite stack.-bind0s :: Ord n => Sub n -> [Bind n] -> (Sub n, [Bind n])-bind0s = mapAccumL bind0----- | Rewrite a use of a level-1 binder if need be.-use1 :: Ord n => Sub n -> Bound n -> Bound n-use1 sub u-        | UName _ t             <- u-        , BindStack binds _ _ _ <- subStack1 sub-        , Just ix               <- findIndex (boundMatchesBind u) binds-        = UIx ix t--        | otherwise-        = u----- | Rewrite the use of a level-0 binder if need be.-use0 :: Ord n => Sub n -> Bound n -> Bound n-use0 sub u-        | UName _ t             <- u-        , BindStack binds _ _ _ <- subStack0 sub-        , Just ix               <- findIndex (boundMatchesBind u) binds-        = UIx ix (rewriteWith sub t)--        | otherwise-        = rewriteWith sub u-----------------------------------------------------------------------------------class Rewrite (c :: * -> *) where- -- | Rewrite names in some thing to anonymous form if they conflict with---    any names in the `Sub` state.- rewriteWith :: Ord n => Sub n -> c n -> c n ---instance Rewrite Bind where- rewriteWith sub bb-  = replaceTypeOfBind  (rewriteWith sub (typeOfBind bb))  bb---instance Rewrite Bound where- rewriteWith sub uu-  = replaceTypeOfBound (rewriteWith sub (typeOfBound uu)) uu---instance Rewrite LetMode where- rewriteWith sub lm-  = case lm of-        LetStrict        -> lm-        LetLazy (Just t) -> LetLazy (Just $ rewriteWith sub t) -        LetLazy Nothing  -> LetLazy Nothing---instance Rewrite Cast where- rewriteWith sub cc-  = let down    = rewriteWith sub -    in case cc of-        CastWeakenEffect  eff   -> CastWeakenEffect  (down eff)-        CastWeakenClosure clo   -> CastWeakenClosure (down clo)-        CastPurify w            -> CastPurify (down w)-        CastForget w            -> CastForget (down w)---instance Rewrite Type where- rewriteWith sub tt -  = let down    = rewriteWith -    in case tt of-        TVar u          -> TVar (use1 sub u)-        TCon{}          -> tt--        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)---instance Rewrite TypeSum where- rewriteWith sub ts-        = Sum.fromList (Sum.kindOfSum ts)-        $ map (rewriteWith sub)-        $ Sum.toList ts---instance Rewrite Witness where- rewriteWith sub ww-  = let down    = rewriteWith -    in case ww of-        WVar u          -> WVar  (use0 sub u)-        WCon{}          -> ww-        WApp  w1 w2     -> WApp  (down sub w1) (down sub w2)-        WJoin w1 w2     -> WJoin (down sub w1) (down sub w2)-        WType t         -> WType (down sub t)
− 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
@@ -2,32 +2,48 @@ -- | Utilities for working with `TypeSum`s. -- module DDC.Type.Sum -        ( empty+        ( -- * Constructors+          empty         , singleton-        , elem-        , insert-        , delete         , union         , unions-        , difference+        , insert++          -- * Conversion+        , toList+        , fromList++          -- * Projection         , kindOfSum-        , toList, fromList-        , hashTyCon, hashTyConRange-        , unhashTyCon-        , takeSumArrayElem-        , makeSumArrayElem)+        , elem++          -- * Deletion+        , delete+        , difference++          -- * Hashing+        , hashTyCon+        , hashTyConRange+        , unhashTyCon) where import DDC.Type.Exp import Data.Array-import qualified Data.List      as L-import qualified Data.Map       as Map-import qualified Data.Set       as Set-import Prelude                  hiding (elem)+import qualified Data.List              as L+import qualified Data.Map.Strict        as Map+import qualified Data.Set               as Set+import Prelude                          hiding (elem)   -- | Construct an empty type sum of the given kind. empty :: Kind n -> TypeSum n-empty k = TypeSum+empty k = TypeSumBot k+++-- | Construct an empty type sum of the given kind, but in `TypeSumSet` form.+--   This isn't exported.+emptySet :: Kind n -> TypeSum n+emptySet k +        = TypeSumSet         { typeSumKind           = k         , typeSumElems          = listArray hashTyConRange (repeat Set.empty)         , typeSumBoundNamed     = Map.empty@@ -50,17 +66,15 @@ --   * May return False if the first argument is miskinded but still --     alpha-equivalent to some component of the sum. elem :: (Eq n, Ord n) => Type n -> TypeSum n -> Bool-elem t ts +elem _ TypeSumBot{}      =  False+elem t ts@TypeSumSet{}  = case t of-        TVar (UName n _) -> Map.member n (typeSumBoundNamed ts)+        TVar (UName n)   -> Map.member n (typeSumBoundNamed ts)+        TVar (UIx   i)   -> Map.member i (typeSumBoundAnon  ts)         TVar (UPrim n _) -> Map.member n (typeSumBoundNamed ts)-        TVar (UIx   i _) -> Map.member i (typeSumBoundAnon  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@@ -69,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@@ -86,18 +105,18 @@  -- | Insert a new element into a sum. insert :: Ord n => Type n -> TypeSum n -> TypeSum n-insert t ts- = case t of-        TVar (UName n k) -> ts { typeSumBoundNamed = Map.insert n k (typeSumBoundNamed ts) }-        TVar (UPrim n k) -> ts { typeSumBoundNamed = Map.insert n k (typeSumBoundNamed ts) }-        TVar (UIx   i k) -> ts { typeSumBoundAnon  = Map.insert i k (typeSumBoundAnon  ts) }-        TCon{}           -> ts { typeSumSpill      = t : typeSumSpill ts }+insert t (TypeSumBot k)   = insert t (emptySet k)+insert t ts@TypeSumSet{}+ = let k        = typeSumKind ts+   in case t of+        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) } -        -- 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      = t : typeSumSpill ts }+        TCon{}          -> ts { typeSumSpill      = L.nub $ t : typeSumSpill ts } +        TAbs{}          -> ts { typeSumSpill      = L.nub $ t : typeSumSpill ts }+         TApp (TCon _) _          |  Just (h, vc)  <- takeSumArrayElem t          ,  tsThere       <- typeSumElems ts ! h@@ -105,27 +124,36 @@                 then ts                 else ts { typeSumElems = (typeSumElems ts) // [(h, Set.insert vc tsThere)] }         -        TApp{}           -> ts { typeSumSpill      = t : typeSumSpill ts }+        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')   -- | Delete an element from a sum. delete :: Ord n => Type n -> TypeSum n -> TypeSum n-delete t ts+delete _ ts@TypeSumBot{} = ts+delete t ts@TypeSumSet{}  = case t of-        TVar (UName n _) -> ts { typeSumBoundNamed = Map.delete n (typeSumBoundNamed ts) }-        TVar (UPrim n _) -> ts { typeSumBoundNamed = Map.delete n (typeSumBoundNamed ts) }-        TVar (UIx   i _) -> ts { typeSumBoundAnon  = Map.delete i (typeSumBoundAnon  ts) }-        TCon{}           -> ts { typeSumSpill      = L.delete t (typeSumSpill ts) }-        TForall{}        -> ts { typeSumSpill      = L.delete t (typeSumSpill ts) }+        TVar (UName n)  -> ts { typeSumBoundNamed = Map.delete n (typeSumBoundNamed ts) }+        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) }++        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') @@ -157,7 +185,10 @@  -- | Flatten out a sum, yielding a list of individual terms. toList :: TypeSum n -> [Type n]-toList TypeSum+toList TypeSumBot{}       + = []++toList TypeSumSet         { typeSumKind           = _kind         , typeSumElems          = sumElems         , typeSumBoundNamed     = named@@ -166,8 +197,8 @@   =      [ makeSumArrayElem h vc                 | (h, ts) <- assocs sumElems, vc <- Set.toList ts] -        ++ [TVar $ UName n k | (n, k) <- Map.toList named]-        ++ [TVar $ UIx   i k | (i, k) <- Map.toList anon]+        ++ [TVar $ UName n | (n, _) <- Map.toList named]+        ++ [TVar $ UIx   i | (i, _) <- Map.toList anon]         ++ spill                  @@ -194,8 +225,6 @@         TcConWrite      -> Just $ TyConHash 2         TcConDeepWrite  -> Just $ TyConHash 3         TcConAlloc      -> Just $ TyConHash 4-        TcConUse        -> Just $ TyConHash 5-        TcConDeepUse    -> Just $ TyConHash 6         _               -> Nothing  @@ -216,12 +245,10 @@         2               -> TcConWrite         3               -> TcConDeepWrite         4               -> TcConAlloc-        5               -> TcConUse-        6               -> TcConDeepUse          -- This should never happen, because we only produce hashes         -- with the above 'hashTyCon' function.-        _ -> error $ "DDC.Type.Sum: bad TyConHash " ++ show i+        _ -> error $ "ddc-core.unhashTyCon: bad TyConHash " ++ show i   -- | If this type can be put in one of our arrays then split it@@ -231,7 +258,7 @@         | Just h        <- hashTyCon tc         = case t2 of                 TVar u                  -> Just (h, TypeSumVar u)-                TCon (TyConBound u)     -> Just (h, TypeSumCon u)+                TCon (TyConBound u k)   -> Just (h, TypeSumCon u k)                 _                       -> Nothing          takeSumArrayElem _ = Nothing@@ -243,7 +270,7 @@  = let  tc       = unhashTyCon h    in   case vc of          TypeSumVar u   -> TApp (TCon tc) (TVar u)-         TypeSumCon u   -> TApp (TCon tc) (TCon (TyConBound u))+         TypeSumCon u k -> TApp (TCon tc) (TCon (TyConBound u k))   -- Type Equality --------------------------------------------------------------@@ -268,6 +295,7 @@         -- Unwrap single element sums into plain types.   where normalise (TSum ts)          | [t'] <- toList ts    = t'+         | []   <- toList ts    = TSum $ empty (typeSumKind ts)          normalise t'            = t' @@ -280,25 +308,47 @@         , []    <- toList ts2         = typeSumKind ts1 == typeSumKind ts2 -        -- If the sum has elements, then compare them directly and ignore the+        | TypeSumBot{}  <- normalise ts1+        , TypeSumBot{}  <- normalise ts2+        = typeSumKind ts1 == typeSumKind ts2++        -- If both sums have elements, then compare them directly and ignore the         -- kind. This allows us to use (tBot sComp) as the typeSumKind field         -- when we want to compute the real kind based on the elements. -        | otherwise+        | TypeSumSet{} <- ts1+        , 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 +  where normalise ts+         | []   <- toList ts    = empty (typeSumKind ts)+        normalise ts            = ts++ instance Ord n => Ord (Bound n) where- compare (UName n1 _) (UName n2 _)      = compare n1 n2- compare (UIx   i1 _) (UIx   i2 _)      = compare i1 i2- compare (UPrim n1 _) (UPrim n2 _)      = compare n1 n2- compare (UIx   _  _) _                 = LT- compare (UName _  _) (UIx   _ _)       = GT- compare (UName _  _) (UPrim _ _)       = LT- compare (UPrim _  _) _                 = GT+ compare (UName n1)     (UName n2)              = compare n1 n2+ compare (UIx   i1)     (UIx   i2)              = compare i1 i2+ compare (UPrim n1 _)   (UPrim n2 _)            = compare n1 n2+ compare UIx{}          _                       = LT+ compare UName{}        UIx{}                   = GT+ compare UName{}        UPrim{}                 = LT+ compare UPrim{}        _                       = GT -deriving instance Eq n  => Eq  (TypeSumVarCon n)-deriving instance Ord n => Ord (TypeSumVarCon n)++instance Eq n => Eq (TypeSumVarCon n) where+ (==) (TypeSumVar u1)      (TypeSumVar u2)      = u1 == u2+ (==) (TypeSumCon u1 _)    (TypeSumCon u2 _)    = u1 == u2+ (==) _ _                                       = False++instance Ord n => Ord (TypeSumVarCon n) where+ compare (TypeSumVar u1)   (TypeSumVar u2)      = compare u1 u2+ compare (TypeSumCon u1 _) (TypeSumCon u2 _)    = compare u1 u2+ compare (TypeSumVar _)    _                    = LT+ compare (TypeSumCon _ _)  _                    = GT
+ 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,152 +0,0 @@-module DDC.Type.Transform.Crush-        (crushEffect)-where-import DDC.Type.Predicates-import DDC.Type.Compounds-import DDC.Type.Exp-import qualified DDC.Type.Sum   as Sum----- | 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- = 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 u, (tR : _)) -              |  (k1 : _, _) <- takeKFuns (typeOfBound u)-              ,  isRegionKind k1-              -> tRead tR--             -- Type has no head region.-             -- This happens with  case () of { ... }-             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 u, ts)-              | (ks, _)  <- takeKFuns (typeOfBound u)-              , 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 u, ts)-              | (ks, _)  <- takeKFuns (typeOfBound u)-              , 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 u, ts)-              | (ks, _)  <- takeKFuns (typeOfBound u)-              , length ks == length ts-              , Just effs       <- sequence $ zipWith makeDeepAlloc ks ts-              -> crushEffect $ TSum $ Sum.fromList kEffect effs--             _ -> tt--         -- TODO: we're hijacking crushEffect to work on witnesses as well.-         --       we should split this into another function.-         -- Deep Global-         -- See Note: Crushing with higher kinded type vars.-         | Just (TyConWitness TwConDeepGlobal, [t]) <- takeTyConApps tt-         -> case takeTyConApps t of-             Just (TyConBound u, ts)-              | (ks, _)  <- takeKFuns (typeOfBound u)-              , 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/Instantiate.hs view
@@ -5,12 +5,16 @@ where import DDC.Type.Exp import DDC.Type.Transform.SubstituteT-import DDC.Base.Pretty          (Pretty)   -- | Instantiate a type with an argument. --   The type to be instantiated must have an outer forall, else `Nothing`.-instantiateT :: (Ord n, Pretty n) => Type n -> Type n -> Maybe (Type n)+instantiateT +        :: Ord n+        => Type n               -- ^ Type to instantiate.+        -> Type n               -- ^ Argument type.+        -> Maybe (Type n)+ instantiateT (TForall b tBody) t2 = Just $ substituteT b t2 tBody instantiateT _ _                  = Nothing @@ -18,7 +22,12 @@ -- | Instantiate a type with several arguments. --   The type to be instantiated must have at least as many outer foralls  --   as provided type arguments, else `Nothing`.-instantiateTs :: (Ord n, Pretty n) => Type n -> [Type n] -> Maybe (Type n)+instantiateTs +        :: Ord n+        => Type n               -- ^ Type to instantiate.+        -> [Type n]             -- ^ Argument types.+        -> Maybe (Type n)+ instantiateTs t []              = Just t instantiateTs t (tArg:tsArgs)  = case instantiateT t tArg of
− DDC/Type/Transform/LiftT.hs 
@@ -1,63 +0,0 @@---- | Lifting of deBruijn indices in a type.-------   TODO: merge this code with LowerT-module DDC.Type.Transform.LiftT-        (LiftT(..))-where-import DDC.Type.Exp-import DDC.Type.Compounds-import qualified DDC.Type.Sum   as Sum---class LiftT (c :: * -> *) where-- -- | Lift type indices that are at least a certain depth by the given number of levels.- liftAtDepthT   -        :: forall n. Ord n-        => Int          -- ^ Number of levels to lift.-        -> Int          -- ^ Current binding depth.-        -> c n          -- ^ Lift type indices in this thing.-        -> c n- - -- | Wrapper for `liftAtDepthT` that starts at depth 0.       - liftT  :: forall n. Ord n-        => Int          -- ^ Number of levels to lift-        -> c n          -- ^ Lift type indices in this thing.-        -> c n-        - liftT n xx  = liftAtDepthT n 0 xx- --instance LiftT Bind where- liftAtDepthT n d bb-  = replaceTypeOfBind (liftAtDepthT n d $ typeOfBind bb) bb-  --instance LiftT Bound where- liftAtDepthT n d uu-  = case uu of-        UName{}         -> uu-        UPrim{}         -> uu-        UIx i t -         | d <= i       -> UIx (i + n) t-         | otherwise    -> uu-         --instance LiftT Type where- liftAtDepthT n d tt-  = let down = liftAtDepthT n-    in case tt of-        TVar u          -> TVar    (down d u)-        TCon{}          -> tt-        TForall b t     -> TForall (down d b)  (down (d + 1) t)-        TApp t1 t2      -> TApp    (down d t1) (down d t2)-        TSum ss         -> TSum    (down d ss)---instance LiftT TypeSum where- liftAtDepthT n d ss-  = Sum.fromList (liftAtDepthT n d $ Sum.kindOfSum ss)-        $ map (liftAtDepthT n d)-        $ Sum.toList ss-
− DDC/Type/Transform/LowerT.hs 
@@ -1,63 +0,0 @@---- | Lowering of deBruijn indices in a type.-------   TODO: merge this code with LiftT.-module DDC.Type.Transform.LowerT-        (LowerT(..))-where-import DDC.Type.Exp-import DDC.Type.Compounds-import qualified DDC.Type.Sum   as Sum---class LowerT (c :: * -> *) where-- -- | Lower type indices that are at least a certain depth by the given number of levels.- lowerAtDepthT   -        :: forall n. Ord n-        => Int          -- ^ Number of levels to lower.-        -> Int          -- ^ Current binding depth.-        -> c n          -- ^ Lower type indices in this thing.-        -> c n- - -- | Wrapper for `lowerAtDepthT` that starts at depth 0.       - lowerT :: forall n. Ord n-        => Int          -- ^ Number of levels to lower.-        -> c n          -- ^ Lower type indices in this thing.-        -> c n-        - lowerT n xx  = lowerAtDepthT n 0 xx- --instance LowerT Bind where- lowerAtDepthT n d bb-  = replaceTypeOfBind (lowerAtDepthT n d $ typeOfBind bb) bb-  --instance LowerT Bound where- lowerAtDepthT n d uu-  = case uu of-        UName{}         -> uu-        UPrim{}         -> uu-        UIx i t -         | d <= i       -> UIx (i - n) t-         | otherwise    -> uu-         --instance LowerT Type where- lowerAtDepthT n d tt-  = let down = lowerAtDepthT n -    in case tt of-        TVar uu         -> TVar    (down d uu)-        TCon{}          -> tt-        TForall b t     -> TForall (down d b)  (down (d + 1) t)-        TApp t1 t2      -> TApp    (down d t1) (down d t2)-        TSum ss         -> TSum    (down d ss)---instance LowerT TypeSum where- lowerAtDepthT n d ss-  = Sum.fromList (lowerAtDepthT n d $ Sum.kindOfSum ss)-        $ map (lowerAtDepthT n d)-        $ Sum.toList ss-
+ DDC/Type/Transform/Rename.hs view
@@ -0,0 +1,252 @@++-- | Renaming of variable binders to anonymous form to avoid capture.+module DDC.Type.Transform.Rename+        ( Rename(..)++        -- * Substitution states+        , Sub(..)++        -- * Binding stacks+        , BindStack(..)+        , pushBind+        , pushBinds+        , substBound++        -- * Rewriting binding occurences+        , bind1, bind1s, bind0, bind0s++        -- * Rewriting bound occurences+        , use1,  use0)+where+import DDC.Type.Exp.Simple+import Data.List+import Data.Set                         (Set)+import qualified DDC.Type.Sum           as Sum+import qualified Data.Set               as Set+++-------------------------------------------------------------------------------+class Rename (c :: * -> *) where+ -- | Rewrite names in some thing to anonymous form if they conflict with+--    any names in the `Sub` state. We use this to avoid variable capture+--    during substitution.+ renameWith :: Ord n => Sub n -> c n -> c n +++instance Rename Type where+ renameWith sub tt +  = {-# SCC renameWith #-}+    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'++        TSum ts         -> TSum (down sub ts)+++instance Rename TypeSum where+ renameWith sub ts+        = Sum.fromList (Sum.kindOfSum ts)+        $ map (renameWith sub)+        $ Sum.toList ts+++instance Rename Bind where+ renameWith sub bb+  = replaceTypeOfBind  (renameWith sub (typeOfBind bb))  bb+++-------------------------------------------------------------------------------+-- | Substitution state.+--   Keeps track of the binders in the environment that have been rewrittten+--   to avoid variable capture or spec binder shadowing.+data Sub n+        = Sub+        { -- | Bound variable that we're substituting for.+          subBound      :: !(Bound n)++          -- | We've decended past a binder that shadows the one that we're+          --   substituting for. We're no longer substituting, but still may+          --   need to anonymise variables in types. +          --   This can only happen for level-0 named binders.+        , subShadow0    :: !Bool ++          -- | Level-1 names that need to be rewritten to avoid capture.+        , subConflict1  :: !(Set n)++          -- | Level-0 names that need to be rewritten to avoid capture.+        , subConflict0  :: !(Set n)++          -- | Rewriting stack for level-1 names.+        , subStack1     :: !(BindStack n)++          -- | Rewriting stack for level-0 names.+        , subStack0     :: !(BindStack n)  }+++-- | Stack of anonymous binders that we've entered under during substitution. +data BindStack n+        = BindStack+        { -- | Holds anonymous binders that were already in the program,+          --   as well as named binders that are being rewritten to anonymous ones.+          --   In the resulting expression all these binders will be anonymous.+          stackBinds    :: ![Bind n]++          -- | Holds all binders, independent of whether they are being rewritten or not.+        , stackAll      :: ![Bind n] ++          -- | Number of `BAnon` in `stackBinds`.+        , stackAnons    :: !Int++          -- | Number of `BName` in `stackBinds`.+        , stackNamed    :: !Int }+++-- | Push several binds onto the bind stack,+--   anonymyzing them if need be to avoid variable capture.+pushBinds :: Ord n => Set n -> BindStack n -> [Bind n]  -> (BindStack n, [Bind n])+pushBinds fns stack bs+        = mapAccumL (pushBind fns) stack bs+++-- | Push a bind onto a bind stack, +--   anonymizing it if need be to avoid variable capture.+pushBind+        :: Ord n+        => Set n                  -- ^ Names that need to be rewritten.+        -> BindStack n            -- ^ Current bind stack.+        -> Bind n                 -- ^ Bind to push.+        -> (BindStack n, Bind n)  -- ^ New stack and possibly anonymised bind.++pushBind fns bs@(BindStack stack env dAnon dName) bb+ = case bb of+        -- Push already anonymous bind on stack.+        BAnon t                 +         -> ( BindStack (BAnon t   : stack) (BAnon t : env) (dAnon + 1) dName+            , BAnon t)+            +        -- If the binder needs to be rewritten then push the original name on the+        -- 'stackBinds' to remember this.+        BName n t+         | Set.member n fns     +         -> ( BindStack (BName n t : stack) (BAnon t : env)  dAnon       (dName + 1)+            , BAnon t)++         | otherwise+         -> ( BindStack stack               (BName n t : env) dAnon dName+            , bb)++        -- Binder was a wildcard.+        _ -> (bs, bb)++++-- | Compare a `Bound` against the one we're substituting for.+substBound+        :: Ord n+        => BindStack n      -- ^ Current Bind stack during substitution.+        -> Bound n          -- ^ Bound we're substituting for.+        -> Bound n          -- ^ Bound we're looking at now.+        -> Either +                (Bound n)   --   Bound doesn't match, but replace with this one.+                Int         --   Bound matches, drop the thing being substituted and +                            --   and lift indices this many steps.++substBound (BindStack binds _ dAnon dName) u u'+        -- Bound name matches the one that we're substituting for.+        | UName n1      <- u+        , UName n2      <- u'+        , n1 == n2+        = Right (dAnon + dName)++        -- Bound index matches the one that we're substituting for.+        | UIx  i1       <- u+        , UIx  i2       <- u'+        , i1 + dAnon == i2 +        = Right (dAnon + dName)++        -- The Bind for this name was rewritten to avoid variable capture,+        -- so we also have to update the bound occurrence.+        | UName _       <- u'+        , Just ix       <- findIndex (boundMatchesBind u') binds+        = Left $ UIx ix++        -- Bound index doesn't match, but lower this index by one to account+        -- for the removal of the outer binder.+        | UIx  i2       <- u'+        , i2 > dAnon+        , cutOffset     <- case u of+                                UIx{}   -> 1+                                _       -> 0+        = Left $ UIx (i2 + dName - cutOffset)++        -- Some name that didn't match.+        | otherwise+        = Left u'+++-------------------------------------------------------------------------------+-- | Push a level-1 binder on the rewrite stack.+bind1 :: Ord n => Sub n -> Bind n -> (Sub n, Bind n)+bind1 sub b + = let  (stackT', b')     = pushBind (subConflict1 sub) (subStack1 sub) b+   in   (sub { subStack1  = stackT' }, b')+++-- | Push some level-1 binders on the rewrite stack.+bind1s :: Ord n => Sub n -> [Bind n] -> (Sub n, [Bind n])+bind1s = mapAccumL bind1+++-- | Push a level-0 binder on the rewrite stack.+bind0 :: Ord n => Sub n -> Bind n -> (Sub n, Bind n)+bind0 sub b + = let  b1                  = renameWith sub b+        (stackX', b2)       = pushBind (subConflict0 sub) (subStack0 sub) b1+   in   ( sub { subStack0   = stackX'+              , subShadow0  =  subShadow0 sub +                            || namedBoundMatchesBind (subBound sub) b2 }+        , b2)+++-- | Push some level-0 binders on the rewrite stack.+bind0s :: Ord n => Sub n -> [Bind n] -> (Sub n, [Bind n])+bind0s = mapAccumL bind0+++-- | Rewrite the use of a level-1 binder if need be.+use1 :: Ord n => Sub n -> Bound n -> Bound n+use1 sub u+        | UName _               <- u+        , BindStack binds _ _ _ <- subStack1 sub+        , Just ix               <- findIndex (boundMatchesBind u) binds+        = UIx ix++        | otherwise+        = u+++-- | Rewrite the use of a level-0 binder if need be.+use0 :: Ord n => Sub n -> Bound n -> Bound n+use0 sub u+        | UName _               <- u+        , BindStack binds _ _ _ <- subStack0 sub+        , Just ix               <- findIndex (boundMatchesBind u) binds+        = UIx ix++        | otherwise+        = u+
DDC/Type/Transform/SpreadT.hs view
@@ -2,18 +2,22 @@ module DDC.Type.Transform.SpreadT         (SpreadT(..)) where+import DDC.Type.DataDef import DDC.Type.Exp-import DDC.Type.Env                     (Env)+import DDC.Type.Env                     (TypeEnv) import qualified DDC.Type.Env           as Env import qualified DDC.Type.Sum           as T+import qualified Data.Map               as Map   class SpreadT (c :: * -> *) where - -- | Spread type annotations from variable binders in to the bound- --   occurrences.+ -- | Rewrite `UName` bounds to `UPrim` bounds and attach their types.+ --   Primitives have their types attached because they are so common in the+ --   language, their types are closed, and we don't want to keep having to+ --   look them up from the environment.  spreadT :: forall n. Ord n -         => Env n -> c n -> c n+         => TypeEnv n -> c n -> c n           instance SpreadT Type where@@ -22,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)          @@ -47,21 +56,50 @@  instance SpreadT Bound where  spreadT kenv uu-  | Just t'     <- Env.lookup uu kenv   = case uu of-        UIx ix _        -> UIx ix t'-        UPrim n _       -> UPrim n t'-        UName n _-         -> if Env.isPrim kenv n -                 then UPrim n t'-                 else UName n t'-                 -  | otherwise           = uu+        UIx{}           -> uu+        UPrim{}         -> uu +        UName n+         -> case Env.envPrimFun kenv n of+                Nothing -> UName n+                Just t  -> UPrim n t+                   instance SpreadT TyCon where  spreadT kenv tc   = case tc of-        TyConBound u    -> TyConBound (spreadT kenv u)+        TyConBound (UName n) _+         -> case Env.envPrimFun kenv n of+                Nothing -> tc+                Just t  -> TyConBound (UPrim n t) t+         _               -> tc+++instance SpreadT DataDef where+ spreadT kenv def@DataDef{}+  = def+  { dataDefCtors   +     = case dataDefCtors def of+        Nothing         -> Nothing+        Just ctors      -> Just (map (spreadT kenv) ctors) }+++instance SpreadT DataDefs where+ spreadT kenv defs+  = defs+  { dataDefsTypes  = Map.map (spreadT kenv) (dataDefsTypes defs)+  , dataDefsCtors  = Map.map (spreadT kenv) (dataDefsCtors defs) }+++instance SpreadT DataType where+ spreadT _kenv dt  = dt+++instance SpreadT DataCtor where+ spreadT kenv dc@DataCtor{}+  = dc+  { dataCtorFieldTypes  = map (spreadT kenv) (dataCtorFieldTypes dc)+  , dataCtorResultType  = spreadT kenv (dataCtorResultType dc) }
DDC/Type/Transform/SubstituteT.hs view
@@ -1,23 +1,20 @@  -- | Capture avoiding substitution of types in types. module DDC.Type.Transform.SubstituteT-        ( SubstituteT(..)-        , substituteT+        ( substituteT         , substituteTs         , substituteBoundT+        , SubstituteT(..)          , BindStack(..)         , pushBind         , pushBinds         , substBound) where-import DDC.Type.Exp-import DDC.Type.Compounds import DDC.Core.Collect-import DDC.Type.Transform.LiftT-import DDC.Type.Transform.Crush-import DDC.Type.Transform.Trim-import DDC.Type.Rewrite+import DDC.Type.Transform.BoundT+import DDC.Type.Transform.Rename+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,163 +0,0 @@--module DDC.Type.Transform.Trim -        (trimClosure)-where-import DDC.Core.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 @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-        = 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 TcConFun)) _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 @@ --- | Universes of the Disciple Core language. module DDC.Type.Universe         ( Universe(..)+        , universeUp         , universeFromType3         , universeFromType2         , universeFromType1         , universeOfType) where import DDC.Type.Exp-import DDC.Type.Compounds+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.@@ -45,6 +49,29 @@         deriving (Show, Eq)   +instance Pretty Universe where+ ppr u+  = case u of+        UniverseLevel i -> text "Universe" <> int i+        UniverseSort    -> text "Sort"+        UniverseKind    -> text "Kind"+        UniverseSpec    -> text "Spec"+        UniverseWitness -> text "Witness"+        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@@ -61,6 +88,7 @@ universeFromType2 tt  = case tt of         TVar _                  -> Nothing+         TCon (TyConSort _)      -> Just UniverseSpec          TCon (TyConKind kc)     @@ -69,48 +97,69 @@                 KiConData       -> Just UniverseData                 _               -> Nothing -        TCon (TyConWitness _)   -> Nothing-        TCon (TyConSpec  _)     -> Nothing-        TCon (TyConBound _)     -> Nothing-        TForall _ _             -> Nothing+        TCon TyConWitness{}     -> Nothing+        TCon TyConSpec{}        -> Nothing+        TCon TyConBound{}       -> Nothing+        TCon TyConExists{}      -> Nothing++        TAbs{}                  -> Nothing         TApp _ t2               -> universeFromType2 t2+        TForall{}               -> Nothing         TSum _                  -> Nothing   -- | Given the type of some thing (up one level), --   yield the universe of the original thing, or `Nothing` if it was badly formed.-universeFromType1 :: Type n -> Maybe Universe-universeFromType1 tt+universeFromType1 :: Ord n => Env n -> Type n -> Maybe Universe+universeFromType1 kenv tt  = case tt of-        TVar u                    -> universeFromType2 (typeOfBound u)-        TCon (TyConSort _)        -> Just UniverseKind-        TCon (TyConKind _)        -> Just UniverseSpec-        TCon (TyConWitness _)     -> Just UniverseWitness-        TCon (TyConSpec TcConFun) -> Just UniverseData-        TCon (TyConSpec _)        -> Nothing-        TCon (TyConBound u)       -> universeFromType2 (typeOfBound u)-        TForall _ t2              -> universeFromType1 t2-        TApp _ t2                 -> universeFromType1 t2-        TSum _                    -> Nothing+        TVar n+         -> case Env.lookup n kenv of+                Nothing            -> Nothing+                Just k             -> universeFromType2 k +        TCon (TyConSort _)         -> Just UniverseKind+        TCon (TyConKind _)         -> Just UniverseSpec+        TCon (TyConWitness _)      -> Just UniverseWitness+        +        TCon (TyConSpec TcConUnit) -> Just UniverseData+        TCon (TyConSpec TcConFun)  -> Just UniverseData+        TCon (TyConSpec TcConSusp) -> Just UniverseData+        TCon (TyConSpec _)         -> Nothing+        +        TCon (TyConBound  _ k)     -> universeFromType2 k+        TCon (TyConExists _ k)     -> universeFromType2 k +        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++ -- | Yield the universe of some type. -- -- @  universeOfType (tBot kEffect) = UniverseSpec --  universeOfType kRegion        = UniverseKind -- @ ---universeOfType :: Type n -> Maybe Universe-universeOfType tt+universeOfType :: Ord n => Env n -> Type n -> Maybe Universe+universeOfType kenv tt  = case tt of-        TVar u                  -> universeFromType1 (typeOfBound u)+        TVar n+         -> case Env.lookup n kenv of+                Nothing         -> Nothing+                Just k          -> universeFromType1 kenv k+         TCon (TyConSort _)      -> Just UniverseSort         TCon (TyConKind _)      -> Just UniverseKind         TCon (TyConWitness _)   -> Just UniverseSpec         TCon (TyConSpec _)      -> Just UniverseSpec-        TCon (TyConBound u)     -> universeFromType1 (typeOfBound u)-        TForall _ t2            -> universeOfType t2-        TApp _ t2               -> universeOfType t2-        TSum ss                 -> universeFromType1 (T.kindOfSum ss)+        TCon (TyConBound  _ k)  -> universeFromType1 kenv k+        TCon (TyConExists _ k)  -> universeFromType1 kenv k++        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-2012 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@@ -13,18 +13,4 @@  The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.----------------------------------------------------------------------------------Under Australian law copyright is free and automatic.-By contributing to DDC authors grant all rights they have regarding their-contributions to the other members of the Disciplined Disciple Compiler Strike-Force, past, present and future, as well as placing their contributions under-the above license.--Use "darcs show authors" to get a list of Strike Force members.- ---------------------------------------------------------------------------------Redistributions of libraries in ./external are governed by their own licenses:--  - TinyPTC   GNU Lesser General Public License-
ddc-core.cabal view
@@ -1,5 +1,5 @@ Name:           ddc-core-Version:        0.2.1.2+Version:        0.4.3.1 License:        MIT License-file:   LICENSE Author:         The Disciplined Disciple Compiler Strike Force@@ -9,92 +9,242 @@ Stability:      experimental Category:       Compilers/Interpreters Homepage:       http://disciple.ouroborus.net-Bug-reports:    disciple@ouroborus.net-Synopsis:       Disciple Core language and type checker.+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 features of -        System-F2 it supports region, effect and closure typing. Evaluation order is -        left-to-right call-by-value by default, but explicit lazy evaluation is also supported.-        There is also a capability system to track whether objects are mutable or constant,-        and to ensure that computations that perform visible side effects are not suspended with-        lazy evaluation.+        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 @ddci-core@ package for a user-facing interpreter.+        See the @ddc-tools@ package for a user-facing interpreter and compiler.  Library   Build-Depends: -        base            == 4.6.*,+        base            >= 4.6   && < 4.10,+        array           >= 0.4   && < 0.6,+        deepseq         >= 1.3   && < 1.5,         containers      == 0.5.*,-        array           == 0.4.*,-        transformers    == 0.3.*,-        mtl             == 2.1.*,-        ddc-base        == 0.2.1.*+        directory       == 1.2.*,+        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.Check.CheckExp-        DDC.Core.Check.CheckWitness-        DDC.Core.Check.Error-        DDC.Core.Check.TaggedClosure-        DDC.Core.Parser.Lexer-        DDC.Core.Parser.Tokens-        DDC.Core.Transform.LiftW-        DDC.Core.Transform.LiftX+        DDC.Control.Check+        DDC.Control.Panic+        DDC.Control.Parser++        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.Generic+        DDC.Core.Exp.Literal        ++        DDC.Core.Lexer.Offside+        DDC.Core.Lexer.Tokens+        DDC.Core.Lexer.Unicode+        +        DDC.Core.Transform.BoundT+        DDC.Core.Transform.BoundX+        DDC.Core.Transform.MapT+        DDC.Core.Transform.Reannotate+        DDC.Core.Transform.Rename         DDC.Core.Transform.SpreadX         DDC.Core.Transform.SubstituteTX         DDC.Core.Transform.SubstituteWX         DDC.Core.Transform.SubstituteXX++        DDC.Core.Call         DDC.Core.Check         DDC.Core.Collect-        DDC.Core.Compounds-        DDC.Core.DataDef         DDC.Core.Exp-        DDC.Core.Pretty-        DDC.Core.Predicates+        DDC.Core.Fragment+        DDC.Core.Lexer+        DDC.Core.Load+        DDC.Core.Module         DDC.Core.Parser-        DDC.Type.Check.Monad-        DDC.Type.Transform.Crush+        DDC.Core.Pretty++        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.LowerT+        DDC.Type.Transform.Rename         DDC.Type.Transform.SpreadT         DDC.Type.Transform.SubstituteT-        DDC.Type.Transform.Trim-        DDC.Type.Check-        DDC.Type.Compounds+        +        DDC.Type.Bind+        DDC.Type.DataDef         DDC.Type.Env-        DDC.Type.Equiv         DDC.Type.Exp-        DDC.Type.Parser-        DDC.Type.Predicates-        DDC.Type.Rewrite-        DDC.Type.Subsumes         DDC.Type.Sum         DDC.Type.Universe +        DDC.Version++   Other-modules:-        DDC.Core.Check.ErrorMessage-        DDC.Type.Check.CheckCon-        DDC.Type.Check.CheckError-        DDC.Type.Pretty-                  +        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+        DDC.Core.Check.Judge.Type.Case+        DDC.Core.Check.Judge.Type.Cast+        DDC.Core.Check.Judge.Type.DaCon+        DDC.Core.Check.Judge.Type.LamT+        DDC.Core.Check.Judge.Type.LamX+        DDC.Core.Check.Judge.Type.Let+        DDC.Core.Check.Judge.Type.LetPrivate+        DDC.Core.Check.Judge.Type.Sub+        DDC.Core.Check.Judge.Type.VarCon+        DDC.Core.Check.Judge.Type.Witness++        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.Exp++        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.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:-        ParallelListComp-        PatternGuards-        RankNTypes-        FlexibleContexts-        FlexibleInstances+        NoMonomorphismRestriction+        FunctionalDependencies         MultiParamTypeClasses         UndecidableInstances-        KindSignatures-        NoMonomorphismRestriction         ScopedTypeVariables         StandaloneDeriving+        DeriveDataTypeable+        FlexibleInstances+        ParallelListComp+        FlexibleContexts+        ConstraintKinds         DoAndIfThenElse-        +        PatternSynonyms+        KindSignatures+        PatternGuards+        BangPatterns+        InstanceSigs+        ViewPatterns+        RankNTypes+