diff --git a/DDC/Control/Check.hs b/DDC/Control/Check.hs new file mode 100644 --- /dev/null +++ b/DDC/Control/Check.hs @@ -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 #-} + + diff --git a/DDC/Control/Panic.hs b/DDC/Control/Panic.hs new file mode 100644 --- /dev/null +++ b/DDC/Control/Panic.hs @@ -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] diff --git a/DDC/Control/Parser.hs b/DDC/Control/Parser.hs new file mode 100644 --- /dev/null +++ b/DDC/Control/Parser.hs @@ -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 + diff --git a/DDC/Core/Annot/AnT.hs b/DDC/Core/Annot/AnT.hs deleted file mode 100644 --- a/DDC/Core/Annot/AnT.hs +++ /dev/null @@ -1,35 +0,0 @@ - -module DDC.Core.Annot.AnT - (AnT (..)) -where -import DDC.Type.Exp -import DDC.Base.Pretty -import Control.DeepSeq -import Data.Typeable - - --- Annot ---------------------------------------------------------------------- --- | The type checker for witnesses adds this annotation to every node in the, --- giving the type of each component of the witness. ---- --- NOTE: We want to leave the components lazy so that the checker --- doesn't actualy need to produce the type components if they're --- not needed. -data AnT a n - = AnT - { annotType :: (Type n) - , annotTail :: a } - deriving (Show, Typeable) - - -instance (NFData a, NFData n) => NFData (AnT a n) where - rnf !an - = rnf (annotType an) - `seq` rnf (annotTail an) - - -instance Pretty (AnT a n) where - ppr _ = text "AnT" - - - diff --git a/DDC/Core/Annot/AnTEC.hs b/DDC/Core/Annot/AnTEC.hs deleted file mode 100644 --- a/DDC/Core/Annot/AnTEC.hs +++ /dev/null @@ -1,50 +0,0 @@ - -module DDC.Core.Annot.AnTEC - ( AnTEC (..) - , fromAnT) -where -import DDC.Type.Compounds -import DDC.Type.Exp -import DDC.Base.Pretty -import Control.DeepSeq -import Data.Typeable -import DDC.Core.Annot.AnT (AnT) -import qualified DDC.Core.Annot.AnT as AnT - - --- Annot ---------------------------------------------------------------------- --- | The type checker adds this annotation to every node in the AST, --- giving its type, effect and closure. ---- --- NOTE: We want to leave the components lazy so that the checker --- doesn't actualy need to produce the type components if they're --- not needed. -data AnTEC a n - = AnTEC - { annotType :: (Type n) - , annotEffect :: (Effect n) - , annotClosure :: (Closure n) - , annotTail :: a } - deriving (Show, Typeable) - - --- | Promote an `AnT` to an `AnTEC` by filling in the effect and closure --- portions with bottoms. -fromAnT :: AnT a n -> AnTEC a n -fromAnT (AnT.AnT t a) - = (AnTEC t (tBot kEffect) (tBot kClosure) a) - - -instance (NFData a, NFData n) => NFData (AnTEC a n) where - rnf !an - = rnf (annotType an) - `seq` rnf (annotEffect an) - `seq` rnf (annotClosure an) - `seq` rnf (annotTail an) - - -instance Pretty (AnTEC a n) where - ppr _ = text "AnTEC" - - - diff --git a/DDC/Core/Call.hs b/DDC/Core/Call.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Call.hs @@ -0,0 +1,435 @@ + +-- | Call patterns. +-- +-- A call pattern describes the sequence of objects that are eliminated +-- by some object when we apply it, and before it starts constructing +-- new values. +-- +-- @ +-- Constructor (+ve) Eliminator (-ve) +-- /\x. (type abstraction) \@' (type application) +-- \x. (object abstraction) \@ (object application) +-- box (suspend evaluation) run (commence evaluation) +-- @ +-- +module DDC.Core.Call + ( -- * Call constructors + Cons (..) + , isConsType + , isConsValue + , isConsBox + , takeCallConsFromExp + , takeCallConsFromType + , splitStdCallCons + , takeStdCallConsFromTypeArity + + -- * Call eliminators + , Elim (..) + , isElimType + , isElimValue + , isElimRun + , takeCallElim + , applyElim + , splitStdCallElims + + -- * Matching + , elimForCons + , dischargeConsWithElims + , dischargeTypeWithElims) +where +import DDC.Core.Exp.Annot +import DDC.Type.Transform.SubstituteT + + +----------------------------------------------------------------------------- +-- | One component of the call pattern of a super. +-- This is the "outer wrapper" of the computation, +-- +-- With @/\(a : k). \(x : t). box (x + 1)@ the call pattern consists of +-- the two lambdas and the box. These three things need to be eliminated +-- before we can construct any new values. +-- +data Cons n + = -- | A type lambda that needs a type of this kind. + ConsType (Bind n) + + -- | A value lambda that needs a value of this type. + | ConsValue (Type n) + + -- | A suspended expression that needs to be run. + | ConsBox + deriving (Show) + + +-- | Check if this is an `ConsType`. +isConsType :: Cons n -> Bool +isConsType cc + = case cc of + ConsType{} -> True + _ -> False + + +-- | Check if this is an `ElimType`. +isConsValue :: Cons n -> Bool +isConsValue cc + = case cc of + ConsValue{} -> True + _ -> False + + +-- | Check if this is an `ElimType`. +isConsBox :: Cons n -> Bool +isConsBox cc + = case cc of + ConsBox{} -> True + _ -> False + + +-- | Get the call pattern of an expression. +takeCallConsFromExp :: Exp a n -> [Cons n] +takeCallConsFromExp xx + = case xx of + XLAM _ b x + -> ConsType b : takeCallConsFromExp x + + XLam _ b x + -> let t = typeOfBind b + in ConsValue t : takeCallConsFromExp x + + XCast _ CastBox x + -> ConsBox : takeCallConsFromExp x + + _ -> [] + + +-- | Infer the call pattern of an expression from its type. +-- If the type has a function constructor then we assume there +-- is a corresponding lambda abstraction in the expression, and so on. +takeCallConsFromType :: Type n -> [Cons n] +takeCallConsFromType tt + | TForall bParam tBody <- tt + = ConsType bParam : takeCallConsFromType tBody + + | Just (tParam, tResult) <- takeTFun tt + = ConsValue tParam : takeCallConsFromType tResult + + | Just (_, tResult) <- takeTSusp tt + = ConsBox : takeCallConsFromType tResult + + | otherwise + = [] + + +-- | Like `splitStdCallElim`, but for the constructor side. +-- +splitStdCallCons + :: [Cons n] + -> Maybe ([Cons n], [Cons n], [Cons n]) + +splitStdCallCons cs + = eatTypes [] cs + where + eatTypes accTs (e@ConsType{} : es) + = eatTypes (e : accTs) es + + eatTypes accTs es + = eatValues (reverse accTs) [] es + + eatValues accTs accVs (e@ConsValue{} : es) + = eatValues accTs (e : accVs) es + + eatValues accTs accVs es + = eatRuns accTs (reverse accVs) [] es + + eatRuns accTs accVs accRs (e@ConsBox{} : es) + = eatRuns accTs accVs (e : accRs) es + + eatRuns accTs accVs accRs [] + = Just (accTs, accVs, reverse accRs) + + eatRuns _accTs _accVs _accRs _ + = Nothing + + +-- | Given the type of a super, and the number of type parameters, +-- value parameters and boxings, produce the corresponding list +-- of call constructors. +-- +-- Example: +-- +-- @ +-- takeStdCallConsFromType +-- [| forall (a : k1) (b : k2). a -> b -> S e b |] +-- 2 2 1 +-- => [ ConsType [|k1|], ConsType [|k2|] +-- , ConsValue [|a\], ConsValue [|b|] +-- , ConsBox ] +-- @ +-- +-- When we're considering the parts of the type, if the given arity +-- does not match what is in the type then `Nothing`. +-- +takeStdCallConsFromTypeArity + :: Type n -- ^ Type of super + -> Int -- ^ Number of type parameters. + -> Int -- ^ Number of value parameters. + -> Int -- ^ Number of boxings. + -> Maybe [Cons n] + +takeStdCallConsFromTypeArity tt0 nTypes0 nValues0 nBoxes0 + = eatTypes [] tt0 nTypes0 + where + -- Consider type parameters. + eatTypes !accTs !tt !nTypes + + -- The arity information tells us to expect a type parameter. + | nTypes > 0 + = case tt of + -- The super type matches. + TForall b tBody + -> eatTypes (ConsType b : accTs) tBody (nTypes - 1) + + -- The super type does not match the arity information. + _ -> Nothing + + -- No more type parameters expected, so consider the value parameters. + | otherwise + = eatValues (reverse accTs) [] tt nValues0 + + + -- Consider value parameters. + eatValues !accTs !accVs !tt !nValues + + -- The arity information tells us to expect a value parameter. + | nValues > 0 + = case takeTFun tt of + -- The super type matches. + Just (t1, t2) + -> eatValues accTs (ConsValue t1 : accVs) t2 (nValues - 1) + + -- The super type does not match the arity information. + _ -> Nothing + + -- No more value parameters expect, so consider the boxes. + | otherwise + = eatBoxes accTs (reverse accVs) [] tt nBoxes0 + + + -- Consider boxes. + eatBoxes !accTs !accVs !accBs tt nBoxes + + -- The arity information tells us to expect a boxing. + | nBoxes > 0 + = case takeTSusp tt of + -- The super type matches. + Just (_eff, tBody) + -> eatBoxes accTs accVs (ConsBox : accBs) tBody (nBoxes - 1) + + -- The super type does not match the arity information. + _ -> Nothing + + -- No more boxings to expect, so we're done. + | otherwise + = return (accTs ++ accVs ++ reverse accBs) + + +------------------------------------------------------------------------------- +-- | One component of a super call. +data Elim a n + = -- | Give a type to a type lambda. + ElimType a a (Type n) + + -- | Give a value to a value lambda. + | ElimValue a (Exp a n) + + -- | Run a suspended computation. + | ElimRun a + deriving (Show) + + +-- | Check if this is an `ElimType`. +isElimType :: Elim a n -> Bool +isElimType ee + = case ee of + ElimType{} -> True + _ -> False + + +-- | Check if this is an `ElimType`. +isElimValue :: Elim a n -> Bool +isElimValue ee + = case ee of + ElimValue{} -> True + _ -> False + + +-- | Check if this is an `ElimType`. +isElimRun :: Elim a n -> Bool +isElimRun ee + = case ee of + ElimRun{} -> True + _ -> False + + +-- | Apply an eliminator to an expression. +applyElim :: Exp a n -> Elim a n -> Exp a n +applyElim xx e + = case e of + ElimType a at t -> XApp a xx (XType at t) + ElimValue a x -> XApp a xx x + ElimRun a -> XCast a CastRun xx + + +-- | Split the application of some object into the object being +-- applied and its eliminators. +takeCallElim :: Exp a n -> (Exp a n, [Elim a n]) +takeCallElim xx + = case xx of + XApp a x1 (XType at t2) + -> let (xF, xArgs) = takeCallElim x1 + in (xF, xArgs ++ [ElimType a at t2]) + + XApp a x1 x2 + -> let (xF, xArgs) = takeCallElim x1 + in (xF, xArgs ++ [ElimValue a x2]) + + XCast a CastRun x1 + -> let (xF, xArgs) = takeCallElim x1 + in (xF, xArgs ++ [ElimRun a]) + + _ -> (xx, []) + + +-- | Group eliminators into sets for a standard call. +-- +-- The standard call sequence is a list of type arguments, followed +-- by some objects, and optionally running the result suspension. +-- +-- @run f [T1] [T2] x1 x2@ +-- +-- If 'f' is a super, and this is a saturating call then the super header +-- will look like the following: +-- +-- @f = (/\t1. /\t2. \v1. \v2. box. body)@ + +-- If the eliminators are not in the standard call sequence then `Nothing`. +-- +splitStdCallElims + :: [Elim a n] + -> Maybe ([Elim a n], [Elim a n], [Elim a n]) + +splitStdCallElims ee + = eatTypes [] ee + where + eatTypes accTs (e@ElimType{} : es) + = eatTypes (e : accTs) es + + eatTypes accTs es + = eatValues (reverse accTs) [] es + + eatValues accTs accVs (e@ElimValue{} : es) + = eatValues accTs (e : accVs) es + + eatValues accTs accVs es + = eatRuns accTs (reverse accVs) [] es + + eatRuns accTs accVs accRs (e@ElimRun{} : es) + = eatRuns accTs accVs (e : accRs) es + + eatRuns accTs accVs accRs [] + = Just (accTs, accVs, reverse accRs) + + eatRuns _accTs _accVs _accRs _ + = Nothing + + +------------------------------------------------------------------------------- +-- | Check if this an eliminator for the given constructor. +-- This only checks the general form of the eliminator +-- and constructor, not the exact types or kinds. +elimForCons :: Elim a n -> Cons n -> Bool +elimForCons e c + = case (e, c) of + (ElimType{}, ConsType{}) -> True + (ElimValue{}, ConsValue{}) -> True + (ElimRun{}, ConsBox{}) -> True + _ -> False + + +-- | Given lists of constructors and eliminators, check if the +-- eliminators satisfy the constructors, and return any remaining +-- unmatching constructors and eliminators. +-- +-- We assume that the application is well typed and that applying +-- the given eliminators will not cause variable capture. +--- +-- ISSUE #347: Avoid name capture in dischargeConsWithElims +-- This process doesn't avoid name capture by ConsTypes earlier +-- in the list, but it's only called from the Curry transform +-- where there shouldn't be any shadowed type binders. +-- +dischargeConsWithElims + :: Ord n + => [Cons n] + -> [Elim a n] + -> ([Cons n], [Elim a n]) + +dischargeConsWithElims (c : cs) (e : es) + = case (c, e) of + (ConsType b1, ElimType _ _ t2) + -> dischargeConsWithElims + (map (instantiateConsT b1 t2) cs) + es + + (ConsValue _t1, ElimValue _ _x2) + -> dischargeConsWithElims cs es + + (ConsBox, ElimRun _) + -> dischargeConsWithElims cs es + + _ -> (c : cs, e : es) + +dischargeConsWithElims cs es + = (cs, es) + + +instantiateConsT :: Ord n => Bind n -> Type n -> Cons n -> Cons n +instantiateConsT b t cc + = case cc of + ConsType{} -> cc + ConsValue t' -> ConsValue (substituteT b t t') + ConsBox{} -> cc + + +-- | Given a type of a function and eliminators, discharge +-- foralls, abstractions and boxes to get the result type +-- of performing the application. +-- +-- We assume that the application is well typed. +-- +dischargeTypeWithElims + :: Ord n + => Type n + -> [Elim a n] + -> Maybe (Type n) + +dischargeTypeWithElims tt (ElimType _ _ tArg : es) + | TForall b tBody <- tt + = dischargeTypeWithElims + (substituteT b tArg tBody) + es + +dischargeTypeWithElims tt (ElimValue _ _xArg : es) + | Just (_tParam, tResult) <- takeTFun tt + = dischargeTypeWithElims tResult es + +dischargeTypeWithElims tt (ElimRun _ : es) + | Just (_, tBody) <- takeTSusp tt + = dischargeTypeWithElims tBody es + +dischargeTypeWithElims tt [] + = Just tt + +dischargeTypeWithElims _tt _es + = Nothing + diff --git a/DDC/Core/Check.hs b/DDC/Core/Check.hs --- a/DDC/Core/Check.hs +++ b/DDC/Core/Check.hs @@ -1,4 +1,3 @@ - -- | Type checker for the Disciple Core language. -- -- The functions in this module do not check for language fragment compliance. @@ -9,25 +8,93 @@ 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.CheckModule -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 + diff --git a/DDC/Core/Check/Base.hs b/DDC/Core/Check/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Base.hs @@ -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 () + diff --git a/DDC/Core/Check/CheckDaCon.hs b/DDC/Core/Check/CheckDaCon.hs deleted file mode 100644 --- a/DDC/Core/Check/CheckDaCon.hs +++ /dev/null @@ -1,50 +0,0 @@ - -module DDC.Core.Check.CheckDaCon - (checkDaConM) -where -import DDC.Core.Check.Error -import DDC.Core.Check.CheckWitness -import DDC.Core.Exp.DaCon -import DDC.Core.Exp -import DDC.Type.Compounds -import DDC.Type.DataDef -import DDC.Control.Monad.Check (throw) -import Control.Monad -import Prelude as L -import qualified Data.Map as Map - - --- | Check a data constructor. --- The data constructor must be in the set of data type declarations. -checkDaConM - :: (Ord n, Eq n, Show n) - => Config n - -> Exp a n -- ^ The full expression for error messages. - -> DaCon n -- ^ Data constructor to check. - -> CheckM a n () - -checkDaConM _ _ dc - | DaConUnit <- daConName dc - = return () - -checkDaConM config xx dc - | DaConNamed nCtor <- daConName dc - , daConIsAlgebraic dc - = let tResult = snd $ takeTFunArgResult $ eraseTForalls $ typeOfDaCon dc - defs = configPrimDataDefs config - in case liftM fst $ takeTyConApps tResult of - Just (TyConBound u _) - | Just nType <- takeNameOfBound u - , Just dataType <- Map.lookup nType (dataDefsTypes defs) - -> case dataTypeMode dataType of - DataModeSmall nsCtors - | L.elem nCtor nsCtors -> return () - | otherwise -> throw $ ErrorUndefinedCtor xx - - DataModeLarge -> return () - - _ -> throw $ ErrorUndefinedCtor xx - -checkDaConM _ _ _ - = return () - diff --git a/DDC/Core/Check/CheckExp.hs b/DDC/Core/Check/CheckExp.hs deleted file mode 100644 --- a/DDC/Core/Check/CheckExp.hs +++ /dev/null @@ -1,1145 +0,0 @@ --- | Type checker for the Disciple Core language. -module DDC.Core.Check.CheckExp - ( Config (..) - , AnTEC (..) - , checkExp - , typeOfExp - , CheckM - , checkExpM - , TaggedClosure(..)) -where -import DDC.Core.Predicates -import DDC.Core.Compounds -import DDC.Core.Collect -import DDC.Core.Pretty -import DDC.Core.Exp -import DDC.Core.Annot.AnTEC -import DDC.Core.Check.Error -import DDC.Core.Check.CheckDaCon -import DDC.Core.Check.CheckWitness -import DDC.Core.Check.TaggedClosure -import DDC.Core.Transform.Reannotate -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.DataDef -import DDC.Type.Equiv -import DDC.Type.Universe -import DDC.Type.Sum as Sum -import DDC.Type.Env (Env, KindEnv, TypeEnv) -import DDC.Control.Monad.Check (throw, result) -import Data.Set (Set) -import qualified DDC.Type.Env as Env -import qualified Data.Set as Set -import Control.Monad -import DDC.Data.ListUtils -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. --- --- 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. --- -checkExp - :: (Ord n, Show n, Pretty n) - => Config n -- ^ Static configuration. - -> KindEnv n -- ^ Starting Kind environment. - -> TypeEnv n -- ^ Starting Type environment. - -> Exp a n -- ^ Expression to check. - -> Either (Error a n) - ( Exp (AnTEC a n) n - , Type n - , Effect n - , Closure n) - -checkExp !config !kenv !tenv !xx - = result - $ do (xx', t, effs, clos) - <- checkExpM config - (Env.union kenv (configPrimKinds config)) - (Env.union tenv (configPrimTypes config)) - xx - return ( xx' - , t - , TSum effs - , closureOfTaggedSet clos) - - --- | Like `checkExp`, but only return the value type of an expression. -typeOfExp - :: (Ord n, Pretty n, Show n) - => Config n -- ^ Static configuration. - -> KindEnv n -- ^ Starting Kind environment - -> TypeEnv n -- ^ Starting Type environment. - -> Exp a n -- ^ Expression to check. - -> Either (Error a n) (Type n) -typeOfExp !config !kenv !tenv !xx - = case checkExp config kenv tenv xx of - Left err -> Left err - Right (_, t, _, _) -> Right t - - --- checkExp ------------------------------------------------------------------- --- | Like `checkExp` but using the `CheckM` monad to handle errors. -checkExpM - :: (Show n, Pretty n, Ord n) - => Config n -- ^ Static config. - -> Env n -- ^ Kind environment. - -> Env n -- ^ Type environment. - -> Exp a n -- ^ Expression to check. - -> CheckM a n - ( Exp (AnTEC a n) n - , Type n - , TypeSum n - , Set (TaggedClosure n)) - -checkExpM !config !kenv !tenv !xx - = {-# SCC checkExpM #-} - checkExpM' config kenv tenv xx - --- variables ------------------------------------ -checkExpM' !_config !_kenv !tenv (XVar a u) - = case Env.lookup u tenv of - Nothing -> throw $ ErrorUndefinedVar u UniverseData - Just t - -> returnX a - (\z -> XVar z u) - t - (Sum.empty kEffect) - (Set.singleton $ taggedClosureOfValBound t u) - - --- constructors --------------------------------- -checkExpM' !config !_kenv !_tenv xx@(XCon a dc) - = do - -- All data constructors need to have valid type annotations. - when (isBot $ daConType dc) - $ throw $ ErrorUndefinedCtor xx - - -- Check that the constructor is in the data type declarations. - checkDaConM config xx dc - - -- Type of the data constructor. - let tResult - = typeOfDaCon dc - - returnX a - (\z -> XCon z dc) - tResult - (Sum.empty kEffect) - Set.empty - - --- application ------------------------------------ --- value-type application. --- --- Note: 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. --- -checkExpM' !config !kenv !tenv xx@(XApp a x1 (XType t2)) - = do (x1', t1, effs1, clos1) <- checkExpM config kenv tenv x1 - - -- Check the type argument. - k2 <- checkTypeM config kenv t2 - - -- Take any Use annots from a region arg. - -- This always matches because we just checked 't2' - let Just t2_clo = taggedClosureOfTyArg kenv t2 - - case t1 of - TForall b11 t12 - | typeOfBind b11 == k2 - -> returnX a - (\z -> XApp z x1' (XType t2)) - (substituteT b11 t2 t12) - effs1 - (clos1 `Set.union` t2_clo) - - | otherwise -> throw $ ErrorAppMismatch xx (typeOfBind b11) t2 - _ -> throw $ ErrorAppNotFun xx t1 t2 - - --- value-witness application. -checkExpM' !config !kenv !tenv xx@(XApp a x1 (XWitness w2)) - = do (x1', t1, effs1, clos1) <- checkExpM config kenv tenv x1 - - (w2', t2) <- checkWitnessM config kenv tenv w2 - let w2TEC = reannotate fromAnT w2' - - - case t1 of - TApp (TApp (TCon (TyConWitness TwConImpl)) t11) t12 - | t11 `equivT` t2 - -> returnX a - (\z -> XApp z x1' (XWitness w2TEC)) - t12 effs1 clos1 - - | otherwise -> throw $ ErrorAppMismatch xx t11 t2 - _ -> throw $ ErrorAppNotFun xx t1 t2 - - --- value-value application. -checkExpM' !config !kenv !tenv xx@(XApp a x1 x2) - = do (x1', t1, effs1, clos1) <- checkExpM config kenv tenv x1 - (x2', t2, effs2, clos2) <- checkExpM config kenv tenv x2 - - case t1 of - -- Oblivious application of a pure function. - -- Computation of the function and argument may themselves have - -- an effect, but the function application does not. - TApp (TApp (TCon (TyConSpec TcConFun)) t11) t12 - | t11 `equivT` t2 - -> returnX a - (\z -> XApp z x1' x2') - t12 - (effs1 `Sum.union` effs2) - (clos1 `Set.union` clos2) - - -- Function with latent effect and closure. - -- Note: we don't need to use the closure of the function because - -- all of its components will already be part of clos1 above. - TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFunEC)) t11) eff) _clo) t12 - | t11 `equivT` t2 - , effs <- Sum.fromList kEffect [eff] - -> returnX a - (\z -> XApp z 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' !config !kenv !tenv xx@(XLAM a b1 x2) - = do let t1 = typeOfBind b1 - _ <- checkTypeM config kenv t1 - - -- Check the body - let kenv' = Env.extend b1 kenv - let tenv' = Env.lift 1 tenv - (x2', t2, e2, c2) <- checkExpM config kenv' tenv' x2 - k2 <- checkTypeM config 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 UniverseSpec (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 - - returnX a - (\z -> XLAM z b1 x2') - (TForall b1 t2) - (Sum.empty kEffect) - c2_cut - - --- function abstraction ------------------------- -checkExpM' !config !kenv !tenv xx@(XLam a b1 x2) - = do - -- Check the type of the binder. - let t1 = typeOfBind b1 - k1 <- checkTypeM config kenv t1 - - -- Check the body. - let tenv' = Env.extend b1 tenv - (x2', t2, e2, c2) <- checkExpM config kenv tenv' x2 - - -- The typing rules guarantee that the checked type of an - -- expression is well kinded, but we need to check it again - -- to find out what that kind is. - k2 <- checkTypeM config kenv t2 - - -- The form of the function constructor depends on what universe the - -- binder is in. - case universeFromType2 k1 of - - -- This is a data abstraction. - Just UniverseData - - -- The body of a data abstraction must accept data. - | not $ isDataKind k1 - -> throw $ ErrorLamBindNotData xx t1 k1 - - -- The body of a data abstraction must produce data. - | not $ isDataKind k2 - -> throw $ ErrorLamBodyNotData xx b1 t2 k2 - - -- Looks good. - | 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 already checked that. - Just c2_captured - - -- If we're not tracking closure information then just drop it - -- on the floor. - | not $ configTrackedClosures config - = Just $ tBot kClosure - - | otherwise - = trimClosure $ closureOfTaggedSet c2_cut - - -- If we're not tracking effect information then just drop it - -- on the floor. - e2_captured - | not $ configTrackedEffects config - = tBot kEffect - - | otherwise - = TSum e2 - - -- If the function type for the current fragment supports - -- latent effects and closures then just use that. - fun_result - | configFunctionalEffects config - , configFunctionalClosures config - = returnX a - (\z -> XLam z b1 x2') - (tFunEC t1 e2_captured c2_captured t2) - (Sum.empty kEffect) - c2_cut - - -- If the function type for the current fragment does not - -- support latent effects, then the body expression needs - -- to be pure. - | e2_captured == tBot kEffect - , c2_captured == tBot kClosure - = returnX a - (\z -> XLam z b1 x2') - (tFun t1 t2) - (Sum.empty kEffect) - Set.empty - - | e2_captured /= tBot kEffect - = throw $ ErrorLamNotPure xx UniverseData e2_captured - - | c2_captured /= tBot kClosure - = throw $ ErrorLamNotEmpty xx UniverseData c2_captured - - -- One of the above error cases is supposed to fire, - -- so we should never hit this error. - | otherwise - = error "checkExpM': can't build function type." - - in fun_result - - - -- This is a witness abstraction. - Just UniverseWitness - - -- The body of a witness abstraction must be pure. - | e2 /= Sum.empty kEffect - -> throw $ ErrorLamNotPure xx UniverseWitness (TSum e2) - - -- The body of a witness abstraction must produce data. - | not $ isDataKind k2 - -> throw $ ErrorLamBodyNotData xx b1 t2 k2 - - -- Looks good. - | otherwise - -> returnX a - (\z -> XLam z b1 x2') - (tImpl t1 t2) - (Sum.empty kEffect) - c2 - - _ -> throw $ ErrorMalformedType xx k1 - - --- let -------------------------------------------- -checkExpM' !config !kenv !tenv xx@(XLet a lts x2) - | case lts of - LLet{} -> True - LRec{} -> True - _ -> False - - = do - -- Check the bindings - (lts', bs', effs12, clo12) - <- checkLetsM xx config kenv tenv lts - - -- Check the body expression. - let tenv1 = Env.extends bs' tenv - (x2', t2, effs2, c2) <- checkExpM config kenv tenv1 x2 - - -- The body should have data kind. - k2 <- checkTypeM config 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 (cutTaggedClosureXs bs') - $ Set.toList c2 - - returnX a - (\z -> XLet z lts' x2') - t2 - (effs12 `Sum.union` effs2) - (clo12 `Set.union` c2_cut) - - --- letregion -------------------------------------- -checkExpM' !config !kenv !tenv xx@(XLet a (LLetRegions bsRgn bsWit) x) - = case takeSubstBoundsOfBinds bsRgn of - [] -> checkExpM config kenv tenv x - us -> do - -- - let depth = length $ map isBAnon bsRgn - - -- Check the type on the region binders. - let ks = map typeOfBind bsRgn - mapM_ (checkTypeM config kenv) ks - - -- The binders must have region kind. - when (any (not . isRegionKind) ks) - $ throw $ ErrorLetRegionsNotRegion xx bsRgn ks - - -- 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 Env.memberBind kenv) bsRgn - when (not $ null rebounds) - $ throw $ ErrorLetRegionsRebound xx rebounds - - -- Check the witness types. - let kenv' = Env.extends bsRgn kenv - let tenv' = Env.lift depth tenv - mapM_ (checkTypeM config kenv') $ map typeOfBind bsWit - - -- Check that the witnesses bound here are for the region, - -- and they don't conflict with each other. - checkWitnessBindsM kenv xx us bsWit - - -- Check the body expression. - let tenv2 = Env.extends bsWit tenv' - (xBody', tBody, effs, clo) <- checkExpM config kenv' tenv2 x - - -- The body type must have data kind. - kBody <- checkTypeM config 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 (any (flip Set.member fvsT) us) - $ throw $ ErrorLetRegionFree xx bsRgn tBody - - -- 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 - let effs' = foldl delEff effs us - - -- Delete the bound region variable from the closure. - -- Mask closure terms due to locally bound region vars. - let cutClo c r = mapMaybe (cutTaggedClosureT r) c - let c2_cut = Set.fromList - $ foldl cutClo (Set.toList clo) bsRgn - - returnX a - (\z -> XLet z (LLetRegions bsRgn bsWit) xBody') - (lowerT depth tBody) - (lowerT depth effs') - c2_cut - - --- withregion ----------------------------------- -checkExpM' !config !kenv !tenv xx@(XLet a (LWithRegion u) x) - = do - -- The handle must have region kind. - (case Env.lookup u kenv of - Nothing -> throw $ ErrorUndefinedVar u UniverseSpec - - Just k | not $ isRegionKind k - -> throw $ ErrorWithRegionNotRegion xx u k - - _ -> return ()) - - -- Check the body expression. - (xBody', tBody, effs, clo) - <- checkExpM config kenv tenv x - - -- The body type must have data kind. - kBody <- checkTypeM config kenv tBody - when (not $ isDataKind kBody) - $ throw $ ErrorLetBodyNotData xx tBody kBody - - -- The bound region variable cannot be free in the body type. - let tcs = supportTyCon - $ support Env.empty Env.empty tBody - when (Set.member u tcs) - $ throw $ ErrorWithRegionFree xx u tBody - - -- Delete effects on the bound region from the result. - let tu = TCon $ TyConBound u kRegion - 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 - - returnX a - (\z -> XLet z (LWithRegion u) xBody') - tBody - effs' - clo_masked - - --- case expression ------------------------------ -checkExpM' !config !kenv !tenv xx@(XCase a xDiscrim alts) - = do - -- Check the discriminant. - (xDiscrim', tDiscrim, effsDiscrim, closDiscrim) - <- checkExpM config 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. - (mmode, tsArgs) - <- case takeTyConApps tDiscrim of - Just (tc, ts) - | TyConSpec TcConUnit <- tc - -> return ( Just (DataModeSmall []) - , [] ) - -- ISSUE #269: Refactor DataModeSmall to hold DaCons instead of names. - -- The DataModeSmall should hold DaCons instead of - -- names, as we don't have a name for Unit. - - | TyConBound (UName nTyCon) k <- tc - , takeResultKind k == kData - -> return ( lookupModeOfDataType nTyCon (configPrimDataDefs config) - , ts ) - - | TyConBound (UPrim nTyCon _) k <- tc - , takeResultKind k == kData - -> return ( lookupModeOfDataType nTyCon (configPrimDataDefs config) - , ts ) - - _ -> throw $ ErrorCaseScrutineeNotAlgebraic xx tDiscrim - - -- Get the mode of the data type, - -- this tells us how many constructors there are. - mode - <- case mmode of - Nothing -> throw $ ErrorCaseScrutineeTypeUndeclared xx tDiscrim - Just m -> return m - - -- Check the alternatives. - (alts', ts, effss, closs) - <- liftM unzip4 - $ mapM (checkAltM xx config 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 - - _ | Just patsInit <- takeInit pats - , or $ map isPDefault $ patsInit - -> 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 - - returnX a - (\z -> XCase z xDiscrim' alts') - tAlt - (Sum.unions kEffect (effsDiscrim : effsMatch : effss)) - (Set.unions (closDiscrim : closs)) - - --- type cast ------------------------------------- --- Weaken an effect, adding in the given terms. -checkExpM' !config !kenv !tenv xx@(XCast a (CastWeakenEffect eff) x1) - = do - -- Check the effect term. - kEff <- checkTypeM config kenv eff - when (not $ isEffectKind kEff) - $ throw $ ErrorWeakEffNotEff xx eff kEff - - -- Check the body. - (x1', t1, effs, clo) <- checkExpM config kenv tenv x1 - let c' = CastWeakenEffect eff - - returnX a - (\z -> XCast z c' x1') - t1 - (Sum.insert eff effs) - clo - - --- Weaken a closure, adding in the given terms. -checkExpM' !config !kenv !tenv (XCast a (CastWeakenClosure xs) x1) - = do - -- Check the contained expressions. - (xs', closs) - <- liftM unzip - $ mapM (checkArgM config kenv tenv) xs - - -- Check the body. - (x1', t1, effs, clos) <- checkExpM config kenv tenv x1 - let c' = CastWeakenClosure xs' - - returnX a - (\z -> XCast z c' x1') - t1 - effs - (Set.unions (clos : closs)) - - --- Purify an effect, given a witness that it is pure. -checkExpM' !config !kenv !tenv xx@(XCast a (CastPurify w) x1) - = do - (w', tW) <- checkWitnessM config kenv tenv w - let wTEC = reannotate fromAnT w' - - (x1', t1, effs, clo) <- checkExpM config kenv tenv x1 - - effs' <- case tW of - TApp (TCon (TyConWitness TwConPure)) effMask - -> return $ Sum.delete effMask effs - _ -> throw $ ErrorWitnessNotPurity xx w tW - - let c' = CastPurify wTEC - - returnX a - (\z -> XCast z c' x1') - t1 effs' clo - - --- Forget a closure, given a witness that it is empty. -checkExpM' !config !kenv !tenv xx@(XCast a (CastForget w) x1) - = do - (w', tW) <- checkWitnessM config kenv tenv w - let wTEC = reannotate fromAnT w' - - (x1', t1, effs, clos) <- checkExpM config kenv tenv x1 - - clos' <- case tW of - TApp (TCon (TyConWitness TwConEmpty)) cloMask - -> return $ maskFromTaggedSet - (Sum.singleton kClosure cloMask) - clos - - _ -> throw $ ErrorWitnessNotEmpty xx w tW - - let c' = CastForget wTEC - - returnX a - (\z -> XCast z c' x1') - t1 effs clos' - - --- Suspend a computation, --- capturing its effects in a computation type. -checkExpM' !config !kenv !tenv (XCast a CastSuspend x1) - = do - (x1', t1, effs, clos) <- checkExpM config kenv tenv x1 - - let tS = tApps (TCon (TyConSpec TcConSusp)) - [TSum effs, t1] - - returnX a - (\z -> XCast z CastSuspend x1') - tS (Sum.empty kEffect) clos - - --- Run a suspended computation, --- releasing its effects into the environment. -checkExpM' !config !kenv !tenv xx@(XCast a CastRun x1) - = do - (x1', t1, effs, clos) <- checkExpM config kenv tenv x1 - - case t1 of - TApp (TApp (TCon (TyConSpec TcConSusp)) eff2) tA - -> returnX a - (\z -> XCast z CastRun x1') - tA - (Sum.union effs (Sum.singleton kEffect eff2)) - clos - - _ -> throw $ ErrorRunNotSuspension xx t1 - - --- Type and witness expressions can only appear as the arguments --- to applications. -checkExpM' !_config !_kenv !_tenv xx@(XType _) - = throw $ ErrorNakedType xx - -checkExpM' !_config !_kenv !_tenv xx@(XWitness _) - = throw $ ErrorNakedWitness xx - --- This shouldn't happen. -checkExpM' _ _ _ _ - = error "checkExpM: can't check this expression" - - --- | Like `checkExp` but we allow naked types and witnesses. -checkArgM - :: (Show n, Pretty n, Ord n) - => Config n -- ^ Static config. - -> Env n -- ^ Kind environment. - -> Env n -- ^ Type environment. - -> Exp a n -- ^ Expression to check. - -> CheckM a n - ( Exp (AnTEC a n) n - , Set (TaggedClosure n)) - -checkArgM !config !kenv !tenv !xx - = case xx of - XType t - -> do checkTypeM config kenv t - let Just clo = taggedClosureOfTyArg kenv t - - return ( XType t - , clo) - - XWitness w - -> do (w', _) <- checkWitnessM config kenv tenv w - return ( XWitness (reannotate fromAnT w') - , Set.empty) - - _ -> do - (xx', _, _, clos) <- checkExpM config kenv tenv xx - return ( xx' - , clos) - - --- | 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 - -> (AnTEC a n -> Exp (AnTEC a n) n) - -> Type n - -> TypeSum n - -> Set (TaggedClosure n) - -> CheckM a n - ( Exp (AnTEC a n) n - , Type n - , TypeSum n - , Set (TaggedClosure n)) - -returnX !a !f !t !es !cs - = let e = TSum es - c = closureOfTaggedSet cs - in return (f (AnTEC t e c a) - , t, es, cs) -{-# INLINE returnX #-} - - -------------------------------------------------------------------------------- --- | Check some let bindings. -checkLetsM - :: (Show n, Pretty n, Ord n) - => Exp a n -- ^ Enclosing expression, for error messages. - -> Config n -- ^ Static config. - -> Env n -- ^ Kind environment. - -> Env n -- ^ Type environment. - -> Lets a n - -> CheckM a n - ( Lets (AnTEC a n) n - , [Bind n] - , TypeSum n - , Set (TaggedClosure n)) - -checkLetsM !xx !config !kenv !tenv (LLet b11 x12) - = do - -- Check the right of the binding. - (x12', t12, effs12, clo12) - <- checkExpM config kenv tenv x12 - - -- Check binder annotation against the type we inferred for the right. - (b11', k11') - <- checkLetBindOfTypeM xx config kenv tenv t12 b11 - - -- The right of the binding should have data kind. - when (not $ isDataKind k11') - $ throw $ ErrorLetBindingNotData xx b11' k11' - - return ( LLet b11' x12' - , [b11'] - , effs12 - , clo12) - --- letrec --------------------------------------- -checkLetsM !xx !config !kenv !tenv (LRec bxs) - = do - let (bs, xs) = unzip bxs - - -- No named binders can be multiply defined. - (case duplicates $ filter isBName bs of - [] -> return () - b : _ -> throw $ ErrorLetrecRebound xx b) - - -- Check the types on all the binders. - ks <- mapM (checkTypeM config kenv) - $ map typeOfBind bs - - -- Check all the binders 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 config 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 - - -- Cut closure terms due to locally bound value vars. - let clos_cut - = Set.fromList - $ mapMaybe (cutTaggedClosureXs bs) - $ Set.toList - $ Set.unions clossBinds - - return ( LRec (zip bs xsRight') - , zipWith replaceTypeOfBind tsRight bs - , Sum.empty kEffect - , clos_cut) - -checkLetsM _xx _config _kenv _tenv _lts - = error "checkLetsM: case should have been handled in checkExpM" - - --- | 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 a case alternative. -checkAltM - :: (Show n, Pretty n, Ord n) - => Exp a n -- ^ Whole case expression, for error messages. - -> Config 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 (AnTEC a n) n - , Type n - , TypeSum n - , Set (TaggedClosure n)) - -checkAltM !_xx !config !kenv !tenv !_tDiscrim !_tsArgs (AAlt PDefault xBody) - = do (xBody', tBody, effBody, cloBody) - <- checkExpM config kenv tenv xBody - - return ( AAlt PDefault xBody' - , tBody - , effBody - , cloBody) - -checkAltM !xx !config !kenv !tenv !tDiscrim !tsArgs (AAlt (PData dc bsArg) xBody) - = do - let Just aCase = takeAnnotOfExp xx - - -- 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. - (if isBot (daConType dc) - then throw $ ErrorUndefinedCtor $ XCon aCase dc - else return ()) - - -- 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 = daConType dc - - 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 $ ErrorCaseScrutineeTypeMismatch 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 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 <- 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 config 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 dc 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 - :: (Show n, Ord n) - => KindEnv n - -> Exp a n - -> [Bound n] - -> [Bind n] - -> CheckM a n () - -checkWitnessBindsM !kenv !xx !nRegions !bsWits - = mapM_ (checkWitnessBindM kenv xx nRegions bsWits) bsWits - - -checkWitnessBindM - :: (Show n, Ord n) - => Env n - -> Exp a n - -> [Bound n] -- ^ Region variables bound in the letregion. - -> [Bind n] -- ^ Other witness bindings in the same set. - -> Bind n -- ^ The witness binding to check. - -> CheckM a n () - -checkWitnessBindM !kenv !xx !uRegions !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' - | all (/= u') uRegions -> throw $ ErrorLetRegionsWitnessOther xx uRegions bWit - | otherwise -> return () - - TCon (TyConBound u' _) - | all (/= u') uRegions -> throw $ ErrorLetRegionsWitnessOther xx uRegions bWit - | otherwise -> return () - - -- The parser should ensure the right of a witness is a - -- constructor or variable. - _ -> throw $ ErrorLetRegionWitnessInvalid xx bWit - - inEnv t - = case t of - TVar u' | Env.member u' kenv -> True - TCon (TyConBound u' _) | Env.member u' kenv -> True - _ -> False - - 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 - - (takeTyConApps -> Just (TyConWitness (TwConDistinct 2), [t1, t2])) - | inEnv t1 -> checkWitnessArg t2 - | inEnv t2 -> checkWitnessArg t1 - | t1 /= t2 -> mapM_ checkWitnessArg [t1, t2] - | otherwise -> throw $ ErrorLetRegionWitnessInvalid xx bWit - - (takeTyConApps -> Just (TyConWitness (TwConDistinct _), ts)) - -> mapM_ checkWitnessArg ts - - _ -> throw $ ErrorLetRegionWitnessInvalid xx bWit - - -------------------------------------------------------------------------------- --- | 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 - :: (Ord n, Show n, Pretty n) - => Exp a n - -> Config 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 !config !kenv !_tenv !tRight b - -- If the annotation is Bot then just replace it. - | isBot (typeOfBind b) - = do k <- checkTypeM config 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 config kenv (typeOfBind b) - return (b, k) diff --git a/DDC/Core/Check/CheckModule.hs b/DDC/Core/Check/CheckModule.hs deleted file mode 100644 --- a/DDC/Core/Check/CheckModule.hs +++ /dev/null @@ -1,159 +0,0 @@ - -module DDC.Core.Check.CheckModule - ( checkModule - , checkModuleM) -where -import DDC.Core.Module -import DDC.Core.Exp -import DDC.Core.Check.CheckExp -import DDC.Core.Check.Error -import DDC.Type.Compounds -import DDC.Base.Pretty -import DDC.Type.Equiv -import DDC.Type.Env (KindEnv, TypeEnv) -import DDC.Control.Monad.Check (result, throw) -import Data.Map (Map) -import qualified DDC.Type.Check as T -import qualified DDC.Type.Env as Env -import qualified Data.Map as Map - - --- Wrappers ------------------------------------------------------------------- --- | Type check a module. --- --- If it's good, you get a new version with types attached to all the bound --- variables --- --- If it's bad, you get a description of the error. -checkModule - :: (Ord n, Show n, Pretty n) - => Config n -- ^ Static configuration. - -> Module a n -- ^ Module to check. - -> Either (Error a n) (Module (AnTEC a n) n) - -checkModule !config !xx - = result - $ checkModuleM - config - (configPrimKinds config) - (configPrimTypes config) - xx - - --- checkModule ---------------------------------------------------------------- --- | Like `checkModule` but using the `CheckM` monad to handle errors. -checkModuleM - :: (Ord n, Show n, Pretty n) - => Config n -- ^ Static configuration. - -> KindEnv n -- ^ Starting kind environment. - -> TypeEnv n -- ^ Starting type environment. - -> Module a n -- ^ Module to check. - -> CheckM a n (Module (AnTEC a n) n) - -checkModuleM !config !kenv !tenv mm@ModuleCore{} - = do - -- Convert the imported kind and type map to a list of binds. - let bksImport = [BName n k | (n, (_, k)) <- Map.toList $ moduleImportKinds mm] - let btsImport = [BName n t | (n, (_, t)) <- Map.toList $ moduleImportTypes mm] - - -- Check the imported kinds and types. - -- The imported types are in scope in both imported and exported signatures. - mapM_ (checkTypeM config kenv) $ map typeOfBind bksImport - let kenv' = Env.union kenv $ Env.fromList bksImport - - mapM_ (checkTypeM config kenv') $ map typeOfBind btsImport - let tenv' = Env.union tenv $ Env.fromList btsImport - - -- Check the sigs for exported things. - mapM_ (checkTypeM config kenv') $ Map.elems $ moduleExportKinds mm - mapM_ (checkTypeM config kenv') $ Map.elems $ moduleExportTypes mm - - -- Check our let bindings. - (x', _, _effs, _) <- checkExpM config kenv' tenv' (moduleBody mm) - - -- Check that each exported signature matches the type of its binding. - envDef <- checkModuleBinds (moduleExportKinds mm) (moduleExportTypes mm) x' - - -- Check that all exported bindings are defined by the module. - mapM_ (checkBindDefined envDef) $ Map.keys $ moduleExportTypes mm - - -- Return the checked bindings as they have explicit type annotations. - let mm' = mm { moduleBody = x' } - return mm' - - --- | Check that the exported signatures match the types of their bindings. -checkModuleBinds - :: Ord n - => Map n (Kind n) -- ^ Kinds of exported types. - -> Map n (Type n) -- ^ Types of exported values. - -> Exp (AnTEC a n) n - -> CheckM a n (TypeEnv n) -- ^ Environment of top-level bindings - -- defined by the module - -checkModuleBinds !ksExports !tsExports !xx - = case xx of - XLet _ (LLet b _) x2 - -> do checkModuleBind ksExports tsExports b - env <- checkModuleBinds ksExports tsExports x2 - return $ Env.extend b env - - XLet _ (LRec bxs) x2 - -> do mapM_ (checkModuleBind ksExports tsExports) $ map fst bxs - env <- checkModuleBinds ksExports tsExports x2 - return $ Env.extends (map fst bxs) env - - XLet _ (LLetRegions _ _) x2 - -> checkModuleBinds ksExports tsExports x2 - - _ -> return Env.empty - - --- | If some bind is exported, then check that it matches the exported version. -checkModuleBind - :: Ord n - => Map n (Kind n) -- ^ Kinds of exported types. - -> Map n (Type n) -- ^ Types of exported values. - -> Bind n - -> CheckM a n () - -checkModuleBind !_ksExports !tsExports !b - | BName n tDef <- b - = case Map.lookup n tsExports of - Nothing -> return () - Just tExport - | equivT tDef tExport -> return () - | otherwise -> throw $ ErrorExportMismatch n tExport tDef - - -- Only named bindings can be exported, - -- so we don't need to worry about non-named ones. - | otherwise - = return () - - --- | Check that a top-level binding is actually defined by the module. -checkBindDefined - :: Ord n - => TypeEnv n -- ^ Types defined by the module. - -> n -- ^ Name of an exported binding. - -> CheckM a n () - -checkBindDefined env n - = case Env.lookup (UName n) env of - Just _ -> return () - _ -> throw $ ErrorExportUndefined n - - -------------------------------------------------------------------------------- --- | Check a type in the exp checking monad. -checkTypeM :: (Ord n, Show n, Pretty n) - => Config n - -> KindEnv n - -> Type n - -> CheckM a n (Kind n) - -checkTypeM !config !kenv !tt - = case T.checkType config kenv tt of - Left err -> throw $ ErrorType err - Right k -> return k - diff --git a/DDC/Core/Check/CheckWitness.hs b/DDC/Core/Check/CheckWitness.hs deleted file mode 100644 --- a/DDC/Core/Check/CheckWitness.hs +++ /dev/null @@ -1,196 +0,0 @@ --- | Type checker for witness expressions. -module DDC.Core.Check.CheckWitness - ( Config(..) - , configOfProfile - - , checkWitness - , typeOfWitness - , typeOfWiCon - , typeOfWbCon - - , CheckM - , checkWitnessM - - , checkTypeM) -where -import DDC.Core.Exp -import DDC.Core.Annot.AnT -import DDC.Core.Pretty -import DDC.Core.Check.Error -import DDC.Core.Check.ErrorMessage () -import DDC.Type.Check (Config (..), configOfProfile) -import DDC.Type.Transform.SubstituteT -import DDC.Type.Compounds -import DDC.Type.Universe -import DDC.Type.Sum as Sum -import DDC.Type.Env (KindEnv, TypeEnv) -import DDC.Control.Monad.Check (throw, result) -import DDC.Base.Pretty () -import qualified DDC.Control.Monad.Check as G -import qualified DDC.Type.Env as Env -import qualified DDC.Type.Check as T - - --- | 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. --- --- The kinds and types of primitives are added to the environments --- automatically, you don't need to supply these as part of the --- starting environments. --- -checkWitness - :: (Ord n, Show n, Pretty n) - => Config n -- ^ Static configuration. - -> KindEnv n -- ^ Starting Kind Environment. - -> TypeEnv n -- ^ Strating Type Environment. - -> Witness a n -- ^ Witness to check. - -> Either (Error a n) - ( Witness (AnT a n) n - , Type n) - -checkWitness config kenv tenv xx - = result $ checkWitnessM config 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, Show n, Pretty n) - => Config n - -> Witness a n - -> Either (Error a n) (Type n) - -typeOfWitness config ww - = case checkWitness config Env.empty Env.empty ww of - Left err -> Left err - Right (_, t) -> Right t - - ------------------------------------------------------------------------------- --- | Like `checkWitness` but using the `CheckM` monad to manage errors. -checkWitnessM - :: (Ord n, Show n, Pretty n) - => Config n -- ^ Data type definitions. - -> KindEnv n -- ^ Kind environment. - -> TypeEnv n -- ^ Type environment. - -> Witness a n -- ^ Witness to check. - -> CheckM a n - ( Witness (AnT a n) n - , Type n) - -checkWitnessM !_config !_kenv !tenv (WVar a u) - = case Env.lookup u tenv of - Nothing -> throw $ ErrorUndefinedVar u UniverseWitness - Just t -> return ( WVar (AnT t a) u - , t) - -checkWitnessM !_config !_kenv !_tenv (WCon a wc) - = let t' = typeOfWiCon wc - in return ( WCon (AnT t' a) wc - , t') - --- witness-type application -checkWitnessM !config !kenv !tenv ww@(WApp a1 w1 (WType a2 t2)) - = do (w1', t1) <- checkWitnessM config kenv tenv w1 - k2 <- checkTypeM config kenv t2 - 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 ww (typeOfBind b11) k2 - _ -> throw $ ErrorWAppNotCtor ww t1 t2 - --- witness-witness application -checkWitnessM !config !kenv !tenv ww@(WApp a w1 w2) - = do (w1', t1) <- checkWitnessM config kenv tenv w1 - (w2', t2) <- checkWitnessM config kenv tenv w2 - case t1 of - TApp (TApp (TCon (TyConWitness TwConImpl)) t11) t12 - | t11 == t2 - -> return ( WApp (AnT t12 a) w1' w2' - , t12) - - | otherwise -> throw $ ErrorWAppMismatch ww t11 t2 - _ -> throw $ ErrorWAppNotCtor ww t1 t2 - --- witness joining -checkWitnessM !config !kenv !tenv ww@(WJoin a w1 w2) - = do (w1', t1) <- checkWitnessM config kenv tenv w1 - (w2', t2) <- checkWitnessM config kenv tenv w2 - case (t1, t2) of - ( TApp (TCon (TyConWitness TwConPure)) eff1 - , TApp (TCon (TyConWitness TwConPure)) eff2) - -> let t' = TApp (TCon (TyConWitness TwConPure)) - (TSum $ Sum.fromList kEffect [eff1, eff2]) - in return ( WJoin (AnT t' a) w1' w2' - , t') - - ( TApp (TCon (TyConWitness TwConEmpty)) clo1 - , TApp (TCon (TyConWitness TwConEmpty)) clo2) - -> let t' = TApp (TCon (TyConWitness TwConEmpty)) - (TSum $ Sum.fromList kClosure [clo1, clo2]) - in return ( WJoin (AnT t' a) w1' w2' - , t') - - _ -> throw $ ErrorCannotJoin ww w1 t1 w2 t2 - --- embedded types -checkWitnessM !config !kenv !_tenv (WType a t) - = do k <- checkTypeM config kenv t - return ( WType (AnT k a) t - , k) - - --- | Take the type of a witness constructor. -typeOfWiCon :: WiCon n -> Type n -typeOfWiCon wc - = case wc of - WiConBuiltin wb -> typeOfWbCon wb - WiConBound _ t -> t - - --- | Take the type of a builtin witness constructor. -typeOfWbCon :: WbCon -> Type n -typeOfWbCon wb - = case wb of - WbConPure -> tPure (tBot kEffect) - WbConEmpty -> tEmpty (tBot kClosure) - WbConUse -> tForall kRegion $ \r -> tGlobal r `tImpl` (tEmpty $ tUse r) - WbConRead -> tForall kRegion $ \r -> tConst r `tImpl` (tPure $ tRead r) - WbConAlloc -> tForall kRegion $ \r -> tConst r `tImpl` (tPure $ tAlloc r) - - --- checkType ------------------------------------------------------------------ --- | Check a type in the exp checking monad. -checkTypeM - :: (Ord n, Show n, Pretty n) - => Config n - -> KindEnv n - -> Type n - -> CheckM a n (Kind n) - -checkTypeM config kenv tt - = case T.checkType config kenv tt of - Left err -> throw $ ErrorType err - Right k -> return k - diff --git a/DDC/Core/Check/Config.hs b/DDC/Core/Check/Config.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Config.hs @@ -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 + } + + diff --git a/DDC/Core/Check/Context.hs b/DDC/Core/Check/Context.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Context.hs @@ -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 + diff --git a/DDC/Core/Check/Context/Apply.hs b/DDC/Core/Check/Context/Apply.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Context/Apply.hs @@ -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' + diff --git a/DDC/Core/Check/Context/Base.hs b/DDC/Core/Check/Context/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Context/Base.hs @@ -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 diff --git a/DDC/Core/Check/Context/Effect.hs b/DDC/Core/Check/Context/Effect.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Context/Effect.hs @@ -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 + diff --git a/DDC/Core/Check/Context/Elem.hs b/DDC/Core/Check/Context/Elem.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Context/Elem.hs @@ -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 diff --git a/DDC/Core/Check/Context/Mode.hs b/DDC/Core/Check/Context/Mode.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Context/Mode.hs @@ -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) + + diff --git a/DDC/Core/Check/Error.hs b/DDC/Core/Check/Error.hs --- a/DDC/Core/Check/Error.hs +++ b/DDC/Core/Check/Error.hs @@ -1,338 +1,17 @@ -- | Errors produced when checking core expressions. module DDC.Core.Check.Error - (Error(..)) + ( Error (..) + , ErrorType (..) + , ErrorData (..)) where -import DDC.Core.Exp -import DDC.Type.Universe -import qualified DDC.Type.Check as T - - --- | All the things that can go wrong when type checking an expression --- or witness. -data Error a n - -- Type ------------------------------------------- - -- | Found a kind error when checking a type. - = ErrorType - { errorTypeError :: T.Error n } - - -- | Found a malformed type, - -- and we don't have a more specific diagnosis. - | ErrorMalformedType - { errorChecking :: Exp a n - , errorType :: Type n } - - - -- Module ----------------------------------------- - -- | Exported value is undefined. - | ErrorExportUndefined - { 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 } - - - -- Exp -------------------------------------------- - -- | Found a malformed expression, - -- and we don't have a more specific diagnosis. - | ErrorMalformedExp - { errorChecking :: Exp a n } - - - -- Var -------------------------------------------- - -- | An undefined type variable. - | ErrorUndefinedVar - { errorBound :: Bound n - , errorUniverse :: Universe } - - -- | A bound occurrence of a variable whose type annotation does not match - -- the corresponding annotation in the environment. - | ErrorVarAnnotMismatch - { errorBound :: Bound n - , errorTypeAnnot :: Type 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 } - - -- | An abstraction where the body has a visible side effect that - -- is not supported by the current language fragment. - | ErrorLamNotPure - { errorChecking :: Exp a n - , errorUniverse :: Universe - , errorEffect :: Effect n } - - -- | An abstraction where the body has a visible closure that - -- is not supported by the current language fragment. - | ErrorLamNotEmpty - { errorChecking :: Exp a n - , errorUniverse :: Universe - , errorClosure :: Closure 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 } - - - -- 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 } - - -- | A recursive let-expression that has more than one binding - -- with the same name. - | ErrorLetrecRebound - { errorChecking :: Exp a n - , errorBind :: Bind n } - - - -- Letregion -------------------------------------- - -- | A letregion-expression where the some of the bound variables do not - -- have region kind. - | ErrorLetRegionsNotRegion - { errorChecking :: Exp a n - , errorBinds :: [Bind n] - , errorKinds :: [Kind n] } - - -- | A letregion-expression that tried to shadow some pre-existing named - -- region variables. - | ErrorLetRegionsRebound - { 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 - { errorChecking :: Exp a n - , errorBinds :: [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. - | ErrorLetRegionsWitnessOther - { errorChecking :: Exp a n - , errorBoundRegions :: [Bound n] - , errorBindWitness :: Bind n } - - -- | A letregion-expression where the witness binding references some - -- free region variable that is not the one being introduced. - | ErrorLetRegionWitnessFree - { errorChecking :: Exp a n - , errorBindWitness :: Bind n } - - - -- Withregion ------------------------------------- - -- | A withregion-expression where the handle does not have region kind. - | ErrorWithRegionNotRegion - { errorChecking :: Exp a n - , errorBound :: Bound n - , errorKind :: Kind n } - - -- | A letregion-expression where some of the the bound region variables - -- are free in the type of the body. - | ErrorWithRegionFree - { errorChecking :: Exp a n - , errorBound :: Bound n - , errorType :: Type n } - - - -- Witnesses -------------------------------------- - -- | A witness application where the argument type does not match - -- the parameter type. - | ErrorWAppMismatch - { errorWitness :: Witness a n - , errorParamType :: Type n - , errorArgType :: Type n } - - -- | Tried to perform a witness application with a non-witness. - | ErrorWAppNotCtor - { errorWitness :: Witness a n - , errorNotFunType :: Type n - , errorArgType :: Type n } - - -- | An invalid witness join. - | ErrorCannotJoin - { errorWitness :: Witness a n - , errorWitnessLeft :: Witness a n - , errorTypeLeft :: Type n - , errorWitnessRight :: Witness a n - , errorTypeRight :: Type n } - - -- | A witness provided for a purify cast that does not witness purity. - | ErrorWitnessNotPurity - { errorChecking :: Exp a n - , errorWitness :: Witness a n - , errorType :: Type n } - - -- | A witness provided for a forget cast that does not witness emptiness. - | ErrorWitnessNotEmpty - { errorChecking :: Exp a n - , errorWitness :: Witness a n - , errorType :: Type n } - - - -- Case Expressions ------------------------------- - -- | A case-expression where the scrutinee type is not algebraic. - | ErrorCaseScrutineeNotAlgebraic - { errorChecking :: Exp a n - , errorTypeScrutinee :: Type n } - - -- | A case-expression where the scrutinee type is not in our set - -- of data type declarations. - | ErrorCaseScrutineeTypeUndeclared - { errorChecking :: Exp a n - , errorTypeScrutinee :: 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 - , errorCtorDaCon :: DaCon n - , errorCtorFields :: Int - , errorPatternFields :: Int } - - -- | A case-expression where the pattern types could not be instantiated - -- with the arguments of the scrutinee type. - | ErrorCaseCannotInstantiate - { 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 - { 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 - { errorChecking :: Exp a n - , errorTypeAnnot :: Type n - , errorTypeField :: Type n } - - -- | A case-expression where the result types of the alternatives are not - -- identical. - | ErrorCaseAltResultMismatch - { errorChecking :: Exp a n - , errorAltType1 :: Type n - , errorAltType2 :: Type n } - - - -- Casts ------------------------------------------ - -- | A weakeff-cast where the type provided does not have effect kind. - | ErrorWeakEffNotEff - { errorChecking :: Exp a n - , errorEffect :: Effect n - , errorKind :: Kind n } - - -- | A run cast applied to a non-suspension. - | ErrorRunNotSuspension - { errorChecking :: Exp a n - , errorType :: Type n } +import DDC.Core.Check.Error.ErrorExp +import DDC.Core.Check.Error.ErrorExpMessage () +import DDC.Core.Check.Error.ErrorType +import DDC.Core.Check.Error.ErrorTypeMessage () - -- Types ------------------------------------------ - -- | Found a naked `XType` that wasn't the argument of an application. - | ErrorNakedType - { errorChecking :: Exp a n } +import DDC.Core.Check.Error.ErrorData +import DDC.Core.Check.Error.ErrorDataMessage () - -- Witnesses -------------------------------------- - -- | Found a naked `XWitness` that wasn't the argument of an application. - | ErrorNakedWitness - { errorChecking :: Exp a n } - deriving (Show) diff --git a/DDC/Core/Check/Error/ErrorData.hs b/DDC/Core/Check/Error/ErrorData.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Error/ErrorData.hs @@ -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 diff --git a/DDC/Core/Check/Error/ErrorDataMessage.hs b/DDC/Core/Check/Error/ErrorDataMessage.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Error/ErrorDataMessage.hs @@ -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 ] + diff --git a/DDC/Core/Check/Error/ErrorExp.hs b/DDC/Core/Check/Error/ErrorExp.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Error/ErrorExp.hs @@ -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) + + + + diff --git a/DDC/Core/Check/Error/ErrorExpMessage.hs b/DDC/Core/Check/Error/ErrorExpMessage.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Error/ErrorExpMessage.hs @@ -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) ] + diff --git a/DDC/Core/Check/Error/ErrorType.hs b/DDC/Core/Check/Error/ErrorType.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Error/ErrorType.hs @@ -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 + + diff --git a/DDC/Core/Check/Error/ErrorTypeMessage.hs b/DDC/Core/Check/Error/ErrorTypeMessage.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Error/ErrorTypeMessage.hs @@ -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" ] + diff --git a/DDC/Core/Check/ErrorMessage.hs b/DDC/Core/Check/ErrorMessage.hs deleted file mode 100644 --- a/DDC/Core/Check/ErrorMessage.hs +++ /dev/null @@ -1,368 +0,0 @@ --- | Errors produced when checking core expressions. -module DDC.Core.Check.ErrorMessage - (Error(..)) -where -import DDC.Core.Pretty -import DDC.Core.Check.Error -import DDC.Type.Compounds -import DDC.Type.Universe - - -instance (Show n, Eq n, Pretty 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) ] - - -- Modules --------------------------------------- - ErrorExportUndefined n - -> vcat [ text "Exported value '" <> ppr n <> text "' is undefined." ] - - ErrorExportMismatch n tExport tDef - -> vcat [ text "Type of exported value does not match type of definition." - , text " with binding: " <> ppr n - , text " type of export: " <> ppr tExport - , text " type of definition: " <> ppr tDef ] - - - -- Variable --------------------------------------- - ErrorUndefinedVar u universe - -> case universe of - UniverseSpec - -> vcat [ text "Undefined spec variable: " <> ppr u ] - - UniverseData - -> vcat [ text "Undefined value variable: " <> ppr u ] - - UniverseWitness - -> vcat [ text "Undefined witness variable: " <> ppr u ] - - -- Universes other than the above don't have variables, - -- but let's not worry about that here. - _ -> vcat [ text "Undefined variable: " <> ppr u ] - - ErrorVarAnnotMismatch u tEnv tAnnot - -> vcat [ text "Type mismatch in annotation." - , text " Variable: " <> ppr u - , text " has annotation: " <> ppr tAnnot - , text " which conflicts with: " <> ppr tEnv - , 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 universe eff - -> vcat - [ text "Impure" <+> ppr universe <+> text "abstraction" - , text " has effect: " <> ppr eff - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLamNotEmpty xx universe eff - -> vcat - [ text "Non-empty" <+> ppr universe <+> text "abstraction" - , text " has closure: " <> 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) ] - - - -- 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) ] - - ErrorLetrecRebound xx b - -> vcat [ text "Redefined binder '" <> ppr b <> text "' in letrec." - , empty - , text "with: " <> align (ppr xx) ] - - -- Letregion -------------------------------------- - ErrorLetRegionsNotRegion xx bs ks - -> vcat [ 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: %" - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetRegionsRebound xx bs - -> vcat [ text "Region variables shadow existing ones." - , text " Region variables: " <> (hcat $ map ppr bs) - , text " are already in environment" - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetRegionFree xx bs t - -> vcat [ text "Region variables escape scope of letregion." - , text " The region variables: " <> (hcat $ map ppr bs) - , 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) ] - - ErrorLetRegionsWitnessOther xx bs1 b2 - -> vcat [ text "Witness type is not for bound regions." - , text " letregion binds: " <> (hsep $ map ppr bs1) - , text " but witness type is: " <> ppr b2 - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetRegionWitnessFree xx b - -> vcat [ text "Witness type references a free region variable." - , text " the binding: " <> ppr b - , text " contains free region variables." - , empty - , text "with: " <> align (ppr xx) ] - - -- Withregion ------------------------------------- - ErrorWithRegionFree xx u t - -> vcat [ text "Region handle escapes scope of withregion." - , text " The region handle: " <> ppr u - , text " is used in the body type: " <> ppr t - , empty - , text "with: " <> align (ppr xx) ] - - ErrorWithRegionNotRegion 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 ------------------------------- - ErrorCaseScrutineeNotAlgebraic xx tScrutinee - -> vcat [ text "Scrutinee of case expression is not algebraic data." - , text " Scrutinee type: " <> ppr tScrutinee - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseScrutineeTypeUndeclared xx tScrutinee - -> vcat [ text "Type of scrutinee does not have a data declaration." - , text " Scrutinee type: " <> ppr tScrutinee - , 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 tScrutinee tCtor - -> vcat [ text "Cannot instantiate constructor type with scrutinee type args." - , text " Either the constructor has an invalid type," - , text " or the type of the scrutinee does not match the type of the pattern." - , text " Scrutinee type: " <> ppr tScrutinee - , text " Constructor type: " <> ppr tCtor - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseScrutineeTypeMismatch xx tScrutinee tPattern - -> vcat [ text "Scrutinee type does not match result of pattern type." - , text " Scrutinee type: " <> ppr tScrutinee - , text " Pattern type: " <> ppr tPattern - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseFieldTypeMismatch 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 ------------------------------------------ - ErrorWeakEffNotEff xx eff k - -> vcat [ text "Type provided for a 'weakeff' does not have effect kind." - , text " Type: " <> ppr eff - , text " has kind: " <> ppr k - , empty - , text "with: " <> align (ppr xx) ] - - ErrorRunNotSuspension xx t - -> vcat [ text "Expression to run is not a suspension." - , text " Type: " <> ppr t - , empty - , text "with: " <> align (ppr xx) ] - - - -- Type ------------------------------------------- - ErrorNakedType xx - -> vcat [ text "Found naked type in core program." - , empty - , text "with: " <> align (ppr xx) ] - - -- Witness ---------------------------------------- - ErrorNakedWitness xx - -> vcat [ text "Found naked witness in core program." - , empty - , text "with: " <> align (ppr xx) ] - - diff --git a/DDC/Core/Check/Exp.hs b/DDC/Core/Check/Exp.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Exp.hs @@ -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 } + diff --git a/DDC/Core/Check/Judge/DataDefs.hs b/DDC/Core/Check/Judge/DataDefs.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/DataDefs.hs @@ -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 + + + diff --git a/DDC/Core/Check/Judge/EqT.hs b/DDC/Core/Check/Judge/EqT.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/EqT.hs @@ -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 + diff --git a/DDC/Core/Check/Judge/Inst.hs b/DDC/Core/Check/Judge/Inst.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/Inst.hs @@ -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 diff --git a/DDC/Core/Check/Judge/Kind.hs b/DDC/Core/Check/Judge/Kind.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/Kind.hs @@ -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. +-- diff --git a/DDC/Core/Check/Judge/Kind/TyCon.hs b/DDC/Core/Check/Judge/Kind/TyCon.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/Kind/TyCon.hs @@ -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 diff --git a/DDC/Core/Check/Judge/Module.hs b/DDC/Core/Check/Judge/Module.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/Module.hs @@ -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 + diff --git a/DDC/Core/Check/Judge/Sub.hs b/DDC/Core/Check/Judge/Sub.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/Sub.hs @@ -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 + diff --git a/DDC/Core/Check/Judge/Type/AppT.hs b/DDC/Core/Check/Judge/Type/AppT.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/Type/AppT.hs @@ -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 + diff --git a/DDC/Core/Check/Judge/Type/AppX.hs b/DDC/Core/Check/Judge/Type/AppX.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/Type/AppX.hs @@ -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 + diff --git a/DDC/Core/Check/Judge/Type/Base.hs b/DDC/Core/Check/Judge/Type/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/Type/Base.hs @@ -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') + diff --git a/DDC/Core/Check/Judge/Type/Case.hs b/DDC/Core/Check/Judge/Type/Case.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/Type/Case.hs @@ -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 + diff --git a/DDC/Core/Check/Judge/Type/Cast.hs b/DDC/Core/Check/Judge/Type/Cast.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/Type/Cast.hs @@ -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 + + diff --git a/DDC/Core/Check/Judge/Type/DaCon.hs b/DDC/Core/Check/Judge/Type/DaCon.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/Type/DaCon.hs @@ -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 + diff --git a/DDC/Core/Check/Judge/Type/LamT.hs b/DDC/Core/Check/Judge/Type/LamT.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/Type/LamT.hs @@ -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 + diff --git a/DDC/Core/Check/Judge/Type/LamX.hs b/DDC/Core/Check/Judge/Type/LamX.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/Type/LamX.hs @@ -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." + diff --git a/DDC/Core/Check/Judge/Type/Let.hs b/DDC/Core/Check/Judge/Type/Let.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/Type/Let.hs @@ -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 + diff --git a/DDC/Core/Check/Judge/Type/LetPrivate.hs b/DDC/Core/Check/Judge/Type/LetPrivate.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/Type/LetPrivate.hs @@ -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 + + + diff --git a/DDC/Core/Check/Judge/Type/Sub.hs b/DDC/Core/Check/Judge/Type/Sub.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/Type/Sub.hs @@ -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) + + diff --git a/DDC/Core/Check/Judge/Type/VarCon.hs b/DDC/Core/Check/Judge/Type/VarCon.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/Type/VarCon.hs @@ -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 + diff --git a/DDC/Core/Check/Judge/Type/Witness.hs b/DDC/Core/Check/Judge/Type/Witness.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/Type/Witness.hs @@ -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" diff --git a/DDC/Core/Check/Judge/Witness.hs b/DDC/Core/Check/Judge/Witness.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/Judge/Witness.hs @@ -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 + diff --git a/DDC/Core/Check/TaggedClosure.hs b/DDC/Core/Check/TaggedClosure.hs deleted file mode 100644 --- a/DDC/Core/Check/TaggedClosure.hs +++ /dev/null @@ -1,229 +0,0 @@ - -module DDC.Core.Check.TaggedClosure - ( TaggedClosure(..) - , closureOfTagged - , closureOfTaggedSet - , taggedClosureOfValBound - , taggedClosureOfTyArg - , taggedClosureOfWeakClo - , maskFromTaggedSet - , cutTaggedClosureX - , cutTaggedClosureXs - , cutTaggedClosureT) -where -import DDC.Type.Transform.LiftT -import DDC.Type.Transform.Trim -import DDC.Type.Compounds -import DDC.Type.Predicates -import DDC.Type.Pretty -import DDC.Type.Exp -import Control.Monad -import Data.Maybe -import Data.Set (Set) -import DDC.Type.Env (Env) -import qualified DDC.Type.Env as Env -import qualified DDC.Type.Sum as Sum -import qualified Data.Set as Set - - --- | A closure-term tagged with the bound variable that the term is due to. -data TaggedClosure n - -- | Term due to a free value variable. - = GBoundVal (Bound n) (TypeSum n) - - -- | Term due to a free region variable. - | GBoundRgnVar (Bound n) - - -- | Term due to a region handle. - | GBoundRgnCon (Bound n) - deriving Show - - -instance Eq n => Eq (TaggedClosure n) where - (==) (GBoundVal u1 _) (GBoundVal u2 _) = u1 == u2 - (==) (GBoundRgnVar u1) (GBoundRgnVar u2) = u1 == u2 - (==) (GBoundRgnCon u1) (GBoundRgnCon u2) = u1 == u2 - (==) _ _ = False - - -instance Ord n => Ord (TaggedClosure n) where - compare g1 g2 = compare (ordify g1) (ordify g2) - where - ordify gg - = case gg of - GBoundVal u _ -> (0, u) :: (Int, Bound n) - GBoundRgnVar u -> (1, u) - GBoundRgnCon u -> (2, u) - - -instance (Eq n, Pretty n) => Pretty (TaggedClosure n) where - ppr cc - = case cc of - GBoundVal u clos -> text "CLOVAL " <+> ppr u <+> text ":" <+> ppr clos - GBoundRgnVar u -> text "CLORGNVAR" <+> ppr u - GBoundRgnCon u -> text "CLORGNCON" <+> ppr u - - -instance Ord n => MapBoundT TaggedClosure n where - mapBoundAtDepthT f d cc - = let down = mapBoundAtDepthT f d - in case cc of - GBoundVal u ts -> GBoundVal (down u) (down ts) - GBoundRgnVar u1 -> GBoundRgnVar (down u1) - GBoundRgnCon u2 -> GBoundRgnCon u2 - - --- | Convert a tagged clousure to a regular closure by dropping the tag variables. -closureOfTagged :: TaggedClosure n -> Closure n -closureOfTagged gg - = case gg of - GBoundVal _ clos -> TSum $ clos - GBoundRgnVar u -> tUse (TVar u) - GBoundRgnCon u -> tUse (TCon (TyConBound u kRegion)) - - --- | Convert a set of tagged closures to a regular closure by dropping the --- tag variables. -closureOfTaggedSet :: Ord n => Set (TaggedClosure n) -> Closure n -closureOfTaggedSet clos - = TSum $ Sum.fromList kClosure - $ map closureOfTagged - $ Set.toList clos - - --- | Yield the tagged closure of a value variable. -taggedClosureOfValBound - :: (Ord n, Pretty n) - => Type n -> Bound n -> TaggedClosure n - -taggedClosureOfValBound t u - = GBoundVal u - $ Sum.singleton kClosure - $ (let clo = tDeepUse t - in fromMaybe clo (trimClosure clo)) - - --- | Yield the tagged closure of a type argument, --- or `Nothing` for out-of-scope type vars. -taggedClosureOfTyArg - :: (Ord n, Pretty n) - => Env n -> Type n -> Maybe (Set (TaggedClosure n)) - -taggedClosureOfTyArg kenv tt - = case tt of - TVar u - -> case Env.lookup u kenv of - Nothing -> Nothing - Just k - | isRegionKind k -> Just $ Set.singleton $ GBoundRgnVar u - | otherwise -> Just Set.empty - - TCon (TyConBound u k) - | isRegionKind k - -> Just $ Set.singleton $ GBoundRgnCon u - - _ -> Just $ Set.empty - - --- | Convert the closure provided as a 'weakclo' to tagged form. --- Only terms of form `Use r` can be converted. -taggedClosureOfWeakClo - :: (Ord n, Pretty n) - => Closure n -> Maybe (Set (TaggedClosure n)) - -taggedClosureOfWeakClo clo - = liftM Set.fromList - $ sequence - $ map convert - $ Sum.toList $ Sum.singleton kClosure clo - - where convert c - = case takeTyConApps c of - Just (TyConSpec TcConUse, [TVar u]) - -> Just $ GBoundRgnVar u - - Just (TyConSpec TcConUse, [TCon (TyConBound u _)]) - -> Just $ GBoundRgnCon u - - _ -> Nothing - - --- | Mask a closure term from a tagged closure. --- --- This is used for the `forget` cast. -maskFromTaggedSet - :: Ord n - => TypeSum n - -> Set (TaggedClosure n) -> Set (TaggedClosure n) -maskFromTaggedSet ts1 set - = Set.fromList $ mapMaybe mask $ Set.toList set - - where mask gg - = case gg of - GBoundVal u ts2 - -> Just $ GBoundVal u $ ts2 `Sum.difference` ts1 - - GBoundRgnVar u - | Sum.elem (tUse (TVar u)) ts1 - -> Nothing - | otherwise -> Just gg - - GBoundRgnCon u - | Sum.elem (tUse (TCon (TyConBound u kRegion))) ts1 - -> Nothing - | otherwise -> Just gg - - --- | Cut the terms due to the outermost binder from a tagged closure. -cutTaggedClosureT - :: (Eq n, Ord n) - => Bind n - -> TaggedClosure n - -> Maybe (TaggedClosure n) - -cutTaggedClosureT b1 cc - = let lower = case b1 of - BAnon{} -> lowerT 1 - _ -> id - in case cc of - GBoundVal u2 ts -> Just $ GBoundVal u2 (lower ts) - - GBoundRgnVar u2 - | boundMatchesBind u2 b1 -> Nothing - | otherwise -> Just $ GBoundRgnVar (lower u2) - - GBoundRgnCon u2 -> Just $ GBoundRgnCon (lower u2) - - --- | Like `cutTaggedClosureX` but cut terms due to several binders. -cutTaggedClosureXs - :: (Eq n, Ord n) - => [Bind n] - -> TaggedClosure n -> Maybe (TaggedClosure n) - -cutTaggedClosureXs bb c - = case bb of - [] -> Just c - (b:bs) -> case cutTaggedClosureX b c of - Nothing -> Nothing - Just c' -> cutTaggedClosureXs bs c' - - --- | Cut the terms due to the outermost binder from a tagged closure. -cutTaggedClosureX - :: (Eq n, Ord n) - => Bind n - -> TaggedClosure n - -> Maybe (TaggedClosure n) - -cutTaggedClosureX b1 cc - = let lower = case b1 of - BAnon{} -> lowerT 1 - _ -> id - in case cc of - GBoundVal u2 ts - | boundMatchesBind u2 b1 -> Nothing - | otherwise -> Just $ GBoundVal (lower u2) ts - - GBoundRgnVar u2 -> Just $ GBoundRgnVar u2 - GBoundRgnCon u2 -> Just $ GBoundRgnCon u2 diff --git a/DDC/Core/Collect.hs b/DDC/Core/Collect.hs --- a/DDC/Core/Collect.hs +++ b/DDC/Core/Collect.hs @@ -2,17 +2,24 @@ -- | Collecting sets of variables and constructors. module DDC.Core.Collect ( -- * Free Variables - freeT + freeT, freeVarsT , freeX -- * Bounds and Binds , collectBound , collectBinds + -- * Abstract Binding Structures + , BindTree (..) + , BindWay (..) + , BoundLevel (..) + , BindStruct (..) + -- * Support , Support (..) , SupportX (..)) where -import DDC.Core.Collect.Free +import DDC.Core.Collect.FreeX +import DDC.Core.Collect.FreeT +import DDC.Core.Collect.BindStruct import DDC.Core.Collect.Support -import DDC.Type.Collect diff --git a/DDC/Core/Collect/BindStruct.hs b/DDC/Core/Collect/BindStruct.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Collect/BindStruct.hs @@ -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 + + _ -> [] + + diff --git a/DDC/Core/Collect/Free.hs b/DDC/Core/Collect/Free.hs deleted file mode 100644 --- a/DDC/Core/Collect/Free.hs +++ /dev/null @@ -1,121 +0,0 @@ --- | Collecting sets of variables and constructors. -module DDC.Core.Collect.Free - (freeX) -where -import DDC.Type.Collect -import DDC.Type.Compounds -import DDC.Core.Module -import DDC.Core.Exp -import DDC.Type.Env (Env) -import qualified DDC.Type.Env as Env -import qualified Data.Set as Set -import Data.Set (Set) - - --- freeX ---------------------------------------------------------------------- --- | Collect the free Data and Witness variables in a thing (level-0). -freeX :: (BindStruct c, Ord n) - => Env n -> c n -> Set (Bound n) -freeX tenv xx = Set.unions $ map (freeOfTreeX tenv) $ slurpBindTree xx - -freeOfTreeX :: Ord n => Env n -> BindTree n -> Set (Bound n) -freeOfTreeX tenv tt - = {-# SCC freeOfTreeX #-} - case tt of - BindDef way bs ts - | isBoundExpWit $ boundLevelOfBindWay way - , tenv' <- Env.extends bs tenv - -> Set.unions $ map (freeOfTreeX tenv') ts - - BindDef _ _ ts - -> Set.unions $ map (freeOfTreeX tenv) ts - - BindUse bl u - | isBoundExpWit bl - , Env.member u tenv -> Set.empty - | isBoundExpWit bl -> Set.singleton u - _ -> Set.empty - - --- Module --------------------------------------------------------------------- -instance BindStruct (Module a) where - slurpBindTree mm - = slurpBindTree $ moduleBody mm - - --- Exp ------------------------------------------------------------------------ -instance BindStruct (Exp a) where - slurpBindTree xx - = case xx of - XVar _ u - -> [BindUse BoundExp u] - - XCon _ dc - -> case daConName dc of - DaConUnit -> [] - DaConNamed 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 _ (LLetRegions b bs) x2 - -> [ BindDef BindLetRegions b - [bindDefX BindLetRegionWith bs [x2]]] - - XLet _ (LWithRegion u) x2 - -> BindUse BoundExp u : slurpBindTree x2 - - XCase _ x alts -> slurpBindTree x ++ concatMap slurpBindTree alts - XCast _ c x -> slurpBindTree c ++ slurpBindTree x - XType t -> slurpBindTree t - XWitness w -> slurpBindTree w - - -instance BindStruct (Cast a) where - slurpBindTree cc - = case cc of - CastWeakenEffect eff -> slurpBindTree eff - CastWeakenClosure xs -> concatMap slurpBindTree xs - CastPurify w -> slurpBindTree w - CastForget w -> slurpBindTree w - CastSuspend -> [] - CastRun -> [] - - -instance BindStruct (Alt a) where - slurpBindTree alt - = case alt of - AAlt PDefault x - -> slurpBindTree x - - AAlt (PData _ bs) x - -> [bindDefX BindCasePat bs [x]] - - -instance BindStruct (Witness a) where - slurpBindTree ww - = case ww of - WVar _ u -> [BindUse BoundWit u] - WCon{} -> [] - WApp _ w1 w2 -> slurpBindTree w1 ++ slurpBindTree w2 - WJoin _ w1 w2 -> slurpBindTree w1 ++ slurpBindTree w2 - WType _ t -> slurpBindTree t - - --- | Helper for constructing the `BindTree` for an expression or witness binder. -bindDefX :: BindStruct c - => BindWay -> [Bind n] -> [c n] -> BindTree n -bindDefX way bs xs - = BindDef way bs - $ concatMap (slurpBindTree . typeOfBind) bs - ++ concatMap slurpBindTree xs diff --git a/DDC/Core/Collect/FreeT.hs b/DDC/Core/Collect/FreeT.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Collect/FreeT.hs @@ -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) + + diff --git a/DDC/Core/Collect/FreeX.hs b/DDC/Core/Collect/FreeX.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Collect/FreeX.hs @@ -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 diff --git a/DDC/Core/Collect/Support.hs b/DDC/Core/Collect/Support.hs --- a/DDC/Core/Collect/Support.hs +++ b/DDC/Core/Collect/Support.hs @@ -1,18 +1,20 @@ module DDC.Core.Collect.Support ( Support (..) - , SupportX (..)) + , SupportX (..) + , supportEnvFlags) where -import DDC.Core.Compounds -import DDC.Core.Exp -import DDC.Type.Collect.FreeT +import DDC.Core.Module +import DDC.Core.Exp.Annot +import DDC.Core.Collect.FreeT import Data.Set (Set) import DDC.Type.Env (KindEnv, TypeEnv) import qualified DDC.Type.Env as Env import qualified Data.Set as Set -import Data.Monoid - +import Data.Maybe +import Data.Monoid ((<>)) +--------------------------------------------------------------------------------------------------- data Support n = Support { -- | Type constructors used in the expression. @@ -56,6 +58,26 @@ , supportDaVar = Set.unions [supportDaVar sp1, supportDaVar sp2] } +--------------------------------------------------------------------------------------------------- +-- | Get a description of the type and value environment from a Support. +-- Type (level-1) variables are tagged with True, while +-- value and witness (level-0) variables are tagged with False. +supportEnvFlags + :: Ord n => Support n + -> Set (Bool, Bound n) + +supportEnvFlags supp + = let + us1 = Set.map (\u -> (True, u)) $ supportSpVar supp + + us0 = Set.unions + [ Set.map (\u -> (False, u)) $ supportDaVar supp + , Set.map (\u -> (False, u)) $ supportWiVar supp] + + in Set.union us1 us0 + + +--------------------------------------------------------------------------------------------------- class SupportX (c :: * -> *) where support :: Ord n @@ -71,10 +93,11 @@ , supportSpVar = fvs1 } -instance SupportX Bind where - support kenv tenv b - = support kenv tenv - $ typeOfBind b +instance SupportX (Module a) where + support kenv tenv mm + = let kenv' = Env.union kenv (moduleKindEnv mm) + tenv' = Env.union tenv (moduleTypeEnv mm) + in support kenv' tenv' (moduleBody mm) instance SupportX (Exp a) where @@ -118,12 +141,12 @@ s2 = support kenv tenv x2 in mappend s1 s2 - XType t + XType _ t -> let sup = support kenv tenv t in sup { supportTyConXArg = supportTyCon sup , supportSpVarXArg = supportSpVar sup } - XWitness w -> support kenv tenv w + XWitness _ w -> support kenv tenv w instance SupportX (Alt a) where @@ -151,10 +174,6 @@ -> support kenv tenv w1 <> support kenv tenv w2 - WJoin _ w1 w2 - -> support kenv tenv w1 - <> support kenv tenv w2 - WType _ t -> support kenv tenv t @@ -165,16 +184,10 @@ CastWeakenEffect eff -> support kenv tenv eff - CastWeakenClosure xs - -> mconcat $ map (support kenv tenv) xs - CastPurify w -> support kenv tenv w - CastForget w - -> support kenv tenv w - - CastSuspend + CastBox -> mempty CastRun @@ -193,12 +206,16 @@ <> (let tenv' = Env.extends (map fst bxs) tenv in mconcat $ map (support kenv tenv') $ map snd bxs) - LLetRegions bs ws + 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) - LWithRegion u - | Env.member u kenv -> mempty - | otherwise -> mempty { supportSpVar = Set.singleton u } + +instance SupportX Bind where + support kenv tenv b + = support kenv tenv + $ typeOfBind b + diff --git a/DDC/Core/Compounds.hs b/DDC/Core/Compounds.hs deleted file mode 100644 --- a/DDC/Core/Compounds.hs +++ /dev/null @@ -1,7 +0,0 @@ - --- | Utilities for constructing and destructing compound expressions. -module DDC.Core.Compounds - ( module DDC.Core.Compounds.Annot ) -where -import DDC.Core.Compounds.Annot - diff --git a/DDC/Core/Compounds/Annot.hs b/DDC/Core/Compounds/Annot.hs deleted file mode 100644 --- a/DDC/Core/Compounds/Annot.hs +++ /dev/null @@ -1,342 +0,0 @@ - --- | Utilities for constructing and destructing compound expressions. --- --- For the annotated version of the AST. -module DDC.Core.Compounds.Annot - ( module DDC.Type.Compounds - - -- * Annotations - , takeAnnotOfExp - - -- * Lambdas - , xLAMs - , xLams - , makeXLamFlags - , takeXLAMs - , takeXLams - , takeXLamFlags - - -- * Applications - , xApps - , makeXAppsWithAnnots - , takeXApps - , takeXApps1 - , takeXAppsAsList - , takeXAppsWithAnnots - , takeXConApps - , takeXPrimApps - - -- * Lets - , xLets, xLetsAnnot - , splitXLets - , bindsOfLets - , specBindsOfLets - , valwitBindsOfLets - - -- * Patterns - , bindsOfPat - - -- * Alternatives - , takeCtorNameOfAlt - - -- * Witnesses - , wApp - , wApps - , takeXWitness - , takeWAppsAsList - , takePrimWiConApps - - -- * Types - , takeXType - - -- * Data Constructors - , xUnit, dcUnit - , mkDaConAlg - , mkDaConSolid - , takeNameOfDaCon - , typeOfDaCon) -where -import DDC.Type.Compounds -import DDC.Core.Exp -import DDC.Core.Exp.DaCon - - --- Annotations ---------------------------------------------------------------- --- | Take the outermost annotation from an expression, --- or Nothing if this is an `XType` or `XWitness` without an annotation. -takeAnnotOfExp :: Exp a n -> Maybe a -takeAnnotOfExp xx - = case xx of - XVar a _ -> Just a - XCon a _ -> Just a - XLAM a _ _ -> Just a - XLam a _ _ -> Just a - XApp a _ _ -> Just a - XLet a _ _ -> Just a - XCase a _ _ -> Just a - XCast a _ _ -> Just a - XType{} -> Nothing - XWitness{} -> Nothing - - --- Lambdas --------------------------------------------------------------------- --- | Make some nested type lambdas. -xLAMs :: a -> [Bind n] -> Exp a n -> Exp a n -xLAMs a bs x - = foldr (XLAM a) x bs - - --- | Make some nested value or witness lambdas. -xLams :: a -> [Bind n] -> Exp a n -> Exp a n -xLams a bs x - = foldr (XLam a) x bs - - --- | Split type lambdas from the front of an expression, --- or `Nothing` if there aren't any. -takeXLAMs :: Exp a n -> Maybe ([Bind n], Exp a n) -takeXLAMs xx - = let go bs (XLAM _ b x) = go (b:bs) x - go bs x = (reverse bs, x) - in case go [] xx of - ([], _) -> Nothing - (bs, body) -> Just (bs, body) - - --- | Split nested value or witness lambdas from the front of an expression, --- or `Nothing` if there aren't any. -takeXLams :: Exp a n -> Maybe ([Bind n], Exp a n) -takeXLams xx - = let go bs (XLam _ b x) = go (b:bs) x - go bs x = (reverse bs, x) - in case go [] xx of - ([], _) -> Nothing - (bs, body) -> Just (bs, body) - - --- | Make some nested lambda abstractions, --- using a flag to indicate whether the lambda is a --- level-1 (True), or level-0 (False) binder. -makeXLamFlags :: a -> [(Bool, Bind n)] -> Exp a n -> Exp a n -makeXLamFlags a fbs x - = foldr (\(f, b) x' - -> if f then XLAM a b x' - else XLam a b x') - x fbs - - --- | Split nested lambdas from the front of an expression, --- with a flag indicating whether the lambda was a level-1 (True), --- or level-0 (False) binder. -takeXLamFlags :: Exp a n -> Maybe ([(Bool, Bind n)], Exp a n) -takeXLamFlags xx - = let go bs (XLAM _ b x) = go ((True, b):bs) x - go bs (XLam _ b x) = go ((False, b):bs) x - go bs x = (reverse bs, x) - in case go [] xx of - ([], _) -> Nothing - (bs, body) -> Just (bs, body) - - --- Applications --------------------------------------------------------------- --- | Build sequence of value applications. -xApps :: a -> Exp a n -> [Exp a n] -> Exp a n -xApps a t1 ts = foldl (XApp a) t1 ts - - --- | Build sequence of applications. --- Similar to `xApps` but also takes list of annotations for --- the `XApp` constructors. -makeXAppsWithAnnots :: Exp a n -> [(Exp a n, a)] -> Exp a n -makeXAppsWithAnnots f xas - = case xas of - [] -> f - (arg,a ) : as -> makeXAppsWithAnnots (XApp a f arg) as - - --- | Flatten an application into the function part and its arguments. --- --- Returns `Nothing` if there is no outer application. -takeXApps :: Exp a n -> Maybe (Exp a n, [Exp a n]) -takeXApps xx - = case takeXAppsAsList xx of - (x1 : xsArgs) -> Just (x1, xsArgs) - _ -> Nothing - - --- | Flatten an application into the function part and its arguments. --- --- This is like `takeXApps` above, except we know there is at least one argument. -takeXApps1 :: Exp a n -> Exp a n -> (Exp a n, [Exp a n]) -takeXApps1 x1 x2 - = case takeXApps x1 of - Nothing -> (x1, [x2]) - Just (x11, x12s) -> (x11, x12s ++ [x2]) - - --- | Flatten an application into the function parts and arguments, if any. -takeXAppsAsList :: Exp a n -> [Exp a n] -takeXAppsAsList xx - = case xx of - XApp _ x1 x2 -> takeXAppsAsList x1 ++ [x2] - _ -> [xx] - - --- | Destruct sequence of applications. --- Similar to `takeXAppsAsList` but also keeps annotations for later. -takeXAppsWithAnnots :: Exp a n -> (Exp a n, [(Exp a n, a)]) -takeXAppsWithAnnots xx - = case xx of - XApp a f arg - -> let (f', args') = takeXAppsWithAnnots f - in (f', args' ++ [(arg,a)]) - - _ -> (xx, []) - - --- | Flatten an application of a primop into the variable --- and its arguments. --- --- Returns `Nothing` if the expression isn't a primop application. -takeXPrimApps :: Exp a n -> Maybe (n, [Exp a n]) -takeXPrimApps xx - = case takeXAppsAsList xx of - XVar _ (UPrim p _) : xs -> Just (p, xs) - _ -> Nothing - --- | Flatten an application of a data constructor into the constructor --- and its arguments. --- --- Returns `Nothing` if the expression isn't a constructor application. -takeXConApps :: Exp a n -> Maybe (DaCon n, [Exp a n]) -takeXConApps xx - = case takeXAppsAsList xx of - XCon _ dc : xs -> Just (dc, xs) - _ -> Nothing - - --- Lets ----------------------------------------------------------------------- --- | Wrap some let-bindings around an expression. -xLets :: a -> [Lets a n] -> Exp a n -> Exp a n -xLets a lts x - = foldr (XLet a) x lts - - --- | Wrap some let-bindings around an expression, with individual annotations. -xLetsAnnot :: [(Lets a n, a)] -> Exp a n -> Exp a n -xLetsAnnot lts x - = foldr (\(l, a) x' -> XLet a l x') x lts - - --- | Split let-bindings from the front of an expression, if any. -splitXLets :: Exp a n -> ([Lets a n], Exp a n) -splitXLets xx - = case xx of - XLet _ lts x - -> let (lts', x') = splitXLets x - in (lts : lts', x') - - _ -> ([], xx) - --- | Take the binds of a `Lets`. --- --- The level-1 and level-0 binders are returned separately. -bindsOfLets :: Lets a n -> ([Bind n], [Bind n]) -bindsOfLets ll - = case ll of - LLet b _ -> ([], [b]) - LRec bxs -> ([], map fst bxs) - LLetRegions bs bbs -> (bs, bbs) - LWithRegion{} -> ([], []) - - --- | Like `bindsOfLets` but only take the spec (level-1) binders. -specBindsOfLets :: Lets a n -> [Bind n] -specBindsOfLets ll - = case ll of - LLet _ _ -> [] - LRec _ -> [] - LLetRegions bs _ -> bs - LWithRegion{} -> [] - - --- | Like `bindsOfLets` but only take the value and witness (level-0) binders. -valwitBindsOfLets :: Lets a n -> [Bind n] -valwitBindsOfLets ll - = case ll of - LLet b _ -> [b] - LRec bxs -> map fst bxs - LLetRegions _ bs -> bs - LWithRegion{} -> [] - - --- Alternatives --------------------------------------------------------------- --- | Take the constructor name of an alternative, if there is one. -takeCtorNameOfAlt :: Alt a n -> Maybe n -takeCtorNameOfAlt aa - = case aa of - AAlt (PData dc _) _ -> takeNameOfDaCon dc - _ -> Nothing - - --- Patterns ------------------------------------------------------------------- --- | Take the binds of a `Pat`. -bindsOfPat :: Pat n -> [Bind n] -bindsOfPat pp - = case pp of - PDefault -> [] - PData _ bs -> bs - - --- Witnesses ------------------------------------------------------------------ --- | Construct a witness application -wApp :: 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 witness from an `XWitness` argument, if any. -takeXWitness :: Exp a n -> Maybe (Witness a n) -takeXWitness xx - = case xx of - XWitness t -> Just t - _ -> Nothing - - --- | Flatten an application into the function parts and arguments, if any. -takeWAppsAsList :: Witness a n -> [Witness a n] -takeWAppsAsList ww - = case ww of - WApp _ w1 w2 -> takeWAppsAsList w1 ++ [w2] - _ -> [ww] - - --- | Flatten an application of a witness into the witness constructor --- name and its arguments. --- --- Returns nothing if there is no witness constructor in head position. -takePrimWiConApps :: Witness a n -> Maybe (n, [Witness a n]) -takePrimWiConApps ww - = case takeWAppsAsList ww of - WCon _ wc : args | WiConBound (UPrim n _) _ <- wc - -> Just (n, args) - _ -> Nothing - - --- Types ---------------------------------------------------------------------- --- | Take the type from an `XType` argument, if any. -takeXType :: Exp a n -> Maybe (Type n) -takeXType xx - = case xx of - XType t -> Just t - _ -> Nothing - - --- Units ----------------------------------------------------------------------- --- | Construct a value of unit type. -xUnit :: a -> Exp a n -xUnit a = XCon a dcUnit diff --git a/DDC/Core/Compounds/Simple.hs b/DDC/Core/Compounds/Simple.hs deleted file mode 100644 --- a/DDC/Core/Compounds/Simple.hs +++ /dev/null @@ -1,293 +0,0 @@ - --- | Utilities for constructing and destructing compound expressions. --- --- For the Simple version of the AST. -module DDC.Core.Compounds.Simple - ( module DDC.Type.Compounds - - -- * Lambdas - , xLAMs - , xLams - , makeXLamFlags - , takeXLAMs - , takeXLams - , takeXLamFlags - - -- * Applications - , xApps - , takeXApps - , takeXApps1 - , takeXAppsAsList - , takeXConApps - , takeXPrimApps - - -- * Lets - , xLets - , splitXLets - , bindsOfLets - , specBindsOfLets - , valwitBindsOfLets - - -- * Patterns - , bindsOfPat - - -- * Alternatives - , takeCtorNameOfAlt - - -- * Witnesses - , wApp - , wApps - , takeXWitness - , takeWAppsAsList - , takePrimWiConApps - - -- * Types - , takeXType - - -- * Data Constructors - , xUnit, dcUnit - , mkDaConAlg - , mkDaConSolid - , takeNameOfDaCon - , typeOfDaCon) -where -import DDC.Type.Exp -import DDC.Core.Exp.Simple -import DDC.Core.Exp.DaCon -import DDC.Type.Compounds - - --- Lambdas --------------------------------------------------------------------- --- | Make some nested type lambdas. -xLAMs :: [Bind n] -> Exp a n -> Exp a n -xLAMs bs x - = foldr XLAM x bs - - --- | Make some nested value or witness lambdas. -xLams :: [Bind n] -> Exp a n -> Exp a n -xLams bs x - = foldr XLam x bs - - --- | Split type lambdas from the front of an expression, --- or `Nothing` if there aren't any. -takeXLAMs :: Exp a n -> Maybe ([Bind n], Exp a n) -takeXLAMs xx - = let go bs (XLAM b x) = go (b:bs) x - go bs x = (reverse bs, x) - in case go [] xx of - ([], _) -> Nothing - (bs, body) -> Just (bs, body) - - --- | Split nested value or witness lambdas from the front of an expression, --- or `Nothing` if there aren't any. -takeXLams :: Exp a n -> Maybe ([Bind n], Exp a n) -takeXLams xx - = let go bs (XLam b x) = go (b:bs) x - go bs x = (reverse bs, x) - in case go [] xx of - ([], _) -> Nothing - (bs, body) -> Just (bs, body) - - --- | Make some nested lambda abstractions, --- using a flag to indicate whether the lambda is a --- level-1 (True), or level-0 (False) binder. -makeXLamFlags :: [(Bool, Bind n)] -> Exp a n -> Exp a n -makeXLamFlags fbs x - = foldr (\(f, b) x' - -> if f then XLAM b x' - else XLam b x') - x fbs - - --- | Split nested lambdas from the front of an expression, --- with a flag indicating whether the lambda was a level-1 (True), --- or level-0 (False) binder. -takeXLamFlags :: Exp a n -> Maybe ([(Bool, Bind n)], Exp a n) -takeXLamFlags xx - = let go bs (XLAM b x) = go ((True, b):bs) x - go bs (XLam b x) = go ((False, b):bs) x - go bs x = (reverse bs, x) - in case go [] xx of - ([], _) -> Nothing - (bs, body) -> Just (bs, body) - - --- Applications --------------------------------------------------------------- --- | Build sequence of value applications. -xApps :: Exp a n -> [Exp a n] -> Exp a n -xApps t1 ts = foldl XApp t1 ts - - --- | Flatten an application into the function part and its arguments. --- --- Returns `Nothing` if there is no outer application. -takeXApps :: Exp a n -> Maybe (Exp a n, [Exp a n]) -takeXApps xx - = case takeXAppsAsList xx of - (x1 : xsArgs) -> Just (x1, xsArgs) - _ -> Nothing - - --- | Flatten an application into the function part and its arguments. --- --- This is like `takeXApps` above, except we know there is at least one argument. -takeXApps1 :: Exp a n -> Exp a n -> (Exp a n, [Exp a n]) -takeXApps1 x1 x2 - = case takeXApps x1 of - Nothing -> (x1, [x2]) - Just (x11, x12s) -> (x11, x12s ++ [x2]) - - --- | Flatten an application into the function parts and arguments, if any. -takeXAppsAsList :: Exp a n -> [Exp a n] -takeXAppsAsList xx - = case xx of - XApp x1 x2 -> takeXAppsAsList x1 ++ [x2] - _ -> [xx] - - --- | Flatten an application of a primop into the variable --- and its arguments. --- --- Returns `Nothing` if the expression isn't a primop application. -takeXPrimApps :: Exp a n -> Maybe (n, [Exp a n]) -takeXPrimApps xx - = case takeXAppsAsList xx of - XVar (UPrim p _) : xs -> Just (p, xs) - _ -> Nothing - --- | Flatten an application of a data constructor into the constructor --- and its arguments. --- --- Returns `Nothing` if the expression isn't a constructor application. -takeXConApps :: Exp a n -> Maybe (DaCon n, [Exp a n]) -takeXConApps xx - = case takeXAppsAsList xx of - XCon dc : xs -> Just (dc, xs) - _ -> Nothing - - --- Lets ----------------------------------------------------------------------- --- | Wrap some let-bindings around an expression. -xLets :: [Lets a n] -> Exp a n -> Exp a n -xLets lts x - = foldr XLet x lts - - --- | Split let-bindings from the front of an expression, if any. -splitXLets :: Exp a n -> ([Lets a n], Exp a n) -splitXLets xx - = case xx of - XLet lts x - -> let (lts', x') = splitXLets x - in (lts : lts', x') - - _ -> ([], xx) - - --- | Take the binds of a `Lets`. --- --- The level-1 and level-0 binders are returned separately. -bindsOfLets :: Lets a n -> ([Bind n], [Bind n]) -bindsOfLets ll - = case ll of - LLet b _ -> ([], [b]) - LRec bxs -> ([], map fst bxs) - LLetRegions bs bbs -> (bs, bbs) - LWithRegion{} -> ([], []) - - --- | Like `bindsOfLets` but only take the spec (level-1) binders. -specBindsOfLets :: Lets a n -> [Bind n] -specBindsOfLets ll - = case ll of - LLet _ _ -> [] - LRec _ -> [] - LLetRegions bs _ -> bs - LWithRegion{} -> [] - - --- | Like `bindsOfLets` but only take the value and witness (level-0) binders. -valwitBindsOfLets :: Lets a n -> [Bind n] -valwitBindsOfLets ll - = case ll of - LLet b _ -> [b] - LRec bxs -> map fst bxs - LLetRegions _ bs -> bs - LWithRegion{} -> [] - - --- Alternatives --------------------------------------------------------------- --- | Take the constructor name of an alternative, if there is one. -takeCtorNameOfAlt :: Alt a n -> Maybe n -takeCtorNameOfAlt aa - = case aa of - AAlt (PData dc _) _ -> takeNameOfDaCon dc - _ -> Nothing - - --- Patterns ------------------------------------------------------------------- --- | Take the binds of a `Pat`. -bindsOfPat :: Pat n -> [Bind n] -bindsOfPat pp - = case pp of - PDefault -> [] - PData _ bs -> bs - - --- Witnesses ------------------------------------------------------------------ --- | Construct a witness application -wApp :: Witness a n -> Witness a n -> Witness a n -wApp = WApp - - --- | Construct a sequence of witness applications -wApps :: Witness a n -> [Witness a n] -> Witness a n -wApps = foldl wApp - - --- | Take the witness from an `XWitness` argument, if any. -takeXWitness :: Exp a n -> Maybe (Witness a n) -takeXWitness xx - = case xx of - XWitness t -> Just t - _ -> Nothing - - --- | Flatten an application into the function parts and arguments, if any. -takeWAppsAsList :: Witness a n -> [Witness a n] -takeWAppsAsList ww - = case ww of - WApp w1 w2 -> takeWAppsAsList w1 ++ [w2] - _ -> [ww] - - --- | Flatten an application of a witness into the witness constructor --- name and its arguments. --- --- Returns nothing if there is no witness constructor in head position. -takePrimWiConApps :: Witness a n -> Maybe (n, [Witness a n]) -takePrimWiConApps ww - = case takeWAppsAsList ww of - WCon wc : args | WiConBound (UPrim n _) _ <- wc - -> Just (n, args) - _ -> Nothing - - --- Types ---------------------------------------------------------------------- --- | Take the type from an `XType` argument, if any. -takeXType :: Exp a n -> Maybe (Type n) -takeXType xx - = case xx of - XType t -> Just t - _ -> Nothing - - --- Units ----------------------------------------------------------------------- --- | Construct a value of unit type. -xUnit :: Exp a n -xUnit = XCon dcUnit diff --git a/DDC/Core/Env/EnvT.hs b/DDC/Core/Env/EnvT.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Env/EnvT.hs @@ -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 } + diff --git a/DDC/Core/Env/EnvX.hs b/DDC/Core/Env/EnvX.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Env/EnvX.hs @@ -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 } + diff --git a/DDC/Core/Exp.hs b/DDC/Core/Exp.hs --- a/DDC/Core/Exp.hs +++ b/DDC/Core/Exp.hs @@ -1,6 +1,6 @@ -- | Abstract syntax for the Disciple core language. module DDC.Core.Exp - ( module DDC.Core.Exp.Annot ) + ( module DDC.Core.Exp.Annot.Exp ) where -import DDC.Core.Exp.Annot +import DDC.Core.Exp.Annot.Exp diff --git a/DDC/Core/Exp/Annot.hs b/DDC/Core/Exp/Annot.hs --- a/DDC/Core/Exp/Annot.hs +++ b/DDC/Core/Exp/Annot.hs @@ -1,202 +1,123 @@ --- | Core language AST that includes an annotation on every node of --- an expression. --- --- This is the default representation for Disciple Core, and should be preferred --- over the 'Simple' version of the AST in most cases. --- --- * Local transformations on this AST should propagate the annotations in a way that --- would make sense if they were source position identifiers that tracked the provenance --- of each code snippet. If the specific annotations attached to the AST would not make --- sense after such a transformation, then the client should erase them to @()@ beforehand --- using the `reannotate` transform. --- --- * Global transformations that drastically change the provenance of code snippets should --- accept an AST with an arbitrary annotation type, but produce one with the annotations --- set to @()@. --- -module DDC.Core.Exp.Annot - ( module DDC.Type.Exp +module DDC.Core.Exp.Annot + ( + --------------------------------------- + -- * Abstract Syntax + module DDC.Type.Exp - -- * Expressions + -- ** Expressions , Exp (..) , Lets (..) , Alt (..) , Pat (..) , Cast (..) - -- * Witnesses + -- ** Witnesses , Witness (..) - -- * Data Constructors + -- ** Data Constructors , DaCon (..) - , DaConName (..) - -- * Witness Constructors + -- ** Witness Constructors , WiCon (..) - , WbCon (..)) -where -import DDC.Core.Exp.WiCon -import DDC.Core.Exp.DaCon -import DDC.Core.Exp.Pat -import DDC.Type.Exp -import DDC.Type.Sum () -import Control.DeepSeq - --- Values --------------------------------------------------------------------- --- | Well-typed expressions have types of kind `Data`. -data Exp a n - -- | Value variable or primitive operation. - = XVar !a !(Bound n) - - -- | Data constructor or literal. - | XCon !a !(DaCon n) - - -- | Type abstraction (level-1). - | XLAM !a !(Bind n) !(Exp a n) - - -- | Value and Witness abstraction (level-0). - | XLam !a !(Bind n) !(Exp a n) - - -- | Application. - | XApp !a !(Exp a n) !(Exp a n) - - -- | Possibly recursive bindings. - | XLet !a !(Lets a n) !(Exp a n) - - -- | Case branching. - | XCase !a !(Exp a n) ![Alt a n] - - -- | Type cast. - | XCast !a !(Cast a n) !(Exp a n) - - -- | Type can appear as the argument of an application. - | XType !(Type n) - - -- | Witness can appear as the argument of an application. - | XWitness !(Witness a n) - deriving (Show, Eq) - - --- | Possibly recursive bindings. -data Lets a n - -- | Non-recursive expression binding. - = LLet !(Bind n) !(Exp a n) - - -- | Recursive binding of lambda abstractions. - | LRec ![(Bind n, Exp a n)] - - -- | Bind a local region variable, - -- and witnesses to its properties. - | LLetRegions ![Bind n] ![Bind n] - - -- | Holds a region handle during evaluation. - | LWithRegion !(Bound n) - deriving (Show, Eq) - - --- | Case alternatives. -data Alt a n - = AAlt !(Pat n) !(Exp a n) - deriving (Show, Eq) - + --------------------------------------- + -- * Predicates + , module DDC.Type.Exp.Simple.Predicates --- | Type casts. -data Cast a n - -- | Weaken the effect of an expression. - -- The given effect is added to the effect - -- of the body. - = CastWeakenEffect !(Effect n) - - -- | Weaken the closure of an expression. - -- The closures of these expressions are added to the closure - -- of the body. - | CastWeakenClosure ![Exp a n] + -- ** Atoms + , isXVar, isXCon + , isAtomX, isAtomW - -- | Purify the effect (action) of an expression. - | CastPurify !(Witness a n) + -- ** Lambdas + , isXLAM, isXLam + , isLambdaX - -- | Forget about the closure (sharing) of an expression. - | CastForget !(Witness a n) + -- ** Applications + , isXApp - -- | Suspend a computation, - -- capturing its effects in the S computation type. - | CastSuspend + -- ** Cast + , isXCast + , isXCastBox + , isXCastRun - -- | Run a computation, - -- releasing its effects into the environment. - | CastRun - deriving (Show, Eq) + -- ** Let bindings + , isXLet + -- ** Patterns + , isPDefault --- | When a witness exists in the program it guarantees that a --- certain property of the program is true. -data Witness a n - -- | Witness variable. - = WVar a !(Bound n) - - -- | Witness constructor. - | WCon a !(WiCon n) - - -- | Witness application. - | WApp a !(Witness a n) !(Witness a n) + -- ** Types and Witnesses + , isXType + , isXWitness - -- | Joining of witnesses. - | WJoin a !(Witness a n) !(Witness a n) + --------------------------------------- + -- * Compounds + , module DDC.Type.Exp.Simple.Compounds - -- | Type can appear as the argument of an application. - | WType a !(Type n) - deriving (Show, Eq) + -- ** Annotations + , annotOfExp + , mapAnnotOfExp + -- ** Lambdas + , xLAMs + , xLams + , makeXLamFlags + , takeXLAMs + , takeXLams + , takeXLamFlags --- NFData --------------------------------------------------------------------- -instance (NFData a, NFData n) => NFData (Exp a n) where - rnf xx - = case xx of - XVar a u -> rnf a `seq` rnf u - XCon a dc -> rnf a `seq` rnf dc - XLAM a b x -> rnf a `seq` rnf b `seq` rnf x - XLam a b x -> rnf a `seq` rnf b `seq` rnf x - XApp a x1 x2 -> rnf a `seq` rnf x1 `seq` rnf x2 - XLet a lts x -> rnf a `seq` rnf lts `seq` rnf x - XCase a x alts -> rnf a `seq` rnf x `seq` rnf alts - XCast a c x -> rnf a `seq` rnf c `seq` rnf x - XType t -> rnf t - XWitness w -> rnf w + , Param(..) + , takeXLamParam + -- ** Applications + , xApps + , makeXAppsWithAnnots + , takeXApps + , takeXApps1 + , takeXAppsAsList + , takeXAppsWithAnnots + , takeXConApps + , takeXPrimApps -instance (NFData a, NFData n) => NFData (Cast a n) where - rnf cc - = case cc of - CastWeakenEffect e -> rnf e - CastWeakenClosure xs -> rnf xs - CastPurify w -> rnf w - CastForget w -> rnf w - CastSuspend -> () - CastRun -> () + -- ** Lets + , xLets + , xLetsAnnot + , splitXLets + , splitXLetsAnnot + , bindsOfLets + , specBindsOfLets + , valwitBindsOfLets + -- ** Alternatives + , patOfAlt + , takeCtorNameOfAlt -instance (NFData a, NFData n) => NFData (Lets a n) where - rnf lts - = case lts of - LLet b x -> rnf b `seq` rnf x - LRec bxs -> rnf bxs - LLetRegions bs1 bs2 -> rnf bs1 `seq` rnf bs2 - LWithRegion u -> rnf u + -- ** Patterns + , bindsOfPat + -- ** Casts + , makeRuns -instance (NFData a, NFData n) => NFData (Alt a n) where - rnf aa - = case aa of - AAlt w x -> rnf w `seq` rnf x + -- ** Witnesses + , wApp + , wApps + , annotOfWitness + , takeXWitness + , takeWAppsAsList + , takePrimWiConApps + -- ** Types + , takeXType -instance (NFData a, NFData n) => NFData (Witness a n) where - rnf ww - = case ww of - WVar a u -> rnf a `seq` rnf u - WCon a c -> rnf a `seq` rnf c - WApp a w1 w2 -> rnf a `seq` rnf w1 `seq` rnf w2 - WJoin a w1 w2 -> rnf a `seq` rnf w1 `seq` rnf w2 - WType a tt -> rnf a `seq` rnf tt + -- ** Data Constructors + , xUnit, dcUnit + , takeNameOfDaCon + , takeTypeOfDaCon) +where +import DDC.Core.Exp.Annot.Exp +import DDC.Core.Exp.Annot.Compounds +import DDC.Core.Exp.Annot.Predicates +import DDC.Type.Exp.Simple.Compounds +import DDC.Type.Exp.Simple.Predicates +import DDC.Type.Exp diff --git a/DDC/Core/Exp/Annot/AnT.hs b/DDC/Core/Exp/Annot/AnT.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/Annot/AnT.hs @@ -0,0 +1,35 @@ + +module DDC.Core.Exp.Annot.AnT + (AnT (..)) +where +import DDC.Type.Exp +import DDC.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" + + + diff --git a/DDC/Core/Exp/Annot/AnTEC.hs b/DDC/Core/Exp/Annot/AnTEC.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/Annot/AnTEC.hs @@ -0,0 +1,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" + + + diff --git a/DDC/Core/Exp/Annot/Compounds.hs b/DDC/Core/Exp/Annot/Compounds.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/Annot/Compounds.hs @@ -0,0 +1,414 @@ + +-- | Utilities for constructing and destructing compound expressions. +-- +-- For the annotated version of the AST. +-- +module DDC.Core.Exp.Annot.Compounds + ( module DDC.Type.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 diff --git a/DDC/Core/Exp/Annot/Context.hs b/DDC/Core/Exp/Annot/Context.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/Annot/Context.hs @@ -0,0 +1,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 diff --git a/DDC/Core/Exp/Annot/Ctx.hs b/DDC/Core/Exp/Annot/Ctx.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/Annot/Ctx.hs @@ -0,0 +1,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" + diff --git a/DDC/Core/Exp/Annot/Exp.hs b/DDC/Core/Exp/Annot/Exp.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/Annot/Exp.hs @@ -0,0 +1,198 @@ + +-- | Core language AST that includes an annotation on every node of +-- an expression. +-- +-- This is the default representation for Disciple Core, and should be preferred +-- over the 'Simple' version of the AST in most cases. +-- +-- * Local transformations on this AST should propagate the annotations in a way that +-- would make sense if they were source position identifiers that tracked the provenance +-- of each code snippet. If the specific annotations attached to the AST would not make +-- sense after such a transformation, then the client should erase them to @()@ beforehand +-- using the `reannotate` transform. +-- +-- * Global transformations that drastically change the provenance of code snippets should +-- accept an AST with an arbitrary annotation type, but produce one with the annotations +-- set to @()@. +-- +module DDC.Core.Exp.Annot.Exp + ( module DDC.Type.Exp + + -- * Expressions + , Exp (..) + , Lets (..) + , Alt (..) + , Pat (..) + , Cast (..) + + -- * Witnesses + , Witness (..) + + -- * Data Constructors + , DaCon (..) + + -- * Witness Constructors + , WiCon (..)) +where +import DDC.Core.Exp.WiCon +import DDC.Core.Exp.DaCon +import DDC.Type.Exp +import DDC.Type.Sum () +import Control.DeepSeq + + +-- Values --------------------------------------------------------------------- +-- | Well-typed expressions have types of kind `Data`. +data Exp a n + -- | Value variable or primitive operation. + = XVar !a !(Bound n) + + -- | Data constructor or literal. + | XCon !a !(DaCon n (Type 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 diff --git a/DDC/Core/Exp/Annot/Predicates.hs b/DDC/Core/Exp/Annot/Predicates.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/Annot/Predicates.hs @@ -0,0 +1,162 @@ + +-- | Simple predicates on core expressions. +module DDC.Core.Exp.Annot.Predicates + ( module DDC.Type.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 + diff --git a/DDC/Core/Exp/Annot/Pretty.hs b/DDC/Core/Exp/Annot/Pretty.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/Annot/Pretty.hs @@ -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 + diff --git a/DDC/Core/Exp/DaCon.hs b/DDC/Core/Exp/DaCon.hs --- a/DDC/Core/Exp/DaCon.hs +++ b/DDC/Core/Exp/DaCon.hs @@ -1,101 +1,74 @@ module DDC.Core.Exp.DaCon - ( DaCon (..) - , DaConName (..) + ( DaCon (..) -- * Compounds , dcUnit - , mkDaConAlg - , mkDaConSolid , takeNameOfDaCon - , typeOfDaCon) + , takeTypeOfDaCon) where -import DDC.Type.Compounds -import DDC.Type.Exp +import DDC.Type.Exp.Simple import Control.DeepSeq -------------------------------------------------------------------------------- --- | Data constructor names. -data DaConName n - -- | The unit data constructor is builtin. +-- | Data constructors. +data DaCon n t + -- | Baked in unit data constructor. = DaConUnit - -- | Data constructor name defined by the client. - | DaConNamed n - deriving (Eq, Show) - - -instance NFData n => NFData (DaConName n) where - rnf dcn - = case dcn of - DaConUnit -> () - DaConNamed n -> rnf n - - -------------------------------------------------------------------------------- --- | Data constructors. -data DaCon n - = DaCon + -- | 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 :: !(DaConName n) + daConName :: !n -- | Type of the data constructor. - -- The type must be closed. - , daConType :: !(Type n) + , daConType :: !t + } - -- | Algebraic constructors can be deconstructed with case-expressions, - -- and must have a data type declaration. - -- - -- Non-algebraic types like 'Float' can't be inspected with - -- case-expressions. - , daConIsAlgebraic :: !Bool } + -- | Data constructor that has a data type declaration. + | DaConBound + { -- | Name of the data constructor. + daConName :: !n + } deriving (Show, Eq) -instance NFData n => NFData (DaCon n) where +instance (NFData n, NFData t) => NFData (DaCon n t) where rnf !dc - = rnf (daConName dc) - `seq` rnf (daConType dc) - `seq` rnf (daConIsAlgebraic dc) + = case dc of + DaConUnit -> () + DaConPrim n t -> rnf n `seq` rnf t + DaConBound n -> rnf n --- | Take the name of data constructor. -takeNameOfDaCon :: DaCon n -> Maybe n +-- | Take the name of data constructor, +-- if there is one. +takeNameOfDaCon :: DaCon n t -> Maybe n takeNameOfDaCon dc - = case daConName dc of - DaConUnit -> Nothing - DaConNamed n -> Just n + = case dc of + DaConUnit -> Nothing + DaConPrim{} -> Just $ daConName dc + DaConBound{} -> Just $ daConName dc --- | Take the type annotation of a data constructor. -typeOfDaCon :: DaCon n -> Type n -typeOfDaCon dc = daConType 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 -dcUnit = DaCon - { daConName = DaConUnit - , daConType = tUnit - , daConIsAlgebraic = True } - - --- | Make an algebraic data constructor. -mkDaConAlg :: n -> Type n -> DaCon n -mkDaConAlg n t - = DaCon - { daConName = DaConNamed n - , daConType = t - , daConIsAlgebraic = True } - +dcUnit :: DaCon n t +dcUnit = DaConUnit --- | Make a non-algebraic (solid) constructor. --- These are used for location values in the interpreter, --- and for floating point literals in the main compiler. -mkDaConSolid :: n -> Type n -> DaCon n -mkDaConSolid n t - = DaCon - { daConName = DaConNamed n - , daConType = t - , daConIsAlgebraic = False } diff --git a/DDC/Core/Exp/Generic.hs b/DDC/Core/Exp/Generic.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/Generic.hs @@ -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 + + diff --git a/DDC/Core/Exp/Generic/BindStruct.hs b/DDC/Core/Exp/Generic/BindStruct.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/Generic/BindStruct.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE TypeFamilies #-} + +module DDC.Core.Exp.Generic.BindStruct where +import DDC.Core.Exp.Generic.Exp +import DDC.Core.Exp.DaCon +import DDC.Core.Collect.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 + diff --git a/DDC/Core/Exp/Generic/Compounds.hs b/DDC/Core/Exp/Generic/Compounds.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/Generic/Compounds.hs @@ -0,0 +1,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 + diff --git a/DDC/Core/Exp/Generic/Exp.hs b/DDC/Core/Exp/Generic/Exp.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/Generic/Exp.hs @@ -0,0 +1,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) + diff --git a/DDC/Core/Exp/Generic/Predicates.hs b/DDC/Core/Exp/Generic/Predicates.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/Generic/Predicates.hs @@ -0,0 +1,122 @@ + +-- | Simple predicates on core expressions. +module DDC.Core.Exp.Generic.Predicates + ( module DDC.Type.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 + diff --git a/DDC/Core/Exp/Generic/Pretty.hs b/DDC/Core/Exp/Generic/Pretty.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/Generic/Pretty.hs @@ -0,0 +1,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 + + diff --git a/DDC/Core/Exp/Literal.hs b/DDC/Core/Exp/Literal.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/Literal.hs @@ -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) diff --git a/DDC/Core/Exp/Pat.hs b/DDC/Core/Exp/Pat.hs deleted file mode 100644 --- a/DDC/Core/Exp/Pat.hs +++ /dev/null @@ -1,26 +0,0 @@ - -module DDC.Core.Exp.Pat - ( Pat (..)) -where -import DDC.Core.Exp.DaCon -import DDC.Type.Exp -import Control.DeepSeq - - --- | Pattern matching. -data Pat n - -- | The default pattern always succeeds. - = PDefault - - -- | Match a data constructor and bind its arguments. - | PData !(DaCon n) ![Bind n] - deriving (Show, Eq) - - -instance NFData n => NFData (Pat n) where - rnf pp - = case pp of - PDefault -> () - PData dc bs -> rnf dc `seq` rnf bs - - diff --git a/DDC/Core/Exp/Simple.hs b/DDC/Core/Exp/Simple.hs deleted file mode 100644 --- a/DDC/Core/Exp/Simple.hs +++ /dev/null @@ -1,202 +0,0 @@ - --- | Core language AST with a separate node to hold annotations. --- --- This version of the AST is used when generating code where most or all --- of the annotations would be empty. General purpose transformations should --- deal with the fully annotated version of the AST instead. --- -module DDC.Core.Exp.Simple - ( module DDC.Type.Exp - - -- * Expressions - , Exp (..) - , Cast (..) - , Lets (..) - , Alt (..) - , Pat (..) - - -- * Witnesses - , Witness (..) - - -- * Data Constructors - , DaCon (..) - , DaConName (..) - - -- * Witness Constructors - , WiCon (..) - , WbCon (..)) -where -import DDC.Core.Exp.WiCon -import DDC.Core.Exp.DaCon -import DDC.Core.Exp.Pat -import DDC.Type.Exp -import DDC.Type.Sum () -import Control.DeepSeq - - --- Values --------------------------------------------------------------------- --- | Well-typed expressions have types of kind `Data`. -data Exp a n - -- | Annotation. - = XAnnot a (Exp a n) - - -- | Value variable or primitive operation. - | XVar !(Bound n) - - -- | Data constructor or literal. - | XCon !(DaCon n) - - -- | Type abstraction (level-1). - | XLAM !(Bind n) !(Exp a n) - - -- | Value and Witness abstraction (level-0). - | XLam !(Bind n) !(Exp a n) - - -- | Application. - | XApp !(Exp a n) !(Exp a n) - - -- | Possibly recursive bindings. - | XLet !(Lets a n) !(Exp a n) - - -- | Case branching. - | XCase !(Exp a n) ![Alt a n] - - -- | Type cast. - | XCast !(Cast a n) !(Exp a n) - - -- | Type can appear as the argument of an application. - | XType !(Type n) - - -- | Witness can appear as the argument of an application. - | XWitness !(Witness a n) - deriving (Show, Eq) - - --- | Possibly recursive bindings. -data Lets a n - -- | Non-recursive expression binding. - = LLet !(Bind n) !(Exp a n) - - -- | Recursive binding of lambda abstractions. - | LRec ![(Bind n, Exp a n)] - - -- | Bind a local region variable, - -- and witnesses to its properties. - | LLetRegions ![Bind n] ![Bind n] - - -- | Holds a region handle during evaluation. - | LWithRegion !(Bound n) - deriving (Show, Eq) - - --- | Case alternatives. -data Alt a n - = AAlt !(Pat n) !(Exp a n) - deriving (Show, Eq) - - --- | When a witness exists in the program it guarantees that a --- certain property of the program is true. -data Witness a n - = WAnnot a (Witness a n) - - -- | Witness variable. - | WVar !(Bound n) - - -- | Witness constructor. - | WCon !(WiCon n) - - -- | Witness application. - | WApp !(Witness a n) !(Witness a n) - - -- | Joining of witnesses. - | WJoin !(Witness a n) !(Witness a n) - - -- | Type can appear as the argument of an application. - | WType !(Type n) - deriving (Show, Eq) - - --- | Type casts. -data Cast a n - -- | Weaken the effect of an expression. - -- The given effect is added to the effect - -- of the body. - = CastWeakenEffect !(Effect n) - - -- | Weaken the closure of an expression. - -- The closures of these expressions are added to the closure - -- of the body. - | CastWeakenClosure ![Exp a n] - - -- | Purify the effect (action) of an expression. - | CastPurify !(Witness a n) - - -- | Forget about the closure (sharing) of an expression. - | CastForget !(Witness a n) - - -- | Suspend a computation, - -- capturing its effects in the S computation type. - | CastSuspend - - -- | Run a computation, - -- releasing its effects into the environment. - | CastRun - deriving (Show, Eq) - - - - --- NFData --------------------------------------------------------------------- -instance (NFData a, NFData n) => NFData (Exp a n) where - rnf xx - = case xx of - XAnnot a x -> rnf a `seq` rnf x - XVar u -> rnf u - XCon dc -> rnf dc - XLAM b x -> rnf b `seq` rnf x - XLam b x -> rnf b `seq` rnf x - XApp x1 x2 -> rnf x1 `seq` rnf x2 - XLet lts x -> rnf lts `seq` rnf x - XCase x alts -> rnf x `seq` rnf alts - XCast c x -> rnf c `seq` rnf x - XType t -> rnf t - XWitness w -> rnf w - - -instance (NFData a, NFData n) => NFData (Cast a n) where - rnf cc - = case cc of - CastWeakenEffect e -> rnf e - CastWeakenClosure xs -> rnf xs - CastPurify w -> rnf w - CastForget w -> rnf w - CastSuspend -> () - 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 - LLetRegions bs1 bs2 -> rnf bs1 `seq` rnf bs2 - LWithRegion u -> rnf u - - -instance (NFData a, NFData n) => NFData (Alt a n) where - rnf aa - = case aa of - AAlt w x -> rnf w `seq` rnf x - - -instance (NFData a, NFData n) => NFData (Witness a n) where - rnf ww - = case ww of - WAnnot a w -> rnf a `seq` rnf w - WVar u -> rnf u - WCon c -> rnf c - WApp w1 w2 -> rnf w1 `seq` rnf w2 - WJoin w1 w2 -> rnf w1 `seq` rnf w2 - WType t -> rnf t - diff --git a/DDC/Core/Exp/WiCon.hs b/DDC/Core/Exp/WiCon.hs --- a/DDC/Core/Exp/WiCon.hs +++ b/DDC/Core/Exp/WiCon.hs @@ -1,7 +1,6 @@ module DDC.Core.Exp.WiCon - ( WiCon (..) - , WbCon (..)) + ( WiCon (..)) where import DDC.Type.Exp import DDC.Type.Sum () @@ -10,58 +9,10 @@ -- | Witness constructors. data WiCon n - -- | Witness constructors baked into the language. - = WiConBuiltin !WbCon - -- | Witness constructors defined in the environment. -- In the interpreter we use this to hold runtime capabilities. -- The attached type must be closed. - | WiConBound !(Bound n) !(Type n) - deriving (Show, Eq) - - --- | Built-in witness constructors. --- --- These are used to convert a runtime capability into a witness that --- the corresponding property is true. -data WbCon - -- | (axiom) The pure effect is pure. - -- - -- @pure :: Pure !0@ - = WbConPure - - -- | (axiom) The empty closure is empty. - -- - -- @empty :: Empty $0@ - | WbConEmpty - - -- | Convert a capability guaranteeing that a region is in the global - -- heap, into a witness that a closure using this region is empty. - -- This lets us rely on the garbage collector to reclaim objects - -- in the region. It is needed when we suspend the evaluation of - -- expressions that have a region in their closure, because the - -- type of the returned thunk may not reveal that it references - -- objects in that region. - -- - -- @use :: [r : %]. Global r => Empty (Use r)@ - | WbConUse - - -- | Convert a capability guaranteeing the constancy of a region, into - -- a witness that a read from that region is pure. - -- This lets us suspend applications that read constant objects, - -- because it doesn't matter if the read is delayed, we'll always - -- get the same result. - -- - -- @read :: [r : %]. Const r => Pure (Read r)@ - | WbConRead - - -- | Convert a capability guaranteeing the constancy of a region, into - -- a witness that allocation into that region is pure. - -- This lets us increase the sharing of constant objects, - -- because we can't tell constant objects of the same value apart. - -- - -- @alloc :: [r : %]. Const r => Pure (Alloc r)@ - | WbConAlloc + = WiConBound !(Bound n) !(Type n) deriving (Show, Eq) @@ -69,7 +20,8 @@ instance NFData n => NFData (WiCon n) where rnf wi = case wi of - WiConBuiltin wb -> rnf wb WiConBound u t -> rnf u `seq` rnf t -instance NFData WbCon + + + diff --git a/DDC/Core/Fragment.hs b/DDC/Core/Fragment.hs --- a/DDC/Core/Fragment.hs +++ b/DDC/Core/Fragment.hs @@ -2,17 +2,21 @@ -- | The ambient Disciple Core language is specialised to concrete languages -- by adding primitive operations and optionally restricting the set of -- available language features. This specialisation results in user-facing --- language fragments such as @Disciple Core Lite@ and @Disciple Core Salt@. +-- language fragments such as @Disciple Core Tetra@ and @Disciple Core Salt@. module DDC.Core.Fragment ( -- * Langauge fragments Fragment (..) + , mapProfileOfFragment + , Profile (..) + , mapFeaturesOfProfile , zeroProfile -- * Fragment features , Feature (..) , Features (..) , zeroFeatures + , setFeature -- * Compliance , complies @@ -27,7 +31,6 @@ import DDC.Core.Module import DDC.Core.Exp import DDC.Core.Lexer -import DDC.Data.Token -- | Carries all the information we need to work on a particular @@ -45,11 +48,11 @@ -- | Lex module source into tokens, -- given the source name and starting line number. - , fragmentLexModule :: String -> Int -> String -> [Token (Tok n)] + , fragmentLexModule :: String -> Int -> String -> [Located (Token n)] -- | Lex expression source into tokens, -- given the source name and starting line number. - , fragmentLexExp :: String -> Int -> String -> [Token (Tok n)] + , fragmentLexExp :: String -> Int -> String -> [Located (Token n)] -- | Perform language fragment specific checks on a module. , fragmentCheckModule :: forall a. Module a n -> Maybe (err a) @@ -62,3 +65,12 @@ show frag = profileName $ fragmentProfile frag + +-- | Apply a function to the profile in a fragment. +mapProfileOfFragment + :: (Profile n -> Profile n) + -> Fragment n err -> Fragment n err + +mapProfileOfFragment f fragment + = fragment + { fragmentProfile = f (fragmentProfile fragment) } diff --git a/DDC/Core/Fragment/Compliance.hs b/DDC/Core/Fragment/Compliance.hs --- a/DDC/Core/Fragment/Compliance.hs +++ b/DDC/Core/Fragment/Compliance.hs @@ -1,23 +1,20 @@ module DDC.Core.Fragment.Compliance ( complies - , compliesWithEnvs + , compliesWithEnvs , Complies) where import DDC.Core.Fragment.Feature import DDC.Core.Fragment.Profile import DDC.Core.Fragment.Error -import DDC.Core.Compounds -import DDC.Core.Predicates import DDC.Core.Module -import DDC.Core.Exp +import DDC.Core.Exp.Annot import Control.Monad import Data.Maybe import DDC.Type.Env (Env) import Data.Set (Set) import qualified DDC.Type.Env as Env import qualified Data.Set as Set -import qualified Data.Map.Strict as Map -- | Check whether a core thing complies with a language fragment profile. @@ -40,10 +37,10 @@ :: (Ord n, Show n, Complies c) => Profile n -- ^ Fragment profile giving the supported -- language features and primitive operators. - -> Env.KindEnv n -- ^ Starting kind environment. - -> Env.TypeEnv n -- ^ Starting type environment. - -> c a n -- ^ The thing to check. - -> Maybe (Error a n) + -> Env.KindEnv n -- ^ Starting kind environment. + -> Env.TypeEnv n -- ^ Starting type environment. + -> c a n -- ^ The thing to check. + -> Maybe (Error a n) compliesWithEnvs profile kenv tenv thing = let merr = result @@ -75,8 +72,8 @@ instance Complies Module where compliesX profile kenv tenv context mm - = do let bs = [ BName n t - | (n, (_, t)) <- Map.toList $ moduleImportTypes 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) @@ -97,7 +94,7 @@ | args <- fromMaybe 0 $ contextFunArgs context , Just t <- Env.lookup u tenv , arity <- arityOfType t - , args < arity + , args >= 1 && args < arity , not $ has featuresPartialApplication -> throw $ ErrorUnsupported PartialApplication @@ -165,7 +162,7 @@ return (tUsed, vUsed') -- application -------------------------- - XApp _ x1 (XType t2) + XApp _ x1 (XType _ t2) | profileTypeIsUnboxed profile t2 , Nothing <- takeXPrimApps xx -> throw $ ErrorUnsupported UnboxedInstantiation @@ -211,19 +208,13 @@ vUseds' <- checkBinds profile tenv bs vUseds return (tUseds, vUseds') - - XLet _ (LLetRegions rs bs) x2 + XLet _ (LPrivate rs _ bs) x2 -> do (tUsed2, vUsed2) <- compliesX profile (Env.extends rs kenv) (Env.extends bs tenv) (reset context) x2 return (tUsed2, vUsed2) - XLet _ (LWithRegion _) x2 - -> do (tUsed2, vUsed2) <- compliesX profile kenv tenv - (reset context) x2 - return (tUsed2, vUsed2) - -- case --------------------------------- XCase _ x1 alts -> do (tUsed1, vUsed1) @@ -240,8 +231,8 @@ XCast _ _ x -> compliesX profile kenv tenv (reset context) x -- type and witness --------------------- - XType t -> throw $ ErrorNakedType t - XWitness w -> throw $ ErrorNakedWitness w + XType _ t -> throw $ ErrorNakedType t + XWitness _ w -> throw $ ErrorNakedWitness w instance Complies Alt where @@ -361,6 +352,16 @@ -- | 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) diff --git a/DDC/Core/Fragment/Feature.hs b/DDC/Core/Fragment/Feature.hs --- a/DDC/Core/Fragment/Feature.hs +++ b/DDC/Core/Fragment/Feature.hs @@ -19,6 +19,15 @@ -- | 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 @@ -35,6 +44,10 @@ -- The output of the lambda-lifter should not contain these. | NestedFunctions + -- | Recursive let-expressions where the right hand sides + -- are not lambda abstractions. + | GeneralLetRec + -- | Debruijn binders. -- Most backends will want to use real names, instead of indexed -- binders. @@ -60,3 +73,4 @@ -- | Allow unused named matches. | UnusedMatches deriving (Eq, Ord, Show) + diff --git a/DDC/Core/Fragment/Profile.hs b/DDC/Core/Fragment/Profile.hs --- a/DDC/Core/Fragment/Profile.hs +++ b/DDC/Core/Fragment/Profile.hs @@ -2,16 +2,19 @@ -- | A fragment profile determines what features a program can use. module DDC.Core.Fragment.Profile ( Profile (..) + , mapFeaturesOfProfile , zeroProfile , Features(..) , zeroFeatures , setFeature) where +import DDC.Core.Exp.Literal import DDC.Core.Fragment.Feature import DDC.Type.DataDef import DDC.Type.Exp -import DDC.Type.Env (SuperEnv, KindEnv, TypeEnv) +import DDC.Type.Env (KindEnv, TypeEnv) +import DDC.Data.SourcePos import qualified DDC.Type.Env as Env @@ -28,9 +31,6 @@ -- | Primitive data type declarations. , profilePrimDataDefs :: !(DataDefs n) - -- | Supers of primitive kinds. - , profilePrimSupers :: !(SuperEnv n) - -- | Kinds of primitive types. , profilePrimKinds :: !(KindEnv n) @@ -39,9 +39,27 @@ -- | Check whether a type is an unboxed type. -- Some fragments limit how these can be used. - , profileTypeIsUnboxed :: !(Type n -> Bool) } + , 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. @@ -51,10 +69,11 @@ { profileName = "Zero" , profileFeatures = zeroFeatures , profilePrimDataDefs = emptyDataDefs - , profilePrimSupers = Env.empty , profilePrimKinds = Env.empty , profilePrimTypes = Env.empty - , profileTypeIsUnboxed = const False } + , profileTypeIsUnboxed = const False + , profileNameIsHole = Nothing + , profileMakeLiteralName = Nothing } -- | A flattened set of features, for easy lookup. @@ -64,10 +83,14 @@ , 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 @@ -85,10 +108,14 @@ , 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 @@ -105,10 +132,14 @@ 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 } diff --git a/DDC/Core/Lexer.hs b/DDC/Core/Lexer.hs --- a/DDC/Core/Lexer.hs +++ b/DDC/Core/Lexer.hs @@ -8,23 +8,30 @@ -- module DDC.Core.Lexer ( module DDC.Core.Lexer.Tokens - , module DDC.Core.Lexer.Names + , Located (..) -- * Lexer , lexModuleWithOffside , lexExp) where +import DDC.Core.Lexer.Token.Builtin +import DDC.Core.Lexer.Token.Index +import DDC.Core.Lexer.Token.Keyword +import DDC.Core.Lexer.Token.Literal +import DDC.Core.Lexer.Token.Names +import DDC.Core.Lexer.Token.Operator +import DDC.Core.Lexer.Token.Symbol + import DDC.Core.Lexer.Offside -import DDC.Core.Lexer.Comments -import DDC.Core.Lexer.Names import DDC.Core.Lexer.Tokens import DDC.Data.SourcePos -import DDC.Data.Token -import Data.Char -import Data.List +import Data.Text (Text) +import qualified System.IO.Unsafe as System +import qualified Text.Lexer.Inchworm.Char as I +import qualified Data.Text as Text --- Module --------------------------------------------------------------------- +-- Module ----------------------------------------------------------------------------------------- -- | Lex a module and apply the offside rule. -- -- Automatically drop comments from the token stream along the way. @@ -33,17 +40,23 @@ :: FilePath -- ^ Path to source file, for error messages. -> Int -- ^ Starting line number. -> String -- ^ String containing program text. - -> [Token (Tok String)] + -> [Located (Token String)] lexModuleWithOffside sourceName lineStart str - = {-# SCC lexWithOffside #-} - applyOffside [] + = applyOffside [] [] $ addStarts - $ dropComments - $ lexString sourceName lineStart str + $ dropUnused + $ lexText sourceName lineStart + $ Text.pack str + where dropUnused ts + = case ts of + [] -> [] + Located _ (KM KComment{}) : ts' -> dropUnused ts' + t : ts' -> t : dropUnused ts' --- Exp ------------------------------------------------------------------------ + +-- Exp -------------------------------------------------------------------------------------------- -- | Lex a string into tokens. -- -- Automatically drop comments from the token stream along the way. @@ -51,172 +64,129 @@ lexExp :: FilePath -- ^ Path to source file, for error messages. -> Int -- ^ Starting line number. -> String -- ^ String containing program text. - -> [Token (Tok String)] + -> [Located (Token String)] lexExp sourceName lineStart str - = {-# SCC lexExp #-} - dropNewLines - $ dropComments - $ lexString sourceName lineStart str + = dropUnused + $ lexText sourceName lineStart + $ Text.pack str + where dropUnused ts + = case ts of + [] -> [] + Located _ (KM KComment{}) : ts' -> dropUnused ts' + Located _ (KM KNewLine{}) : ts' -> dropUnused ts' + t : ts' -> t : dropUnused ts' --- Generic -------------------------------------------------------------------- -lexString :: String -> Int -> String -> [Token (Tok String)] -lexString sourceName lineStart str - = lexWord lineStart 1 str - where - lexWord :: Int -> Int -> String -> [Token (Tok String)] - lexWord line column w - = let tok t = Token t (SourcePos sourceName line column) - tokM = tok . KM - tokA = tok . KA - tokN = tok . KN - lexMore n rest - = lexWord line (column + n) rest +-- 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)] - in case w of - [] -> [] +lexText filePath nStart txt + = let (toks, locEnd, strLeftover) + = System.unsafePerformIO + $ I.scanListIO + (I.Location nStart 1) + I.bumpLocationWithChar + (Text.unpack txt) + (scanner filePath) - -- Whitespace - ' ' : w' -> lexMore 1 w' - '\t' : w' -> lexMore 8 w' + I.Location lineEnd colEnd = locEnd + spEnd = SourcePos filePath lineEnd colEnd - -- Literal values - -- This needs to come before the rule for '-' - c : cs - | isDigit c - , (body, rest) <- span isLitBody cs - -> tokN (KLit (c:body)) : lexMore (length (c:body)) rest + in case strLeftover of + [] -> toks + str -> toks ++ [Located spEnd (KErrorJunk (take 10 str))] - '-' : c : cs - | isDigit c - , (body, rest) <- span isLitBody cs - -> tokN (KLit ('-':c:body)) : lexMore (length (c:body)) rest - -- Meta tokens - -- ISSUE #302: Don't try to lex body of a block comment. - '{' : '-' : w' - -> tokM KCommentBlockStart : lexMore 2 w' +-- | Scanner for core tokens tokens. +type Scanner a + = I.Scanner IO I.Location [Char] a - '-' : '}' : w' - -> tokM KCommentBlockEnd : lexMore 2 w' - '-' : '-' : w' - -> let (_junk, w'') = span (/= '\n') w' - in tokM KCommentLineStart : lexMore 2 w'' - - '\n' : w' -> tokM KNewLine : lexWord (line + 1) 1 w' - - -- The unit data constructor - '(' : ')' : w' -> tokA KDaConUnit : lexMore 2 w' - - -- Compound Parens - '[' : ':' : w' -> tokA KSquareColonBra : lexMore 2 w' - ':' : ']' : w' -> tokA KSquareColonKet : lexMore 2 w' - '<' : ':' : w' -> tokA 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 KArrowDashLeft : lexMore 2 w' - '=' : '>' : w' -> tokA KArrowEquals : lexMore 2 w' - - -- Compound symbols - ':' : ':' : w' -> tokA KColonColon : lexMore 2 w' - '/' : '\\' : w' -> tokA KBigLambda : lexMore 2 w' +------------------------------------------------------------------------------- +-- | 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)) - -- Debruijn indices - '^' : cs - | (ds, rest) <- span isDigit cs - , length ds >= 1 - -> tokA (KIndex (read ds)) : lexMore (1 + length ds) rest +scanner fileName + = let + stamp :: (I.Location, a) -> Located a + stamp (I.Location line col, token) + = Located (SourcePos fileName line col) token + {-# INLINE stamp #-} - -- 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' + stamp' :: (a -> b) + -> (I.Location, a) -> Located b + stamp' k (I.Location line col, token) + = Located (SourcePos fileName line col) (k token) + {-# INLINE stamp' #-} - -- 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 - name - | Just w' <- stripPrefix "Pure" name - -> tokA KBotEffect : lexMore 2 w' - - | Just w' <- stripPrefix "Empty" name - -> tokA KBotClosure : lexMore 2 w' + in I.skip (\c -> c == ' ' || c == '\t') + $ I.alts + [ -- Newlines are scanned to their own tokens because + -- the transform that manages the offside rule uses them. + fmap stamp + $ I.from (\c -> case c of + '\n' -> return $ KM KNewLine + _ -> Nothing) - -- Named Constructors - c : cs - | isConStart c - , (body, rest) <- span isConBody cs - , (body', rest') <- case rest of - '\'' : rest' -> (body ++ "'", rest') - '#' : rest' -> (body ++ "#", rest') - _ -> (body, rest) - -> let readNamedCon s - | Just socon <- readSoConBuiltin s - = tokA (KSoConBuiltin socon) : lexMore (length s) rest' + -- Scan comments into their own tokens, + -- these then get dropped by the dropComments function. + , fmap (stamp' (KM . KComment)) $ I.scanHaskellCommentLine + , fmap (stamp' (KM . KComment)) $ I.scanHaskellCommentBlock - | Just kicon <- readKiConBuiltin s - = tokA (KKiConBuiltin kicon) : lexMore (length s) rest' + -- deBruijn indices. + -- Needs to come before scanSymbol as '^' is also an operator. + , fmap (stamp' (KA . KIndex)) $ scanIndex - | Just twcon <- readTwConBuiltin s - = tokA (KTwConBuiltin twcon) : lexMore (length s) rest' - - | Just tccon <- readTcConBuiltin s - = tokA (KTcConBuiltin tccon) : lexMore (length s) rest' - - | Just con <- readCon s - = tokN (KCon con) : lexMore (length s) rest' - - | otherwise - = [tok (KJunk [c])] - - in readNamedCon (c : body') + -- Literal values. + , fmap (stamp' (\(l, b) -> KA (KLiteral l b))) + $ scanLiteral - -- Keywords, Named Variables and Witness constructors - c : cs - | isVarStart c - , (body, rest) <- span isVarBody cs - , (body', rest') <- case rest of - '#' : rest' -> (body ++ "#", rest') - _ -> (body, rest) - -> let readNamedVar s - | Just t <- lookup s keywords - = tok t : lexMore (length s) rest' + -- Infix operators. + -- Needs to come before scanSymbol because operators + -- like "==" are parsed atomically rather than as + -- two separate '=' symbols. + , fmap (stamp' (KA . KOp)) $ scanInfixOperator - | Just wc <- readWbConBuiltin s - = tokA (KWbConBuiltin wc) : lexMore (length s) rest' - - | Just v <- readVar s - = tokN (KVar v) : lexMore (length s) rest' + -- Prefix operators. + , fmap (stamp' (KA . KOpVar)) $ scanPrefixOperator - | otherwise - = [tok (KJunk [c])] + -- The unit value. + -- Needs to come before scanSymbol because the "()" + -- lexeme is parsed atomically rather than as + -- separate '(' and ')' symbols. + , fmap stamp + $ I.froms (Just 2) + (\ss -> if ss == "()" + then Just (KA $ KBuiltin $ BDaConUnit) + else Nothing) - in readNamedVar (c : body') + -- Symbolic tokens like punctuation. + , fmap (stamp' (KA . KSymbol)) $ scanSymbol - -- Some unrecognised character. - -- We still need to keep lexing as this may be in a comment. - c : cs -> (tok $ KJunk [c]) : lexMore 1 cs + -- Named things. + -- Keywords have the same lexical structure as variables as + -- they all start with a lower-case letter. We need to check + -- for keywords before accepting a variable. + , fmap (stamp' (KA . KBuiltin)) $ scanBuiltin + , fmap (stamp' (KA . KKeyword)) $ scanKeyword + , fmap (stamp' (KN . KCon)) $ scanConName + , fmap (stamp' (KN . KVar)) $ scanVarName + ] diff --git a/DDC/Core/Lexer/Comments.hs b/DDC/Core/Lexer/Comments.hs deleted file mode 100644 --- a/DDC/Core/Lexer/Comments.hs +++ /dev/null @@ -1,64 +0,0 @@ - -module DDC.Core.Lexer.Comments - ( dropComments - , dropNewLines) -where -import DDC.Core.Lexer.Tokens -import DDC.Data.Token -import DDC.Data.SourcePos - - --- | Drop all the comments and newline tokens in this stream. -dropComments - :: Eq n => [Token (Tok n)] -> [Token (Tok n)] - -dropComments [] = [] -dropComments (t@(Token tok sourcePos) : xs) - = case tok of - KM KCommentLineStart - -> dropComments $ dropWhile (\t' -> not $ isToken t' (KM KNewLine)) xs - - KM KCommentBlockStart - -> dropComments $ dropCommentBlock sourcePos xs t - - _ -> t : dropComments xs - - --- | Drop block comments form a token stream. -dropCommentBlock - :: Eq n - => SourcePos -- ^ Position of outer-most block comment start. - -> [Token (Tok n)] - -> Token (Tok n) - -> [Token (Tok n)] - -dropCommentBlock spStart [] _terr - = [Token (KM KCommentUnterminated) spStart] - -dropCommentBlock spStart (t@(Token tok _) : xs) terr - = case tok of - -- enter into nested block comments. - KM KCommentBlockStart - -> dropCommentBlock spStart (dropCommentBlock spStart xs t) terr - - -- outer-most block comment has ended. - KM KCommentBlockEnd - -> xs - - _ -> dropCommentBlock spStart xs terr - - --- | Drop newline tokens from this list. -dropNewLines :: Eq n => [Token (Tok n)] -> [Token (Tok n)] -dropNewLines [] = [] -dropNewLines (t:ts) - | isToken t (KM KNewLine) - = dropNewLines ts - - | otherwise - = t : dropNewLines ts - - -isToken :: Eq n => Token (Tok n) -> Tok n -> Bool -isToken (Token tok _) tok2 = tok == tok2 - diff --git a/DDC/Core/Lexer/Names.hs b/DDC/Core/Lexer/Names.hs deleted file mode 100644 --- a/DDC/Core/Lexer/Names.hs +++ /dev/null @@ -1,261 +0,0 @@ - -module DDC.Core.Lexer.Names - ( -- * Keywords - keywords - - -- * Builtin constructors - , readSoConBuiltin - , readKiConBuiltin - , readTwConBuiltin - , readTcConBuiltin - , readWbConBuiltin - - -- * Variable names - , isVarName - , isVarStart - , isVarBody - , readVar - - -- * Constructor names - , isConName - , isConStart - , isConBody - , readCon - - -- * Literal names - , isLitName - , isLitStart - , isLitBody) -where -import DDC.Core.Exp -import DDC.Core.Lexer.Tokens -import DDC.Data.ListUtils -import Data.Char -import Data.List - - --- | Textual keywords in the core language. -keywords :: [(String, Tok n)] -keywords - = [ ("module", KA KModule) - , ("imports", KA KImports) - , ("exports", KA KExports) - , ("in", KA KIn) - , ("of", KA KOf) - , ("letrec", KA KLetRec) - , ("letregions", KA KLetRegions) - , ("letregion", KA KLetRegion) - , ("withregion", KA KWithRegion) - , ("let", KA KLet) - , ("lazy", KA KLazy) - , ("case", KA KCase) - , ("purify", KA KPurify) - , ("forget", KA KForget) - , ("suspend", KA KSuspend) - , ("run", KA KRun) - , ("type", KA KType) - , ("weakeff", KA KWeakEff) - , ("weakclo", KA KWeakClo) - , ("with", KA KWith) - , ("where", KA KWhere) - , ("do", KA KDo) - , ("match", KA KMatch) - , ("else", KA KElse) ] - - --- | Read a named sort constructor. -readSoConBuiltin :: String -> Maybe SoCon -readSoConBuiltin ss - = case ss of - "Prop" -> Just SoConProp - "Comp" -> Just SoConComp - _ -> Nothing - - --- | Read a named kind constructor. -readKiConBuiltin :: String -> Maybe KiCon -readKiConBuiltin ss - = case ss of - "Witness" -> Just KiConWitness - "Data" -> Just KiConData - "Region" -> Just KiConRegion - "Effect" -> Just KiConEffect - "Closure" -> Just KiConClosure - _ -> Nothing - - --- | Read a named witness type constructor. -readTwConBuiltin :: String -> Maybe TwCon -readTwConBuiltin ss - = case ss of - "Global" -> Just TwConGlobal - "DeepGlobal" -> Just TwConDeepGlobal - "Const" -> Just TwConConst - "DeepConst" -> Just TwConDeepConst - "Mutable" -> Just TwConMutable - "DeepMutable" -> Just TwConDeepMutable - "Lazy" -> Just TwConLazy - "HeadLazy" -> Just TwConHeadLazy - "Manifest" -> Just TwConManifest - "Purify" -> Just TwConPure - "Emptify" -> Just TwConEmpty - "Disjoint" -> Just TwConDisjoint - "Distinct" -> Just (TwConDistinct 2) - _ -> readTwConWithArity ss - - -readTwConWithArity :: String -> Maybe TwCon -readTwConWithArity ss - | Just n <- stripPrefix "Distinct" ss - , all isDigit n - = Just (TwConDistinct $ read n) - | otherwise = Nothing - - --- | Read a builtin type constructor with a non-symbolic name. --- ie not '->'. -readTcConBuiltin :: String -> Maybe TcCon -readTcConBuiltin ss - = case ss of - "Unit" -> Just TcConUnit - "S" -> Just TcConSusp - "Read" -> Just TcConRead - "HeadRead" -> Just TcConHeadRead - "DeepRead" -> Just TcConDeepRead - "Write" -> Just TcConWrite - "DeepWrite" -> Just TcConDeepWrite - "Alloc" -> Just TcConAlloc - "DeepAlloc" -> Just TcConDeepAlloc - "Use" -> Just TcConUse - "DeepUse" -> Just TcConDeepUse - _ -> Nothing - - --- | Read a witness constructor. -readWbConBuiltin :: String -> Maybe WbCon -readWbConBuiltin ss - = case ss of - "pure" -> Just WbConPure - "empty" -> Just WbConEmpty - "use" -> Just WbConUse - "read" -> Just WbConRead - "alloc" -> Just WbConAlloc - _ -> Nothing - - --- Variable names ------------------------------------------------------------- --- | String is a variable name -isVarName :: String -> Bool -isVarName str - = case str of - [] -> False - c : cs - | isVarStart c - , and (map isVarBody cs) - -> True - - | _ : _ <- cs - , Just initCs <- takeInit cs - , isVarStart c - , and (map isVarBody initCs) - , last cs == '#' - -> True - - | otherwise - -> False - - --- | Charater can start a variable name. -isVarStart :: Char -> Bool -isVarStart = isLower - - --- | Character can be part of a variable body. -isVarBody :: Char -> Bool -isVarBody c - = isUpper c - || isLower c - || isDigit c - || c == '_' - || c == '\'' - || c == '$' - - --- | Read a named, user defined variable. -readVar :: String -> Maybe String -readVar ss - | isVarName ss = Just ss - | otherwise = Nothing - - --- Constructor names ---------------------------------------------------------- --- | String is a constructor name. -isConName :: String -> Bool -isConName str - = case str of - [] -> False - c : cs - | isConStart c - , and (map isConBody cs) - -> True - - | _ : _ <- cs - , Just initCs <- takeInit cs - , isConStart c - , and (map isConBody initCs) - , last cs == '#' - -> True - - | otherwise - -> False - --- | Character can start a constructor name. -isConStart :: Char -> Bool -isConStart = isUpper - - --- | Charater can be part of a constructor body. -isConBody :: Char -> Bool -isConBody c - = isUpper c - || isLower c - || isDigit c - || c == '_' - - --- | Read a named, user defined `TcCon`. -readCon :: String -> Maybe String -readCon ss - | isConName ss = Just ss - | otherwise = Nothing - - --- Literal names -------------------------------------------------------------- --- | String is the name of a literal. -isLitName :: String -> Bool -isLitName str - = case str of - [] -> False - c : cs - | isLitStart c - , and (map isLitBody cs) - -> True - - | otherwise - -> False - --- | Character can start a literal. -isLitStart :: Char -> Bool -isLitStart c - = isDigit c - || c == '-' - --- | Character can be part of a literal body. -isLitBody :: Char -> Bool -isLitBody c - = isDigit c - || c == 'b' || c == 'o' || c == 'x' - || c == 'w' || c == 'i' - || c == '#' - || c == '\'' - diff --git a/DDC/Core/Lexer/Offside.hs b/DDC/Core/Lexer/Offside.hs --- a/DDC/Core/Lexer/Offside.hs +++ b/DDC/Core/Lexer/Offside.hs @@ -7,130 +7,214 @@ where import DDC.Core.Lexer.Tokens import DDC.Data.SourcePos -import DDC.Data.Token +--------------------------------------------------------------------------------------------------- -- | Holds a real token or start symbol which is used to apply the offside rule. data Lexeme n - = LexemeToken (Token (Tok n)) + = LexemeToken (Located (Token n)) | LexemeStartLine Int -- | Signal that we're starting a block in this column. | 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. -- +-- 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) - => [Context] - -> [Lexeme n] - -> [Token (Tok n)] + :: (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 [] (LexemeToken t : ts) - | isToken t (KA KModule) +applyOffside ps [] (LexemeToken t : ts) + | isKeyword t EModule || isKNToken t - = t : applyOffside [] ts + = t : applyOffside ps [] ts --- When we see the top-level letrec then enter into the outer-most context. -applyOffside [] (LexemeToken t1 : (LexemeStartBlock n) : ls) - | isToken t1 (KA KLetRec) - || isToken t1 (KA KExports) - || isToken t1 (KA KImports) - = t1 : newCBra ls : applyOffside [n] ls +-- 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 [] (LexemeStartLine _ : ts) - = applyOffside [] ts +applyOffside ps [] (LexemeStartLine _ : ts) + = applyOffside ps [] ts -applyOffside [] (LexemeStartBlock _ : ts) - = applyOffside [] ts +applyOffside ps [] (LexemeStartBlock _ : ts) + = applyOffside ps [] ts -- line start -applyOffside mm@(m : ms) (t@(LexemeStartLine n) : ts) +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 mm ts + = newSemiColon ts : applyOffside ps mm ts -- end a block - -- we keep the StartLine token in the recursion in case we're ending - -- multiple blocks difference from Haskell98: add a semicolon as well - | n < m - = newSemiColon ts : newCKet ts : applyOffside ms (t : ts) + | 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 mm ts + = applyOffside ps mm ts -- block start -applyOffside mm@(m : ms) (LexemeStartBlock n : ts) +applyOffside ps mm@(m : ms) (LexemeStartBlock n : ts) -- enter into a nested context | n > m - = newCBra ts : applyOffside (n : m : ms) ts + = newCBra ts : applyOffside (ParenBrace : ps) (n : m : ms) ts -- new context starts less than the current one. - -- This should never happen, - -- provided addStarts works. + -- This should never happen, + -- provided addStarts works. | tNext : _ <- dropNewLinesLexeme ts - = error $ "DDC.Core.Lexer.Tokens.Offside: layout error on " ++ show tNext ++ "." + = 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 + -- 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.Lexer.Tokens.Offside: tried to start new context at end of file." + = error $ "ddc-core: tried to start new context at end of file." -- an empty block | otherwise - = newCBra ts : newCKet ts : applyOffside mm (LexemeStartLine n : ts) + = newCBra ts : newCKet ts : applyOffside ps mm (LexemeStartLine n : ts) --- pop contexts from explicit close braces -applyOffside mm (LexemeToken t@Token { tokenTok = KA KBraceKet } : 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 - = t : applyOffside ms ts + | 0 : ms <- mm + , ParenBrace : ps' <- ps + = t : applyOffside ps' ms ts -- nup | _tNext : _ <- dropNewLinesLexeme ts = [newOffsideClosingBrace ts] --- push contexts for explicit open braces -applyOffside ms (LexemeToken t@Token { tokenTok = KA KBraceBra } : ts) - = t : applyOffside (0 : ms) ts +-- push context for explict open paren. +applyOffside ps ms + ( LexemeToken t@(Located _ (KA (KSymbol SRoundBra))) : ts) + = t : applyOffside (ParenRound : ps) ms ts -applyOffside ms (LexemeToken t : ts) - = t : applyOffside 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) -applyOffside [] [] = [] +-- 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 (_ : ms) [] = newCKet [] : applyOffside ms [] +applyOffside ps (_ : ms) [] + = newCKet [] : applyOffside ps ms [] --- addStarts ------------------------------------------------------------------ +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 lifted straight from the Haskell98 report. -addStarts :: Eq n => [Token (Tok n)] -> [Lexeme n] +-- +-- 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 KBraceBra] - -> LexemeStartBlock (tokenColumn t1) : addStarts' (t1 : tsRest) + | not $ or $ map (isToken t1) [KA (KSymbol SBraceBra)] + -> LexemeStartBlock (columnOfLocated t1) : addStarts' (t1 : tsRest) | otherwise -> addStarts' (t1 : tsRest) @@ -139,47 +223,58 @@ [] -> [] -addStarts' :: Eq n => [Token (Tok n)] -> [Lexeme n] -addStarts' [] = [] -addStarts' (t1 : ts) - - -- We're starting a block - | isBlockStart t1 - , [] <- dropNewLines ts - = LexemeToken t1 : [LexemeStartBlock 0] +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] - | isBlockStart t1 - , t2 : tsRest <- dropNewLines ts - , not $ isToken t2 (KA KBraceBra) - = LexemeToken t1 : LexemeStartBlock (tokenColumn t2) - : addStarts' (t2 : tsRest) + -- 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 - | isToken t1 (KA KBraceBra) - = LexemeToken t1 : addStarts' ts + | t1 : ts' <- ts + , isToken t1 (KA (KSymbol SBraceBra)) + = LexemeToken t1 : addStarts' ts' -- check for end of list - | isToken t1 (KA KBraceKet) - = LexemeToken t1 : addStarts' ts + | t1 : ts' <- ts + , isToken t1 (KA (KSymbol SBraceKet)) + = LexemeToken t1 : addStarts' ts' -- check for start of new line - | isToken t1 (KM KNewLine) - , t2 : tsRest <- dropNewLines ts - , not $ isToken t2 (KA KBraceBra) - = LexemeStartLine (tokenColumn t2) + | 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 - | isToken t1 (KM KNewLine) - = addStarts' ts + | t1 : ts' <- ts + , isToken t1 (KM KNewLine) + = addStarts' ts' -- a regular token + | t1 : ts' <- ts + = LexemeToken t1 : addStarts' ts' + + -- end of input | otherwise - = LexemeToken t1 : addStarts' ts + = [] --- | Drop newline tokens at the front fo this stream. -dropNewLines :: Eq n => [Token (Tok n)] -> [Token (Tok n)] +-- | 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) @@ -189,7 +284,7 @@ = t1 : ts --- | Drop newline tokens at the front fo this stream. +-- | Drop newline tokens at the front of this stream. dropNewLinesLexeme :: Eq n => [Lexeme n] -> [Lexeme n] dropNewLinesLexeme ll = case ll of @@ -203,63 +298,137 @@ -- | Check if a token is one that starts a block of statements. -isBlockStart :: Token (Tok n) -> Bool -isBlockStart Token { tokenTok = tok } - = case tok of - KA KDo -> True - KA KOf -> True - KA KLetRec -> True - KA KWhere -> True - KA KExports -> True - KA KImports -> True - _ -> False +splitBlockStart + :: [Located (Token n)] + -> Maybe ([Located (Token n)], [Located (Token n)]) +splitBlockStart toks --- Utils ---------------------------------------------------------------------- + -- 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 => Token (Tok n) -> Tok n -> Bool -isToken (Token tok _) tok2 = tok == tok2 +isToken :: Eq n => Located (Token n) -> Token n -> Bool +isToken (Located _ tok) tok2 + = tok == tok2 -- | Test whether this wrapper token matches. -isKNToken :: Eq n => Token (Tok n) -> Bool -isKNToken (Token (KN _) _) = True +isKNToken :: Eq n => Located (Token n) -> Bool +isKNToken (Located _ (KN _)) = True isKNToken _ = False -- | When generating new source tokens, take the position from the first -- non-newline token in this list -newCBra :: [Lexeme n] -> Token (Tok n) +newCBra :: [Lexeme n] -> Located (Token n) newCBra ts - = (takeTok ts) { tokenTok = KA KBraceBra } + = case takeTok ts of + Located sp _ -> Located sp (KA (KSymbol SBraceBra)) -newCKet :: [Lexeme n] -> Token (Tok n) +newCKet :: [Lexeme n] -> Located (Token n) newCKet ts - = (takeTok ts) { tokenTok = KA KBraceKet } + = case takeTok ts of + Located sp _ -> Located sp (KA (KSymbol SBraceKet)) -newSemiColon :: [Lexeme n] -> Token (Tok n) -newSemiColon ts - = (takeTok ts) { tokenTok = KA KSemiColon } +newSemiColon :: [Lexeme n] -> Located (Token n) +newSemiColon ts + = case takeTok ts of + Located sp _ -> Located sp (KA (KSymbol SSemiColon)) -- | This is injected by `applyOffside` when it finds an explit close -- brace in a position where it would close a synthetic one. -newOffsideClosingBrace :: [Lexeme n] -> Token (Tok n) +newOffsideClosingBrace :: [Lexeme n] -> Located (Token n) newOffsideClosingBrace ts - = (takeTok ts) { tokenTok = KM KOffsideClosingBrace } + = case takeTok ts of + Located sp _ -> Located sp (KM KOffsideClosingBrace) -takeTok :: [Lexeme n] -> Token (Tok n) +takeTok :: [Lexeme n] -> Located (Token n) takeTok [] - = Token (KJunk "") (SourcePos "" 0 0) + = Located (SourcePos "" 0 0) (KErrorJunk "") takeTok (l : ls) = case l of - LexemeToken (Token { tokenTok = KM KNewLine }) + LexemeToken (Located _ (KM KNewLine)) -> takeTok ls LexemeToken t -> t LexemeStartLine _ -> takeTok ls LexemeStartBlock _ -> takeTok ls + diff --git a/DDC/Core/Lexer/Token/Builtin.hs b/DDC/Core/Lexer/Token/Builtin.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Token/Builtin.hs @@ -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 + + diff --git a/DDC/Core/Lexer/Token/Index.hs b/DDC/Core/Lexer/Token/Index.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Token/Index.hs @@ -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 + diff --git a/DDC/Core/Lexer/Token/Keyword.hs b/DDC/Core/Lexer/Token/Keyword.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Token/Keyword.hs @@ -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 + diff --git a/DDC/Core/Lexer/Token/Literal.hs b/DDC/Core/Lexer/Token/Literal.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Token/Literal.hs @@ -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] + diff --git a/DDC/Core/Lexer/Token/Names.hs b/DDC/Core/Lexer/Token/Names.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Token/Names.hs @@ -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 == '#' + diff --git a/DDC/Core/Lexer/Token/Operator.hs b/DDC/Core/Lexer/Token/Operator.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Token/Operator.hs @@ -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 + + + + diff --git a/DDC/Core/Lexer/Token/Symbol.hs b/DDC/Core/Lexer/Token/Symbol.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Token/Symbol.hs @@ -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 diff --git a/DDC/Core/Lexer/Tokens.hs b/DDC/Core/Lexer/Tokens.hs --- a/DDC/Core/Lexer/Tokens.hs +++ b/DDC/Core/Lexer/Tokens.hs @@ -1,25 +1,64 @@ module DDC.Core.Lexer.Tokens - ( -- * Tokens - Tok (..) - , renameTok - , describeTok + ( Located (..) + , columnOfLocated - -- * Meta Tokens - , TokMeta (..) - , describeTokMeta + -- * Tokens + , Token (..) + , TokenMeta (..) + , TokenAtom (..) + , TokenNamed (..) - -- * Atomic Tokens - , TokAtom (..) - , describeTokAtom + , Keyword (..) + , Symbol (..) + , Builtin (..) + , Literal (..) - -- * Named Tokens - , TokNamed (..) - , describeTokNamed) + -- ** Description + , describeToken + , describeTokenMeta + , describeTokenAtom + , describeTokenNamed + , sayKeyword + , saySymbol + , sayBuiltin + + -- ** Renaming + , renameToken + + -- ** Predicates + , isVarName + , isVarStart + , isVarBody + + , isConName + , isConStart + , isConBody + + , isLitName + , isLitStart + , isLitBody + + -- ** Literal Reading + , readLitInteger + , readLitNat + , readLitInt + , readLitSize + , readLitWordOfBits + , readLitFloatOfBits + , readBinary + , readHex) where +import DDC.Data.SourcePos +import DDC.Core.Lexer.Token.Symbol +import DDC.Core.Lexer.Token.Keyword +import DDC.Core.Lexer.Token.Builtin +import DDC.Core.Lexer.Token.Literal +import DDC.Core.Lexer.Token.Names import DDC.Core.Pretty -import DDC.Core.Exp import Control.Monad +import Data.Text (Text) +import qualified Data.Text as T -- TokenFamily ---------------------------------------------------------------- @@ -32,7 +71,8 @@ | Keyword | Constructor | Index - | Variable + | Literal + | Pragma -- | Describe a token family, for parser error messages. @@ -43,63 +83,73 @@ Keyword -> "keyword" Constructor -> "constructor" Index -> "index" - Variable -> "variable" + Literal -> "literal" + Pragma -> "pragma" --- Tok ------------------------------------------------------------------------ +-- Token ------------------------------------------------------------------------ -- | Tokens accepted by the core language parser. -data Tok n +data Token n -- | Some junk symbol that isn't part of the language. - = KJunk String + = KErrorJunk String + -- | The first part of an unterminated string. + | KErrorUnterm String + -- | Meta tokens contain out-of-band information that is eliminated -- before parsing proper. - | KM !TokMeta + | KM !TokenMeta -- | Atomic tokens are keywords, punctuation and baked-in -- constructor names. - | KA !TokAtom + | KA !TokenAtom -- | A named token that is specific to the language fragment -- (maybe it's a primop), or a user defined name. - | KN !(TokNamed n) + | KN !(TokenNamed n) deriving (Eq, Show) -- | Apply a function to all the names in a `Tok`. -renameTok +renameToken :: Ord n2 => (n1 -> Maybe n2) - -> Tok n1 - -> Maybe (Tok n2) + -> Token n1 + -> Maybe (Token n2) -renameTok f kk +renameToken f kk = case kk of - KJunk s -> Just $ KJunk s + KErrorJunk s + -> Just $ KErrorJunk s + + KErrorUnterm s + -> Just $ KErrorUnterm s + KM t -> Just $ KM t KA t -> Just $ KA t - KN t -> liftM KN $ renameTokNamed f t + KN t -> liftM KN $ renameTokenNamed f t -- | Describe a token for parser error messages. -describeTok :: Pretty n => Tok n -> String -describeTok kk +describeToken :: Pretty n => Token n -> String +describeToken kk = case kk of - KJunk c -> "character " ++ show c - KM tm -> describeTokMeta tm - KA ta -> describeTokAtom ta - KN tn -> describeTokNamed tn + KErrorJunk c -> "character " ++ show c + KErrorUnterm _ -> "unterminated string" + KM tm -> describeTokenMeta tm + KA ta -> describeTokenAtom ta + KN tn -> describeTokenNamed tn -- TokMeta -------------------------------------------------------------------- -- | Meta tokens contain out-of-band information that is -- eliminated before parsing proper. -data TokMeta +data TokenMeta = KNewLine - | KCommentLineStart - | KCommentBlockStart - | KCommentBlockEnd + -- | Comment string. + | KComment String + -- | This is injected by `dropCommentBlock` when it finds -- an unterminated block comment. | KCommentUnterminated @@ -111,13 +161,11 @@ -- | Describe a TokMeta, for lexer error messages. -describeTokMeta :: TokMeta -> String -describeTokMeta tm +describeTokenMeta :: TokenMeta -> String +describeTokenMeta tm = case tm of KNewLine -> "new line" - KCommentLineStart -> "comment start" - KCommentBlockStart -> "block comment start" - KCommentBlockEnd -> "block comment end" + KComment{} -> "comment" KCommentUnterminated -> "unterminated block comment" KOffsideClosingBrace -> "closing brace" @@ -126,220 +174,79 @@ -- | Atomic tokens are keywords, punctuation and baked-in constructor names. -- They don't contain user-defined names or primops specific to the -- language fragment. -data TokAtom - -- parens - = KRoundBra - | KRoundKet - | KSquareBra - | KSquareKet - | KBraceBra - | KBraceKet - | 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 - | KArrowTilde - | KArrowDash - | KArrowDashLeft - | KArrowEquals - - -- bottoms - | KBotEffect - | KBotClosure - - -- core keywords - | KModule - | KImports - | KExports - | KWith - | KWhere - | KIn - | KLet - | KLazy - | KLetRec - | KLetRegions - | KLetRegion - | KWithRegion - | KCase - | KOf - | KType - | KWeakEff - | KWeakClo - | KPurify - | KForget - | KSuspend - | KRun - - -- sugar keywords - | KDo - | KMatch - | KElse +data TokenAtom + -- | Pragmas. + = KPragma Text - -- debruijn indices - | KIndex Int + -- | Symbols. + | KSymbol Symbol - -- builtin names ------------ - -- sort constructors. - | KSoConBuiltin SoCon + -- | Keywords. + | KKeyword Keyword - -- kind constructors. - | KKiConBuiltin KiCon + -- | Builtin names. + | KBuiltin Builtin - -- witness type constructors. - | KTwConBuiltin TwCon + -- | Infix operators, like in 1 + 2. + | KOp String - -- witness constructors. - | KWbConBuiltin WbCon + -- | Wrapped operator, like in (+) 1 2. + | KOpVar String - -- other builtin spec constructors. - | KTcConBuiltin TcCon + -- | Debrujn indices. + | KIndex Int - -- the unit data constructor. - | KDaConUnit + -- | Literal values. + | KLiteral + Literal -- Literal value. + Bool -- Trailing '#' prim specifier. deriving (Eq, Show) -- | Describe a `TokAtom`, for parser error messages. -describeTokAtom :: TokAtom -> String -describeTokAtom ta - = let (family, str) = describeTokAtom' ta +describeTokenAtom :: TokenAtom -> String +describeTokenAtom ta + = let (family, str) = describeTokenAtom' ta in describeTokenFamily family ++ " " ++ show str -describeTokAtom' :: TokAtom -> (TokenFamily, String) -describeTokAtom' ta +describeTokenAtom' :: TokenAtom -> (TokenFamily, String) +describeTokenAtom' ta = case ta of - -- parens - KRoundBra -> (Symbol, "(") - KRoundKet -> (Symbol, ")") - KSquareBra -> (Symbol, "[") - KSquareKet -> (Symbol, "]") - KBraceBra -> (Symbol, "{") - KBraceKet -> (Symbol, "}") - KAngleBra -> (Symbol, "<") - KAngleKet -> (Symbol, ">") + KPragma p -> (Pragma, "{-#" ++ T.unpack p ++ "#-}") + KSymbol ss -> (Symbol, saySymbol ss) + KKeyword kw -> (Keyword, sayKeyword kw) + KBuiltin bb -> (Constructor, sayBuiltin bb) + KOp op -> (Symbol, op) + KOpVar op -> (Symbol, "(" ++ op ++ ")") + KIndex i -> (Index, "^" ++ show i) + KLiteral l b -> (Literal, show (l, b)) - -- 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 - KArrowTilde -> (Constructor, "~>") - KArrowDash -> (Constructor, "->") - KArrowDashLeft -> (Constructor, "<-") - KArrowEquals -> (Constructor, "=>") - - -- bottoms - KBotEffect -> (Constructor, "!0") - KBotClosure -> (Constructor, "!$") - - -- expression keywords - KModule -> (Keyword, "module") - KImports -> (Keyword, "imports") - KExports -> (Keyword, "exports") - KWith -> (Keyword, "with") - KWhere -> (Keyword, "where") - KIn -> (Keyword, "in") - KLet -> (Keyword, "let") - KLazy -> (Keyword, "lazy") - KLetRec -> (Keyword, "letrec") - KLetRegions -> (Keyword, "letregions") - KLetRegion -> (Keyword, "letregion") - KWithRegion -> (Keyword, "withregion") - KCase -> (Keyword, "case") - KOf -> (Keyword, "of") - KType -> (Keyword, "type") - KWeakEff -> (Keyword, "weakeff") - KWeakClo -> (Keyword, "weakclo") - KPurify -> (Keyword, "purify") - KForget -> (Keyword, "forget") - KSuspend -> (Keyword, "suspend") - KRun -> (Keyword, "run") - - -- sugar keywords - KDo -> (Keyword, "do") - KMatch -> (Keyword, "match") - KElse -> (Keyword, "else") - - -- debruijn indices - KIndex i -> (Index, "^" ++ show i) - - -- builtin names - KSoConBuiltin so -> (Constructor, renderPlain $ ppr so) - KKiConBuiltin ki -> (Constructor, renderPlain $ ppr ki) - KTwConBuiltin tw -> (Constructor, renderPlain $ ppr tw) - KWbConBuiltin wi -> (Constructor, renderPlain $ ppr wi) - KTcConBuiltin tc -> (Constructor, renderPlain $ ppr tc) - KDaConUnit -> (Constructor, "()") - - -- TokNamed ------------------------------------------------------------------- -- | A token with a user-defined name. -data TokNamed n +data TokenNamed n = KCon n | KVar n - | KLit n deriving (Eq, Show) -- | Describe a `TokNamed`, for parser error messages. -describeTokNamed :: Pretty n => TokNamed n -> String -describeTokNamed tn +describeTokenNamed :: Pretty n => TokenNamed n -> String +describeTokenNamed tn = case tn of KCon n -> renderPlain $ text "constructor" <+> (dquotes $ ppr n) KVar n -> renderPlain $ text "variable" <+> (dquotes $ ppr n) - KLit n -> renderPlain $ text "literal" <+> (dquotes $ ppr n) -- | Apply a function to all the names in a `TokNamed`. -renameTokNamed +renameTokenNamed :: Ord n2 => (n1 -> Maybe n2) - -> TokNamed n1 - -> Maybe (TokNamed n2) + -> TokenNamed n1 + -> Maybe (TokenNamed n2) -renameTokNamed f kk +renameTokenNamed f kk = case kk of KCon c -> liftM KCon $ f c KVar c -> liftM KVar $ f c - KLit c -> liftM KLit $ f c diff --git a/DDC/Core/Lexer/Unicode.hs b/DDC/Core/Lexer/Unicode.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Unicode.hs @@ -0,0 +1,81 @@ + +-- | Defines allowable unicode operator symbols. +-- +-- We want to allow the use of common operator symbols that most people +-- can pronounce, but deny the ones that can be confused with others. +-- +-- NOTE: We also want to guide client programmers into using unicode +-- symbols in a sane and friendly way. When we add operator definitions, +-- setup the syntax so that each operator is naturally given a pronouncable +-- name. +-- +-- operator compose ∘ as infix 5 +-- operator union ∪ as infix 3 +-- operator sqrt √ as prefix +-- operator and ∧ /\ as infix 3 +-- +-- Give up on && and || for logical AND and OR operators. +-- If we allow ∧ and ∨ then the ASCII version should be /\ and \/. +-- +-- We could then provide a compiler command to lookup the name and input +-- information for provided operators. +-- +module DDC.Core.Lexer.Unicode + (unicodeOperatorsInfix) +where +import Data.Set (Set) +import qualified Data.Set as Set + + +-- | Common use of a unicode operator. +data Use + = Denied + | Infix + | Prefix + deriving Show + + +-- | Unicode operators that are used infix. +unicodeOperatorsInfix :: Set Char +unicodeOperatorsInfix + = Set.fromList + $ [c | (c, _, Infix) <- unicodeOperatorTable] + + +-- | Symbols from the Unicode Range 2200-22ff "Mathematical Operators". +-- From http://www.unicode.org/charts/PDF/U2200.pdf +-- +-- We restrict the allowable unicode to the common ones that most people +-- know how to pronounce, that do not conflict with other symbols, +-- and that are tradionally used infix. +-- +unicodeOperatorTable :: [(Char, String, Use)] +unicodeOperatorTable + = [ -- Set membership + ('∈', "element of", Infix) -- U+2208 ok + , ('∉', "not an element of", Infix) -- U+2209 ok +-- , ('∊', "small element of", Infix) -- U+220a looks like U+2208 + , ('∋', "contains as member", Infix) -- U+220b + , ('∌', "does not contain as member", Infix) -- U+220c +-- , ('∍', "small contains as member", Denied) -- U+220d looks like U+220b + + -- Operators +-- ('−', "minus sign", Denied) -- U+2212 looks like regular minus + , ('∓', "minus-or-plus sign", Infix) -- U+2213 ok + , ('∔', "dot plus", Infix) -- U+2214 ok +-- , ('∕', "division slash", Denied) -- U+2215 looks like fwd slash. +-- , ('∖', "set minus", Denied) -- U+2216 looks like back slash. +-- , ('∗', "asterix operator", Denied) -- U+2217 looks like times + , ('∘', "ring operator", Infix) -- U+2218 ok + , ('∙', "bullet operator", Infix) -- U+2219 ok + , ('√', "square root", Prefix) -- U+221a ok + , ('∛', "cube root", Prefix) -- U+221b ok + , ('∜', "fourth root", Prefix) -- U+221c ok + , ('∝', "proportional to", Infix) -- U+221d ok + + -- Logical and set operators. + , ('∧', "logical and", Infix) -- U+2227 ok + , ('∨', "logical or", Infix) -- U+2228 ok + , ('∩', "intersection", Infix) -- U+2229 ok + , ('∪', "union", Infix) -- U+222a ok + ] diff --git a/DDC/Core/Load.hs b/DDC/Core/Load.hs --- a/DDC/Core/Load.hs +++ b/DDC/Core/Load.hs @@ -1,47 +1,66 @@ +{-# 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 (..) + ( C.AnTEC (..) + , Error (..) + , Mode (..) + , CheckTrace (..) + + -- * Loading modules , loadModuleFromFile , loadModuleFromString , loadModuleFromTokens - , loadExp - , loadType - , loadWitness) + + -- * 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.Annot.AnT (AnT) +import DDC.Core.Exp.Annot.AnT (AnT) import DDC.Type.Transform.SpreadT +import DDC.Type.Universe import DDC.Core.Module -import DDC.Base.Pretty -import DDC.Data.Token -import qualified DDC.Core.Fragment as I +import DDC.Data.Pretty +import DDC.Core.Fragment (Fragment) +import qualified DDC.Core.Env.EnvX as EnvX +import qualified DDC.Core.Fragment as F import qualified DDC.Core.Parser as C import qualified DDC.Core.Check as C -import qualified DDC.Type.Check as T -import qualified DDC.Type.Env as Env -import qualified DDC.Base.Parser as BP +import qualified DDC.Control.Parser as BP +import qualified Data.Map.Strict as Map import Data.Map.Strict (Map) import System.Directory +-- Error ------------------------------------------------------------------------------------------ -- | Things that can go wrong when loading a core thing. -data Error n +data Error n err = ErrorRead !String | ErrorParser !BP.ParseError - | ErrorCheckType !(T.Error n) + | ErrorCheckType !(C.Error BP.SourcePos n) | ErrorCheckExp !(C.Error BP.SourcePos n) - | ErrorCompliance !(I.Error (C.AnTEC BP.SourcePos n) n) - deriving Show + | ErrorCompliance !(F.Error (C.AnTEC BP.SourcePos n) n) + | ErrorFragment !(err (C.AnTEC BP.SourcePos n)) -instance (Eq n, Show n, Pretty n) => Pretty (Error n) where +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 @@ -56,7 +75,6 @@ -> vcat [ text "When checking type." , indent 2 $ ppr err' ] - ErrorCheckExp err' -> vcat [ text "When checking expression." , indent 2 $ ppr err' ] @@ -65,145 +83,215 @@ -> vcat [ text "During fragment compliance check." , indent 2 $ ppr err' ] + ErrorFragment err' + -> vcat [ text "During fragment specific check." + , indent 2 $ ppr err' ] --- Module --------------------------------------------------------------------- + +-- Module ----------------------------------------------------------------------------------------- -- | Parse and type check a core module from a file. loadModuleFromFile :: (Eq n, Ord n, Show n, Pretty n) - => Profile n -- ^ Language fragment profile. - -> (String -> [Token (Tok n)]) -- ^ Function to lex the source file. + => Fragment n err -- ^ Language fragment definition. -> FilePath -- ^ File containing source code. - -> IO (Either (Error n) - (Module (C.AnTEC BP.SourcePos n) n)) + -> Mode n -- ^ Type checker mode. + -> IO ( Either (Error n err) + (Module (C.AnTEC BP.SourcePos n) n) + , Maybe CheckTrace) -loadModuleFromFile profile lexSource filePath +loadModuleFromFile fragment filePath mode = do -- Check whether the file exists. exists <- doesFileExist filePath if not exists - then return $ Left $ ErrorRead "Cannot read file." + then return ( Left $ ErrorRead $ "No such file '" ++ filePath ++ "'" + , Nothing) else do -- Read the source file. src <- readFile filePath -- Lex the source. - let toks = lexSource src + let toks = (F.fragmentLexModule fragment) filePath 1 src - return $ loadModuleFromTokens profile filePath toks + 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) - => Profile n -- ^ Language fragment profile. - -> (String -> [Token (Tok n)]) -- ^ Function to lex the source file. + => 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) - (Module (C.AnTEC BP.SourcePos n) n) + -> ( Either (Error n err) + (Module (C.AnTEC BP.SourcePos n) n) + , Maybe CheckTrace) -loadModuleFromString profile lexSource filePath src - = loadModuleFromTokens profile filePath (lexSource src) +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. +-- | Parse and type check a core module from some tokens. loadModuleFromTokens :: (Eq n, Ord n, Show n, Pretty n) - => Profile n -- ^ Language fragment profile. + => Fragment n err -- ^ Language fragment definition. -> FilePath -- ^ Path to source file for error messages. - -> [Token (Tok n)] -- ^ Source tokens. - -> Either (Error n) - (Module (C.AnTEC BP.SourcePos n) n) + -> Mode n -- ^ Type checker mode. + -> [Located (Token n)] -- ^ Source tokens. + -> ( Either (Error n err) + (Module (C.AnTEC BP.SourcePos n) n) + , Maybe CheckTrace) -loadModuleFromTokens profile sourceName toks' +loadModuleFromTokens fragment sourceName mode toks' = goParse toks' where -- Type checker config kind and type environments. - config = C.configOfProfile profile - kenv = profilePrimKinds profile - tenv = profilePrimTypes profile + profile = F.fragmentProfile fragment + config = C.configOfProfile profile + kenv = profilePrimKinds profile + tenv = profilePrimTypes profile -- Parse the tokens. goParse toks - = case BP.runTokenParser describeTok sourceName + = case BP.runTokenParser describeToken sourceName (C.pModule (C.contextOfProfile profile)) toks of - Left err -> Left (ErrorParser err) - Right mm -> goCheckType (spreadX kenv tenv mm) + Left err -> (Left (ErrorParser err), Nothing) + Right mm -> goCheckType (spreadX kenv tenv mm) - -- Check that the module is type sound. + -- Check that the module is type well-typed. goCheckType mm - = case C.checkModule config mm of - Left err -> Left (ErrorCheckExp err) - Right mm' -> goCheckCompliance 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 mm - = case I.complies profile mm of - Just err -> Left (ErrorCompliance err) - Nothing -> Right mm + 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 ------------------------------------------------------------------------ + +-- 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 -loadExp +loadExpFromTokens :: (Eq n, Ord n, Show n, Pretty n) - => Profile n -- ^ Language fragment profile. + => 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. - -> [Token (Tok n)] -- ^ Source tokens. - -> Either (Error n) - (Exp (C.AnTEC BP.SourcePos n) n) + -> Mode n -- ^ Type checker mode. + -> [Located (Token n)] -- ^ Source tokens. + -> ( Either (Error n err) + (Exp (C.AnTEC BP.SourcePos n) n) + , Maybe CheckTrace) -loadExp profile modules sourceName toks' +loadExpFromTokens fragment modules sourceName mode toks' = goParse toks' where -- Type checker profile, kind and type environments. + profile = F.fragmentProfile fragment config = C.configOfProfile profile - kenv = modulesExportKinds modules $ profilePrimKinds profile - tenv = modulesExportTypes modules $ profilePrimTypes profile + + envx = modulesEnvX + (profilePrimKinds profile) + (profilePrimTypes profile) + (profilePrimDataDefs profile) + (Map.elems modules) + kenv = EnvX.kindEnvOfEnvX envx + tenv = EnvX.typeEnvOfEnvX envx + -- Parse the tokens. goParse toks - = case BP.runTokenParser describeTok sourceName + = case BP.runTokenParser describeToken sourceName (C.pExp (C.contextOfProfile profile)) toks of - Left err -> Left (ErrorParser err) - Right t -> goCheckType (spreadX kenv tenv t) + 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 kenv tenv x of - Left err -> Left (ErrorCheckExp err) - Right (x', _, _, _) -> goCheckCompliance 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 x - = case I.compliesWithEnvs profile kenv tenv x of - Just err -> Left (ErrorCompliance err) - Nothing -> Right x + 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, --- returning it along with its kind. -loadType + +-- Type ------------------------------------------------------------------------------------------- +-- | Parse and check a type from a string, returning it along with its kind. +loadTypeFromString :: (Eq n, Ord n, Show n, Pretty n) - => Profile n -- ^ Language fragment profile. + => Fragment n err -- ^ Language fragment definition. + -> Universe -- ^ Universe this type is supposed to be in. -> FilePath -- ^ Path to source file for error messages. - -> [Token (Tok n)] -- ^ Source tokens. - -> Either (Error n) + -> String -- ^ Source string. + -> Either (Error n err) (Type n, Kind n) -loadType profile sourceName toks' +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 describeTok sourceName + = case BP.runTokenParser describeToken sourceName (C.pType (C.contextOfProfile profile)) toks of Left err -> Left (ErrorParser err) @@ -211,33 +299,52 @@ -- Check the kind of the type. goCheckType t - = case T.checkType (T.configOfProfile profile) Env.empty t of - Left err -> Left (ErrorCheckType err) - Right k -> Right (t, k) + = 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) --- Witness -------------------------------------------------------------------- --- | Parse and check a witness, --- returning it along with its type. -loadWitness +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) - => Profile n -- ^ Language fragment profile. + => Fragment n err -- ^ Language fragment profile. -> FilePath -- ^ Path to source file for error messages. - -> [Token (Tok n)] -- ^ Source tokens. - -> Either (Error n) + -> [Located (Token n)] -- ^ Source tokens. + -> Either (Error n err) (Witness (AnT BP.SourcePos n) n, Type n) -loadWitness profile sourceName toks' +loadWitnessFromTokens fragment sourceName toks' = goParse toks' where -- Type checker config, kind and type environments. - config = C.configOfProfile profile + 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 describeTok sourceName + = case BP.runTokenParser describeToken sourceName (C.pWitness (C.contextOfProfile profile)) toks of Left err -> Left (ErrorParser err) @@ -245,7 +352,7 @@ -- Check the kind of the type. goCheckType w - = case C.checkWitness config kenv tenv w of + = case C.checkWitness config env w of Left err -> Left (ErrorCheckExp err) Right (w', t) -> Right (w', t) diff --git a/DDC/Core/Module.hs b/DDC/Core/Module.hs --- a/DDC/Core/Module.hs +++ b/DDC/Core/Module.hs @@ -1,59 +1,116 @@ - module DDC.Core.Module ( -- * Modules Module (..) , isMainModule - , moduleKindEnv - , moduleTypeEnv - , modulesGetBinds + , moduleDataDefs + , moduleTypeDefs + , moduleKindEnv, moduleTypeEnv + , moduleEnvT, moduleEnvX + , modulesEnvT, modulesEnvX + , moduleTopBinds + , moduleTopBindTypes + , mapTopBinds - -- * Module maps - , ModuleMap - , modulesExportKinds - , modulesExportTypes + -- * Module maps + , ModuleMap + , modulesExportTypes + , modulesExportValues - -- * Module Names. - , QualName (..) + -- * Module Names , ModuleName (..) - , isMainModuleName) + , 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.Exp +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 --------------------------------------------------------------------- +-- 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. - , moduleExportKinds :: !(Map n (Kind n)) + , moduleExportTypes :: ![(n, ExportSource n (Type n))] -- | Types of exported values. - , moduleExportTypes :: !(Map n (Type n)) + , moduleExportValues :: ![(n, ExportSource n (Type n))] -- Imports ------------------ - -- | Kinds of imported types, - -- along with the name of the module they are from. - , moduleImportKinds :: !(Map n (QualName n, Kind n)) + -- | Define imported types. + , moduleImportTypes :: ![(n, ImportType n (Type n))] - -- | Types of imported values, - -- along with the name of the module they are from. - , moduleImportTypes :: !(Map n (QualName n, Type n)) + -- | Define imported capabilities. + , moduleImportCaps :: ![(n, ImportCap n (Type n))] - -- Local -------------------- - -- | 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. + -- | 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) @@ -61,12 +118,18 @@ instance (NFData a, NFData n) => NFData (Module a n) where rnf !mm - = rnf (moduleName mm) - `seq` rnf (moduleExportKinds mm) - `seq` rnf (moduleExportTypes mm) - `seq` rnf (moduleImportKinds mm) - `seq` rnf (moduleImportTypes mm) - `seq` rnf (moduleBody mm) + = rnf (moduleName mm) + `seq` rnf (moduleIsHeader mm) + `seq` rnf (moduleExportTypes mm) + `seq` rnf (moduleExportValues mm) + `seq` rnf (moduleImportTypes mm) + `seq` rnf (moduleImportCaps mm) + `seq` rnf (moduleImportValues mm) + `seq` rnf (moduleImportDataDefs mm) + `seq` rnf (moduleImportTypeDefs mm) + `seq` rnf (moduleDataDefsLocal mm) + `seq` rnf (moduleTypeDefsLocal mm) + `seq` rnf (moduleBody mm) -- | Check if this is the `Main` module. @@ -76,12 +139,25 @@ $ moduleName mm +-- | Get the data type definitions visible in a module. +moduleDataDefs :: Ord n => Module a n -> DataDefs n +moduleDataDefs mm + = fromListDataDefs + $ (moduleImportDataDefs mm ++ moduleDataDefsLocal mm) + + +-- | Get the data type definitions visible in a module. +moduleTypeDefs :: Ord n => Module a n -> [(n, (Kind n, Type n))] +moduleTypeDefs mm + = moduleImportTypeDefs mm ++ moduleTypeDefsLocal mm + + -- | Get the top-level kind environment of a module, -- from its imported types. moduleKindEnv :: Ord n => Module a n -> KindEnv n moduleKindEnv mm = Env.fromList - $ [BName n k | (n, (_, k)) <- Map.toList $ moduleImportKinds mm] + $ [BName n (kindOfImportType isrc) | (n, isrc) <- moduleImportTypes mm] -- | Get the top-level type environment of a module, @@ -89,59 +165,228 @@ moduleTypeEnv :: Ord n => Module a n -> TypeEnv n moduleTypeEnv mm = Env.fromList - $ [BName n k | (n, (_, k)) <- Map.toList $ moduleImportTypes mm] + $ [BName n (typeOfImportValue isrc) | (n, isrc) <- moduleImportValues mm] --- ModuleMap ------------------------------------------------------------------ --- | Map of module names to modules. -type ModuleMap a n - = Map ModuleName (Module a n) +-- | 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 -modulesGetBinds m - = Env.fromList $ map (uncurry BName) (Map.assocs m) +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] --- | Add the kind environment exported by all these modules to the given one. -modulesExportKinds :: Ord n => ModuleMap a n -> KindEnv n -> KindEnv n -modulesExportKinds mods base - = foldl Env.union base - $ map (modulesGetBinds.moduleExportKinds) (Map.elems mods) + , EnvT.envtPrimFun + = Env.envPrimFun kenvPrim + , EnvT.envtMap + = let -- Kinds of imported foreign types. + nksImportForeignType + = Map.fromList [(n, kindOfImportType isrc) + | (n, isrc) <- moduleImportTypes mm] --- | Add the type environment exported by all these modules to the given one. -modulesExportTypes :: Ord n => ModuleMap a n -> TypeEnv n -> TypeEnv n + -- Kinds of imported data types. + nksImportDataType + = Map.fromList [(dataDefTypeName def, kindOfDataDef def) + | def <- moduleImportDataDefs mm] -modulesExportTypes mods base - = foldl Env.union base - $ map (modulesGetBinds.moduleExportTypes) (Map.elems mods) + -- 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] --- ModuleName ----------------------------------------------------------------- --- | A hierarchical module name. -data ModuleName - = ModuleName [String] - deriving (Show, Eq, Ord, Typeable) + -- Kinds of imported type defs. + nksLocalTypeDef + = Map.fromList [(n, k) | (n, (k, _)) <- moduleTypeDefsLocal mm] -instance NFData ModuleName where - rnf (ModuleName ss) - = rnf ss - + 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 ] --- | A fully qualified name, --- including the name of the module it is from. -data QualName n - = QualName ModuleName n - deriving Show + , EnvT.envtStack = [] + , EnvT.envtStackLength = 0 -instance NFData n => NFData (QualName n) where - rnf (QualName mn n) - = rnf mn `seq` rnf n + } --- | Check whether this is the name of the \"Main\" module. -isMainModuleName :: ModuleName -> Bool -isMainModuleName mn - = case mn of - ModuleName ["Main"] -> True - _ -> False +-- | 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) diff --git a/DDC/Core/Module/Export.hs b/DDC/Core/Module/Export.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Module/Export.hs @@ -0,0 +1,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 + diff --git a/DDC/Core/Module/Import.hs b/DDC/Core/Module/Import.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Module/Import.hs @@ -0,0 +1,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) + diff --git a/DDC/Core/Module/Name.hs b/DDC/Core/Module/Name.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Module/Name.hs @@ -0,0 +1,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 + diff --git a/DDC/Core/Parser.hs b/DDC/Core/Parser.hs --- a/DDC/Core/Parser.hs +++ b/DDC/Core/Parser.hs @@ -4,18 +4,26 @@ , Context (..) , contextOfProfile + -- * Types + , pType + , pTypeApp + , pTypeAtom + -- * Modules , pModule + , pModuleName - -- * Expressions + -- * Expressions , pExp , pExpApp , pExpAtom - -- * Types - , pType - , pTypeApp - , pTypeAtom + -- * Function Parameters + , ParamSpec(..) + , funTypeOfParams + , expOfParams + , pBindParamSpecAnnot + , pBindParamSpec -- * Witnesses , pWitness @@ -23,17 +31,22 @@ , pWitnessAtom -- * Constructors - , pCon - , pLit + , pCon, pConSP + , pLit, pLitSP -- * Variables + , pIndex, pIndexSP + , pVar, pVarSP , pBinder - , pIndex - , pVar , pName + + -- * Infix operators + , pOpSP + , pOpVarSP -- * Raw Tokens - , pTok + , pSym, pKey + , pTok, pTokSP , pTokAs) where @@ -43,4 +56,4 @@ import DDC.Core.Parser.Type import DDC.Core.Parser.Exp import DDC.Core.Parser.Module - +import DDC.Core.Parser.Param diff --git a/DDC/Core/Parser/Base.hs b/DDC/Core/Parser/Base.hs --- a/DDC/Core/Parser/Base.hs +++ b/DDC/Core/Parser/Base.hs @@ -4,43 +4,57 @@ , pModuleName , pQualName , pName - , pWbCon, pWbConSP , pCon, pConSP , pLit, pLitSP , pIndex, pIndexSP - , pVar, pVarSP + , pVar, pVarSP, pVarNamedSP + , pKey, pSym , pTok, pTokSP - , pTokAs, pTokAsSP) + , pTokAs, pTokAsSP + , pOpSP + , pOpVarSP + , pPragmaSP) where -import DDC.Base.Pretty +import DDC.Data.Pretty import DDC.Core.Module -import DDC.Core.Exp import DDC.Core.Lexer.Tokens -import DDC.Base.Parser ((), SourcePos) -import qualified DDC.Base.Parser as P - +import DDC.Control.Parser ((), SourcePos) +import Data.Text (Text) +import qualified DDC.Control.Parser as P -- | A parser of core language tokens. type Parser n a - = P.Parser (Tok n) a + = P.Parser (Token n) a -- | Parse a module name. --- ---- ISSUE #273: Handle hierarchical module names. --- Accept hierachical names, and reject hashes at the end of a name. --- Hashes can be at the end of constructor name, but not module names. pModuleName :: Pretty n => Parser n ModuleName -pModuleName = P.pTokMaybe f - where f (KN (KCon n)) = Just $ ModuleName [renderPlain $ ppr n] - f _ = Nothing +pModuleName + = do ms <- P.sepBy1 pModuleName1 (pTok (KSymbol SDot)) + return $ ModuleName + $ concat + $ map (\(ModuleName ss) -> ss) ms +-- | Parse a single component module name. +pModuleName1 :: Pretty n => Parser n ModuleName +pModuleName1 = P.pTokMaybe f + where f (KN (KCon n)) = Just $ ModuleName [ renderPlain $ ppr n ] + + -- These names are lexed as constructors + -- but can be part of a module name. + f (KA (KBuiltin (BSoCon c))) = Just $ ModuleName [ renderPlain $ ppr c ] + f (KA (KBuiltin (BKiCon c))) = Just $ ModuleName [ renderPlain $ ppr c ] + f (KA (KBuiltin (BTwCon c))) = Just $ ModuleName [ renderPlain $ ppr c ] + f (KA (KBuiltin (BTcCon c))) = Just $ ModuleName [ renderPlain $ ppr c ] + f _ = Nothing + + -- | Parse a qualified variable or constructor name. pQualName :: Pretty n => Parser n (QualName n) pQualName = do mn <- pModuleName - pTok KDot + pTok (KSymbol SDot) n <- pName return $ QualName mn n @@ -50,20 +64,6 @@ pName = P.choice [pCon, pVar] --- | Parse a builtin named `WbCon` -pWbCon :: Parser n WbCon -pWbCon = P.pTokMaybe f - where f (KA (KWbConBuiltin wb)) = Just wb - f _ = Nothing - - --- | Parse a builtin named `WbCon` -pWbConSP :: Parser n (WbCon, SourcePos) -pWbConSP = P.pTokMaybeSP f - where f (KA (KWbConBuiltin wb)) = Just wb - f _ = Nothing - - -- | Parse a constructor name. pCon :: Parser n n pCon = P.pTokMaybe f @@ -78,18 +78,18 @@ f _ = Nothing --- | Parse a literal -pLit :: Parser n n +-- | Parse a literal. +pLit :: Parser n (Literal, Bool) pLit = P.pTokMaybe f - where f (KN (KLit n)) = Just n - f _ = Nothing + where f (KA (KLiteral l b)) = Just (l, b) + f _ = Nothing --- | Parse a literal, with source position. -pLitSP :: Parser n (n, SourcePos) +-- | Parse a numeric literal, with source position. +pLitSP :: Parser n ((Literal, Bool), SourcePos) pLitSP = P.pTokMaybeSP f - where f (KN (KLit n)) = Just n - f _ = Nothing + where f (KA (KLiteral l b)) = Just (l, b) + f _ = Nothing -- | Parse a variable. @@ -108,7 +108,15 @@ f _ = Nothing --- | Parse a deBruijn index +-- | 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" @@ -124,21 +132,55 @@ 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 :: TokAtom -> Parser n () +pTok :: TokenAtom -> Parser n () pTok k = P.pTok (KA k) -- | Parse an atomic token, yielding its source position. -pTokSP :: TokAtom -> Parser n SourcePos +pTokSP :: TokenAtom -> Parser n SourcePos pTokSP k = P.pTokSP (KA k) -- | Parse an atomic token and return some value. -pTokAs :: TokAtom -> a -> Parser n a +pTokAs :: TokenAtom -> a -> Parser n a pTokAs k x = P.pTokAs (KA k) x -- | Parse an atomic token and return source position and value. -pTokAsSP :: TokAtom -> a -> Parser n (a, SourcePos) +pTokAsSP :: TokenAtom -> a -> Parser n (a, SourcePos) pTokAsSP k x = P.pTokAsSP (KA k) x + + diff --git a/DDC/Core/Parser/Context.hs b/DDC/Core/Parser/Context.hs --- a/DDC/Core/Parser/Context.hs +++ b/DDC/Core/Parser/Context.hs @@ -3,32 +3,46 @@ ( Context (..) , contextOfProfile) where +import DDC.Core.Exp.Literal import DDC.Core.Fragment +import DDC.Data.SourcePos -- | Configuration and information from the context. -- Used for context sensitive parsing. -data Context +data Context n = Context { contextTrackedEffects :: Bool , contextTrackedClosures :: Bool , contextFunctionalEffects :: Bool - , contextFunctionalClosures :: Bool } + , contextFunctionalClosures :: Bool + -- | Check whether the given fragment includes literals of this sort, + -- and convert it to the appropriate primitive name. + , contextMakeLiteralName + :: Maybe (SourcePos -> Literal -> Bool -> Maybe n) } --- | Slurp an initital Context from a Profile -contextOfProfile :: Profile n -> Context + +-- | Slurp an initital `Context` from a language `Profile`. +contextOfProfile :: Profile n -> Context n contextOfProfile profile = Context - { contextTrackedEffects = featuresTrackedEffects - $ profileFeatures profile + { contextTrackedEffects + = featuresTrackedEffects + $ profileFeatures profile - , contextTrackedClosures = featuresTrackedClosures - $ profileFeatures profile + , contextTrackedClosures + = featuresTrackedClosures + $ profileFeatures profile - , contextFunctionalEffects = featuresFunctionalEffects - $ profileFeatures profile + , contextFunctionalEffects + = featuresFunctionalEffects + $ profileFeatures profile - , contextFunctionalClosures = featuresFunctionalClosures - $ profileFeatures profile + , contextFunctionalClosures + = featuresFunctionalClosures + $ profileFeatures profile + + , contextMakeLiteralName + = profileMakeLiteralName profile } diff --git a/DDC/Core/Parser/DataDef.hs b/DDC/Core/Parser/DataDef.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Parser/DataDef.hs @@ -0,0 +1,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 } + diff --git a/DDC/Core/Parser/Exp.hs b/DDC/Core/Parser/Exp.hs --- a/DDC/Core/Parser/Exp.hs +++ b/DDC/Core/Parser/Exp.hs @@ -9,159 +9,96 @@ , pTypeApp , pTypeAtom) where -import DDC.Core.Exp +import DDC.Core.Exp.Annot import DDC.Core.Parser.Witness import DDC.Core.Parser.Param import DDC.Core.Parser.Type import DDC.Core.Parser.Context import DDC.Core.Parser.Base import DDC.Core.Lexer.Tokens -import DDC.Core.Compounds -import DDC.Base.Parser ((), SourcePos) -import qualified DDC.Base.Parser as P -import qualified DDC.Type.Compounds as T -import Control.Monad.Error +import DDC.Control.Parser ((), SourcePos) +import qualified DDC.Control.Parser as P +import qualified DDC.Type.Exp.Simple as T +import Control.Monad.Except --- Expressions ---------------------------------------------------------------- +-- Exp -------------------------------------------------------------------------------------------- -- | Parse a core language expression. -pExp :: Ord n => Context -> Parser n (Exp SourcePos n) +pExp :: Ord n => Context n -> Parser n (Exp SourcePos n) pExp c = P.choice -- Level-0 lambda abstractions - -- \(x1 x2 ... : TYPE) (y1 y2 ... : TYPE) ... . EXP - [ do sp <- pTokSP KBackSlash - - bs <- liftM concat - $ P.many1 - $ do pTok KRoundBra - bs' <- P.many1 pBinder - pTok KColon - t <- pType c - pTok KRoundKet - return (map (\b -> T.makeBindFromBinder b t) bs') - - pTok KDot + -- (λ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. - -- /\(x1 x2 ... : TYPE) (y1 y2 ... : TYPE) ... . EXP - , do sp <- pTokSP KBigLambda - - bs <- liftM concat - $ P.many1 - $ do pTok KRoundBra - bs' <- P.many1 pBinder - pTok KColon - t <- pType c - pTok KRoundKet - return (map (\b -> T.makeBindFromBinder b t) bs') - - pTok KDot + -- (Λ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 - pTok KIn + pKey EIn x2 <- pExp c return $ XLet sp lts x2 - -- do { STMTS } -- Sugar for a let-expression. - , do pTok KDo - pTok KBraceBra + , do pKey EDo + pSym SBraceBra xx <- pStmts c - pTok KBraceKet + pSym SBraceKet return $ xx - - -- withregion CON in EXP - , do sp <- pTokSP KWithRegion - u <- P.choice - [ do n <- pVar - return $ UName n - - , do n <- pCon - return $ UPrim n kRegion] - pTok KIn - x <- pExp c - return $ XLet sp (LWithRegion u) x - - -- case EXP of { ALTS } - , do sp <- pTokSP KCase + , do sp <- pKey ECase x <- pExp c - pTok KOf - pTok KBraceBra - alts <- P.sepEndBy1 (pAlt c) (pTok KSemiColon) - pTok KBraceKet + pKey EOf + pSym SBraceBra + alts <- P.sepEndBy1 (pAlt c) (pSym SSemiColon) + pSym SBraceKet return $ XCase sp x alts - - -- match PAT <- EXP else EXP in EXP - -- Sugar for a case-expression. - , do sp <- pTokSP KMatch + -- letcase PAT = EXP in EXP + , do -- Sugar for a single-alternative case expression. + sp <- pKey ELetCase p <- pPat c - pTok KArrowDashLeft + pSym SEquals x1 <- pExp c - pTok KElse + pKey EIn x2 <- pExp c - pTok KIn - x3 <- pExp c - return $ XCase sp x1 [AAlt p x3, AAlt PDefault x2] - + return $ XCase sp x1 [AAlt p x2] -- weakeff [TYPE] in EXP - , do sp <- pTokSP KWeakEff - pTok KSquareBra + , do sp <- pKey EWeakEff + pSym SSquareBra t <- pType c - pTok KSquareKet - pTok KIn + pSym SSquareKet + pKey EIn x <- pExp c return $ XCast sp (CastWeakenEffect t) x - - -- weakclo {EXP;+} in EXP - , do sp <- pTokSP KWeakClo - pTok KBraceBra - xs <- liftM (map fst . concat) - $ P.sepEndBy1 (pArgSPs c) (pTok KSemiColon) - pTok KBraceKet - pTok KIn - x <- pExp c - return $ XCast sp (CastWeakenClosure xs) x - - - -- purify in EXP - , do sp <- pTokSP KPurify - pTok KAngleBra + -- purify WITNESS in EXP + , do sp <- pKey EPurify w <- pWitness c - pTok KAngleKet - pTok KIn + pTok (KKeyword EIn) x <- pExp c return $ XCast sp (CastPurify w) x - - -- forget in EXP - , do sp <- pTokSP KForget - pTok KAngleBra - w <- pWitness c - pTok KAngleKet - pTok KIn - x <- pExp c - return $ XCast sp (CastForget w) x - - -- suspend EXP - , do sp <- pTokSP KSuspend + -- box EXP + , do sp <- pKey EBox x <- pExp c - return $ XCast sp CastSuspend x + return $ XCast sp CastBox x -- run EXP - , do sp <- pTokSP KRun + , do sp <- pKey ERun x <- pExp c return $ XCast sp CastRun x @@ -172,8 +109,8 @@ "an expression" --- Applications. -pExpApp :: Ord n => Context -> Parser n (Exp SourcePos n) +-- | Parse a function application. +pExpApp :: Ord n => Context n -> Parser n (Exp SourcePos n) pExpApp c = do (x1, _) <- pExpAtomSP c @@ -187,32 +124,32 @@ -- Comp, Witness or Spec arguments. -pArgSPs :: Ord n => Context -> Parser n [(Exp SourcePos n, SourcePos)] +pArgSPs :: Ord n => Context n -> Parser n [(Exp SourcePos n, SourcePos)] pArgSPs c = P.choice -- [TYPE] - [ do sp <- pTokSP KSquareBra + [ do sp <- pSym SSquareBra t <- pType c - pTok KSquareKet - return [(XType t, sp)] + pSym SSquareKet + return [(XType sp t, sp)] -- [: TYPE0 TYPE0 ... :] - , do sp <- pTokSP KSquareColonBra + , do sp <- pSym SSquareColonBra ts <- P.many1 (pTypeAtom c) - pTok KSquareColonKet - return [(XType t, sp) | t <- ts] + pSym SSquareColonKet + return [(XType sp t, sp) | t <- ts] - -- - , do sp <- pTokSP KAngleBra + -- {WITNESS} + , do sp <- pSym SBraceBra w <- pWitness c - pTok KAngleKet - return [(XWitness w, sp)] + pSym SBraceKet + return [(XWitness sp w, sp)] - -- <: WITNESS0 WITNESS0 ... :> - , do sp <- pTokSP KAngleColonBra + -- {: WITNESS0 WITNESS0 ... :} + , do sp <- pSym SBraceColonBra ws <- P.many1 (pWitnessAtom c) - pTok KAngleColonKet - return [(XWitness w, sp) | w <- ws] + pSym SBraceColonKet + return [(XWitness sp w, sp) | w <- ws] -- EXP0 , do (x, sp) <- pExpAtomSP c @@ -222,7 +159,7 @@ -- | Parse a variable, constructor or parenthesised expression. -pExpAtom :: Ord n => Context -> Parser n (Exp SourcePos n) +pExpAtom :: Ord n => Context n -> Parser n (Exp SourcePos n) pExpAtom c = do (x, _) <- pExpAtomSP c return x @@ -232,167 +169,202 @@ -- also returning source position. pExpAtomSP :: Ord n - => Context + => Context n -> Parser n (Exp SourcePos n, SourcePos) pExpAtomSP c = P.choice -- (EXP2) - [ do sp <- pTokSP KRoundBra + [ do sp <- pSym SRoundBra t <- pExp c - pTok KRoundKet + pSym SRoundKet return (t, sp) -- The unit data constructor. - , do sp <- pTokSP KDaConUnit + , do sp <- pTokSP (KBuiltin BDaConUnit) return (XCon sp dcUnit, sp) -- Named algebraic constructors. - -- We just fill-in the type with tBot for now, and leave it to - -- the spreader to attach the real type. - , do (con, sp) <- pConSP - return (XCon sp (mkDaConAlg con (T.tBot T.kData)), sp) + , do (con, sp) <- pConSP + return (XCon sp (DaConBound con), sp) -- Literals. - -- We just fill-in the type with tBot for now, and leave it to - -- the spreader to attach the real type. - -- We also set the literal as being algebraic, which may not be - -- true (as for Floats). The spreader also needs to fix this. - , do (lit, sp) <- pLitSP - return (XCon sp (mkDaConAlg lit (T.tBot T.kData)), sp) + -- 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 + , do (i, sp) <- pIndexSP return (XVar sp (UIx i), sp) -- Variables - , do (var, sp) <- pVarSP + , do (var, sp) <- pVarSP return (XVar sp (UName var), sp) ] "a variable, constructor, or parenthesised type" --- Alternatives --------------------------------------------------------------- +-- Alt -------------------------------------------------------------------------------------------- -- Case alternatives. -pAlt :: Ord n => Context -> Parser n (Alt SourcePos n) +pAlt :: Ord n => Context n -> Parser n (Alt SourcePos n) pAlt c = do p <- pPat c - pTok KArrowDash + pSym SArrowDashRight x <- pExp c return $ AAlt p x -- Patterns. pPat :: Ord n - => Context -> Parser n (Pat n) + => Context n -> Parser n (Pat n) pPat c = P.choice - [ -- Wildcard - do pTok KUnderscore + [ -- Wildcard Pattern: _ + do pSym SUnderscore return $ PDefault -- LIT - , do nLit <- pLit - return $ PData (mkDaConAlg nLit (T.tBot T.kData)) [] + , 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 KDaConUnit + , do pTok (KBuiltin BDaConUnit) return $ PData dcUnit [] -- CON BIND BIND ... , do nCon <- pCon - bs <- P.many (pBindPat c) - return $ PData (mkDaConAlg nCon (T.tBot T.kData)) bs] + 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. -pBindPat +pBinds :: Ord n - => Context -> Parser n (Bind n) -pBindPat c + => Context n -> Parser n [Bind n] +pBinds c = P.choice -- Plain binder. - [ do b <- pBinder - return $ T.makeBindFromBinder b (T.tBot T.kData) + [ do bs <- P.many1 pBinder + return [T.makeBindFromBinder b (T.tBot T.kData) | b <- bs] -- Binder with type, wrapped in parens. - , do pTok KRoundBra - b <- pBinder - pTok KColon + , do pSym SRoundBra + bs <- P.many1 pBinder + pTok (KOp ":") t <- pType c - pTok KRoundKet - return $ T.makeBindFromBinder b t + pSym SRoundKet + return [T.makeBindFromBinder b t | b <- bs] ] --- Bindings ------------------------------------------------------------------- +-- Bindings --------------------------------------------------------------------------------------- +-- | Parse some `Lets`, also returning the source position where they +-- started. pLetsSP :: Ord n - => Context -> Parser n (Lets SourcePos n, SourcePos) + => Context n -> Parser n (Lets SourcePos n, SourcePos) pLetsSP c = P.choice [ -- non-recursive let. - do sp <- pTokSP KLet + do sp <- pTokSP (KKeyword ELet) (b1, x1) <- pLetBinding c return (LLet b1 x1, sp) -- recursive let. - , do sp <- pTokSP KLetRec + , do sp <- pTokSP (KKeyword ELetRec) P.choice -- Multiple bindings in braces - [ do pTok KBraceBra - lets <- P.sepEndBy1 (pLetRecBinding c) (pTok KSemiColon) - pTok KBraceKet + [ do pSym SBraceBra + lets <- P.sepEndBy1 (pLetBinding c) (pSym SSemiColon) + pSym SBraceKet return (LRec lets, sp) -- A single binding without braces. - , do ll <- pLetRecBinding c + , do ll <- pLetBinding c return (LRec [ll], sp) ] - -- Local region binding. - -- letregions [BINDER] with { BINDER : TYPE ... } in EXP - -- letregions [BINDER] in EXP - , do sp <- pTokSP KLetRegions - brs <- P.manyTill pBinder (P.try $ P.lookAhead $ P.choice [pTok KIn, pTok KWith]) + -- 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 - r <- pLetWits c bs - return (r, sp) - - , do sp <- pTokSP KLetRegion - br <- pBinder - let b = T.makeBindFromBinder br T.kRegion - r <- pLetWits c [b] + + -- 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 -> [Bind n] -> Parser n (Lets SourcePos n) + => Context n + -> [Bind n] -> Maybe (Type n) + -> Parser n (Lets SourcePos n) -pLetWits c bs +pLetWits c bs mParent = P.choice - [ do pTok KWith - pTok KBraceBra - wits <- P.sepBy - (do b <- pBinder - pTok KColon - t <- pTypeApp c - return $ T.makeBindFromBinder b t) - (pTok KSemiColon) - pTok KBraceKet - return (LLetRegions bs wits) + [ 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 (LLetRegions bs []) + , do return (LPrivate bs mParent []) ] -- | A binding for let expression. pLetBinding :: Ord n - => Context + => Context n -> Parser n ( Bind n , Exp SourcePos n) pLetBinding c @@ -401,9 +373,9 @@ P.choice [ do -- Binding with full type signature. -- BINDER : TYPE = EXP - pTok KColon + pTok (KOp ":") t <- pType c - pTok KEquals + pSym SEquals xBody <- pExp c return $ (T.makeBindFromBinder b t, xBody) @@ -413,7 +385,7 @@ -- This form can't be used with letrec as we can't use it -- to build the full type sig for the let-bound variable. -- BINDER = EXP - pTok KEquals + pSym SEquals xBody <- pExp c let t = T.tBot T.kData return $ (T.makeBindFromBinder b t, xBody) @@ -425,11 +397,12 @@ P.choice [ do -- Function syntax with a return type. - -- We can make the full type sig for the let-bound variable. + -- We can make the full type sig for the let-bound + -- variable. -- BINDER PARAM1 PARAM2 .. PARAMN : TYPE = EXP - pTok KColon + pTok (KOp ":") tBody <- pType c - sp <- pTokSP KEquals + sp <- pSym SEquals xBody <- pExp c let x = expOfParams sp ps xBody @@ -441,7 +414,7 @@ -- but we can create lambda abstractions with the given -- parameter types. -- BINDER PARAM1 PARAM2 .. PARAMN = EXP - , do sp <- pTokSP KEquals + , do sp <- pSym SEquals xBody <- pExp c let x = expOfParams sp ps xBody @@ -449,44 +422,8 @@ return (T.makeBindFromBinder b t, x) ] ] --- | 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 - => Context - -> Parser n (Bind n, Exp SourcePos n) -pLetRecBinding c - = do b <- pBinder - - P.choice - [ do -- Binding with full type signature. - -- BINDER : TYPE = EXP - pTok KColon - t <- pType c - pTok KEquals - xBody <- pExp c - - return $ (T.makeBindFromBinder b t, xBody) - - - , do -- Binding using function syntax. - -- BINDER PARAM1 PARAM2 .. PARAMN : TYPE = EXP - ps <- liftM concat - $ P.many (pBindParamSpec c) - - pTok KColon - tBody <- pType c - let t = funTypeOfParams c ps tBody - - sp <- pTokSP KEquals - xBody <- pExp c - let x = expOfParams sp ps xBody - - return (T.makeBindFromBinder b t, x) ] - - --- Statements ----------------------------------------------------------------- +-- Stmt ------------------------------------------------------------------------------------------- data Stmt n = StmtBind SourcePos (Bind n) (Exp SourcePos n) | StmtMatch SourcePos (Pat n) (Exp SourcePos n) (Exp SourcePos n) @@ -494,7 +431,7 @@ -- | Parse a single statement. -pStmt :: Ord n => Context -> Parser n (Stmt n) +pStmt :: Ord n => Context n -> Parser n (Stmt n) pStmt c = P.choice [ -- BINDER = EXP ; @@ -503,7 +440,7 @@ -- P.try $ do br <- pBinder - sp <- pTokSP KEquals + sp <- pSym SEquals x1 <- pExp c let t = T.tBot T.kData let b = T.makeBindFromBinder br t @@ -515,27 +452,22 @@ -- as a function name in a non-binding statement. , P.try $ do p <- pPat c - sp <- pTokSP KArrowDashLeft + sp <- pSym SArrowDashLeft x1 <- pExp c - pTok KElse + pTok (KKeyword EElse) x2 <- pExp c return $ StmtMatch sp p x1 x2 -- EXP , do x <- pExp c - - -- This should always succeed because pExp doesn't - -- parse plain types or witnesses - let Just sp = takeAnnotOfExp x - - return $ StmtNone sp x + return $ StmtNone (annotOfExp x) x ] -- | Parse some statements. -pStmts :: Ord n => Context -> Parser n (Exp SourcePos n) +pStmts :: Ord n => Context n -> Parser n (Exp SourcePos n) pStmts c - = do stmts <- P.sepEndBy1 (pStmt c) (pTok KSemiColon) + = do stmts <- P.sepEndBy1 (pStmt c) (pSym SSemiColon) case makeStmts stmts of Nothing -> P.unexpected "do-block must end with a statement" Just x -> return x diff --git a/DDC/Core/Parser/ExportSpec.hs b/DDC/Core/Parser/ExportSpec.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Parser/ExportSpec.hs @@ -0,0 +1,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." + diff --git a/DDC/Core/Parser/ImportSpec.hs b/DDC/Core/Parser/ImportSpec.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Parser/ImportSpec.hs @@ -0,0 +1,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." + diff --git a/DDC/Core/Parser/Module.hs b/DDC/Core/Parser/Module.hs --- a/DDC/Core/Parser/Module.hs +++ b/DDC/Core/Parser/Module.hs @@ -1,130 +1,157 @@ - +{-# OPTIONS -fno-warn-unused-binds #-} module DDC.Core.Parser.Module (pModule) where -import DDC.Core.Module -import DDC.Core.Exp import DDC.Core.Parser.Type import DDC.Core.Parser.Exp import DDC.Core.Parser.Context import DDC.Core.Parser.Base +import DDC.Core.Parser.ExportSpec +import DDC.Core.Parser.ImportSpec +import DDC.Core.Parser.DataDef +import DDC.Core.Module import DDC.Core.Lexer.Tokens -import DDC.Core.Compounds -import DDC.Base.Pretty -import qualified DDC.Base.Parser as P +import DDC.Core.Exp.Annot +import DDC.Data.Pretty +import Data.Char import qualified Data.Map as Map +import qualified Data.Text as T +import qualified DDC.Control.Parser as P --- Module --------------------------------------------------------------------- -- | Parse a core module. pModule :: (Ord n, Pretty n) - => Context + => Context n -> Parser n (Module P.SourcePos n) pModule c - = do sp <- pTokSP KModule + = do sp <- pTokSP (KKeyword EModule) name <- pModuleName - -- exports { SIG;+ } - tExports - <- P.choice - [do pTok KExports - pTok KBraceBra - sigs <- P.sepEndBy1 (pTypeSig c) (pTok KSemiColon) - pTok KBraceKet - return sigs + -- Parse header declarations + heads <- P.many (pHeadDecl c) + let importSpecs_noArity = concat $ [specs | HeadImportSpecs specs <- heads ] + let exportSpecs = concat $ [specs | HeadExportSpecs specs <- heads ] - , return []] + let dataDefsLocal = [def | HeadDataDef def <- heads ] + let typeDefsLocal = [(n, (k, t)) | HeadTypeDef n k t <- heads ] - -- imports { SIG;+ } - tImportKindsTypes - <- P.choice - [do pTok KImports - pTok KBraceBra - importKinds <- P.sepEndBy (pImportKindSpec c) (pTok KSemiColon) - importTypes <- P.sepEndBy (pImportTypeSpec c) (pTok KSemiColon) - pTok KBraceKet - return (importKinds, importTypes) + -- 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 ] - , return ([], [])] + let attachAritySpec (ImportForeignValue n (ImportValueModule mn v t _)) + = ImportForeignValue n (ImportValueModule mn v t (Map.lookup n importArities)) - let (tImportKinds, tImportTypes) - = tImportKindsTypes + attachAritySpec spec = spec - pTok KWith + let importSpecs + = map attachAritySpec importSpecs_noArity - -- LET;+ - lts <- P.sepBy1 (pLetsSP c) (pTok KIn) + -- 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) - -- ISSUE #295: Check for duplicate exported names in module parser. - -- The names are added to a unique map, so later ones with the same - -- name will replace earlier ones. return $ ModuleCore { moduleName = name - , moduleExportKinds = Map.empty - , moduleExportTypes = Map.fromList tExports - , moduleImportKinds = Map.fromList tImportKinds - , moduleImportTypes = Map.fromList tImportTypes + , 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 } --- | Parse a type signature. -pTypeSig - :: Ord n - => Context -> Parser n (n, Type n) +--------------------------------------------------------------------------------------------------- +-- | Wrapper for a declaration that can appear in the module header. +data HeadDecl n + -- | Import specifications. + = HeadImportSpecs [ImportSpec n] -pTypeSig c - = do var <- pVar - pTok KColonColon - t <- pType c - return (var, t) + -- | Export specifications. + | HeadExportSpecs [ExportSpec n] + -- | Data type definitions. + | HeadDataDef (DataDef n) --- | Parse the type signature of an imported variable. -pImportKindSpec - :: (Ord n, Pretty n) - => Context -> Parser n (n, (QualName n, Kind n)) + -- | Type equations. + | HeadTypeDef n (Kind n) (Type n) -pImportKindSpec c - = pTok KType - >> P.choice - [ -- Import with an explicit external name. - -- Module.varExternal with varLocal - do qn <- pQualName - pTok KWith - n <- pName - pTok KColonColon - k <- pType c - return (n, (qn, k)) + -- | Arity pragmas. + -- Number of type parameters, value parameters, and boxes for some super. + | HeadPragmaArity n Int Int Int - , do n <- pName - pTok KColonColon - k <- pType c - return (n, (QualName (ModuleName []) n, k)) - ] +-- | Parse one of the declarations that can appear in a module header. +pHeadDecl :: (Ord n, Pretty n) + => Context n -> Parser n (HeadDecl n) --- | Parse the type signature of an imported variable. -pImportTypeSpec - :: (Ord n, Pretty n) - => Context -> Parser n (n, (QualName n, Type n)) +pHeadDecl ctx + = P.choice + [ do imports <- pImportSpecs ctx + return $ HeadImportSpecs imports -pImportTypeSpec c - = P.choice - [ -- Import with an explicit external name. - -- Module.varExternal with varLocal - do qn <- pQualName - pTok KWith + , 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 - pTok KColonColon + pTokSP (KOp ":") + k <- pType c + pSym SEquals t <- pType c - return (n, (qn, t)) + pSym SSemiColon + return (n, k, t) - , do n <- pName - pTok KColonColon - t <- pType c - return (n, (QualName (ModuleName []) n, 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 ++ "#-}" diff --git a/DDC/Core/Parser/Param.hs b/DDC/Core/Parser/Param.hs --- a/DDC/Core/Parser/Param.hs +++ b/DDC/Core/Parser/Param.hs @@ -3,15 +3,16 @@ ( ParamSpec (..) , funTypeOfParams , expOfParams - , pBindParamSpec) + , pBindParamSpecAnnot + , pBindParamSpec ) where import DDC.Core.Exp import DDC.Core.Parser.Type import DDC.Core.Parser.Context -import DDC.Core.Parser.Base (Parser) +import DDC.Core.Parser.Base import DDC.Core.Lexer.Tokens -import qualified DDC.Base.Parser as P -import qualified DDC.Type.Compounds as T +import qualified DDC.Type.Exp.Simple as T +import qualified DDC.Control.Parser as P -- | Specification of a function parameter. @@ -47,7 +48,7 @@ -- | Build the type of a function from specifications of its parameters, -- and the type of the body. funTypeOfParams - :: Context + :: Context n -> [ParamSpec n] -- ^ Spec of parameters. -> Type n -- ^ Type of body. -> Type n -- ^ Type of whole function. @@ -65,70 +66,87 @@ -> T.tImpl (T.typeOfBind b) $ funTypeOfParams c ps tBody - ParamValue b eff clo - | contextFunctionalEffects c - , contextFunctionalClosures c - -> T.tFunEC (T.typeOfBind b) eff clo - $ funTypeOfParams c ps tBody - - | otherwise + ParamValue b _eff _clo -> T.tFun (T.typeOfBind b) $ funTypeOfParams c ps tBody --- | Parse a parameter specification. --- +-- | 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 } -- -pBindParamSpec +pBindParamSpecAnnot :: Ord n - => Context -> Parser n [ParamSpec n] + => Context n -> Parser n [ParamSpec n] -pBindParamSpec c +pBindParamSpecAnnot c = P.choice -- Type parameter -- [BIND1 BIND2 .. BINDN : TYPE] - [ do pTok KSquareBra + [ do pSym SSquareBra bs <- P.many1 pBinder - pTok KColon + pTok (KOp ":") t <- pType c - pTok KSquareKet + pSym SSquareKet return [ ParamType b | b <- zipWith T.makeBindFromBinder bs (repeat t)] - -- Witness parameter - -- - , do pTok KAngleBra + -- {BIND : TYPE} + , do pSym SBraceBra b <- pBinder - pTok KColon + pTok (KOp ":") t <- pType c - pTok KAngleKet + pSym SBraceKet return [ ParamWitness $ T.makeBindFromBinder b t] - -- Value parameter - -- (BIND : TYPE) - -- (BIND : TYPE) { TYPE | TYPE } - , do pTok KRoundBra - b <- pBinder - pTok KColon + -- 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 - pTok KRoundKet + pSym SRoundKet (eff, clo) <- P.choice - [ do pTok KBraceBra + [ do pSym SBraceBra eff' <- pType c - pTok KBar + pSym SBar clo' <- pType c - pTok KBraceKet + 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) eff clo] + return $ [ ParamValue (T.makeBindFromBinder b t) + (T.tBot T.kEffect) (T.tBot T.kClosure) + | b <- reverse bsInit] + ++ [ ParamValue (T.makeBindFromBinder bLast t) eff clo] ] diff --git a/DDC/Core/Parser/Type.hs b/DDC/Core/Parser/Type.hs --- a/DDC/Core/Parser/Type.hs +++ b/DDC/Core/Parser/Type.hs @@ -12,16 +12,15 @@ import DDC.Core.Parser.Context import DDC.Core.Parser.Base import DDC.Core.Lexer.Tokens -import DDC.Type.Exp -import DDC.Type.Compounds -import DDC.Base.Parser (()) -import qualified DDC.Base.Parser as P +import DDC.Type.Exp.Simple +import DDC.Control.Parser (()) +import qualified DDC.Control.Parser as P import qualified DDC.Type.Sum as TS -- | Parse a type. pType :: Ord n - => Context -> Parser n (Type n) + => Context n -> Parser n (Type n) pType c = pTypeSum c @@ -31,13 +30,13 @@ -- | Parse a type sum. pTypeSum :: Ord n - => Context -> Parser n (Type n) + => Context n -> Parser n (Type n) pTypeSum c = do t1 <- pTypeForall c P.choice [ -- Type sums. -- T2 + T3 - do pTok KPlus + do pTok (KOp "+") t2 <- pTypeSum c return $ TSum $ TS.fromList (tBot sComp) [t1, t2] @@ -54,11 +53,11 @@ return $ RName v -- Anonymous binders. - , do pTok KHat + , do pSym SHat return $ RAnon -- Vacant binders. - , do pTok KUnderscore + , do pSym SUnderscore return $ RNone ] "a binder" @@ -66,17 +65,29 @@ -- | Parse a quantified type. pTypeForall :: Ord n - => Context -> Parser n (Type n) + => Context n -> Parser n (Type n) pTypeForall c = P.choice - [ -- Universal quantification. + [ -- Type abstraction. + do pSym SLambda + bs <- P.many1 pBinder + pTok (KOp ":") + k <- pTypeSum c + pSym SDot + + tBody <- pTypeForall c + + return $ foldr TAbs tBody + $ map (\b -> makeBindFromBinder b k) bs + + -- Universal quantification. -- [v1 v1 ... vn : T1]. T2 - do pTok KSquareBra + , do pSym SSquareBra bs <- P.many1 pBinder - pTok KColon + pTok (KOp ":") k <- pTypeSum c - pTok KSquareKet - pTok KDot + pSym SSquareKet + pSym SDot body <- pTypeForall c @@ -91,40 +102,25 @@ -- | Parse a function type. pTypeFun :: Ord n - => Context -> Parser n (Type n) + => Context n -> Parser n (Type n) pTypeFun c = do t1 <- pTypeApp c P.choice [ -- T1 ~> T2 - do pTok KArrowTilde - t2 <- pTypeFun c + do pSym SArrowTilde + t2 <- pTypeForall c return $ TApp (TApp (TCon (TyConKind KiConFun)) t1) t2 -- T1 => T2 - , do pTok KArrowEquals - t2 <- pTypeFun c + , do pSym SArrowEquals + t2 <- pTypeForall c return $ TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2 -- T1 -> T2 - , do pTok KArrowDash - t2 <- pTypeFun c - if ( contextFunctionalEffects c - && contextFunctionalClosures c) - then return $ t1 `tFunPE` t2 - else return $ t1 `tFun` t2 - - -- T1 -(TSUM | TSUM)> t2 - , do pTok KDash - pTok KRoundBra - eff <- pTypeSum c - pTok KBar - clo <- pTypeSum c - pTok KRoundKet - pTok KAngleKet - t2 <- pTypeFun c - return $ tFunEC t1 eff clo t2 - + , do pSym SArrowDashRight + t2 <- pTypeForall c + return $ t1 `tFun` t2 -- Body type , do return t1 ] @@ -134,7 +130,7 @@ -- | Parse a type application. pTypeApp :: Ord n - => Context -> Parser n (Type n) + => Context n -> Parser n (Type n) pTypeApp c = do (t:ts) <- P.many1 (pTypeAtom c) return $ foldl TApp t ts @@ -144,35 +140,27 @@ -- | Parse a variable, constructor or parenthesised type. pTypeAtom :: Ord n - => Context -> Parser n (Type n) + => Context n -> Parser n (Type n) pTypeAtom c = P.choice -- (~>) and (=>) and (->) and (TYPE2) - [ 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 (KOpVar "~>") + return (TCon $ TyConKind KiConFun) - , do pTok KArrowDash - pTok KRoundKet + -- (=>) + , do pTok (KOpVar "=>") + return (TCon $ TyConWitness TwConImpl) - -- Decide what type constructor to use for the (->) token. - -- Only use the function constructor with latent effects - -- and closures if the language fragment supports both. - if ( contextFunctionalEffects c - && contextFunctionalClosures c) - then return (TCon $ TyConSpec TcConFunEC) - else return (TCon $ TyConSpec TcConFun) + -- (->) + , do pTok (KOpVar "->") + return (TCon $ TyConSpec TcConFun) - , do t <- pTypeSum c - pTok KRoundKet - return t - ] + -- (TYPE2) + , do pSym SRoundBra + t <- pTypeSum c + pSym SRoundKet + return t -- Named type constructors , do so <- pSoCon @@ -191,8 +179,8 @@ return $ TCon tc -- Bottoms. - , do pTokAs KBotEffect (tBot kEffect) - , do pTokAs KBotClosure (tBot kClosure) + , do pTokAs (KBuiltin BPure) (tBot kEffect) + , do pTokAs (KBuiltin BEmpty) (tBot kClosure) -- Bound occurrence of a variable. -- We don't know the kind of this variable yet, so fill in the @@ -202,7 +190,7 @@ return $ TVar (UName v) , do i <- pIndex - return $ TVar (UIx (fromIntegral i)) + return $ TVar (UIx i) ] "an atomic type" @@ -212,32 +200,32 @@ pSoCon :: Parser n SoCon pSoCon = P.pTokMaybe f "a sort constructor" - where f (KA (KSoConBuiltin c)) = Just c - f _ = Nothing + where f (KA (KBuiltin (BSoCon c))) = Just c + f _ = Nothing -- | Parse a builtin kind constructor. pKiCon :: Parser n KiCon pKiCon = P.pTokMaybe f "a kind constructor" - where f (KA (KKiConBuiltin c)) = Just c - f _ = Nothing + where f (KA (KBuiltin (BKiCon c))) = Just c + f _ = Nothing -- | Parse a builtin type constructor. pTcCon :: Parser n TcCon pTcCon = P.pTokMaybe f "a type constructor" - where f (KA (KTcConBuiltin c)) = Just c - f _ = Nothing + where f (KA (KBuiltin (BTcCon c))) = Just c + f _ = Nothing -- | Parse a builtin witness type constructor. pTwCon :: Parser n TwCon pTwCon = P.pTokMaybe f "a witness constructor" - where f (KA (KTwConBuiltin c)) = Just c - f _ = Nothing + where f (KA (KBuiltin (BTwCon c))) = Just c + f _ = Nothing -- | Parse a user defined type constructor. diff --git a/DDC/Core/Parser/Witness.hs b/DDC/Core/Parser/Witness.hs --- a/DDC/Core/Parser/Witness.hs +++ b/DDC/Core/Parser/Witness.hs @@ -9,38 +9,34 @@ import DDC.Core.Parser.Base import DDC.Core.Lexer.Tokens import DDC.Core.Exp -import DDC.Base.Parser ((), SourcePos) -import qualified DDC.Base.Parser as P -import qualified DDC.Type.Compounds as T +import DDC.Control.Parser ((), SourcePos) +import qualified DDC.Control.Parser as P +import qualified DDC.Type.Exp.Simple as T import Control.Monad -- | Parse a witness expression. pWitness :: Ord n - => Context -> Parser n (Witness SourcePos n) + => Context n -> Parser n (Witness SourcePos n) pWitness c = pWitnessJoin c -- | Parse a witness join. pWitnessJoin :: Ord n - => Context -> Parser n (Witness SourcePos n) + => Context n -> Parser n (Witness SourcePos n) pWitnessJoin c -- WITNESS or WITNESS & WITNESS = do w1 <- pWitnessApp c P.choice - [ do sp <- pTokSP KAmpersand - w2 <- pWitnessJoin c - return (WJoin sp w1 w2) - - , do return w1 ] + [ do return w1 ] -- | Parse a witness application. pWitnessApp :: Ord n - => Context -> Parser n (Witness SourcePos n) + => Context n -> Parser n (Witness SourcePos n) pWitnessApp c = do (x:xs) <- P.many1 (pWitnessArgSP c) @@ -55,14 +51,14 @@ -- | Parse a witness argument. pWitnessArgSP :: Ord n - => Context -> Parser n (Witness SourcePos n, SourcePos) + => Context n -> Parser n (Witness SourcePos n, SourcePos) pWitnessArgSP c = P.choice [ -- [TYPE] - do sp <- pTokSP KSquareBra + do sp <- pSym SSquareBra t <- pType c - pTok KSquareKet + pSym SSquareKet return (WType sp t, sp) -- WITNESS @@ -73,7 +69,7 @@ -- | Parse a variable, constructor or parenthesised witness. pWitnessAtom :: Ord n - => Context -> Parser n (Witness SourcePos n) + => Context n -> Parser n (Witness SourcePos n) pWitnessAtom c = liftM fst (pWitnessAtomSP c) @@ -83,24 +79,19 @@ -- also returning source position. pWitnessAtomSP :: Ord n - => Context -> Parser n (Witness SourcePos n, SourcePos) + => Context n -> Parser n (Witness SourcePos n, SourcePos) pWitnessAtomSP c = P.choice -- (WITNESS) - [ do sp <- pTokSP KRoundBra + [ do sp <- pSym SRoundBra w <- pWitness c - pTok KRoundKet + pSym SRoundKet return (w, sp) -- Named constructors , do (con, sp) <- pConSP return (WCon sp (WiConBound (UName con) (T.tBot T.kWitness)), sp) - - -- Baked-in witness constructors. - , do (wb, sp) <- pWbConSP - return (WCon sp (WiConBuiltin wb), sp) - -- Debruijn indices , do (i, sp) <- pIndexSP diff --git a/DDC/Core/Predicates.hs b/DDC/Core/Predicates.hs deleted file mode 100644 --- a/DDC/Core/Predicates.hs +++ /dev/null @@ -1,131 +0,0 @@ - --- | Simple predicates on core expressions. -module DDC.Core.Predicates - ( module DDC.Type.Predicates - - -- * Atoms - , isXVar, isXCon - , isAtomX, isAtomW - - -- * Lambdas - , isXLAM, isXLam - , isLambdaX - - -- * Applications - , isXApp - - -- * Let bindings - , isXLet - - -- * Types and Witnesses - , isXType - , isXWitness - - -- * Patterns - , isPDefault) -where -import DDC.Core.Exp -import DDC.Type.Predicates - - --- Atoms ---------------------------------------------------------------------- --- | Check whether an expression is a variable. -isXVar :: Exp a n -> Bool -isXVar xx - = case xx of - XVar{} -> True - _ -> False - - --- | Check whether an expression is a constructor. -isXCon :: Exp a n -> Bool -isXCon xx - = case xx of - XCon{} -> True - _ -> False - - --- | Check whether an expression is a `XVar` or an `XCon`, --- or some type or witness atom. -isAtomX :: Exp a n -> Bool -isAtomX xx - = case xx of - XVar{} -> True - XCon{} -> True - XType t -> isAtomT t - XWitness w -> isAtomW w - _ -> False - - --- | Check whether a witness is a `WVar` or `WCon`. -isAtomW :: Witness a n -> Bool -isAtomW ww - = case ww of - WVar{} -> True - WCon{} -> True - _ -> False - - --- Lambdas -------------------------------------------------------------------- --- | Check whether an expression is a spec abstraction (level-1). -isXLAM :: Exp a n -> Bool -isXLAM xx - = case xx of - XLAM{} -> True - _ -> False - - --- | Check whether an expression is a value or witness abstraction (level-0). -isXLam :: Exp a n -> Bool -isXLam xx - = case xx of - XLam{} -> True - _ -> False - - --- | Check whether an expression is a spec, value, or witness abstraction. -isLambdaX :: Exp a n -> Bool -isLambdaX xx - = isXLAM xx || isXLam xx - - --- Applications --------------------------------------------------------------- --- | Check whether an expression is an `XApp`. -isXApp :: Exp a n -> Bool -isXApp xx - = case xx of - XApp{} -> True - _ -> False - - --- Let Bindings --------------------------------------------------------------- -isXLet :: Exp a n -> Bool -isXLet xx - = case xx of - XLet{} -> True - _ -> False - - --- Type and Witness ----------------------------------------------------------- --- | Check whether an expression is an `XType` -isXType :: Exp a n -> Bool -isXType xx - = case xx of - XType{} -> True - _ -> False - - --- | Check whether an expression is an `XWitness` -isXWitness :: Exp a n -> Bool -isXWitness xx - = case xx of - XWitness{} -> True - _ -> False - - --- Patterns ------------------------------------------------------------------- --- | Check whether an alternative is a `PDefault`. -isPDefault :: Pat n -> Bool -isPDefault PDefault = True -isPDefault _ = False - diff --git a/DDC/Core/Pretty.hs b/DDC/Core/Pretty.hs --- a/DDC/Core/Pretty.hs +++ b/DDC/Core/Pretty.hs @@ -1,340 +1,251 @@ +{-# LANGUAGE TypeFamilies #-} --- | Provides pretty printing for core modules and expressions. +-- | 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.Compounds -import DDC.Core.Predicates import DDC.Core.Module -import DDC.Core.Exp -import DDC.Type.Pretty -import DDC.Base.Pretty +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 qualified Data.Map.Strict as Map +import Prelude hiding ((<$>)) --- ModuleName ----------------------------------------------------------------- +-- ModuleName ------------------------------------------------------------------------------------- instance Pretty ModuleName where ppr (ModuleName parts) = text $ intercalate "." parts --- Module --------------------------------------------------------------------- +-- Module ----------------------------------------------------------------------------------------- instance (Pretty n, Eq n) => Pretty (Module a n) where - ppr ModuleCore + data PrettyMode (Module a n) + = PrettyModeModule + { modeModuleLets :: PrettyMode (Lets a n) + , modeModuleSuppressImports :: Bool + , modeModuleSuppressExports :: Bool } + + pprDefaultMode + = PrettyModeModule + { modeModuleLets = pprDefaultMode + , modeModuleSuppressImports = False + , modeModuleSuppressExports = False } + + pprModePrec mode _ + ModuleCore { moduleName = name - , moduleExportKinds = exportKinds , moduleExportTypes = exportTypes - , moduleImportKinds = importKinds + , 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 - - docsExportKinds - | Map.null exportKinds = empty - | otherwise - = nest 8 $ line - <> vcat [ text "type" <+> ppr n <+> text "::" <+> ppr t <> semi - | (n, t) <- Map.toList exportKinds ] - - docsExportTypes - | Map.null exportTypes = empty - | otherwise - = nest 8 $ line - <> vcat [ ppr n <+> text "::" <+> ppr t <> semi - | (n, t) <- Map.toList exportTypes ] - - docsImportKinds - | Map.null importKinds = empty - | otherwise - = nest 8 $ line - <> vcat [ text "type" <+> ppr n <+> text "::" <+> ppr t <> semi - | (n, (_, t)) <- Map.toList importKinds ] - - docsImportTypes - | Map.null importTypes = empty - | otherwise - = nest 8 $ line - <> vcat [ ppr n <+> text "::" <+> ppr t <> semi - | (n, (_, t)) <- Map.toList importTypes ] - - in text "module" <+> ppr name - <+> (if Map.null exportKinds && Map.null exportTypes - then empty - else line - <> text "exports" <+> lbrace - <> docsExportKinds - <> docsExportTypes - <> line - <> rbrace <> space) - - <> (if Map.null importKinds && Map.null importTypes - then empty - else line - <> text "imports" <+> lbrace - <> docsImportKinds - <> docsImportTypes - <> line - <> rbrace <> space) - <> text "with" <$$> (vcat $ map ppr lts) - - --- Exp ------------------------------------------------------------------------ -instance (Pretty n, Eq n) => Pretty (Exp a n) where - pprPrec d xx - = {-# SCC "ppr[Exp]" #-} - case xx of - XVar _ u -> ppr u - XCon _ dc -> ppr dc + (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 - - XApp _ x1 x2 - -> pprParen' (d > 10) - $ pprPrec 10 x1 - <> nest 4 (breakWhen (not $ isSimpleX x2) - <> pprPrec 11 x2) + -- Exports -------------------- + dExportTypes + | null $ exportTypes = empty + | otherwise = (vcat $ map pprExportType exportTypes) <> line - XLet _ lts x - -> pprParen' (d > 2) - $ ppr lts <+> text "in" - <$> ppr x + dExportValues + | null $ exportValues = empty + | otherwise = (vcat $ map pprExportValue exportValues) <> line - XCase _ x1 [AAlt p x2] - -> pprParen' (d > 2) - $ text "caselet" <+> ppr p - <+> nest 2 (breakWhen (not $ isSimpleX x1) - <> text "=" <+> align (ppr x1)) - <+> text "in" - <$> ppr x2 + -- 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 _ CastSuspend x - -> pprParen' (d > 2) - $ text "suspend" <$> ppr x + dImportValues + | null $ importValues = empty + | otherwise = (vcat $ map pprImportValue importValues) <> line - XCast _ CastRun x - -> pprParen' (d > 2) - $ text "run" <+> ppr x + 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 - XCast _ cc x - -> pprParen' (d > 2) - $ ppr cc <+> text "in" - <$> ppr x + | otherwise + = line <> dExportTypes <> dExportValues + <> dImportTypes <> dImportCaps <> dImportValues + + -- Data Definitions ----- + docsDataImport + | null importData = empty + | otherwise + = line <> vsep (map (\i -> text "import" <+> ppr i) $ importData) - XType t -> text "[" <> ppr t <> text "]" - XWitness w -> text "<" <> ppr w <> text ">" + 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) --- 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) + docsTypeLocal + | null localType = empty + | otherwise + = line <> vsep (map pprTypeDef localType) + pprLts = pprModePrec (modeModuleLets mode) 0 --- | 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 + in text "module" <+> ppr name + <+> docsImportsExports + <> docsDataImport + <> docsDataLocal + <> docsTypeImport + <> docsTypeLocal + <> (case lts of + [] -> empty + [LRec[]] -> empty + _ -> text "with" <$$> (vcat $ map pprLts lts)) --- 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)) - +-- 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 --- DaCon ---------------------------------------------------------------------- -instance (Pretty n, Eq n) => Pretty (DaCon n) where - ppr dc - = case daConName dc of - DaConUnit -> text "()" - DaConNamed n -> ppr n + ExportSourceLocalNoType _n + -> text "export type" <+> padL 10 (ppr n) <> semi --- Cast ----------------------------------------------------------------------- -instance (Pretty n, Eq n) => Pretty (Cast a n) where - ppr cc - = case cc of - CastWeakenEffect eff - -> text "weakeff" <+> brackets (ppr eff) - - CastWeakenClosure xs - -> text "weakclo" - <+> braces (hcat $ punctuate (semi <> space) - $ map ppr xs) - - CastPurify w - -> text "purify" <+> angles (ppr w) - - CastForget w - -> text "forget" <+> angles (ppr w) - - CastSuspend - -> text "suspend" +-- | 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 - CastRun - -> text "run" + ExportSourceLocalNoType _n + -> text "export value" <+> padL 10 (ppr n) <> semi --- Lets ----------------------------------------------------------------------- -instance (Pretty n, Eq n) => Pretty (Lets a n) where - ppr lts - = case lts of - LLet b x - -> let dBind = if isBot (typeOfBind b) - then ppr (binderOfBind b) - else ppr b - in text "let" - <+> align ( dBind - <> nest 2 ( breakWhen (not $ isSimpleX x) - <> text "=" <+> align (ppr x))) - - 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 - - - LLetRegions [b] [] - -> text "letregion" - <+> ppr (binderOfBind b) - - LLetRegions [b] bs - -> text "letregion" - <+> ppr (binderOfBind b) - <+> text "with" - <+> braces (cat $ punctuate (text "; ") $ map ppr bs) - - LLetRegions b [] - -> text "letregions" - <+> (hcat $ punctuate space (map (ppr . binderOfBind) b)) - - LLetRegions b bs - -> text "letregions" - <+> (hcat $ punctuate space (map (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 --- Witness -------------------------------------------------------------------- -instance (Pretty n, Eq n) => Pretty (Witness a n) where - pprPrec d ww - = case ww of - WVar _ n -> ppr n - WCon _ wc -> ppr wc - - WApp _ w1 w2 - -> pprParen (d > 10) (ppr w1 <+> pprPrec 11 w2) - - WJoin _ w1 w2 - -> pprParen (d > 9) (ppr w1 <+> text "&" <+> ppr w2) - - WType _ t -> text "[" <> ppr t <> text "]" +-- | 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 -instance (Pretty n, Eq n) => Pretty (WiCon n) where - ppr wc - = case wc of - WiConBuiltin wb -> ppr wb - WiConBound u _ -> ppr u +-- | 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 + 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 ] -instance Pretty WbCon where - ppr wb - = case wb of - WbConPure -> text "pure" - WbConEmpty -> text "empty" - WbConUse -> text "use" - WbConRead -> text "read" - WbConAlloc -> text "alloc" + ImportValueSea _var t + -> text "import foreign c value" <> line + <> indent 8 (padL 15 (ppr n) <+> text ":" <+> ppr t <> semi) + <> line --- Binder --------------------------------------------------------------------- -pprBinder :: Pretty n => Binder n -> Doc -pprBinder bb - = case bb of - RName v -> ppr v - RAnon -> text "^" - RNone -> text "_" +-- DataDef ---------------------------------------------------------------------------------------- +instance (Pretty n, Eq n) => Pretty (DataDef n) where + pprPrec _ def = pprDataDef def --- | 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 - +-- | 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 diff --git a/DDC/Core/Transform/Annotate.hs b/DDC/Core/Transform/Annotate.hs deleted file mode 100644 --- a/DDC/Core/Transform/Annotate.hs +++ /dev/null @@ -1,92 +0,0 @@ - -module DDC.Core.Transform.Annotate - (Annotate (..)) -where -import qualified DDC.Core.Exp.Annot as A -import qualified DDC.Core.Exp.Simple as S - - --- | Convert the `Simple` version of the AST to the `Annot` version, --- using a the provided default annotation value. -class Annotate - (c1 :: * -> * -> *) - (c2 :: * -> * -> *) | c1 -> c2 - where - annotate :: a -> c1 a n -> c2 a n - - -instance Annotate S.Exp A.Exp where - annotate def xx - = let down = annotate def - in case xx of - S.XAnnot _ (S.XAnnot a x) -> down (S.XAnnot a x) - S.XAnnot a (S.XVar u) -> A.XVar a u - S.XAnnot a (S.XCon dc) -> A.XCon a dc - S.XAnnot a (S.XLAM b x) -> A.XLAM a b (down x) - S.XAnnot a (S.XLam b x) -> A.XLam a b (down x) - S.XAnnot a (S.XApp x1 x2) -> A.XApp a (down x1) (down x2) - S.XAnnot a (S.XLet lts x) -> A.XLet a (down lts) (down x) - S.XAnnot a (S.XCase x alts) -> A.XCase a (down x) (map down alts) - S.XAnnot a (S.XCast c x) -> A.XCast a (down c) (down x) - S.XAnnot _ (S.XType t) -> A.XType t - S.XAnnot _ (S.XWitness w) -> A.XWitness (down w) - - S.XVar u -> A.XVar def u - S.XCon dc -> A.XCon def dc - S.XLAM b x -> A.XLAM def b (down x) - S.XLam b x -> A.XLam def b (down x) - S.XApp x1 x2 -> A.XApp def (down x1) (down x2) - S.XLet lts x -> A.XLet def (down lts) (down x) - S.XCase x alts -> A.XCase def (down x) (map down alts) - S.XCast c x -> A.XCast def (down c) (down x) - S.XType t -> A.XType t - S.XWitness w -> A.XWitness (down w) - - -instance Annotate S.Cast A.Cast where - annotate def cc - = let down = annotate def - in case cc of - S.CastWeakenEffect eff -> A.CastWeakenEffect eff - S.CastWeakenClosure clo -> A.CastWeakenClosure (map down clo) - S.CastPurify w -> A.CastPurify (down w) - S.CastForget w -> A.CastForget (down w) - S.CastSuspend -> A.CastSuspend - S.CastRun -> A.CastRun - - -instance Annotate S.Lets A.Lets where - annotate def lts - = let down = annotate def - in case lts of - S.LLet b x -> A.LLet b (down x) - S.LRec bxs -> A.LRec [(b, down x) | (b, x) <- bxs] - S.LLetRegions bks bts -> A.LLetRegions bks bts - S.LWithRegion u -> A.LWithRegion u - - -instance Annotate S.Alt A.Alt where - annotate def alt - = let down = annotate def - in case alt of - S.AAlt w x -> A.AAlt w (down x) - - -instance Annotate S.Witness A.Witness where - annotate def wit - = let down = annotate def - in case wit of - S.WAnnot _ (S.WAnnot a x) -> down (S.WAnnot a x) - S.WAnnot a (S.WVar u) -> A.WVar a u - S.WAnnot a (S.WCon wc) -> A.WCon a wc - S.WAnnot a (S.WApp w1 w2) -> A.WApp a (down w1) (down w2) - S.WAnnot a (S.WJoin w1 w2) -> A.WJoin a (down w1) (down w2) - S.WAnnot a (S.WType t) -> A.WType a t - - S.WVar u -> A.WVar def u - S.WCon dc -> A.WCon def dc - S.WApp x1 x2 -> A.WApp def (down x1) (down x2) - S.WJoin x1 x2 -> A.WJoin def (down x1) (down x2) - S.WType t -> A.WType def t - - diff --git a/DDC/Core/Transform/BoundT.hs b/DDC/Core/Transform/BoundT.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Transform/BoundT.hs @@ -0,0 +1,89 @@ + +-- | Lifting and lowering level-1 deBruijn indices in code things. +-- +-- Level-1 indices are used for type variables. +-- +module DDC.Core.Transform.BoundT + ( liftT, liftAtDepthT + , MapBoundT(..)) +where +import DDC.Core.Exp.Annot.Exp +import DDC.Type.Transform.BoundT + + +instance Ord n => MapBoundT (Exp a) n where + mapBoundAtDepthT f d xx + = let down = mapBoundAtDepthT f d + in case xx of + XVar a u -> XVar a u + XCon{} -> xx + XApp a x1 x2 -> XApp a (down x1) (down x2) + XLAM a b x -> XLAM a b (mapBoundAtDepthT f (d + countBAnons [b]) x) + XLam a b x -> XLam a (down b) (down x) + + XLet a lets x + -> let (lets', levels) = mapBoundAtDepthTLets f d lets + in XLet a lets' (mapBoundAtDepthT f (d + levels) x) + + XCase a x alts -> XCase a (down x) (map down alts) + XCast a cc x -> XCast a (down cc) (down x) + XType a t -> XType a (down t) + XWitness a w -> XWitness a (down w) + + +instance Ord n => MapBoundT (Witness a) n where + mapBoundAtDepthT f d ww + = let down = mapBoundAtDepthT f d + in case ww of + WVar a u -> WVar a (down u) + WCon _ _ -> ww + WApp a w1 w2 -> WApp a (down w1) (down w2) + WType a t -> WType a (down t) + + +instance Ord n => MapBoundT (Cast a) n where + mapBoundAtDepthT f d cc + = let down = mapBoundAtDepthT f d + in case cc of + CastWeakenEffect t -> CastWeakenEffect (down t) + CastPurify w -> CastPurify (down w) + CastBox -> CastBox + CastRun -> CastRun + + +instance Ord n => MapBoundT (Alt a) n where + mapBoundAtDepthT f d (AAlt p x) + = let down = mapBoundAtDepthT f d + in case p of + PDefault -> AAlt PDefault (down x) + PData dc bs -> AAlt (PData dc (map down bs)) (down x) + + +mapBoundAtDepthTLets + :: Ord n + => (Int -> Bound n -> Bound n) -- ^ Number of levels to lift. + -> Int -- ^ Current binding depth. + -> Lets a n -- ^ Lift exp indices in this thing. + -> (Lets a n, Int) -- ^ Lifted, and how much to increase depth by + +mapBoundAtDepthTLets f d lts + = let down = mapBoundAtDepthT f d + in case lts of + LLet b x + -> ( LLet (down b) (down x) + , 0) + + LRec bs + -> let bs' = [ (b, mapBoundAtDepthT f d x) | (b, x) <- bs ] + in (LRec bs', 0) + + LPrivate bsT mT bsX + -> let inc = countBAnons bsT + bsX' = map (mapBoundAtDepthT f (d + inc)) bsX + in ( LPrivate bsT mT bsX' + , inc) + + +countBAnons = length . filter isAnon + where isAnon (BAnon _) = True + isAnon _ = False diff --git a/DDC/Core/Transform/BoundX.hs b/DDC/Core/Transform/BoundX.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Transform/BoundX.hs @@ -0,0 +1,166 @@ + +-- | Lifting and lowering level-0 deBruijn indices in core things. +-- +-- Level-0 indices are used for both value and witness variables. +-- +module DDC.Core.Transform.BoundX + ( liftX, liftAtDepthX + , lowerX, lowerAtDepthX + , MapBoundX(..)) +where +import DDC.Core.Exp + + +-- Lift ----------------------------------------------------------------------- +-- | Lift debruijn indices less than or equal to the given depth. +liftAtDepthX + :: MapBoundX c n + => Int -- ^ Number of levels to lift. + -> Int -- ^ Current binding depth. + -> c n -- ^ Lift expression indices in this thing. + -> c n + +liftAtDepthX n d + = {-# SCC liftAtDepthX #-} + mapBoundAtDepthX liftU d + where + liftU d' u + = case u of + UName{} -> u + UPrim{} -> u + UIx i + | d' <= i -> UIx (i + n) + | otherwise -> u + + +-- | Wrapper for `liftAtDepthX` that starts at depth 0. +liftX :: MapBoundX c n => Int -> c n -> c n +liftX n xx = liftAtDepthX n 0 xx + + +-- Lower ---------------------------------------------------------------------- +-- | Lower debruijn indices less than or equal to the given depth. +lowerAtDepthX + :: MapBoundX c n + => Int -- ^ Number of levels to lower. + -> Int -- ^ Current binding depth. + -> c n -- ^ Lower expression indices in this thing. + -> c n + +lowerAtDepthX n d + = {-# SCC lowerAtDepthX #-} + mapBoundAtDepthX liftU d + where + liftU d' u + = case u of + UName{} -> u + UPrim{} -> u + UIx i + | d' <= i -> UIx (i - n) + | otherwise -> u + + +-- | Wrapper for `lowerAtDepthX` that starts at depth 0. +lowerX :: MapBoundX c n => Int -> c n -> c n +lowerX n xx = lowerAtDepthX n 0 xx + + +-- MapBoundX ------------------------------------------------------------------ +class MapBoundX (c :: * -> *) n where + -- | Apply a function to all bound variables in the program. + -- The function is passed the current binding depth. + -- This is used to defined both `liftX` and `lowerX`. + mapBoundAtDepthX + :: (Int -> Bound n -> Bound n) + -- ^ Function to apply to the bound occ. + -- It is passed the current binding depth. + -> Int -- ^ Current binding depth. + -> c n -- ^ Lift expression indices in this thing. + -> c n + + +instance MapBoundX Bound n where + mapBoundAtDepthX f d u + = f d u + + +instance MapBoundX (Exp a) n where + mapBoundAtDepthX f d xx + = let down = mapBoundAtDepthX f d + in case xx of + XVar a u -> XVar a (f d u) + XCon{} -> xx + XApp a x1 x2 -> XApp a (down x1) (down x2) + XLAM a b x -> XLAM a b (down x) + XLam a b x -> XLam a b (mapBoundAtDepthX f (d + countBAnons [b]) x) + + XLet a lets x + -> let (lets', levels) = mapBoundAtDepthXLets f d lets + in XLet a lets' (mapBoundAtDepthX f (d + levels) x) + + XCase a x alts -> XCase a (down x) (map down alts) + XCast a cc x -> XCast a (down cc) (down x) + XType{} -> xx + XWitness a w -> XWitness a (down w) + + +instance MapBoundX (Witness a) n where + mapBoundAtDepthX f d ww + = let down = mapBoundAtDepthX f d + in case ww of + WVar a u -> WVar a (down u) + WCon _ _ -> ww + WApp a w1 w2 -> WApp a (down w1) (down w2) + WType _ _ -> ww + + +instance MapBoundX (Cast a) n where + mapBoundAtDepthX _f _d cc + = case cc of + CastWeakenEffect{} -> cc + CastPurify w -> CastPurify w + CastBox -> CastBox + CastRun -> CastRun + + +instance MapBoundX (Alt a) n where + mapBoundAtDepthX f d (AAlt p x) + = case p of + PDefault + -> AAlt PDefault (mapBoundAtDepthX f d x) + + PData _ bs + -> let d' = d + countBAnons bs + in AAlt p (mapBoundAtDepthX f d' x) + + +mapBoundAtDepthXLets + :: (Int -> Bound n -> Bound n) + -- ^ Number of levels to lift. + -> Int -- ^ Current binding depth. + -> Lets a n -- ^ Lift exp indices in this thing. + -> (Lets a n, Int) -- ^ Lifted, and how much to increase depth by + +mapBoundAtDepthXLets f d lts + = case lts of + LLet b x + -> let inc = countBAnons [b] + + -- non-recursive binding: do not increase x's depth + x' = mapBoundAtDepthX f d x + in (LLet b x', inc) + + LRec bs + -> let inc = countBAnons (map fst bs) + bs' = map (\(b,e) -> (b, mapBoundAtDepthX f (d+inc) e)) bs + in (LRec bs', inc) + + LPrivate _b _ bs + -> (lts, countBAnons bs) + + +countBAnons = length . filter isAnon + where isAnon (BAnon _) = True + isAnon _ = False + + diff --git a/DDC/Core/Transform/Deannotate.hs b/DDC/Core/Transform/Deannotate.hs deleted file mode 100644 --- a/DDC/Core/Transform/Deannotate.hs +++ /dev/null @@ -1,78 +0,0 @@ - -module DDC.Core.Transform.Deannotate - (Deannotate(..)) -where -import qualified DDC.Core.Exp.Annot as A -import qualified DDC.Core.Exp.Simple as S - - --- | Convert the `Annot` version of the AST to the `Simple` version, --- using the provided function to decide when to keep the annotation. -class Deannotate - (c1 :: * -> * -> *) - (c2 :: * -> * -> *) | c1 -> c2 - where - deannotate :: (a -> Maybe a) -> c1 a n -> c2 a n - - -instance Deannotate A.Exp S.Exp where - deannotate f xx - = let down = deannotate f - wrap a x = case f a of - Nothing -> x - Just a' -> S.XAnnot a' x - in case xx of - A.XVar a u -> wrap a (S.XVar u) - A.XCon a dc -> wrap a (S.XCon dc) - A.XLAM a b x -> wrap a (S.XLAM b (down x)) - A.XLam a b x -> wrap a (S.XLam b (down x)) - A.XApp a x1 x2 -> wrap a (S.XApp (down x1) (down x2)) - A.XLet a lts x2 -> wrap a (S.XLet (down lts) (down x2)) - A.XCase a x alts -> wrap a (S.XCase (down x) (map down alts)) - A.XCast a cc x -> wrap a (S.XCast (down cc) (down x)) - A.XType t -> S.XType t - A.XWitness w -> S.XWitness (down w) - - -instance Deannotate A.Lets S.Lets where - deannotate f lts - = let down = deannotate f - in case lts of - A.LLet b x -> S.LLet b (down x) - A.LRec bxs -> S.LRec [(b, down x) | (b, x) <- bxs] - A.LLetRegions bks bts -> S.LLetRegions bks bts - A.LWithRegion u -> S.LWithRegion u - - -instance Deannotate A.Alt S.Alt where - deannotate f aa - = case aa of - A.AAlt w x -> S.AAlt w (deannotate f x) - - -instance Deannotate A.Witness S.Witness where - deannotate f ww - = let down = deannotate f - wrap a x = case f a of - Nothing -> x - Just a' -> S.WAnnot a' x - in case ww of - A.WVar a u -> wrap a (S.WVar u) - A.WCon a wc -> wrap a (S.WCon wc) - A.WApp a w1 w2 -> wrap a (S.WApp (down w1) (down w2)) - A.WJoin a w1 w2 -> wrap a (S.WJoin (down w1) (down w2)) - A.WType a t -> wrap a (S.WType t) - - -instance Deannotate A.Cast S.Cast where - deannotate f cc - = let down = deannotate f - in case cc of - A.CastWeakenEffect e -> S.CastWeakenEffect e - A.CastWeakenClosure xs -> S.CastWeakenClosure (map down xs) - A.CastPurify w -> S.CastPurify (down w) - A.CastForget w -> S.CastForget (down w) - A.CastSuspend -> S.CastSuspend - A.CastRun -> S.CastRun - - diff --git a/DDC/Core/Transform/LiftT.hs b/DDC/Core/Transform/LiftT.hs deleted file mode 100644 --- a/DDC/Core/Transform/LiftT.hs +++ /dev/null @@ -1,91 +0,0 @@ - -module DDC.Core.Transform.LiftT - ( liftT, liftAtDepthT - , MapBoundT(..)) -where -import DDC.Core.Exp -import DDC.Type.Transform.LiftT - - -instance Ord n => MapBoundT (Exp a) n where - mapBoundAtDepthT f d xx - = let down = mapBoundAtDepthT f d - in case xx of - XVar a u -> XVar a u - XCon{} -> xx - XApp a x1 x2 -> XApp a (down x1) (down x2) - XLAM a b x -> XLAM a b (mapBoundAtDepthT f (d + countBAnons [b]) x) - XLam a b x -> XLam a (down b) (down x) - - XLet a lets x - -> let (lets', levels) = mapBoundAtDepthTLets f d lets - in XLet a lets' (mapBoundAtDepthT f (d + levels) x) - - XCase a x alts -> XCase a (down x) (map down alts) - XCast a cc x -> XCast a (down cc) (down x) - XType t -> XType (down t) - XWitness w -> XWitness (down w) - - -instance Ord n => MapBoundT (Witness a) n where - mapBoundAtDepthT f d ww - = let down = mapBoundAtDepthT f d - in case ww of - WVar a u -> WVar a (down u) - WCon _ _ -> ww - WApp a w1 w2 -> WApp a (down w1) (down w2) - WJoin a w1 w2 -> WJoin a (down w1) (down w2) - WType a t -> WType a (down t) - - -instance Ord n => MapBoundT (Cast a) n where - mapBoundAtDepthT f d cc - = let down = mapBoundAtDepthT f d - in case cc of - CastWeakenEffect t -> CastWeakenEffect (down t) - CastWeakenClosure xs -> CastWeakenClosure (map down xs) - CastPurify w -> CastPurify (down w) - CastForget w -> CastForget (down w) - CastSuspend -> CastSuspend - 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) - - LLetRegions bsT bsX - -> let inc = countBAnons bsT - bsX' = map (mapBoundAtDepthT f (d + inc)) bsX - in ( LLetRegions bsT bsX' - , inc) - - LWithRegion _ - -> (lts, 0) - - -countBAnons = length . filter isAnon - where isAnon (BAnon _) = True - isAnon _ = False diff --git a/DDC/Core/Transform/LiftX.hs b/DDC/Core/Transform/LiftX.hs deleted file mode 100644 --- a/DDC/Core/Transform/LiftX.hs +++ /dev/null @@ -1,170 +0,0 @@ - --- | Lifting and lowering level-0 deBruijn indices in core things. --- --- Level-0 indices are used for both value and witness variables. -module DDC.Core.Transform.LiftX - ( liftX, liftAtDepthX - , lowerX, lowerAtDepthX - , MapBoundX(..)) -where -import DDC.Core.Exp - - --- Lift ----------------------------------------------------------------------- --- | Lift debruijn indices less than or equal to the given depth. -liftAtDepthX - :: MapBoundX c n - => Int -- ^ Number of levels to lift. - -> Int -- ^ Current binding depth. - -> c n -- ^ Lift expression indices in this thing. - -> c n - -liftAtDepthX n d - = {-# SCC liftAtDepthX #-} - mapBoundAtDepthX liftU d - where - liftU d' u - = case u of - UName{} -> u - UPrim{} -> u - UIx i - | d' <= i -> UIx (i + n) - | otherwise -> u - - --- | Wrapper for `liftAtDepthX` that starts at depth 0. -liftX :: MapBoundX c n => Int -> c n -> c n -liftX n xx = liftAtDepthX n 0 xx - - --- Lower ---------------------------------------------------------------------- --- | Lower debruijn indices less than or equal to the given depth. -lowerAtDepthX - :: MapBoundX c n - => Int -- ^ Number of levels to lower. - -> Int -- ^ Current binding depth. - -> c n -- ^ Lower expression indices in this thing. - -> c n - -lowerAtDepthX n d - = {-# SCC lowerAtDepthX #-} - mapBoundAtDepthX liftU d - where - liftU d' u - = case u of - UName{} -> u - UPrim{} -> u - UIx i - | d' <= i -> UIx (i - n) - | otherwise -> u - - --- | Wrapper for `lowerAtDepthX` that starts at depth 0. -lowerX :: MapBoundX c n => Int -> c n -> c n -lowerX n xx = lowerAtDepthX n 0 xx - - --- MapBoundX ------------------------------------------------------------------ -class MapBoundX (c :: * -> *) n where - -- | Apply a function to all bound variables in the program. - -- The function is passed the current binding depth. - -- This is used to defined both `liftX` and `lowerX`. - mapBoundAtDepthX - :: (Int -> Bound n -> Bound n) -- ^ Function to apply to the bound occ. - -- It is passed the current binding depth. - -> Int -- ^ Current binding depth. - -> c n -- ^ Lift expression indices in this thing. - -> c n - - -instance MapBoundX Bound n where - mapBoundAtDepthX f d u - = f d u - - -instance MapBoundX (Exp a) n where - mapBoundAtDepthX f d xx - = let down = mapBoundAtDepthX f d - in case xx of - XVar a u -> XVar a (f d u) - XCon{} -> xx - XApp a x1 x2 -> XApp a (down x1) (down x2) - XLAM a b x -> XLAM a b (down x) - XLam a b x -> XLam a b (mapBoundAtDepthX f (d + countBAnons [b]) x) - - XLet a lets x - -> let (lets', levels) = mapBoundAtDepthXLets f d lets - in XLet a lets' (mapBoundAtDepthX f (d + levels) x) - - XCase a x alts -> XCase a (down x) (map down alts) - XCast a cc x -> XCast a (down cc) (down x) - XType{} -> xx - XWitness w -> XWitness (down w) - - -instance MapBoundX (Witness a) n where - mapBoundAtDepthX f d ww - = let down = mapBoundAtDepthX f d - in case ww of - WVar a u -> WVar a (down u) - WCon _ _ -> ww - WApp a w1 w2 -> WApp a (down w1) (down w2) - WJoin a w1 w2 -> WJoin a (down w1) (down w2) - WType _ _ -> ww - - -instance MapBoundX (Cast a) n where - mapBoundAtDepthX f d cc - = case cc of - CastWeakenEffect{} - -> cc - - CastWeakenClosure xs - -> CastWeakenClosure (map (mapBoundAtDepthX f d) xs) - - CastPurify w -> CastPurify w - CastForget w -> CastForget w - CastSuspend -> CastSuspend - 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) - - LLetRegions _b bs -> (lts, countBAnons bs) - LWithRegion _ -> (lts, 0) - - -countBAnons = length . filter isAnon - where isAnon (BAnon _) = True - isAnon _ = False - - diff --git a/DDC/Core/Transform/MapT.hs b/DDC/Core/Transform/MapT.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Transform/MapT.hs @@ -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 + + diff --git a/DDC/Core/Transform/Reannotate.hs b/DDC/Core/Transform/Reannotate.hs --- a/DDC/Core/Transform/Reannotate.hs +++ b/DDC/Core/Transform/Reannotate.hs @@ -3,77 +3,90 @@ (Reannotate (..)) where import DDC.Core.Module -import DDC.Core.Exp +import DDC.Core.Exp.Annot.Exp +import Control.Monad.Identity -- | Apply the given function to every annotation in a core thing. class Reannotate c where - reannotate :: (a -> b) -> c a n -> c b n + reannotate :: (a -> b) -> c a n -> c b n + reannotate f xx + = runIdentity (reannotateM (\x -> return $ f x) xx) + reannotateM :: forall m a b n. Monad m + => (a -> m b) -> c a n -> m (c b n) + instance Reannotate Module where - reannotate f - (ModuleCore name - exportKinds exportTypes - importKinds importTypes + reannotateM f + (ModuleCore name isHeader + exportKinds exportTypes + importKinds importCaps importTypes importDataDefs importTypeDefs + dataDefsLocal typeDefsLocal body) - = ModuleCore name - exportKinds exportTypes - importKinds importTypes - (reannotate f body) + = do body' <- reannotateM f body + return $ ModuleCore name isHeader + exportKinds exportTypes + importKinds importCaps importTypes importDataDefs importTypeDefs + dataDefsLocal typeDefsLocal + body' + instance Reannotate Exp where - reannotate f xx - = let down x = reannotate f x + reannotateM f xx + = let down x = reannotateM f x in case xx of - XVar a u -> XVar (f a) u - XCon a u -> XCon (f a) u - XLAM a b x -> XLAM (f a) b (down x) - XLam a b x -> XLam (f a) b (down x) - XApp a x1 x2 -> XApp (f a) (down x1) (down x2) - XLet a lts x -> XLet (f a) (down lts) (down x) - XCase a x alts -> XCase (f a) (down x) (map down alts) - XCast a c x -> XCast (f a) (down c) (down x) - XType t -> XType t - XWitness w -> XWitness (down w) + XVar a u -> XVar <$> f a <*> pure u + XCon a u -> XCon <$> f a <*> pure u + XLAM a b x -> XLAM <$> f a <*> pure b <*> down x + XLam a b x -> XLam <$> f a <*> pure b <*> down x + XApp a x1 x2 -> XApp <$> f a <*> down x1 <*> down x2 + XLet a lts x -> XLet <$> f a <*> down lts <*> down x + XCase a x alts -> XCase <$> f a <*> down x <*> mapM down alts + XCast a c x -> XCast <$> f a <*> down c <*> down x + XType a t -> XType <$> f a <*> pure t + XWitness a w -> XWitness <$> f a <*> down w instance Reannotate Lets where - reannotate f xx - = let down x = reannotate f x + reannotateM f xx + = let down x = reannotateM f x in case xx of - LLet b x -> LLet b (down x) - LRec bxs -> LRec [(b, down x) | (b, x) <- bxs] - LLetRegions b bs -> LLetRegions b bs - LWithRegion b -> LWithRegion b + LLet b x + -> LLet <$> pure b <*> down x + LRec bxs + -> do let (bs, xs) = unzip bxs + xs' <- mapM down xs + return $ LRec $ zip bs xs' + LPrivate b t bs + -> return $ LPrivate b t bs + + instance Reannotate Alt where - reannotate f aa + reannotateM f aa = case aa of - AAlt w x -> AAlt w (reannotate f x) + AAlt w x -> AAlt w <$> reannotateM f x instance Reannotate Cast where - reannotate f cc - = let down x = reannotate f x + reannotateM f cc + = let down x = reannotateM f x in case cc of - CastWeakenEffect eff -> CastWeakenEffect eff - CastWeakenClosure xs -> CastWeakenClosure (map down xs) - CastPurify w -> CastPurify (down w) - CastForget w -> CastForget (down w) - CastSuspend -> CastSuspend - CastRun -> CastRun + CastWeakenEffect eff -> pure $ CastWeakenEffect eff + CastPurify w -> CastPurify <$> down w + CastBox -> pure CastBox + CastRun -> pure CastRun instance Reannotate Witness where - reannotate f ww - = let down x = reannotate f x + reannotateM f ww + = let down x = reannotateM f x in case ww of - WVar a u -> WVar (f a) u - WCon a c -> WCon (f a) c - WApp a w1 w2 -> WApp (f a) (down w1) (down w2) - WJoin a w1 w2 -> WJoin (f a) (down w1) (down w2) - WType a t -> WType (f a) t + WVar a u -> WVar <$> f a <*> pure u + WCon a c -> WCon <$> f a <*> pure c + WApp a w1 w2 -> WApp <$> f a <*> down w1 <*> down w2 + WType a t -> WType <$> f a <*> pure t diff --git a/DDC/Core/Transform/Rename.hs b/DDC/Core/Transform/Rename.hs --- a/DDC/Core/Transform/Rename.hs +++ b/DDC/Core/Transform/Rename.hs @@ -17,7 +17,7 @@ -- * Rewriting bound occurences , use1, use0) where -import DDC.Core.Exp +import DDC.Core.Exp.Annot.Exp import DDC.Type.Transform.Rename @@ -28,6 +28,5 @@ WVar a u -> WVar a (use0 sub u) WCon a c -> WCon a c WApp a w1 w2 -> WApp a (down sub w1) (down sub w2) - WJoin a w1 w2 -> WJoin a (down sub w1) (down sub w2) WType a t -> WType a (down sub t) diff --git a/DDC/Core/Transform/SpreadX.hs b/DDC/Core/Transform/SpreadX.hs --- a/DDC/Core/Transform/SpreadX.hs +++ b/DDC/Core/Transform/SpreadX.hs @@ -3,12 +3,11 @@ (SpreadX(..)) where import DDC.Core.Module -import DDC.Core.Exp -import DDC.Core.Compounds +import DDC.Core.Exp.Annot import DDC.Type.Transform.SpreadT +import Control.Monad import DDC.Type.Env (Env) import qualified DDC.Type.Env as Env -import qualified Data.Map as Map class SpreadX (c :: * -> *) where @@ -22,27 +21,104 @@ => Env n -> Env n -> c n -> c n --- Module --------------------------------------------------------------------- +--------------------------------------------------------------------------------------------------- instance SpreadX (Module a) where spreadX kenv tenv mm@ModuleCore{} - = mm - { moduleExportKinds = Map.map (spreadT kenv) (moduleExportKinds mm) - , moduleExportTypes = Map.map (spreadT kenv) (moduleExportTypes mm) - , moduleImportKinds = Map.map (liftSnd (spreadT kenv)) (moduleImportKinds mm) - , moduleImportTypes = Map.map (liftSnd (spreadT kenv)) (moduleImportTypes mm) - , moduleBody = spreadX kenv tenv (moduleBody mm) } + = let liftSnd f (x, y) = (x, f y) + in ModuleCore + { moduleName + = moduleName mm - where liftSnd f (x, y) = (x, f y) - + , 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 = {-# 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 @@ -59,50 +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 DaCon where - spreadX _kenv tenv dc - = case daConName dc of - DaConUnit -> dc +--------------------------------------------------------------------------------------------------- +spreadDaCon _kenv tenv dc + = case dc of + DaConUnit + -> dc - DaConNamed n - -> let u | Env.isPrim tenv n = UPrim n (daConType 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' } - - -- Primitive constructors won't be in the type environment. - -- But we leave it to checkExp to worry about whether a constructor - -- is primitive or simply undefined. 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 x = spreadX kenv tenv x in case cc of CastWeakenEffect eff -> CastWeakenEffect (spreadT kenv eff) - CastWeakenClosure xs -> CastWeakenClosure (map down xs) CastPurify w -> CastPurify (down w) - CastForget w -> CastForget (down w) - CastSuspend -> CastSuspend + CastBox -> CastBox CastRun -> CastRun +--------------------------------------------------------------------------------------------------- instance SpreadX Pat where spreadX kenv tenv pat = 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 @@ -112,6 +194,7 @@ in AAlt p' (spreadX kenv tenv' x) +--------------------------------------------------------------------------------------------------- instance SpreadX (Lets a) where spreadX kenv tenv lts = let down x = spreadX kenv tenv x @@ -126,16 +209,15 @@ xs' = map (spreadX kenv tenv') xs in LRec (zip bs' xs') - LLetRegions b bs + 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 LLetRegions b' bs' - - LWithRegion b - -> LWithRegion (spreadX kenv tenv b) + in LPrivate b' mT' bs' +--------------------------------------------------------------------------------------------------- instance SpreadX (Witness a) where spreadX kenv tenv ww = let down = spreadX kenv tenv @@ -143,10 +225,10 @@ WCon a wc -> WCon a (down wc) WVar a u -> WVar a (down u) WApp a w1 w2 -> WApp a (down w1) (down w2) - WJoin a w1 w2 -> WJoin a (down w1) (down w2) WType a t1 -> WType a (spreadT kenv t1) +--------------------------------------------------------------------------------------------------- instance SpreadX WiCon where spreadX kenv tenv wc = case wc of @@ -160,6 +242,7 @@ _ -> wc +--------------------------------------------------------------------------------------------------- instance SpreadX Bind where spreadX kenv _tenv bb = case bb of @@ -168,6 +251,7 @@ BNone t -> BNone (spreadT kenv t) +--------------------------------------------------------------------------------------------------- instance SpreadX Bound where spreadX kenv tenv uu | Just t' <- Env.lookup uu tenv @@ -182,5 +266,4 @@ UPrim n _ -> UPrim n t' | otherwise = uu - diff --git a/DDC/Core/Transform/SubstituteTX.hs b/DDC/Core/Transform/SubstituteTX.hs --- a/DDC/Core/Transform/SubstituteTX.hs +++ b/DDC/Core/Transform/SubstituteTX.hs @@ -11,13 +11,14 @@ , substituteBoundTX) where import DDC.Core.Collect -import DDC.Core.Exp -import DDC.Type.Compounds +import DDC.Core.Exp.Annot.Exp +import DDC.Type.Exp.Simple import DDC.Type.Transform.SubstituteT import DDC.Type.Transform.Rename import Data.Maybe 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. @@ -95,19 +96,17 @@ x2' = down sub1 x2 in XLet a (LRec (zip bs' xs')) x2' - XLet a (LLetRegions b bs) x2 - -> let (sub1, b') = bind1s 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 (LLetRegions 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 (down sub cc) (down sub x1) - XType t -> XType (down sub t) - XWitness w -> XWitness (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 @@ -128,10 +127,8 @@ = let down x = substituteWithTX tArg x in case cc of CastWeakenEffect eff -> CastWeakenEffect (down sub eff) - CastWeakenClosure clo -> CastWeakenClosure (map (down sub) clo) CastPurify w -> CastPurify (down sub w) - CastForget w -> CastForget (down sub w) - CastSuspend -> CastSuspend + CastBox -> CastBox CastRun -> CastRun @@ -142,7 +139,6 @@ WVar a u -> WVar a u WCon{} -> ww WApp a w1 w2 -> WApp a (down sub w1) (down sub w2) - WJoin a w1 w2 -> WJoin a (down sub w1) (down sub w2) WType a t -> WType a (down sub t) diff --git a/DDC/Core/Transform/SubstituteWX.hs b/DDC/Core/Transform/SubstituteWX.hs --- a/DDC/Core/Transform/SubstituteWX.hs +++ b/DDC/Core/Transform/SubstituteWX.hs @@ -9,14 +9,15 @@ , substituteWX , substituteWXs) where -import DDC.Core.Exp +import DDC.Core.Exp.Annot.Exp import DDC.Core.Collect import DDC.Core.Transform.Rename -import DDC.Core.Transform.LiftX -import DDC.Type.Compounds +import DDC.Core.Transform.BoundX +import DDC.Type.Exp.Simple import Data.Maybe import qualified DDC.Type.Env as Env import qualified Data.Set as Set +import Control.Monad -- | Wrapper for `substituteWithWX` that determines the set of free names in the @@ -101,19 +102,17 @@ x2' = down sub1 x2 in XLet a (LRec (zip bs' xs')) x2' - XLet a (LLetRegions b bs) x2 + 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 (LLetRegions b' bs') x2' - - XLet a (LWithRegion uR) x2 - -> XLet a (LWithRegion uR) (down sub x2) + mT' = liftM (into sub) mT + 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 (down sub cc) (down sub x1) - XType t -> XType (into sub t) - XWitness w -> XWitness (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 where @@ -135,10 +134,8 @@ into s x = renameWith s x in case cc of CastWeakenEffect eff -> CastWeakenEffect (into sub eff) - CastWeakenClosure xs -> CastWeakenClosure (map (down sub) xs) CastPurify w -> CastPurify (down sub w) - CastForget w -> CastForget (down sub w) - CastSuspend -> CastSuspend + CastBox -> CastBox CastRun -> CastRun @@ -154,7 +151,6 @@ WCon{} -> ww WApp a w1 w2 -> WApp a (down sub w1) (down sub w2) - WJoin a w1 w2 -> WJoin a (down sub w1) (down sub w2) WType a t -> WType a (into sub t) diff --git a/DDC/Core/Transform/SubstituteXX.hs b/DDC/Core/Transform/SubstituteXX.hs --- a/DDC/Core/Transform/SubstituteXX.hs +++ b/DDC/Core/Transform/SubstituteXX.hs @@ -11,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.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 @@ -77,8 +78,8 @@ 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 @@ -135,19 +136,17 @@ x2' = down sub1 x2 in XLet a (LRec (zip bs' xs')) x2' - XLet a (LLetRegions b bs) x2 - -> let (sub1, b') = bind1s 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 (LLetRegions 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 (down 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 @@ -164,15 +163,12 @@ instance SubstituteXX Cast where - substituteWithXX xArg sub cc - = let down s x = substituteWithXX xArg s x - into s x = renameWith s x + substituteWithXX _xArg sub cc + = let into s x = renameWith s x in case cc of CastWeakenEffect eff -> CastWeakenEffect (into sub eff) - CastWeakenClosure xs -> CastWeakenClosure (map (down sub) xs) CastPurify w -> CastPurify (into sub w) - CastForget w -> CastForget (into sub w) - CastSuspend -> CastSuspend + CastBox -> CastBox CastRun -> CastRun diff --git a/DDC/Core/Transform/Trim.hs b/DDC/Core/Transform/Trim.hs deleted file mode 100644 --- a/DDC/Core/Transform/Trim.hs +++ /dev/null @@ -1,112 +0,0 @@ - --- | Trim the expressions passed to @weakclo@ casts to just those terms --- that can affect the closure of the body. --- -module DDC.Core.Transform.Trim - ( trimX, trimClosures ) -where -import DDC.Core.Collect() -import DDC.Type.Collect -import DDC.Core.Exp -import DDC.Type.Env -import DDC.Core.Transform.Reannotate -import Data.List (nubBy) - - --- | Trim the expressions of a weaken closure @(XCast CastWeakenClosure)@ --- into only the free variables. --- --- For example, --- @trimClosures [build (\k z. something k), else] --- = [build, something, else] --- @ -trimClosures - :: (Ord n) - => a - -> [Exp a n] - -> [Exp a n] - -trimClosures a xs - = {-# SCC trimClosures #-} - nub' $ concatMap (freeExp a empty empty) xs - where nub' = nubBy (\x y -> reannotate (const ()) x == reannotate (const ()) y) - - --- | Trim an expression if it is a @weakclo@ cast. --- --- Non-recursive version. If you want to recursively trim closures, --- use @transformUpX' (const trimX)@. -trimX :: (Ord n) - => Exp a n - -> Exp a n -trimX (XCast a (CastWeakenClosure ws) in_) - = XCast a (CastWeakenClosure $ trimClosures a ws) in_ - -trimX x - = x - - --- freeExp -------------------------------------------------------------------- --- | Collect all the free variables, but return them all as expressions: --- eg --- @ --- freeExp --- (let i = 5 [R0#] () in --- updateInt [:R0# R1#:] i ...) --- --- will return something like --- [ XType (TCon R0#) --- , XVar updateInt --- , XType (TCon R0#) --- , XType (TCon R1#) --- , XWitness w ] --- @ -freeExp :: (BindStruct c, Ord n) - => a - -> Env n - -> Env n - -> c n - -> [Exp a n] -freeExp a kenv tenv xx - = concatMap (freeOfTreeExp a kenv tenv) $ slurpBindTree xx - -freeOfTreeExp - :: Ord n - => a - -> Env n - -> Env n - -> BindTree n - -> [Exp a n] -freeOfTreeExp a kenv tenv tt - = case tt of - BindDef way bs ts - | isBoundExpWit $ boundLevelOfBindWay way - , tenv' <- extends bs tenv - -> concatMap (freeOfTreeExp a kenv tenv') ts - - BindDef way bs ts - | BoundSpec <- boundLevelOfBindWay way - , kenv' <- extends bs kenv - -> concatMap (freeOfTreeExp a kenv' tenv) ts - - BindDef _ _ ts - -> concatMap (freeOfTreeExp a kenv tenv) ts - - BindUse BoundExp u - | member u tenv -> [] - | otherwise -> [XVar a u] - - BindUse BoundWit u - | member u tenv -> [] - | otherwise -> [XWitness (WVar a u)] - - BindUse BoundSpec u - | member u kenv -> [] - | otherwise -> [XType (TVar u)] - - BindCon BoundSpec u (Just k) - | member u kenv -> [] - | otherwise -> [XType (TCon (TyConBound u k))] - - _ -> [] - diff --git a/DDC/Data/Canned.hs b/DDC/Data/Canned.hs new file mode 100644 --- /dev/null +++ b/DDC/Data/Canned.hs @@ -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" diff --git a/DDC/Data/Env.hs b/DDC/Data/Env.hs new file mode 100644 --- /dev/null +++ b/DDC/Data/Env.hs @@ -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 + diff --git a/DDC/Data/ListUtils.hs b/DDC/Data/ListUtils.hs new file mode 100644 --- /dev/null +++ b/DDC/Data/ListUtils.hs @@ -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 + diff --git a/DDC/Data/Name.hs b/DDC/Data/Name.hs new file mode 100644 --- /dev/null +++ b/DDC/Data/Name.hs @@ -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) + + diff --git a/DDC/Data/Pretty.hs b/DDC/Data/Pretty.hs new file mode 100644 --- /dev/null +++ b/DDC/Data/Pretty.hs @@ -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 + + + diff --git a/DDC/Data/SourcePos.hs b/DDC/Data/SourcePos.hs new file mode 100644 --- /dev/null +++ b/DDC/Data/SourcePos.hs @@ -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 '''' 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 diff --git a/DDC/Type/Check.hs b/DDC/Type/Check.hs deleted file mode 100644 --- a/DDC/Type/Check.hs +++ /dev/null @@ -1,187 +0,0 @@ --- | Check the kind of a type. -module DDC.Type.Check - ( Config (..) - , configOfProfile - - -- * Kinds of Types - , checkType - , kindOfType - - -- * Kinds of Constructors - , takeSortOfKiCon - , kindOfTwCon - , kindOfTcCon - - -- * Errors - , Error(..)) -where -import DDC.Type.DataDef -import DDC.Type.Check.Error -import DDC.Type.Check.ErrorMessage () -import DDC.Type.Check.CheckCon -import DDC.Type.Check.Config -import DDC.Type.Compounds -import DDC.Type.Predicates -import DDC.Type.Exp -import DDC.Base.Pretty -import Data.List -import Control.Monad -import DDC.Type.Pretty () -import DDC.Type.Env (KindEnv) -import DDC.Control.Monad.Check (throw, result) -import qualified DDC.Control.Monad.Check as G -import qualified DDC.Type.Sum as TS -import qualified DDC.Type.Env as Env -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, Show n, Pretty n) - => Config n - -> KindEnv 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, Show n, Pretty n) - => Config 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, Show n, Pretty n) - => Config n - -> KindEnv n - -> Type n - -> CheckM n (Kind n) - -checkTypeM config env tt - = -- trace (renderPlain $ text "checkTypeM:" <+> text (show tt)) $ - {-# SCC checkTypeM #-} - checkTypeM' config env tt - --- Variables ------------------ -checkTypeM' _config env (TVar u) - = case Env.lookup u env of - Just t -> return t - Nothing -> throw $ ErrorUndefined u - --- Constructors --------------- -checkTypeM' config 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 k - -> case u of - UName n - | Just _ <- Map.lookup n - $ dataDefsTypes $ configPrimDataDefs config - -> return k - - | Just s <- Env.lookupName n - $ configPrimSupers config - -> return s - - | Just s <- Env.lookupName n env - -> return s - - | otherwise - -> throw $ ErrorUndefinedCtor u - - UPrim{} -> return k - UIx{} -> throw $ ErrorUndefinedCtor u - - --- Quantifiers ---------------- -checkTypeM' config env tt@(TForall b1 t2) - = do _ <- checkTypeM config env (typeOfBind b1) - k2 <- checkTypeM config (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' config env (TApp (TApp (TCon (TyConKind KiConFun)) k1) k2) - = do _ <- checkTypeM config env k1 - s2 <- checkTypeM config env k2 - return s2 - --- The implication constructor is overloaded and can have the --- following kinds: --- (=>) :: @ ~> @ ~> @, for witness implication. --- (=>) :: @ ~> * ~> *, for a context. -checkTypeM' config env tt@(TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2) - = do k1 <- checkTypeM config env t1 - k2 <- checkTypeM config 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' config env tt@(TApp t1 t2) - = do k1 <- checkTypeM config env t1 - k2 <- checkTypeM config 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' config env (TSum ts) - = do ks <- mapM (checkTypeM config 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 - diff --git a/DDC/Type/Check/CheckCon.hs b/DDC/Type/Check/CheckCon.hs deleted file mode 100644 --- a/DDC/Type/Check/CheckCon.hs +++ /dev/null @@ -1,78 +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 k -> Just k - - --- | Take the superkind of an atomic kind constructor. --- --- Yields `Nothing` for the kind function (~>) as it doesn't have a sort --- without being fully applied. -takeSortOfKiCon :: KiCon -> Maybe (Sort n) -takeSortOfKiCon kc - = case kc of - KiConFun -> Nothing - KiConData -> Just sComp - KiConRegion -> Just sComp - KiConEffect -> Just sComp - KiConClosure -> Just sComp - KiConWitness -> Just sProp - - --- | Take the kind of a witness type constructor. -kindOfTwCon :: TwCon -> Kind n -kindOfTwCon tc - = case tc of - TwConImpl -> kWitness `kFun` kWitness `kFun` kWitness - TwConPure -> kEffect `kFun` kWitness - TwConEmpty -> kClosure `kFun` kWitness - TwConGlobal -> kRegion `kFun` kWitness - TwConDeepGlobal -> kData `kFun` kWitness - TwConConst -> kRegion `kFun` kWitness - TwConDeepConst -> kData `kFun` kWitness - TwConMutable -> kRegion `kFun` kWitness - TwConDeepMutable-> kData `kFun` kWitness - TwConLazy -> kRegion `kFun` kWitness - TwConHeadLazy -> kData `kFun` kWitness - TwConManifest -> kRegion `kFun` kWitness - TwConDisjoint -> kEffect `kFun` kEffect `kFun` kWitness - TwConDistinct n -> (replicate n kRegion) `kFuns` kWitness - - --- | Take the kind of a computation type constructor. -kindOfTcCon :: TcCon -> Kind n -kindOfTcCon tc - = case tc of - TcConUnit -> kData - TcConFun -> kData `kFun` kData `kFun` kData - TcConFunEC -> [kData, kEffect, kClosure, kData] `kFuns` kData - TcConSusp -> kEffect `kFun` kData `kFun` kData - TcConRead -> kRegion `kFun` kEffect - TcConHeadRead -> kData `kFun` kEffect - TcConDeepRead -> kData `kFun` kEffect - TcConWrite -> kRegion `kFun` kEffect - TcConDeepWrite -> kData `kFun` kEffect - TcConAlloc -> kRegion `kFun` kEffect - TcConDeepAlloc -> kData `kFun` kEffect - TcConUse -> kRegion `kFun` kClosure - TcConDeepUse -> kData `kFun` kClosure - - diff --git a/DDC/Type/Check/Config.hs b/DDC/Type/Check/Config.hs deleted file mode 100644 --- a/DDC/Type/Check/Config.hs +++ /dev/null @@ -1,66 +0,0 @@ - -module DDC.Type.Check.Config - ( Config (..) - , configOfProfile) -where -import DDC.Type.DataDef -import DDC.Type.Env (SuperEnv, 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 - { -- | Data type definitions. - configPrimDataDefs :: DataDefs n - - -- | Super kinds of primitive kinds. - , configPrimSupers :: SuperEnv n - - -- | Kinds of primitive types. - , configPrimKinds :: KindEnv n - - -- | Types of primitive operators. - , configPrimTypes :: TypeEnv n - - -- | Track effect type information. - , configTrackedEffects :: Bool - - -- | Track closure type information. - , configTrackedClosures :: Bool - - -- | Attach effect information to function types. - , configFunctionalEffects :: Bool - - -- | Attach closure information to function types. - , configFunctionalClosures :: Bool } - - - --- | Convert a langage profile to a type checker configuration. -configOfProfile :: F.Profile n -> Config n -configOfProfile profile - = Config - { configPrimDataDefs = F.profilePrimDataDefs profile - , configPrimSupers = F.profilePrimSupers profile - , configPrimKinds = F.profilePrimKinds profile - , configPrimTypes = F.profilePrimTypes profile - - , configTrackedEffects = F.featuresTrackedEffects - $ F.profileFeatures profile - - , configTrackedClosures = F.featuresTrackedClosures - $ F.profileFeatures profile - - , configFunctionalEffects = F.featuresFunctionalEffects - $ F.profileFeatures profile - - , configFunctionalClosures = F.featuresFunctionalClosures - $ F.profileFeatures profile } - diff --git a/DDC/Type/Check/Error.hs b/DDC/Type/Check/Error.hs deleted file mode 100644 --- a/DDC/Type/Check/Error.hs +++ /dev/null @@ -1,71 +0,0 @@ - --- | Errors produced when checking types. -module DDC.Type.Check.Error - (Error(..)) -where -import DDC.Type.Exp - - --- | Things that can go wrong when checking the kind of at type. -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 - diff --git a/DDC/Type/Check/ErrorMessage.hs b/DDC/Type/Check/ErrorMessage.hs deleted file mode 100644 --- a/DDC/Type/Check/ErrorMessage.hs +++ /dev/null @@ -1,75 +0,0 @@ - --- | Errors produced when checking types. -module DDC.Type.Check.ErrorMessage -where -import DDC.Type.Check.Error -import DDC.Type.Compounds -import DDC.Type.Pretty - - -instance (Eq n, Show 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 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 ] - diff --git a/DDC/Type/Collect.hs b/DDC/Type/Collect.hs deleted file mode 100644 --- a/DDC/Type/Collect.hs +++ /dev/null @@ -1,185 +0,0 @@ - --- | Collecting sets of variables and constructors. -module DDC.Type.Collect - ( freeT - , collectBound - , collectBinds - , BindTree (..) - , BindWay (..) - , BindStruct (..) - - , BoundLevel (..) - , isBoundExpWit - , boundLevelOfBindWay - , bindDefT) -where -import DDC.Type.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 - - --- collectBound --------------------------------------------------------------- --- | Collect all the bound variables in a thing, --- independent of whether they are free or not. -collectBound :: (BindStruct c, Ord n) => c n -> Set (Bound n) -collectBound - = Set.unions . map collectBoundOfTree . slurpBindTree - -collectBoundOfTree :: Ord n => BindTree n -> Set (Bound n) -collectBoundOfTree tt - = case tt of - BindDef _ _ ts -> Set.unions $ map collectBoundOfTree ts - BindUse _ u -> Set.singleton u - BindCon _ u _ -> Set.singleton u - - --- collectSpecBinds ----------------------------------------------------------- --- | Collect all the spec and exp binders in a thing. -collectBinds - :: (BindStruct c, Ord n) - => c n - -> ([Bind n], [Bind n]) - -collectBinds thing - = let tree = slurpBindTree thing - in ( concatMap collectSpecBindsOfTree tree - , concatMap collectExpBindsOfTree tree) - - -collectSpecBindsOfTree :: Ord n => BindTree n -> [Bind n] -collectSpecBindsOfTree tt - = case tt of - BindDef way bs ts - | BoundSpec <- boundLevelOfBindWay way - -> concat ( bs - : map collectSpecBindsOfTree ts) - - | otherwise - -> concatMap collectSpecBindsOfTree ts - - _ -> [] - - -collectExpBindsOfTree :: Ord n => BindTree n -> [Bind n] -collectExpBindsOfTree tt - = case tt of - BindDef way bs ts - | BoundExp <- boundLevelOfBindWay way - -> concat ( bs - : map collectExpBindsOfTree ts) - - | otherwise - -> concatMap collectExpBindsOfTree ts - - _ -> [] - - -------------------------------------------------------------------------------- --- | A description of the binding structure of some type or expression. -data BindTree n - -- | An abstract binding expression. - = BindDef BindWay [Bind n] [BindTree n] - - -- | Use of a variable. - | BindUse BoundLevel (Bound n) - - -- | Use of a constructor. - | BindCon BoundLevel (Bound n) (Maybe (Kind n)) - deriving (Eq, Show) - - --- | Describes how a variable was bound. -data BindWay - = BindForall - | BindLAM - | BindLam - | BindLet - | BindLetRec - | BindLetRegions - | BindLetRegionWith - | BindCasePat - deriving (Eq, Show) - - --- | What level this binder is at. -data BoundLevel - = BoundSpec - | BoundExp - | BoundWit - deriving (Eq, Show) - - --- | Check if a boundlevel is expression or witness -isBoundExpWit :: BoundLevel -> Bool -isBoundExpWit BoundExp = True -isBoundExpWit BoundWit = True -isBoundExpWit _ = False - - --- | Get the `BoundLevel` corresponding to a `BindWay`. -boundLevelOfBindWay :: BindWay -> BoundLevel -boundLevelOfBindWay way - = case way of - BindForall -> BoundSpec - BindLAM -> BoundSpec - BindLam -> BoundExp - BindLet -> BoundExp - BindLetRec -> BoundExp - BindLetRegions -> BoundSpec - BindLetRegionWith -> BoundExp - BindCasePat -> BoundExp - - --- BindStruct ----------------------------------------------------------------- -class BindStruct (c :: * -> *) where - slurpBindTree :: c n -> [BindTree n] - - -instance BindStruct Type where - slurpBindTree tt - = case tt of - TVar u -> [BindUse BoundSpec u] - TCon tc -> slurpBindTree tc - TForall b t -> [bindDefT BindForall [b] [t]] - TApp t1 t2 -> slurpBindTree t1 ++ slurpBindTree t2 - TSum ts -> concatMap slurpBindTree $ Sum.toList ts - - -instance BindStruct TyCon where - slurpBindTree tc - = case tc of - TyConBound u k -> [BindCon BoundSpec u (Just k)] - _ -> [] - - --- | Helper for constructing the `BindTree` for a type binder. -bindDefT :: BindStruct c - => BindWay -> [Bind n] -> [c n] -> BindTree n -bindDefT way bs xs - = BindDef way bs $ concatMap slurpBindTree xs diff --git a/DDC/Type/Collect/FreeT.hs b/DDC/Type/Collect/FreeT.hs deleted file mode 100644 --- a/DDC/Type/Collect/FreeT.hs +++ /dev/null @@ -1,47 +0,0 @@ - -module DDC.Type.Collect.FreeT - (FreeVarConT(..)) -where -import DDC.Type.Exp -import Data.Set (Set) -import DDC.Type.Env (KindEnv) -import qualified DDC.Type.Env as Env -import qualified DDC.Type.Sum as Sum -import qualified Data.Set as Set - - -class FreeVarConT (c :: * -> *) where - -- | Collect the free type variables and constructors used in a thing. - freeVarConT - :: Ord n - => KindEnv n -> c n - -> (Set (Bound n), Set (Bound n)) - - -instance FreeVarConT Type where - freeVarConT kenv tt - = case tt of - TVar u - -> if Env.member u kenv - then (Set.empty, Set.empty) - else (Set.singleton u, Set.empty) - - TCon tc - | TyConBound u _ <- tc -> (Set.empty, Set.singleton u) - | otherwise -> (Set.empty, Set.empty) - - TForall b t - -> freeVarConT (Env.extend b kenv) t - - TApp t1 t2 - -> let (vs1, cs1) = freeVarConT kenv t1 - (vs2, cs2) = freeVarConT kenv t2 - in ( Set.union vs1 vs2 - , Set.union cs1 cs2) - - TSum ts - -> let (vss, css) = unzip $ map (freeVarConT kenv) - $ Sum.toList ts - in (Set.unions vss, Set.unions css) - - diff --git a/DDC/Type/Compounds.hs b/DDC/Type/Compounds.hs deleted file mode 100644 --- a/DDC/Type/Compounds.hs +++ /dev/null @@ -1,628 +0,0 @@ -{-# OPTIONS -fno-warn-missing-signatures #-} -module DDC.Type.Compounds - ( -- * Binds - takeNameOfBind - , typeOfBind - , replaceTypeOfBind - - -- * Binders - , binderOfBind - , makeBindFromBinder - , partitionBindsByType - - -- * Bounds - , takeNameOfBound - , boundMatchesBind - , namedBoundMatchesBind - , takeSubstBoundOfBind - , takeSubstBoundsOfBinds - , replaceTypeOfBound - - -- * Kinds - , kFun - , kFuns - , takeKFun - , takeKFuns - , takeKFuns' - , takeResultKind - - -- * Quantifiers - , tForall, tForall' - , tForalls, tForalls' - , takeTForalls, eraseTForalls - - -- * Sums - , tBot - , tSum - - -- * Applications - , tApp, ($:) - , tApps, takeTApps - , takeTyConApps - , takePrimTyConApps - , takeDataTyConApps - , takePrimeRegion - - -- * Functions - , tFun, tFunOfList - , tFunPE, tFunOfListPE - , tFunEC - , takeTFun, takeTFunEC - , takeTFunArgResult - , takeTFunWitArgResult - , takeTFunAllArgResult - , arityOfType - - -- * Suspensions - , tSusp - - -- * Implications - , tImpl - - -- * Units - , tUnit - - -- * Variables - , tIx - - -- * Sort construction - , sComp, sProp - - -- * Kind construction - , kData, kRegion, kEffect, kClosure, kWitness - - -- * Effect type constructors - , tRead, tDeepRead, tHeadRead - , tWrite, tDeepWrite - , tAlloc, tDeepAlloc - - -- * Closure type constructors - , tUse, tDeepUse - - -- * Witness type constructors - , tPure - , tEmpty - , tGlobal, tDeepGlobal - , tConst, tDeepConst - , tMutable, tDeepMutable - , tDistinct - , tLazy, tHeadLazy - , tManifest - , tConData0, tConData1) -where -import DDC.Type.Exp -import qualified DDC.Type.Sum as Sum - - --- Binds ---------------------------------------------------------------------- --- | Take the variable name of a bind. --- If this is an anonymous binder then there won't be a name. -takeNameOfBind :: Bind n -> Maybe n -takeNameOfBind bb - = case bb of - BName n _ -> Just n - BAnon _ -> Nothing - BNone _ -> Nothing - - --- | Take the type of a bind. -typeOfBind :: Bind n -> Type n -typeOfBind bb - = case bb of - BName _ t -> t - BAnon t -> t - BNone t -> t - - --- | Replace the type of a bind with a new one. -replaceTypeOfBind :: Type n -> Bind n -> Bind n -replaceTypeOfBind t bb - = case bb of - BName n _ -> BName n t - BAnon _ -> BAnon t - BNone _ -> BNone t - - --- Binders -------------------------------------------------------------------- --- | Take the binder of a bind. -binderOfBind :: Bind n -> Binder n -binderOfBind bb - = case bb of - BName n _ -> RName n - BAnon _ -> RAnon - BNone _ -> RNone - - --- | Make a bind from a binder and its type. -makeBindFromBinder :: Binder n -> Type n -> Bind n -makeBindFromBinder bb t - = case bb of - RName n -> BName n t - RAnon -> BAnon t - RNone -> BNone t - - --- | Make lists of binds that have the same type. -partitionBindsByType :: Eq n => [Bind n] -> [([Binder n], Type n)] -partitionBindsByType [] = [] -partitionBindsByType (b:bs) - = let t = typeOfBind b - bsSame = takeWhile (\b' -> typeOfBind b' == t) bs - rs = map binderOfBind (b:bsSame) - in (rs, t) : partitionBindsByType (drop (length bsSame) bs) - - --- Bounds --------------------------------------------------------------------- --- | Take the name of bound variable. --- If this is a deBruijn index then there won't be a name. -takeNameOfBound :: Bound n -> Maybe n -takeNameOfBound uu - = case uu of - UName n -> Just n - UPrim n _ -> Just n - UIx{} -> Nothing - - --- | 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 0 bs - where go _level [] = [] - go level (BName n _ : bs') = UName n : go level bs' - go level (BAnon _ : bs') = UIx level : go (level + 1) bs' - go level (BNone _ : bs') = go level 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) - - --- 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) - - | TyConBound UPrim{} k <- tc - , TCon (TyConKind KiConData) <- takeResultKind k - -> Just (tc, args) - - _ -> Nothing - - --- | Take the prime region variable of a data type. --- This corresponds to the region the outermost constructor is allocated into. -takePrimeRegion :: Type n -> Maybe (Type n) -takePrimeRegion tt - = case takeTApps tt of - TCon _ : tR@(TVar _) : _ - -> Just tR - - _ -> Nothing - - --- Foralls -------------------------------------------------------------------- --- | Build an anonymous type abstraction, with a single parameter. -tForall :: Kind n -> (Type n -> Type n) -> Type n -tForall k f - = TForall (BAnon k) (f (TVar (UIx 0))) - --- | Build an anonymous type abstraction, with a single parameter. --- Starting the next index from the given value. -tForall' :: Int -> Kind n -> (Type n -> Type n) -> Type n -tForall' ix k f - = TForall (BAnon k) (f (TVar (UIx ix))) - - --- | Build an anonymous type abstraction, with several parameters. --- Starting the next index from the given value. -tForalls :: [Kind n] -> ([Type n] -> Type n) -> Type n -tForalls ks f - = let bs = [BAnon k | k <- ks] - us = map (\i -> TVar (UIx i)) [0 .. (length ks - 1)] - in foldr TForall (f $ reverse us) bs - - --- | Build an anonymous type abstraction, with several parameters. --- Starting the next index from the given value. -tForalls' :: Int -> [Kind n] -> ([Type n] -> Type n) -> Type n -tForalls' ix ks f - = let bs = [BAnon k | k <- ks] - us = map (\i -> TVar (UIx i)) [ix .. ix + (length ks - 1)] - in foldr TForall (f $ reverse us) bs - - --- | Split nested foralls from the front of a type, --- or `Nothing` if there was no outer forall. -takeTForalls :: Type n -> Maybe ([Bind n], Type n) -takeTForalls tt - = let go bs (TForall b t) = go (b:bs) t - go bs t = (reverse bs, t) - in case go [] tt of - ([], _) -> Nothing - (bs, body) -> Just (bs, body) - - --- | Erase all `TForall` quantifiers from a type. -eraseTForalls :: Ord n => Type n -> Type n -eraseTForalls tt - = case tt of - TVar{} -> tt - TCon{} -> tt - TForall _ t -> eraseTForalls t - TApp t1 t2 -> TApp (eraseTForalls t1) (eraseTForalls t2) - TSum ts -> TSum $ Sum.fromList (Sum.kindOfSum ts) - $ map eraseTForalls $ Sum.toList ts - - --- Sums ----------------------------------------------------------------------- -tSum :: Ord n => Kind n -> [Type n] -> Type n -tSum k ts - = TSum (Sum.fromList k ts) - - --- Unit ----------------------------------------------------------------------- -tUnit :: Type n -tUnit = TCon (TyConSpec TcConUnit) - - --- Function Constructors ------------------------------------------------------ --- | Construct a kind function. -kFun :: Kind n -> Kind n -> Kind n -kFun k1 k2 = ((TCon $ TyConKind KiConFun)`TApp` k1) `TApp` k2 -infixr `kFun` - - --- | Construct some kind functions. -kFuns :: [Kind n] -> Kind n -> Kind n -kFuns [] k1 = k1 -kFuns (k:ks) k1 = k `kFun` kFuns ks k1 - - --- | Destruct a kind function -takeKFun :: Kind n -> Maybe (Kind n, Kind n) -takeKFun kk - = case kk of - TApp (TApp (TCon (TyConKind KiConFun)) k1) k2 - -> Just (k1, k2) - _ -> Nothing - - --- | Destruct a chain of kind functions into the arguments -takeKFuns :: Kind n -> ([Kind n], Kind n) -takeKFuns kk - = case kk of - TApp (TApp (TCon (TyConKind KiConFun)) k1) k2 - | (ks, k2') <- takeKFuns k2 - -> (k1 : ks, k2') - - _ -> ([], kk) - - --- | Like `takeKFuns`, but return argument and return kinds in the same list. -takeKFuns' :: Kind n -> [Kind n] -takeKFuns' kk - | (ks, k1) <- takeKFuns kk - = ks ++ [k1] - - --- | Take the result kind of a kind function, or return the same kind --- unharmed if it's not a kind function. -takeResultKind :: Kind n -> Kind n -takeResultKind kk - = case kk of - TApp (TApp (TCon (TyConKind KiConFun)) _) k2 - -> takeResultKind k2 - _ -> kk - - --- Function types ------------------------------------------------------------- --- | Construct a pure function type. -tFun :: Type n -> Type n -> Type n -tFun t1 t2 - = (TCon $ TyConSpec TcConFun) `tApps` [t1, t2] -infixr `tFun` - - --- | Construct a value type function, --- with the provided effect and closure. -tFunEC :: Type n -> Effect n -> Closure n -> Type n -> Type n -tFunEC t1 eff clo t2 - = (TCon $ TyConSpec TcConFunEC) `tApps` [t1, eff, clo, t2] -infixr `tFunEC` - - --- | Construct a pure and empty value type function. -tFunPE :: Type n -> Type n -> Type n -tFunPE t1 t2 = tFunEC t1 (tBot kEffect) (tBot kClosure) t2 -infixr `tFunPE` - - --- | Construct a pure and empty function from a list containing the --- parameter and return type. Yields `Nothing` if the list is empty. -tFunOfList :: [Type n] -> Maybe (Type n) -tFunOfList ts - = case reverse ts of - [] -> Nothing - (t : tsArgs) - -> let tFuns' [] = t - tFuns' (t' : ts') = t' `tFun` tFuns' ts' - in Just $ tFuns' (reverse tsArgs) - - --- | Construct a pure and empty function from a list containing the --- parameter and return type. Yields `Nothing` if the list is empty. -tFunOfListPE :: [Type n] -> Maybe (Type n) -tFunOfListPE ts - = case reverse ts of - [] -> Nothing - (t : tsArgs) - -> let tFunPEs' [] = t - tFunPEs' (t' : ts') = t' `tFunPE` tFunPEs' ts' - in Just $ tFunPEs' (reverse tsArgs) - - --- | Yield the argument and result type of a function type. --- --- Works for both `TcConFun` and `TcConFunEC`. -takeTFun :: Type n -> Maybe (Type n, Type n) -takeTFun tt - = case tt of - TApp (TApp (TCon (TyConSpec TcConFun)) t1) t2 - -> Just (t1, t2) - - TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFunEC)) t1) _eff) _clo) t2 - -> Just (t1, t2) - - _ -> Nothing - - --- | Yield the argument and result type of a function type. -takeTFunEC :: Type n -> Maybe (Type n, Effect n, Closure n, Type n) -takeTFunEC tt - = case tt of - TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFunEC)) t1) eff) clo) t2 - -> Just (t1, eff, clo, t2) - - _ -> Nothing - - --- | Destruct the type of a function, returning just the argument and result types. --- --- Works for both `TcConFun` and `TcConFunEC`. -takeTFunArgResult :: Type n -> ([Type n], Type n) -takeTFunArgResult tt - = case tt of - TApp (TApp (TCon (TyConSpec TcConFun)) t1) t2 - -> let (tsMore, tResult) = takeTFunArgResult t2 - in (t1 : tsMore, tResult) - - TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFunEC)) t1) _eff) _clo) t2 - -> let (tsMore, tResult) = takeTFunArgResult t2 - in (t1 : tsMore, tResult) - - _ -> ([], tt) - - --- | Destruct the type of a function, --- returning the witness argument, value argument and result types. --- The function type must have the witness implications before --- the value arguments, eg @T1 => T2 -> T3 -> T4 -> T5@. --- --- Works for both `TcConFun` and `TcConFunEC`. --- -takeTFunWitArgResult :: Type n -> ([Type n], [Type n], Type n) -takeTFunWitArgResult tt - = case tt of - TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2 - -> let (twsMore, tvsMore, tResult) = takeTFunWitArgResult t2 - in (t1 : twsMore, tvsMore, tResult) - - _ -> let (tvsMore, tResult) = takeTFunArgResult tt - in ([], tvsMore, tResult) - - --- | Destruct the type of a possibly polymorphic function --- returning all kinds of quantifiers, witness arguments, --- and value arguments in the order they appear, along with --- the type of the result. -takeTFunAllArgResult :: Type n -> ([Type n], Type n) -takeTFunAllArgResult tt - = case tt of - TVar{} -> ([], tt) - TCon{} -> ([], tt) - - TForall b t - -> let (tsMore, tResult) = takeTFunAllArgResult t - in (typeOfBind b : tsMore, tResult) - - TApp (TApp (TCon (TyConSpec TcConFun)) t1) t2 - -> let (tsMore, tResult) = takeTFunAllArgResult t2 - in (t1 : tsMore, tResult) - - TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFunEC)) t1) _eff) _clo) t2 - -> let (tsMore, tResult) = takeTFunAllArgResult t2 - in (t1 : tsMore, tResult) - - TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2 - -> let (tsMore, tResult) = takeTFunAllArgResult t2 - in (t1 : tsMore, tResult) - - _ -> ([], tt) - - --- | Determine the arity of an expression by looking at its type. --- Count all the function arrows, and foralls. -arityOfType :: Type n -> Int -arityOfType tt - = case tt of - TForall _ t -> 1 + arityOfType t - t -> length $ fst $ takeTFunArgResult t - - --- Implications --------------------------------------------------------------- --- | Construct a witness implication type. -tImpl :: Type n -> Type n -> Type n -tImpl t1 t2 - = ((TCon $ TyConWitness TwConImpl) `tApp` t1) `tApp` t2 -infixr `tImpl` - - --- Suspensions ---------------------------------------------------------------- -tSusp :: Effect n -> Type n -> Type n -tSusp tE tA - = (TCon $ TyConSpec TcConSusp) `tApp` tE `tApp` tA - - --- Level 3 constructors (sorts) ----------------------------------------------- -sComp = TCon $ TyConSort SoConComp -sProp = TCon $ TyConSort SoConProp - - --- Level 2 constructors (kinds) ----------------------------------------------- -kData = TCon $ TyConKind KiConData -kRegion = TCon $ TyConKind KiConRegion -kEffect = TCon $ TyConKind KiConEffect -kClosure = TCon $ TyConKind KiConClosure -kWitness = TCon $ TyConKind KiConWitness - - --- Level 1 constructors (witness and computation types) ----------------------- - --- Effect type constructors -tRead = tcCon1 TcConRead -tHeadRead = tcCon1 TcConHeadRead -tDeepRead = tcCon1 TcConDeepRead -tWrite = tcCon1 TcConWrite -tDeepWrite = tcCon1 TcConDeepWrite -tAlloc = tcCon1 TcConAlloc -tDeepAlloc = tcCon1 TcConDeepAlloc - --- Closure type constructors. -tUse = tcCon1 TcConUse -tDeepUse = tcCon1 TcConDeepUse - --- Witness type constructors. -tPure = twCon1 TwConPure -tEmpty = twCon1 TwConEmpty -tGlobal = twCon1 TwConGlobal -tDeepGlobal = twCon1 TwConDeepGlobal -tConst = twCon1 TwConConst -tDeepConst = twCon1 TwConDeepConst -tMutable = twCon1 TwConMutable -tDeepMutable = twCon1 TwConDeepMutable -tDistinct n = twCon2 (TwConDistinct n) -tLazy = twCon1 TwConLazy -tHeadLazy = twCon1 TwConHeadLazy -tManifest = twCon1 TwConManifest - -tcCon1 tc t = (TCon $ TyConSpec tc) `tApp` t -twCon1 tc t = (TCon $ TyConWitness tc) `tApp` t - -twCon2 tc ts = tApps (TCon $ TyConWitness tc) ts - - --- | Build a nullary type constructor of the given kind. -tConData0 :: n -> Kind n -> Type n -tConData0 n k = TCon (TyConBound (UName n) k) - - --- | Build a type constructor application of one argumnet. -tConData1 :: n -> Kind n -> Type n -> Type n -tConData1 n k t1 = TApp (TCon (TyConBound (UName n) k)) t1 - diff --git a/DDC/Type/DataDef.hs b/DDC/Type/DataDef.hs --- a/DDC/Type/DataDef.hs +++ b/DDC/Type/DataDef.hs @@ -2,41 +2,142 @@ -- | Algebraic data type definitions. module DDC.Type.DataDef ( DataDef (..) + , kindOfDataDef + , dataTypeOfDataDef + , dataCtorNamesOfDataDef + , makeDataDefAlg + , makeDataDefAbs -- * Data type definition table , DataDefs (..) + , DataMode (..) - , DataType (..) - , DataCtor (..) - , emptyDataDefs , insertDataDef + , unionDataDefs , fromListDataDefs - , lookupModeOfDataType) + + , 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 - -- | Kinds of type parameters. - , dataDefParamKinds :: ![Kind n] + -- | Binders for type parameters. + , dataDefParams :: ![Bind n] - -- | Constructors of the data type, or Nothing if there are - -- too many to list (like with `Int`). - , dataDefCtors :: !(Maybe [(n, [Type 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 --- DataDefs ------------------------------------------------------------------- +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 @@ -63,11 +164,14 @@ dataTypeName :: !n -- | Kinds of type parameters to constructor. - , dataTypeParamKinds :: ![Kind n] + , dataTypeParams :: ![Bind n] -- | Names of data constructors of this data type, -- or `Nothing` if it has infinitely many constructors. - , dataTypeMode :: !(DataMode n) } + , dataTypeMode :: !(DataMode n) + + -- | Whether the data type is algebraic. + , dataTypeIsAlgebraic :: Bool } deriving Show @@ -75,19 +179,43 @@ data DataCtor n = DataCtor { -- | Name of data constructor. - dataCtorName :: !n + dataCtorName :: !n -- | Tag of constructor (order in data type declaration) - , dataCtorTag :: !Integer + , dataCtorTag :: !Integer -- | Field types of constructor. - , dataCtorFieldTypes :: ![Type n] + , dataCtorFieldTypes :: ![Type n] + -- | Result type of constructor. + , dataCtorResultType :: !(Type n) + -- | Name of result type of constructor. - , dataCtorTypeName :: !n } + , 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 @@ -96,34 +224,32 @@ , 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 ks mCtors) dataDefs +insertDataDef (DataDef nType bsParam mCtors isAlg) dataDefs = let defType = DataType - { dataTypeName = nType - , dataTypeParamKinds = ks - , dataTypeMode = defMode } + { dataTypeName = nType + , dataTypeParams = bsParam + , dataTypeMode = defMode + , dataTypeIsAlgebraic = isAlg } defMode = case mCtors of Nothing -> DataModeLarge - Just ctors -> DataModeSmall (map fst ctors) - - makeDefCtor tag (nCtor, tsFields) - = DataCtor - { dataCtorName = nCtor - , dataCtorTag = tag - , dataCtorFieldTypes = tsFields - , dataCtorTypeName = nType } - - defCtors = case mCtors of - Nothing -> Nothing - Just cs -> Just $ zipWith makeDefCtor [0..] cs + 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 defCtors ]} + | def@(DataCtor n _ _ _ _ _) <- concat $ maybeToList mCtors ]} -- | Build a `DataDefs` table from a list of `DataDef` @@ -132,11 +258,16 @@ = 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 diff --git a/DDC/Type/Env.hs b/DDC/Type/Env.hs --- a/DDC/Type/Env.hs +++ b/DDC/Type/Env.hs @@ -14,12 +14,15 @@ -- * Construction , empty + , singleton , extend , extends , union + , unions -- * Conversion , fromList + , fromListNT , fromTypeMap -- * Projections @@ -34,13 +37,10 @@ , isPrim -- * Lifting - , wrapTForalls - - -- * Wrapping , lift) where import DDC.Type.Exp -import DDC.Type.Transform.LiftT +import DDC.Type.Transform.BoundT import Data.Maybe import Data.Map (Map) import Prelude hiding (lookup) @@ -84,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 @@ -120,6 +126,12 @@ = foldr extend empty bs +-- | Convert a list of name and types into an environment +fromListNT :: Ord n => [(n, Type n)] -> Env n +fromListNT nts + = fromList [BName n t | (n, t) <- nts] + + -- | Convert a map of names to types to a environment. fromTypeMap :: Map n (Type n) -> Env n fromTypeMap m @@ -138,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 @@ -168,7 +187,8 @@ -- | Lookup a bound name from an environment. lookupName :: Ord n => n -> Env n -> Maybe (Type n) lookupName n env - = Map.lookup n (envMap env) + = Map.lookup n (envMap env) + `mplus` (envPrimFun env n) -- | Yield the total depth of the deBruijn stack. @@ -191,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 diff --git a/DDC/Type/Equiv.hs b/DDC/Type/Equiv.hs deleted file mode 100644 --- a/DDC/Type/Equiv.hs +++ /dev/null @@ -1,128 +0,0 @@ - -module DDC.Type.Equiv - ( equivT - , equivWithBindsT) -where -import DDC.Type.Transform.Crush -import DDC.Type.Compounds -import DDC.Type.Bind -import DDC.Type.Exp -import qualified DDC.Type.Sum as Sum - - --- | Check equivalence of types. --- --- Checks equivalence up to alpha-renaming, as well as crushing of effects --- and trimming of closures. --- --- * Return `False` if we find any free variables. --- --- * We assume the types are well-kinded, so that the type annotations on --- bound variables match the binders. If this is not the case then you get --- an indeterminate result. --- -equivT :: Ord n => Type n -> Type n -> Bool -equivT t1 t2 - = equivWithBindsT [] [] t1 t2 - --- | Like `equivT` but take the initial stacks of type binders. -equivWithBindsT - :: Ord n - => [Bind n] - -> [Bind n] - -> Type n - -> Type n - -> Bool - -equivWithBindsT stack1 stack2 t1 t2 - = let t1' = unpackSumT $ crushSomeT t1 - t2' = unpackSumT $ crushSomeT t2 - in case (t1', t2') of - (TVar u1, TVar u2) - -- Free variables are name-equivalent, bound variables aren't: - -- (forall a. a) != (forall b. a) - | Nothing <- getBindType stack1 u1 - , Nothing <- getBindType stack2 u2 - , u1 == u2 -> checkBounds u1 u2 True - - -- Both variables are bound in foralls, so check the stack - -- to see if they would be equivalent if we named them. - | Just (ix1, t1a) <- getBindType stack1 u1 - , Just (ix2, t2a) <- getBindType stack2 u2 - , ix1 == ix2 - -> checkBounds u1 u2 - $ equivWithBindsT stack1 stack2 t1a t2a - - | otherwise - -> checkBounds u1 u2 - $ False - - -- Constructor names must be equal. - (TCon tc1, TCon tc2) - -> tc1 == tc2 - - -- Push binders on the stack as we enter foralls. - (TForall b11 t12, TForall b21 t22) - | equivT (typeOfBind b11) (typeOfBind b21) - -> equivWithBindsT - (b11 : stack1) - (b21 : stack2) - t12 t22 - - -- Decend into applications. - (TApp t11 t12, TApp t21 t22) - -> equivWithBindsT stack1 stack2 t11 t21 - && equivWithBindsT stack1 stack2 t12 t22 - - -- Sums are equivalent if all of their components are. - (TSum ts1, TSum ts2) - -> let ts1' = Sum.toList ts1 - ts2' = Sum.toList ts2 - - -- If all the components of the sum were in the element - -- arrays then they come out of Sum.toList sorted - -- and we can compare corresponding pairs. - checkFast = and $ zipWith (equivWithBindsT stack1 stack2) ts1' ts2' - - -- If any of the components use a higher kinded type variable - -- like (c : % ~> !) then they won't nessesarally be sorted, - -- so we need to do this slower O(n^2) check. - -- Make sure to get the bind stacks the right way around here. - checkSlow = and [ or (map (equivWithBindsT stack1 stack2 t1c) ts2') - | t1c <- ts1' ] - && and [ or (map (equivWithBindsT stack2 stack1 t2c) ts1') - | t2c <- ts2' ] - - in (length ts1' == length ts2') - && (checkFast || checkSlow) - - (_, _) -> False - - --- | If we have a UName and UPrim with the same name then these won't match --- even though they pretty print the same. This will only happen due to --- a compiler bugs, but is very confusing when it does, so we check for --- this case explicitly. -checkBounds :: Eq n => Bound n -> Bound n -> a -> a -checkBounds u1 u2 x - = case (u1, u2) of - (UName n2, UPrim n1 _) - | n1 == n2 -> die - - (UPrim n1 _, UName n2) - | n1 == n2 -> die - - _ -> x - where - die = error $ unlines - [ "DDC.Type.Equiv" - , " Found a primitive and non-primitive bound variable with the same name."] - - --- | Unpack single element sums into plain types. -unpackSumT :: Type n -> Type n -unpackSumT (TSum ts) - | [t] <- Sum.toList ts = t -unpackSumT tt = tt - - diff --git a/DDC/Type/Exp.hs b/DDC/Type/Exp.hs --- a/DDC/Type/Exp.hs +++ b/DDC/Type/Exp.hs @@ -14,6 +14,6 @@ , Bind (..) , Bound (..)) where -import DDC.Type.Exp.Base -import DDC.Type.Exp.NFData () +import DDC.Type.Exp.Simple.Exp +import DDC.Type.Exp.Simple.NFData () diff --git a/DDC/Type/Exp/Base.hs b/DDC/Type/Exp/Base.hs deleted file mode 100644 --- a/DDC/Type/Exp/Base.hs +++ /dev/null @@ -1,273 +0,0 @@ - -module DDC.Type.Exp.Base where -import Data.Array -import Data.Map.Strict (Map) -import Data.Set (Set) - - --- Bind ----------------------------------------------------------------------- --- | A variable binder. -data Binder n - = RNone - | RAnon - | RName !n - deriving Show - - --- | A variable binder with its type. -data Bind n - -- | A variable with no uses in the body doesn't need a name. - = BNone !(Type n) - - -- | Nameless variable on the deBruijn stack. - | BAnon !(Type n) - - -- | Named variable in the environment. - | BName n !(Type n) - deriving Show - - - --- | A bound occurrence of a variable, with its type. --- --- If variable hasn't been annotated with its real type then this --- can be `tBot` (an empty sum). - -data Bound n - -- | Nameless variable that should be on the deBruijn stack. - = UIx !Int - - -- | Named variable that should be in the environment. - | UName !n - - -- | Named primitive that has its type attached to it. - -- The types of primitives must be closed. - | UPrim !n !(Type n) - deriving Show - - --- Types ---------------------------------------------------------------------- --- | A value type, kind, or sort. --- --- We use the same data type to represent all three universes, as they have --- a similar algebraic structure. --- -data Type n - -- | Variable. - = TVar !(Bound n) - - -- | Constructor. - | TCon !(TyCon n) - - -- | Abstraction. - | TForall !(Bind n) !(Type n) - - -- | Application. - | TApp !(Type n) !(Type n) - - -- | Least upper bound. - | TSum !(TypeSum n) - deriving Show - - -type Sort n = Type n -type Kind n = Type n -type Region n = Type n -type Effect n = Type n -type Closure n = Type n - - --- Type Sums ------------------------------------------------------------------ --- | A least upper bound of several types. --- --- We keep type sums in this normalised format instead of joining them --- together with a binary operator (like @(+)@). This makes sums easier to work --- with, as a given sum type often only has a single physical representation. -data TypeSum n - = TypeSumBot - { typeSumKind :: !(Kind n) } - - | TypeSumSet - { -- | The kind of the elements in this sum. - typeSumKind :: !(Kind n) - - -- | Where we can see the outer constructor of a type, its argument - -- is inserted into this array. This handles common cases like - -- Read, Write, Alloc effects. - , typeSumElems :: !(Array TyConHash (Set (TypeSumVarCon n))) - - -- | A map for named type variables. - , typeSumBoundNamed :: !(Map n (Kind n)) - - -- | A map for anonymous type variables. - , typeSumBoundAnon :: !(Map Int (Kind n)) - - -- | Types that can't be placed in the other fields go here. - -- - -- INVARIANT: this list doesn't contain more `TSum`s. - , typeSumSpill :: ![Type n] } - deriving Show - - --- | Hash value used to insert types into the `typeSumElems` array of a `TypeSum`. -data TyConHash - = TyConHash !Int - deriving (Eq, Show, Ord, Ix) - - --- | Wraps a variable or constructor that can be added the `typeSumElems` array. -data TypeSumVarCon n - = TypeSumVar !(Bound n) - | TypeSumCon !(Bound n) !(Type 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) !(Type n) - deriving Show - - --- | Sort constructor. -data SoCon - -- | Sort of witness kinds. - = SoConProp -- 'Prop' - - -- | Sort of computation kinds. - | SoConComp -- 'Comp' - deriving (Eq, Show) - - --- | Kind constructor. -data KiCon - -- | Function kind constructor. - -- This is only well formed when it is fully applied. - = KiConFun -- (~>) - - -- Witness kinds ------------------------ - -- | Kind of witnesses. - | KiConWitness -- 'Witness :: Prop' - - -- Computation kinds --------------------- - -- | Kind of data values. - | KiConData -- 'Data :: Comp' - - -- | Kind of regions. - | KiConRegion -- 'Region :: Comp' - - -- | Kind of effects. - | KiConEffect -- 'Effect :: Comp' - - -- | Kind of closures. - | KiConClosure -- 'Closure :: Comp' - deriving (Eq, Show) - - --- | Witness type constructors. -data TwCon - -- Witness implication. - = TwConImpl -- :: '(=>) :: Witness ~> Data' - - -- | Purity of some effect. - | TwConPure -- :: Effect ~> Witness - - -- | Emptiness of some closure. - | TwConEmpty -- :: Closure ~> Witness - - -- | Globalness of some region. - | TwConGlobal -- :: Region ~> Witness - - -- | Globalness of material regions in some type. - | TwConDeepGlobal -- :: Data ~> Witness - - -- | Constancy of some region. - | TwConConst -- :: Region ~> Witness - - -- | Constancy of material regions in some type - | TwConDeepConst -- :: Data ~> Witness - - -- | Mutability of some region. - | TwConMutable -- :: Region ~> Witness - - -- | Mutability of material regions in some type. - | TwConDeepMutable -- :: Data ~> Witness - - -- | Distinctness of some n regions - | TwConDistinct Int -- :: Data ~> [Region] ~> Witness - - -- | Laziness of some region. - | TwConLazy -- :: Region ~> Witness - - -- | Laziness of the primary region in some type. - | TwConHeadLazy -- :: Data ~> Witness - - -- | Manifestness of some region (not lazy). - | TwConManifest -- :: Region ~> Witness - - -- | Non-interfering effects are disjoint. Used for rewrite rules. - | TwConDisjoint -- :: Effect ~> Effect ~> Witness - deriving (Eq, Show) - - --- | Other constructors at the spec level. -data TcCon - -- Data type constructors --------------- - -- | The unit data type constructor is baked in. - = TcConUnit -- 'Unit :: Data' - - -- | Pure function. - | TcConFun -- '(->)' :: Data ~> Data ~> Data - - -- | Function with a latent effect and closure. - | TcConFunEC -- '(->) :: Data ~> Data ~> Effect ~> Closure ~> Data' - - -- | A suspended computation. - | TcConSusp -- 'S :: Effect ~> Data ~> Data' - - -- Effect type constructors ------------- - -- | Read of some region. - | TcConRead -- :: 'Region ~> Effect' - - -- | Read the head region in a data type. - | TcConHeadRead -- :: 'Data ~> Effect' - - -- | Read of all material regions in a data type. - | TcConDeepRead -- :: 'Data ~> Effect' - - -- | Write of some region. - | TcConWrite -- :: 'Region ~> Effect' - - -- | Write to all material regions in some data type. - | TcConDeepWrite -- :: 'Data ~> Effect' - - -- | Allocation into some region. - | TcConAlloc -- :: 'Region ~> Effect' - - -- | Allocation into all material regions in some data type. - | TcConDeepAlloc -- :: 'Data ~> Effect' - - -- Closure type constructors ------------ - -- | Region is captured in a closure. - | TcConUse -- :: 'Region ~> Closure' - - -- | All material regions in a data type are captured in a closure. - | TcConDeepUse -- :: 'Data ~> Closure' - deriving (Eq, Show) diff --git a/DDC/Type/Exp/Flat.hs b/DDC/Type/Exp/Flat.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Flat.hs @@ -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 diff --git a/DDC/Type/Exp/Flat/Exp.hs b/DDC/Type/Exp/Flat/Exp.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Flat/Exp.hs @@ -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 + diff --git a/DDC/Type/Exp/Flat/Pretty.hs b/DDC/Type/Exp/Flat/Pretty.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Flat/Pretty.hs @@ -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 + diff --git a/DDC/Type/Exp/Generic.hs b/DDC/Type/Exp/Generic.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Generic.hs @@ -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 + diff --git a/DDC/Type/Exp/Generic/Binding.hs b/DDC/Type/Exp/Generic/Binding.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Generic/Binding.hs @@ -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 diff --git a/DDC/Type/Exp/Generic/Compounds.hs b/DDC/Type/Exp/Generic/Compounds.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Generic/Compounds.hs @@ -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] diff --git a/DDC/Type/Exp/Generic/Exp.hs b/DDC/Type/Exp/Generic/Exp.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Generic/Exp.hs @@ -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) + diff --git a/DDC/Type/Exp/Generic/NFData.hs b/DDC/Type/Exp/Generic/NFData.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Generic/NFData.hs @@ -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 + diff --git a/DDC/Type/Exp/Generic/Predicates.hs b/DDC/Type/Exp/Generic/Predicates.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Generic/Predicates.hs @@ -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 diff --git a/DDC/Type/Exp/Generic/Pretty.hs b/DDC/Type/Exp/Generic/Pretty.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Generic/Pretty.hs @@ -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 + diff --git a/DDC/Type/Exp/NFData.hs b/DDC/Type/Exp/NFData.hs deleted file mode 100644 --- a/DDC/Type/Exp/NFData.hs +++ /dev/null @@ -1,81 +0,0 @@ - -module DDC.Type.Exp.NFData where -import DDC.Type.Exp.Base -import Control.DeepSeq - - -instance NFData n => NFData (Binder n) where - rnf bb - = case bb of - RNone -> () - RAnon -> () - RName n -> rnf n - - -instance NFData n => NFData (Bind n) where - rnf bb - = case bb of - BNone t -> rnf t - BAnon t -> rnf t - BName n t -> rnf n `seq` rnf t - - -instance NFData n => NFData (Bound n) where - rnf uu - = case uu of - UIx i -> rnf i - UName n -> rnf n - UPrim u t -> rnf u `seq` rnf t - - -instance NFData n => NFData (Type n) where - rnf tt - = case tt of - TVar u -> rnf u - TCon tc -> rnf tc - TForall b t -> rnf b `seq` rnf t - TApp t1 t2 -> rnf t1 `seq` rnf t2 - TSum ts -> rnf ts - - -instance NFData n => NFData (TypeSum n) where - rnf !ts - = case ts of - TypeSumBot{} - -> rnf (typeSumKind ts) - - TypeSumSet{} - -> rnf (typeSumKind ts) - `seq` rnf (typeSumElems ts) - `seq` rnf (typeSumBoundNamed ts) - `seq` rnf (typeSumBoundAnon ts) - `seq` rnf (typeSumSpill ts) - - -instance NFData TyConHash where - rnf (TyConHash i) - = rnf i - - -instance NFData n => NFData (TypeSumVarCon n) where - rnf ts - = case ts of - TypeSumVar u -> rnf u - TypeSumCon u t -> rnf u `seq` rnf t - - -instance NFData n => NFData (TyCon n) where - rnf tc - = case tc of - TyConSort con -> rnf con - TyConKind con -> rnf con - TyConWitness con -> rnf con - TyConSpec con -> rnf con - TyConBound con k -> rnf con `seq` rnf k - - -instance NFData SoCon -instance NFData KiCon -instance NFData TwCon -instance NFData TcCon - diff --git a/DDC/Type/Exp/Pretty.hs b/DDC/Type/Exp/Pretty.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Pretty.hs @@ -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" + diff --git a/DDC/Type/Exp/Simple.hs b/DDC/Type/Exp/Simple.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Simple.hs @@ -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 + + + diff --git a/DDC/Type/Exp/Simple/Compounds.hs b/DDC/Type/Exp/Simple/Compounds.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Simple/Compounds.hs @@ -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 + diff --git a/DDC/Type/Exp/Simple/Equiv.hs b/DDC/Type/Exp/Simple/Equiv.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Simple/Equiv.hs @@ -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. +-} diff --git a/DDC/Type/Exp/Simple/Exp.hs b/DDC/Type/Exp/Simple/Exp.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Simple/Exp.hs @@ -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 + diff --git a/DDC/Type/Exp/Simple/NFData.hs b/DDC/Type/Exp/Simple/NFData.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Simple/NFData.hs @@ -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 + diff --git a/DDC/Type/Exp/Simple/Predicates.hs b/DDC/Type/Exp/Simple/Predicates.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Simple/Predicates.hs @@ -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 + diff --git a/DDC/Type/Exp/Simple/Pretty.hs b/DDC/Type/Exp/Simple/Pretty.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Simple/Pretty.hs @@ -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 + diff --git a/DDC/Type/Exp/Simple/Subsumes.hs b/DDC/Type/Exp/Simple/Subsumes.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Simple/Subsumes.hs @@ -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 diff --git a/DDC/Type/Exp/TyCon.hs b/DDC/Type/Exp/TyCon.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/TyCon.hs @@ -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) + diff --git a/DDC/Type/Predicates.hs b/DDC/Type/Predicates.hs deleted file mode 100644 --- a/DDC/Type/Predicates.hs +++ /dev/null @@ -1,245 +0,0 @@ - --- | Predicates on type expressions. -module DDC.Type.Predicates - ( -- * Binders - isBNone - , isBAnon - , isBName - - -- * Atoms - , isTVar - , isBot - , isAtomT - - -- * Kinds - , isDataKind - , isRegionKind - , isEffectKind - , isClosureKind - , isWitnessKind - - -- * Data Types - , isAlgDataType - , isWitnessType - , isConstWitType - , isMutableWitType - , isDistinctWitType - - -- * Effect Types - , isReadEffect - , isWriteEffect - , isAllocEffect - , isSomeReadEffect - , isSomeWriteEffect - , isSomeAllocEffect) -where -import DDC.Type.Exp -import DDC.Type.Compounds -import 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 - - --- Kinds ---------------------------------------------------------------------- --- | Check if some kind is the data kind. -isDataKind :: Kind n -> Bool -isDataKind tt - = case tt of - TCon (TyConKind KiConData) -> True - _ -> False - - --- | Check if some kind is the region kind. -isRegionKind :: Region n -> Bool -isRegionKind tt - = case tt of - TCon (TyConKind KiConRegion) -> True - _ -> False - - --- | Check if some kind is the effect kind. -isEffectKind :: Kind n -> Bool -isEffectKind tt - = case tt of - TCon (TyConKind KiConEffect) -> True - _ -> False - - --- | Check if some kind is the closure kind. -isClosureKind :: Kind n -> Bool -isClosureKind tt - = case tt of - TCon (TyConKind KiConClosure) -> True - _ -> False - - --- | Check if some kind is the witness kind. -isWitnessKind :: Kind n -> Bool -isWitnessKind tt - = case tt of - TCon (TyConKind KiConWitness) -> True - _ -> False - - --- Data Types ----------------------------------------------------------------- --- | Check whether this type is that of algebraic data. --- --- It needs to have an explicit data constructor out the front, --- and not a type variable. The constructor must not be the function --- constructor, and must return a value of kind '*'. ---- --- The function constructor (->) also has this result kind, --- but it is in `TyConComp`, so is easy to ignore. -isAlgDataType :: Eq n => Type n -> Bool -isAlgDataType tt - | Just (tc, _) <- takeTyConApps tt - , TyConBound _ k <- tc - = takeResultKind k == kData - - | otherwise - = False - --- | Check whether type is a witness constructor -isWitnessType :: Eq n => Type n -> Bool -isWitnessType tt - = case takeTyConApps tt of - Just (TyConWitness _, _) -> True - _ -> False - - --- | Check whether this is the type of a @Const@ witness. -isConstWitType :: Eq n => Type n -> Bool -isConstWitType tt - = case takeTyConApps tt of - Just (TyConWitness TwConConst, _) -> True - _ -> False - - --- | Check whether this is the type of a @Mutable@ witness. -isMutableWitType :: Eq n => Type n -> Bool -isMutableWitType tt - = case takeTyConApps tt of - Just (TyConWitness TwConMutable, _) -> True - _ -> False - - --- | Check whether this is the type of a @Distinct@ witness. -isDistinctWitType :: Eq n => Type n -> Bool -isDistinctWitType tt - = case takeTyConApps tt of - Just (TyConWitness (TwConDistinct _), _) -> True - _ -> False - - --- Effects -------------------------------------------------------------------- --- | Check whether this is an atomic read effect. -isReadEffect :: Effect n -> Bool -isReadEffect eff - = case eff of - TApp (TCon (TyConSpec TcConRead)) _ -> True - _ -> False - - --- | Check whether this is an atomic write effect. -isWriteEffect :: Effect n -> Bool -isWriteEffect eff - = case eff of - TApp (TCon (TyConSpec TcConWrite)) _ -> True - _ -> False - - --- | Check whether this is an atomic alloc effect. -isAllocEffect :: Effect n -> Bool -isAllocEffect eff - = case eff of - TApp (TCon (TyConSpec TcConAlloc)) _ -> True - _ -> False - - --- | Check whether an effect is some sort of read effect. --- Matches @Read@ @HeadRead@ and @DeepRead@. -isSomeReadEffect :: Effect n -> Bool -isSomeReadEffect tt - = case tt of - TApp (TCon (TyConSpec con)) _ - -> case con of - TcConRead -> True - TcConHeadRead -> True - TcConDeepRead -> True - _ -> False - - _ -> False - - --- | Check whether an effect is some sort of allocation effect. --- Matches @Alloc@ and @DeepAlloc@ -isSomeWriteEffect :: Effect n -> Bool -isSomeWriteEffect tt - = case tt of - TApp (TCon (TyConSpec con)) _ - -> case con of - TcConWrite -> True - TcConDeepWrite -> True - _ -> False - - _ -> False - - --- | Check whether an effect is some sort of allocation effect. --- Matches @Alloc@ and @DeepAlloc@ -isSomeAllocEffect :: Effect n -> Bool -isSomeAllocEffect tt - = case tt of - TApp (TCon (TyConSpec con)) _ - -> case con of - TcConAlloc -> True - TcConDeepAlloc -> True - _ -> False - - _ -> False - diff --git a/DDC/Type/Pretty.hs b/DDC/Type/Pretty.hs deleted file mode 100644 --- a/DDC/Type/Pretty.hs +++ /dev/null @@ -1,198 +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 -> ppr n - UPrim n _ -> ppr n - UIx i -> text "^" <> ppr i - - --- Type ----------------------------------------------------------------------- -instance (Pretty n, Eq n) => Pretty (Type n) where - pprPrec d tt - = case tt of - -- Full application of function constructors are printed infix. - TApp (TApp (TCon (TyConKind KiConFun)) k1) k2 - -> pprParen (d > 5) - $ ppr k1 <+> text "~>" <+> ppr k2 - - TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2 - -> pprParen (d > 5) - $ pprPrec 6 t1 <+> text "=>" pprPrec 5 t2 - - -- Pure function. - TApp (TApp (TCon (TyConSpec TcConFun)) t1) t2 - -> pprParen (d > 5) - $ pprPrec 6 t1 <+> text "->" pprPrec 5 t2 - - -- Function with a latent effect and closure. - TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFunEC)) t1) eff) clo) t2 - | isBot eff, isBot clo - -> pprParen (d > 5) - $ pprPrec 6 t1 <+> text "->" pprPrec 5 t2 - - | otherwise - -> pprParen (d > 5) - $ pprPrec 6 t1 - <+> text "-(" <> ppr eff <> text " | " <> ppr clo <> text ")>" - pprPrec 5 t2 - - -- Standard types. - TCon tc -> ppr tc - TVar b -> ppr b - - TForall b t - | Just (bsMore, tBody) <- takeTForalls t - -> let groups = partitionBindsByType (b:bsMore) - in pprParen (d > 5) - $ (cat $ map pprBinderGroup groups) <> ppr tBody - - | otherwise - -> pprParen (d > 5) - $ brackets (ppr b) <> dot <> ppr t - - TApp t1 t2 - -> pprParen (d > 10) - $ ppr t1 <+> pprPrec 11 t2 - - TSum ts - | isBot tt, isEffectKind $ Sum.kindOfSum ts - -> text "Pure" - - | isBot tt, isClosureKind $ Sum.kindOfSum ts - -> text "Empty" - - | isBot tt, isDataKind $ Sum.kindOfSum ts - -> text "Bot" - - | isBot tt, otherwise - -> error $ stage ++ ": malformed sum" - - | 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 -> 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 "Comp" - SoConProp -> text "Prop" - - -instance Pretty KiCon where - ppr kc - = case kc of - KiConFun -> text "(~>)" - KiConData -> text "Data" - KiConRegion -> text "Region" - KiConEffect -> text "Effect" - KiConClosure -> text "Closure" - KiConWitness -> text "Witness" - - -instance Pretty TwCon where - ppr tw - = case tw of - TwConImpl -> text "(=>)" - TwConPure -> text "Purify" - TwConEmpty -> text "Emptify" - TwConGlobal -> text "Global" - TwConDeepGlobal -> text "DeepGlobal" - TwConConst -> text "Const" - TwConDeepConst -> text "DeepConst" - TwConMutable -> text "Mutable" - TwConDeepMutable-> text "DeepMutable" - TwConDistinct n -> text "Distinct" <> ppr n - TwConLazy -> text "Lazy" - TwConHeadLazy -> text "HeadLazy" - TwConManifest -> text "Manifest" - TwConDisjoint -> text "Disjoint" - - -instance Pretty TcCon where - ppr tc - = case tc of - TcConUnit -> text "Unit" - TcConFun -> text "(->)" - TcConFunEC -> text "(->)" - TcConSusp -> text "S" - TcConRead -> text "Read" - TcConHeadRead -> text "HeadRead" - TcConDeepRead -> text "DeepRead" - TcConWrite -> text "Write" - TcConDeepWrite -> text "DeepWrite" - TcConAlloc -> text "Alloc" - TcConDeepAlloc -> text "DeepAlloc" - TcConUse -> text "Use" - TcConDeepUse -> text "DeepUse" - - diff --git a/DDC/Type/Subsumes.hs b/DDC/Type/Subsumes.hs deleted file mode 100644 --- a/DDC/Type/Subsumes.hs +++ /dev/null @@ -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 diff --git a/DDC/Type/Sum.hs b/DDC/Type/Sum.hs --- a/DDC/Type/Sum.hs +++ b/DDC/Type/Sum.hs @@ -74,10 +74,7 @@ TVar (UPrim n _) -> Map.member n (typeSumBoundNamed ts) TCon{} -> L.elem t (typeSumSpill ts) - -- Foralls can't be a part of well-kinded sums. - -- Just check whether the types are strucutrally equal - -- without worring about alpha-equivalence. - TForall{} -> L.elem t (typeSumSpill ts) + TAbs{} -> L.elem t (typeSumSpill ts) TApp (TCon _) _ | Just (h, vc) <- takeSumArrayElem t @@ -86,6 +83,11 @@ TApp{} -> L.elem t (typeSumSpill ts) + -- Foralls can't be a part of well-kinded sums. + -- Just check whether the types are strucutrally equal + -- without worring about alpha-equivalence. + TForall{} -> L.elem t (typeSumSpill ts) + -- Treat bottom effect and closures as always -- being part of the sum. TSum ts1 @@ -110,12 +112,10 @@ TVar (UName n) -> ts { typeSumBoundNamed = Map.insert n k (typeSumBoundNamed ts) } TVar (UIx i) -> ts { typeSumBoundAnon = Map.insert i k (typeSumBoundAnon ts) } TVar (UPrim n _)-> ts { typeSumBoundNamed = Map.insert n k (typeSumBoundNamed ts) } + TCon{} -> ts { typeSumSpill = L.nub $ t : typeSumSpill ts } - -- Foralls can't be part of well-kinded sums. - -- Just add them to the splill lists so that we can still - -- pretty print such mis-kinded types. - TForall{} -> ts { typeSumSpill = L.nub $ t : typeSumSpill ts } + TAbs{} -> ts { typeSumSpill = L.nub $ t : typeSumSpill ts } TApp (TCon _) _ | Just (h, vc) <- takeSumArrayElem t @@ -125,6 +125,11 @@ else ts { typeSumElems = (typeSumElems ts) // [(h, Set.insert vc tsThere)] } TApp{} -> ts { typeSumSpill = L.nub $ t : typeSumSpill ts } + + -- Foralls can't be part of well-kinded sums. + -- Just add them to the splill lists so that we can still + -- pretty print such mis-kinded types. + TForall{} -> ts { typeSumSpill = L.nub $ t : typeSumSpill ts } TSum ts' -> foldr insert ts (toList ts') @@ -138,14 +143,17 @@ TVar (UIx i) -> ts { typeSumBoundAnon = Map.delete i (typeSumBoundAnon ts) } TVar (UPrim n _)-> ts { typeSumBoundNamed = Map.delete n (typeSumBoundNamed ts) } TCon{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } - TForall{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } + + TAbs{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } TApp (TCon _) _ | Just (h, vc) <- takeSumArrayElem t , tsThere <- typeSumElems ts ! h -> ts { typeSumElems = (typeSumElems ts) // [(h, Set.delete vc tsThere)] } - TApp{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } + TApp{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } + + TForall{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } TSum ts' -> foldr delete ts (toList ts') @@ -217,8 +225,6 @@ TcConWrite -> Just $ TyConHash 2 TcConDeepWrite -> Just $ TyConHash 3 TcConAlloc -> Just $ TyConHash 4 - TcConUse -> Just $ TyConHash 5 - TcConDeepUse -> Just $ TyConHash 6 _ -> Nothing @@ -239,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 @@ -312,15 +316,15 @@ -- kind. This allows us to use (tBot sComp) as the typeSumKind field -- when we want to compute the real kind based on the elements. | TypeSumSet{} <- ts1 - , TypeSumSet{} <- ts2 + , TypeSumSet{} <- ts2 = typeSumElems ts1 == typeSumElems ts2 && typeSumBoundNamed ts1 == typeSumBoundNamed ts2 && typeSumBoundAnon ts1 == typeSumBoundAnon ts2 && typeSumSpill ts1 == typeSumSpill ts2 - -- One is a set and one is bottom, so they are not equal. - | otherwise - = False + -- One is a set and one is bottom, so they are not equal. + | otherwise + = False where normalise ts | [] <- toList ts = empty (typeSumKind ts) @@ -328,23 +332,23 @@ 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 instance Eq n => Eq (TypeSumVarCon n) where - (==) (TypeSumVar u1) (TypeSumVar u2) = u1 == u2 - (==) (TypeSumCon u1 _) (TypeSumCon u2 _) = u1 == u2 - (==) _ _ = False + (==) (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 + compare (TypeSumVar u1) (TypeSumVar u2) = compare u1 u2 + compare (TypeSumCon u1 _) (TypeSumCon u2 _) = compare u1 u2 + compare (TypeSumVar _) _ = LT + compare (TypeSumCon _ _) _ = GT diff --git a/DDC/Type/Transform/BoundT.hs b/DDC/Type/Transform/BoundT.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Transform/BoundT.hs @@ -0,0 +1,109 @@ + +-- | Lifting and lowering of deBruijn indices in types. +module DDC.Type.Transform.BoundT + ( liftT, liftAtDepthT + , lowerT, lowerAtDepthT + , MapBoundT(..)) +where +import DDC.Type.Exp.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 + diff --git a/DDC/Type/Transform/Crush.hs b/DDC/Type/Transform/Crush.hs deleted file mode 100644 --- a/DDC/Type/Transform/Crush.hs +++ /dev/null @@ -1,185 +0,0 @@ -module DDC.Type.Transform.Crush - ( crushSomeT - , crushEffect ) -where -import DDC.Type.Predicates -import DDC.Type.Compounds -import DDC.Type.Transform.Trim -import DDC.Type.Exp -import qualified DDC.Type.Sum as Sum -import Data.Maybe - - --- | Crush compound effects and closure terms. --- We check for a crushable term before calling crushT because that function --- will recursively crush the components. --- As equivT is already recursive, we don't want a doubly-recursive function --- that tries to re-crush the same non-crushable type over and over. --- -crushSomeT :: Ord n => Type n -> Type n -crushSomeT tt - = {-# SCC crushSomeT #-} - case tt of - (TApp (TCon tc) _) - -> case tc of - TyConSpec TcConDeepRead -> crushEffect tt - TyConSpec TcConDeepWrite -> crushEffect tt - TyConSpec TcConDeepAlloc -> crushEffect tt - - -- If a closure is miskinded then 'trimClosure' - -- can return Nothing, so we just leave the term untrimmed. - TyConSpec TcConDeepUse -> fromMaybe tt (trimClosure tt) - - TyConWitness TwConDeepGlobal -> crushEffect tt - _ -> tt - - _ -> tt - - --- | Crush compound effect terms into their components. --- --- This is like `trimClosure` but for effects instead of closures. --- --- For example, crushing @DeepRead (List r1 (Int r2))@ yields @(Read r1 + Read r2)@. --- -crushEffect :: Ord n => Effect n -> Effect n -crushEffect tt - = {-# SCC crushEffect #-} - case tt of - TVar{} -> tt - TCon{} -> tt - TForall b t - -> TForall b (crushEffect t) - - TSum ts - -> TSum - $ Sum.fromList (Sum.kindOfSum ts) - $ map crushEffect - $ Sum.toList ts - - TApp t1 t2 - -- Head Read. - | Just (TyConSpec TcConHeadRead, [t]) <- takeTyConApps tt - -> case takeTyConApps t of - - -- Type has a head region. - Just (TyConBound _ k, (tR : _)) - | (k1 : _, _) <- takeKFuns k - , isRegionKind k1 - -> tRead tR - - -- Type has no head region. - -- This happens with case () of { ... } - Just (TyConSpec TcConUnit, []) -> tBot kEffect - Just (TyConBound _ _, []) -> tBot kEffect - - _ -> tt - - -- Deep Read. - -- See Note: Crushing with higher kinded type vars. - | Just (TyConSpec TcConDeepRead, [t]) <- takeTyConApps tt - -> case takeTyConApps t of - Just (TyConBound _ k, ts) - | (ks, _) <- takeKFuns k - , length ks == length ts - , Just effs <- sequence $ zipWith makeDeepRead ks ts - -> crushEffect $ TSum $ Sum.fromList kEffect effs - - _ -> tt - - -- Deep Write - -- See Note: Crushing with higher kinded type vars. - | Just (TyConSpec TcConDeepWrite, [t]) <- takeTyConApps tt - -> case takeTyConApps t of - Just (TyConBound _ k, ts) - | (ks, _) <- takeKFuns k - , length ks == length ts - , Just effs <- sequence $ zipWith makeDeepWrite ks ts - -> crushEffect $ TSum $ Sum.fromList kEffect effs - - _ -> tt - - -- Deep Alloc - -- See Note: Crushing with higher kinded type vars. - | Just (TyConSpec TcConDeepAlloc, [t]) <- takeTyConApps tt - -> case takeTyConApps t of - Just (TyConBound _ k, ts) - | (ks, _) <- takeKFuns k - , length ks == length ts - , Just effs <- sequence $ zipWith makeDeepAlloc ks ts - -> crushEffect $ TSum $ Sum.fromList kEffect effs - - _ -> tt - - -- Deep Global - -- See Note: Crushing with higher kinded type vars. - -- - -- NOTE: We're hijacking crushEffect to work on witnesses as well. - -- It would be better to split this into another function. - -- - | Just (TyConWitness TwConDeepGlobal, [t]) <- takeTyConApps tt - -> case takeTyConApps t of - Just (TyConBound _ k, ts) - | (ks, _) <- takeKFuns k - , length ks == length ts - , Just props <- sequence $ zipWith makeDeepGlobal ks ts - -> crushEffect $ TSum $ Sum.fromList kWitness props - - _ -> tt - - | otherwise - -> TApp (crushEffect t1) (crushEffect t2) - - --- | If this type has first order kind then wrap with the --- appropriate read effect. -makeDeepRead :: Kind n -> Type n -> Maybe (Effect n) -makeDeepRead k t - | isRegionKind k = Just $ tRead t - | isDataKind k = Just $ tDeepRead t - | isClosureKind k = Just $ tBot kEffect - | isEffectKind k = Just $ tBot kEffect - | otherwise = Nothing - - --- | If this type has first order kind then wrap with the --- appropriate read effect. -makeDeepWrite :: Kind n -> Type n -> Maybe (Effect n) -makeDeepWrite k t - | isRegionKind k = Just $ tWrite t - | isDataKind k = Just $ tDeepWrite t - | isClosureKind k = Just $ tBot kEffect - | isEffectKind k = Just $ tBot kEffect - | otherwise = Nothing - - --- | If this type has first order kind then wrap with the --- appropriate read effect. -makeDeepAlloc :: Kind n -> Type n -> Maybe (Effect n) -makeDeepAlloc k t - | isRegionKind k = Just $ tAlloc t - | isDataKind k = Just $ tDeepAlloc t - | isClosureKind k = Just $ tBot kEffect - | isEffectKind k = Just $ tBot kEffect - | otherwise = Nothing - - --- | If this type has first order kind then wrap with the --- appropriate read effect. -makeDeepGlobal :: Kind n -> Type n -> Maybe (Type n) -makeDeepGlobal k t - | isRegionKind k = Just $ tGlobal t - | isDataKind k = Just $ tDeepGlobal t - | isClosureKind k = Nothing - | isEffectKind k = Just $ tBot kEffect - | otherwise = Nothing - - -{- [Note: Crushing with higher kinded type vars] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We can't just look at the free variables here and wrap Read and DeepRead constructors - around them, as the type may contain higher kinded type variables such as: (t a). - Instead, we'll only crush the effect when all variable have first-order kind. - When comparing types with higher order variables, we'll have to use the type - equivalence checker, instead of relying on the effects to be pre-crushed. --} diff --git a/DDC/Type/Transform/Instantiate.hs b/DDC/Type/Transform/Instantiate.hs --- a/DDC/Type/Transform/Instantiate.hs +++ b/DDC/Type/Transform/Instantiate.hs @@ -5,13 +5,12 @@ 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) + :: Ord n => Type n -- ^ Type to instantiate. -> Type n -- ^ Argument type. -> Maybe (Type n) @@ -24,7 +23,7 @@ -- The type to be instantiated must have at least as many outer foralls -- as provided type arguments, else `Nothing`. instantiateTs - :: (Ord n, Pretty n) + :: Ord n => Type n -- ^ Type to instantiate. -> [Type n] -- ^ Argument types. -> Maybe (Type n) diff --git a/DDC/Type/Transform/LiftT.hs b/DDC/Type/Transform/LiftT.hs deleted file mode 100644 --- a/DDC/Type/Transform/LiftT.hs +++ /dev/null @@ -1,109 +0,0 @@ - --- | Lifting of deBruijn indices in a type. -module DDC.Type.Transform.LiftT - ( liftT, liftAtDepthT - , lowerT, lowerAtDepthT - , MapBoundT(..)) -where -import DDC.Type.Exp -import DDC.Type.Compounds -import qualified DDC.Type.Sum as Sum - - --- Lift ----------------------------------------------------------------------- --- | Lift debruijn indices less than or equal to the given depth. -liftAtDepthT - :: MapBoundT c n - => Int -- ^ Number of levels to lift. - -> Int -- ^ Current binding depth. - -> c n -- ^ Lift expression indices in this thing. - -> c n - -liftAtDepthT n d - = mapBoundAtDepthT liftU d - where - liftU d' u - = case u of - UName{} -> u - UPrim{} -> u - UIx i - | d' <= i -> UIx (i + n) - | otherwise -> u - - --- | Wrapper for `liftAtDepthX` that starts at depth 0. -liftT :: MapBoundT c n => Int -> c n -> c n -liftT n xx = liftAtDepthT n 0 xx - - --- Lower ---------------------------------------------------------------------- --- | Lower debruijn indices less than or equal to the given depth. -lowerAtDepthT - :: MapBoundT c n - => Int -- ^ Number of levels to lower. - -> Int -- ^ Current binding depth. - -> c n -- ^ Lower expression indices in this thing. - -> c n - -lowerAtDepthT n d - = mapBoundAtDepthT lowerU d - where - lowerU d' u - = case u of - UName{} -> u - UPrim{} -> u - UIx i - | d' <= i -> UIx (i - n) - | otherwise -> u - - --- | Wrapper for `lowerAtDepthX` that starts at depth 0. -lowerT :: MapBoundT c n => Int -> c n -> c n -lowerT n xx = lowerAtDepthT n 0 xx - - --- MapBoundT ------------------------------------------------------------------ -class MapBoundT (c :: * -> *) n where - -- | Apply a function to all bound variables in the program. - -- The function is passed the current binding depth. - -- This is used to defined both `liftT` and `lowerT`. - mapBoundAtDepthT - :: (Int -> Bound n -> Bound n) - -- ^ Function to apply to the bound occ. - -- It is passed the current binding depth. - -> Int -- ^ Current binding depth. - -> c n -- ^ Lift expression indices in this thing. - -> c n - - -instance Ord n => MapBoundT Bind n where - mapBoundAtDepthT f d bb - = replaceTypeOfBind (mapBoundAtDepthT f d $ typeOfBind bb) bb - - -instance MapBoundT Bound n where - mapBoundAtDepthT f d u - = f d u - - -instance Ord n => MapBoundT Type n where - mapBoundAtDepthT f d tt - = let down = mapBoundAtDepthT f d - in case tt of - TVar u -> TVar (f d u) - TCon{} -> tt - TForall b t -> TForall b (mapBoundAtDepthT f (d + countBAnons [b]) t) - TApp t1 t2 -> TApp (down t1) (down t2) - TSum ss -> TSum (down ss) - - -instance Ord n => MapBoundT TypeSum n where - mapBoundAtDepthT f d ss - = Sum.fromList (Sum.kindOfSum ss) - $ map (mapBoundAtDepthT f d) - $ Sum.toList ss - -countBAnons = length . filter isAnon - where isAnon (BAnon _) = True - isAnon _ = False - diff --git a/DDC/Type/Transform/Rename.hs b/DDC/Type/Transform/Rename.hs --- a/DDC/Type/Transform/Rename.hs +++ b/DDC/Type/Transform/Rename.hs @@ -18,8 +18,7 @@ -- * Rewriting bound occurences , use1, use0) where -import DDC.Type.Compounds -import DDC.Type.Exp +import DDC.Type.Exp.Simple import Data.List import Data.Set (Set) import qualified DDC.Type.Sum as Sum @@ -40,14 +39,21 @@ let down = renameWith in case tt of TVar u -> TVar (use1 sub u) + TCon{} -> tt + TAbs b t + -> let (sub1, b') = bind1 sub b + t' = down sub1 t + in TAbs b' t' + + TApp t1 t2 -> TApp (down sub t1) (down sub t2) + TForall b t -> let (sub1, b') = bind1 sub b t' = down sub1 t in TForall b' t' - TApp t1 t2 -> TApp (down sub t1) (down sub t2) TSum ts -> TSum (down sub ts) diff --git a/DDC/Type/Transform/SpreadT.hs b/DDC/Type/Transform/SpreadT.hs --- a/DDC/Type/Transform/SpreadT.hs +++ b/DDC/Type/Transform/SpreadT.hs @@ -2,10 +2,12 @@ module DDC.Type.Transform.SpreadT (SpreadT(..)) where +import DDC.Type.DataDef import DDC.Type.Exp 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 @@ -24,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) @@ -68,4 +75,31 @@ 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) } diff --git a/DDC/Type/Transform/SubstituteT.hs b/DDC/Type/Transform/SubstituteT.hs --- a/DDC/Type/Transform/SubstituteT.hs +++ b/DDC/Type/Transform/SubstituteT.hs @@ -11,13 +11,10 @@ , pushBinds , substBound) where -import DDC.Type.Collect -import DDC.Type.Compounds -import DDC.Type.Transform.LiftT -import DDC.Type.Transform.Crush -import DDC.Type.Transform.Trim +import DDC.Core.Collect +import DDC.Type.Transform.BoundT import DDC.Type.Transform.Rename -import DDC.Type.Exp +import DDC.Type.Exp.Simple import Data.Maybe import qualified DDC.Type.Sum as Sum import qualified DDC.Type.Env as Env @@ -25,7 +22,7 @@ import Data.Set (Set) --- | Substitute a `Type` for the `Bound` corresponding to some `Bind` in a thing. +-- | Substitute a `Type` for the `Bound` corresponding to a `Bind` in a thing. substituteT :: (SubstituteT c, Ord n) => Bind n -> Type n -> c n -> c n substituteT b t x = case takeSubstBoundOfBind b of @@ -58,15 +55,15 @@ class SubstituteT (c :: * -> *) where -- | Substitute a type into some thing. - -- In the target, if we find a named binder that would capture a free variable - -- in the type to substitute, then we rewrite that binder to anonymous form, - -- avoiding the capture. + -- In the target, if we find a named binder that would capture a free + -- variable in the type to substitute, then we rewrite that binder to + -- anonymous form, avoiding the capture. substituteWithT :: forall n. Ord n - => Bound n -- ^ Bound variable that we're subsituting into. - -> Type n -- ^ Type to substitute. - -> Set n -- ^ Names of free varaibles in the type to substitute. - -> BindStack n -- ^ Bind stack. + => Bound n -- ^ Bound variable that we're subsituting into. + -> Type n -- ^ Type to substitute. + -> Set n -- ^ Names of free varaibles in the type to substitute. + -> BindStack n -- ^ Bind stack. -> c n -> c n @@ -81,32 +78,29 @@ substituteWithT u t fns stack tt = let down = substituteWithT u t fns stack in case tt of - TCon{} -> tt - - -- Crush out compound effects and closures as we substitute them. - TApp t1 t2 - -> case t1 of - TCon (TyConSpec TcConHeadRead) - -> crushEffect (TApp t1 (down t2)) - - TCon (TyConSpec TcConDeepRead) - -> crushEffect (TApp t1 (down t2)) + TCon{} -> tt - TCon (TyConSpec TcConDeepWrite) - -> crushEffect (TApp t1 (down t2)) + TVar u' + -> case substBound stack u u' of + Left u'' -> TVar u'' + Right n -> liftT n t - TCon (TyConSpec TcConDeepAlloc) - -> crushEffect (TApp t1 (down t2)) + TAbs b tBody + | namedBoundMatchesBind u b -> tt + | otherwise + -> let -- Substitute into the annotation on the binder. + bSub = down b - -- If the closure is miskinded then trimClosure can - -- return Nothing, so we leave it untrimmed. - TCon (TyConSpec TcConDeepUse) - -> fromMaybe tt (trimClosure (TApp t1 (down t2))) + -- Push bind onto stack, and anonymise to avoid capture. + (stack', b') = pushBind fns stack bSub + + -- Substitute into body. + tBody' = substituteWithT u t fns stack' tBody - _ -> TApp (down t1) (down t2) + in TAbs b' tBody' - TSum ss - -> TSum (down ss) + TApp t1 t2 + -> TApp (down t1) (down t2) TForall b tBody | namedBoundMatchesBind u b -> tt @@ -114,7 +108,7 @@ -> let -- Substitute into the annotation on the binder. bSub = down b - -- Push bind onto stack, and anonymise to avoid capture if needed + -- Push bind onto stack, and anonymise to avoid capture. (stack', b') = pushBind fns stack bSub -- Substitute into body. @@ -122,10 +116,7 @@ in TForall b' tBody' - TVar u' - -> case substBound stack u u' of - Left u'' -> TVar u'' - Right n -> liftT n t + TSum ss -> TSum (down ss) instance SubstituteT TypeSum where diff --git a/DDC/Type/Transform/Trim.hs b/DDC/Type/Transform/Trim.hs deleted file mode 100644 --- a/DDC/Type/Transform/Trim.hs +++ /dev/null @@ -1,166 +0,0 @@ - -module DDC.Type.Transform.Trim - (trimClosure) -where -import DDC.Type.Collect -import DDC.Type.Check.CheckCon -import DDC.Type.Exp -import DDC.Type.Compounds -import DDC.Type.Predicates -import Control.Monad -import Data.Set (Set) -import qualified DDC.Type.Env as Env -import qualified DDC.Type.Sum as Sum -import qualified Data.Set as Set - - --- | Trim compound closures into their components. --- --- This is like `crushEffect`, but for closures instead of effects. --- --- For example, trimming @DeepUse (Int r2 -(Read r1 | Use r1)> Int r2)@ yields --- just @Use r1@. --- Only @r1@ might contain an actual store object that is reachable from a function --- closure with such a type. --- --- This function assumes the closure is well-kinded, and may return `Nothing` if --- this is not the case. --- -trimClosure - :: Ord n - => Closure n - -> Maybe (Closure n) - -trimClosure cc - = {-# SCC trimClosure #-} - liftM TSum $ trimToSumC cc - - --- | Trim a closure down to a closure sum. --- May return 'Nothing' if the closure is mis-kinded. -trimToSumC - :: forall n. Ord n - => Closure n -> Maybe (TypeSum n) - -trimToSumC cc - = case cc of - -- Keep closure variables. - TVar{} -> Just $ Sum.singleton kClosure cc - - -- There aren't any naked constructors of closure type. - -- If we find a constructor the closure is miskinded. - TCon{} -> Nothing - - -- The body of a forall should have data or witness kind. - -- If we find a forall then the closure is miskinded. - TForall{} -> Nothing - - -- Keep use constructor applied to a region. - TApp (TCon (TyConSpec TcConUse)) _ - -> Just $ Sum.singleton kClosure cc - - -- Trim DeepUse constructor applied to a data type. - TApp (TCon (TyConSpec TcConDeepUse)) t2 - -> Just $ trimDeepUsedD t2 - - -- Some other constructor we don't know about, - -- perhaps using a type variable of higher kind. - TApp{} -> Just $ Sum.singleton kClosure cc - - -- Trim components of a closure sum and rebuild the sum. - TSum ts - -> case sequence $ map trimToSumC $ Sum.toList ts of - Nothing -> Nothing - Just sums -> Just $ Sum.fromList kClosure - $ concatMap Sum.toList sums - - --- | Trim the argument of a DeepUsed constructor down to a closure sum. --- The argument is of data kind. -trimDeepUsedD - :: forall n. Ord n - => Type n -> TypeSum n - -trimDeepUsedD tt - = case tt of - -- Keep type variables. - TVar{} -> Sum.singleton kClosure $ tDeepUse tt - - -- Naked data constructors like 'Unit' don't contain region variables, - -- but the interpreter uses constructors of region kind to encode - -- region handes, that we need to keep. - TCon tc - | Just k <- takeKindOfTyCon tc - , isRegionKind k - -> Sum.singleton kClosure $ tDeepUse tt - - | otherwise - -> Sum.empty kClosure - - -- Add locally bound variable to the environment. - -- See Note: Trimming Foralls. - TForall{} - -> let ns = freeT Env.empty tt :: Set (Bound n) - in if Set.size ns == 0 - then Sum.empty kClosure - else Sum.singleton kClosure $ tDeepUse tt - - -- Trim function constructors. - -- See Note: Material variables and the interpreter - TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFunEC)) _t1) _eff) clo) _t2 - -> Sum.singleton kClosure clo - - -- Trim a type application. - -- See Note: Trimming with higher kinded type vars. - TApp{} - -> case takeTyConApps tt of - Just (tc, args) - | Just k <- takeKindOfTyCon tc - , Just cs <- sequence $ zipWith makeUsed (takeKFuns' k) args - -> Sum.fromList kClosure cs - - _ -> Sum.singleton kClosure $ tDeepUse tt - - -- We shouldn't get sums of data types in regular code, - -- but the (tBot kData) form might appear in debugging. - TSum{} -> Sum.singleton kClosure $ tDeepUse tt - - --- | Make the appropriate Use term for a type of the given kind, or `Nothing` if --- there isn't one. Also recursively trim types of data kind. -makeUsed :: (Eq n, Ord n) => Kind n -> Type n -> Maybe (Closure n) -makeUsed k t - | isRegionKind k = Just $ tUse t - | isDataKind k = Just $ TSum $ trimDeepUsedD t - | isEffectKind k = Just $ tBot kClosure - | isClosureKind k = Just $ t - | otherwise = Nothing - - -{- [Note: Trimming with higher kinded type vars] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We can't just look at the free variables here and wrap Use and DeepUse constructors - around them, as the type may contain higher kinded type variables such as: (t a). - We cannot simply drop such variables, as they may be substituted for types that - contain components that we must keep in the closure. To handle this, when we see - higher kinded type varibles we preserve the entire type application, which is - DeepUse (t a) in this example. - - [Note: Trimming Foralls] - ~~~~~~~~~~~~~~~~~~~~~~~~ - For now we just drop the forall if the free vars list is empty. This is ok because - we only do this at top-level, so don't need to lower debruijn indices to account for - deleted intermediate quantifiers. - - [Note: Material variables and the interpreter] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Even though we're not tracking material vars properly yet, - for the interpreter we need to ignore the non-material parameters of the - function constructor so that we can treat store location constructors as - having an empty closure. For example: - - L2# :: Int R1# -> Int R1# - - This does not capture the R1# region, even the handle for it is in its type. --} - diff --git a/DDC/Type/Universe.hs b/DDC/Type/Universe.hs --- a/DDC/Type/Universe.hs +++ b/DDC/Type/Universe.hs @@ -1,22 +1,26 @@ module DDC.Type.Universe ( Universe(..) + , universeUp , universeFromType3 , universeFromType2 , universeFromType1 , universeOfType) where import DDC.Type.Exp -import DDC.Base.Pretty +import DDC.Data.Pretty import DDC.Type.Env as Env import qualified DDC.Type.Sum as T -- | Universes of the Disciple Core language. data Universe + -- | A numbered universe (levels 4..) + = UniverseLevel Int + -- | (level 3). The universe of sorts. -- Sorts classify kinds. - = UniverseSort + | UniverseSort -- | (level 2). The universe of kinds. -- Kinds classify specifications. @@ -48,6 +52,7 @@ instance Pretty Universe where ppr u = case u of + UniverseLevel i -> text "Universe" <> int i UniverseSort -> text "Sort" UniverseKind -> text "Kind" UniverseSpec -> text "Spec" @@ -55,6 +60,18 @@ UniverseData -> text "Data" +-- | Take the next highest universe of the given one. +universeUp :: Universe -> Universe +universeUp uu + = case uu of + UniverseLevel n -> UniverseLevel (n + 1) + UniverseSort -> UniverseLevel 4 + UniverseKind -> UniverseSort + UniverseSpec -> UniverseKind + UniverseWitness -> UniverseSpec + UniverseData -> UniverseSpec + + -- | Given the type of the type of the type of some thing (up three levels), -- yield the universe of the original thing, or `Nothing` it was badly formed. universeFromType3 :: Type n -> Maybe Universe @@ -71,6 +88,7 @@ universeFromType2 tt = case tt of TVar _ -> Nothing + TCon (TyConSort _) -> Just UniverseSpec TCon (TyConKind kc) @@ -82,8 +100,11 @@ TCon TyConWitness{} -> Nothing TCon TyConSpec{} -> Nothing TCon TyConBound{} -> Nothing - TForall _ _ -> Nothing + TCon TyConExists{} -> Nothing + + TAbs{} -> Nothing TApp _ t2 -> universeFromType2 t2 + TForall{} -> Nothing TSum _ -> Nothing @@ -100,12 +121,18 @@ TCon (TyConSort _) -> Just UniverseKind TCon (TyConKind _) -> Just UniverseSpec TCon (TyConWitness _) -> Just UniverseWitness - TCon (TyConSpec TcConFunEC)-> Just UniverseData + TCon (TyConSpec TcConUnit) -> Just UniverseData + TCon (TyConSpec TcConFun) -> Just UniverseData + TCon (TyConSpec TcConSusp) -> Just UniverseData TCon (TyConSpec _) -> Nothing - TCon (TyConBound _ k) -> universeFromType2 k - TForall b t2 -> universeFromType1 (Env.extend b kenv) t2 + + 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 @@ -127,9 +154,12 @@ TCon (TyConKind _) -> Just UniverseKind TCon (TyConWitness _) -> Just UniverseSpec TCon (TyConSpec _) -> Just UniverseSpec - TCon (TyConBound _ k) -> universeFromType1 kenv k - TForall b t2 -> universeOfType (Env.extend b kenv) t2 + 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) diff --git a/DDC/Version.hs b/DDC/Version.hs new file mode 100644 --- /dev/null +++ b/DDC/Version.hs @@ -0,0 +1,8 @@ + +module DDC.Version where + +splash :: String +splash = "The Disciplined Disciple Compiler, version " ++ version + +version :: String +version = "0.4.3" diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2013 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 - diff --git a/ddc-core.cabal b/ddc-core.cabal --- a/ddc-core.cabal +++ b/ddc-core.cabal @@ -1,5 +1,5 @@ Name: ddc-core -Version: 0.3.2.1 +Version: 0.4.3.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -11,151 +11,240 @@ Homepage: http://disciple.ouroborus.net Synopsis: Disciplined Disciple Compiler core language and type checker. Description: - Disciple Core is an explicitly typed language based on System-F2, intended - as an intermediate representation for a compiler. In addition to the polymorphism of - System-F2 it supports region, effect and closure typing. Evaluation order is - left-to-right call-by-value by default. There is a capability system to track whether - objects are mutable or constant, and to ensure that computations that perform visible - side effects are not reordered inappropriately. + Disciple Core is an explicitly typed language based on System-F2, + intended as an intermediate representation for a compiler. In addition + to the polymorphism of System-F2 it supports region, effect and closure + typing. Evaluation order is left-to-right call-by-value by default. + There is a capability system to track whether objects are mutable or + constant, and to ensure that computations that perform visible side + effects are not reordered inappropriately. See the @ddc-tools@ package for a user-facing interpreter and compiler. Library Build-Depends: - base == 4.6.*, - deepseq == 1.3.*, + base >= 4.6 && < 4.10, + array >= 0.4 && < 0.6, + deepseq >= 1.3 && < 1.5, containers == 0.5.*, - array == 0.4.*, directory == 1.2.*, - transformers == 0.3.*, - mtl == 2.1.*, - ddc-base == 0.3.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.Annot.AnT - DDC.Core.Annot.AnTEC + DDC.Control.Check + DDC.Control.Panic + DDC.Control.Parser - DDC.Core.Check - DDC.Core.Collect + DDC.Core.Collect.Support + DDC.Core.Collect.BindStruct + DDC.Core.Collect.FreeT + DDC.Core.Collect.FreeX - DDC.Core.Compounds.Annot - DDC.Core.Compounds.Simple - DDC.Core.Compounds + DDC.Core.Env.EnvT + DDC.Core.Env.EnvX - DDC.Core.Exp.Simple - DDC.Core.Exp.Annot - DDC.Core.Exp + 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.Fragment + DDC.Core.Exp.Annot + DDC.Core.Exp.Generic + DDC.Core.Exp.Literal - DDC.Core.Lexer.Names + DDC.Core.Lexer.Offside DDC.Core.Lexer.Tokens - DDC.Core.Lexer - - DDC.Core.Parser - - DDC.Core.Transform.Annotate - DDC.Core.Transform.Deannotate - DDC.Core.Transform.LiftT - DDC.Core.Transform.LiftX + 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.Transform.Trim + DDC.Core.Call + DDC.Core.Check + DDC.Core.Collect + DDC.Core.Exp + DDC.Core.Fragment + DDC.Core.Lexer DDC.Core.Load DDC.Core.Module - DDC.Core.Predicates + DDC.Core.Parser DDC.Core.Pretty - DDC.Type.Transform.Crush + DDC.Data.Canned + DDC.Data.Env + DDC.Data.ListUtils + DDC.Data.Name + DDC.Data.Pretty + DDC.Data.SourcePos + + DDC.Type.Exp.Flat.Exp + DDC.Type.Exp.Flat.Pretty + + DDC.Type.Exp.Generic.Binding + DDC.Type.Exp.Generic.Compounds + DDC.Type.Exp.Generic.Exp + DDC.Type.Exp.Generic.NFData + DDC.Type.Exp.Generic.Predicates + DDC.Type.Exp.Generic.Pretty + + DDC.Type.Exp.Simple.Compounds + DDC.Type.Exp.Simple.Equiv + DDC.Type.Exp.Simple.Exp + DDC.Type.Exp.Simple.Predicates + DDC.Type.Exp.Simple.Subsumes + + DDC.Type.Exp.Flat + DDC.Type.Exp.Generic + DDC.Type.Exp.Pretty + DDC.Type.Exp.Simple + DDC.Type.Exp.TyCon + + DDC.Type.Transform.BoundT DDC.Type.Transform.Instantiate - DDC.Type.Transform.LiftT DDC.Type.Transform.Rename DDC.Type.Transform.SpreadT DDC.Type.Transform.SubstituteT - DDC.Type.Transform.Trim + DDC.Type.Bind - DDC.Type.Check - DDC.Type.Collect - DDC.Type.Compounds DDC.Type.DataDef DDC.Type.Env - DDC.Type.Equiv DDC.Type.Exp - DDC.Type.Predicates - DDC.Type.Pretty - DDC.Type.Subsumes DDC.Type.Sum DDC.Type.Universe + DDC.Version + + Other-modules: - DDC.Core.Check.CheckDaCon - DDC.Core.Check.CheckExp - DDC.Core.Check.CheckModule - DDC.Core.Check.CheckWitness - DDC.Core.Check.ErrorMessage + 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.TaggedClosure + DDC.Core.Check.Exp - DDC.Core.Collect.Support - DDC.Core.Collect.Free + 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.Exp.DaCon - DDC.Core.Exp.Pat DDC.Core.Fragment.Compliance DDC.Core.Fragment.Error DDC.Core.Fragment.Feature DDC.Core.Fragment.Profile - DDC.Core.Lexer.Comments - DDC.Core.Lexer.Offside + DDC.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.Check.CheckCon - DDC.Type.Check.Error - DDC.Type.Check.ErrorMessage - DDC.Type.Check.Config - - DDC.Type.Collect.FreeT - - DDC.Type.Exp.Base - DDC.Type.Exp.NFData + DDC.Type.Exp.Simple.NFData + DDC.Type.Exp.Simple.Pretty - GHC-options: -Wall -fno-warn-orphans - -fno-warn-missing-signatures -fno-warn-unused-do-bind + -fno-warn-missing-methods + -fno-warn-missing-signatures + -fno-warn-missing-pattern-synonym-signatures + -fno-warn-redundant-constraints Extensions: - BangPatterns - ParallelListComp - PatternGuards - RankNTypes - FlexibleContexts - FlexibleInstances + NoMonomorphismRestriction + FunctionalDependencies MultiParamTypeClasses UndecidableInstances - KindSignatures - NoMonomorphismRestriction ScopedTypeVariables StandaloneDeriving - DoAndIfThenElse DeriveDataTypeable + FlexibleInstances + ParallelListComp + FlexibleContexts + ConstraintKinds + DoAndIfThenElse + PatternSynonyms + KindSignatures + PatternGuards + BangPatterns + InstanceSigs ViewPatterns - FunctionalDependencies + RankNTypes