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/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,17 +1,100 @@ - --- | Type checker for the Disciple core language. +-- | Type checker for the Disciple Core language. +-- +-- The functions in this module do not check for language fragment compliance. +-- This needs to be done separately via "DDC.Core.Fragment". +-- module DDC.Core.Check - ( -- * Checking Expressions - checkExp, typeOfExp + ( -- * Configuration + Config(..) + , configOfProfile + -- * Type checker trace + , CheckTrace (..) + + -- * Checking Modules + , checkModule + + -- * Checking Types + , checkType, checkTypeM + , checkSpec + , kindOfSpec + , sortOfKind + + -- * Checking Expressions + , Mode (..) + , Demand (..) + , checkExp, typeOfExp + -- * Checking Witnesses , checkWitness, typeOfWitness , typeOfWiCon + -- * Kinds of Constructors + , takeSortOfKiCon + , kindOfTwCon + , kindOfTcCon + + -- * Annotations + , AnTEC(..) + -- * Error messages - , Error(..)) + , Error (..) + , ErrorType (..) + , ErrorData (..)) where +import DDC.Core.Check.Judge.Kind +import DDC.Core.Check.Judge.Kind.TyCon +import DDC.Core.Check.Judge.Module +import DDC.Core.Check.Judge.Witness import DDC.Core.Check.Error -import DDC.Core.Check.ErrorMessage () -import DDC.Core.Check.CheckExp -import DDC.Core.Check.CheckWitness +import DDC.Core.Check.Exp +import DDC.Core.Check.Base + + +-- | Check a type in the given universe with the given environment +-- Returns the updated type and its classifier (a kind or sort), +-- depeding on the universe of the type being checked. +checkType :: (Ord n, Show n, Pretty n) + => Config n -> Universe -> Type n + -> Either (Error a n) (Type n, Type n) + +checkType config uni tt + = evalCheck (mempty, 0, 0) + $ do (t, k, _) <- checkTypeM config emptyContext uni tt Recon + return (t, k) + + +-- | Check a spec in the given environment, returning an error or its kind. +checkSpec :: (Ord n, Show n, Pretty n) + => Config n -> Type n + -> Either (Error a n) (Type n, Kind n) + +checkSpec config tt + = evalCheck (mempty, 0, 0) + $ do (t, k, _) <- checkTypeM config emptyContext UniverseSpec tt Recon + return (t, k) + + +-- | Check a spec in an empty environment, returning an error or its kind. +kindOfSpec + :: (Ord n, Show n, Pretty n) + => Config n -> Type n + -> Either (Error a n) (Kind n) + +kindOfSpec config tt + = evalCheck (mempty, 0, 0) + $ do (_, k, _) <- checkTypeM config emptyContext UniverseSpec tt Recon + return k + + +-- | Check a kind in an empty environment, returning an error or its sort. +sortOfKind + :: (Ord n, Show n, Pretty n) + => Config n -> Kind n + -> Either (Error a n) (Sort n) + +sortOfKind config tt + = evalCheck (mempty, 0, 0) + $ do (_, s, _) <- checkTypeM config emptyContext UniverseKind tt Recon + return s + 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/CheckExp.hs b/DDC/Core/Check/CheckExp.hs deleted file mode 100644 --- a/DDC/Core/Check/CheckExp.hs +++ /dev/null @@ -1,946 +0,0 @@ - --- | Type checker for the Disciple Core language. -module DDC.Core.Check.CheckExp - ( checkExp - , typeOfExp - , CheckM - , checkExpM - , TaggedClosure(..)) -where -import DDC.Core.DataDef -import DDC.Core.Predicates -import DDC.Core.Compounds -import DDC.Core.Exp -import DDC.Core.Pretty -import DDC.Core.Collect -import DDC.Core.Check.Error -import DDC.Core.Check.CheckWitness -import DDC.Core.Check.TaggedClosure -import DDC.Type.Transform.SubstituteT -import DDC.Type.Transform.Crush -import DDC.Type.Transform.Trim -import DDC.Type.Transform.Instantiate -import DDC.Type.Transform.LiftT -import DDC.Type.Transform.LowerT -import DDC.Type.Equiv -import DDC.Type.Universe -import DDC.Type.Compounds -import DDC.Type.Predicates -import DDC.Type.Sum as Sum -import DDC.Type.Env (Env) -import DDC.Type.Check.Monad (result, throw) -import DDC.Base.Pretty () -import Data.Set (Set) -import qualified DDC.Type.Env as Env -import qualified DDC.Type.Check as T -import qualified Data.Set as Set -import qualified Data.Map as Map -import Control.Monad -import Data.List as L -import Data.Maybe - - --- Wrappers ------------------------------------------------------------------- --- | Type check an expression. --- --- If it's good, you get a new version with types attached to all the bound --- variables, as well its the type, effect and closure. --- --- If it's bad, you get a description of the error. --- --- The returned expression has types attached to all variable occurrences, --- so you can call `typeOfExp` on any open subterm. -checkExp - :: (Ord n, Pretty n) - => DataDefs n -- ^ Data type definitions. - -> Env n -- ^ Kind environment. - -> Env n -- ^ Type environment. - -> Exp a n -- ^ Expression to check. - -> Either (Error a n) - ( Exp a n - , Type n - , Effect n - , Closure n) - -checkExp defs kenv tenv xx - = result - $ do (xx', t, effs, clos) <- checkExpM defs kenv tenv xx - return ( xx' - , t - , TSum effs - , closureOfTaggedSet clos) - - --- | Like `checkExp`, but check in an empty environment, --- and only return the value type of an expression. --- --- As this function is not given an environment, the types of free variables --- must be attached directly to the bound occurrences. --- This attachment is performed by `checkExp` above. --- -typeOfExp - :: (Ord n, Pretty n) - => DataDefs n - -> Exp a n - -> Either (Error a n) (Type n) -typeOfExp defs xx - = case checkExp defs Env.empty Env.empty xx of - Left err -> Left err - Right (_, t, _, _) -> Right t - - --- checkExp ------------------------------------------------------------------- --- | Like `checkExp` but using the `CheckM` monad to handle errors. -checkExpM - :: (Ord n, Pretty n) - => DataDefs n -- ^ Data type definitions. - -> Env n -- ^ Kind environment. - -> Env n -- ^ Type environment. - -> Exp a n -- ^ Expression to check. - -> CheckM a n - ( Exp a n - , Type n - , TypeSum n - , Set (TaggedClosure n)) - -checkExpM defs kenv tenv xx - = checkExpM' defs kenv tenv xx -{-} = do (xx', t, eff, clo) <- checkExpM' defs kenv tenv xx - trace (pretty $ vcat - [ text "checkExpM: " <+> ppr xx - , text " :: " <+> ppr t - , text " :!: " <+> ppr eff - , text " :$: " <+> ppr clo - , text ""]) - $ return (xx', t, eff, clo) --} - --- variables ------------------------------------ -checkExpM' _defs _kenv tenv (XVar a u) - = do let tBound = typeOfBound u - let mtEnv = Env.lookup u tenv - - let mkResult - -- When annotation on the bound is bot, - -- then use the type from the environment. - | Just tEnv <- mtEnv - , isBot tBound - = return tEnv - - -- The bound has an explicit type annotation, - -- which matches the one from the environment. - -- - -- When the bound is a deBruijn index we need to lift the - -- annotation on the original binder through any lambdas - -- between the binding occurrence and the use. - | Just tEnv <- mtEnv - , UIx i _ <- u - , equivT tBound (liftT (i + 1) tEnv) - = return tBound - - -- The bound has an explicit type annotation, - -- which matches the one from the environment. - | Just tEnv <- mtEnv - , equivT tBound tEnv - = return tEnv - - -- The bound has an explicit type annotation, - -- which does not match the one from the environment. - -- This shouldn't happen because the parser doesn't add non-bot - -- annotations to bound variables. - | Just tEnv <- mtEnv - = throw $ ErrorVarAnnotMismatch u tEnv - - -- Variable not in environment, so use annotation. - -- This happens when checking open terms. - | otherwise - = return tBound - - tResult <- mkResult - - return ( XVar a u - , tResult - , Sum.empty kEffect - , Set.singleton - $ taggedClosureOfValBound - $ replaceTypeOfBound tResult u) - - --- constructors --------------------------------- -checkExpM' defs _kenv _tenv xx@(XCon a u) - | UName n _ <- u - = case Map.lookup n (dataDefsCtors defs) of - Nothing -> throw $ ErrorUndefinedCtor xx - Just _ - -> return - ( XCon a u - , typeOfBound u - , Sum.empty kEffect - , Set.empty) - - | UPrim{} <- u - = return ( XCon a u - , typeOfBound u - , Sum.empty kEffect - , Set.empty) - - -- Constructors can't be locally bound. - | otherwise - = throw $ ErrorMalformedExp xx - - --- application ------------------------------------ --- value-type application. -checkExpM' defs kenv tenv xx@(XApp a x1 (XType t2)) - = do (x1', t1, effs1, clos1) <- checkExpM defs kenv tenv x1 - k2 <- checkTypeM defs kenv t2 - case t1 of - TForall b11 t12 - | typeOfBind b11 == k2 - -> return ( XApp a x1' (XType t2) - , substituteT b11 t2 t12 - , substituteT b11 t2 effs1 - , clos1 `Set.union` taggedClosureOfTyArg t2) - - | otherwise -> throw $ ErrorAppMismatch xx (typeOfBind b11) t2 - _ -> throw $ ErrorAppNotFun xx t1 t2 - - --- value-witness application. -checkExpM' defs kenv tenv xx@(XApp a x1 (XWitness w2)) - = do (x1', t1, effs1, clos1) <- checkExpM defs kenv tenv x1 - t2 <- checkWitnessM defs kenv tenv w2 - case t1 of - TApp (TApp (TCon (TyConWitness TwConImpl)) t11) t12 - | t11 `equivT` t2 - -> return ( XApp a x1' (XWitness w2) - , t12 - , effs1 - , clos1) - - | otherwise -> throw $ ErrorAppMismatch xx t11 t2 - _ -> throw $ ErrorAppNotFun xx t1 t2 - - --- value-value application. -checkExpM' defs kenv tenv xx@(XApp a x1 x2) - = do (x1', t1, effs1, clos1) <- checkExpM defs kenv tenv x1 - (x2', t2, effs2, clos2) <- checkExpM defs kenv tenv x2 - - -- Note: we don't need to use the closure of the function because - -- all of its components will already be part of clos1 above. - case t1 of - TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFun)) t11) eff) _clo) t12 - | t11 `equivT` t2 - , effs <- Sum.fromList kEffect [eff] - -> return ( XApp a x1' x2' - , t12 - , effs1 `Sum.union` effs2 `Sum.union` effs - , clos1 `Set.union` clos2) - - | otherwise -> throw $ ErrorAppMismatch xx t11 t2 - _ -> throw $ ErrorAppNotFun xx t1 t2 - - --- spec abstraction ----------------------------- -checkExpM' defs kenv tenv xx@(XLAM a b1 x2) - = do let t1 = typeOfBind b1 - _ <- checkTypeM defs kenv t1 - - -- Check the body - let kenv' = Env.extend b1 kenv - let tenv' = Env.lift 1 tenv - (x2', t2, e2, c2) <- checkExpM defs kenv' tenv' x2 - k2 <- checkTypeM defs kenv' t2 - - when (Env.memberBind b1 kenv) - $ throw $ ErrorLamShadow xx b1 - - -- The body of a spec abstraction must be pure. - when (e2 /= Sum.empty kEffect) - $ throw $ ErrorLamNotPure xx (TSum e2) - - -- The body of a spec abstraction must have data kind. - when (not $ isDataKind k2) - $ throw $ ErrorLamBodyNotData xx b1 t2 k2 - - -- Mask closure terms due to locally bound region vars. - let c2_cut = Set.fromList - $ mapMaybe (cutTaggedClosureT b1) - $ Set.toList c2 - - return ( XLAM a b1 x2' - , TForall b1 t2 - , Sum.empty kEffect - , c2_cut) - - --- function abstractions ------------------------ -checkExpM' defs kenv tenv xx@(XLam a b1 x2) - = do let t1 = typeOfBind b1 - k1 <- checkTypeM defs kenv t1 - - -- Check the body. - let tenv' = Env.extend b1 tenv - (x2', t2, e2, c2) <- checkExpM defs kenv tenv' x2 - k2 <- checkTypeM defs kenv t2 - - -- The form of the function constructor depends on what universe the - -- binder is in. - case universeFromType2 k1 of - Just UniverseData - | not $ isDataKind k1 -> throw $ ErrorLamBindNotData xx t1 k1 - | not $ isDataKind k2 -> throw $ ErrorLamBodyNotData xx b1 t2 k2 - | otherwise - -> let - -- Cut closure terms due to locally bound value vars. - -- This also lowers deBruijn indices in un-cut closure terms. - c2_cut = Set.fromList - $ mapMaybe (cutTaggedClosureX b1) - $ Set.toList c2 - - -- Trim the closure before we annotate the returned function - -- type with it. - -- This should always succeed because trimClosure only returns - -- Nothing if the closure is miskinded, and we've already - -- allready checked that. - Just c2_captured - = trimClosure $ closureOfTaggedSet c2_cut - - in return ( XLam a b1 x2' - , tFun t1 (TSum e2) c2_captured t2 - , Sum.empty kEffect - , c2_cut) - - Just UniverseWitness - | e2 /= Sum.empty kEffect -> throw $ ErrorLamNotPure xx (TSum e2) - | not $ isDataKind k2 -> throw $ ErrorLamBodyNotData xx b1 t2 k2 - | otherwise - -> return ( XLam a b1 x2' - , tImpl t1 t2 - , Sum.empty kEffect - , c2) - - _ -> throw $ ErrorMalformedType xx k1 - - --- let -------------------------------------------- -checkExpM' defs kenv tenv xx@(XLet a (LLet mode b11 x12) x2) - = do -- Check the right of the binding. - (x12', t12, effs12, clo12) - <- checkExpM defs kenv tenv x12 - - -- Check binder annotation against the type we inferred for the right. - (b11', k11') - <- checkLetBindOfTypeM xx defs kenv tenv t12 b11 - - -- The right of the binding should have data kind. - when (not $ isDataKind k11') - $ throw $ ErrorLetBindingNotData xx b11' k11' - - -- Check the body expression. - let tenv1 = Env.extend b11' tenv - (x2', t2, effs2, c2) <- checkExpM defs kenv tenv1 x2 - - -- The body should have data kind. - k2 <- checkTypeM defs kenv t2 - when (not $ isDataKind k2) - $ throw $ ErrorLetBodyNotData xx t2 k2 - - -- Mask closure terms due to locally bound value vars. - let c2_cut = Set.fromList - $ mapMaybe (cutTaggedClosureX b11') - $ Set.toList c2 - - -- Check purity and emptiness for lazy bindings. - (case mode of - LetStrict -> return () - LetLazy _ - -> do let eff12' = TSum effs12 - when (not $ isBot eff12') - $ throw $ ErrorLetLazyNotPure xx b11 eff12' - - let clo12' = closureOfTaggedSet clo12 - when (not $ isBot clo12') - $ throw $ ErrorLetLazyNotEmpty xx b11 clo12') - - -- Check region witness for lazy bindings. - (case mode of - LetStrict -> return () - - -- Type of lazy binding has no head region, like Unit and (->). - LetLazy Nothing - -> do case takeDataTyConApps t12 of - Just (_tc, t1 : _) - -> do k1 <- checkTypeM defs kenv t1 - when (isRegionKind k1) - $ throw $ ErrorLetLazyNoWitness xx b11 t12 - - _ -> return () - - -- Type of lazy binding might have a head region, - -- so we need a Lazy witness for it. - LetLazy (Just wit) - -> do tWit <- checkWitnessM defs kenv tenv wit - let tWitExp = case takeDataTyConApps t12 of - Just (_tc, tR : _ts) -> tLazy tR - _ -> tHeadLazy t12 - - when (not $ equivT tWit tWitExp) - $ throw $ ErrorLetLazyWitnessTypeMismatch - xx b11 tWit t12 tWitExp) - - - return ( XLet a (LLet mode b11' x12') x2' - , t2 - , effs12 `Sum.union` effs2 - , clo12 `Set.union` c2_cut) - - --- letrec ----------------------------------------- -checkExpM' defs kenv tenv xx@(XLet a (LRec bxs) xBody) - = do - let (bs, xs) = unzip bxs - - -- Check all the annotations. - ks <- mapM (checkTypeM defs kenv) - $ map typeOfBind bs - - -- Check all the annots have data kind. - zipWithM_ (\b k - -> when (not $ isDataKind k) - $ throw $ ErrorLetBindingNotData xx b k) - bs ks - - -- All right hand sides need to be lambdas. - forM_ xs $ \x - -> when (not $ (isXLam x || isXLAM x)) - $ throw $ ErrorLetrecBindingNotLambda xx x - - -- All variables are in scope in all right hand sides. - let tenv' = Env.extends bs tenv - - -- Check the right hand sides. - (xsRight', tsRight, _effssBinds, clossBinds) - <- liftM unzip4 $ mapM (checkExpM defs kenv tenv') xs - - -- Check annots on binders against inferred types of the bindings. - zipWithM_ (\b t - -> if not $ equivT (typeOfBind b) t - then throw $ ErrorLetMismatch xx b t - else return ()) - bs tsRight - - -- Check the body expression. - (xBody', tBody, effsBody, closBody) - <- checkExpM defs kenv tenv' xBody - - -- The body type must have data kind. - kBody <- checkTypeM defs kenv tBody - when (not $ isDataKind kBody) - $ throw $ ErrorLetBodyNotData xx tBody kBody - - -- Cut closure terms due to locally bound value vars. - -- This also lowers deBruijn indices in un-cut closure terms. - let clos_cut - = Set.fromList - $ mapMaybe (cutTaggedClosureXs bs) - $ Set.toList - $ Set.unions (closBody : clossBinds) - - return ( XLet a (LRec (zip bs xsRight')) xBody' - , tBody - , effsBody - , clos_cut) - - --- letregion -------------------------------------- -checkExpM' defs kenv tenv xx@(XLet a (LLetRegion b bs) x) - = case takeSubstBoundOfBind b of - Nothing -> checkExpM defs kenv tenv x - Just u - -> do - -- Check the type on the region binder. - let k = typeOfBind b - checkTypeM defs kenv k - - -- The binder must have region kind. - when (not $ isRegionKind k) - $ throw $ ErrorLetRegionNotRegion xx b k - - -- We can't shadow region binders because we might have witnesses - -- in the environment that conflict with the ones created here. - when (Env.memberBind b kenv) - $ throw $ ErrorLetRegionRebound xx b - - -- Check the witness types. - let kenv' = Env.extend b kenv - let tenv' = Env.lift 1 tenv - mapM_ (checkTypeM defs kenv') $ map typeOfBind bs - - -- Check that the witnesses bound here are for the region, - -- and they don't conflict with each other. - checkWitnessBindsM xx u bs - - -- Check the body expression. - let tenv2 = Env.extends bs tenv' - (xBody', tBody, effs, clo) <- checkExpM defs kenv' tenv2 x - - -- The body type must have data kind. - kBody <- checkTypeM defs kenv' tBody - when (not $ isDataKind kBody) - $ throw $ ErrorLetBodyNotData xx tBody kBody - - -- The bound region variable cannot be free in the body type. - let fvsT = freeT Env.empty tBody - when (Set.member u fvsT) - $ throw $ ErrorLetRegionFree xx b tBody - - -- Delete effects on the bound region from the result. - let effs' = Sum.delete (tRead (TVar u)) - $ Sum.delete (tWrite (TVar u)) - $ Sum.delete (tAlloc (TVar u)) - $ effs - - -- Delete the bound region variable from the closure. - -- Mask closure terms due to locally bound region vars. - let c2_cut = Set.fromList - $ mapMaybe (cutTaggedClosureT b) - $ Set.toList clo - - return ( XLet a (LLetRegion b bs) xBody' - , lowerT 1 tBody - , lowerT 1 effs' - , c2_cut) - - --- withregion ----------------------------------- -checkExpM' defs kenv tenv xx@(XLet a (LWithRegion u) x) - = do -- Check the type on the region handle. - let k = typeOfBound u - checkTypeM defs kenv k - - -- The handle must have region kind. - when (not $ isRegionKind k) - $ throw $ ErrorWithRegionNotRegion xx u k - - -- Check the body expression. - (xBody', tBody, effs, clo) - <- checkExpM defs kenv tenv x - - -- The body type must have data kind. - kBody <- checkTypeM defs kenv tBody - when (not $ isDataKind kBody) - $ throw $ ErrorLetBodyNotData xx tBody kBody - - -- Delete effects on the bound region from the result. - let tu = TCon $ TyConBound u - let effs' = Sum.delete (tRead tu) - $ Sum.delete (tWrite tu) - $ Sum.delete (tAlloc tu) - $ effs - - -- Delete the bound region handle from the closure. - let clo_masked = Set.delete (GBoundRgnCon u) clo - - return ( XLet a (LWithRegion u) xBody' - , tBody - , effs' - , clo_masked) - - --- case expression ------------------------------ -checkExpM' defs kenv tenv xx@(XCase a xDiscrim alts) - = do - -- Check the discriminant. - (xDiscrim', tDiscrim, effsDiscrim, closDiscrim) - <- checkExpM defs kenv tenv xDiscrim - - -- Split the type into the type constructor names and type parameters. - -- Also check that it's algebraic data, and not a function or effect - -- type etc. - (nTyCon, tsArgs) - <- case takeTyConApps tDiscrim of - Just (tc, ts) - | TyConBound (UName n t) <- tc - , takeResultKind t == kData - -> return (n, ts) - - | TyConBound (UPrim n t) <- tc - , takeResultKind t == kData - -> return (n, ts) - - _ -> throw $ ErrorCaseDiscrimNotAlgebraic xx tDiscrim - - -- Get the mode of the data type, - -- this tells us how many constructors there are. - mode - <- case lookupModeOfDataType nTyCon defs of - Nothing -> throw $ ErrorCaseDiscrimTypeUndeclared xx tDiscrim - Just m -> return m - - -- Check the alternatives. - (alts', ts, effss, closs) - <- liftM unzip4 - $ mapM (checkAltM xx defs kenv tenv tDiscrim tsArgs) alts - - -- There must be at least one alternative - when (null ts) - $ throw $ ErrorCaseNoAlternatives xx - - -- All alternative result types must be identical. - let (tAlt : _) = ts - forM_ ts $ \tAlt' - -> when (not $ equivT tAlt tAlt') - $ throw $ ErrorCaseAltResultMismatch xx tAlt tAlt' - - -- Check for overlapping alternatives. - let pats = [p | AAlt p _ <- alts] - let psDefaults = filter isPDefault pats - let nsCtorsMatched = mapMaybe takeCtorNameOfAlt alts - - -- Alts overlapping because there are multiple defaults. - when (length psDefaults > 1) - $ throw $ ErrorCaseOverlapping xx - - -- Alts overlapping because the same ctor is used multiple times. - when (length (nub nsCtorsMatched) /= length nsCtorsMatched ) - $ throw $ ErrorCaseOverlapping xx - - -- Check for alts overlapping because a default is not last. - -- Also check there is at least one alternative. - (case pats of - [] -> throw $ ErrorCaseNoAlternatives xx - - _ | or $ map isPDefault $ init pats - -> throw $ ErrorCaseOverlapping xx - - | otherwise - -> return ()) - - -- Check the alternatives are exhaustive. - (case mode of - - -- Small types have some finite number of constructors. - DataModeSmall nsCtors - -- If there is a default alternative then we've covered all the - -- possibiliies. We know this we've also checked for overlap. - | any isPDefault [p | AAlt p _ <- alts] - -> return () - - -- Look for unmatched constructors. - | nsCtorsMissing <- nsCtors \\ nsCtorsMatched - , not $ null nsCtorsMissing - -> throw $ ErrorCaseNonExhaustive xx nsCtorsMissing - - -- All constructors were matched. - | otherwise - -> return () - - -- Large types have an effectively infinite number of constructors - -- (like integer literals), so there needs to be a default alt. - DataModeLarge - | any isPDefault [p | AAlt p _ <- alts] -> return () - | otherwise - -> throw $ ErrorCaseNonExhaustiveLarge xx) - - let effsMatch - = Sum.singleton kEffect - $ crushEffect $ tHeadRead tDiscrim - - return ( XCase a xDiscrim' alts' - , tAlt - , Sum.unions kEffect (effsDiscrim : effsMatch : effss) - , Set.unions (closDiscrim : closs) ) - - --- type cast ------------------------------------- --- Weaken an effect, adding in the given terms. -checkExpM' defs kenv tenv xx@(XCast a c@(CastWeakenEffect eff) x1) - = do - -- Check the effect term. - kEff <- checkTypeM defs kenv eff - when (not $ isEffectKind kEff) - $ throw $ ErrorMaxeffNotEff xx eff kEff - - -- Check the body. - (x1', t1, effs, clo) <- checkExpM defs kenv tenv x1 - - return ( XCast a c x1' - , t1 - , Sum.insert eff effs - , clo) - - --- Weaken a closure, adding in the given terms. -checkExpM' defs kenv tenv xx@(XCast a c@(CastWeakenClosure clo2) x1) - = do - -- Check the closure term. - kClo <- checkTypeM defs kenv clo2 - when (not $ isClosureKind kClo) - $ throw $ ErrorMaxcloNotClo xx clo2 kClo - - -- The closure supplied to weakclo can only contain Use terms - -- of region variables. - clos2 - <- case taggedClosureOfWeakClo clo2 of - Nothing -> throw $ ErrorMaxcloMalformed xx clo2 - Just clos2' -> return clos2' - - -- Check the body. - (x1', t1, effs, clos) <- checkExpM defs kenv tenv x1 - - return ( XCast a c x1' - , t1 - , effs - , Set.union clos clos2) - - --- Purify an effect, given a witness that it is pure. -checkExpM' defs kenv tenv xx@(XCast a c@(CastPurify w) x1) - = do tW <- checkWitnessM defs kenv tenv w - (x1', t1, effs, clo) <- checkExpM defs kenv tenv x1 - - effs' <- case tW of - TApp (TCon (TyConWitness TwConPure)) effMask - -> return $ Sum.delete effMask effs - _ -> throw $ ErrorWitnessNotPurity xx w tW - - return ( XCast a c x1' - , t1 - , effs' - , clo) - - --- Forget a closure, given a witness that it is empty. -checkExpM' defs kenv tenv xx@(XCast a c@(CastForget w) x1) - = do tW <- checkWitnessM defs kenv tenv w - (x1', t1, effs, clos) <- checkExpM defs kenv tenv x1 - - clos' <- case tW of - TApp (TCon (TyConWitness TwConEmpty)) cloMask - -> return $ maskFromTaggedSet - (Sum.singleton kClosure cloMask) - clos - - _ -> throw $ ErrorWitnessNotEmpty xx w tW - - return ( XCast a c x1' - , t1 - , effs - , clos') - - --- Type and witness expressions can only appear as the arguments --- to applications. -checkExpM' _defs _kenv _tenv xx@(XType _) - = throw $ ErrorNakedType xx - -checkExpM' _defs _kenv _tenv xx@(XWitness _) - = throw $ ErrorNakedWitness xx - - -------------------------------------------------------------------------------- --- | Check a case alternative. -checkAltM - :: (Pretty n, Ord n) - => Exp a n -- ^ Whole case expression, for error messages. - -> DataDefs n -- ^ Data type definitions. - -> Env n -- ^ Kind environment. - -> Env n -- ^ Type environment. - -> Type n -- ^ Type of discriminant. - -> [Type n] -- ^ Args to type constructor of discriminant. - -> Alt a n -- ^ Alternative to check. - -> CheckM a n - ( Alt a n - , Type n - , TypeSum n - , Set (TaggedClosure n)) - -checkAltM _xx defs kenv tenv _tDiscrim _tsArgs (AAlt PDefault xBody) - = do (xBody', tBody, effBody, cloBody) - <- checkExpM defs kenv tenv xBody - - return ( AAlt PDefault xBody' - , tBody - , effBody - , cloBody) - -checkAltM xx defs kenv tenv tDiscrim tsArgs (AAlt (PData uCon bsArg) xBody) - = do - -- Take the type of the constructor and instantiate it with the - -- type arguments we got from the discriminant. - -- If the ctor type doesn't instantiate then it won't have enough foralls - -- on the front, which should have been checked by the def checker. - let tCtor = typeOfBound uCon - tCtor_inst - <- case instantiateTs tCtor tsArgs of - Nothing -> throw $ ErrorCaseCannotInstantiate xx tDiscrim tCtor - Just t -> return t - - -- Split the constructor type into the field and result types. - let (tsFields_ctor, tResult) - = takeTFunArgResult tCtor_inst - - -- The result type of the constructor must match the discriminant type. - -- If it doesn't then the constructor in the pattern probably isn't for - -- the discriminant type. - when (not $ equivT tDiscrim tResult) - $ throw $ ErrorCaseDiscrimTypeMismatch xx tDiscrim tResult - - -- There must be at least as many fields as variables in the pattern. - -- It's ok to bind less fields than provided by the constructor. - when (length tsFields_ctor < length bsArg) - $ throw $ ErrorCaseTooManyBinders xx uCon - (length tsFields_ctor) - (length bsArg) - - -- Merge the field types we get by instantiating the constructor - -- type with possible annotations from the source program. - -- If the annotations don't match, then we throw an error. - tsFields <- zipWithM (mergeAnnot xx) - (map typeOfBind bsArg) - tsFields_ctor - - -- Extend the environment with the field types. - let bsArg' = zipWith replaceTypeOfBind tsFields bsArg - let tenv' = Env.extends bsArg' tenv - - -- Check the body in this new environment. - (xBody', tBody, effsBody, closBody) - <- checkExpM defs kenv tenv' xBody - - -- Cut closure terms due to locally bound value vars. - -- This also lowers deBruijn indices in un-cut closure terms. - let closBody_cut - = Set.fromList - $ mapMaybe (cutTaggedClosureXs bsArg') - $ Set.toList closBody - - return ( AAlt (PData uCon bsArg') xBody' - , tBody - , effsBody - , closBody_cut) - - --- | Merge a type annotation on a pattern field with a type we get by --- instantiating the constructor type. -mergeAnnot :: Eq n => Exp a n -> Type n -> Type n -> CheckM a n (Type n) -mergeAnnot xx tAnnot tActual - -- Annotation is bottom, so just use the real type. - | isBot tAnnot = return tActual - - -- Annotation matches actual type, all good. - | tAnnot == tActual = return tActual - - -- Annotation does not match actual type. - | otherwise - = throw $ ErrorCaseFieldTypeMismatch xx tAnnot tActual - - -------------------------------------------------------------------------------- --- | Check the set of witness bindings bound in a letregion for conflicts. -checkWitnessBindsM :: Ord n => Exp a n -> Bound n -> [Bind n] -> CheckM a n () -checkWitnessBindsM xx nRegion bsWits - = mapM_ (checkWitnessBindM xx nRegion bsWits) bsWits - - -checkWitnessBindM - :: Ord n - => Exp a n - -> Bound n -- ^ Region variable bound in the letregion. - -> [Bind n] -- ^ Other witness bindings in the same set. - -> Bind n -- ^ The witness binding to check. - -> CheckM a n () - -checkWitnessBindM xx uRegion bsWit bWit - = let btsWit - = [(typeOfBind b, b) | b <- bsWit] - - -- Check the argument of a witness type is for the region we're - -- introducing here. - checkWitnessArg t - = case t of - TVar u' - | uRegion /= u' -> throw $ ErrorLetRegionWitnessOther xx uRegion bWit - | otherwise -> return () - - TCon (TyConBound u') - | uRegion /= u' -> throw $ ErrorLetRegionWitnessOther xx uRegion bWit - | otherwise -> return () - - -- The parser should ensure the right of a witness is a - -- constructor or variable. - _ -> throw $ ErrorLetRegionWitnessInvalid xx bWit - - in case typeOfBind bWit of - TApp (TCon (TyConWitness TwConGlobal)) t2 - -> checkWitnessArg t2 - - TApp (TCon (TyConWitness TwConConst)) t2 - | Just bConflict <- L.lookup (tMutable t2) btsWit - -> throw $ ErrorLetRegionWitnessConflict xx bWit bConflict - | otherwise -> checkWitnessArg t2 - - TApp (TCon (TyConWitness TwConMutable)) t2 - | Just bConflict <- L.lookup (tConst t2) btsWit - -> throw $ ErrorLetRegionWitnessConflict xx bWit bConflict - | otherwise -> checkWitnessArg t2 - - TApp (TCon (TyConWitness TwConLazy)) t2 - | Just bConflict <- L.lookup (tManifest t2) btsWit - -> throw $ ErrorLetRegionWitnessConflict xx bWit bConflict - | otherwise -> checkWitnessArg t2 - - TApp (TCon (TyConWitness TwConManifest)) t2 - | Just bConflict <- L.lookup (tLazy t2) btsWit - -> throw $ ErrorLetRegionWitnessConflict xx bWit bConflict - | otherwise -> checkWitnessArg t2 - - _ -> throw $ ErrorLetRegionWitnessInvalid xx bWit - - -------------------------------------------------------------------------------- --- | Check a type in the exp checking monad. -checkTypeM :: (Ord n, Pretty n) - => DataDefs n - -> Env n - -> Type n - -> CheckM a n (Kind n) - -checkTypeM defs kenv tt - = case T.checkType defs kenv tt of - Left err -> throw $ ErrorType err - Right k -> return k - - -------------------------------------------------------------------------------- --- | Check the type annotation of a let bound variable against the type --- inferred for the right of the binding. --- If the annotation is Bot then we just replace the annotation, --- otherwise it must match that for the right of the binding. -checkLetBindOfTypeM - :: (Eq n, Ord n, Pretty n) - => Exp a n - -> DataDefs n -- Data type definitions. - -> Env n -- Kind environment. - -> Env n -- Type environment. - -> Type n - -> Bind n - -> CheckM a n (Bind n, Kind n) - -checkLetBindOfTypeM xx defs kenv _tenv tRight b - -- If the annotation is Bot then just replace it. - | isBot (typeOfBind b) - = do k <- checkTypeM defs kenv tRight - return ( replaceTypeOfBind tRight b - , k) - - -- The type of the binder must match that of the right of the binding. - | not $ equivT (typeOfBind b) tRight - = throw $ ErrorLetMismatch xx b tRight - - | otherwise - = do k <- checkTypeM defs kenv (typeOfBind b) - return (b, k) - 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,212 +0,0 @@ - --- | Type checker for witness expressions. -module DDC.Core.Check.CheckWitness - ( checkWitness - , typeOfWitness - , typeOfWiCon - , typeOfWbCon - - , CheckM - , checkWitnessM) -where -import DDC.Core.DataDef -import DDC.Core.Exp -import DDC.Core.Pretty -import DDC.Core.Check.Error -import DDC.Core.Check.ErrorMessage () -import DDC.Type.Transform.SubstituteT -import DDC.Type.Compounds -import DDC.Type.Predicates -import DDC.Type.Equiv -import DDC.Type.Transform.LiftT -import DDC.Type.Sum as Sum -import DDC.Type.Env (Env) -import DDC.Type.Check.Monad (result, throw) -import DDC.Base.Pretty () -import qualified DDC.Type.Env as Env -import qualified DDC.Type.Check as T -import qualified DDC.Type.Check.Monad as G - - --- | Type checker monad. --- Used to manage type errors. -type CheckM a n = G.CheckM (Error a n) - - --- Wrappers -------------------------------------------------------------------- --- | Check a witness. --- --- If it's good, you get a new version with types attached to all the bound --- variables, as well as the type of the overall witness. --- --- If it's bad, you get a description of the error. --- --- The returned expression has types attached to all variable occurrences, --- so you can call `typeOfWitness` on any open subterm. --- -checkWitness - :: (Ord n, Pretty n) - => DataDefs n -- ^ Data type definitions. - -> Env n -- ^ Kind Environment. - -> Env n -- ^ Type Environment. - -> Witness n -- ^ Witness to check. - -> Either (Error a n) (Type n) - -checkWitness defs kenv tenv xx - = result $ checkWitnessM defs kenv tenv xx - - --- | Like `checkWitness`, but check in an empty environment. --- --- As this function is not given an environment, the types of free variables --- must be attached directly to the bound occurrences. --- This attachment is performed by `checkWitness` above. --- -typeOfWitness - :: (Ord n, Pretty n) - => DataDefs n - -> Witness n - -> Either (Error a n) (Type n) - -typeOfWitness defs ww - = result - $ checkWitnessM defs Env.empty Env.empty ww - - ------------------------------------------------------------------------------- --- | Like `checkWitness` but using the `CheckM` monad to manage errors. -checkWitnessM - :: (Ord n, Pretty n) - => DataDefs n -- ^ Data type definitions. - -> Env n -- ^ Kind environment. - -> Env n -- ^ Type environment. - -> Witness n -- ^ Witness to check. - -> CheckM a n (Type n) - -checkWitnessM _defs _kenv tenv (WVar u) - = do let tBound = typeOfBound u - let mtEnv = Env.lookup u tenv - - let mkResult - -- When annotation on the bound is bot, - -- then use the type from the environment. - | Just tEnv <- mtEnv - , isBot tBound - = return tEnv - - -- The bound has an explicit type annotation, - -- which matches the one from the environment. - -- - -- When the bound is a deBruijn index we need to lift the - -- annotation on the original binder through any lambdas - -- between the binding occurrence and the use. - | Just tEnv <- mtEnv - , UIx i _ <- u - , equivT tBound (liftT (i + 1) tEnv) - = return tBound - - -- The bound has an explicit type annotation, - -- which matches the one from the environment. - | Just tEnv <- mtEnv - , equivT tBound tEnv - = return tEnv - - -- The bound has an explicit type annotation, - -- which does not match the one from the environment. - -- This shouldn't happen because the parser doesn't add non-bot - -- annotations to bound variables. - | Just tEnv <- mtEnv - = throw $ ErrorVarAnnotMismatch u tEnv - - -- Variable not in environment, so use annotation. - -- This happens when checking open terms. - | otherwise - = return tBound - - tResult <- mkResult - return tResult - - -checkWitnessM _defs _kenv _tenv (WCon wc) - = return $ typeOfWiCon wc - - --- value-type application -checkWitnessM defs kenv tenv ww@(WApp w1 (WType t2)) - = do t1 <- checkWitnessM defs kenv tenv w1 - k2 <- checkTypeM defs kenv t2 - case t1 of - TForall b11 t12 - | typeOfBind b11 == k2 - -> return $ substituteT b11 t2 t12 - - | otherwise -> throw $ ErrorWAppMismatch ww (typeOfBind b11) k2 - _ -> throw $ ErrorWAppNotCtor ww t1 t2 - --- witness-witness application -checkWitnessM defs kenv tenv ww@(WApp w1 w2) - = do t1 <- checkWitnessM defs kenv tenv w1 - t2 <- checkWitnessM defs kenv tenv w2 - case t1 of - TApp (TApp (TCon (TyConWitness TwConImpl)) t11) t12 - | t11 == t2 - -> return t12 - - | otherwise -> throw $ ErrorWAppMismatch ww t11 t2 - _ -> throw $ ErrorWAppNotCtor ww t1 t2 - --- witness joining -checkWitnessM defs kenv tenv ww@(WJoin w1 w2) - = do t1 <- checkWitnessM defs kenv tenv w1 - t2 <- checkWitnessM defs kenv tenv w2 - case (t1, t2) of - ( TApp (TCon (TyConWitness TwConPure)) eff1 - , TApp (TCon (TyConWitness TwConPure)) eff2) - -> return $ TApp (TCon (TyConWitness TwConPure)) - (TSum $ Sum.fromList kEffect [eff1, eff2]) - - ( TApp (TCon (TyConWitness TwConEmpty)) clo1 - , TApp (TCon (TyConWitness TwConEmpty)) clo2) - -> return $ TApp (TCon (TyConWitness TwConEmpty)) - (TSum $ Sum.fromList kClosure [clo1, clo2]) - - _ -> throw $ ErrorCannotJoin ww w1 t1 w2 t2 - --- embedded types -checkWitnessM defs kenv _tenv (WType t) - = checkTypeM defs kenv t - - --- | Take the type of a witness constructor. -typeOfWiCon :: WiCon n -> Type n -typeOfWiCon wc - = case wc of - WiConBuiltin wb -> typeOfWbCon wb - WiConBound u -> typeOfBound u - - --- | Take the type of a builtin witness constructor. -typeOfWbCon :: WbCon -> Type n -typeOfWbCon wb - = case wb of - WbConPure -> tPure (tBot kEffect) - WbConEmpty -> tEmpty (tBot kClosure) - WbConUse -> tForall kRegion $ \r -> tGlobal r `tImpl` (tEmpty $ tUse r) - WbConRead -> tForall kRegion $ \r -> tConst r `tImpl` (tPure $ tRead r) - WbConAlloc -> tForall kRegion $ \r -> tConst r `tImpl` (tPure $ tAlloc r) - - --- checkType ------------------------------------------------------------------ --- | Check a type in the exp checking monad. -checkTypeM - :: (Ord n, Pretty n) - => DataDefs n - -> Env n - -> Type n - -> CheckM a n (Kind n) - -checkTypeM defs kenv tt - = case T.checkType defs kenv tt of - Left err -> throw $ ErrorType err - Right k -> return k - 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,313 +1,17 @@ -- | Errors produced when checking core expressions. module DDC.Core.Check.Error - (Error(..)) + ( Error (..) + , ErrorType (..) + , ErrorData (..)) where -import DDC.Core.Exp -import qualified DDC.Type.Check as T - - --- | All the things that can go wrong when type checking an expression --- or witness. -data Error a n - -- | Found a kind error when checking a type. - = ErrorType - { errorTypeError :: T.Error n } - - -- | Found a malformed expression, - -- and we don't have a more specific diagnosis. - | ErrorMalformedExp - { errorChecking :: Exp a n } - - -- | Found a malformed type, - -- and we don't have a more specific diagnosis. - | ErrorMalformedType - { errorChecking :: Exp a n - , errorType :: Type n } - - -- | Found a naked `XType` that wasn't the argument of an application. - | ErrorNakedType - { errorChecking :: Exp a n } - - -- | Found a naked `XWitness` that wasn't the argument of an application. - | ErrorNakedWitness - { errorChecking :: Exp a n } - - -- Var -------------------------------------------- - -- | A bound occurrence of a variable who's type annotation does not match - -- the corresponding annotation in the environment. - | ErrorVarAnnotMismatch - { errorBound :: Bound n - , errorTypeEnv :: Type n } - - -- Con -------------------------------------------- - -- | A data constructor that wasn't in the set of data definitions. - | ErrorUndefinedCtor - { errorChecking :: Exp a n } - - -- Application ------------------------------------ - -- | A function application where the parameter and argument don't match. - | ErrorAppMismatch - { errorChecking :: Exp a n - , errorParamType :: Type n - , errorArgType :: Type n } - - -- | Tried to apply something that is not a function. - | ErrorAppNotFun - { errorChecking :: Exp a n - , errorNotFunType :: Type n - , errorArgType :: Type n } - - - -- Lambda ----------------------------------------- - -- | A type abstraction that tries to shadow a type variable that is - -- already in the environment. - | ErrorLamShadow - { errorChecking :: Exp a n - , errorBind :: Bind n } - - -- | A type or witness abstraction where the body has a visible side effect. - | ErrorLamNotPure - { errorChecking :: Exp a n - , errorEffect :: Effect n } - - -- | A value function where the parameter does not have data kind. - | ErrorLamBindNotData - { errorChecking :: Exp a n - , errorType :: Type n - , errorKind :: Kind n } - - -- | An abstraction where the body does not have data kind. - | ErrorLamBodyNotData - { errorChecking :: Exp a n - , errorBind :: Bind n - , errorType :: Type n - , errorKind :: Kind n } - - - -- Let -------------------------------------------- - -- | A let-expression where the type of the binder does not match the right - -- of the binding. - | ErrorLetMismatch - { errorChecking :: Exp a n - , errorBind :: Bind n - , errorType :: Type n } - - -- | A let-expression where the right of the binding does not have data kind. - | ErrorLetBindingNotData - { errorChecking :: Exp a n - , errorBind :: Bind n - , errorKind :: Kind n } - - -- | A let-expression where the body does not have data kind. - | ErrorLetBodyNotData - { errorChecking :: Exp a n - , errorType :: Type n - , errorKind :: Kind n } - - - -- Let Lazy --------------------------------------- - -- | A lazy let binding that has a visible side effect. - | ErrorLetLazyNotPure - { errorChecking :: Exp a n - , errorBind :: Bind n - , errorEffect :: Effect n } - - -- | A lazy let binding with a non-empty closure. - | ErrorLetLazyNotEmpty - { errorChecking :: Exp a n - , errorBind :: Bind n - , errorClosure :: Closure n } - - -- | A lazy let binding without a witness that binding is in a lazy region. - | ErrorLetLazyNoWitness - { errorChecking :: Exp a n - , errorBind :: Bind n - , errorType :: Type n } - - -- | A lazy let binding where the witness has the wrong type. - | ErrorLetLazyWitnessTypeMismatch - { errorChecking :: Exp a n - , errorBind :: Bind n - , errorWitnessTypeHave :: Type n - , errorBindType :: Type n - , errorWitnessTypeExpect :: Type n } - - - -- Letrec ----------------------------------------- - -- | A recursive let-expression where the right of the binding is not - -- a lambda abstraction. - | ErrorLetrecBindingNotLambda - { errorChecking :: Exp a n - , errorExp :: Exp a n } - - - -- Letregion -------------------------------------- - -- | A letregion-expression where the bound variable does not have - -- region kind. - | ErrorLetRegionNotRegion - { errorChecking :: Exp a n - , errorBind :: Bind n - , errorKind :: Kind n } - - -- | A letregion-expression that tried to shadow a pre-existing named - -- region variable. - | ErrorLetRegionRebound - { errorChecking :: Exp a n - , errorBind :: Bind n } - - -- | A letregion-expression where the bound region variable is free in - -- the type of the body. - | ErrorLetRegionFree - { errorChecking :: Exp a n - , errorBind :: Bind n - , errorType :: Type n } - - -- | A letregion-expression that tried to create a witness with an - -- invalid type. - | ErrorLetRegionWitnessInvalid - { errorChecking :: Exp a n - , errorBind :: Bind n } - - -- | A letregion-expression that tried to create conflicting witnesses. - | ErrorLetRegionWitnessConflict - { errorChecking :: Exp a n - , errorBindWitness1 :: Bind n - , errorBindWitness2 :: Bind n } - - -- | A letregion-expression where a bound witnesses was not for the - -- the region variable being introduced. - | ErrorLetRegionWitnessOther - { errorChecking :: Exp a n - , errorBoundRegion :: Bound n - , errorBindWitness :: Bind n } - - -- | A withregion-expression where the handle does not have region kind. - | ErrorWithRegionNotRegion - { errorChecking :: Exp a n - , errorBound :: Bound n - , errorKind :: Kind n } - - - -- Witnesses -------------------------------------- - -- | A witness application where the argument type does not match - -- the parameter type. - | ErrorWAppMismatch - { errorWitness :: Witness n - , errorParamType :: Type n - , errorArgType :: Type n } - - -- | Tried to perform a witness application with a non-witness. - | ErrorWAppNotCtor - { errorWitness :: Witness n - , errorNotFunType :: Type n - , errorArgType :: Type n } - - -- | An invalid witness join. - | ErrorCannotJoin - { errorWitness :: Witness n - , errorWitnessLeft :: Witness n - , errorTypeLeft :: Type n - , errorWitnessRight :: Witness n - , errorTypeRight :: Type n } - - -- | A witness provided for a purify cast that does not witness purity. - | ErrorWitnessNotPurity - { errorChecking :: Exp a n - , errorWitness :: Witness n - , errorType :: Type n } - - -- | A witness provided for a forget cast that does not witness emptiness. - | ErrorWitnessNotEmpty - { errorChecking :: Exp a n - , errorWitness :: Witness n - , errorType :: Type n } - - - -- Case Expressions ------------------------------- - -- | A case-expression where the discriminant type is not algebraic. - | ErrorCaseDiscrimNotAlgebraic - { errorChecking :: Exp a n - , errorTypeDiscrim :: Type n } - - -- | A case-expression where the discriminant type is not in our set - -- of data type declarations. - | ErrorCaseDiscrimTypeUndeclared - { errorChecking :: Exp a n - , errorTypeDiscrim :: Type n } - - -- | A case-expression with no alternatives. - | ErrorCaseNoAlternatives - { errorChecking :: Exp a n } - - -- | A case-expression where the alternatives don't cover all the - -- possible data constructors. - | ErrorCaseNonExhaustive - { errorChecking :: Exp a n - , errorCtorNamesMissing :: [n] } - - -- | A case-expression where the alternatives don't cover all the - -- possible constructors, and the type has too many data constructors - -- to list. - | ErrorCaseNonExhaustiveLarge - { errorChecking :: Exp a n } - - -- | A case-expression with overlapping alternatives. - | ErrorCaseOverlapping - { errorChecking :: Exp a n } - - -- | A case-expression where one of the patterns has too many binders. - | ErrorCaseTooManyBinders - { errorChecking :: Exp a n - , errorCtorBound :: Bound n - , errorCtorFields :: Int - , errorPatternFields :: Int } - - -- | A case-expression where the pattern types could not be instantiated - -- with the arguments of the discriminant type. - | ErrorCaseCannotInstantiate - { errorChecking :: Exp a n - , errorTypeCtor :: Type n - , errorTypeDiscrim :: Type n } - - -- | A case-expression where the type of the discriminant does not match - -- the type of the pattern. - | ErrorCaseDiscrimTypeMismatch - { errorChecking :: Exp a n - , errorTypeDiscrim :: Type n - , errorTypePattern :: Type n } +import DDC.Core.Check.Error.ErrorExp +import DDC.Core.Check.Error.ErrorExpMessage () - -- | A case-expression where the annotation on a pattern variable binder - -- does not match the field type of the constructor. - | ErrorCaseFieldTypeMismatch - { errorChecking :: Exp a n - , errorTypeAnnot :: Type n - , errorTypeField :: Type n } +import DDC.Core.Check.Error.ErrorType +import DDC.Core.Check.Error.ErrorTypeMessage () - -- | A case-expression where the result types of the alternatives are not - -- identical. - | ErrorCaseAltResultMismatch - { errorChecking :: Exp a n - , errorAltType1 :: Type n - , errorAltType2 :: Type n } +import DDC.Core.Check.Error.ErrorData +import DDC.Core.Check.Error.ErrorDataMessage () - -- Casts ------------------------------------------ - -- | A maxeff-cast where the type provided does not have effect kind. - | ErrorMaxeffNotEff - { errorChecking :: Exp a n - , errorEffect :: Effect n - , errorKind :: Kind n } - - -- | A maxclo-cast where the type provided does not have closure kind. - | ErrorMaxcloNotClo - { errorChecking :: Exp a n - , errorClosure :: Closure n - , errorKind :: Kind n } - - -- | A maxclo-case where the closure provided is malformed. - -- It can only contain `Use` terms. - | ErrorMaxcloMalformed - { errorChecking :: Exp a n - , errorClosure :: Closure n } - deriving (Show) 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,350 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} --- | Errors produced when checking core expressions. -module DDC.Core.Check.ErrorMessage - (Error(..)) -where -import DDC.Core.Pretty -import DDC.Core.Check.Error -import DDC.Type.Compounds - - -instance (Pretty n, Eq n) => Pretty (Error a n) where - ppr err - = case err of - ErrorType err' -> ppr err' - - ErrorMalformedExp xx - -> vcat [ text "Malformed expression: " <> align (ppr xx) ] - - ErrorMalformedType xx tt - -> vcat [ text "Found malformed type: " <> ppr tt - , empty - , text "with: " <> align (ppr xx) ] - - ErrorNakedType xx - -> vcat [ text "Found naked type in core program." - , empty - , text "with: " <> align (ppr xx) ] - - ErrorNakedWitness xx - -> vcat [ text "Found naked witness in core program." - , empty - , text "with: " <> align (ppr xx) ] - - -- Variable --------------------------------------- - ErrorVarAnnotMismatch u t - -> vcat [ text "Type mismatch in annotation." - , text " Variable: " <> ppr u - , text " has annotation: " <> (ppr $ typeOfBound u) - , text " which conflicts with: " <> ppr t - , text " from environment." ] - - - -- Constructor ------------------------------------ - ErrorUndefinedCtor xx - -> vcat [ text "Undefined data constructor: " <> ppr xx ] - - - -- Application ------------------------------------ - ErrorAppMismatch xx t1 t2 - -> vcat [ text "Type mismatch in application." - , text " Function expects: " <> ppr t1 - , text " but argument is: " <> ppr t2 - , empty - , text "with: " <> align (ppr xx) ] - - ErrorAppNotFun xx t1 t2 - -> vcat [ text "Cannot apply non-function" - , text " of type: " <> ppr t1 - , text " to argument of type: " <> ppr t2 - , empty - , text "with: " <> align (ppr xx) ] - - - -- Lambda ----------------------------------------- - ErrorLamShadow xx b - -> vcat [ text "Cannot shadow named spec variable." - , text " binder: " <> ppr b - , text " is already in the environment." - , text "with: " <> align (ppr xx) ] - - ErrorLamNotPure xx eff - -> vcat [ text "Impure type abstraction" - , text " has effect: " <> ppr eff - , empty - , text "with: " <> align (ppr xx) ] - - - ErrorLamBindNotData xx t1 k1 - -> vcat [ text "Function parameter does not have data kind." - , text " The function parameter:" <> ppr t1 - , text " has kind: " <> ppr k1 - , text " but it must be: *" - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLamBodyNotData xx b1 t2 k2 - -> vcat [ text "Result of function does not have data kind." - , text " In function with binder: " <> ppr b1 - , text " the result has type: " <> ppr t2 - , text " with kind: " <> ppr k2 - , text " but it must be: *" - , empty - , text "with: " <> align (ppr xx) ] - - - -- Let -------------------------------------------- - ErrorLetMismatch xx b t - -> vcat [ text "Type mismatch in let-binding." - , text " The binder: " <> ppr (binderOfBind b) - , text " has type: " <> ppr (typeOfBind b) - , text " but the body has type: " <> ppr t - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetBindingNotData xx b k - -> vcat [ text "Let binding does not have data kind." - , text " The binding for: " <> ppr (binderOfBind b) - , text " has type: " <> ppr (typeOfBind b) - , text " with kind: " <> ppr k - , text " but it must be: * " - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetBodyNotData xx t k - -> vcat [ text "Let body does not have data kind." - , text " Body of let has type: " <> ppr t - , text " with kind: " <> ppr k - , text " but it must be: * " - , empty - , text "with: " <> align (ppr xx) ] - - - -- Let Lazy --------------------------------------- - ErrorLetLazyNotEmpty xx b clo - -> vcat [ text "Lazy let binding is not empty." - , text " The binding for: " <> ppr (binderOfBind b) - , text " has closure: " <> ppr clo - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetLazyNotPure xx b eff - -> vcat [ text "Lazy let binding is not pure." - , text " The binding for: " <> ppr (binderOfBind b) - , text " has effect: " <> ppr eff - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetLazyNoWitness xx b t - -> vcat [ text "Lazy let binding has no witness but the bound value may have a head region." - , text " The binding for: " <> ppr (binderOfBind b) - , text " Has type: " <> ppr t - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetLazyWitnessTypeMismatch xx b tWitGot tBind tWitExp - -> vcat [ text "Unexpected witness type in lazy let binding." - , text " The binding for: " <> ppr (binderOfBind b) - , text " has a witness of type: " <> ppr tWitGot - , text " but is type is: " <> ppr tBind - , text " so the witness should be: " <> ppr tWitExp - , empty - , text "with: " <> align (ppr xx) ] - - -- Letrec ----------------------------------------- - ErrorLetrecBindingNotLambda xx x - -> vcat [ text "Letrec can only bind lambda abstractions." - , text " This is not one: " <> ppr x - , empty - , text "with: " <> align (ppr xx) ] - - - -- Letregion -------------------------------------- - ErrorLetRegionNotRegion xx b k - -> vcat [ text "Letregion binder does not have region kind." - , text " Region binder: " <> ppr b - , text " has kind: " <> ppr k - , text " but is must be: %" - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetRegionRebound xx b - -> vcat [ text "Region variable shadows existing one." - , text " Region variable: " <> ppr b - , text " is already in environment" - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetRegionFree xx b t - -> vcat [ text "Region variable escapes scope of letregion." - , text " The region variable: " <> ppr b - , text " is free in the body type: " <> ppr t - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetRegionWitnessInvalid xx b - -> vcat [ text "Invalid witness type with letregion." - , text " The witness: " <> ppr b - , text " cannot be created with a letregion" - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetRegionWitnessConflict xx b1 b2 - -> vcat [ text "Conflicting witness types with letregion." - , text " Witness binding: " <> ppr b1 - , text " conflicts with: " <> ppr b2 - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetRegionWitnessOther xx b1 b2 - -> vcat [ text "Witness type is not for bound region." - , text " letregion binds: " <> ppr b1 - , text " but witness type is: " <> ppr b2 - , empty - , text "with: " <> align (ppr xx) ] - - ErrorWithRegionNotRegion xx u k - -> vcat [ text "Withregion handle does not have region kind." - , text " Region var or ctor: " <> ppr u - , text " has kind: " <> ppr k - , text " but it must be: %" - , empty - , text "with: " <> align (ppr xx) ] - - -- Witnesses -------------------------------------- - ErrorWAppMismatch ww t1 t2 - -> vcat [ text "Type mismatch in witness application." - , text " Constructor expects: " <> ppr t1 - , text " but argument is: " <> ppr t2 - , empty - , text "with: " <> align (ppr ww) ] - - ErrorWAppNotCtor ww t1 t2 - -> vcat [ text "Type cannot apply non-constructor witness" - , text " of type: " <> ppr t1 - , text " to argument of type: " <> ppr t2 - , empty - , text "with: " <> align (ppr ww) ] - - ErrorCannotJoin ww w1 t1 w2 t2 - -> vcat [ text "Cannot join witnesses." - , text " Cannot join: " <> ppr w1 - , text " of type: " <> ppr t1 - , text " with witness: " <> ppr w2 - , text " of type: " <> ppr t2 - , empty - , text "with: " <> align (ppr ww) ] - - ErrorWitnessNotPurity xx w t - -> vcat [ text "Witness for a purify does not witness purity." - , text " Witness: " <> ppr w - , text " has type: " <> ppr t - , empty - , text "with: " <> align (ppr xx) ] - - ErrorWitnessNotEmpty xx w t - -> vcat [ text "Witness for a forget does not witness emptiness." - , text " Witness: " <> ppr w - , text " has type: " <> ppr t - , empty - , text "with: " <> align (ppr xx) ] - - - -- Case Expressions ------------------------------- - ErrorCaseDiscrimNotAlgebraic xx tDiscrim - -> vcat [ text "Discriminant of case expression is not algebraic data." - , text " Discriminant type: " <> ppr tDiscrim - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseDiscrimTypeUndeclared xx tDiscrim - -> vcat [ text "Type of discriminant does not have a data declaration." - , text " Discriminant type: " <> ppr tDiscrim - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseNoAlternatives xx - -> vcat [ text "Case expression does not have any alternatives." - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseNonExhaustive xx ns - -> vcat [ text "Case alternatives are non-exhaustive." - , text " Constructors not matched: " - <> (sep $ punctuate comma $ map ppr ns) - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseNonExhaustiveLarge xx - -> vcat [ text "Case alternatives are non-exhaustive." - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseOverlapping xx - -> vcat [ text "Case alternatives are overlapping." - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseTooManyBinders xx uCtor iCtorFields iPatternFields - -> vcat [ text "Pattern has more binders than there are fields in the constructor." - , text " Contructor: " <> ppr uCtor - , text " has: " <> ppr iCtorFields - <+> text "fields" - , text " but there are: " <> ppr iPatternFields - <+> text "binders in the pattern" - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseCannotInstantiate xx tCtor tDiscrim - -> vcat [ text "Cannot instantiate constructor type with discriminant type args." - , text " Either the constructor has an invalid type," - , text " or the type of the discriminant does not match the type of the pattern." - , text " Constructor type: " <> ppr tCtor - , text " Discriminant type: " <> ppr tDiscrim - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseDiscrimTypeMismatch xx tDiscrim tPattern - -> vcat [ text "Discriminant type does not match result of pattern type." - , text " Discriminant type: " <> ppr tDiscrim - , text " Pattern type: " <> ppr tPattern - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseFieldTypeMismatch xx tAnnot tField - -> vcat [ text "Annotation on pattern variable does not match type of field." - , text " Annotation type: " <> ppr tAnnot - , text " Field type: " <> ppr tField - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseAltResultMismatch xx t1 t2 - -> vcat [ text "Mismatch in alternative result types." - , text " Type of alternative: " <> ppr t1 - , text " does not match: " <> ppr t2 - , empty - , text "with: " <> align (ppr xx) ] - - - -- Casts ------------------------------------------ - ErrorMaxeffNotEff xx eff k - -> vcat [ text "Type provided for a 'maxeff' does not have effect kind." - , text " Type: " <> ppr eff - , text " has kind: " <> ppr k - , empty - , text "with: " <> align (ppr xx) ] - - ErrorMaxcloNotClo xx clo k - -> vcat [ text "Type provided for a 'maxclo' does not have closure kind." - , text " Type: " <> ppr clo - , text " has kind: " <> ppr k - , empty - , text "with: " <> align (ppr xx) ] - - ErrorMaxcloMalformed xx clo - -> vcat [ text "Type provided for a 'maxclo' is malformed." - , text " Closure: " <> ppr clo - , text " can only contain 'Use' terms." - , empty - , text "with: " <> align (ppr xx) ] - 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,223 +0,0 @@ - -module DDC.Core.Check.TaggedClosure - ( TaggedClosure(..) - , closureOfTagged - , closureOfTaggedSet - , taggedClosureOfValBound - , taggedClosureOfTyArg - , taggedClosureOfWeakClo - , maskFromTaggedSet - , cutTaggedClosureX - , cutTaggedClosureXs - , cutTaggedClosureT) -where -import DDC.Type.Transform.LowerT -import DDC.Type.Transform.Trim -import DDC.Type.Compounds -import DDC.Type.Predicates -import DDC.Type.Pretty -import DDC.Type.Exp -import Control.Monad -import Data.Maybe -import Data.Set (Set) -import qualified DDC.Type.Sum as Sum -import qualified Data.Set as Set - - --- | A closure-term tagged with the bound variable that the term is due to. -data TaggedClosure n - -- | Term due to a free value variable. - = GBoundVal (Bound n) (TypeSum n) - - -- | Term due to a free region variable. - | GBoundRgnVar (Bound n) - - -- | Term due to a region handle. - | GBoundRgnCon (Bound n) - deriving Show - - -instance Eq n => Eq (TaggedClosure n) where - (==) (GBoundVal u1 _) (GBoundVal u2 _) = u1 == u2 - (==) (GBoundRgnVar u1) (GBoundRgnVar u2) = u1 == u2 - (==) (GBoundRgnCon u1) (GBoundRgnCon u2) = u1 == u2 - (==) _ _ = False - - -instance Ord n => Ord (TaggedClosure n) where - compare g1 g2 = compare (ordify g1) (ordify g2) - where - ordify gg - = case gg of - GBoundVal u _ -> (0, u) :: (Int, Bound n) - GBoundRgnVar u -> (1, u) - GBoundRgnCon u -> (2, u) - - -instance (Eq n, Pretty n) => Pretty (TaggedClosure n) where - ppr cc - = case cc of - GBoundVal u clos -> text "CLOVAL " <+> ppr u <+> text ":" <+> ppr clos - GBoundRgnVar u -> text "CLORGNVAR" <+> ppr u - GBoundRgnCon u -> text "CLORGNCON" <+> ppr u - - -instance LowerT TaggedClosure where - lowerAtDepthT n d cc - = let down = lowerAtDepthT n d - in case cc of - GBoundVal u ts -> GBoundVal (down u) (down ts) - GBoundRgnVar u1 -> GBoundRgnVar (down u1) - GBoundRgnCon u2 -> GBoundRgnCon u2 - - --- | Convert a tagged clousure to a regular closure by dropping the tag variables. -closureOfTagged :: TaggedClosure n -> Closure n -closureOfTagged gg - = case gg of - GBoundVal _ clos -> TSum $ clos - GBoundRgnVar u -> tUse (TVar u) - GBoundRgnCon u -> tUse (TCon (TyConBound u)) - - --- | Convert a set of tagged closures to a regular closure by dropping the --- tag variables. -closureOfTaggedSet :: Ord n => Set (TaggedClosure n) -> Closure n -closureOfTaggedSet clos - = TSum $ Sum.fromList kClosure - $ map closureOfTagged - $ Set.toList clos - - --- | Yield the tagged closure of a value variable. -taggedClosureOfValBound - :: (Ord n, Pretty n) - => Bound n -> TaggedClosure n - -taggedClosureOfValBound u - = GBoundVal u - $ Sum.singleton kClosure - $ (let clo = tDeepUse $ typeOfBound u - in fromMaybe clo (trimClosure clo)) - - --- | Yield the tagged closure of a type argument. -taggedClosureOfTyArg - :: (Ord n, Pretty n) - => Type n -> Set (TaggedClosure n) - -taggedClosureOfTyArg tt - = case tt of - TVar u - | isRegionKind (typeOfBound u) - -> Set.singleton $ GBoundRgnVar u - - TCon (TyConBound u) - | isRegionKind (typeOfBound u) - -> Set.singleton $ GBoundRgnCon u - - _ -> Set.empty - - --- | Convert the closure provided as a 'weakclo' to tagged form. --- Only terms of form `Use r` can be converted. -taggedClosureOfWeakClo - :: (Ord n, Pretty n) - => Closure n -> Maybe (Set (TaggedClosure n)) - -taggedClosureOfWeakClo clo - = liftM Set.fromList - $ sequence - $ map convert - $ Sum.toList $ Sum.singleton kClosure clo - - where convert c - = case takeTyConApps c of - Just (TyConSpec TcConUse, [TVar u]) - -> Just $ GBoundRgnVar u - - Just (TyConSpec TcConUse, [TCon (TyConBound u)]) - -> Just $ GBoundRgnVar u - - _ -> Nothing - - --- | Mask a closure term from a tagged closure. --- --- This is used for the `forget` cast. -maskFromTaggedSet - :: Ord n - => TypeSum n - -> Set (TaggedClosure n) -> Set (TaggedClosure n) -maskFromTaggedSet ts1 set - = Set.fromList $ mapMaybe mask $ Set.toList set - - where mask gg - = case gg of - GBoundVal u ts2 - -> Just $ GBoundVal u $ ts2 `Sum.difference` ts1 - - GBoundRgnVar u - | Sum.elem (tUse (TVar u)) ts1 - -> Nothing - | otherwise -> Just gg - - GBoundRgnCon u - | Sum.elem (tUse (TCon (TyConBound u))) ts1 - -> Nothing - | otherwise -> Just gg - - --- | Cut the terms due to the outermost binder from a tagged closure. -cutTaggedClosureT - :: (Eq n, Ord n) - => Bind n - -> TaggedClosure n - -> Maybe (TaggedClosure n) - -cutTaggedClosureT b1 cc - = let lower = case b1 of - BAnon{} -> lowerT 1 - _ -> id - in case cc of - GBoundVal u2 ts -> Just $ GBoundVal u2 (lower ts) - - GBoundRgnVar u2 - | boundMatchesBind u2 b1 -> Nothing - | otherwise -> Just $ GBoundRgnVar (lower u2) - - GBoundRgnCon u2 -> Just $ GBoundRgnCon (lower u2) - - --- | Like `cutTaggedClosureX` but cut terms due to several binders. -cutTaggedClosureXs - :: (Eq n, Ord n) - => [Bind n] - -> TaggedClosure n -> Maybe (TaggedClosure n) - -cutTaggedClosureXs bb c - = case bb of - [] -> Just c - (b:bs) -> case cutTaggedClosureX b c of - Nothing -> Nothing - Just c' -> cutTaggedClosureXs bs c' - - --- | Cut the terms due to the outermost binder from a tagged closure. -cutTaggedClosureX - :: (Eq n, Ord n) - => Bind n - -> TaggedClosure n - -> Maybe (TaggedClosure n) - -cutTaggedClosureX b1 cc - = let lower = case b1 of - BAnon{} -> lowerT 1 - _ -> id - in case cc of - GBoundVal u2 ts - | boundMatchesBind u2 b1 -> Nothing - | otherwise -> Just $ GBoundVal (lower u2) ts - - GBoundRgnVar u2 -> Just $ GBoundRgnVar u2 - GBoundRgnCon u2 -> Just $ GBoundRgnCon u2 diff --git a/DDC/Core/Collect.hs b/DDC/Core/Collect.hs --- a/DDC/Core/Collect.hs +++ b/DDC/Core/Collect.hs @@ -1,253 +1,25 @@ -- | Collecting sets of variables and constructors. module DDC.Core.Collect - ( freeT + ( -- * Free Variables + freeT, freeVarsT , freeX - , collectBound - , collectSpecBinds) -where -import DDC.Type.Compounds -import DDC.Core.Exp -import DDC.Type.Env (Env) -import qualified DDC.Type.Env as Env -import qualified DDC.Type.Sum as Sum -import qualified Data.Set as Set -import Data.Set (Set) - --- freeT ---------------------------------------------------------------------- --- | Collect the free Spec variables in a thing (level-1). -freeT :: (BindStruct c, Ord n) - => Env n -> c n -> Set (Bound n) -freeT tenv xx = Set.unions $ map (freeOfTreeT tenv) $ slurpBindTree xx - -freeOfTreeT :: Ord n => Env n -> BindTree n -> Set (Bound n) -freeOfTreeT kenv tt - = case tt of - BindDef way bs ts - | BoundSpec <- boundLevelOfBindWay way - , kenv' <- Env.extends bs kenv - -> Set.unions $ map (freeOfTreeT kenv') ts - - BindDef _ _ ts - -> Set.unions $ map (freeOfTreeT kenv) ts - - BindUse BoundSpec u - | Env.member u kenv -> Set.empty - | otherwise -> Set.singleton u - _ -> Set.empty - - --- freeX ---------------------------------------------------------------------- --- | Collect the free Data and Witness variables in a thing (level-0). -freeX :: (BindStruct c, Ord n) - => Env n -> c n -> Set (Bound n) -freeX tenv xx = Set.unions $ map (freeOfTreeX tenv) $ slurpBindTree xx - -freeOfTreeX :: Ord n => Env n -> BindTree n -> Set (Bound n) -freeOfTreeX tenv tt - = case tt of - BindDef way bs ts - | BoundExpWit <- boundLevelOfBindWay way - , tenv' <- Env.extends bs tenv - -> Set.unions $ map (freeOfTreeX tenv') ts - - BindDef _ _ ts - -> Set.unions $ map (freeOfTreeX tenv) ts - - BindUse BoundExpWit u - | Env.member u tenv -> Set.empty - | otherwise -> Set.singleton u - _ -> Set.empty - - --- collectBound --------------------------------------------------------------- --- | Collect all the bound variables in a thing, --- independent of whether they are free or not. -collectBound :: (BindStruct c, Ord n) => c n -> Set (Bound n) -collectBound - = Set.unions . map collectBoundOfTree . slurpBindTree - -collectBoundOfTree :: Ord n => BindTree n -> Set (Bound n) -collectBoundOfTree tt - = case tt of - BindDef _ _ ts -> Set.unions $ map collectBoundOfTree ts - BindUse _ u -> Set.singleton u - BindCon _ u -> Set.singleton u - - --- collectSpecBinds ----------------------------------------------------------- --- | Collect all the Spec binders in a thing. -collectSpecBinds :: (BindStruct c, Ord n) => c n -> [Bind n] -collectSpecBinds - = concatMap collectSpecBindsOfTree . slurpBindTree - - -collectSpecBindsOfTree :: Ord n => BindTree n -> [Bind n] -collectSpecBindsOfTree tt - = case tt of - BindDef way bs ts - | BoundSpec <- boundLevelOfBindWay way - -> concat ( bs - : map collectSpecBindsOfTree ts) - - | otherwise - -> concatMap collectSpecBindsOfTree ts - - _ -> [] - - -------------------------------------------------------------------------------- --- | A description of the binding structure of some type or expression. -data BindTree n - -- | An abstract binding expression. - = BindDef BindWay [Bind n] [BindTree n] - - -- | Use of a variable. - | BindUse BoundLevel (Bound n) - - -- | Use of a constructor. - | BindCon BoundLevel (Bound n) - deriving (Eq, Show) - - --- | Describes how a variable was bound. -data BindWay - = BindForall - | BindLAM - | BindLam - | BindLet - | BindLetRec - | BindLetRegion - | BindLetRegionWith - | BindCasePat - deriving (Eq, Show) - - --- | What level this binder is at. -data BoundLevel - = BoundSpec - | BoundExpWit - deriving (Eq, Show) - - --- | Get the `BoundLevel` corresponding to a `BindWay`. -boundLevelOfBindWay :: BindWay -> BoundLevel -boundLevelOfBindWay way - = case way of - BindForall -> BoundSpec - BindLAM -> BoundSpec - BindLam -> BoundExpWit - BindLet -> BoundExpWit - BindLetRec -> BoundExpWit - BindLetRegion -> BoundSpec - BindLetRegionWith -> BoundExpWit - BindCasePat -> BoundExpWit - - --- BindStruct ----------------------------------------------------------------- -class BindStruct (c :: * -> *) where - slurpBindTree :: c n -> [BindTree n] - - -instance BindStruct Type where - slurpBindTree tt - = case tt of - TVar u -> [BindUse BoundSpec u] - TCon tc -> slurpBindTree tc - TForall b t -> [bindDefT BindForall [b] [t]] - TApp t1 t2 -> slurpBindTree t1 ++ slurpBindTree t2 - TSum ts -> concatMap slurpBindTree $ Sum.toList ts - - -instance BindStruct TyCon where - slurpBindTree tc - = case tc of - TyConBound u -> [BindCon BoundSpec u] - _ -> [] - - -instance BindStruct (Exp a) where - slurpBindTree xx - = case xx of - XVar _ u -> [BindUse BoundExpWit u] - XCon _ u -> [BindCon BoundExpWit u] - XApp _ x1 x2 -> slurpBindTree x1 ++ slurpBindTree x2 - XLAM _ b x -> [bindDefT BindLAM [b] [x]] - XLam _ b x -> [bindDefX BindLam [b] [x]] - - XLet _ (LLet m b x1) x2 - -> slurpBindTree m - ++ slurpBindTree x1 - ++ [bindDefX BindLet [b] [x2]] - - XLet _ (LRec bxs) x2 - -> [bindDefX BindLetRec - (map fst bxs) - (map snd bxs ++ [x2])] - - XLet _ (LLetRegion b bs) x2 - -> [ BindDef BindLetRegion [b] - [bindDefX BindLetRegionWith bs [x2]]] - - XLet _ (LWithRegion u) x2 - -> BindUse BoundExpWit u : slurpBindTree x2 - - XCase _ x alts -> slurpBindTree x ++ concatMap slurpBindTree alts - XCast _ c x -> slurpBindTree c ++ slurpBindTree x - XType t -> slurpBindTree t - XWitness w -> slurpBindTree w - - -instance BindStruct LetMode where - slurpBindTree mm - = case mm of - LetLazy (Just w) -> slurpBindTree w - _ -> [] - - -instance BindStruct Cast where - slurpBindTree cc - = case cc of - CastWeakenEffect eff -> slurpBindTree eff - CastWeakenClosure clo -> slurpBindTree clo - CastPurify w -> slurpBindTree w - CastForget w -> slurpBindTree w - - -instance BindStruct (Alt a) where - slurpBindTree alt - = case alt of - AAlt PDefault x - -> slurpBindTree x - - AAlt (PData _ bs) x - -> [bindDefX BindCasePat bs [x]] - - -instance BindStruct Witness where - slurpBindTree ww - = case ww of - WVar u -> [BindUse BoundExpWit u] - WCon{} -> [] - WApp w1 w2 -> slurpBindTree w1 ++ slurpBindTree w2 - WJoin w1 w2 -> slurpBindTree w1 ++ slurpBindTree w2 - WType t -> slurpBindTree t - - --- | Helper for constructing the `BindTree` for an expression or witness binder. -bindDefX :: BindStruct c - => BindWay -> [Bind n] -> [c n] -> BindTree n -bindDefX way bs xs - = BindDef way bs - $ concatMap (slurpBindTree . typeOfBind) bs - ++ concatMap slurpBindTree xs - - --- | Helper for constructing the `BindTree` for a type binder. -bindDefT :: BindStruct c - => BindWay -> [Bind n] -> [c n] -> BindTree n -bindDefT way bs xs - = BindDef way bs $ concatMap slurpBindTree xs + -- * Bounds and Binds + , collectBound + , collectBinds + -- * Abstract Binding Structures + , BindTree (..) + , BindWay (..) + , BoundLevel (..) + , BindStruct (..) + -- * Support + , Support (..) + , SupportX (..)) +where +import DDC.Core.Collect.FreeX +import DDC.Core.Collect.FreeT +import DDC.Core.Collect.BindStruct +import DDC.Core.Collect.Support 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/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 new file mode 100644 --- /dev/null +++ b/DDC/Core/Collect/Support.hs @@ -0,0 +1,221 @@ + +module DDC.Core.Collect.Support + ( Support (..) + , SupportX (..) + , supportEnvFlags) +where +import DDC.Core.Module +import DDC.Core.Exp.Annot +import DDC.Core.Collect.FreeT +import Data.Set (Set) +import DDC.Type.Env (KindEnv, TypeEnv) +import qualified DDC.Type.Env as Env +import qualified Data.Set as Set +import Data.Maybe +import Data.Monoid ((<>)) + +--------------------------------------------------------------------------------------------------- +data Support n + = Support + { -- | Type constructors used in the expression. + supportTyCon :: Set (Bound n) + + -- | Type constructors used in the argument of a value-type application. + , supportTyConXArg :: Set (Bound n) + + -- | Free spec variables in an expression. + , supportSpVar :: Set (Bound n) + + -- | Type constructors used in the argument of a value-type application. + , supportSpVarXArg :: Set (Bound n) + + -- | Free witness variables in an expression. + -- (from the Witness universe) + , supportWiVar :: Set (Bound n) + + -- | Free value variables in an expression. + -- (from the Data universe) + , supportDaVar :: Set (Bound n) } + deriving Show + + +instance Ord n => Monoid (Support n) where + mempty = Support + { supportTyCon = Set.empty + , supportTyConXArg = Set.empty + , supportSpVar = Set.empty + , supportSpVarXArg = Set.empty + , supportWiVar = Set.empty + , supportDaVar = Set.empty } + + mappend sp1 sp2 + = Support + { supportTyCon = Set.unions [supportTyCon sp1, supportTyCon sp2] + , supportTyConXArg = Set.unions [supportTyConXArg sp1, supportTyConXArg sp2] + , supportSpVar = Set.unions [supportSpVar sp1, supportSpVar sp2] + , supportSpVarXArg = Set.unions [supportSpVarXArg sp1, supportSpVarXArg sp2] + , supportWiVar = Set.unions [supportWiVar sp1, supportWiVar sp2] + , supportDaVar = Set.unions [supportDaVar sp1, supportDaVar sp2] } + + +--------------------------------------------------------------------------------------------------- +-- | Get a description of the type and value environment from a Support. +-- Type (level-1) variables are tagged with True, while +-- value and witness (level-0) variables are tagged with False. +supportEnvFlags + :: Ord n => Support n + -> Set (Bool, Bound n) + +supportEnvFlags supp + = let + us1 = Set.map (\u -> (True, u)) $ supportSpVar supp + + us0 = Set.unions + [ Set.map (\u -> (False, u)) $ supportDaVar supp + , Set.map (\u -> (False, u)) $ supportWiVar supp] + + in Set.union us1 us0 + + +--------------------------------------------------------------------------------------------------- +class SupportX (c :: * -> *) where + support + :: Ord n + => KindEnv n -> TypeEnv n + -> c n + -> Support n + + +instance SupportX Type where + support kenv _tenv t + = let (fvs1, tcs) = freeVarConT kenv t + in mempty { supportTyCon = tcs + , supportSpVar = fvs1 } + + +instance SupportX (Module a) where + support kenv tenv mm + = let kenv' = Env.union kenv (moduleKindEnv mm) + tenv' = Env.union tenv (moduleTypeEnv mm) + in support kenv' tenv' (moduleBody mm) + + +instance SupportX (Exp a) where + support kenv tenv xx + = case xx of + XVar _ u + | Env.member u tenv -> mempty + | otherwise -> mempty { supportDaVar = Set.singleton u} + + XCon{} + -> mempty + + XLAM _ b x + -> support kenv tenv b + <> support (Env.extend b kenv) tenv x + + XLam _ b x + -> support kenv tenv b + <> support kenv (Env.extend b tenv) x + + XApp _ x1 x2 + -> let s1 = support kenv tenv x1 + s2 = support kenv tenv x2 + in mappend s1 s2 + + XLet _a lts x2 + -> let s1 = support kenv tenv lts + (bs1, bs0) = bindsOfLets lts + kenv' = Env.extends bs1 kenv + tenv' = Env.extends bs0 tenv + s2 = support kenv' tenv' x2 + in mappend s1 s2 + + XCase _ x1 alts + -> let s1 = support kenv tenv x1 + ss = mconcat $ map (support kenv tenv) alts + in mappend s1 ss + + XCast _ c1 x2 + -> let s1 = support kenv tenv c1 + s2 = support kenv tenv x2 + in mappend s1 s2 + + XType _ t + -> let sup = support kenv tenv t + in sup { supportTyConXArg = supportTyCon sup + , supportSpVarXArg = supportSpVar sup } + + XWitness _ w -> support kenv tenv w + + +instance SupportX (Alt a) where + support kenv tenv aa + = case aa of + AAlt PDefault x + -> support kenv tenv x + + AAlt (PData _dc bs0) x + -> let tenv' = Env.extends bs0 tenv + in support kenv tenv' x + + +instance SupportX (Witness a) where + support kenv tenv ww + = case ww of + WVar _ u + | Env.member u tenv -> mempty + | otherwise -> mempty { supportWiVar = Set.singleton u } + + WCon{} + -> mempty + + WApp _ w1 w2 + -> support kenv tenv w1 + <> support kenv tenv w2 + + WType _ t + -> support kenv tenv t + + +instance SupportX (Cast a) where + support kenv tenv cc + = case cc of + CastWeakenEffect eff + -> support kenv tenv eff + + CastPurify w + -> support kenv tenv w + + CastBox + -> mempty + + CastRun + -> mempty + + +instance SupportX (Lets a) where + support kenv tenv lts + = case lts of + LLet b x + -> support kenv tenv b + <> support kenv (Env.extend b tenv) x + + LRec bxs + -> (mconcat $ map (support kenv tenv) $ map fst bxs) + <> (let tenv' = Env.extends (map fst bxs) tenv + in mconcat $ map (support kenv tenv') $ map snd bxs) + + LPrivate bs t2 ws + -> (mconcat $ map (support kenv tenv) bs) + <> (mconcat $ map (support kenv tenv) $ maybeToList t2) + <> (let kenv' = Env.extends bs kenv + in mconcat $ map (support kenv' tenv) ws) + + +instance SupportX Bind where + support kenv tenv b + = support kenv tenv + $ typeOfBind b + + diff --git a/DDC/Core/Compounds.hs b/DDC/Core/Compounds.hs deleted file mode 100644 --- a/DDC/Core/Compounds.hs +++ /dev/null @@ -1,172 +0,0 @@ - --- | Utilities for constructing and destructing compound expressions. -module DDC.Core.Compounds - ( -- * Lets - bindsOfLets - , specBindsOfLets - , valwitBindsOfLets - - -- * Patterns - , bindsOfPat - - -- * Lambdas - , makeXLAMs, takeXLAMs - , makeXLams, takeXLams - , takeXLamFlags - , makeXLamFlags - - -- * Applications - , makeXApps - , takeXApps - , takeXConApps - , takeXPrimApps - - -- * Alternatives - , takeCtorNameOfAlt) -where -import DDC.Type.Compounds -import DDC.Core.Exp - - --- | Take the binds of a `Lets`. -bindsOfLets :: Lets a n -> [Bind n] -bindsOfLets ll - = case ll of - LLet _ b _ -> [b] - LRec bxs -> map fst bxs - LLetRegion b bs -> b : bs - LWithRegion{} -> [] - - --- | Like `bindsOfLets` but only take the type binders. -specBindsOfLets :: Lets a n -> [Bind n] -specBindsOfLets ll - = case ll of - LLet _ _ _ -> [] - LRec _ -> [] - LLetRegion b _ -> [b] - LWithRegion{} -> [] - - --- | Like `bindsOfLets` but only take the value and witness binders. -valwitBindsOfLets :: Lets a n -> [Bind n] -valwitBindsOfLets ll - = case ll of - LLet _ b _ -> [b] - LRec bxs -> map fst bxs - LLetRegion _ bs -> bs - LWithRegion{} -> [] - - --- | Take the binds of a `Pat`. -bindsOfPat :: Pat n -> [Bind n] -bindsOfPat pp - = case pp of - PDefault -> [] - PData _ bs -> bs - - --- Lambdas --------------------------------------------------------------------- --- | Make some nested type lambda abstractions. -makeXLAMs :: a -> [Bind n] -> Exp a n -> Exp a n -makeXLAMs a bs x - = foldr (XLAM a) x (reverse bs) - - --- | Split nested value and witness lambdas from the front of an expression, --- or `Nothing` if there aren't any. -takeXLAMs :: Exp a n -> Maybe ([Bind n], Exp a n) -takeXLAMs xx - = let go bs (XLAM _ b x) = go (b:bs) x - go bs x = (reverse bs, x) - in case go [] xx of - ([], _) -> Nothing - (bs, body) -> Just (bs, body) - - --- | Make some nested value or witness lambda abstractions. -makeXLams :: a -> [Bind n] -> Exp a n -> Exp a n -makeXLams a bs x - = foldr (XLam a) x (reverse bs) - - --- | Split nested value or witness lambdas from the front of an expression, --- or `Nothing` if there aren't any. -takeXLams :: Exp a n -> Maybe ([Bind n], Exp a n) -takeXLams xx - = let go bs (XLam _ b x) = go (b:bs) x - go bs x = (reverse bs, x) - in case go [] xx of - ([], _) -> Nothing - (bs, body) -> Just (bs, body) - - --- | Split nested lambdas from the front of an expression, --- with a flag indicating whether the lambda was a level-1 (True), --- or level-0 (False) binder. -takeXLamFlags :: Exp a n -> Maybe ([(Bool, Bind n)], Exp a n) -takeXLamFlags xx - = let go bs (XLAM _ b x) = go ((True, b):bs) x - go bs (XLam _ b x) = go ((False, b):bs) x - go bs x = (reverse bs, x) - in case go [] xx of - ([], _) -> Nothing - (bs, body) -> Just (bs, body) - - --- | Make some nested lambda abstractions, --- using a flag to indicate whether the lambda is a --- level-1 (True), or level-0 (False) binder. -makeXLamFlags :: a -> [(Bool, Bind n)] -> Exp a n -> Exp a n -makeXLamFlags a fbs x - = foldr (\(f, b) x' - -> if f then XLAM a b x' - else XLam a b x') - x fbs - - --- Applications --------------------------------------------------------------- --- | Build sequence of type applications. -makeXApps :: a -> Exp a n -> [Exp a n] -> Exp a n -makeXApps a t1 ts = foldl (XApp a) t1 ts - - --- | Flatten an application into the function parts and arguments, if any. -takeXApps :: Exp a n -> [Exp a n] -takeXApps xx - = case xx of - XApp _ x1 x2 -> takeXApps x1 ++ [x2] - _ -> [xx] - - --- | Flatten an application of a primop into the variable --- and its arguments. --- --- Returns `Nothing` if the expression isn't a primop application. -takeXPrimApps :: Exp a n -> Maybe (n, [Exp a n]) -takeXPrimApps xx - = case takeXApps xx of - XVar _ (UPrim p _) : xs -> Just (p, xs) - _ -> Nothing - --- | Flatten an application of a data constructor into the constructor --- and its arguments. --- --- Returns `Nothing` if the expression isn't a constructor application. -takeXConApps :: Exp a n -> Maybe (Bound n, [Exp a n]) -takeXConApps xx - = case takeXApps xx of - XCon _ u : xs -> Just (u, xs) - _ -> Nothing - - --- Alternatives --------------------------------------------------------------- --- | Take the constructor name of an alternative, if there is one. -takeCtorNameOfAlt :: Alt a n -> Maybe n -takeCtorNameOfAlt aa - = case aa of - AAlt (PData u _) _ -> takeNameOfBound u - _ -> Nothing - - - diff --git a/DDC/Core/DataDef.hs b/DDC/Core/DataDef.hs deleted file mode 100644 --- a/DDC/Core/DataDef.hs +++ /dev/null @@ -1,135 +0,0 @@ - --- | Algebraic data type definitions. -module DDC.Core.DataDef - ( DataDef (..) - - -- * Data type definition table - , DataDefs (..) - , DataMode (..) - , DataType (..) - , DataCtor (..) - - , emptyDataDefs - , insertDataDef - , fromListDataDefs - , lookupModeOfDataType) -where -import DDC.Type.Exp -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe -import Control.Monad - - --- | The definition of a single data type. -data DataDef n - = DataDef - { -- | Name of the data type. - dataDefTypeName :: n - - -- | Kinds of type parameters. - , dataDefParamKinds :: [Kind n] - - -- | Constructors of the data type, or Nothing if there are - -- too many to list (like with `Int`). - , dataDefCtors :: Maybe [(n, [Type n])] } - - - --- DataDefs ------------------------------------------------------------------- --- | A table of data type definitions, --- unpacked into type and data constructors so we can find them easily. -data DataDefs n - = DataDefs - { dataDefsTypes :: Map n (DataType n) - , dataDefsCtors :: Map n (DataCtor n) } - - --- | The mode of a data type records how many data constructors there are. --- This can be set to 'Large' for large primitive types like Int and Float. --- In this case we don't ever expect them all to be enumerated --- as case alternatives. -data DataMode n - = DataModeSmall [n] - | DataModeLarge - - --- | Describes a data type constructor, used in the `DataDefs` table. -data DataType n - = DataType - { -- | Name of data type constructor. - dataTypeName :: n - - -- | Kinds of type parameters to constructor. - , dataTypeParamKinds :: [Kind n] - - -- | Names of data constructors of this data type, - -- or `Nothing` if it has infinitely many constructors. - , dataTypeMode :: DataMode n } - - --- | Describes a data constructor, used in the `DataDefs` table. -data DataCtor n - = DataCtor - { -- | Name of data constructor. - dataCtorName :: n - - -- | Field types of constructor. - , dataCtorFieldTypes :: [Type n] - - -- | Name of result type of constructor. - , dataCtorTypeName :: n } - - - --- | An empty table of data type definitions. -emptyDataDefs :: DataDefs n -emptyDataDefs - = DataDefs - { dataDefsTypes = Map.empty - , dataDefsCtors = Map.empty } - - --- | Insert a data type definition into some DataDefs. -insertDataDef :: Ord n => DataDef n -> DataDefs n -> DataDefs n -insertDataDef (DataDef nType ks mCtors) dataDefs - = let defType = DataType - { dataTypeName = nType - , dataTypeParamKinds = ks - , dataTypeMode = defMode } - - defMode = case mCtors of - Nothing -> DataModeLarge - Just ctors -> DataModeSmall (map fst ctors) - - makeDefCtor (nCtor, tsFields) - = DataCtor - { dataCtorName = nCtor - , dataCtorFieldTypes = tsFields - , dataCtorTypeName = nType } - - defCtors = case mCtors of - Nothing -> Nothing - Just cs -> Just $ map makeDefCtor cs - - in dataDefs - { dataDefsTypes = Map.insert nType defType (dataDefsTypes dataDefs) - , dataDefsCtors = Map.union (dataDefsCtors dataDefs) - $ Map.fromList [(n, def) | def@(DataCtor n _ _) - <- concat $ maybeToList defCtors] } - - --- | Build a `DataDefs` table from a list of `DataDef` -fromListDataDefs :: Ord n => [DataDef n] -> DataDefs n -fromListDataDefs defs - = foldr insertDataDef emptyDataDefs defs - - - --- | Yield the list of data constructor names for some data type, --- or `Nothing` for large types with too many constructors to list. -lookupModeOfDataType :: Ord n => n -> DataDefs n -> Maybe (DataMode n) -lookupModeOfDataType n defs - = liftM dataTypeMode $ Map.lookup n (dataDefsTypes defs) - - 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,198 +1,6 @@ -- | Abstract syntax for the Disciple core language. module DDC.Core.Exp - ( module DDC.Type.Exp - - -- * Computation expressions - , Exp (..) - , Cast (..) - , Lets (..) - , LetMode (..) - , Alt (..) - , Pat (..) - - -- * Witnesses expressions - , Witness (..) - , WiCon (..) - , WbCon (..)) + ( module DDC.Core.Exp.Annot.Exp ) where -import DDC.Type.Exp -import DDC.Type.Sum () - - --- Values --------------------------------------------------------------------- --- | Well-typed expressions live in the Data universe, and their types always --- have kind '*'. --- --- Expressions do something useful at runtime, and might diverge or cause --- side effects. -data Exp a n - -- | Value variable or primitive operation. - = XVar a (Bound n) - - -- | Data constructor or literal. - | XCon a (Bound n) - - -- | Type abstraction (level-1). - | XLAM a (Bind n) (Exp a n) - - -- | Value and Witness abstraction (level-0). - | XLam a (Bind n) (Exp a n) - - -- | Application. - | XApp a (Exp a n) (Exp a n) - - -- | Possibly recursive bindings. - | XLet a (Lets a n) (Exp a n) - - -- | Case branching. - | XCase a (Exp a n) [Alt a n] - - -- | Type cast. - | XCast a (Cast n) (Exp a n) - - -- | Type can appear as the argument of an application. - | XType (Type n) - - -- | Witness can appear as the argument of an application. - | XWitness (Witness n) - deriving (Eq, Show) - - --- | Type casts. -data Cast n - -- | Weaken the effect of an expression. - = CastWeakenEffect (Effect n) - - -- | Weaken the closure of an expression. - | CastWeakenClosure (Closure n) - - -- | Purify the effect of an expression. - | CastPurify (Witness n) - - -- | Hide sharing of the closure of an expression. - | CastForget (Witness n) - deriving (Eq, Show) - - --- | Possibly recursive bindings. -data Lets a n - -- | Non-recursive expression binding. - = LLet (LetMode n) (Bind n) (Exp a n) - - -- | Recursive binding of lambda abstractions. - | LRec [(Bind n, Exp a n)] - - -- | Bind a local region variable, - -- and witnesses to its properties. - | LLetRegion (Bind n) [Bind n] - - -- | Holds a region handle during evaluation. - | LWithRegion (Bound n) - deriving (Eq, Show) - - --- | Describes how a let binding should be evaluated. -data LetMode n - -- | Evaluate binding before substituting the result. - = LetStrict - - -- | Use lazy evaluation. - -- The witness shows that the head region of the bound expression - -- can contain thunks (is lazy), or Nothing if there is no head region. - | LetLazy (Maybe (Witness n)) - deriving (Eq, Show) - - --- | Case alternatives. -data Alt a n - = AAlt (Pat n) (Exp a n) - deriving (Eq, Show) - - --- | Pattern matching. -data Pat n - -- | The default pattern always succeeds. - = PDefault - - -- | Match a data constructor and bind its arguments. - | PData (Bound n) [Bind n] - deriving (Eq, Show) - - --- Witness -------------------------------------------------------------------- --- | When a witness exists in the program it guarantees that a --- certain property of the program is true. -data Witness n - -- | Witness variable. - = WVar (Bound n) - - -- | Witness constructor. - | WCon (WiCon n) - - -- | Witness application. - | WApp (Witness n) (Witness n) - - -- | Joining of witnesses. - | WJoin (Witness n) (Witness n) - - -- | Type can appear as the argument of an application. - | WType (Type n) - deriving (Eq, Show) - - --- | Witness constructors. -data WiCon n - -- | Witness constructors baked into the language. - = WiConBuiltin WbCon - - -- | Witness constructors defined in the environment. - -- In the interpreter we use this to hold runtime capabilities. - | WiConBound (Bound n) - deriving (Eq, Show) - - --- | Built-in witness constructors. --- --- These are used to convert a runtime capability into a witness that --- the corresponding property is true. -data WbCon - -- | (axiom) The pure effect is pure. - -- - -- @pure :: Pure !0@ - = WbConPure - - -- | (axiom) The empty closure is empty. - -- - -- @empty :: Empty $0@ - | WbConEmpty - - -- | Convert a capability guaranteeing that a region is in the global - -- heap into a witness that a closure using this region is empty. - -- This lets us rely on the garbage collector to reclaim objects - -- in the region. It is needed when we suspend the evaluation of - -- expressions that have a region in their closure, because the - -- type of the returned thunk may not reveal that it references - -- objects in that region. - -- - -- @use :: [r: %]. Global r => Empty (Use r)@ - | WbConUse - - -- | Convert a capability guaranteeing the constancy of a region into - -- a witness that a read from that region is pure. - -- This lets us suspend applications that read constant objects, - -- because it doesn't matter if the read is delayed, we'll always - -- get the same result. - -- - -- @read :: [r: %]. Const r => Pure (Read r)@ - | WbConRead - - -- | Convert a capability guaranteeing the constancy of a region into - -- a witness that allocation into that region is pure. - -- This lets us increase the sharing of constant objects, - -- because we can't tell constant objects of the same value apart. - -- - -- @alloc :: [r: %]. Const r => Pure (Alloc r)@ - | WbConAlloc - deriving (Eq, Show) - +import DDC.Core.Exp.Annot.Exp diff --git a/DDC/Core/Exp/Annot.hs b/DDC/Core/Exp/Annot.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/Annot.hs @@ -0,0 +1,123 @@ + +module DDC.Core.Exp.Annot + ( + --------------------------------------- + -- * Abstract Syntax + module DDC.Type.Exp + + -- ** Expressions + , Exp (..) + , Lets (..) + , Alt (..) + , Pat (..) + , Cast (..) + + -- ** Witnesses + , Witness (..) + + -- ** Data Constructors + , DaCon (..) + + -- ** Witness Constructors + , WiCon (..) + + --------------------------------------- + -- * Predicates + , module DDC.Type.Exp.Simple.Predicates + + -- ** Atoms + , isXVar, isXCon + , isAtomX, isAtomW + + -- ** Lambdas + , isXLAM, isXLam + , isLambdaX + + -- ** Applications + , isXApp + + -- ** Cast + , isXCast + , isXCastBox + , isXCastRun + + -- ** Let bindings + , isXLet + + -- ** Patterns + , isPDefault + + -- ** Types and Witnesses + , isXType + , isXWitness + + --------------------------------------- + -- * Compounds + , module DDC.Type.Exp.Simple.Compounds + + -- ** Annotations + , annotOfExp + , mapAnnotOfExp + + -- ** Lambdas + , xLAMs + , xLams + , makeXLamFlags + , takeXLAMs + , takeXLams + , takeXLamFlags + + , Param(..) + , takeXLamParam + + -- ** Applications + , xApps + , makeXAppsWithAnnots + , takeXApps + , takeXApps1 + , takeXAppsAsList + , takeXAppsWithAnnots + , takeXConApps + , takeXPrimApps + + -- ** Lets + , xLets + , xLetsAnnot + , splitXLets + , splitXLetsAnnot + , bindsOfLets + , specBindsOfLets + , valwitBindsOfLets + + -- ** Alternatives + , patOfAlt + , takeCtorNameOfAlt + + -- ** Patterns + , bindsOfPat + + -- ** Casts + , makeRuns + + -- ** Witnesses + , wApp + , wApps + , annotOfWitness + , takeXWitness + , takeWAppsAsList + , takePrimWiConApps + + -- ** Types + , takeXType + + -- ** Data Constructors + , xUnit, dcUnit + , takeNameOfDaCon + , takeTypeOfDaCon) +where +import DDC.Core.Exp.Annot.Exp +import DDC.Core.Exp.Annot.Compounds +import DDC.Core.Exp.Annot.Predicates +import DDC.Type.Exp.Simple.Compounds +import DDC.Type.Exp.Simple.Predicates +import DDC.Type.Exp 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 new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/DaCon.hs @@ -0,0 +1,74 @@ + +module DDC.Core.Exp.DaCon + ( DaCon (..) + + -- * Compounds + , dcUnit + , takeNameOfDaCon + , takeTypeOfDaCon) +where +import DDC.Type.Exp.Simple +import Control.DeepSeq + + +-- | Data constructors. +data DaCon n t + -- | Baked in unit data constructor. + = DaConUnit + + -- | Primitive data constructor used for literals and baked-in + -- constructors. + -- + -- The type of the constructor needs to be attached to handle the + -- case where there are too many constructors in the data type to list, + -- like for Int literals. In this case we determine what data type + -- it belongs to from the attached type of the data constructor. + -- + | DaConPrim + { -- | Name of the data constructor. + daConName :: !n + + -- | Type of the data constructor. + , daConType :: !t + } + + -- | Data constructor that has a data type declaration. + | DaConBound + { -- | Name of the data constructor. + daConName :: !n + } + deriving (Show, Eq) + + +instance (NFData n, NFData t) => NFData (DaCon n t) where + rnf !dc + = case dc of + DaConUnit -> () + DaConPrim n t -> rnf n `seq` rnf t + DaConBound n -> rnf n + + +-- | Take the name of data constructor, +-- if there is one. +takeNameOfDaCon :: DaCon n t -> Maybe n +takeNameOfDaCon dc + = case dc of + DaConUnit -> Nothing + DaConPrim{} -> Just $ daConName dc + DaConBound{} -> Just $ daConName dc + + +-- | Take the type annotation of a data constructor, +-- if we know it locally. +takeTypeOfDaCon :: DaCon n (Type n) -> Maybe (Type n) +takeTypeOfDaCon dc + = case dc of + DaConUnit -> Just $ tUnit + DaConPrim{} -> Just $ daConType dc + DaConBound{} -> Nothing + + +-- | The unit data constructor. +dcUnit :: DaCon n t +dcUnit = DaConUnit + 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/WiCon.hs b/DDC/Core/Exp/WiCon.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/WiCon.hs @@ -0,0 +1,27 @@ + +module DDC.Core.Exp.WiCon + ( WiCon (..)) +where +import DDC.Type.Exp +import DDC.Type.Sum () +import Control.DeepSeq + + +-- | Witness constructors. +data WiCon n + -- | Witness constructors defined in the environment. + -- In the interpreter we use this to hold runtime capabilities. + -- The attached type must be closed. + = WiConBound !(Bound n) !(Type n) + deriving (Show, Eq) + + +-- NFData --------------------------------------------------------------------- +instance NFData n => NFData (WiCon n) where + rnf wi + = case wi of + WiConBound u t -> rnf u `seq` rnf t + + + + diff --git a/DDC/Core/Fragment.hs b/DDC/Core/Fragment.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Fragment.hs @@ -0,0 +1,76 @@ + +-- | The ambient Disciple Core language is specialised to concrete languages +-- by adding primitive operations and optionally restricting the set of +-- available language features. This specialisation results in user-facing +-- language fragments such as @Disciple Core Tetra@ and @Disciple Core Salt@. +module DDC.Core.Fragment + ( -- * Langauge fragments + Fragment (..) + , mapProfileOfFragment + + , Profile (..) + , mapFeaturesOfProfile + , zeroProfile + + -- * Fragment features + , Feature (..) + , Features (..) + , zeroFeatures + , setFeature + + -- * Compliance + , complies + , compliesWithEnvs + , Complies + , Error (..)) +where +import DDC.Core.Fragment.Feature +import DDC.Core.Fragment.Compliance +import DDC.Core.Fragment.Error +import DDC.Core.Fragment.Profile +import DDC.Core.Module +import DDC.Core.Exp +import DDC.Core.Lexer + + +-- | Carries all the information we need to work on a particular +-- fragment of the Disciple Core language. +data Fragment n (err :: * -> *) + = Fragment + { -- | Language profile for this fragment. + fragmentProfile :: Profile n + + -- | File extension to use when dumping modules in this fragment. + , fragmentExtension :: String + + -- | Read a name. + , fragmentReadName :: String -> Maybe n + + -- | Lex module source into tokens, + -- given the source name and starting line number. + , fragmentLexModule :: String -> Int -> String -> [Located (Token n)] + + -- | Lex expression source into tokens, + -- given the source name and starting line number. + , fragmentLexExp :: String -> Int -> String -> [Located (Token n)] + + -- | Perform language fragment specific checks on a module. + , fragmentCheckModule :: forall a. Module a n -> Maybe (err a) + + -- | Perform language fragment specific checks on an expression. + , fragmentCheckExp :: forall a. Exp a n -> Maybe (err a) } + + +instance Show (Fragment n err) where + show frag + = profileName $ fragmentProfile frag + + +-- | Apply a function to the profile in a fragment. +mapProfileOfFragment + :: (Profile n -> Profile n) + -> Fragment n err -> Fragment n err + +mapProfileOfFragment f fragment + = fragment + { fragmentProfile = f (fragmentProfile fragment) } diff --git a/DDC/Core/Fragment/Compliance.hs b/DDC/Core/Fragment/Compliance.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Fragment/Compliance.hs @@ -0,0 +1,381 @@ + +module DDC.Core.Fragment.Compliance + ( complies + , compliesWithEnvs + , Complies) +where +import DDC.Core.Fragment.Feature +import DDC.Core.Fragment.Profile +import DDC.Core.Fragment.Error +import DDC.Core.Module +import DDC.Core.Exp.Annot +import Control.Monad +import Data.Maybe +import DDC.Type.Env (Env) +import Data.Set (Set) +import qualified DDC.Type.Env as Env +import qualified Data.Set as Set + + +-- | Check whether a core thing complies with a language fragment profile. +complies + :: (Ord n, Show n, Complies c) + => Profile n -- ^ Fragment profile giving the supported + -- language features and primitive operators. + -> c a n -- ^ The thing to check. + -> Maybe (Error a n) + +complies profile thing + = compliesWithEnvs profile + (profilePrimKinds profile) + (profilePrimTypes profile) + thing + + +-- | Like `complies` but with some starting environments. +compliesWithEnvs + :: (Ord n, Show n, Complies c) + => Profile n -- ^ Fragment profile giving the supported + -- language features and primitive operators. + -> Env.KindEnv n -- ^ Starting kind environment. + -> Env.TypeEnv n -- ^ Starting type environment. + -> c a n -- ^ The thing to check. + -> Maybe (Error a n) + +compliesWithEnvs profile kenv tenv thing + = let merr = result + $ compliesX profile + kenv tenv + contextTop thing + in case merr of + Left err -> Just err + Right _ -> Nothing + + + +-- Complies ------------------------------------------------------------------- +-- | Class of things we can check language fragment compliance for. +class Complies (c :: * -> * -> *) where + -- Check compliance of a well typed term with a language profile. + -- If it is not well typed then this can return a bad result. + compliesX + :: (Ord n, Show n) + => Profile n -- ^ Fragment profile giving the supported + -- language features and primitive operators. + -> Env n -- ^ Starting Kind environment. + -> Env n -- ^ Starting Type environment. + -> Context + -> c a n + -> CheckM a n + (Set n, Set n) -- Used type and value names. + + +instance Complies Module where + compliesX profile kenv tenv context mm + = do let bs = [ BName n (typeOfImportValue isrc) + | (n, isrc) <- moduleImportValues mm ] + let tenv' = Env.extends bs tenv + compliesX profile kenv tenv' context (moduleBody mm) + + +-- We'll mark type vars that only appear in types of binders as unused. +instance Complies Exp where + compliesX profile kenv tenv context xx + = let has f = f $ profileFeatures profile + ok = return (Set.empty, Set.empty) + in case xx of + + -- variables ---------------------------- + XVar _ u@(UName n) + | not $ Env.member u tenv + , not $ has featuresUnboundLevel0Vars + -> throw $ ErrorUndefinedVar n + + | args <- fromMaybe 0 $ contextFunArgs context + , Just t <- Env.lookup u tenv + , arity <- arityOfType t + , args >= 1 && args < arity + , not $ has featuresPartialApplication + -> throw $ ErrorUnsupported PartialApplication + + | otherwise + -> return (Set.empty, Set.singleton n) + + XVar _ u@(UPrim n t) + | not $ Env.member u (profilePrimTypes profile) + -> throw $ ErrorUndefinedPrim n + + | args <- fromMaybe 0 $ contextFunArgs context + , arity <- arityOfType t + , args < arity + , not $ has featuresPartialPrims + -> throw $ ErrorUnsupported PartialPrims + + | otherwise + -> return (Set.empty, Set.empty) + + XVar{} -> ok + + -- constructors ------------------------- + XCon{} -> ok + + -- spec binders ------------------------- + XLAM _ b x + | contextAbsBody context + , not $ has featuresNestedFunctions + -> throw $ ErrorUnsupported NestedFunctions + + | otherwise + -> do + -- If the body isn't another lambda then remember + -- that we've entered into a function. + let context' + | isXLAM x || isXLam x = context + | otherwise = setBody context + + (tUsed, vUsed) <- compliesX profile + (Env.extend b kenv) tenv + context' x + + tUsed' <- checkBind profile kenv b tUsed + return (tUsed', vUsed) + + -- value and witness abstraction -------- + XLam _ b x + | contextAbsBody context + , not $ has featuresNestedFunctions + -> throw $ ErrorUnsupported NestedFunctions + + | otherwise + -> do + -- If the body isn't another lambda then remember + -- that we've entered into a function. + let context' + | isXLAM x || isXLam x = context + | otherwise = setBody context + + (tUsed, vUsed) <- compliesX profile + kenv (Env.extend b tenv) + context' x + + vUsed' <- checkBind profile tenv b vUsed + return (tUsed, vUsed') + + -- application -------------------------- + XApp _ x1 (XType _ t2) + | profileTypeIsUnboxed profile t2 + , Nothing <- takeXPrimApps xx + -> throw $ ErrorUnsupported UnboxedInstantiation + + | otherwise + -> do checkFunction profile x1 + compliesX profile kenv tenv (addArg context) x1 + + XApp _ x1 XWitness{} + -> do checkFunction profile x1 + compliesX profile kenv tenv (addArg context) x1 + + XApp _ x1 x2 + -> do checkFunction profile x1 + (tUsed1, vUsed1) <- compliesX profile kenv tenv (addArg context) x1 + (tUsed2, vUsed2) <- compliesX profile kenv tenv context x2 + return ( Set.union tUsed1 tUsed2 + , Set.union vUsed1 vUsed2) + + -- let ---------------------------------- + XLet _ (LLet b1 x1) x2 + -> do let tenv' = Env.extend b1 tenv + (tUsed1, vUsed1) <- compliesX profile kenv tenv (reset context) x1 + (tUsed2, vUsed2) <- compliesX profile kenv tenv' (reset context) x2 + vUsed2' <- checkBind profile tenv b1 vUsed2 + + return ( Set.union tUsed1 tUsed2 + , Set.union vUsed1 vUsed2') + + XLet _ (LRec bxs) x2 + -> do let (bs, xs) = unzip bxs + let tenv' = Env.extends bs tenv + + (tUseds1, vUseds1) + <- liftM unzip + $ mapM (compliesX profile kenv tenv' (reset context)) + xs + + (tUsed2, vUsed2) <- compliesX profile kenv tenv' (reset context) x2 + let tUseds = Set.unions (tUsed2 : tUseds1) + let vUseds = Set.unions (vUsed2 : vUseds1) + + vUseds' <- checkBinds profile tenv bs vUseds + return (tUseds, vUseds') + + XLet _ (LPrivate rs _ bs) x2 + -> do (tUsed2, vUsed2) + <- compliesX profile (Env.extends rs kenv) + (Env.extends bs tenv) + (reset context) x2 + return (tUsed2, vUsed2) + + -- case --------------------------------- + XCase _ x1 alts + -> do (tUsed1, vUsed1) + <- compliesX profile kenv tenv (reset context) x1 + + (tUseds2, vUseds2) <- liftM unzip + $ mapM (compliesX profile kenv tenv (reset context)) alts + + return ( Set.unions $ tUsed1 : tUseds2 + , Set.unions $ vUsed1 : vUseds2) + + + -- cast --------------------------------- + XCast _ _ x -> compliesX profile kenv tenv (reset context) x + + -- type and witness --------------------- + XType _ t -> throw $ ErrorNakedType t + XWitness _ w -> throw $ ErrorNakedWitness w + + +instance Complies Alt where + compliesX profile kenv tenv context aa + = case aa of + AAlt PDefault x + -> do (tUsed1, vUsed1) <- compliesX profile kenv tenv + (reset context) x + return (tUsed1, vUsed1) + + AAlt (PData _ bs) x + -> do (tUsed1, vUsed1) <- compliesX profile kenv (Env.extends bs tenv) + (reset context) x + vUsed1' <- checkBinds profile tenv bs vUsed1 + return (tUsed1, vUsed1') + + +-- Bind ----------------------------------------------------------------------- +-- | Check for compliance violations at a binding site. +checkBind + :: Ord n + => Profile n -- ^ The current language profile. + -> Env n -- ^ The current environment + -> Bind n -- ^ The binder at this site. + -> Set n -- ^ Names used under the binder. + -> CheckM a n (Set n) -- ^ Names used above the binder. + +checkBind profile env bb used + = let has f = f $ profileFeatures profile + in case bb of + BName n _ + | not $ Set.member n used + , not $ has featuresUnusedBindings + -> throw $ ErrorUnusedBind n + + | Env.memberBind bb env + , not $ has featuresNameShadowing + -> throw $ ErrorShadowedBind n + + | otherwise + -> return $ Set.delete n used + + BAnon{} + | not $ has featuresDebruijnBinders + -> throw $ ErrorUnsupported DebruijnBinders + + _ -> return used + + +-- | Check for compliance violations at a binding site. +-- The binders must all be at the same level. +checkBinds + :: Ord n + => Profile n + -> Env n -> [Bind n] -> Set n + -> CheckM a n (Set n) + +checkBinds profile env bs used + = case bs of + [] -> return used + (b : bs') + -> do used' <- checkBinds profile env bs' used + checkBind profile env b used' + + +-- Function ------------------------------------------------------------------- +-- | Check the function part of an application. +checkFunction :: Profile n -> Exp a n -> CheckM a n () +checkFunction profile xx + = let has f = f $ profileFeatures profile + ok = return () + in case xx of + XVar{} -> ok + XCon{} -> ok + XApp{} -> ok + XCast{} -> ok + _ + | has featuresGeneralApplication -> return () + | otherwise -> throw $ ErrorUnsupported GeneralApplication + + +-- Context -------------------------------------------------------------------- +data Context + = Context + { contextAbsBody :: Bool + , contextFunArgs :: Maybe Int } + deriving (Eq, Show) + + +-- | The top level context, used at the top-level scope of a module. +contextTop :: Context +contextTop + = Context + { contextAbsBody = False + , contextFunArgs = Nothing } + + +-- | Record that we've entered into an abstraction body. +setBody :: Context -> Context +setBody context = context { contextAbsBody = True } + + +-- | Record that the expression is being directly applied to an argument. +addArg :: Context -> Context +addArg context + = case contextFunArgs context of + Nothing -> context { contextFunArgs = Just 1 } + Just args -> context { contextFunArgs = Just (args + 1) } + + +-- | Reset the argument counter of a context. +reset :: Context -> Context +reset context = context { contextFunArgs = Nothing } + + +-- Monad ---------------------------------------------------------------------- +-- | Compliance checking monad. +data CheckM a n x + = CheckM (Either (Error a n) x) + + +instance Functor (CheckM s err) where + fmap = liftM + + +instance Applicative (CheckM s err) where + (<*>) = ap + pure = return + + +instance Monad (CheckM a n) where + return x = CheckM (Right x) + (>>=) m f + = case m of + CheckM (Left err) -> CheckM (Left err) + CheckM (Right x) -> f x + + +-- | Throw an error in the monad. +throw :: Error a n -> CheckM a n x +throw e = CheckM $ Left e + + +-- | Take the result from a check monad. +result :: CheckM a n x -> Either (Error a n) x +result (CheckM r) = r diff --git a/DDC/Core/Fragment/Error.hs b/DDC/Core/Fragment/Error.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Fragment/Error.hs @@ -0,0 +1,59 @@ + +module DDC.Core.Fragment.Error + (Error(..)) +where +import DDC.Core.Fragment.Feature +import DDC.Core.Exp +import DDC.Core.Pretty + + +-- | Language fragment compliance violations. +data Error a n + -- | Found an unsupported language feature. + = ErrorUnsupported !Feature + + -- | Found an undefined primitive operator. + | ErrorUndefinedPrim !n + + -- | Found an unbound variable. + | ErrorUndefinedVar !n + + -- | Found a variable binder that shadows another one at a higher scope, + -- but the profile doesn't permit this. + | ErrorShadowedBind !n + + -- | Found a bound variable with no uses, + -- but the profile doesn't permit this. + | ErrorUnusedBind !n + + -- | Found a naked type that isn't used as a function argument. + | ErrorNakedType !(Type n) + + -- | Found a naked witness that isn't used as a function argument. + | ErrorNakedWitness !(Witness a n) + deriving Show + + +instance (Pretty n, Eq n) => Pretty (Error a n) where + ppr err + = case err of + ErrorUnsupported feature + -> vcat [ text "Unsupported feature: " <> text (show feature) ] + + ErrorUndefinedPrim n + -> vcat [ text "Undefined primitive: " <> ppr n ] + + ErrorUndefinedVar n + -> vcat [ text "Undefined variable: " <> ppr n ] + + ErrorShadowedBind n + -> vcat [ text "Binding shadows existing name: " <> ppr n ] + + ErrorUnusedBind n + -> vcat [ text "Bound name is not used: " <> ppr n ] + + ErrorNakedType t + -> vcat [ text "Naked type is not a function argument: " <> ppr t] + + ErrorNakedWitness w + -> vcat [ text "Naked witness is not a function argument: " <> ppr w ] diff --git a/DDC/Core/Fragment/Feature.hs b/DDC/Core/Fragment/Feature.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Fragment/Feature.hs @@ -0,0 +1,76 @@ + +module DDC.Core.Fragment.Feature + (Feature(..)) +where + + +-- | Language feature supported by a fragment. +data Feature + -- Type system features --------------------------- + -- | Track effect type information. + = TrackedEffects + + -- | Track closure type information. + | TrackedClosures + + -- | Attach latent effects to function types. + | FunctionalEffects + + -- | Attach latent closures to function types. + | FunctionalClosures + + -- | Treat effects as capabilities. + | EffectCapabilities + + -- | Insert implicit run casts for effectful applications. + | ImplicitRun + + -- | Insert implicit box casts for bodies of abstractions. + | ImplicitBox + + -- General features ------------------------------- + -- | Partially applied primitive operators. + | PartialPrims + + -- | Partially applied functions + | PartialApplication + + -- | Function application where the thing being applied + -- is not a variable. + -- Most backend languages (like LLVM) don't support this. + | GeneralApplication + + -- | Nested function bindings. + -- The output of the lambda-lifter should not contain these. + | NestedFunctions + + -- | Recursive let-expressions where the right hand sides + -- are not lambda abstractions. + | GeneralLetRec + + -- | Debruijn binders. + -- Most backends will want to use real names, instead of indexed + -- binders. + | DebruijnBinders + + -- | Allow data and witness vars without binding occurrences if + -- they are annotated directly with their types. This lets + -- us work with open terms. + | UnboundLevel0Vars + + -- | Allow non-primitive functions to be instantiated at unboxed types. + -- Our existing backends can't handle this, because boxed and unboxed + -- objects have different representations. + | UnboxedInstantiation + + -- Sanity ----------------------------------------- + -- | Allow name shadowing. + | NameShadowing + + -- | Allow unused named data and witness bindings. + | UnusedBindings + + -- | Allow unused named matches. + | UnusedMatches + deriving (Eq, Ord, Show) + diff --git a/DDC/Core/Fragment/Profile.hs b/DDC/Core/Fragment/Profile.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Fragment/Profile.hs @@ -0,0 +1,149 @@ + +-- | A fragment profile determines what features a program can use. +module DDC.Core.Fragment.Profile + ( Profile (..) + , mapFeaturesOfProfile + , zeroProfile + + , Features(..) + , zeroFeatures + , setFeature) +where +import DDC.Core.Exp.Literal +import DDC.Core.Fragment.Feature +import DDC.Type.DataDef +import DDC.Type.Exp +import DDC.Type.Env (KindEnv, TypeEnv) +import DDC.Data.SourcePos +import qualified DDC.Type.Env as Env + + +-- | The fragment profile describes the language features and +-- primitive operators available in the language. +data Profile n + = Profile + { -- | The name of this profile. + profileName :: !String + + -- | Permitted language features. + , profileFeatures :: !Features + + -- | Primitive data type declarations. + , profilePrimDataDefs :: !(DataDefs n) + + -- | Kinds of primitive types. + , profilePrimKinds :: !(KindEnv n) + + -- | Types of primitive operators. + , profilePrimTypes :: !(TypeEnv n) + + -- | Check whether a type is an unboxed type. + -- Some fragments limit how these can be used. + , profileTypeIsUnboxed :: !(Type n -> Bool) + + -- | Check whether some name represents a hole that needs + -- to be filled in by the type checker. + , profileNameIsHole :: !(Maybe (n -> Bool)) + + -- | Convert a literal to a name, + -- given the source position, literal value and whether + -- the literal should be taken as a language primitive + -- (with a trailing '#'). + , profileMakeLiteralName + :: Maybe (SourcePos -> Literal -> Bool -> Maybe n) } + + +-- | Apply a function to the `Features` of a `Profile`. +mapFeaturesOfProfile :: (Features -> Features) -> Profile n -> Profile n +mapFeaturesOfProfile f profile + = profile + { profileFeatures = f (profileFeatures profile) } + + +-- | A language profile with no features or primitive operators. +-- +-- This provides a simple first-order language. +zeroProfile :: Profile n +zeroProfile + = Profile + { profileName = "Zero" + , profileFeatures = zeroFeatures + , profilePrimDataDefs = emptyDataDefs + , profilePrimKinds = Env.empty + , profilePrimTypes = Env.empty + , profileTypeIsUnboxed = const False + , profileNameIsHole = Nothing + , profileMakeLiteralName = Nothing } + + +-- | A flattened set of features, for easy lookup. +data Features + = Features + { featuresTrackedEffects :: Bool + , featuresTrackedClosures :: Bool + , featuresFunctionalEffects :: Bool + , featuresFunctionalClosures :: Bool + , featuresEffectCapabilities :: Bool + , featuresImplicitRun :: Bool + , featuresImplicitBox :: Bool + , featuresPartialPrims :: Bool + , featuresPartialApplication :: Bool + , featuresGeneralApplication :: Bool + , featuresNestedFunctions :: Bool + , featuresGeneralLetRec :: Bool + , featuresDebruijnBinders :: Bool + , featuresUnboundLevel0Vars :: Bool + , featuresUnboxedInstantiation :: Bool + , featuresNameShadowing :: Bool + , featuresUnusedBindings :: Bool + , featuresUnusedMatches :: Bool + } + + +-- | An emtpy feature set, with all flags set to `False`. +zeroFeatures :: Features +zeroFeatures + = Features + { featuresTrackedEffects = False + , featuresTrackedClosures = False + , featuresFunctionalEffects = False + , featuresFunctionalClosures = False + , featuresEffectCapabilities = False + , featuresImplicitRun = False + , featuresImplicitBox = False + , featuresPartialPrims = False + , featuresPartialApplication = False + , featuresGeneralApplication = False + , featuresNestedFunctions = False + , featuresGeneralLetRec = False + , featuresDebruijnBinders = False + , featuresUnboundLevel0Vars = False + , featuresUnboxedInstantiation = False + , featuresNameShadowing = False + , featuresUnusedBindings = False + , featuresUnusedMatches = False } + + +-- | Set a language `Flag` in the `Profile`. +setFeature :: Feature -> Bool -> Features -> Features +setFeature feature val features + = case feature of + TrackedEffects -> features { featuresTrackedEffects = val } + TrackedClosures -> features { featuresTrackedClosures = val } + FunctionalEffects -> features { featuresFunctionalEffects = val } + FunctionalClosures -> features { featuresFunctionalClosures = val } + EffectCapabilities -> features { featuresEffectCapabilities = val } + ImplicitRun -> features { featuresImplicitRun = val } + ImplicitBox -> features { featuresImplicitBox = val } + PartialPrims -> features { featuresPartialPrims = val } + PartialApplication -> features { featuresPartialApplication = val } + GeneralApplication -> features { featuresGeneralApplication = val } + NestedFunctions -> features { featuresNestedFunctions = val } + GeneralLetRec -> features { featuresGeneralLetRec = val } + DebruijnBinders -> features { featuresDebruijnBinders = val } + UnboundLevel0Vars -> features { featuresUnboundLevel0Vars = val } + UnboxedInstantiation -> features { featuresUnboxedInstantiation = val } + NameShadowing -> features { featuresNameShadowing = val } + UnusedBindings -> features { featuresUnusedBindings = val } + UnusedMatches -> features { featuresUnusedMatches = val } + diff --git a/DDC/Core/Lexer.hs b/DDC/Core/Lexer.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer.hs @@ -0,0 +1,192 @@ + +-- | Reference lexer for core langauge parser. Slow but Simple. +-- +-- The lexers here all use 'String' in place of a real name type. +-- After applying these functions to the program text, we need +-- to use `renameTok` tok convert the strings in `TokNamed` tokens +-- into the name type specific to the langauge fragment to be parsed. +-- +module DDC.Core.Lexer + ( module DDC.Core.Lexer.Tokens + , Located (..) + + -- * Lexer + , lexModuleWithOffside + , lexExp) +where +import DDC.Core.Lexer.Token.Builtin +import DDC.Core.Lexer.Token.Index +import DDC.Core.Lexer.Token.Keyword +import DDC.Core.Lexer.Token.Literal +import DDC.Core.Lexer.Token.Names +import DDC.Core.Lexer.Token.Operator +import DDC.Core.Lexer.Token.Symbol + +import DDC.Core.Lexer.Offside +import DDC.Core.Lexer.Tokens +import DDC.Data.SourcePos +import Data.Text (Text) +import qualified System.IO.Unsafe as System +import qualified Text.Lexer.Inchworm.Char as I +import qualified Data.Text as Text + + +-- Module ----------------------------------------------------------------------------------------- +-- | Lex a module and apply the offside rule. +-- +-- Automatically drop comments from the token stream along the way. +-- +lexModuleWithOffside + :: FilePath -- ^ Path to source file, for error messages. + -> Int -- ^ Starting line number. + -> String -- ^ String containing program text. + -> [Located (Token String)] + +lexModuleWithOffside sourceName lineStart str + = applyOffside [] [] + $ addStarts + $ dropUnused + $ lexText sourceName lineStart + $ Text.pack str + + where dropUnused ts + = case ts of + [] -> [] + Located _ (KM KComment{}) : ts' -> dropUnused ts' + t : ts' -> t : dropUnused ts' + + +-- Exp -------------------------------------------------------------------------------------------- +-- | Lex a string into tokens. +-- +-- Automatically drop comments from the token stream along the way. +-- +lexExp :: FilePath -- ^ Path to source file, for error messages. + -> Int -- ^ Starting line number. + -> String -- ^ String containing program text. + -> [Located (Token String)] + +lexExp sourceName lineStart str + = dropUnused + $ lexText sourceName lineStart + $ Text.pack str + + where dropUnused ts + = case ts of + [] -> [] + Located _ (KM KComment{}) : ts' -> dropUnused ts' + Located _ (KM KNewLine{}) : ts' -> dropUnused ts' + t : ts' -> t : dropUnused ts' + + +-- Generic ---------------------------------------------------------------------------------------- +-- Tokenize some input text. +-- +-- NOTE: Although the main interface for the lexer uses standard Haskell strings, +-- we're using Text internally to get proper unicode tokenization. +-- Eventually, we should refactor the API to only pass around Text, rather +-- than Strings. +-- +lexText :: String -- ^ Name of source file, which is attached to the tokens. + -> Int -- ^ Starting line number. + -> Text -- ^ Text to tokenize. + -> [Located (Token String)] + +lexText filePath nStart txt + = let (toks, locEnd, strLeftover) + = System.unsafePerformIO + $ I.scanListIO + (I.Location nStart 1) + I.bumpLocationWithChar + (Text.unpack txt) + (scanner filePath) + + I.Location lineEnd colEnd = locEnd + spEnd = SourcePos filePath lineEnd colEnd + + in case strLeftover of + [] -> toks + str -> toks ++ [Located spEnd (KErrorJunk (take 10 str))] + + +-- | Scanner for core tokens tokens. +type Scanner a + = I.Scanner IO I.Location [Char] a + + +------------------------------------------------------------------------------- +-- | Scanner for source and core files. +-- +-- The lexical structure for source and core is a bit different, +-- but close enough that there's no point writing a separate lexer yet. +-- +scanner :: FilePath + -> Scanner (Located (Token String)) + +scanner fileName + = let + stamp :: (I.Location, a) -> Located a + stamp (I.Location line col, token) + = Located (SourcePos fileName line col) token + {-# INLINE stamp #-} + + stamp' :: (a -> b) + -> (I.Location, a) -> Located b + stamp' k (I.Location line col, token) + = Located (SourcePos fileName line col) (k token) + {-# INLINE stamp' #-} + + in I.skip (\c -> c == ' ' || c == '\t') + $ I.alts + [ -- Newlines are scanned to their own tokens because + -- the transform that manages the offside rule uses them. + fmap stamp + $ I.from (\c -> case c of + '\n' -> return $ KM KNewLine + _ -> Nothing) + + -- Scan comments into their own tokens, + -- these then get dropped by the dropComments function. + , fmap (stamp' (KM . KComment)) $ I.scanHaskellCommentLine + , fmap (stamp' (KM . KComment)) $ I.scanHaskellCommentBlock + + -- deBruijn indices. + -- Needs to come before scanSymbol as '^' is also an operator. + , fmap (stamp' (KA . KIndex)) $ scanIndex + + -- Literal values. + , fmap (stamp' (\(l, b) -> KA (KLiteral l b))) + $ scanLiteral + + -- Infix operators. + -- Needs to come before scanSymbol because operators + -- like "==" are parsed atomically rather than as + -- two separate '=' symbols. + , fmap (stamp' (KA . KOp)) $ scanInfixOperator + + -- Prefix operators. + , fmap (stamp' (KA . KOpVar)) $ scanPrefixOperator + + -- The unit value. + -- Needs to come before scanSymbol because the "()" + -- lexeme is parsed atomically rather than as + -- separate '(' and ')' symbols. + , fmap stamp + $ I.froms (Just 2) + (\ss -> if ss == "()" + then Just (KA $ KBuiltin $ BDaConUnit) + else Nothing) + + -- Symbolic tokens like punctuation. + , fmap (stamp' (KA . KSymbol)) $ scanSymbol + + -- Named things. + -- Keywords have the same lexical structure as variables as + -- they all start with a lower-case letter. We need to check + -- for keywords before accepting a variable. + , fmap (stamp' (KA . KBuiltin)) $ scanBuiltin + , fmap (stamp' (KA . KKeyword)) $ scanKeyword + , fmap (stamp' (KN . KCon)) $ scanConName + , fmap (stamp' (KN . KVar)) $ scanVarName + ] + diff --git a/DDC/Core/Lexer/Offside.hs b/DDC/Core/Lexer/Offside.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Offside.hs @@ -0,0 +1,434 @@ + +-- | Apply the offside rule to a token stream to add braces. +module DDC.Core.Lexer.Offside + ( Lexeme (..) + , applyOffside + , addStarts) +where +import DDC.Core.Lexer.Tokens +import DDC.Data.SourcePos + + +--------------------------------------------------------------------------------------------------- +-- | Holds a real token or start symbol which is used to apply the offside rule. +data Lexeme n + = LexemeToken (Located (Token n)) + | LexemeStartLine Int + + -- | Signal that we're starting a block in this column. + | LexemeStartBlock Int + deriving (Eq, Show) + + +-- | Parenthesis that we're currently inside. +data Paren + = ParenRound + | ParenBrace + deriving Show + +-- | What column number the current layout context started in. +type Context + = Int + + +-- | Apply the offside rule to this token stream. +-- +-- It should have been processed with addStarts first to add the +-- LexemeStartLine/LexemeStartLine tokens. +-- +-- Unlike the definition in the Haskell 98 report, we explicitly track +-- which parenthesis we're inside. We use these to partly implement +-- the layout rule that says we much check for entire parse errors to +-- perform the offside rule. +applyOffside + :: (Eq n, Show n) + => [Paren] -- ^ What parenthesis we're inside. + -> [Context] -- ^ Current layout context. + -> [Lexeme n] -- ^ Input lexemes. + -> [Located (Token n)] + +-- Wait for the module header before we start applying the real offside rule. +-- This allows us to write 'module Name with letrec' all on the same line. +applyOffside ps [] (LexemeToken t : ts) + | isKeyword t EModule + || isKNToken t + = t : applyOffside ps [] ts + + +-- Enter into a top-level block in the module, and start applying the +-- offside rule within it. +-- The blocks are introduced by: +-- 'exports' 'imports' 'letrec' 'where' +-- 'import foreign MODE type' +-- 'import foreign MODE capability' +-- 'import foreign MODE value' +applyOffside ps [] ls + | LexemeToken t1 + : (LexemeStartBlock n) : ls' <- ls + , isKeyword t1 EExport + || isKeyword t1 EImport + || isKeyword t1 ELetRec + || isKeyword t1 EWhere + = t1 : newCBra ls' : applyOffside (ParenBrace : ps) [n] ls' + + -- (import | export) (type | value) { ... } + | LexemeToken t1 : LexemeToken t2 + : LexemeStartBlock n : ls' <- ls + , isKeyword t1 EImport || isKeyword t1 EExport + , isKeyword t2 EType || isKeyword t2 EValue + = t1 : t2 : newCBra ls' : applyOffside (ParenBrace : ps) [n] ls' + + -- (import | export) foreign X (type | capability | value) { ... } + | LexemeToken t1 : LexemeToken t2 : LexemeToken t3 : LexemeToken t4 + : LexemeStartBlock n : ls' <- ls + , isKeyword t1 EImport || isKeyword t1 EExport + , isKeyword t2 EForeign + , isKeyword t4 EType || isKeyword t4 ECapability || isKeyword t4 EValue + = t1 : t2 : t3 : t4 : newCBra ls' : applyOffside (ParenBrace : ps) [n] ls' + +-- At top level without a context. +-- Skip over everything until we get the 'with' in 'module Name with ...'' +applyOffside ps [] (LexemeStartLine _ : ts) + = applyOffside ps [] ts + +applyOffside ps [] (LexemeStartBlock _ : ts) + = applyOffside ps [] ts + + +-- line start +applyOffside ps mm@(m : ms) (t@(LexemeStartLine n) : ts) + -- add semicolon to get to the next statement in this block + | m == n + = newSemiColon ts : applyOffside ps mm ts + + -- end a block + | n <= m + = case ps of + -- Closed a block that we're inside, ok. + ParenBrace : ps' + -> newCKet ts : applyOffside ps' ms (t : ts) + + -- We're supposed to close the block we're inside, but we're + -- still inside an open '(' context. Just keep passing the + -- tokens through, and let the parser give its error when + -- it gets to it. + ParenRound : _ + -> applyOffside ps ms ts + + -- We always push an element of the layout context + -- at the same time as a paren context, so this shouldn't happen. + _ -> error $ "ddc-core: paren / layout context mismatch." + + -- indented continuation of this statement + | otherwise + = applyOffside ps mm ts + + +-- block start +applyOffside ps mm@(m : ms) (LexemeStartBlock n : ts) + -- enter into a nested context + | n > m + = newCBra ts : applyOffside (ParenBrace : ps) (n : m : ms) ts + + -- new context starts less than the current one. + -- This should never happen, + -- provided addStarts works. + | tNext : _ <- dropNewLinesLexeme ts + = error $ "ddc-core: layout error on " ++ show tNext ++ "." + + -- new context cannot be less indented than outer one + -- This should never happen, + -- as there is no lexeme to start a new context at the end of the file. + | [] <- dropNewLinesLexeme ts + = error $ "ddc-core: tried to start new context at end of file." + + -- an empty block + | otherwise + = newCBra ts : newCKet ts : applyOffside ps mm (LexemeStartLine n : ts) + + +-- push context for explicit open brace +applyOffside ps ms + (LexemeToken t@(Located _ (KA (KSymbol SBraceBra))) : ts) + = t : applyOffside (ParenBrace : ps) (0 : ms) ts + +-- pop context from explicit close brace +applyOffside ps mm + (LexemeToken t@(Located _ (KA (KSymbol SBraceKet))) : ts) + + -- make sure that explict open braces match explicit close braces + | 0 : ms <- mm + , ParenBrace : ps' <- ps + = t : applyOffside ps' ms ts + + -- nup + | _tNext : _ <- dropNewLinesLexeme ts + = [newOffsideClosingBrace ts] + + +-- push context for explict open paren. +applyOffside ps ms + ( LexemeToken t@(Located _ (KA (KSymbol SRoundBra))) : ts) + = t : applyOffside (ParenRound : ps) ms ts + +-- force close of block on close paren. +-- This partially handles the crazy (Note 5) rule from the Haskell98 standard. +applyOffside (ParenBrace : ps) (m : ms) + (lt@(LexemeToken (Located _ (KA (KSymbol SRoundKet)))) : ts) + | m /= 0 + = newCKet ts : applyOffside ps ms (lt : ts) + +-- pop context for explicit close paren. +applyOffside (ParenRound : ps) ms + ( LexemeToken t@(Located _ (KA (KSymbol SRoundKet))) : ts) + = t : applyOffside ps ms ts + +-- pass over tokens. +applyOffside ps ms (LexemeToken t : ts) + = t : applyOffside ps ms ts + +applyOffside _ [] [] = [] + +-- close off remaining contexts once we've reached the end of the stream. +applyOffside ps (_ : ms) [] + = newCKet [] : applyOffside ps ms [] + + +isKeyword (Located _ tok) k + = case tok of + KA (KKeyword k') -> k == k' + _ -> False + + + +-- addStarts -------------------------------------------------------------------------------------- +-- | Add block and line start tokens to this stream. +-- +-- This is identical to the definition in the Haskell98 report, +-- except that we also use multi-token starting strings like +-- 'imports' 'foreign' 'type'. +addStarts :: (Eq n, Show n) => [Located (Token n)] -> [Lexeme n] +addStarts ts + = case dropNewLines ts of + + -- If the first lexeme of a module is not '{' then start a new block. + (t1 : tsRest) + | not $ or $ map (isToken t1) [KA (KSymbol SBraceBra)] + -> LexemeStartBlock (columnOfLocated t1) : addStarts' (t1 : tsRest) + + | otherwise + -> addStarts' (t1 : tsRest) + + -- empty file + [] -> [] + + +addStarts' :: Eq n => [Located (Token n)] -> [Lexeme n] +addStarts' ts + -- Block started at end of input. + | Just (ts1, ts2) <- splitBlockStart ts + , [] <- dropNewLines ts2 + = [LexemeToken t | t <- ts1] + ++ [LexemeStartBlock 0] + + -- Standard block start. + -- If there is not an open brace after a block start sequence then + -- insert a new one. + | Just (ts1, ts2) <- splitBlockStart ts + , t2 : tsRest <- dropNewLines ts2 + , not $ isToken t2 (KA (KSymbol SBraceBra)) + = [LexemeToken t | t <- ts1] + ++ [LexemeStartBlock (columnOfLocated t2)] + ++ addStarts' (t2 : tsRest) + + -- check for start of list + | t1 : ts' <- ts + , isToken t1 (KA (KSymbol SBraceBra)) + = LexemeToken t1 : addStarts' ts' + + -- check for end of list + | t1 : ts' <- ts + , isToken t1 (KA (KSymbol SBraceKet)) + = LexemeToken t1 : addStarts' ts' + + -- check for start of new line + | t1 : ts' <- ts + , isToken t1 (KM KNewLine) + , t2 : tsRest <- dropNewLines ts' + , not $ isToken t2 (KA (KSymbol SBraceBra)) + = LexemeStartLine (columnOfLocated t2) + : addStarts' (t2 : tsRest) + + -- eat up trailine newlines + | t1 : ts' <- ts + , isToken t1 (KM KNewLine) + = addStarts' ts' + + -- a regular token + | t1 : ts' <- ts + = LexemeToken t1 : addStarts' ts' + + -- end of input + | otherwise + = [] + + +-- | Drop newline tokens at the front of this stream. +dropNewLines :: Eq n => [Located (Token n)] -> [Located (Token n)] +dropNewLines [] = [] +dropNewLines (t1:ts) + | isToken t1 (KM KNewLine) + = dropNewLines ts + + | otherwise + = t1 : ts + + +-- | Drop newline tokens at the front of this stream. +dropNewLinesLexeme :: Eq n => [Lexeme n] -> [Lexeme n] +dropNewLinesLexeme ll + = case ll of + [] -> [] + LexemeToken t1 : ts + | isToken t1 (KM KNewLine) + -> dropNewLinesLexeme ts + + l : ls + -> l : dropNewLinesLexeme ls + + +-- | Check if a token is one that starts a block of statements. +splitBlockStart + :: [Located (Token n)] + -> Maybe ([Located (Token n)], [Located (Token n)]) + +splitBlockStart toks + + -- export type + | t1@(Located _ (KA (KKeyword EExport))) + : t2@(Located _ (KA (KKeyword EType))) + : ts + <- toks = Just ([t1, t2], ts) + + -- export value + | t1@(Located _ (KA (KKeyword EExport))) + : t2@(Located _ (KA (KKeyword EValue))) + : ts + <- toks = Just ([t1, t2], ts) + + -- export foreign X value + | t1@(Located _ (KA (KKeyword EExport))) + : t2@(Located _ (KA (KKeyword EForeign))) + : t3 + : t4@(Located _ (KA (KKeyword EValue))) + : ts + <- toks = Just ([t1, t2, t3, t4], ts) + + -- import type + | t1@(Located _ (KA (KKeyword EImport))) + : t2@(Located _ (KA (KKeyword EType))) + : ts + <- toks = Just ([t1, t2], ts) + + -- import value + | t1@(Located _ (KA (KKeyword EImport))) + : t2@(Located _ (KA (KKeyword EValue))) + : ts + <- toks = Just ([t1, t2], ts) + + -- import data + | t1@(Located _ (KA (KKeyword EImport))) + : t2@(Located _ (KA (KKeyword EData))) + : ts + <- toks = Just ([t1, t2], ts) + + -- import foreign X type + | t1@(Located _ (KA (KKeyword EImport))) + : t2@(Located _ (KA (KKeyword EForeign))) + : t3 + : t4@(Located _ (KA (KKeyword EType))) + : ts + <- toks = Just ([t1, t2, t3, t4], ts) + + -- import foreign X capability + | t1@(Located _ (KA (KKeyword EImport))) + : t2@(Located _ (KA (KKeyword EForeign))) + : t3 + : t4@(Located _ (KA (KKeyword ECapability))) + : ts + <- toks = Just ([t1, t2, t3, t4], ts) + + -- import foreign X value + | t1@(Located _ (KA (KKeyword EImport))) + : t2@(Located _ (KA (KKeyword EForeign))) + : t3 + : t4@(Located _ (KA (KKeyword EValue))) + : ts + <- toks = Just ([t1, t2, t3, t4], ts) + + | t1@(Located _ (KA (KKeyword EDo))) : ts <- toks = Just ([t1], ts) + | t1@(Located _ (KA (KKeyword EOf))) : ts <- toks = Just ([t1], ts) + | t1@(Located _ (KA (KKeyword ELetRec))) : ts <- toks = Just ([t1], ts) + | t1@(Located _ (KA (KKeyword EWhere))) : ts <- toks = Just ([t1], ts) + | t1@(Located _ (KA (KKeyword EExport))) : ts <- toks = Just ([t1], ts) + | t1@(Located _ (KA (KKeyword EImport))) : ts <- toks = Just ([t1], ts) + | t1@(Located _ (KA (KKeyword EMatch))) : ts <- toks = Just ([t1], ts) + + | otherwise + = Nothing + + +-- Utils ------------------------------------------------------------------------------------------ +-- | Test whether this wrapper token matches. +isToken :: Eq n => Located (Token n) -> Token n -> Bool +isToken (Located _ tok) tok2 + = tok == tok2 + + +-- | Test whether this wrapper token matches. +isKNToken :: Eq n => Located (Token n) -> Bool +isKNToken (Located _ (KN _)) = True +isKNToken _ = False + + +-- | When generating new source tokens, take the position from the first +-- non-newline token in this list +newCBra :: [Lexeme n] -> Located (Token n) +newCBra ts + = case takeTok ts of + Located sp _ -> Located sp (KA (KSymbol SBraceBra)) + + +newCKet :: [Lexeme n] -> Located (Token n) +newCKet ts + = case takeTok ts of + Located sp _ -> Located sp (KA (KSymbol SBraceKet)) + + +newSemiColon :: [Lexeme n] -> Located (Token n) +newSemiColon ts + = case takeTok ts of + Located sp _ -> Located sp (KA (KSymbol SSemiColon)) + + +-- | This is injected by `applyOffside` when it finds an explit close +-- brace in a position where it would close a synthetic one. +newOffsideClosingBrace :: [Lexeme n] -> Located (Token n) +newOffsideClosingBrace ts + = case takeTok ts of + Located sp _ -> Located sp (KM KOffsideClosingBrace) + + +takeTok :: [Lexeme n] -> Located (Token n) +takeTok [] + = Located (SourcePos "" 0 0) (KErrorJunk "") + +takeTok (l : ls) + = case l of + LexemeToken (Located _ (KM KNewLine)) + -> takeTok ls + + LexemeToken t -> t + LexemeStartLine _ -> takeTok ls + LexemeStartBlock _ -> takeTok ls + 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 new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Tokens.hs @@ -0,0 +1,252 @@ + +module DDC.Core.Lexer.Tokens + ( Located (..) + , columnOfLocated + + -- * Tokens + , Token (..) + , TokenMeta (..) + , TokenAtom (..) + , TokenNamed (..) + + , Keyword (..) + , Symbol (..) + , Builtin (..) + , Literal (..) + + -- ** Description + , describeToken + , describeTokenMeta + , describeTokenAtom + , describeTokenNamed + , sayKeyword + , saySymbol + , sayBuiltin + + -- ** Renaming + , renameToken + + -- ** Predicates + , isVarName + , isVarStart + , isVarBody + + , isConName + , isConStart + , isConBody + + , isLitName + , isLitStart + , isLitBody + + -- ** Literal Reading + , readLitInteger + , readLitNat + , readLitInt + , readLitSize + , readLitWordOfBits + , readLitFloatOfBits + , readBinary + , readHex) +where +import DDC.Data.SourcePos +import DDC.Core.Lexer.Token.Symbol +import DDC.Core.Lexer.Token.Keyword +import DDC.Core.Lexer.Token.Builtin +import DDC.Core.Lexer.Token.Literal +import DDC.Core.Lexer.Token.Names +import DDC.Core.Pretty +import Control.Monad +import Data.Text (Text) +import qualified Data.Text as T + + +-- TokenFamily ---------------------------------------------------------------- +-- | The family of a token. +-- This is used to help generate parser error messages, +-- so we can say ''the constructor Cons'' +-- and ''the keyword case'' etc. +data TokenFamily + = Symbol + | Keyword + | Constructor + | Index + | Literal + | Pragma + + +-- | Describe a token family, for parser error messages. +describeTokenFamily :: TokenFamily -> String +describeTokenFamily tf + = case tf of + Symbol -> "symbol" + Keyword -> "keyword" + Constructor -> "constructor" + Index -> "index" + Literal -> "literal" + Pragma -> "pragma" + + +-- Token ------------------------------------------------------------------------ +-- | Tokens accepted by the core language parser. +data Token n + -- | Some junk symbol that isn't part of the language. + = KErrorJunk String + + -- | The first part of an unterminated string. + | KErrorUnterm String + + -- | Meta tokens contain out-of-band information that is eliminated + -- before parsing proper. + | KM !TokenMeta + + -- | Atomic tokens are keywords, punctuation and baked-in + -- constructor names. + | KA !TokenAtom + + -- | A named token that is specific to the language fragment + -- (maybe it's a primop), or a user defined name. + | KN !(TokenNamed n) + deriving (Eq, Show) + + +-- | Apply a function to all the names in a `Tok`. +renameToken + :: Ord n2 + => (n1 -> Maybe n2) + -> Token n1 + -> Maybe (Token n2) + +renameToken f kk + = case kk of + KErrorJunk s + -> Just $ KErrorJunk s + + KErrorUnterm s + -> Just $ KErrorUnterm s + + KM t -> Just $ KM t + KA t -> Just $ KA t + KN t -> liftM KN $ renameTokenNamed f t + + +-- | Describe a token for parser error messages. +describeToken :: Pretty n => Token n -> String +describeToken kk + = case kk of + KErrorJunk c -> "character " ++ show c + KErrorUnterm _ -> "unterminated string" + KM tm -> describeTokenMeta tm + KA ta -> describeTokenAtom ta + KN tn -> describeTokenNamed tn + + +-- TokMeta -------------------------------------------------------------------- +-- | Meta tokens contain out-of-band information that is +-- eliminated before parsing proper. +data TokenMeta + = KNewLine + + -- | Comment string. + | KComment String + + -- | This is injected by `dropCommentBlock` when it finds + -- an unterminated block comment. + | KCommentUnterminated + + -- | This is injected by `applyOffside` when it finds an explit close + -- brace in a position where it would close a synthetic one. + | KOffsideClosingBrace + deriving (Eq, Show) + + +-- | Describe a TokMeta, for lexer error messages. +describeTokenMeta :: TokenMeta -> String +describeTokenMeta tm + = case tm of + KNewLine -> "new line" + KComment{} -> "comment" + KCommentUnterminated -> "unterminated block comment" + KOffsideClosingBrace -> "closing brace" + + +-- TokAtom -------------------------------------------------------------------- +-- | Atomic tokens are keywords, punctuation and baked-in constructor names. +-- They don't contain user-defined names or primops specific to the +-- language fragment. +data TokenAtom + -- | Pragmas. + = KPragma Text + + -- | Symbols. + | KSymbol Symbol + + -- | Keywords. + | KKeyword Keyword + + -- | Builtin names. + | KBuiltin Builtin + + -- | Infix operators, like in 1 + 2. + | KOp String + + -- | Wrapped operator, like in (+) 1 2. + | KOpVar String + + -- | Debrujn indices. + | KIndex Int + + -- | Literal values. + | KLiteral + Literal -- Literal value. + Bool -- Trailing '#' prim specifier. + deriving (Eq, Show) + + +-- | Describe a `TokAtom`, for parser error messages. +describeTokenAtom :: TokenAtom -> String +describeTokenAtom ta + = let (family, str) = describeTokenAtom' ta + in describeTokenFamily family ++ " " ++ show str + +describeTokenAtom' :: TokenAtom -> (TokenFamily, String) +describeTokenAtom' ta + = case ta of + KPragma p -> (Pragma, "{-#" ++ T.unpack p ++ "#-}") + KSymbol ss -> (Symbol, saySymbol ss) + KKeyword kw -> (Keyword, sayKeyword kw) + KBuiltin bb -> (Constructor, sayBuiltin bb) + KOp op -> (Symbol, op) + KOpVar op -> (Symbol, "(" ++ op ++ ")") + KIndex i -> (Index, "^" ++ show i) + KLiteral l b -> (Literal, show (l, b)) + + +-- TokNamed ------------------------------------------------------------------- +-- | A token with a user-defined name. +data TokenNamed n + = KCon n + | KVar n + deriving (Eq, Show) + + +-- | Describe a `TokNamed`, for parser error messages. +describeTokenNamed :: Pretty n => TokenNamed n -> String +describeTokenNamed tn + = case tn of + KCon n -> renderPlain $ text "constructor" <+> (dquotes $ ppr n) + KVar n -> renderPlain $ text "variable" <+> (dquotes $ ppr n) + + +-- | Apply a function to all the names in a `TokNamed`. +renameTokenNamed + :: Ord n2 + => (n1 -> Maybe n2) + -> TokenNamed n1 + -> Maybe (TokenNamed n2) + +renameTokenNamed f kk + = case kk of + KCon c -> liftM KCon $ f c + KVar c -> liftM KVar $ f c + 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 new file mode 100644 --- /dev/null +++ b/DDC/Core/Load.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- | \"Loading\" refers to the combination of parsing and type checking. +-- This is the easiest way to turn source tokens into a type-checked +-- abstract syntax tree. +module DDC.Core.Load + ( C.AnTEC (..) + , Error (..) + , Mode (..) + , CheckTrace (..) + + -- * Loading modules + , loadModuleFromFile + , loadModuleFromString + , loadModuleFromTokens + + -- * Loading expressions + , loadExpFromString + , loadExpFromTokens + + -- * Loading types + , loadTypeFromString + , loadTypeFromTokens + + -- * Loading witnesses + , loadWitnessFromString + , loadWitnessFromTokens) +where +import DDC.Core.Transform.SpreadX +import DDC.Core.Fragment.Profile +import DDC.Core.Lexer.Tokens +import DDC.Core.Check (Mode(..), CheckTrace) +import DDC.Core.Exp +import DDC.Core.Exp.Annot.AnT (AnT) +import DDC.Type.Transform.SpreadT +import DDC.Type.Universe +import DDC.Core.Module +import DDC.Data.Pretty +import DDC.Core.Fragment (Fragment) +import qualified DDC.Core.Env.EnvX as EnvX +import qualified DDC.Core.Fragment as F +import qualified DDC.Core.Parser as C +import qualified DDC.Core.Check as C +import qualified DDC.Control.Parser as BP +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import System.Directory + + +-- Error ------------------------------------------------------------------------------------------ +-- | Things that can go wrong when loading a core thing. +data Error n err + = ErrorRead !String + | ErrorParser !BP.ParseError + | ErrorCheckType !(C.Error BP.SourcePos n) + | ErrorCheckExp !(C.Error BP.SourcePos n) + | ErrorCompliance !(F.Error (C.AnTEC BP.SourcePos n) n) + | ErrorFragment !(err (C.AnTEC BP.SourcePos n)) + + +instance ( Eq n, Show n, Pretty n + , Pretty (err (C.AnTEC BP.SourcePos n))) + => Pretty (Error n err) where + ppr err + = case err of + ErrorRead str + -> vcat [ text "While reading." + , indent 2 $ text str ] + + ErrorParser err' + -> vcat [ text "While parsing." + , indent 2 $ ppr err' ] + + ErrorCheckType err' + -> vcat [ text "When checking type." + , indent 2 $ ppr err' ] + + ErrorCheckExp err' + -> vcat [ text "When checking expression." + , indent 2 $ ppr err' ] + + ErrorCompliance err' + -> vcat [ text "During fragment compliance check." + , indent 2 $ ppr err' ] + + ErrorFragment err' + -> vcat [ text "During fragment specific check." + , indent 2 $ ppr err' ] + + +-- Module ----------------------------------------------------------------------------------------- +-- | Parse and type check a core module from a file. +loadModuleFromFile + :: (Eq n, Ord n, Show n, Pretty n) + => Fragment n err -- ^ Language fragment definition. + -> FilePath -- ^ File containing source code. + -> Mode n -- ^ Type checker mode. + -> IO ( Either (Error n err) + (Module (C.AnTEC BP.SourcePos n) n) + , Maybe CheckTrace) + +loadModuleFromFile fragment filePath mode + = do + -- Check whether the file exists. + exists <- doesFileExist filePath + if not exists + then return ( Left $ ErrorRead $ "No such file '" ++ filePath ++ "'" + , Nothing) + else do + -- Read the source file. + src <- readFile filePath + + -- Lex the source. + let toks = (F.fragmentLexModule fragment) filePath 1 src + + return $ loadModuleFromTokens fragment filePath mode toks + + +-- | Parse and type check a core module from a string. +loadModuleFromString + :: (Eq n, Ord n, Show n, Pretty n) + => Fragment n err -- ^ Language fragment definition. + -> FilePath -- ^ Path to source file for error messages. + -> Int -- ^ Starting line number for error messages. + -> Mode n -- ^ Type checker mode. + -> String -- ^ Program text. + -> ( Either (Error n err) + (Module (C.AnTEC BP.SourcePos n) n) + , Maybe CheckTrace) + +loadModuleFromString fragment filePath lineStart mode src + = do let toks = F.fragmentLexModule fragment filePath lineStart src + loadModuleFromTokens fragment filePath mode toks + + +-- | Parse and type check a core module from some tokens. +loadModuleFromTokens + :: (Eq n, Ord n, Show n, Pretty n) + => Fragment n err -- ^ Language fragment definition. + -> FilePath -- ^ Path to source file for error messages. + -> Mode n -- ^ Type checker mode. + -> [Located (Token n)] -- ^ Source tokens. + -> ( Either (Error n err) + (Module (C.AnTEC BP.SourcePos n) n) + , Maybe CheckTrace) + +loadModuleFromTokens fragment sourceName mode toks' + = goParse toks' + where + -- Type checker config kind and type environments. + profile = F.fragmentProfile fragment + config = C.configOfProfile profile + kenv = profilePrimKinds profile + tenv = profilePrimTypes profile + + -- Parse the tokens. + goParse toks + = case BP.runTokenParser describeToken sourceName + (C.pModule (C.contextOfProfile profile)) + toks of + Left err -> (Left (ErrorParser err), Nothing) + Right mm -> goCheckType (spreadX kenv tenv mm) + + -- Check that the module is type well-typed. + goCheckType mm + = case C.checkModule config mm mode of + (Left err, ct) -> (Left (ErrorCheckExp err), Just ct) + (Right mm', ct) -> goCheckCompliance ct mm' + + -- Check that the module compiles with the language fragment. + goCheckCompliance ct mm + = case F.complies profile mm of + Just err -> (Left (ErrorCompliance err), Just ct) + Nothing -> goCheckFragment ct mm + + -- Perform fragment specific checks. + goCheckFragment ct mm + = case F.fragmentCheckModule fragment mm of + Just err -> (Left (ErrorFragment err), Just ct) + Nothing -> (Right mm, Just ct) + + +-- Exp -------------------------------------------------------------------------------------------- +-- | Parse and type-check and expression from a string. +loadExpFromString + :: (Eq n, Ord n, Show n, Pretty n) + => Fragment n err -- ^ Language fragment definition. + -> Map ModuleName (Module (C.AnTEC () n) n) + -- ^ Other modules currently in scope. + -- We add their exports to the environment. + -> FilePath -- ^ Path to source file for error messages. + -> Mode n -- ^ Type checker mode. + -> String -- ^ Source string. + -> ( Either (Error n err) + (Exp (C.AnTEC BP.SourcePos n) n) + , Maybe CheckTrace) + +loadExpFromString fragment modules sourceName mode src + = do let toks = F.fragmentLexExp fragment sourceName 1 src + loadExpFromTokens fragment modules sourceName mode toks + + +-- | Parse and check an expression +-- returning it along with its spec, effect and closure +loadExpFromTokens + :: (Eq n, Ord n, Show n, Pretty n) + => Fragment n err -- ^ Language fragment definition. + -> Map ModuleName (Module (C.AnTEC () n) n) + -- ^ Other modules currently in scope. + -- We add their exports to the environment. + -> FilePath -- ^ Path to source file for error messages. + -> Mode n -- ^ Type checker mode. + -> [Located (Token n)] -- ^ Source tokens. + -> ( Either (Error n err) + (Exp (C.AnTEC BP.SourcePos n) n) + , Maybe CheckTrace) + +loadExpFromTokens fragment modules sourceName mode toks' + = goParse toks' + where + -- Type checker profile, kind and type environments. + profile = F.fragmentProfile fragment + config = C.configOfProfile profile + + envx = modulesEnvX + (profilePrimKinds profile) + (profilePrimTypes profile) + (profilePrimDataDefs profile) + (Map.elems modules) + + kenv = EnvX.kindEnvOfEnvX envx + tenv = EnvX.typeEnvOfEnvX envx + + -- Parse the tokens. + goParse toks + = case BP.runTokenParser describeToken sourceName + (C.pExp (C.contextOfProfile profile)) + toks of + Left err -> (Left (ErrorParser err), Nothing) + Right t -> goCheckType (spreadX kenv tenv t) + + -- Check the kind of the type. + goCheckType x + = case C.checkExp config envx mode C.DemandNone x of + (Left err, ct) -> (Left (ErrorCheckExp err), Just ct) + (Right (x', _, _), ct) -> goCheckCompliance ct x' + + -- Check that the module compiles with the language fragment. + goCheckCompliance ct x + = case F.compliesWithEnvs profile kenv tenv x of + Just err -> (Left (ErrorCompliance err), Just ct) + Nothing -> goCheckFragment ct x + + -- Perform fragment specific checks. + goCheckFragment ct x + = case F.fragmentCheckExp fragment x of + Just err -> (Left (ErrorFragment err), Just ct) + Nothing -> (Right x, Just ct) + + +-- Type ------------------------------------------------------------------------------------------- +-- | Parse and check a type from a string, returning it along with its kind. +loadTypeFromString + :: (Eq n, Ord n, Show n, Pretty n) + => Fragment n err -- ^ Language fragment definition. + -> Universe -- ^ Universe this type is supposed to be in. + -> FilePath -- ^ Path to source file for error messages. + -> String -- ^ Source string. + -> Either (Error n err) + (Type n, Kind n) + +loadTypeFromString fragment uni sourceName str + = do let toks = F.fragmentLexExp fragment sourceName 1 str + loadTypeFromTokens fragment uni sourceName toks + + +-- | Parse and check a type from some tokens, returning it along with its kind. +loadTypeFromTokens + :: (Eq n, Ord n, Show n, Pretty n) + => Fragment n err -- ^ Language fragment definition. + -> Universe -- ^ Universe this type is supposed to be in. + -> FilePath -- ^ Path to source file for error messages. + -> [Located (Token n)] -- ^ Source tokens. + -> Either (Error n err) + (Type n, Kind n) + +loadTypeFromTokens fragment uni sourceName toks' + = goParse toks' + where + profile = F.fragmentProfile fragment + + -- Parse the tokens. + goParse toks + = case BP.runTokenParser describeToken sourceName + (C.pType (C.contextOfProfile profile)) + toks of + Left err -> Left (ErrorParser err) + Right t -> goCheckType (spreadT (profilePrimKinds profile) t) + + -- Check the kind of the type. + goCheckType t + = case C.checkType (C.configOfProfile profile) uni t of + Left err -> Left (ErrorCheckType err) + Right (t', k) -> Right (t', k) + + +-- Witness ---------------------------------------------------------------------------------------- +-- | Parse and check a witness from a string, returning it along with its kind. +loadWitnessFromString + :: (Eq n, Ord n, Show n, Pretty n) + => Fragment n err -- ^ Language fragment profile. + -> FilePath -- ^ Path to source file for error messages. + -> String -- ^ Source string. + -> Either (Error n err) + (Witness (AnT BP.SourcePos n) n, Type n) + +loadWitnessFromString fragment sourceName str + = do let toks = F.fragmentLexExp fragment sourceName 1 str + loadWitnessFromTokens fragment sourceName toks + + +-- | Parse and check a witness from some tokens, returning it along with its type. +loadWitnessFromTokens + :: (Eq n, Ord n, Show n, Pretty n) + => Fragment n err -- ^ Language fragment profile. + -> FilePath -- ^ Path to source file for error messages. + -> [Located (Token n)] -- ^ Source tokens. + -> Either (Error n err) + (Witness (AnT BP.SourcePos n) n, Type n) + +loadWitnessFromTokens fragment sourceName toks' + = goParse toks' + where -- Type checker config, kind and type environments. + profile = F.fragmentProfile fragment + config = C.configOfProfile profile + + env = EnvX.fromPrimEnvs + (profilePrimKinds profile) + (profilePrimTypes profile) + (profilePrimDataDefs profile) + + kenv = profilePrimKinds profile + tenv = profilePrimTypes profile + + -- Parse the tokens. + goParse toks + = case BP.runTokenParser describeToken sourceName + (C.pWitness (C.contextOfProfile profile)) + toks of + Left err -> Left (ErrorParser err) + Right t -> goCheckType (spreadX kenv tenv t) + + -- Check the kind of the type. + goCheckType w + = case C.checkWitness config env w of + Left err -> Left (ErrorCheckExp err) + Right (w', t) -> Right (w', t) + diff --git a/DDC/Core/Module.hs b/DDC/Core/Module.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Module.hs @@ -0,0 +1,392 @@ +module DDC.Core.Module + ( -- * Modules + Module (..) + , isMainModule + , moduleDataDefs + , moduleTypeDefs + , moduleKindEnv, moduleTypeEnv + , moduleEnvT, moduleEnvX + , modulesEnvT, modulesEnvX + , moduleTopBinds + , moduleTopBindTypes + , mapTopBinds + + -- * Module maps + , ModuleMap + , modulesExportTypes + , modulesExportValues + + -- * Module Names + , ModuleName (..) + , readModuleName + , isMainModuleName + , moduleNameMatchesPath + + -- * Qualified names. + , QualName (..) + + -- * Export Definitions + , ExportSource (..) + , takeTypeOfExportSource + , mapTypeOfExportSource + + -- * Import Definitions + -- ** Import Types + , ImportType (..) + , kindOfImportType + , mapKindOfImportType + + -- ** Import Capabilities + , ImportCap (..) + , typeOfImportCap + , mapTypeOfImportCap + + -- ** Import Types + , ImportValue (..) + , typeOfImportValue + , mapTypeOfImportValue) +where +import DDC.Core.Module.Export +import DDC.Core.Module.Import +import DDC.Core.Module.Name +import DDC.Core.Exp.Annot +import DDC.Type.DataDef +import Data.Typeable +import Data.Map.Strict (Map) +import Data.Set (Set) +import DDC.Core.Env.EnvT (EnvT (EnvT)) +import DDC.Core.Env.EnvX (EnvX) +import DDC.Type.Env as Env +import qualified DDC.Type.DataDef as DataDef +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified DDC.Core.Env.EnvT as EnvT +import qualified DDC.Core.Env.EnvX as EnvX +import Control.DeepSeq +import Data.Maybe + + +-- Module ----------------------------------------------------------------------------------------- +-- | A module can be mutually recursive with other modules. +data Module a n + = ModuleCore + { -- | Name of this module. + moduleName :: !ModuleName + + -- | Whether this is a module header only. + -- Module headers contain type definitions, as well as imports and exports, + -- but no function definitions. Module headers are used in interface files. + , moduleIsHeader :: !Bool + + -- Exports ------------------ + -- | Kinds of exported types. + , moduleExportTypes :: ![(n, ExportSource n (Type n))] + + -- | Types of exported values. + , moduleExportValues :: ![(n, ExportSource n (Type n))] + + -- Imports ------------------ + -- | Define imported types. + , moduleImportTypes :: ![(n, ImportType n (Type n))] + + -- | Define imported capabilities. + , moduleImportCaps :: ![(n, ImportCap n (Type n))] + + -- | Define imported values. + , moduleImportValues :: ![(n, ImportValue n (Type n))] + + -- | Data defs imported from other modules. + , moduleImportDataDefs :: ![DataDef n] + + -- | Type defs imported from other modules. + , moduleImportTypeDefs :: ![(n, (Kind n, Type n))] + + -- Local defs --------------- + -- | Data types defined in this module. + , moduleDataDefsLocal :: ![DataDef n] + + -- | Type definitions in this module. + , moduleTypeDefsLocal :: ![(n, (Kind n, Type n))] + + -- | The module body consists of some let-bindings wrapping a unit + -- data constructor. We're only interested in the bindings, with + -- the unit being just a place-holder. + , moduleBody :: !(Exp a n) + } + deriving (Show, Typeable) + + +instance (NFData a, NFData n) => NFData (Module a n) where + rnf !mm + = rnf (moduleName mm) + `seq` rnf (moduleIsHeader mm) + `seq` rnf (moduleExportTypes mm) + `seq` rnf (moduleExportValues mm) + `seq` rnf (moduleImportTypes mm) + `seq` rnf (moduleImportCaps mm) + `seq` rnf (moduleImportValues mm) + `seq` rnf (moduleImportDataDefs mm) + `seq` rnf (moduleImportTypeDefs mm) + `seq` rnf (moduleDataDefsLocal mm) + `seq` rnf (moduleTypeDefsLocal mm) + `seq` rnf (moduleBody mm) + + +-- | Check if this is the `Main` module. +isMainModule :: Module a n -> Bool +isMainModule mm + = isMainModuleName + $ moduleName mm + + +-- | Get the data type definitions visible in a module. +moduleDataDefs :: Ord n => Module a n -> DataDefs n +moduleDataDefs mm + = fromListDataDefs + $ (moduleImportDataDefs mm ++ moduleDataDefsLocal mm) + + +-- | Get the data type definitions visible in a module. +moduleTypeDefs :: Ord n => Module a n -> [(n, (Kind n, Type n))] +moduleTypeDefs mm + = moduleImportTypeDefs mm ++ moduleTypeDefsLocal mm + + +-- | Get the top-level kind environment of a module, +-- from its imported types. +moduleKindEnv :: Ord n => Module a n -> KindEnv n +moduleKindEnv mm + = Env.fromList + $ [BName n (kindOfImportType isrc) | (n, isrc) <- moduleImportTypes mm] + + +-- | Get the top-level type environment of a module, +-- from its imported values. +moduleTypeEnv :: Ord n => Module a n -> TypeEnv n +moduleTypeEnv mm + = Env.fromList + $ [BName n (typeOfImportValue isrc) | (n, isrc) <- moduleImportValues mm] + + +-- | Extract the top-level `EnvT` environment from a module. +-- +-- This includes kinds for abstract types, data types, and type equations, +-- but not primitive types which are fragment specific. +-- +moduleEnvT + :: Ord n + => KindEnv n -- ^ Primitive kind environment. + -> Module a n -- ^ Module to extract environemnt from. + -> EnvT n + +moduleEnvT kenvPrim mm + = EnvT + { EnvT.envtEquations + = Map.unions + [ Map.fromList [(n, t) | (n, (_, t)) <- moduleImportTypeDefs mm] + , Map.fromList [(n, t) | (n, (_, t)) <- moduleTypeDefsLocal mm]] + + , EnvT.envtCapabilities + = Map.fromList [(n, typeOfImportCap ic) | (n, ic) <- moduleImportCaps mm] + + , EnvT.envtPrimFun + = Env.envPrimFun kenvPrim + + , EnvT.envtMap + = let -- Kinds of imported foreign types. + nksImportForeignType + = Map.fromList [(n, kindOfImportType isrc) + | (n, isrc) <- moduleImportTypes mm] + + -- Kinds of imported data types. + nksImportDataType + = Map.fromList [(dataDefTypeName def, kindOfDataDef def) + | def <- moduleImportDataDefs mm] + + -- Kinds of imported type defs. + nksImportTypeDef + = Map.fromList [(n, k) | (n, (k, _)) <- moduleImportTypeDefs mm] + + -- Kinds of locally defined data types. + nksLocalDataType + = Map.fromList [(dataDefTypeName def, kindOfDataDef def) + | def <- moduleImportDataDefs mm] + + -- Kinds of imported type defs. + nksLocalTypeDef + = Map.fromList [(n, k) | (n, (k, _)) <- moduleTypeDefsLocal mm] + + in -- Build a map of all the kinds, + -- Where kinds of locally defined type shadow the imported ones. + Map.unions + [ nksImportForeignType + , nksImportDataType + , nksImportTypeDef + , nksLocalDataType + , nksLocalTypeDef ] + + , EnvT.envtStack = [] + , EnvT.envtStackLength = 0 + + } + + +-- | Extract the top-level `EnvT` environment from several modules. +--- +-- After unioning all the individual environments we reset the prim +-- function so we only have a single version of it. +modulesEnvT + :: Ord n + => KindEnv n -- ^ Primitive kind environment. + -> [Module a n] -- ^ Modules to build environment from. + -> EnvT n + +modulesEnvT kenv ms + = (EnvT.unions $ map (moduleEnvT kenv) ms) + { EnvT.envtPrimFun = Env.envPrimFun kenv } + + +-- | Extract the top-level `EnvX` environment from a module. +moduleEnvX + :: Ord n + => KindEnv n -- ^ Primitive kind environment. + -> TypeEnv n -- ^ Primitive type environment. + -> DataDefs n -- ^ Primitive data type definitions. + -> Module a n -- ^ Module to extract environemnt from. + -> EnvX n + +moduleEnvX kenvPrim tenvPrim dataDefs mm + = EnvX.empty + { EnvX.envxEnvT = moduleEnvT kenvPrim mm + , EnvX.envxPrimFun = Env.envPrimFun tenvPrim + + , EnvX.envxDataDefs + = DataDef.unionDataDefs dataDefs + $ DataDef.unionDataDefs + (DataDef.fromListDataDefs $ moduleImportDataDefs mm) + (DataDef.fromListDataDefs $ moduleDataDefsLocal mm) + + , EnvX.envxMap + = Map.fromList + [ (n, typeOfImportValue isrc) + | (n, isrc) <- moduleImportValues mm ] + } + + +-- | Extract the top-level `EnvT` environment from several modules. +modulesEnvX + :: Ord n + => KindEnv n -- ^ Primitive kind environment. + -> TypeEnv n -- ^ Primitive type environment. + -> DataDefs n -- ^ Primitive data type definitions. + -> [Module a n] -- ^ Modules to build environment from. + -> EnvX n + +modulesEnvX kenv tenv defs ms + = let -- Base environment contains all the prims. + -- We need to include this for the case when there are no + -- provided modules, so the prims are still end up in the result. + env0 = EnvX.fromPrimEnvs kenv tenv defs + + -- Build environments for each of the modules + envs = map (moduleEnvX kenv tenv defs) ms + + -- Union the above into a composite environment. + env = EnvX.unions (env0 : envs) + + -- The EnvX.unions function combines the prim funs so that + -- if a lookup fails the primfun from the next module will + -- be called, but as the primfuns in each module are identical + -- we only need a single version. + env' = env + { EnvX.envxPrimFun = EnvX.envxPrimFun env0 } + in env' + + +-- | Get the set of top-level value bindings in a module. +moduleTopBinds :: Ord n => Module a n -> Set n +moduleTopBinds mm + = go (moduleBody mm) + where go xx + = case xx of + XLet _ (LLet (BName n _) _) x2 + -> Set.insert n (go x2) + + XLet _ (LLet _ _) x2 + -> go x2 + + XLet _ (LRec bxs) x2 + -> Set.fromList (mapMaybe takeNameOfBind $ map fst bxs) + `Set.union` go x2 + + _ -> Set.empty + + +-- | Get a map of named top-level bindings to their types. +moduleTopBindTypes :: Ord n => Module a n -> Map n (Type n) +moduleTopBindTypes mm + = go Map.empty (moduleBody mm) + where go acc xx + = case xx of + XLet _ (LLet (BName n t) _) x2 + -> go (Map.insert n t acc) x2 + + XLet _ (LLet _ _) x2 + -> go acc x2 + + XLet _ (LRec bxs) x2 + -> let nts = Map.fromList [(n, t) | BName n t <- map fst bxs] + in go (Map.union acc nts) x2 + + _ -> acc + + +-- | Apply a function to all the top-level bindings in a module, +-- producing a list of the results. +mapTopBinds :: (Bind n -> Exp a n -> b) -> Module a n -> [b] +mapTopBinds f mm + = go [] (moduleBody mm) + where + go acc xx + = case xx of + XLet _ (LLet b1 x1) x2 + -> go (f b1 x1 : acc) x2 + + XLet _ (LRec bxs) x2 + -> let rs = reverse $ map (uncurry f) bxs + in go (rs ++ acc) x2 + + _ -> reverse acc + + +-- ModuleMap -------------------------------------------------------------------------------------- +-- | Map of module names to modules. +type ModuleMap a n + = Map ModuleName (Module a n) + + +-- | Add the kind environment exported by all these modules to the given one. +modulesExportTypes :: Ord n => ModuleMap a n -> KindEnv n -> KindEnv n +modulesExportTypes mods base + = let envOfModule m + = Env.fromList + $ [BName n t | (n, Just t) + <- map (liftSnd takeTypeOfExportSource) $ moduleExportTypes m] + + liftSnd f (x, y) = (x, f y) + + in Env.unions $ base : (map envOfModule $ Map.elems mods) + + +-- | Add the type environment exported by all these modules to the given one. +modulesExportValues :: Ord n => ModuleMap a n -> TypeEnv n -> TypeEnv n +modulesExportValues mods base + = let envOfModule m + = Env.fromList + $ [BName n t | (n, Just t) + <- map (liftSnd takeTypeOfExportSource) $ moduleExportValues m] + + liftSnd f (x, y) = (x, f y) + + in Env.unions $ base : (map envOfModule $ Map.elems mods) + 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 @@ -1,631 +1,59 @@ -- | Core language parser. module DDC.Core.Parser - ( module DDC.Base.Parser - , Parser - , pExp - , pWitness) - -where -import DDC.Core.Exp -import DDC.Core.Parser.Tokens -import DDC.Base.Parser (()) -import DDC.Type.Parser (pTok) -import qualified DDC.Base.Parser as P -import qualified DDC.Type.Compounds as T -import qualified DDC.Type.Parser as T -import Control.Monad.Error - - --- | A parser of core language tokens. -type Parser n a - = P.Parser (Tok n) a - - --- Expressions ---------------------------------------------------------------- --- | Parse a core language expression. -pExp :: Ord n => Parser n (Exp () n) -pExp - = P.choice - -- Level-0 lambda abstractions - -- \(x1 x2 ... : TYPE) (y1 y2 ... : TYPE) ... . EXP - [ do pTok KBackSlash - - bs <- liftM concat - $ P.many1 - $ do pTok KRoundBra - bs' <- P.many1 T.pBinder - pTok KColon - t <- T.pType - pTok KRoundKet - return (map (\b -> T.makeBindFromBinder b t) bs') - - pTok KDot - xBody <- pExp - return $ foldr (XLam ()) xBody bs - - -- Level-1 lambda abstractions. - -- /\(x1 x2 ... : TYPE) (y1 y2 ... : TYPE) ... . EXP - , do pTok KBigLambda - - bs <- liftM concat - $ P.many1 - $ do pTok KRoundBra - bs' <- P.many1 T.pBinder - pTok KColon - t <- T.pType - pTok KRoundKet - return (map (\b -> T.makeBindFromBinder b t) bs') - - pTok KDot - xBody <- pExp - return $ foldr (XLAM ()) xBody bs - - - -- let expression - , do pTok KLet - (mode1, b1, x1) <- pLetBinding - pTok KIn - x2 <- pExp - return $ XLet () (LLet mode1 b1 x1) x2 - - - -- letrec expression - , do pTok KLetRec - - P.choice - -- Multiple bindings in braces - [ do pTok KBraceBra - lets <- P.sepEndBy1 pLetRecBinding (pTok KSemiColon) - pTok KBraceKet - pTok KIn - x <- pExp - return $ XLet () (LRec lets) x - - -- A single binding without braces. - , do ll <- pLetRecBinding - pTok KIn - x <- pExp - return $ XLet () (LRec [ll]) x - ] - - - -- Local region binding. - -- letregion BINDER with { BINDER : TYPE ... } in EXP - -- letregion BINDER in EXP - , do pTok KLetRegion - br <- T.pBinder - let b = T.makeBindFromBinder br T.kRegion - - P.choice - [ do pTok KWith - pTok KBraceBra - wits <- P.sepBy - (do w <- pVar - pTok KColon - t <- T.pTypeApp - return (BName w t)) - (pTok KSemiColon) - pTok KBraceKet - pTok KIn - x <- pExp - return $ XLet () (LLetRegion b wits) x - - , do pTok KIn - x <- pExp - return $ XLet () (LLetRegion b []) x ] - - - -- withregion CON in EXP - , do pTok KWithRegion - n <- pVar - pTok KIn - x <- pExp - let u = UName n (T.tBot T.kRegion) - return $ XLet () (LWithRegion u) x - - - -- case EXP of { ALTS } - , do pTok KCase - x <- pExp - pTok KOf - pTok KBraceBra - alts <- P.sepEndBy1 pAlt (pTok KSemiColon) - pTok KBraceKet - return $ XCase () x alts - - - -- weakeff [TYPE] in EXP - , do pTok KWeakEff - pTok KSquareBra - t <- T.pType - pTok KSquareKet - pTok KIn - x <- pExp - return $ XCast () (CastWeakenEffect t) x - - - -- weakclo [TYPE] in EXP - , do pTok KWeakClo - pTok KSquareBra - t <- T.pType - pTok KSquareKet - pTok KIn - x <- pExp - return $ XCast () (CastWeakenClosure t) x - - - -- purify in EXP - , do pTok KPurify - pTok KAngleBra - w <- pWitness - pTok KAngleKet - pTok KIn - x <- pExp - return $ XCast () (CastPurify w) x - - - -- forget in EXP - , do pTok KForget - pTok KAngleBra - w <- pWitness - pTok KAngleKet - pTok KIn - x <- pExp - return $ XCast () (CastForget w) x - - -- APP - , do pExpApp - ] - - "an expression" - - --- Applications. -pExpApp :: Ord n => Parser n (Exp () n) -pExpApp - = do x1 <- pExp0 - - P.choice - [ do xs <- liftM concat $ P.many1 pArgs - return $ foldl (XApp ()) x1 xs - - , return x1] - - "an expression or application" - - --- Comp, Witness or Spec arguments. -pArgs :: Ord n => Parser n [Exp () n] -pArgs - = P.choice - -- [TYPE] - [ do pTok KSquareBra - t <- T.pType - pTok KSquareKet - return [XType t] - - -- [: TYPE0 TYPE0 ... :] - , do pTok KSquareColonBra - ts <- P.many1 T.pTypeAtom - pTok KSquareColonKet - return $ map XType ts - - -- - , do pTok KAngleBra - w <- pWitness - pTok KAngleKet - return [XWitness w] - - -- <: WITNESS0 WITNESS0 ... :> - , do pTok KAngleColonBra - ws <- P.many1 pWitnessAtom - pTok KAngleColonKet - return $ map XWitness ws - - -- EXP0 - , do x <- pExp0 - return [x] - ] - "a type, witness or expression argument" - - --- Atomics -pExp0 :: Ord n => Parser n (Exp () n) -pExp0 - = P.choice - -- (EXP2) - [ do pTok KRoundBra - t <- pExp - pTok KRoundKet - return $ t - - -- Named constructors - , do con <- pCon - return $ XCon () (UName con (T.tBot T.kData)) - - -- Literals - , do lit <- pLit - return $ XCon () (UName lit (T.tBot T.kData)) - - -- Debruijn indices - , do i <- T.pIndex - return $ XVar () (UIx i (T.tBot T.kData)) - - -- Variables - , do var <- pVar - return $ XVar () (UName var (T.tBot T.kData)) - ] - - "a variable, constructor, or parenthesised type" - - --- Case alternatives. -pAlt :: Ord n => Parser n (Alt () n) -pAlt - = do p <- pPat - pTok KArrowDash - x <- pExp - return $ AAlt p x - - --- Patterns. -pPat :: Ord n => Parser n (Pat n) -pPat - = P.choice - [ -- Wildcard - do pTok KUnderscore - return $ PDefault - - -- LIT - , do nLit <- pLit - return $ PData (UName nLit (T.tBot T.kData)) [] - - -- CON BIND BIND ... - , do nCon <- pCon - bs <- P.many pBindPat - return $ PData (UName nCon (T.tBot T.kData)) bs] - - --- Binds in patterns can have no type annotation, --- or can have an annotation if the whole thing is in parens. -pBindPat :: Ord n => Parser n (Bind n) -pBindPat - = P.choice - -- Plain binder. - [ do b <- T.pBinder - return $ T.makeBindFromBinder b (T.tBot T.kData) - - -- Binder with type, wrapped in parens. - , do pTok KRoundBra - b <- T.pBinder - pTok KColon - t <- T.pType - pTok KRoundKet - return $ T.makeBindFromBinder b t - ] - - --- Bindings ------------------------------------------------------------------- --- | A binding for let expression. -pLetBinding :: Ord n => Parser n (LetMode n, Bind n, Exp () n) -pLetBinding - = do b <- T.pBinder - - P.choice - [ do -- Binding with full type signature. - -- BINDER : TYPE = EXP - pTok KColon - t <- T.pType - mode <- pLetMode - pTok KEquals - xBody <- pExp - - return $ (mode, T.makeBindFromBinder b t, xBody) - - - , do -- Non-function binding with no type signature. - -- This form can't be used with letrec as we can't use it - -- to build the full type sig for the let-bound variable. - -- BINDER = EXP - mode <- pLetMode - pTok KEquals - xBody <- pExp - let t = T.tBot T.kData - return $ (mode, T.makeBindFromBinder b t, xBody) - - - , do -- Binding using function syntax. - ps <- liftM concat - $ P.many pBindParamSpec - - P.choice - [ do -- Function syntax with a return type. - -- We can make the full type sig for the let-bound variable. - -- BINDER PARAM1 PARAM2 .. PARAMN : TYPE = EXP - pTok KColon - tBody <- T.pType - mode <- pLetMode - pTok KEquals - xBody <- pExp - - let x = expOfParams () ps xBody - let t = funTypeOfParams ps tBody - return (mode, T.makeBindFromBinder b t, x) - - -- Function syntax with no return type. - -- We can't make the type sig for the let-bound variable, - -- but we can create lambda abstractions with the given - -- parameter types. - -- BINDER PARAM1 PARAM2 .. PARAMN = EXP - , do mode <- pLetMode - pTok KEquals - xBody <- pExp - - let x = expOfParams () ps xBody - let t = T.tBot T.kData - return (mode, T.makeBindFromBinder b t, x) ] - ] - --- | Parse a let mode specifier. --- Only allow the lazy specifier with non-recursive bindings. --- We don't support value recursion, so the right of all recursive --- bindings must be explicit lambda abstractions anyway, so there's --- no point suspending them. -pLetMode :: Ord n => Parser n (LetMode n) -pLetMode - = do P.choice - -- lazy - [ do pTok KLazy - - P.choice - [ do pTok KAngleBra - w <- pWitness - pTok KAngleKet - return $ LetLazy (Just w) - - , do return $ LetLazy Nothing ] - - , do return $ LetStrict ] - - --- | Letrec bindings must have a full type signature, --- or use function syntax with a return type so that we can make one. -pLetRecBinding :: Ord n => Parser n (Bind n, Exp () n) -pLetRecBinding - = do b <- T.pBinder - - P.choice - [ do -- Binding with full type signature. - -- BINDER : TYPE = EXP - pTok KColon - t <- T.pType - pTok KEquals - xBody <- pExp - - return $ (T.makeBindFromBinder b t, xBody) - - - , do -- Binding using function syntax. - -- BINDER PARAM1 PARAM2 .. PARAMN : TYPE = EXP - ps <- liftM concat - $ P.many pBindParamSpec - - pTok KColon - tBody <- T.pType - let t = funTypeOfParams ps tBody - - pTok KEquals - xBody <- pExp - let x = expOfParams () ps xBody - - return (T.makeBindFromBinder b t, x) ] - - --- | Parse a parameter specification. --- --- [BIND1 BIND2 .. BINDN : TYPE] --- or (BIND : TYPE) --- or (BIND : TYPE) { EFFECT | CLOSURE } --- -pBindParamSpec :: Ord n => Parser n [ParamSpec n] -pBindParamSpec - = P.choice - -- Type parameter - -- [BIND1 BIND2 .. BINDN : TYPE] - [ do pTok KSquareBra - bs <- P.many1 T.pBinder - pTok KColon - t <- T.pType - pTok KSquareKet - return [ ParamType b - | b <- zipWith T.makeBindFromBinder bs (repeat t)] - - - -- Witness parameter - -- - , do pTok KAngleBra - b <- T.pBinder - pTok KColon - t <- T.pType - pTok KAngleKet - return [ ParamWitness $ T.makeBindFromBinder b t] - - -- Value parameter - -- (BIND : TYPE) - -- (BIND : TYPE) { TYPE | TYPE } - , do pTok KRoundBra - b <- T.pBinder - pTok KColon - t <- T.pType - pTok KRoundKet - - (eff, clo) - <- P.choice - [ do pTok KBraceBra - eff' <- T.pType - pTok KBar - clo' <- T.pType - pTok KBraceKet - return (eff', clo') - - , do return (T.tBot T.kEffect, T.tBot T.kClosure) ] - - - return $ [ParamValue (T.makeBindFromBinder b t) eff clo] - ] - - --- | Specification of a function parameter. --- We can determine the contribution to the type of the function, --- as well as its expression based on the parameter. -data ParamSpec n - = ParamType (Bind n) - | ParamWitness (Bind n) - | ParamValue (Bind n) (Type n) (Type n) - + ( Parser + , Context (..) + , contextOfProfile --- | Build the type of a function from specifications of its parameters, --- and the type of the body. -funTypeOfParams - :: [ParamSpec n] -- ^ Spec of parameters. - -> Type n -- ^ Type of body. - -> Type n -- ^ Type of whole function. + -- * Types + , pType + , pTypeApp + , pTypeAtom -funTypeOfParams [] tBody = tBody -funTypeOfParams (p:ps) tBody - = case p of - ParamType b - -> TForall b - $ funTypeOfParams ps tBody + -- * Modules + , pModule + , pModuleName - ParamWitness b - -> T.tImpl (T.typeOfBind b) - $ funTypeOfParams ps tBody + -- * Expressions + , pExp + , pExpApp + , pExpAtom - ParamValue b eff clo - -> T.tFun (T.typeOfBind b) eff clo - $ funTypeOfParams ps tBody + -- * Function Parameters + , ParamSpec(..) + , funTypeOfParams + , expOfParams + , pBindParamSpecAnnot + , pBindParamSpec + -- * Witnesses + , pWitness + , pWitnessApp + , pWitnessAtom --- | Build the expression of a function from specifications of its parameters, --- and the expression for the body. -expOfParams - :: a - -> [ParamSpec n] -- ^ Spec of parameters. - -> Exp a n -- ^ Body of function. - -> Exp a n -- ^ Expression of whole function. + -- * Constructors + , pCon, pConSP + , pLit, pLitSP -expOfParams _ [] xBody = xBody -expOfParams a (p:ps) xBody - = case p of - ParamType b - -> XLAM a b $ expOfParams a ps xBody + -- * Variables + , pIndex, pIndexSP + , pVar, pVarSP + , pBinder + , pName - ParamWitness b - -> XLam a b $ expOfParams a ps xBody - - ParamValue b _ _ - -> XLam a b $ expOfParams a ps xBody - - - --- Witnesses ------------------------------------------------------------------ --- | Parse a witness expression. -pWitness :: Ord n => Parser n (Witness n) -pWitness = pWitnessJoin - - --- Witness Joining -pWitnessJoin :: Ord n => Parser n (Witness n) -pWitnessJoin - -- WITNESS or WITNESS & WITNESS - = do w1 <- pWitnessApp - P.choice - [ do pTok KAmpersand - w2 <- pWitnessJoin - return (WJoin w1 w2) - - , do return w1 ] - - --- Applications -pWitnessApp :: Ord n => Parser n (Witness n) -pWitnessApp - = do (x:xs) <- P.many1 pWitnessArg - return $ foldl WApp x xs - - "a witness expression or application" - - --- Function argument -pWitnessArg :: Ord n => Parser n (Witness n) -pWitnessArg - = P.choice - [ -- [TYPE] - do pTok KSquareBra - t <- T.pType - pTok KSquareKet - return $ WType t - - -- WITNESS - , do pWitnessAtom ] - - --- Atomics -pWitnessAtom :: Ord n => Parser n (Witness n) -pWitnessAtom - = P.choice - -- (WITNESS) - [ do pTok KRoundBra - w <- pWitness - pTok KRoundKet - return $ w - - -- Named constructors - , do con <- pCon - return $ WCon (WiConBound $ UName con (T.tBot T.kWitness)) - - -- Baked-in witness constructors. - , do wb <- pWbCon - return $ WCon (WiConBuiltin wb) - - - -- Debruijn indices - , do i <- T.pIndex - return $ WVar (UIx i (T.tBot T.kWitness)) - - -- Variables - , do var <- pVar - return $ WVar (UName var (T.tBot T.kWitness)) ] - - "a witness" - - -------------------------------------------------------------------------------- --- | Parse a builtin named `WiCon` -pWbCon :: Parser n WbCon -pWbCon = P.pTokMaybe f - where f (KA (KWbConBuiltin wb)) = Just wb - f _ = Nothing - - --- | Parse a variable name -pVar :: Parser n n -pVar = P.pTokMaybe f - where f (KN (KVar n)) = Just n - f _ = Nothing - - --- | Parse a constructor name -pCon :: Parser n n -pCon = P.pTokMaybe f - where f (KN (KCon n)) = Just n - f _ = Nothing - + -- * Infix operators + , pOpSP + , pOpVarSP --- | Parse a literal -pLit :: Parser n n -pLit = P.pTokMaybe f - where f (KN (KLit n)) = Just n - f _ = Nothing + -- * Raw Tokens + , pSym, pKey + , pTok, pTokSP + , pTokAs) +where +import DDC.Core.Parser.Base +import DDC.Core.Parser.Context +import DDC.Core.Parser.Witness +import DDC.Core.Parser.Type +import DDC.Core.Parser.Exp +import DDC.Core.Parser.Module +import DDC.Core.Parser.Param diff --git a/DDC/Core/Parser/Base.hs b/DDC/Core/Parser/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Parser/Base.hs @@ -0,0 +1,186 @@ + +module DDC.Core.Parser.Base + ( Parser + , pModuleName + , pQualName + , pName + , pCon, pConSP + , pLit, pLitSP + , pIndex, pIndexSP + , pVar, pVarSP, pVarNamedSP + , pKey, pSym + , pTok, pTokSP + , pTokAs, pTokAsSP + , pOpSP + , pOpVarSP + , pPragmaSP) +where +import DDC.Data.Pretty +import DDC.Core.Module +import DDC.Core.Lexer.Tokens +import DDC.Control.Parser ((), SourcePos) +import Data.Text (Text) +import qualified DDC.Control.Parser as P + +-- | A parser of core language tokens. +type Parser n a + = P.Parser (Token n) a + + +-- | Parse a module name. +pModuleName :: Pretty n => Parser n ModuleName +pModuleName + = do ms <- P.sepBy1 pModuleName1 (pTok (KSymbol SDot)) + return $ ModuleName + $ concat + $ map (\(ModuleName ss) -> ss) ms + + +-- | Parse a single component module name. +pModuleName1 :: Pretty n => Parser n ModuleName +pModuleName1 = P.pTokMaybe f + where f (KN (KCon n)) = Just $ ModuleName [ renderPlain $ ppr n ] + + -- These names are lexed as constructors + -- but can be part of a module name. + f (KA (KBuiltin (BSoCon c))) = Just $ ModuleName [ renderPlain $ ppr c ] + f (KA (KBuiltin (BKiCon c))) = Just $ ModuleName [ renderPlain $ ppr c ] + f (KA (KBuiltin (BTwCon c))) = Just $ ModuleName [ renderPlain $ ppr c ] + f (KA (KBuiltin (BTcCon c))) = Just $ ModuleName [ renderPlain $ ppr c ] + f _ = Nothing + + +-- | Parse a qualified variable or constructor name. +pQualName :: Pretty n => Parser n (QualName n) +pQualName + = do mn <- pModuleName + pTok (KSymbol SDot) + n <- pName + return $ QualName mn n + + +-- | Parse a constructor or variable name. +pName :: Parser n n +pName = P.choice [pCon, pVar] + + +-- | Parse a constructor name. +pCon :: Parser n n +pCon = P.pTokMaybe f + where f (KN (KCon n)) = Just n + f _ = Nothing + + +-- | Parse a constructor name. +pConSP :: Parser n (n, SourcePos) +pConSP = P.pTokMaybeSP f + where f (KN (KCon n)) = Just n + f _ = Nothing + + +-- | Parse a literal. +pLit :: Parser n (Literal, Bool) +pLit = P.pTokMaybe f + where f (KA (KLiteral l b)) = Just (l, b) + f _ = Nothing + + +-- | Parse a numeric literal, with source position. +pLitSP :: Parser n ((Literal, Bool), SourcePos) +pLitSP = P.pTokMaybeSP f + where f (KA (KLiteral l b)) = Just (l, b) + f _ = Nothing + + +-- | Parse a variable. +pVar :: Parser n n +pVar = P.pTokMaybe f + "a variable" + where f (KN (KVar n)) = Just n + f _ = Nothing + + +-- | Parse a variable, with source position. +pVarSP :: Parser n (n, SourcePos) +pVarSP = P.pTokMaybeSP f + "a variable" + where f (KN (KVar n)) = Just n + f _ = Nothing + + +-- | Parse a variable of a specific name, with its source position. +pVarNamedSP :: String -> Parser String SourcePos +pVarNamedSP str + = fmap snd (P.pTokMaybeSP f "a variable") + where f (KN (KVar n)) | n == str = Just n + f _ = Nothing + + +-- | Parse a deBruijn index. +pIndex :: Parser n Int +pIndex = P.pTokMaybe f + "an index" + where f (KA (KIndex i)) = Just i + f _ = Nothing + + +-- | Parse a deBruijn index, with source position. +pIndexSP :: Parser n (Int, SourcePos) +pIndexSP = P.pTokMaybeSP f + "an index" + where f (KA (KIndex i)) = Just i + f _ = Nothing + + +-- | Parse an infix operator. +pOpSP :: Parser n (String, SourcePos) +pOpSP = P.pTokMaybeSP f + where f (KA (KOp str)) = Just str + f _ = Nothing + + +-- | Parse an infix operator used as a variable. +pOpVarSP :: Parser n (String, SourcePos) +pOpVarSP = P.pTokMaybeSP f + where f (KA (KOpVar str)) = Just str + f _ = Nothing + + +-- | Parse a pragma. +pPragmaSP :: Parser n (Text, SourcePos) +pPragmaSP = P.pTokMaybeSP f + where f (KA (KPragma txt)) = Just txt + f _ = Nothing + +------------------------------------------------------------------------------- +-- | Parse a `Symbol`. +pSym :: Symbol -> Parser n SourcePos +pSym ss = P.pTokSP (KA (KSymbol ss)) + + +-- | Parse a `Keyword`. +pKey :: Keyword -> Parser n SourcePos +pKey kw = P.pTokSP (KA (KKeyword kw)) + + +------------------------------------------------------------------------------- +-- | Parse an atomic token. +pTok :: TokenAtom -> Parser n () +pTok k = P.pTok (KA k) + + +-- | Parse an atomic token, yielding its source position. +pTokSP :: TokenAtom -> Parser n SourcePos +pTokSP k = P.pTokSP (KA k) + + +-- | Parse an atomic token and return some value. +pTokAs :: TokenAtom -> a -> Parser n a +pTokAs k x = P.pTokAs (KA k) x + + +-- | Parse an atomic token and return source position and value. +pTokAsSP :: TokenAtom -> a -> Parser n (a, SourcePos) +pTokAsSP k x = P.pTokAsSP (KA k) x + + diff --git a/DDC/Core/Parser/Context.hs b/DDC/Core/Parser/Context.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Parser/Context.hs @@ -0,0 +1,48 @@ + +module DDC.Core.Parser.Context + ( Context (..) + , contextOfProfile) +where +import DDC.Core.Exp.Literal +import DDC.Core.Fragment +import DDC.Data.SourcePos + + +-- | Configuration and information from the context. +-- Used for context sensitive parsing. +data Context n + = Context + { contextTrackedEffects :: Bool + , contextTrackedClosures :: Bool + , contextFunctionalEffects :: Bool + , contextFunctionalClosures :: Bool + + -- | Check whether the given fragment includes literals of this sort, + -- and convert it to the appropriate primitive name. + , contextMakeLiteralName + :: Maybe (SourcePos -> Literal -> Bool -> Maybe n) } + + +-- | Slurp an initital `Context` from a language `Profile`. +contextOfProfile :: Profile n -> Context n +contextOfProfile profile + = Context + { contextTrackedEffects + = featuresTrackedEffects + $ profileFeatures profile + + , contextTrackedClosures + = featuresTrackedClosures + $ profileFeatures profile + + , contextFunctionalEffects + = featuresFunctionalEffects + $ profileFeatures profile + + , contextFunctionalClosures + = featuresFunctionalClosures + $ profileFeatures profile + + , contextMakeLiteralName + = profileMakeLiteralName profile + } 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 new file mode 100644 --- /dev/null +++ b/DDC/Core/Parser/Exp.hs @@ -0,0 +1,498 @@ + +-- | Core language parser. +module DDC.Core.Parser.Exp + ( pExp + , pExpApp + , pExpAtom, pExpAtomSP + , pLetsSP + , pType + , pTypeApp + , pTypeAtom) +where +import DDC.Core.Exp.Annot +import DDC.Core.Parser.Witness +import DDC.Core.Parser.Param +import DDC.Core.Parser.Type +import DDC.Core.Parser.Context +import DDC.Core.Parser.Base +import DDC.Core.Lexer.Tokens +import DDC.Control.Parser ((), SourcePos) +import qualified DDC.Control.Parser as P +import qualified DDC.Type.Exp.Simple as T +import Control.Monad.Except + + +-- Exp -------------------------------------------------------------------------------------------- +-- | Parse a core language expression. +pExp :: Ord n => Context n -> Parser n (Exp SourcePos n) +pExp c + = P.choice + -- Level-0 lambda abstractions + -- (λBIND.. . EXP) or (\BIND.. . EXP) + [ do sp <- P.choice [ pSym SLambda, pSym SBackSlash] + bs <- liftM concat $ P.many1 (pBinds c) + pSym SDot + xBody <- pExp c + return $ foldr (XLam sp) xBody bs + + -- Level-1 lambda abstractions. + -- (ΛBINDS.. . EXP) or (/\BIND.. . EXP) + , do sp <- P.choice [ pSym SBigLambda, pSym SBigLambdaSlash] + bs <- liftM concat $ P.many1 (pBinds c) + pSym SDot + xBody <- pExp c + return $ foldr (XLAM sp) xBody bs + + -- let expression + , do (lts, sp) <- pLetsSP c + pKey EIn + x2 <- pExp c + return $ XLet sp lts x2 + + -- do { STMTS } + -- Sugar for a let-expression. + , do pKey EDo + pSym SBraceBra + xx <- pStmts c + pSym SBraceKet + return $ xx + + -- case EXP of { ALTS } + , do sp <- pKey ECase + x <- pExp c + pKey EOf + pSym SBraceBra + alts <- P.sepEndBy1 (pAlt c) (pSym SSemiColon) + pSym SBraceKet + return $ XCase sp x alts + + -- letcase PAT = EXP in EXP + , do -- Sugar for a single-alternative case expression. + sp <- pKey ELetCase + p <- pPat c + pSym SEquals + x1 <- pExp c + pKey EIn + x2 <- pExp c + return $ XCase sp x1 [AAlt p x2] + + -- weakeff [TYPE] in EXP + , do sp <- pKey EWeakEff + pSym SSquareBra + t <- pType c + pSym SSquareKet + pKey EIn + x <- pExp c + return $ XCast sp (CastWeakenEffect t) x + + -- purify WITNESS in EXP + , do sp <- pKey EPurify + w <- pWitness c + pTok (KKeyword EIn) + x <- pExp c + return $ XCast sp (CastPurify w) x + + -- box EXP + , do sp <- pKey EBox + x <- pExp c + return $ XCast sp CastBox x + + -- run EXP + , do sp <- pKey ERun + x <- pExp c + return $ XCast sp CastRun x + + -- APP + , do pExpApp c + ] + + "an expression" + + +-- | Parse a function application. +pExpApp :: Ord n => Context n -> Parser n (Exp SourcePos n) +pExpApp c + = do (x1, _) <- pExpAtomSP c + + P.choice + [ do xs <- liftM concat $ P.many1 (pArgSPs c) + return $ foldl (\x (x', sp) -> XApp sp x x') x1 xs + + , return x1] + + "an expression or application" + + +-- Comp, Witness or Spec arguments. +pArgSPs :: Ord n => Context n -> Parser n [(Exp SourcePos n, SourcePos)] +pArgSPs c + = P.choice + -- [TYPE] + [ do sp <- pSym SSquareBra + t <- pType c + pSym SSquareKet + return [(XType sp t, sp)] + + -- [: TYPE0 TYPE0 ... :] + , do sp <- pSym SSquareColonBra + ts <- P.many1 (pTypeAtom c) + pSym SSquareColonKet + return [(XType sp t, sp) | t <- ts] + + -- {WITNESS} + , do sp <- pSym SBraceBra + w <- pWitness c + pSym SBraceKet + return [(XWitness sp w, sp)] + + -- {: WITNESS0 WITNESS0 ... :} + , do sp <- pSym SBraceColonBra + ws <- P.many1 (pWitnessAtom c) + pSym SBraceColonKet + return [(XWitness sp w, sp) | w <- ws] + + -- EXP0 + , do (x, sp) <- pExpAtomSP c + return [(x, sp)] + ] + "a type, witness or expression argument" + + +-- | Parse a variable, constructor or parenthesised expression. +pExpAtom :: Ord n => Context n -> Parser n (Exp SourcePos n) +pExpAtom c + = do (x, _) <- pExpAtomSP c + return x + + +-- | Parse a variable, constructor or parenthesised expression, +-- also returning source position. +pExpAtomSP + :: Ord n + => Context n + -> Parser n (Exp SourcePos n, SourcePos) + +pExpAtomSP c + = P.choice + -- (EXP2) + [ do sp <- pSym SRoundBra + t <- pExp c + pSym SRoundKet + return (t, sp) + + -- The unit data constructor. + , do sp <- pTokSP (KBuiltin BDaConUnit) + return (XCon sp dcUnit, sp) + + -- Named algebraic constructors. + , do (con, sp) <- pConSP + return (XCon sp (DaConBound con), sp) + + -- Literals. + -- The attached type is set to Bottom for now, which needs + -- to be filled in later by the Spread transform. + , do ((lit, bPrim), sp) <- pLitSP + let Just mkLit = contextMakeLiteralName c + case mkLit sp lit bPrim of + Just name -> return (XCon sp (DaConPrim name (T.tBot T.kData)), sp) + Nothing -> P.unexpected "literal" + + -- Debruijn indices + , do (i, sp) <- pIndexSP + return (XVar sp (UIx i), sp) + + -- Variables + , do (var, sp) <- pVarSP + return (XVar sp (UName var), sp) + ] + + "a variable, constructor, or parenthesised type" + + +-- Alt -------------------------------------------------------------------------------------------- +-- Case alternatives. +pAlt :: Ord n => Context n -> Parser n (Alt SourcePos n) +pAlt c + = do p <- pPat c + pSym SArrowDashRight + x <- pExp c + return $ AAlt p x + + +-- Patterns. +pPat :: Ord n + => Context n -> Parser n (Pat n) +pPat c + = P.choice + [ -- Wildcard Pattern: _ + do pSym SUnderscore + return $ PDefault + + -- LIT + , do -- The attached type is set to Bottom for now, which needs + -- to be filled in later by the Spread transform. + ((lit, bPrim), sp) <- pLitSP + let Just mkLit = contextMakeLiteralName c + case mkLit sp lit bPrim of + Just nLit -> return $ PData (DaConPrim nLit (T.tBot T.kData)) [] + _ -> P.unexpected "literal" + + -- Unit + , do pTok (KBuiltin BDaConUnit) + return $ PData dcUnit [] + + -- CON BIND BIND ... + , do nCon <- pCon + bs <- liftM concat $ P.many (pBinds c) + return $ PData (DaConBound nCon) bs] + + +-- Binds in patterns can have no type annotation, +-- or can have an annotation if the whole thing is in parens. +pBinds + :: Ord n + => Context n -> Parser n [Bind n] +pBinds c + = P.choice + -- Plain binder. + [ do bs <- P.many1 pBinder + return [T.makeBindFromBinder b (T.tBot T.kData) | b <- bs] + + -- Binder with type, wrapped in parens. + , do pSym SRoundBra + bs <- P.many1 pBinder + pTok (KOp ":") + t <- pType c + pSym SRoundKet + return [T.makeBindFromBinder b t | b <- bs] + ] + + +-- Bindings --------------------------------------------------------------------------------------- +-- | Parse some `Lets`, also returning the source position where they +-- started. +pLetsSP :: Ord n + => Context n -> Parser n (Lets SourcePos n, SourcePos) +pLetsSP c + = P.choice + [ -- non-recursive let. + do sp <- pTokSP (KKeyword ELet) + (b1, x1) <- pLetBinding c + return (LLet b1 x1, sp) + + -- recursive let. + , do sp <- pTokSP (KKeyword ELetRec) + P.choice + -- Multiple bindings in braces + [ do pSym SBraceBra + lets <- P.sepEndBy1 (pLetBinding c) (pSym SSemiColon) + pSym SBraceKet + return (LRec lets, sp) + + -- A single binding without braces. + , do ll <- pLetBinding c + return (LRec [ll], sp) + ] + + -- Private region binding. + -- private BINDER+ (with { BINDER : TYPE ... })? in EXP + , do sp <- pTokSP (KKeyword EPrivate) + + -- new private region names. + brs <- P.manyTill pBinder + $ P.try $ P.lookAhead $ P.choice + [ pTok (KKeyword EIn) + , pTok (KKeyword EWith) ] + + let bs = map (flip T.makeBindFromBinder T.kRegion) brs + + -- witness types. + r <- pLetWits c bs Nothing + return (r, sp) + + -- Extend an existing region. + -- extend BINDER+ using TYPE (with { BINDER : TYPE ...})? in EXP + , do sp <- pTokSP (KKeyword EExtend) + + -- parent region + t <- pType c + pTok (KKeyword EUsing) + + -- new private region names. + brs <- P.manyTill pBinder + $ P.try $ P.lookAhead + $ P.choice + [ pTok (KKeyword EUsing) + , pTok (KKeyword EWith) + , pTok (KKeyword EIn) ] + + let bs = map (flip T.makeBindFromBinder T.kRegion) brs + + -- witness types + r <- pLetWits c bs (Just t) + return (r, sp) + ] + + +pLetWits :: Ord n + => Context n + -> [Bind n] -> Maybe (Type n) + -> Parser n (Lets SourcePos n) + +pLetWits c bs mParent + = P.choice + [ do pKey EWith + pSym SBraceBra + wits <- P.sepBy (P.choice + [ -- Named witness binder. + do b <- pBinder + pTok (KOp ":") + t <- pTypeApp c + return $ T.makeBindFromBinder b t + + -- Ambient witness binding, use for capabilities. + , do t <- pTypeApp c + return $ BNone t ]) + (pSym SSemiColon) + pSym SBraceKet + return (LPrivate bs mParent wits) + + , do return (LPrivate bs mParent []) + ] + + +-- | A binding for let expression. +pLetBinding + :: Ord n + => Context n + -> Parser n ( Bind n + , Exp SourcePos n) +pLetBinding c + = do b <- pBinder + + P.choice + [ do -- Binding with full type signature. + -- BINDER : TYPE = EXP + pTok (KOp ":") + t <- pType c + pSym SEquals + xBody <- pExp c + + return $ (T.makeBindFromBinder b t, xBody) + + + , do -- Non-function binding with no type signature. + -- This form can't be used with letrec as we can't use it + -- to build the full type sig for the let-bound variable. + -- BINDER = EXP + pSym SEquals + xBody <- pExp c + let t = T.tBot T.kData + return $ (T.makeBindFromBinder b t, xBody) + + + , do -- Binding using function syntax. + ps <- liftM concat + $ P.many (pBindParamSpec c) + + P.choice + [ do -- Function syntax with a return type. + -- We can make the full type sig for the let-bound + -- variable. + -- BINDER PARAM1 PARAM2 .. PARAMN : TYPE = EXP + pTok (KOp ":") + tBody <- pType c + sp <- pSym SEquals + xBody <- pExp c + + let x = expOfParams sp ps xBody + let t = funTypeOfParams c ps tBody + return (T.makeBindFromBinder b t, x) + + -- Function syntax with no return type. + -- We can't make the type sig for the let-bound variable, + -- but we can create lambda abstractions with the given + -- parameter types. + -- BINDER PARAM1 PARAM2 .. PARAMN = EXP + , do sp <- pSym SEquals + xBody <- pExp c + + let x = expOfParams sp ps xBody + let t = T.tBot T.kData + return (T.makeBindFromBinder b t, x) ] + ] + + +-- Stmt ------------------------------------------------------------------------------------------- +data Stmt n + = StmtBind SourcePos (Bind n) (Exp SourcePos n) + | StmtMatch SourcePos (Pat n) (Exp SourcePos n) (Exp SourcePos n) + | StmtNone SourcePos (Exp SourcePos n) + + +-- | Parse a single statement. +pStmt :: Ord n => Context n -> Parser n (Stmt n) +pStmt c + = P.choice + [ -- BINDER = EXP ; + -- We need the 'try' because a VARIABLE binders can also be parsed + -- as a function name in a non-binding statement. + -- + P.try $ + do br <- pBinder + sp <- pSym SEquals + x1 <- pExp c + let t = T.tBot T.kData + let b = T.makeBindFromBinder br t + return $ StmtBind sp b x1 + + -- PAT <- EXP else EXP; + -- Sugar for a case-expression. + -- We need the 'try' because the PAT can also be parsed + -- as a function name in a non-binding statement. + , P.try $ + do p <- pPat c + sp <- pSym SArrowDashLeft + x1 <- pExp c + pTok (KKeyword EElse) + x2 <- pExp c + return $ StmtMatch sp p x1 x2 + + -- EXP + , do x <- pExp c + return $ StmtNone (annotOfExp x) x + ] + + +-- | Parse some statements. +pStmts :: Ord n => Context n -> Parser n (Exp SourcePos n) +pStmts c + = do stmts <- P.sepEndBy1 (pStmt c) (pSym SSemiColon) + case makeStmts stmts of + Nothing -> P.unexpected "do-block must end with a statement" + Just x -> return x + + +-- | Make an expression from some statements. +makeStmts :: [Stmt n] -> Maybe (Exp SourcePos n) +makeStmts ss + = case ss of + [StmtNone _ x] + -> Just x + + StmtNone sp x1 : rest + | Just x2 <- makeStmts rest + -> Just $ XLet sp (LLet (BNone (T.tBot T.kData)) x1) x2 + + StmtBind sp b x1 : rest + | Just x2 <- makeStmts rest + -> Just $ XLet sp (LLet b x1) x2 + + StmtMatch sp p x1 x2 : rest + | Just x3 <- makeStmts rest + -> Just $ XCase sp x1 + [ AAlt p x3 + , AAlt PDefault x2] + + _ -> Nothing + 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/Lexer.hs b/DDC/Core/Parser/Lexer.hs deleted file mode 100644 --- a/DDC/Core/Parser/Lexer.hs +++ /dev/null @@ -1,293 +0,0 @@ - --- | Reference lexer for core langauge parser. Slow but Simple. -module DDC.Core.Parser.Lexer - ( -- * Constructors - isConName, isConStart, isConBody - , readTwConBuiltin - , readTcConBuiltin - , readWbConBuiltin - , readCon - - -- * Variables - , isVarName, isVarStart, isVarBody - , readVar - - -- * Lexer - , lexExp) -where -import DDC.Base.Lexer -import DDC.Core.Exp -import DDC.Core.Parser.Tokens -import Data.Char - - --- WbCon names ---------------------------------------------------------------- --- | Read a `WbCon`. -readWbConBuiltin :: String -> Maybe WbCon -readWbConBuiltin ss - = case ss of - "pure" -> Just WbConPure - "empty" -> Just WbConEmpty - "use" -> Just WbConUse - "read" -> Just WbConRead - "alloc" -> Just WbConAlloc - _ -> Nothing - - --- | Textual keywords in the core language. -keywords :: [(String, Tok n)] -keywords - = [ ("in", KA KIn) - , ("of", KA KOf) - , ("letrec", KA KLetRec) - , ("letregion", KA KLetRegion) - , ("withregion", KA KWithRegion) - , ("let", KA KLet) - , ("lazy", KA KLazy) - , ("case", KA KCase) - , ("purify", KA KPurify) - , ("forget", KA KForget) - , ("weakeff", KA KWeakEff) - , ("weakclo", KA KWeakClo) - , ("with", KA KWith) - , ("where", KA KWhere) ] - - -------------------------------------------------------------------------------- --- | Lex a string into tokens. --- -lexExp :: Int -> String -> [Token (Tok String)] -lexExp lineStart str - = lexWord lineStart 1 str - where - - lexWord :: Int -> Int -> String -> [Token (Tok String)] - lexWord line column w - = let tok t = Token t (SourcePos Nothing line column) - tokA = tok . KA - tokN = tok . KN - - lexMore n rest - = lexWord line (column + n) rest - - in case w of - [] -> [] - - ' ' : w' -> lexMore 1 w' - '\t' : w' -> lexMore 8 w' - '\n' : w' -> lexWord (line + 1) 1 w' - - - -- The unit data constructor - '(' : ')' : w' -> tokN (KCon "()") : lexMore 2 w' - - -- Compound Parens - '[' : ':' : w' -> tokA KSquareColonBra : lexMore 2 w' - ':' : ']' : w' -> tokA KSquareColonKet : lexMore 2 w' - '<' : ':' : w' -> tokA KAngleColonBra : lexMore 2 w' - ':' : '>' : w' -> tokA KAngleColonKet : lexMore 2 w' - - -- Function Constructors - '~' : '>' : w' -> tokA KArrowTilde : lexMore 2 w' - '-' : '>' : w' -> tokA KArrowDash : lexMore 2 w' - '=' : '>' : w' -> tokA KArrowEquals : lexMore 2 w' - - -- Compound symbols - ':' : ':' : w' -> tokA KColonColon : lexMore 2 w' - '/' : '\\' : w' -> tokA KBigLambda : lexMore 2 w' - - -- Debruijn indices - '^' : cs - | (ds, rest) <- span isDigit cs - , length ds >= 1 - -> tokA (KIndex (read ds)) : lexMore (1 + length ds) rest - - -- Parens - '(' : w' -> tokA KRoundBra : lexMore 1 w' - ')' : w' -> tokA KRoundKet : lexMore 1 w' - '[' : w' -> tokA KSquareBra : lexMore 1 w' - ']' : w' -> tokA KSquareKet : lexMore 1 w' - '{' : w' -> tokA KBraceBra : lexMore 1 w' - '}' : w' -> tokA KBraceKet : lexMore 1 w' - '<' : w' -> tokA KAngleBra : lexMore 1 w' - '>' : w' -> tokA KAngleKet : lexMore 1 w' - - -- Punctuation - '.' : w' -> tokA KDot : lexMore 1 w' - '|' : w' -> tokA KBar : lexMore 1 w' - '^' : w' -> tokA KHat : lexMore 1 w' - '+' : w' -> tokA KPlus : lexMore 1 w' - ':' : w' -> tokA KColon : lexMore 1 w' - ',' : w' -> tokA KComma : lexMore 1 w' - '\\' : w' -> tokA KBackSlash : lexMore 1 w' - ';' : w' -> tokA KSemiColon : lexMore 1 w' - '_' : w' -> tokA KUnderscore : lexMore 1 w' - '=' : w' -> tokA KEquals : lexMore 1 w' - '&' : w' -> tokA KAmpersand : lexMore 1 w' - '-' : w' -> tokA KDash : lexMore 1 w' - - -- Bottoms - '!' : '0' : w' -> tokA KBotEffect : lexMore 2 w' - '$' : '0' : w' -> tokA KBotClosure : lexMore 2 w' - - -- Sort Constructors - '*' : '*' : w' -> tokA KSortComp : lexMore 2 w' - '@' : '@' : w' -> tokA KSortProp : lexMore 2 w' - - -- Kind Constructors - '*' : w' -> tokA KKindValue : lexMore 1 w' - '%' : w' -> tokA KKindRegion : lexMore 1 w' - '!' : w' -> tokA KKindEffect : lexMore 1 w' - '$' : w' -> tokA KKindClosure : lexMore 1 w' - '@' : w' -> tokA KKindWitness : lexMore 1 w' - - -- Literal values - c : cs - | isDigit c - , (body, rest) <- span isDigit cs - -> tokN (KLit (c:body)) : lexMore (length (c:body)) rest - - -- Named Constructors - c : cs - | isConStart c - , (body, rest) <- span isConBody cs - , (body', rest') <- case rest of - '#' : rest' -> (body ++ "#", rest') - _ -> (body, rest) - -> let readNamedCon s - | Just twcon <- readTwConBuiltin s - = tokA (KTwConBuiltin twcon) : lexMore (length s) rest' - - | Just tccon <- readTcConBuiltin s - = tokA (KTcConBuiltin tccon) : lexMore (length s) rest' - - | Just con <- readCon s - = tokN (KCon con) : lexMore (length s) rest' - - | otherwise - = [tok (KJunk c)] - - in readNamedCon (c : body') - - -- Keywords, Named Variables and Witness constructors - c : cs - | isVarStart c - , (body, rest) <- span isVarBody cs - -> let readNamedVar s - | Just t <- lookup s keywords - = tok t : lexMore (length s) rest - - | Just wc <- readWbConBuiltin s - = tokA (KWbConBuiltin wc) : lexMore (length s) rest - - | Just v <- readVar s - = tokN (KVar v) : lexMore (length s) rest - - | otherwise - = [tok (KJunk c)] - - in readNamedVar (c : body) - - -- Error - c : _ -> [tok $ KJunk c] - - --- TyCon names ---------------------------------------------------------------- --- | String is a constructor name. -isConName :: String -> Bool -isConName str - = case str of - [] -> False - (c:cs) - | isConStart c - , and (map isConBody cs) - -> True - - | _ : _ <- cs - , isConStart c - , and (map isConBody (init cs)) - , last cs == '#' - -> True - - | otherwise - -> False - --- | Character can start a constructor name. -isConStart :: Char -> Bool -isConStart = isUpper - - --- | Charater can be part of a constructor body. -isConBody :: Char -> Bool -isConBody c = isUpper c || isLower c || isDigit c || c == '_' - - --- | Read a named `TwCon`. -readTwConBuiltin :: String -> Maybe TwCon -readTwConBuiltin ss - = case ss of - "Global" -> Just TwConGlobal - "DeepGlobal" -> Just TwConDeepGlobal - "Const" -> Just TwConConst - "DeepConst" -> Just TwConDeepConst - "Mutable" -> Just TwConMutable - "DeepMutable" -> Just TwConDeepMutable - "Lazy" -> Just TwConLazy - "HeadLazy" -> Just TwConHeadLazy - "Manifest" -> Just TwConManifest - "Pure" -> Just TwConPure - "Empty" -> Just TwConEmpty - _ -> Nothing - - --- | Read a builtin `TcCon` with a non-symbolic name, --- ie not '->'. -readTcConBuiltin :: String -> Maybe TcCon -readTcConBuiltin ss - = case ss of - "Read" -> Just TcConRead - "HeadRead" -> Just TcConHeadRead - "DeepRead" -> Just TcConDeepRead - "Write" -> Just TcConWrite - "DeepWrite" -> Just TcConDeepWrite - "Alloc" -> Just TcConAlloc - "DeepAlloc" -> Just TcConDeepAlloc - "Use" -> Just TcConUse - "DeepUse" -> Just TcConDeepUse - _ -> Nothing - - --- | Read a named, user defined `TcCon`. --- --- We won't know its kind, so fill this in with the Bottom element for --- computatation kinds (**0). -readCon :: String -> Maybe String -readCon ss - | isConName ss = Just ss - | otherwise = Nothing - - --- TyVar names ---------------------------------------------------------------- --- | String is a variable name. -isVarName :: String -> Bool -isVarName [] = False -isVarName (c:cs) = isVarStart c && (and $ map isVarBody cs) - - --- | Charater can start a variable name. -isVarStart :: Char -> Bool -isVarStart = isLower - - --- | Character can be part of a variable body. -isVarBody :: Char -> Bool -isVarBody c - = isUpper c || isLower c || isDigit c || c == '_' || c == '\'' - - --- | Read a named, user defined variable. -readVar :: String -> Maybe String -readVar ss - | isVarName ss = Just ss - | otherwise = Nothing - diff --git a/DDC/Core/Parser/Module.hs b/DDC/Core/Parser/Module.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Parser/Module.hs @@ -0,0 +1,157 @@ +{-# OPTIONS -fno-warn-unused-binds #-} +module DDC.Core.Parser.Module + (pModule) +where +import DDC.Core.Parser.Type +import DDC.Core.Parser.Exp +import DDC.Core.Parser.Context +import DDC.Core.Parser.Base +import DDC.Core.Parser.ExportSpec +import DDC.Core.Parser.ImportSpec +import DDC.Core.Parser.DataDef +import DDC.Core.Module +import DDC.Core.Lexer.Tokens +import DDC.Core.Exp.Annot +import DDC.Data.Pretty +import Data.Char +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified DDC.Control.Parser as P + + +-- | Parse a core module. +pModule :: (Ord n, Pretty n) + => Context n + -> Parser n (Module P.SourcePos n) +pModule c + = do sp <- pTokSP (KKeyword EModule) + name <- pModuleName + + -- Parse header declarations + heads <- P.many (pHeadDecl c) + let importSpecs_noArity = concat $ [specs | HeadImportSpecs specs <- heads ] + let exportSpecs = concat $ [specs | HeadExportSpecs specs <- heads ] + + let dataDefsLocal = [def | HeadDataDef def <- heads ] + let typeDefsLocal = [(n, (k, t)) | HeadTypeDef n k t <- heads ] + + -- Attach arity information to import specs. + -- The aritity information itself comes in the ARITY pragmas, + -- which are parsed as separate top level things. + let importArities + = Map.fromList [ (n, (iTypes, iValues, iBoxes )) + | HeadPragmaArity n iTypes iValues iBoxes <- heads ] + + let attachAritySpec (ImportForeignValue n (ImportValueModule mn v t _)) + = ImportForeignValue n (ImportValueModule mn v t (Map.lookup n importArities)) + + attachAritySpec spec = spec + + let importSpecs + = map attachAritySpec importSpecs_noArity + + + -- Parse function definitions. + -- If there is a 'with' keyword then this is a standard module with bindings. + -- If not, then it is a module header, which doesn't need bindings. + (lts, isHeader) + <- P.choice + [ do pTok (KKeyword EWith) + + -- LET;+ + lts <- P.sepBy1 (pLetsSP c) (pTok (KKeyword EIn)) + return (lts, False) + + , do return ([], True) ] + + -- The body of the module consists of the top-level bindings wrapped + -- around a unit constructor place-holder. + let body = xLetsAnnot lts (xUnit sp) + + return $ ModuleCore + { moduleName = name + , moduleIsHeader = isHeader + , moduleExportTypes = [] + , moduleExportValues = [(n, s) | ExportValue n s <- exportSpecs] + , moduleImportTypes = [(n, s) | ImportForeignType n s <- importSpecs] + , moduleImportCaps = [(n, s) | ImportForeignCap n s <- importSpecs] + , moduleImportValues = [(n, s) | ImportForeignValue n s <- importSpecs] + , moduleImportTypeDefs = [(n, (k, t)) | ImportType n k t <- importSpecs] + , moduleImportDataDefs = [def | ImportData def <- importSpecs] + , moduleDataDefsLocal = dataDefsLocal + , moduleTypeDefsLocal = typeDefsLocal + , moduleBody = body } + + +--------------------------------------------------------------------------------------------------- +-- | Wrapper for a declaration that can appear in the module header. +data HeadDecl n + -- | Import specifications. + = HeadImportSpecs [ImportSpec n] + + -- | Export specifications. + | HeadExportSpecs [ExportSpec n] + + -- | Data type definitions. + | HeadDataDef (DataDef n) + + -- | Type equations. + | HeadTypeDef n (Kind n) (Type n) + + -- | Arity pragmas. + -- Number of type parameters, value parameters, and boxes for some super. + | HeadPragmaArity n Int Int Int + + +-- | Parse one of the declarations that can appear in a module header. +pHeadDecl :: (Ord n, Pretty n) + => Context n -> Parser n (HeadDecl n) + +pHeadDecl ctx + = P.choice + [ do imports <- pImportSpecs ctx + return $ HeadImportSpecs imports + + , do exports <- pExportSpecs ctx + return $ HeadExportSpecs exports + + , do def <- pDataDef ctx + return $ HeadDataDef def + + , do (n, k, t) <- pTypeDef ctx + return $ HeadTypeDef n k t + + , do pHeadPragma ctx + ] + + +-- | Parse a type equation. +pTypeDef :: Ord n => Context n -> Parser n (n, Kind n, Type n) +pTypeDef c + = do pKey EType + n <- pName + pTokSP (KOp ":") + k <- pType c + pSym SEquals + t <- pType c + pSym SSemiColon + return (n, k, t) + + +-- | Parse one of the pragmas that can appear in the module header. +pHeadPragma :: Context n -> Parser n (HeadDecl n) +pHeadPragma ctx + = do (txt, sp) <- pPragmaSP + case words $ T.unpack txt of + + -- The type and value arity of a super. + ["ARITY", name, strTypes, strValues, strBoxes] + | all isDigit strTypes + , all isDigit strValues + , all isDigit strBoxes + , Just makeLitName <- contextMakeLiteralName ctx + , Just n <- makeLitName sp (LString (T.pack name)) True + -> return $ HeadPragmaArity n + (read strTypes) (read strValues) (read strBoxes) + + _ -> P.unexpected $ "pragma " ++ "{-# " ++ T.unpack txt ++ "#-}" diff --git a/DDC/Core/Parser/Param.hs b/DDC/Core/Parser/Param.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Parser/Param.hs @@ -0,0 +1,152 @@ + +module DDC.Core.Parser.Param + ( ParamSpec (..) + , funTypeOfParams + , expOfParams + , pBindParamSpecAnnot + , pBindParamSpec ) +where +import DDC.Core.Exp +import DDC.Core.Parser.Type +import DDC.Core.Parser.Context +import DDC.Core.Parser.Base +import DDC.Core.Lexer.Tokens +import qualified DDC.Type.Exp.Simple as T +import qualified DDC.Control.Parser as P + + +-- | Specification of a function parameter. +-- We can determine the contribution to the type of the function, +-- as well as its expression based on the parameter. +data ParamSpec n + = ParamType (Bind n) + | ParamWitness (Bind n) + | ParamValue (Bind n) (Type n) (Type n) + + +-- | Build the expression of a function from specifications of its parameters, +-- and the expression for the body. +expOfParams + :: a + -> [ParamSpec n] -- ^ Spec of parameters. + -> Exp a n -- ^ Body of function. + -> Exp a n -- ^ Expression of whole function. + +expOfParams _ [] xBody = xBody +expOfParams a (p:ps) xBody + = case p of + ParamType b + -> XLAM a b $ expOfParams a ps xBody + + ParamWitness b + -> XLam a b $ expOfParams a ps xBody + + ParamValue b _ _ + -> XLam a b $ expOfParams a ps xBody + + +-- | Build the type of a function from specifications of its parameters, +-- and the type of the body. +funTypeOfParams + :: Context n + -> [ParamSpec n] -- ^ Spec of parameters. + -> Type n -- ^ Type of body. + -> Type n -- ^ Type of whole function. + +funTypeOfParams _ [] tBody + = tBody + +funTypeOfParams c (p:ps) tBody + = case p of + ParamType b + -> TForall b + $ funTypeOfParams c ps tBody + + ParamWitness b + -> T.tImpl (T.typeOfBind b) + $ funTypeOfParams c ps tBody + + ParamValue b _eff _clo + -> T.tFun (T.typeOfBind b) + $ funTypeOfParams c ps tBody + + +-- | Parse a function parameter specification, +-- with an optional type (or kind) annotation. +pBindParamSpec + :: Ord n + => Context n -> Parser n [ParamSpec n] + +pBindParamSpec c + = P.choice + [ -- Value (or type) binder with a type (or kind) annotation. + pBindParamSpecAnnot c + + -- Value binder without type annotations. + , do b <- pBinder + return $ [ ParamValue (T.makeBindFromBinder b (T.tBot T.kData)) + (T.tBot T.kEffect) (T.tBot T.kClosure) ] + ] + + +-- | Parse a function parameter specification, +-- requiring a full type (or kind) annotation. +--- +-- [BIND1 BIND2 .. BINDN : TYPE] +-- or (BIND : TYPE) +-- or (BIND : TYPE) { EFFECT | CLOSURE } +-- +pBindParamSpecAnnot + :: Ord n + => Context n -> Parser n [ParamSpec n] + +pBindParamSpecAnnot c + = P.choice + -- Type parameter + -- [BIND1 BIND2 .. BINDN : TYPE] + [ do pSym SSquareBra + bs <- P.many1 pBinder + pTok (KOp ":") + t <- pType c + pSym SSquareKet + return [ ParamType b + | b <- zipWith T.makeBindFromBinder bs (repeat t)] + + -- Witness parameter + -- {BIND : TYPE} + , do pSym SBraceBra + b <- pBinder + pTok (KOp ":") + t <- pType c + pSym SBraceKet + return [ ParamWitness $ T.makeBindFromBinder b t] + + -- Value parameter with type annotations. + -- (BIND1 BIND2 .. BINDN : TYPE) + -- (BIND1 BIND2 .. BINDN : TYPE) { TYPE | TYPE } + , do pSym SRoundBra + bs <- P.many1 pBinder + pTok (KOp ":") + t <- pType c + pSym SRoundKet + + (eff, clo) + <- P.choice + [ do pSym SBraceBra + eff' <- pType c + pSym SBar + clo' <- pType c + pSym SBraceKet + return (eff', clo') + + , do return (T.tBot T.kEffect, T.tBot T.kClosure) ] + + let bLast : bsInit + = reverse bs + + return $ [ ParamValue (T.makeBindFromBinder b t) + (T.tBot T.kEffect) (T.tBot T.kClosure) + | b <- reverse bsInit] + ++ [ ParamValue (T.makeBindFromBinder bLast t) eff clo] + ] + diff --git a/DDC/Core/Parser/Tokens.hs b/DDC/Core/Parser/Tokens.hs deleted file mode 100644 --- a/DDC/Core/Parser/Tokens.hs +++ /dev/null @@ -1,263 +0,0 @@ - -module DDC.Core.Parser.Tokens - ( Tok (..) - , describeTok - , renameTok - - , TokAtom (..) - , describeTokAtom - - , TokNamed (..) - , describeTokNamed) -where -import DDC.Core.Pretty -import DDC.Core.Exp - - --- TokenFamily ---------------------------------------------------------------- --- | The family of a token. --- This is used to help generate parser error messages, --- so we can say ''the constructor Cons'' --- and ''the keyword case'' etc. -data TokenFamily - = Symbol - | Keyword - | Constructor - | Index - | Variable - - --- | Describe a token family, for parser error messages. -describeTokenFamily :: TokenFamily -> String -describeTokenFamily tf - = case tf of - Symbol -> "symbol" - Keyword -> "keyword" - Constructor -> "constructor" - Index -> "index" - Variable -> "variable" - - --- Tok ------------------------------------------------------------------------ --- | Tokens accepted by the core language parser. -data Tok n - -- Some junk symbol that isn't part of the language. - = KJunk Char - - -- An atomic token. - | KA !TokAtom - - -- A named token. - | KN !(TokNamed n) - deriving (Eq, Show) - - --- | Describe a token for parser error messages. -describeTok :: Pretty n => Tok n -> String -describeTok kk - = case kk of - KJunk c -> "character " ++ show c - KA ta -> describeTokAtom ta - KN tn -> describeTokNamed tn - - --- | Apply a function to all the names in a `Tok`. -renameTok - :: Ord n2 - => (n1 -> n2) -> Tok n1 -> Tok n2 - -renameTok f kk - = case kk of - KJunk s -> KJunk s - KA t -> KA t - KN t -> KN $ renameTokNamed f t - - --- TokAtom -------------------------------------------------------------------- --- | Atomic tokens, that don't contain user-defined names. -data TokAtom - -- parens - = KRoundBra - | KRoundKet - | KSquareBra - | KSquareKet - | KBraceBra - | KBraceKet - | KAngleBra - | KAngleKet - - -- compound parens - | KSquareColonBra - | KSquareColonKet - | KAngleColonBra - | KAngleColonKet - - -- punctuation - | KDot - | KBar - | KHat - | KPlus - | KColon - | KComma - | KBackSlash - | KSemiColon - | KUnderscore - | KEquals - | KAmpersand - | KDash - | KColonColon - | KBigLambda - - -- symbolic constructors - | KSortComp - | KSortProp - | KKindValue - | KKindRegion - | KKindEffect - | KKindClosure - | KKindWitness - | KArrowTilde - | KArrowDash - | KArrowEquals - - -- bottoms - | KBotEffect - | KBotClosure - - -- expression keywords - | KWith - | KWhere - | KIn - | KLet - | KLazy - | KLetRec - | KLetRegion - | KWithRegion - | KCase - | KOf - | KWeakEff - | KWeakClo - | KPurify - | KForget - - -- debruijn indices - | KIndex Int - - -- builtin names - | KTwConBuiltin TwCon - | KWbConBuiltin WbCon - | KTcConBuiltin TcCon - deriving (Eq, Show) - - --- | Describe a `TokAtom`, for parser error messages. -describeTokAtom :: TokAtom -> String -describeTokAtom ta - = let (family, str) = describeTokAtom' ta - in describeTokenFamily family ++ " " ++ show str - -describeTokAtom' :: TokAtom -> (TokenFamily, String) -describeTokAtom' ta - = case ta of - -- parens - KRoundBra -> (Symbol, "(") - KRoundKet -> (Symbol, ")") - KSquareBra -> (Symbol, "[") - KSquareKet -> (Symbol, "]") - KBraceBra -> (Symbol, "{") - KBraceKet -> (Symbol, "}") - KAngleBra -> (Symbol, "<") - KAngleKet -> (Symbol, ">") - - -- compound parens - KSquareColonBra -> (Symbol, "[:") - KSquareColonKet -> (Symbol, ":]") - KAngleColonBra -> (Symbol, "<:") - KAngleColonKet -> (Symbol, ":>") - - -- punctuation - KDot -> (Symbol, ".") - KBar -> (Symbol, "|") - KHat -> (Symbol, "^") - KPlus -> (Symbol, "+") - KColon -> (Symbol, ":") - KComma -> (Symbol, ",") - KBackSlash -> (Symbol, "\\") - KSemiColon -> (Symbol, ";") - KUnderscore -> (Symbol, "_") - KEquals -> (Symbol, "=") - KAmpersand -> (Symbol, "&") - KDash -> (Symbol, "-") - KColonColon -> (Symbol, "::") - KBigLambda -> (Symbol, "/\\") - - -- symbolic constructors - KSortComp -> (Constructor, "**") - KSortProp -> (Constructor, "@@") - KKindValue -> (Constructor, "*") - KKindRegion -> (Constructor, "%") - KKindEffect -> (Constructor, "!") - KKindClosure -> (Constructor, "$") - KKindWitness -> (Constructor, "@") - KArrowTilde -> (Constructor, "~>") - KArrowDash -> (Constructor, "->") - KArrowEquals -> (Constructor, "=>") - - -- bottoms - KBotEffect -> (Constructor, "!0") - KBotClosure -> (Constructor, "!$") - - -- expression keywords - KWith -> (Keyword, "with") - KWhere -> (Keyword, "where") - KIn -> (Keyword, "in") - KLet -> (Keyword, "let") - KLazy -> (Keyword, "lazy") - KLetRec -> (Keyword, "letrec") - KLetRegion -> (Keyword, "letregion") - KWithRegion -> (Keyword, "withregion") - KCase -> (Keyword, "case") - KOf -> (Keyword, "of") - KWeakEff -> (Keyword, "weakeff") - KWeakClo -> (Keyword, "weakclo") - KPurify -> (Keyword, "purify") - KForget -> (Keyword, "forget") - - -- debruijn indices - KIndex i -> (Index, "^" ++ show i) - - -- builtin names - KTwConBuiltin tw -> (Constructor, renderPlain $ ppr tw) - KWbConBuiltin wi -> (Constructor, renderPlain $ ppr wi) - KTcConBuiltin tc -> (Constructor, renderPlain $ ppr tc) - - --- TokNamed ------------------------------------------------------------------- --- | A token witn a user-defined name. -data TokNamed n - = KCon n - | KVar n - | KLit n - deriving (Eq, Show) - - --- | Describe a `TokNamed`, for parser error messages. -describeTokNamed :: Pretty n => TokNamed n -> String -describeTokNamed tn - = case tn of - KCon n -> renderPlain $ text "constructor" <+> (dquotes $ ppr n) - KVar n -> renderPlain $ text "variable" <+> (dquotes $ ppr n) - KLit n -> renderPlain $ text "literal" <+> (dquotes $ ppr n) - - --- | Apply a function to all the names in a `TokNamed`. -renameTokNamed - :: Ord n2 - => (n1 -> n2) -> TokNamed n1 -> TokNamed n2 - -renameTokNamed f kk - = case kk of - KCon c -> KCon $ f c - KVar c -> KVar $ f c - KLit c -> KLit $ f c - diff --git a/DDC/Core/Parser/Type.hs b/DDC/Core/Parser/Type.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Parser/Type.hs @@ -0,0 +1,238 @@ + +-- | Parser for type expressions. +module DDC.Core.Parser.Type + ( pType + , pTypeAtom + , pTypeApp + , pBinder + , pIndex + , pTok + , pTokAs) +where +import DDC.Core.Parser.Context +import DDC.Core.Parser.Base +import DDC.Core.Lexer.Tokens +import DDC.Type.Exp.Simple +import DDC.Control.Parser (()) +import qualified DDC.Control.Parser as P +import qualified DDC.Type.Sum as TS + + +-- | Parse a type. +pType :: Ord n + => Context n -> Parser n (Type n) + +pType c + = pTypeSum c + "a type" + + +-- | Parse a type sum. +pTypeSum + :: Ord n + => Context n -> Parser n (Type n) +pTypeSum c + = do t1 <- pTypeForall c + P.choice + [ -- Type sums. + -- T2 + T3 + do pTok (KOp "+") + t2 <- pTypeSum c + return $ TSum $ TS.fromList (tBot sComp) [t1, t2] + + , do return t1 ] + "a type" + + +-- | Parse a binder. +pBinder :: Ord n => Parser n (Binder n) +pBinder + = P.choice + -- Named binders. + [ do v <- pVar + return $ RName v + + -- Anonymous binders. + , do pSym SHat + return $ RAnon + + -- Vacant binders. + , do pSym SUnderscore + return $ RNone ] + "a binder" + + +-- | Parse a quantified type. +pTypeForall + :: Ord n + => Context n -> Parser n (Type n) +pTypeForall c + = P.choice + [ -- Type abstraction. + do pSym SLambda + bs <- P.many1 pBinder + pTok (KOp ":") + k <- pTypeSum c + pSym SDot + + tBody <- pTypeForall c + + return $ foldr TAbs tBody + $ map (\b -> makeBindFromBinder b k) bs + + -- Universal quantification. + -- [v1 v1 ... vn : T1]. T2 + , do pSym SSquareBra + bs <- P.many1 pBinder + pTok (KOp ":") + k <- pTypeSum c + pSym SSquareKet + pSym SDot + + body <- pTypeForall c + + return $ foldr TForall body + $ map (\b -> makeBindFromBinder b k) bs + + -- Body type + , do pTypeFun c] + "a type" + + +-- | Parse a function type. +pTypeFun + :: Ord n + => Context n -> Parser n (Type n) + +pTypeFun c + = do t1 <- pTypeApp c + P.choice + [ -- T1 ~> T2 + do pSym SArrowTilde + t2 <- pTypeForall c + return $ TApp (TApp (TCon (TyConKind KiConFun)) t1) t2 + + -- T1 => T2 + , do pSym SArrowEquals + t2 <- pTypeForall c + return $ TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2 + + -- T1 -> T2 + , do pSym SArrowDashRight + t2 <- pTypeForall c + return $ t1 `tFun` t2 + + -- Body type + , do return t1 ] + "an atomic type or type application" + + +-- | Parse a type application. +pTypeApp + :: Ord n + => Context n -> Parser n (Type n) +pTypeApp c + = do (t:ts) <- P.many1 (pTypeAtom c) + return $ foldl TApp t ts + "an atomic type or type application" + + +-- | Parse a variable, constructor or parenthesised type. +pTypeAtom + :: Ord n + => Context n -> Parser n (Type n) +pTypeAtom c + = P.choice + -- (~>) and (=>) and (->) and (TYPE2) + [ -- (~>) + do pTok (KOpVar "~>") + return (TCon $ TyConKind KiConFun) + + -- (=>) + , do pTok (KOpVar "=>") + return (TCon $ TyConWitness TwConImpl) + + -- (->) + , do pTok (KOpVar "->") + return (TCon $ TyConSpec TcConFun) + + -- (TYPE2) + , do pSym SRoundBra + t <- pTypeSum c + pSym SRoundKet + return t + + -- Named type constructors + , do so <- pSoCon + return $ TCon (TyConSort so) + + , do ki <- pKiCon + return $ TCon (TyConKind ki) + + , do tc <- pTcCon + return $ TCon (TyConSpec tc) + + , do tc <- pTwCon + return $ TCon (TyConWitness tc) + + , do tc <- pTyConNamed + return $ TCon tc + + -- Bottoms. + , do pTokAs (KBuiltin BPure) (tBot kEffect) + , do pTokAs (KBuiltin BEmpty) (tBot kClosure) + + -- Bound occurrence of a variable. + -- We don't know the kind of this variable yet, so fill in the + -- field with the bottom element of computation kinds. This isn't + -- really part of the language, but makes sense implentation-wise. + , do v <- pVar + return $ TVar (UName v) + + , do i <- pIndex + return $ TVar (UIx i) + ] + "an atomic type" + + +------------------------------------------------------------------------------- +-- | Parse a builtin sort constructor. +pSoCon :: Parser n SoCon +pSoCon = P.pTokMaybe f + "a sort constructor" + where f (KA (KBuiltin (BSoCon c))) = Just c + f _ = Nothing + + +-- | Parse a builtin kind constructor. +pKiCon :: Parser n KiCon +pKiCon = P.pTokMaybe f + "a kind constructor" + where f (KA (KBuiltin (BKiCon c))) = Just c + f _ = Nothing + + +-- | Parse a builtin type constructor. +pTcCon :: Parser n TcCon +pTcCon = P.pTokMaybe f + "a type constructor" + where f (KA (KBuiltin (BTcCon c))) = Just c + f _ = Nothing + + +-- | Parse a builtin witness type constructor. +pTwCon :: Parser n TwCon +pTwCon = P.pTokMaybe f + "a witness constructor" + where f (KA (KBuiltin (BTwCon c))) = Just c + f _ = Nothing + + +-- | Parse a user defined type constructor. +pTyConNamed :: Parser n (TyCon n) +pTyConNamed + = P.pTokMaybe f + "a type constructor" + where f (KN (KCon n)) = Just (TyConBound (UName n) (tBot kData)) + f _ = Nothing + diff --git a/DDC/Core/Parser/Witness.hs b/DDC/Core/Parser/Witness.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Parser/Witness.hs @@ -0,0 +1,104 @@ + +module DDC.Core.Parser.Witness + ( pWitness + , pWitnessApp + , pWitnessAtom) +where +import DDC.Core.Parser.Type +import DDC.Core.Parser.Context +import DDC.Core.Parser.Base +import DDC.Core.Lexer.Tokens +import DDC.Core.Exp +import DDC.Control.Parser ((), SourcePos) +import qualified DDC.Control.Parser as P +import qualified DDC.Type.Exp.Simple as T +import Control.Monad + + +-- | Parse a witness expression. +pWitness + :: Ord n + => Context n -> Parser n (Witness SourcePos n) +pWitness c = pWitnessJoin c + + +-- | Parse a witness join. +pWitnessJoin + :: Ord n + => Context n -> Parser n (Witness SourcePos n) +pWitnessJoin c + -- WITNESS or WITNESS & WITNESS + = do w1 <- pWitnessApp c + P.choice + [ do return w1 ] + + +-- | Parse a witness application. +pWitnessApp + :: Ord n + => Context n -> Parser n (Witness SourcePos n) + +pWitnessApp c + = do (x:xs) <- P.many1 (pWitnessArgSP c) + let x' = fst x + let sp = snd x + let xs' = map fst xs + return $ foldl (WApp sp) x' xs' + + "a witness expression or application" + + +-- | Parse a witness argument. +pWitnessArgSP + :: Ord n + => Context n -> Parser n (Witness SourcePos n, SourcePos) + +pWitnessArgSP c + = P.choice + [ -- [TYPE] + do sp <- pSym SSquareBra + t <- pType c + pSym SSquareKet + return (WType sp t, sp) + + -- WITNESS + , do pWitnessAtomSP c ] + + + +-- | Parse a variable, constructor or parenthesised witness. +pWitnessAtom + :: Ord n + => Context n -> Parser n (Witness SourcePos n) + +pWitnessAtom c + = liftM fst (pWitnessAtomSP c) + + +-- | Parse a variable, constructor or parenthesised witness, +-- also returning source position. +pWitnessAtomSP + :: Ord n + => Context n -> Parser n (Witness SourcePos n, SourcePos) + +pWitnessAtomSP c + = P.choice + -- (WITNESS) + [ do sp <- pSym SRoundBra + w <- pWitness c + pSym SRoundKet + return (w, sp) + + -- Named constructors + , do (con, sp) <- pConSP + return (WCon sp (WiConBound (UName con) (T.tBot T.kWitness)), sp) + + -- Debruijn indices + , do (i, sp) <- pIndexSP + return (WVar sp (UIx i), sp) + + -- Variables + , do (var, sp) <- pVarSP + return (WVar sp (UName var), sp) ] + + "a witness" diff --git a/DDC/Core/Predicates.hs b/DDC/Core/Predicates.hs deleted file mode 100644 --- a/DDC/Core/Predicates.hs +++ /dev/null @@ -1,97 +0,0 @@ - --- | Simple predicates on core expressions. -module DDC.Core.Predicates - ( -- * Atoms - isXVar, isXCon - , isAtomW, isAtomX - - -- * Lambdas - , isXLAM, isXLam - , isLambdaX - - -- * Applications - , isXApp - - -- * Patterns - , isPDefault) -where -import DDC.Core.Exp -import DDC.Type.Predicates - - --- Atoms ---------------------------------------------------------------------- --- | Check whether an expression is a variable. -isXVar :: Exp a n -> Bool -isXVar xx - = case xx of - XVar{} -> True - _ -> False - - --- | Check whether an expression is a constructor. -isXCon :: Exp a n -> Bool -isXCon xx - = case xx of - XCon{} -> True - _ -> False - - --- | Check whether a witness is a `WVar` or `WCon`. -isAtomW :: Witness n -> Bool -isAtomW ww - = case ww of - WVar{} -> True - WCon{} -> True - _ -> False - - --- | Check whether an expression is a `XVar` or an `XCon`, --- or some type or witness atom. -isAtomX :: Exp a n -> Bool -isAtomX xx - = case xx of - XVar{} -> True - XCon{} -> True - XType t -> isAtomT t - XWitness w -> isAtomW w - _ -> False - - --- Lambdas -------------------------------------------------------------------- --- | Check whether an expression is a spec abstraction (level-1). -isXLAM :: Exp a n -> Bool -isXLAM xx - = case xx of - XLAM{} -> True - _ -> False - - --- | Check whether an expression is a value or witness abstraction (level-0). -isXLam :: Exp a n -> Bool -isXLam xx - = case xx of - XLam{} -> True - _ -> False - - --- | Check whether an expression is a spec, value, or witness abstraction. -isLambdaX :: Exp a n -> Bool -isLambdaX xx - = isXLAM xx || isXLam xx - - --- Applications --------------------------------------------------------------- --- | Check whether an expression is an `XApp`. -isXApp :: Exp a n -> Bool -isXApp xx - = case xx of - XApp{} -> True - _ -> False - - --- Patterns ------------------------------------------------------------------- --- | Check whether an alternative is a `PDefault`. -isPDefault :: Pat n -> Bool -isPDefault PDefault = True -isPDefault _ = False - diff --git a/DDC/Core/Pretty.hs b/DDC/Core/Pretty.hs --- a/DDC/Core/Pretty.hs +++ b/DDC/Core/Pretty.hs @@ -1,237 +1,251 @@ --- | Pretty printing for core expressions. +{-# LANGUAGE TypeFamilies #-} + +-- | Pretty printing for core modules and expressions. module DDC.Core.Pretty - ( module DDC.Type.Pretty - , module DDC.Base.Pretty) + ( module DDC.Type.Exp.Simple.Pretty + , module DDC.Data.Pretty + , PrettyMode (..) + , pprExportType, pprExportValue + , pprImportType, pprImportValue + , pprDataDef, pprDataCtor + , pprTypeDef) where -import DDC.Core.Exp -import DDC.Core.Compounds -import DDC.Core.Predicates -import DDC.Type.Pretty -import DDC.Type.Compounds -import DDC.Type.Predicates -import DDC.Base.Pretty +import DDC.Core.Module +import DDC.Core.Exp.Annot.Exp +import DDC.Core.Exp.Annot.Pretty +import DDC.Core.Exp.Annot.Compounds +import DDC.Type.Exp.Simple.Pretty +import DDC.Type.DataDef +import DDC.Data.Pretty +import Data.List +import Prelude hiding ((<$>)) --- Binder --------------------------------------------------------------------- --- | Pretty print a binder, adding spaces after names. --- The RAnon and None binders don't need spaces, as they're single symbols. -pprBinderSep :: Pretty n => Binder n -> Doc -pprBinderSep bb - = case bb of - RName v -> ppr v - RAnon -> text "^" - RNone -> text "_" +-- ModuleName ------------------------------------------------------------------------------------- +instance Pretty ModuleName where + ppr (ModuleName parts) + = text $ intercalate "." parts --- | Print a group of binders with the same type. -pprBinderGroup - :: (Pretty n, Eq n) - => Doc -> ([Binder n], Type n) -> Doc - -pprBinderGroup lam (rs, t) - = lam <> parens ((cat $ map pprBinderSep rs) <+> text ":" <+> ppr t) <> dot +-- Module ----------------------------------------------------------------------------------------- +instance (Pretty n, Eq n) => Pretty (Module a n) where + data PrettyMode (Module a n) + = PrettyModeModule + { modeModuleLets :: PrettyMode (Lets a n) + , modeModuleSuppressImports :: Bool + , modeModuleSuppressExports :: Bool } + pprDefaultMode + = PrettyModeModule + { modeModuleLets = pprDefaultMode + , modeModuleSuppressImports = False + , modeModuleSuppressExports = False } --- Exp ------------------------------------------------------------------------ -instance (Pretty n, Eq n) => Pretty (Exp a n) where - pprPrec d xx - = case xx of - XVar _ u -> ppr u - XCon _ tc -> ppr tc + pprModePrec mode _ + ModuleCore + { moduleName = name + , moduleExportTypes = exportTypes + , moduleExportValues = exportValues + , moduleImportTypes = importTypes + , moduleImportCaps = importCaps + , moduleImportValues = importValues + , moduleImportDataDefs = importData + , moduleImportTypeDefs = importType + , moduleDataDefsLocal = localData + , moduleTypeDefsLocal = localType + , moduleBody = body } + = {-# SCC "ppr[Module]" #-} + let + (lts, _) = splitXLets body - XLAM{} - -> let Just (bs, xBody) = takeXLAMs xx - groups = partitionBindsByType bs - in pprParen' (d > 1) - $ (cat $ map (pprBinderGroup (text "/\\")) groups) - <> (if isXLAM xBody then empty - else if isXLam xBody then line <> space - else if isSimpleX xBody then space - else line) - <> ppr xBody - - XLam{} - -> let Just (bs, xBody) = takeXLams xx - groups = partitionBindsByType bs - in pprParen' (d > 1) - $ (cat $ map (pprBinderGroup (text "\\")) groups) - <> breakWhen (not $ isSimpleX xBody) - <> ppr xBody + -- Exports -------------------- + dExportTypes + | null $ exportTypes = empty + | otherwise = (vcat $ map pprExportType exportTypes) <> line - XApp _ x1 x2 - -> pprParen' (d > 10) - $ pprPrec 10 x1 - <> nest 4 (breakWhen (not $ isSimpleX x2) - <> pprPrec 11 x2) + dExportValues + | null $ exportValues = empty + | otherwise = (vcat $ map pprExportValue exportValues) <> line - XLet _ lts x - -> pprParen' (d > 2) - $ ppr lts <+> text "in" - <$> ppr x + -- Imports -------------------- + dImportTypes + | null $ importTypes = empty + | otherwise = (vcat $ map pprImportType importTypes) <> line - XCase _ x alts - -> pprParen' (d > 2) - $ (nest 2 $ text "case" <+> ppr x <+> text "of" <+> lbrace <> line - <> (vcat $ punctuate semi $ map ppr alts)) - <> line - <> rbrace + dImportCaps + | null $ importCaps = empty + | otherwise = (vcat $ map pprImportCap importCaps) <> line - XCast _ cc x - -> pprParen' (d > 2) - $ ppr cc <+> text "in" - <$> ppr x + dImportValues + | null $ importValues = empty + | otherwise = (vcat $ map pprImportValue importValues) <> line - XType t -> text "[" <> ppr t <> text "]" - XWitness w -> text "<" <> ppr w <> text ">" + docsImportsExports + -- If we're suppressing imports, then don't print it. + | modeModuleSuppressImports mode + = empty + + -- If there are no imports or exports then suppress printing. + | null exportTypes, null exportValues + , null importTypes, null importCaps, null importValues + = empty + | otherwise + = line <> dExportTypes <> dExportValues + <> dImportTypes <> dImportCaps <> dImportValues + + -- Data Definitions ----- + docsDataImport + | null importData = empty + | otherwise + = line <> vsep (map (\i -> text "import" <+> ppr i) $ importData) --- Pat ------------------------------------------------------------------------ -instance (Pretty n, Eq n) => Pretty (Pat n) where - ppr pp - = case pp of - PDefault -> text "_" - PData u bs -> ppr u <+> sep (map pprPatBind bs) + docsDataLocal + | null localData = empty + | otherwise + = line <> vsep (map ppr localData) + -- Type Definitions ----- + docsTypeImport + | null importType = empty + | otherwise + = line <> vsep (map (\i -> text "import" <+> pprTypeDef i) $ importType) --- | Pretty print a binder, --- showing its type annotation only if it's not bottom. -pprPatBind :: (Eq n, Pretty n) => Bind n -> Doc -pprPatBind b - | isBot (typeOfBind b) = ppr $ binderOfBind b - | otherwise = parens $ ppr b + docsTypeLocal + | null localType = empty + | otherwise + = line <> vsep (map pprTypeDef localType) + pprLts = pprModePrec (modeModuleLets mode) 0 --- Alt ------------------------------------------------------------------------ -instance (Pretty n, Eq n) => Pretty (Alt a n) where - ppr (AAlt p x) - = ppr p <+> nest 1 (line <> nest 3 (text "->" <+> ppr x)) + in text "module" <+> ppr name + <+> docsImportsExports + <> docsDataImport + <> docsDataLocal + <> docsTypeImport + <> docsTypeLocal + <> (case lts of + [] -> empty + [LRec[]] -> empty + _ -> text "with" <$$> (vcat $ map pprLts lts)) --- Cast ----------------------------------------------------------------------- -instance (Pretty n, Eq n) => Pretty (Cast n) where - ppr cc - = case cc of - CastWeakenEffect eff - -> text "weakeff" <+> brackets (ppr eff) - - CastWeakenClosure clo - -> text "weakclo" <+> brackets (ppr clo) - - CastPurify w - -> text "purify" <+> angles (ppr w) +-- Exports ---------------------------------------------------------------------------------------- +-- | Pretty print an exported type definition. +pprExportType :: (Pretty n, Pretty t) => (n, ExportSource n t) -> Doc +pprExportType (n, esrc) + = case esrc of + ExportSourceLocal _n k + -> text "export type" <+> padL 10 (ppr n) <+> text ":" <+> ppr k <> semi - CastForget w - -> text "forget" <+> angles (ppr w) + ExportSourceLocalNoType _n + -> text "export type" <+> padL 10 (ppr n) <> semi --- Lets ----------------------------------------------------------------------- -instance (Pretty n, Eq n) => Pretty (Lets a n) where - ppr lts - = case lts of - LLet m b x - -> let dBind = if isBot (typeOfBind b) - then ppr (binderOfBind b) - else ppr b - in text "let" - <+> align ( dBind <> ppr m - <> nest 2 ( breakWhen (not $ isSimpleX x) - <> text "=" <+> align (ppr x))) +-- | Pretty print an exported value definition. +pprExportValue :: (Pretty n, Pretty t) => (n, ExportSource n t) -> Doc +pprExportValue (n, esrc) + = case esrc of + ExportSourceLocal _n t + -> text "export value" <+> padL 10 (ppr n) <+> text ":" <+> ppr t <> semi - LRec bxs - -> let pprLetRecBind (b, x) - = ppr (binderOfBind b) - <+> text ":" - <+> ppr (typeOfBind b) - <> nest 2 ( breakWhen (not $ isSimpleX x) - <> text "=" <+> align (ppr x)) - - in (nest 2 $ text "letrec" - <+> lbrace - <> ( line - <> (vcat $ punctuate (semi <> line) - $ map pprLetRecBind bxs))) - <$> rbrace + ExportSourceLocalNoType _n + -> text "export value" <+> padL 10 (ppr n) <> semi - LLetRegion b [] - -> text "letregion" - <+> ppr (binderOfBind b) - - LLetRegion b bs - -> text "letregion" - <+> ppr (binderOfBind b) - <+> text "with" - <+> braces (cat $ punctuate (text "; ") $ map ppr bs) +-- Imports ---------------------------------------------------------------------------------------- +-- | Pretty print a type import. +pprImportType :: (Pretty n, Pretty t) => (n, ImportType n t) -> Doc +pprImportType (n, isrc) + = case isrc of + ImportTypeAbstract k + -> text "import foreign abstract type" <> line + <> indent 8 (ppr n <+> text ":" <+> ppr k <> semi) + <> line - LWithRegion b - -> text "withregion" - <+> ppr b + ImportTypeBoxed k + -> text "import foreign boxed type" <> line + <> indent 8 (ppr n <+> text ":" <+> ppr k <> semi) + <> line -instance (Pretty n, Eq n) => Pretty (LetMode n) where - ppr lm - = case lm of - LetStrict -> empty - LetLazy Nothing -> text " lazy" - LetLazy (Just w) -> text " lazy <" <> ppr w <> text ">" +-- | Pretty print a capability import. +pprImportCap :: (Pretty n, Pretty t) => (n, ImportCap n t) -> Doc +pprImportCap (n, isrc) + = case isrc of + ImportCapAbstract t + -> text "import foreign abstract capability" <> line + <> indent 8 (padL 15 (ppr n) <+> text ":" <+> ppr t <> semi) + <> line --- Witness -------------------------------------------------------------------- -instance (Pretty n, Eq n) => Pretty (Witness n) where - pprPrec d ww - = case ww of - WVar n -> ppr n - WCon wc -> ppr wc +-- | Pretty print a value import. +pprImportValue :: (Pretty n, Pretty t) => (n, ImportValue n t) -> Doc +pprImportValue (n, isrc) + = case isrc of + ImportValueModule _mn _nSrc t Nothing + -> text "import value" <+> padL 10 (ppr n) <+> text ":" <+> ppr t <> semi - WApp w1 w2 - -> pprParen (d > 10) (ppr w1 <+> pprPrec 11 w2) - - WJoin w1 w2 - -> pprParen (d > 9) (ppr w1 <+> text "&" <+> ppr w2) + ImportValueModule _mn _nSrc t (Just (arityType, arityValue, arityBoxes)) + -> vcat [ text "import value" <+> padL 10 (ppr n) <+> text ":" <+> ppr t <> semi + , text "{-# ARITY " <+> padL 10 (ppr n) + <+> ppr arityType + <+> ppr arityValue + <+> ppr arityBoxes + <+> text "#-}" + , empty ] - WType t -> text "[" <> ppr t <> text "]" + ImportValueSea _var t + -> text "import foreign c value" <> line + <> indent 8 (padL 15 (ppr n) <+> text ":" <+> ppr t <> semi) + <> line -instance (Pretty n, Eq n) => Pretty (WiCon n) where - ppr wc - = case wc of - WiConBuiltin wb -> ppr wb - WiConBound u -> ppr u +-- DataDef ---------------------------------------------------------------------------------------- +instance (Pretty n, Eq n) => Pretty (DataDef n) where + pprPrec _ def = pprDataDef def -instance Pretty WbCon where - ppr wb - = case wb of - WbConPure -> text "pure" - WbConEmpty -> text "empty" - WbConUse -> text "use" - WbConRead -> text "read" - WbConAlloc -> text "alloc" - +-- | Pretty print a data type definition. +pprDataDef :: (Pretty n, Eq n) => DataDef n -> Doc +pprDataDef def + = (text "data" + <+> hsep ( ppr (dataDefTypeName def) + : map (parens . ppr) (dataDefParams def)) + <+> text "where" + <+> lbrace) + <$> (case dataDefCtors def of + Just ctors + -> indent 8 + $ vcat [ ppr ctor <> semi | ctor <- ctors] --- Utils ---------------------------------------------------------------------- -breakWhen :: Bool -> Doc -breakWhen True = line -breakWhen False = space + Nothing + -> text "LARGE") + <> line <> rbrace <> line -isSimpleX :: Exp a n -> Bool -isSimpleX xx - = case xx of - XVar{} -> True - XCon{} -> True - XType{} -> True - XWitness{} -> True - XApp _ x1 x2 -> isSimpleX x1 && isAtomX x2 - _ -> False +-- DataCtor --------------------------------------------------------------------------------------- +instance (Pretty n, Eq n) => Pretty (DataCtor n) where + pprPrec _ def = pprDataCtor def -parens' :: Doc -> Doc -parens' d = lparen <> nest 1 d <> rparen +-- | Pretty print a data constructor definition. +pprDataCtor :: (Pretty n, Eq n) => DataCtor n -> Doc +pprDataCtor ctor + = ppr (dataCtorName ctor) + <+> text ":" + <+> (hsep $ punctuate (text " ->") + $ (map (pprPrec 6) + ( dataCtorFieldTypes ctor + ++ [dataCtorResultType ctor]))) + +-- TypeDef ----------------------------------------------------------------------------------------- +-- | Pretty print a type definition. +pprTypeDef :: (Pretty n, Eq n) => (n, (Kind n, Type n)) -> Doc +pprTypeDef (n, (k, t)) + = text "type" <+> ppr n + <+> text ":" <+> ppr k + <+> text "=" <+> ppr t + <> semi <> line --- | Wrap a `Doc` in parens if the predicate is true. -pprParen' :: Bool -> Doc -> Doc -pprParen' b c - = if b then parens' c - else c 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/LiftW.hs b/DDC/Core/Transform/LiftW.hs deleted file mode 100644 --- a/DDC/Core/Transform/LiftW.hs +++ /dev/null @@ -1,116 +0,0 @@ - --- | Lift deBruijn indices in witnesses. -module DDC.Core.Transform.LiftW - (LiftW(..)) -where -import DDC.Core.Exp - - -class LiftW (c :: * -> *) where - -- | Lift indices that are at least a the given depth by some number - -- of levels - liftAtDepthW - :: forall n. Ord n - => Int -- ^ Number of levels to lift. - -> Int -- ^ Current binding depth. - -> c n -- ^ Lift witness variable indices in this thing. - -> c n - - -- | Wrapper for `liftAtDepthX` that starts at depth 0. - liftW :: forall n. Ord n - => Int -- ^ Number of levels to lift. - -> c n -- ^ Lift witness variable indices in this thing. - -> c n - - liftW n xx = liftAtDepthW n 0 xx - - -instance LiftW Bound where - liftAtDepthW n d uu - = case uu of - UName{} -> uu - UPrim{} -> uu - UIx i t - | d <= i -> UIx (i + n) t - | otherwise -> uu - - -instance LiftW (Exp a) where - liftAtDepthW n d xx - = let down = liftAtDepthW n d - in case xx of - XVar{} -> xx - XCon{} -> xx - XApp a x1 x2 -> XApp a (down x1) (down x2) - XLAM a b x -> XLAM a b (down x) - XLam a b x -> XLam a b (liftAtDepthW n (d + 1) x) - - XLet a lets x - -> let (lets', levels) = liftAtDepthXLets n d lets - in XLet a lets' (liftAtDepthW n (d + levels) x) - - XCase a x alts -> XCase a (down x) (map down alts) - XCast a cc x -> XCast a cc (down x) - XType{} -> xx - XWitness w -> XWitness (down w) - - -instance LiftW LetMode where - liftAtDepthW n d m - = case m of - LetStrict -> m - LetLazy Nothing -> m - LetLazy (Just w) -> LetLazy (Just $ liftAtDepthW n d w) - - -instance LiftW (Alt a) where - liftAtDepthW n d (AAlt p x) - = case p of - PDefault - -> AAlt PDefault (liftAtDepthW n d x) - - PData _ bs - -> let d' = d + countBAnons bs - in AAlt p (liftAtDepthW n d' x) - - -instance LiftW Witness where - liftAtDepthW n d ww - = let down = liftAtDepthW n d - in case ww of - WVar u -> WVar (down u) - WCon{} -> ww - WApp w1 w2 -> WApp (down w1) (down w2) - WJoin w1 w2 -> WJoin (down w1) (down w2) - WType{} -> ww - - -liftAtDepthXLets - :: forall a n. Ord n - => Int -- ^ Number of levels to lift. - -> Int -- ^ Current binding depth. - -> Lets a n -- ^ Lift exp indices in this thing. - -> (Lets a n, Int) -- ^ Lifted, and how much to increase depth by - -liftAtDepthXLets n d lts - = case lts of - LLet m b x - -> let m' = liftAtDepthW n d m - inc = countBAnons [b] - x' = liftAtDepthW n (d+inc) x - in (LLet m' b x', inc) - - LRec bs - -> let inc = countBAnons (map fst bs) - bs' = map (\(b,e) -> (b, liftAtDepthW n (d+inc) e)) bs - in (LRec bs', inc) - - LLetRegion _b bs -> (lts, countBAnons bs) - LWithRegion _ -> (lts, 0) - - -countBAnons = length . filter isAnon - where isAnon (BAnon _) = True - isAnon _ = False - - 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,96 +0,0 @@ - --- | Lift deBruijn indices in expressions. -module DDC.Core.Transform.LiftX - (LiftX(..)) -where -import DDC.Core.Exp - - -class LiftX (c :: * -> *) where - -- | Lift indices that are at least the given depth by some number - -- of levels. - liftAtDepthX - :: forall n. Ord n - => Int -- ^ Number of levels to lift. - -> Int -- ^ Current binding depth. - -> c n -- ^ Lift expression indices in this thing. - -> c n - - -- | Wrapper for `liftAtDepthX` that starts at depth 0. - liftX :: forall n. Ord n - => Int -- ^ Number of levels to lift. - -> c n -- ^ Lift expression indices in this thing. - -> c n - - liftX n xx = liftAtDepthX n 0 xx - - -instance LiftX Bound where - liftAtDepthX n d uu - = case uu of - UName{} -> uu - UPrim{} -> uu - UIx i t - | d <= i -> UIx (i + n) t - | otherwise -> uu - - -instance LiftX (Exp a) where - liftAtDepthX n d xx - = let down = liftAtDepthX n d - in case xx of - XVar a u -> XVar a (down u) - XCon{} -> xx - XApp a x1 x2 -> XApp a (down x1) (down x2) - XLAM a b x -> XLAM a b (down x) - XLam a b x -> XLam a b (liftAtDepthX n (d + 1) x) - - XLet a lets x - -> let (lets', levels) = liftAtDepthXLets n d lets - in XLet a lets' (liftAtDepthX n (d + levels) x) - - XCase a x alts -> XCase a (down x) (map down alts) - XCast a cc x -> XCast a cc (down x) - XType{} -> xx - XWitness{} -> xx - - -instance LiftX (Alt a) where - liftAtDepthX n d (AAlt p x) - = case p of - PDefault - -> AAlt PDefault (liftAtDepthX n d x) - - PData _ bs - -> let d' = d + countBAnons bs - in AAlt p (liftAtDepthX n d' x) - - -liftAtDepthXLets - :: forall a n. Ord n - => Int -- ^ Number of levels to lift. - -> Int -- ^ Current binding depth. - -> Lets a n -- ^ Lift exp indices in this thing. - -> (Lets a n, Int) -- ^ Lifted, and how much to increase depth by - -liftAtDepthXLets n d lts - = case lts of - LLet m b x - -> let inc = countBAnons [b] - x' = liftAtDepthX n (d+inc) x - in (LLet m b x', inc) - - LRec bs - -> let inc = countBAnons (map fst bs) - bs' = map (\(b,e) -> (b, liftAtDepthX n (d+inc) e)) bs - in (LRec bs', inc) - - LLetRegion _b bs -> (lts, countBAnons bs) - LWithRegion _ -> (lts, 0) - - -countBAnons = length . filter isAnon - where isAnon (BAnon _) = True - isAnon _ = False - - 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 new file mode 100644 --- /dev/null +++ b/DDC/Core/Transform/Reannotate.hs @@ -0,0 +1,92 @@ + +module DDC.Core.Transform.Reannotate + (Reannotate (..)) +where +import DDC.Core.Module +import DDC.Core.Exp.Annot.Exp +import Control.Monad.Identity + + +-- | Apply the given function to every annotation in a core thing. +class Reannotate c where + reannotate :: (a -> b) -> c a n -> c b n + reannotate f xx + = runIdentity (reannotateM (\x -> return $ f x) xx) + + reannotateM :: forall m a b n. Monad m + => (a -> m b) -> c a n -> m (c b n) + + +instance Reannotate Module where + reannotateM f + (ModuleCore name isHeader + exportKinds exportTypes + importKinds importCaps importTypes importDataDefs importTypeDefs + dataDefsLocal typeDefsLocal + body) + + = do body' <- reannotateM f body + return $ ModuleCore name isHeader + exportKinds exportTypes + importKinds importCaps importTypes importDataDefs importTypeDefs + dataDefsLocal typeDefsLocal + body' + + +instance Reannotate Exp where + reannotateM f xx + = let down x = reannotateM f x + in case xx of + XVar a u -> XVar <$> f a <*> pure u + XCon a u -> XCon <$> f a <*> pure u + XLAM a b x -> XLAM <$> f a <*> pure b <*> down x + XLam a b x -> XLam <$> f a <*> pure b <*> down x + XApp a x1 x2 -> XApp <$> f a <*> down x1 <*> down x2 + XLet a lts x -> XLet <$> f a <*> down lts <*> down x + XCase a x alts -> XCase <$> f a <*> down x <*> mapM down alts + XCast a c x -> XCast <$> f a <*> down c <*> down x + XType a t -> XType <$> f a <*> pure t + XWitness a w -> XWitness <$> f a <*> down w + + +instance Reannotate Lets where + reannotateM f xx + = let down x = reannotateM f x + in case xx of + LLet b x + -> LLet <$> pure b <*> down x + + LRec bxs + -> do let (bs, xs) = unzip bxs + xs' <- mapM down xs + return $ LRec $ zip bs xs' + + LPrivate b t bs + -> return $ LPrivate b t bs + + +instance Reannotate Alt where + reannotateM f aa + = case aa of + AAlt w x -> AAlt w <$> reannotateM f x + + +instance Reannotate Cast where + reannotateM f cc + = let down x = reannotateM f x + in case cc of + CastWeakenEffect eff -> pure $ CastWeakenEffect eff + CastPurify w -> CastPurify <$> down w + CastBox -> pure CastBox + CastRun -> pure CastRun + + +instance Reannotate Witness where + reannotateM f ww + = let down x = reannotateM f x + in case ww of + WVar a u -> WVar <$> f a <*> pure u + WCon a c -> WCon <$> f a <*> pure c + WApp a w1 w2 -> WApp <$> f a <*> down w1 <*> down w2 + WType a t -> WType <$> f a <*> pure t + diff --git a/DDC/Core/Transform/Rename.hs b/DDC/Core/Transform/Rename.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Transform/Rename.hs @@ -0,0 +1,32 @@ + +module DDC.Core.Transform.Rename + ( Rename(..) + + -- * Substitution states + , Sub(..) + + -- * Binding stacks + , BindStack(..) + , pushBind + , pushBinds + , substBound + + -- * Rewriting binding occurences + , bind1, bind1s, bind0, bind0s + + -- * Rewriting bound occurences + , use1, use0) +where +import DDC.Core.Exp.Annot.Exp +import DDC.Type.Transform.Rename + + +instance Rename (Witness a) where + renameWith sub ww + = let down x = renameWith x + in case ww of + WVar a u -> WVar a (use0 sub u) + WCon a c -> WCon a c + WApp a w1 w2 -> WApp a (down sub w1) (down sub w2) + WType a t -> WType a (down sub t) + 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 @@ -1,12 +1,11 @@ --- | Spread type annotations from binders and the environment into bound --- occurrences of variables and constructors. module DDC.Core.Transform.SpreadX (SpreadX(..)) where -import DDC.Core.Exp -import DDC.Core.Compounds +import DDC.Core.Module +import DDC.Core.Exp.Annot import DDC.Type.Transform.SpreadT +import Control.Monad import DDC.Type.Env (Env) import qualified DDC.Type.Env as Env @@ -22,12 +21,104 @@ => Env n -> Env n -> c n -> c n +--------------------------------------------------------------------------------------------------- +instance SpreadX (Module a) where + spreadX kenv tenv mm@ModuleCore{} + = let liftSnd f (x, y) = (x, f y) + in ModuleCore + { moduleName + = moduleName mm + + , moduleIsHeader + = moduleIsHeader mm + + , moduleExportTypes + = map (liftSnd $ spreadExportSourceT kenv) + $ moduleExportTypes mm + + , moduleExportValues + = map (liftSnd $ spreadExportSourceT kenv) + $ moduleExportValues mm + + , moduleImportTypes + = map (liftSnd $ spreadImportTypeT kenv tenv) + $ moduleImportTypes mm + + , moduleImportCaps + = map (liftSnd $ spreadImportCapX kenv tenv) + $ moduleImportCaps mm + + , moduleImportValues + = map (liftSnd $ spreadImportValueX kenv tenv) + $ moduleImportValues mm + + , moduleImportDataDefs + = map (spreadT kenv) + $ moduleImportDataDefs mm + + , moduleImportTypeDefs + = map (\(n, (k, t)) -> (n, (spreadT kenv k, spreadT kenv t))) + $ moduleImportTypeDefs mm + + , moduleDataDefsLocal + = map (spreadT kenv) + $ moduleDataDefsLocal mm + + , moduleTypeDefsLocal + = map (\(n, (k, t)) -> (n, (spreadT kenv k, spreadT kenv t))) + $ moduleTypeDefsLocal mm + + , moduleBody + = spreadX kenv tenv + $ moduleBody mm + } + + +--------------------------------------------------------------------------------------------------- +spreadExportSourceT kenv esrc + = case esrc of + ExportSourceLocal n t + -> ExportSourceLocal n (spreadT kenv t) + + ExportSourceLocalNoType n + -> ExportSourceLocalNoType n + + +--------------------------------------------------------------------------------------------------- +spreadImportTypeT kenv _tenv isrc + = case isrc of + ImportTypeAbstract t + -> ImportTypeAbstract (spreadT kenv t) + + ImportTypeBoxed t + -> ImportTypeBoxed (spreadT kenv t) + + +--------------------------------------------------------------------------------------------------- +spreadImportCapX kenv _tenv isrc + = case isrc of + ImportCapAbstract t + -> ImportCapAbstract (spreadT kenv t) + + +--------------------------------------------------------------------------------------------------- +spreadImportValueX kenv _tenv isrc + = case isrc of + ImportValueModule mn n t mArity + -> ImportValueModule mn n (spreadT kenv t) mArity + + ImportValueSea n t + -> ImportValueSea n (spreadT kenv t) + + +--------------------------------------------------------------------------------------------------- instance SpreadX (Exp a) where spreadX kenv tenv xx - = let down = spreadX kenv tenv + = {-# SCC spreadX #-} + let down x = spreadX kenv tenv x in case xx of XVar a u -> XVar a (down u) - XCon a u -> XCon a (down u) + XCon a d -> XCon a (spreadDaCon kenv tenv d) XApp a x1 x2 -> XApp a (down x1) (down x2) XLAM a b x @@ -44,30 +135,56 @@ tenv' = Env.extends (valwitBindsOfLets lts') tenv in XLet a lts' (spreadX kenv' tenv' x) - XCase a x alts -> XCase a (down x) (map down alts) - XCast a c x -> XCast a (down c) (down x) - XType t -> XType (spreadT kenv t) - XWitness w -> XWitness (down w) + XCase a x alts -> XCase a (down x) (map down alts) + XCast a c x -> XCast a (down c) (down x) + XType a t -> XType a (spreadT kenv t) + XWitness a w -> XWitness a (down w) -instance SpreadX Cast where +--------------------------------------------------------------------------------------------------- +spreadDaCon _kenv tenv dc + = case dc of + DaConUnit + -> dc + + DaConPrim n t + -> let u | Env.isPrim tenv n = UPrim n t + | otherwise = UName n + + in case Env.lookup u tenv of + Just t' -> dc { daConType = t' } + Nothing -> dc + + DaConBound n + | Env.isPrim tenv n + , Just t' <- Env.lookup (UPrim n (tBot kData)) tenv + -> DaConPrim n t' + + | otherwise + -> DaConBound n + + +--------------------------------------------------------------------------------------------------- +instance SpreadX (Cast a) where spreadX kenv tenv cc - = let down = spreadX kenv tenv + = let down x = spreadX kenv tenv x in case cc of - CastWeakenEffect eff -> CastWeakenEffect (spreadT kenv eff) - CastWeakenClosure clo -> CastWeakenClosure (spreadT kenv clo) - CastPurify w -> CastPurify (down w) - CastForget w -> CastForget (down w) + CastWeakenEffect eff -> CastWeakenEffect (spreadT kenv eff) + CastPurify w -> CastPurify (down w) + CastBox -> CastBox + CastRun -> CastRun +--------------------------------------------------------------------------------------------------- instance SpreadX Pat where spreadX kenv tenv pat - = let down = spreadX kenv tenv + = let down x = spreadX kenv tenv x in case pat of PDefault -> PDefault - PData u bs -> PData (down u) (map down bs) + PData u bs -> PData (spreadDaCon kenv tenv u) (map down bs) +--------------------------------------------------------------------------------------------------- instance SpreadX (Alt a) where spreadX kenv tenv alt = case alt of @@ -77,11 +194,13 @@ in AAlt p' (spreadX kenv tenv' x) +--------------------------------------------------------------------------------------------------- instance SpreadX (Lets a) where spreadX kenv tenv lts - = let down = spreadX kenv tenv + = let down x = spreadX kenv tenv x in case lts of - LLet m b x -> LLet (down m) (down b) (down x) + LLet b x + -> LLet (down b) (down x) LRec bxs -> let (bs, xs) = unzip bxs @@ -90,43 +209,40 @@ xs' = map (spreadX kenv tenv') xs in LRec (zip bs' xs') - LLetRegion b bs - -> let b' = spreadT kenv b - kenv' = Env.extend b' kenv + LPrivate b mT bs + -> let b' = map (spreadT kenv) b + mT' = liftM (spreadT kenv) mT + kenv' = Env.extends b' kenv bs' = map (spreadX kenv' tenv) bs - in LLetRegion b' bs' - - LWithRegion b - -> LWithRegion (spreadX kenv tenv b) - - -instance SpreadX LetMode where - spreadX kenv tenv lm - = case lm of - LetStrict -> LetStrict - LetLazy Nothing -> LetLazy Nothing - LetLazy (Just w) -> LetLazy (Just $ spreadX kenv tenv w) + in LPrivate b' mT' bs' -instance SpreadX Witness where +--------------------------------------------------------------------------------------------------- +instance SpreadX (Witness a) where spreadX kenv tenv ww = let down = spreadX kenv tenv in case ww of - WCon wc -> WCon (down wc) - WVar u -> WVar (down u) - WApp w1 w2 -> WApp (down w1) (down w2) - WJoin w1 w2 -> WJoin (down w1) (down w2) - WType t1 -> WType (spreadT kenv t1) + WCon a wc -> WCon a (down wc) + WVar a u -> WVar a (down u) + WApp a w1 w2 -> WApp a (down w1) (down w2) + WType a t1 -> WType a (spreadT kenv t1) +--------------------------------------------------------------------------------------------------- instance SpreadX WiCon where spreadX kenv tenv wc - = let down = spreadX kenv tenv - in case wc of - WiConBound u -> WiConBound (down u) - WiConBuiltin{} -> wc + = case wc of + WiConBound (UName n) _ + -> case Env.envPrimFun tenv n of + Nothing -> wc + Just t + -> let t' = spreadT kenv t + in WiConBound (UPrim n t') t' + _ -> wc + +--------------------------------------------------------------------------------------------------- instance SpreadX Bind where spreadX kenv _tenv bb = case bb of @@ -135,18 +251,19 @@ BNone t -> BNone (spreadT kenv t) +--------------------------------------------------------------------------------------------------- instance SpreadX Bound where spreadX kenv tenv uu | Just t' <- Env.lookup uu tenv = case uu of - UIx ix _ -> UIx ix t' - UPrim n _ -> UPrim n t' + UIx ix -> UIx ix - UName n _ + UName n -> if Env.isPrim tenv n then UPrim n (spreadT kenv t') - else UName n (spreadT kenv t') + else UName n - | otherwise = uu + UPrim n _ -> UPrim n t' + | otherwise = uu 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 @@ -3,20 +3,22 @@ -- -- If a binder would capture a variable then it is anonymized -- to deBruijn form. +-- module DDC.Core.Transform.SubstituteTX - ( substituteTX + ( SubstituteTX(..) + , substituteTX , substituteTXs - , substituteBoundTX - , SubstituteTX(..)) + , substituteBoundTX) where import DDC.Core.Collect -import DDC.Core.Exp -import DDC.Type.Compounds +import DDC.Core.Exp.Annot.Exp +import DDC.Type.Exp.Simple import DDC.Type.Transform.SubstituteT -import DDC.Type.Rewrite +import DDC.Type.Transform.Rename import Data.Maybe import qualified Data.Set as Set import qualified DDC.Type.Env as Env +import Control.Monad -- | Substitute a `Type` for the `Bound` corresponding to some `Bind` in a thing. @@ -64,9 +66,10 @@ instance SubstituteTX (Exp a) where substituteWithTX tArg sub xx - = let down = substituteWithTX tArg + = {-# SCC substituteWithTX #-} + let down x = substituteWithTX tArg x in case xx of - XVar a u -> XVar a (down sub u) + XVar a u -> XVar a u XCon{} -> xx XApp a x1 x2 -> XApp a (down sub x1) (down sub x2) @@ -80,12 +83,11 @@ x' = down sub1 x in XLam a b' x' - XLet a (LLet m b x1) x2 - -> let m' = down sub m - x1' = down sub x1 + XLet a (LLet b x1) x2 + -> let x1' = down sub x1 (sub1, b') = bind0 sub (down sub b) x2' = down sub1 x2 - in XLet a (LLet m' b' x1') x2' + in XLet a (LLet b' x1') x2' XLet a (LRec bxs) x2 -> let (bs, xs) = unzip bxs @@ -94,33 +96,22 @@ x2' = down sub1 x2 in XLet a (LRec (zip bs' xs')) x2' - XLet a (LLetRegion b bs) x2 - -> let (sub1, b') = bind1 sub b + XLet a (LPrivate b mT bs) x2 + -> let mT' = liftM (down sub) mT + (sub1, b') = bind1s sub b (sub2, bs') = bind0s sub1 (map (down sub1) bs) x2' = down sub2 x2 - in XLet a (LLetRegion b' bs') x2' - - XLet a (LWithRegion uR) x2 - -> XLet a (LWithRegion uR) (down sub x2) - - XCase a x1 alts -> XCase a (down sub x1) (map (down sub) alts) - XCast a cc x1 -> XCast a (down sub cc) (down sub x1) - XType t -> XType (down sub t) - XWitness w -> XWitness (down sub w) - + in XLet a (LPrivate b' mT' bs') x2' -instance SubstituteTX LetMode where - substituteWithTX tArg sub lm - = let down = substituteWithTX tArg - in case lm of - LetStrict -> lm - LetLazy Nothing -> lm - LetLazy (Just w) -> LetLazy (Just $ down sub w) + XCase a x1 alts -> XCase a (down sub x1) (map (down sub) alts) + XCast a cc x1 -> XCast a (down sub cc) (down sub x1) + XType a t -> XType a (down sub t) + XWitness a w -> XWitness a (down sub w) instance SubstituteTX (Alt a) where substituteWithTX tArg sub aa - = let down = substituteWithTX tArg + = let down x = substituteWithTX tArg x in case aa of AAlt PDefault xBody -> AAlt PDefault $ down sub xBody @@ -131,35 +122,29 @@ in AAlt (PData uCon bs') x' -instance SubstituteTX Cast where +instance SubstituteTX (Cast a) where substituteWithTX tArg sub cc - = let down = substituteWithTX tArg + = let down x = substituteWithTX tArg x in case cc of CastWeakenEffect eff -> CastWeakenEffect (down sub eff) - CastWeakenClosure clo -> CastWeakenClosure (down sub clo) CastPurify w -> CastPurify (down sub w) - CastForget w -> CastForget (down sub w) + CastBox -> CastBox + CastRun -> CastRun -instance SubstituteTX Witness where +instance SubstituteTX (Witness a) where substituteWithTX tArg sub ww - = let down = substituteWithTX tArg + = let down x = substituteWithTX tArg x in case ww of - WVar u -> WVar (down sub u) + WVar a u -> WVar a u WCon{} -> ww - WApp w1 w2 -> WApp (down sub w1) (down sub w2) - WJoin w1 w2 -> WJoin (down sub w1) (down sub w2) - WType t -> WType (down sub t) + WApp a w1 w2 -> WApp a (down sub w1) (down sub w2) + WType a t -> WType a (down sub t) instance SubstituteTX Bind where substituteWithTX tArg sub bb = replaceTypeOfBind (substituteWithTX tArg sub (typeOfBind bb)) bb - - -instance SubstituteTX Bound where - substituteWithTX tArg sub uu - = replaceTypeOfBound (substituteWithTX tArg sub (typeOfBound uu)) uu instance SubstituteTX Type where 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 @@ -3,26 +3,28 @@ -- -- If a binder would capture a variable then it is anonymized -- to deBruijn form. +-- module DDC.Core.Transform.SubstituteWX ( SubstituteWX(..) , substituteWX , substituteWXs) where -import DDC.Core.Exp +import DDC.Core.Exp.Annot.Exp import DDC.Core.Collect -import DDC.Core.Transform.LiftW -import DDC.Type.Compounds -import DDC.Type.Rewrite +import DDC.Core.Transform.Rename +import DDC.Core.Transform.BoundX +import DDC.Type.Exp.Simple import Data.Maybe import qualified DDC.Type.Env as Env import qualified Data.Set as Set +import Control.Monad --- | Wrapper for `substituteWithW` that determines the set of free names in the +-- | Wrapper for `substituteWithWX` that determines the set of free names in the -- type being substituted, and starts with an empty binder stack. substituteWX :: (Ord n, SubstituteWX c) - => Bind n -> Witness n -> c n -> c n + => Bind n -> Witness a n -> c a n -> c a n substituteWX b wArg xx | Just u <- takeSubstBoundOfBind b @@ -52,31 +54,28 @@ | otherwise = xx --- | Wrapper for `substituteW` to substitute multiple things. +-- | Wrapper for `substituteWithWX` to substitute multiple things. substituteWXs :: (Ord n, SubstituteWX c) - => [(Bind n, Witness n)] -> c n -> c n + => [(Bind n, Witness a n)] -> c a n -> c a n substituteWXs bts x = foldr (uncurry substituteWX) x bts -class SubstituteWX (c :: * -> *) where - - -- | Substitute a witness into some thing. - -- In the target, if we find a named binder that would capture a free variable - -- in the type to substitute, then we rewrite that binder to anonymous form, - -- avoiding the capture. +------------------------------------------------------------------------------- +class SubstituteWX (c :: * -> * -> *) where substituteWithWX - :: forall n. Ord n - => Witness n -> Sub n -> c n -> c n + :: forall a n. Ord n + => Witness a n -> Sub n -> c a n -> c a n -instance SubstituteWX (Exp a) where +instance SubstituteWX Exp where substituteWithWX wArg sub xx - = let down = substituteWithWX wArg - into = rewriteWith + = {-# SCC substituteWithWX #-} + let down s x = substituteWithWX wArg s x + into s x = renameWith s x in case xx of - XVar a u -> XVar a (into sub u) + XVar a u -> XVar a u XCon{} -> xx XApp a x1 x2 -> XApp a (down sub x1) (down sub x2) @@ -90,12 +89,11 @@ x' = down sub1 x in XLam a b' x' - XLet a (LLet m b x1) x2 - -> let m' = down sub m - x1' = down sub x1 + XLet a (LLet b x1) x2 + -> let x1' = down sub x1 (sub1, b') = bind0 sub b x2' = down sub1 x2 - in XLet a (LLet m' b' x1') x2' + in XLet a (LLet b' x1') x2' XLet a (LRec bxs) x2 -> let (bs, xs) = unzip bxs @@ -104,34 +102,22 @@ x2' = down sub1 x2 in XLet a (LRec (zip bs' xs')) x2' - XLet a (LLetRegion b bs) x2 - -> let (sub1, b') = bind1 sub b + XLet a (LPrivate b mT bs) x2 + -> let (sub1, b') = bind1s sub b (sub2, bs') = bind0s sub1 bs x2' = down sub2 x2 - in XLet a (LLetRegion b' bs') x2' - - XLet a (LWithRegion uR) x2 - -> XLet a (LWithRegion uR) (down sub x2) - - XCase a x1 alts -> XCase a (down sub x1) (map (down sub) alts) - XCast a cc x1 -> XCast a (down sub cc) (down sub x1) - XType t -> XType (into sub t) - XWitness w -> XWitness (down sub w) - - + mT' = liftM (into sub) mT + in XLet a (LPrivate b' mT' bs') x2' -instance SubstituteWX LetMode where - substituteWithWX wArg sub lm - = let down = substituteWithWX wArg - in case lm of - LetStrict -> lm - LetLazy Nothing -> LetLazy Nothing - LetLazy (Just w) -> LetLazy (Just (down sub w)) + XCase a x1 alts -> XCase a (down sub x1) (map (down sub) alts) + XCast a cc x1 -> XCast a (down sub cc) (down sub x1) + XType a t -> XType a (into sub t) + XWitness a w -> XWitness a (down sub w) -instance SubstituteWX (Alt a) where +instance SubstituteWX Alt where substituteWithWX wArg sub aa - = let down = substituteWithWX wArg + = let down s x = substituteWithWX wArg s x in case aa of AAlt PDefault xBody -> AAlt PDefault $ down sub xBody @@ -144,39 +130,38 @@ instance SubstituteWX Cast where substituteWithWX wArg sub cc - = let down = substituteWithWX wArg - into = rewriteWith + = let down s x = substituteWithWX wArg s x + into s x = renameWith s x in case cc of CastWeakenEffect eff -> CastWeakenEffect (into sub eff) - CastWeakenClosure clo -> CastWeakenClosure (into sub clo) CastPurify w -> CastPurify (down sub w) - CastForget w -> CastForget (down sub w) + CastBox -> CastBox + CastRun -> CastRun instance SubstituteWX Witness where substituteWithWX wArg sub ww - = let down = substituteWithWX wArg - into = rewriteWith + = let down s x = substituteWithWX wArg s x + into s x = renameWith s x in case ww of - WVar u + WVar a u -> case substW wArg sub u of - Left u' -> WVar (into sub u') + Left u' -> WVar a u' Right w -> w WCon{} -> ww - WApp w1 w2 -> WApp (down sub w1) (down sub w2) - WJoin w1 w2 -> WJoin (down sub w1) (down sub w2) - WType t -> WType (into sub t) + WApp a w1 w2 -> WApp a (down sub w1) (down sub w2) + WType a t -> WType a (into sub t) -- | Rewrite or substitute into a witness variable. -substW :: Ord n => Witness n -> Sub n -> Bound n - -> Either (Bound n) (Witness n) +substW :: Ord n => Witness a n -> Sub n -> Bound n + -> Either (Bound n) (Witness a n) substW wArg sub u = case substBound (subStack0 sub) (subBound sub) u of - Left u' -> Left (rewriteWith sub u') + Left u' -> Left u' Right n - | not $ subShadow0 sub -> Right (liftW n wArg) - | otherwise -> Left (rewriteWith sub u) + | not $ subShadow0 sub -> Right (liftX n wArg) + | otherwise -> Left u 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 @@ -3,6 +3,7 @@ -- -- If a binder would capture a variable then it is anonymized -- to deBruijn form. +-- module DDC.Core.Transform.SubstituteXX ( SubstituteXX(..) , substituteXX @@ -10,17 +11,18 @@ , substituteXArg , substituteXArgs) where -import DDC.Core.Exp +import DDC.Core.Exp.Annot.Exp import DDC.Core.Collect -import DDC.Core.Transform.LiftX -import DDC.Type.Compounds +import DDC.Core.Transform.BoundX import DDC.Core.Transform.SubstituteWX import DDC.Core.Transform.SubstituteTX import DDC.Type.Transform.SubstituteT -import DDC.Type.Rewrite +import DDC.Type.Transform.Rename +import DDC.Type.Exp.Simple import Data.Maybe import qualified DDC.Type.Env as Env import qualified Data.Set as Set +import Control.Monad -- | Wrapper for `substituteWithX` that determines the set of free names in the @@ -41,7 +43,7 @@ , subConflict1 = Set.fromList $ (mapMaybe takeNameOfBound $ Set.toList $ freeT Env.empty xArg) - ++ (mapMaybe takeNameOfBind $ collectSpecBinds xArg) + ++ (mapMaybe takeNameOfBind $ fst $ collectBinds xArg) -- Rewrite level-0 binders that have the same name as any -- of the free variables in the expression to substitute. @@ -71,19 +73,19 @@ -- Perform type substitution for an `XType` -- and witness substitution for an `XWitness` substituteXArg - :: (Ord n, SubstituteXX c, SubstituteWX (c a), SubstituteTX (c a)) + :: (Ord n, SubstituteXX c, SubstituteWX c, SubstituteTX (c a)) => Bind n -> Exp a n -> c a n -> c a n substituteXArg b arg x = case arg of - XType t -> substituteTX b t x - XWitness w -> substituteWX b w x + XType _ t -> substituteTX b t x + XWitness _ w -> substituteWX b w x _ -> substituteXX b arg x -- | Wrapper for `substituteXArgs` to substitute multiple arguments. substituteXArgs - :: (Ord n, SubstituteXX c, SubstituteWX (c a), SubstituteTX (c a)) + :: (Ord n, SubstituteXX c, SubstituteWX c, SubstituteTX (c a)) => [(Bind n, Exp a n)] -> c a n -> c a n substituteXArgs bas x @@ -99,12 +101,13 @@ instance SubstituteXX Exp where substituteWithXX xArg sub xx - = let down = substituteWithXX xArg - into = rewriteWith + = {-# SCC substituteWithXX #-} + let down s x = substituteWithXX xArg s x + into s x = renameWith s x in case xx of XVar a u -> case substX xArg sub u of - Left u' -> XVar a (into sub u') + Left u' -> XVar a u' Right x -> x XCon{} -> xx @@ -120,12 +123,11 @@ x' = down sub1 x in XLam a b' x' - XLet a (LLet m b x1) x2 - -> let m' = into sub m - x1' = down sub x1 + XLet a (LLet b x1) x2 + -> let x1' = down sub x1 (sub1, b') = bind0 sub b x2' = down sub1 x2 - in XLet a (LLet m' b' x1') x2' + in XLet a (LLet b' x1') x2' XLet a (LRec bxs) x2 -> let (bs, xs) = unzip bxs @@ -134,24 +136,22 @@ x2' = down sub1 x2 in XLet a (LRec (zip bs' xs')) x2' - XLet a (LLetRegion b bs) x2 - -> let (sub1, b') = bind1 sub b + XLet a (LPrivate b mT bs) x2 + -> let mT' = liftM (into sub) mT + (sub1, b') = bind1s sub b (sub2, bs') = bind0s sub1 bs x2' = down sub2 x2 - in XLet a (LLetRegion b' bs') x2' - - XLet a (LWithRegion uR) x2 - -> XLet a (LWithRegion uR) (down sub x2) + in XLet a (LPrivate b' mT' bs') x2' - XCase a x1 alts -> XCase a (down sub x1) (map (down sub) alts) - XCast a cc x1 -> XCast a (into sub cc) (down sub x1) - XType t -> XType (into sub t) - XWitness w -> XWitness (into sub w) + XCase a x1 alts -> XCase a (down sub x1) (map (down sub) alts) + XCast a cc x1 -> XCast a (down sub cc) (down sub x1) + XType a t -> XType a (into sub t) + XWitness a w -> XWitness a (into sub w) instance SubstituteXX Alt where substituteWithXX xArg sub aa - = let down = substituteWithXX xArg + = let down s x = substituteWithXX xArg s x in case aa of AAlt PDefault xBody -> AAlt PDefault $ down sub xBody @@ -162,15 +162,25 @@ in AAlt (PData uCon bs') x' +instance SubstituteXX Cast where + substituteWithXX _xArg sub cc + = let into s x = renameWith s x + in case cc of + CastWeakenEffect eff -> CastWeakenEffect (into sub eff) + CastPurify w -> CastPurify (into sub w) + CastBox -> CastBox + CastRun -> CastRun + + -- | Rewrite or substitute into an expression variable. substX :: Ord n => Exp a n -> Sub n -> Bound n -> Either (Bound n) (Exp a n) substX xArg sub u = case substBound (subStack0 sub) (subBound sub) u of - Left u' -> Left (rewriteWith sub u') + Left u' -> Left u' Right n | not $ subShadow0 sub -> Right (liftX n xArg) - | otherwise -> Left (rewriteWith sub u) + | otherwise -> Left u 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/Bind.hs b/DDC/Type/Bind.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Bind.hs @@ -0,0 +1,31 @@ + +module DDC.Type.Bind + (getBindType) +where +import DDC.Type.Exp + + +-- | Lookup the type of a bound thing from the binder stack. +-- The binder stack contains the binders of all the `TForall`s we've +-- entered under so far. +getBindType :: Eq n => [Bind n] -> Bound n -> Maybe (Int, Type n) +getBindType bs' u' + = go 0 u' bs' + where go n u (BName n1 t : bs) + | UName n2 <- u + , n1 == n2 = Just (n, t) + + | otherwise = go (n + 1) u bs + + go n (UIx i) (BAnon t : bs) + | i < 0 = Nothing + | i == 0 = Just (n, t) + | otherwise = go (n + 1) (UIx (i - 1)) bs + + go n u (BAnon _ : bs) + | otherwise = go (n + 1) u bs + + go n u (BNone _ : bs) + = go (n + 1) u bs + + go _ _ [] = Nothing diff --git a/DDC/Type/Check.hs b/DDC/Type/Check.hs deleted file mode 100644 --- a/DDC/Type/Check.hs +++ /dev/null @@ -1,209 +0,0 @@ --- | Check the kind of a type. -module DDC.Type.Check - ( -- * Kinds of Types - checkType - , kindOfType - - -- * Kinds of Constructors - , takeSortOfKiCon - , kindOfTwCon - , kindOfTcCon - - -- * Errors - , Error(..)) -where -import DDC.Type.Check.CheckError -import DDC.Type.Check.CheckCon -import DDC.Type.Compounds -import DDC.Type.Predicates -import DDC.Type.Transform.LiftT -import DDC.Core.DataDef -import DDC.Type.Exp -import DDC.Base.Pretty -import Data.List -import Control.Monad -import DDC.Type.Check.Monad (throw, result) -import DDC.Type.Pretty () -import DDC.Type.Env (Env) -import qualified DDC.Type.Sum as TS -import qualified DDC.Type.Env as Env -import qualified DDC.Type.Check.Monad as G -import qualified Data.Map as Map - - --- | The type checker monad. -type CheckM n = G.CheckM (Error n) - - --- Wrappers ------------------------------------------------------------------- --- | Check a type in the given environment, returning an error or its kind. -checkType :: (Ord n, Pretty n) - => DataDefs n - -> Env n - -> Type n - -> Either (Error n) (Kind n) - -checkType defs env tt - = result $ checkTypeM defs env tt - - --- | Check a type in an empty environment, returning an error or its kind. -kindOfType :: (Ord n, Pretty n) - => DataDefs n - -> Type n - -> Either (Error n) (Kind n) - -kindOfType defs tt - = result $ checkTypeM defs Env.empty tt - - --- checkType ------------------------------------------------------------------ --- | Check a type, returning its kind. ---- --- Note that when comparing kinds, we can just use plain equality --- (==) instead of equivT. This is because kinds do not contain quantifiers --- that need to be compared up to alpha-equivalence, nor do they contain --- crushable components terms. -checkTypeM - :: (Ord n, Pretty n) - => DataDefs n - -> Env n - -> Type n - -> CheckM n (Kind n) - -checkTypeM defs env tt - = -- trace (pretty $ text "checkTypeM:" <+> ppr tt) $ - checkTypeM' defs env tt - --- Variables ------------------ -checkTypeM' _defs env (TVar u) - = do let tBound = typeOfBound u - let mtEnv = Env.lookup u env - - let mkResult - -- If the annot is Bot then just use the type - -- from the environment. - | Just tEnv <- mtEnv - , isBot tBound - = return tEnv - - -- The bound has an explicit type annotation, - -- which matches the one from the environment. - -- - -- When the bound is a deBruijn index we need to lift the - -- annotation on the original binder through any lambdas - -- between the binding occurrence and the use. - | Just tEnv <- mtEnv - , UIx i _ <- u - , tBound == liftT (i + 1) tEnv - = return tBound - - -- The bound has an explicit type annotation, - -- that matches the one from the environment. - | Just tEnv <- mtEnv - , tBound == tEnv - = return tBound - - -- The bound has an explicit type annotation, - -- that does not match the one from the environment. - | Just tEnv <- mtEnv - = throw $ ErrorVarAnnotMismatch u tEnv - - -- Type variables must be in the environment. - | _ <- mtEnv - = throw $ ErrorUndefined u - - mkResult - --- Constructors --------------- -checkTypeM' defs _env tt@(TCon tc) - = case tc of - -- Sorts don't have a higher classification. - TyConSort _ -> throw $ ErrorNakedSort tt - - -- Can't sort check a naked kind function - -- because the sort depends on the argument kinds. - TyConKind kc - -> case takeSortOfKiCon kc of - Just s -> return s - Nothing -> throw $ ErrorUnappliedKindFun - - TyConWitness tcw -> return $ kindOfTwCon tcw - TyConSpec tcc -> return $ kindOfTcCon tcc - - -- User defined type constructors need to be in the set of data defs. - TyConBound u - -> case u of - UName n _ - | Just _ <- Map.lookup n (dataDefsTypes defs) - -> return $ typeOfBound u - - | otherwise - -> throw $ ErrorUndefinedCtor u - - UPrim{} -> return $ typeOfBound u - UIx{} -> error "sorry" - - --- Quantifiers ---------------- -checkTypeM' defs env tt@(TForall b1 t2) - = do _ <- checkTypeM defs env (typeOfBind b1) - k2 <- checkTypeM defs (Env.extend b1 env) t2 - - -- The body must have data or witness kind. - when ( (not $ isDataKind k2) - && (not $ isWitnessKind k2)) - $ throw $ ErrorForallKindInvalid tt t2 k2 - - return k2 - --- Applications --------------- --- Applications of the kind function constructor are handled directly --- because the constructor doesn't have a sort by itself. -checkTypeM' defs env (TApp (TApp (TCon (TyConKind KiConFun)) k1) k2) - = do _ <- checkTypeM defs env k1 - s2 <- checkTypeM defs env k2 - return s2 - --- The implication constructor is overloaded and can have the --- following kinds: --- (=>) :: @ ~> @ ~> @, for witness implication. --- (=>) :: @ ~> * ~> *, for a context. -checkTypeM' defs env tt@(TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2) - = do k1 <- checkTypeM defs env t1 - k2 <- checkTypeM defs env t2 - if isWitnessKind k1 && isWitnessKind k2 - then return kWitness - else if isWitnessKind k1 && isDataKind k2 - then return kData - else throw $ ErrorWitnessImplInvalid tt t1 k1 t2 k2 - --- Type application. -checkTypeM' defs env tt@(TApp t1 t2) - = do k1 <- checkTypeM defs env t1 - k2 <- checkTypeM defs env t2 - case k1 of - TApp (TApp (TCon (TyConKind KiConFun)) k11) k12 - | k11 == k2 -> return k12 - | otherwise -> throw $ ErrorAppArgMismatch tt k1 k2 - - _ -> throw $ ErrorAppNotFun tt t1 k1 t2 k2 - --- Sums ----------------------- -checkTypeM' defs env (TSum ts) - = do ks <- mapM (checkTypeM defs env) $ TS.toList ts - - -- Check that all the types in the sum have a single kind, - -- and return that kind. - k <- case nub ks of - [] -> return $ TS.kindOfSum ts - [k] -> return k - _ -> throw $ ErrorSumKindMismatch - (TS.kindOfSum ts) ts ks - - -- Check that the kind of the elements is a valid one. - -- Only effects and closures can be summed. - if (k == kEffect || k == kClosure) - then return k - else throw $ ErrorSumKindInvalid ts k - 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,73 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} -module DDC.Type.Check.CheckCon - ( takeKindOfTyCon - , takeSortOfKiCon - , kindOfTwCon - , kindOfTcCon) -where -import DDC.Type.Exp -import DDC.Type.Compounds - - --- | Take the kind of a `TyCon`, if there is one. -takeKindOfTyCon :: TyCon n -> Maybe (Kind n) -takeKindOfTyCon tt - = case tt of - -- Sorts don't have a higher classification. - TyConSort _ -> Nothing - - TyConKind kc -> takeSortOfKiCon kc - TyConWitness tc -> Just $ kindOfTwCon tc - TyConSpec tc -> Just $ kindOfTcCon tc - TyConBound u -> Just $ typeOfBound u - - --- | Take the superkind of an atomic kind constructor. --- --- * Yields `Nothing` for the kind function (~>) as it doesn't have a sort --- without being fully applied. -takeSortOfKiCon :: KiCon -> Maybe (Sort n) -takeSortOfKiCon kc - = case kc of - KiConFun -> Nothing - KiConData -> Just sComp - KiConRegion -> Just sComp - KiConEffect -> Just sComp - KiConClosure -> Just sComp - KiConWitness -> Just sProp - - --- | Take the kind of a witness type constructor. -kindOfTwCon :: TwCon -> Kind n -kindOfTwCon tc - = case tc of - TwConImpl -> kWitness `kFun` (kWitness `kFun` kWitness) - TwConPure -> kEffect `kFun` kWitness - TwConEmpty -> kClosure `kFun` kWitness - TwConGlobal -> kRegion `kFun` kWitness - TwConDeepGlobal -> kData `kFun` kWitness - TwConConst -> kRegion `kFun` kWitness - TwConDeepConst -> kData `kFun` kWitness - TwConMutable -> kRegion `kFun` kWitness - TwConDeepMutable-> kData `kFun` kWitness - TwConLazy -> kRegion `kFun` kWitness - TwConHeadLazy -> kData `kFun` kWitness - TwConManifest -> kRegion `kFun` kWitness - - --- | Take the kind of a computation type constructor. -kindOfTcCon :: TcCon -> Kind n -kindOfTcCon tc - = case tc of - TcConFun -> [kData, kEffect, kClosure, kData] `kFuns` kData - TcConRead -> kRegion `kFun` kEffect - TcConHeadRead -> kData `kFun` kEffect - TcConDeepRead -> kData `kFun` kEffect - TcConWrite -> kRegion `kFun` kEffect - TcConDeepWrite -> kData `kFun` kEffect - TcConAlloc -> kRegion `kFun` kEffect - TcConDeepAlloc -> kData `kFun` kEffect - TcConUse -> kRegion `kFun` kClosure - TcConDeepUse -> kData `kFun` kClosure - - diff --git a/DDC/Type/Check/CheckError.hs b/DDC/Type/Check/CheckError.hs deleted file mode 100644 --- a/DDC/Type/Check/CheckError.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} --- | Errors produced when checking types. -module DDC.Type.Check.CheckError - (Error(..)) -where -import DDC.Type.Exp -import DDC.Type.Compounds -import DDC.Type.Pretty - - --- Error ------------------------------------------------------------------------------------------ --- | Type errors. -data Error n - - -- | An undefined type variable. - = ErrorUndefined - { errorBound :: Bound n } - - -- | An undefined type constructor. - | ErrorUndefinedCtor - { errorBound :: Bound n } - - -- | The kind annotation on the variables does not match the one in the environment. - | ErrorVarAnnotMismatch - { errorBound :: Bound n - , errorTypeEnv :: Type n } - - -- | Found a naked sort constructor. - | ErrorNakedSort - { errorSort :: Sort n } - - -- | Found an unapplied kind function constructor. - | ErrorUnappliedKindFun - - -- | A type application where the parameter and argument kinds don't match. - | ErrorAppArgMismatch - { errorChecking :: Type n - , errorParamKind :: Kind n - , errorArgKind :: Kind n } - - -- | A type application where the thing being applied is not a function. - | ErrorAppNotFun - { errorChecking :: Type n - , errorFunType :: Type n - , errorFunTypeKind :: Kind n - , errorArgType :: Type n - , errorArgTypeKind :: Kind n } - - -- | A type sum where the components have differing kinds. - | ErrorSumKindMismatch - { errorKindExpected :: Kind n - , errorTypeSum :: TypeSum n - , errorKinds :: [Kind n] } - - -- | A type sum that does not have effect or closure kind. - | ErrorSumKindInvalid - { errorCheckingSum :: TypeSum n - , errorKind :: Kind n } - - -- | A forall where the body does not have data or witness kind. - | ErrorForallKindInvalid - { errorChecking :: Type n - , errorBody :: Type n - , errorKind :: Kind n } - - -- | A witness implication where the premise or conclusion has an invalid kind. - | ErrorWitnessImplInvalid - { errorChecking :: Type n - , errorLeftType :: Type n - , errorLeftKind :: Kind n - , errorRightType :: Type n - , errorRightKind :: Kind n } - deriving Show - - -instance (Eq n, Pretty n) => Pretty (Error n) where - ppr err - = case err of - ErrorUndefined u - -> text "Undefined type variable: " <> ppr u - - ErrorUndefinedCtor u - -> text "Undefined type constructor: " <> ppr u - - ErrorUnappliedKindFun - -> text "Can't take sort of unapplied kind function constructor." - - ErrorNakedSort s - -> text "Can't check a naked sort: " <> ppr s - - ErrorVarAnnotMismatch u t - -> vcat [ text "Type mismatch in annotation." - , text " Variable: " <> ppr u - , text " has annotation: " <> (ppr $ typeOfBound u) - , text " which conflicts with: " <> ppr t - , text " from environment." ] - - ErrorAppArgMismatch tt t1 t2 - -> vcat [ text "Core type mismatch in application." - , text " type: " <> ppr t1 - , text " does not match: " <> ppr t2 - , text " in application: " <> ppr tt ] - - ErrorAppNotFun tt t1 k1 t2 k2 - -> vcat [ text "Core type mismatch in application." - , text " cannot apply type: " <> ppr t2 - , text " of kind: " <> ppr k2 - , text " to non-function type: " <> ppr t1 - , text " of kind: " <> ppr k1 - , text " in appliction: " <> ppr tt] - - ErrorSumKindMismatch k ts ks - -> vcat - $ [ text "Core type mismatch in sum." - , text " found multiple types: " <> ppr ts - , text " with differing kinds: " <> ppr ks ] - ++ (if k /= tBot sComp - then [text " expected kind: " <> ppr k ] - else []) - - ErrorSumKindInvalid ts k - -> vcat [ text "Invalid kind for type sum." - , text " the type sum: " <> ppr ts - , text " has kind: " <> ppr k - , text " but it must be ! or $" ] - - ErrorForallKindInvalid tt t k - -> vcat [ text "Invalid kind for body of quantified type." - , text " the body type: " <> ppr t - , text " has kind: " <> ppr k - , text " but it must be * or @" - , text " when checking: " <> ppr tt ] - - ErrorWitnessImplInvalid tt t1 k1 t2 k2 - -> vcat [ text "Invalid args for witness implication." - , text " left type: " <> ppr t1 - , text " has kind: " <> ppr k1 - , text " right type: " <> ppr t2 - , text " has kind: " <> ppr k2 - , text " when checking: " <> ppr tt ] - diff --git a/DDC/Type/Check/Monad.hs b/DDC/Type/Check/Monad.hs deleted file mode 100644 --- a/DDC/Type/Check/Monad.hs +++ /dev/null @@ -1,28 +0,0 @@ - -module DDC.Type.Check.Monad - ( CheckM (..) - , throw - , result) -where - --- | Type checking monad. -data CheckM err a - = CheckM (Either err a) - -instance Monad (CheckM err) where - return x = CheckM (Right x) - (>>=) m f - = case m of - CheckM (Left err) -> CheckM (Left err) - CheckM (Right x) -> f x - - --- | Throw a type error in the monad. -throw :: err -> CheckM err a -throw e = CheckM $ Left e - - --- | Take the result from a check monad. -result :: CheckM err a -> Either err a -result (CheckM r) = r - diff --git a/DDC/Type/Compounds.hs b/DDC/Type/Compounds.hs deleted file mode 100644 --- a/DDC/Type/Compounds.hs +++ /dev/null @@ -1,425 +0,0 @@ -{-# OPTIONS -fno-warn-missing-signatures #-} -module DDC.Type.Compounds - ( -- * Binds - takeNameOfBind - , typeOfBind - , replaceTypeOfBind - - -- * Binders - , binderOfBind - , makeBindFromBinder - , partitionBindsByType - - -- * Bounds - , typeOfBound - , takeNameOfBound - , replaceTypeOfBound - , boundMatchesBind - , namedBoundMatchesBind - , takeSubstBoundOfBind - - -- * Type structure - , tIx - , tApp, ($:) - , tApps, takeTApps - , takeTyConApps, takeDataTyConApps - , tForall - , tForalls, takeTForalls - , tBot - , tSum - - -- * Function type construction - , kFun - , kFuns, takeKFun - , takeKFuns, takeKFuns', takeResultKind - , tFun, takeTFun, takeTFunArgResult - , tFunPE - , tImpl - - -- * Sort construction - , sComp, sProp - - -- * Kind construction - , kData, kRegion, kEffect, kClosure, kWitness - - -- * Effect type constructors - , tRead, tDeepRead, tHeadRead - , tWrite, tDeepWrite - , tAlloc, tDeepAlloc - - -- * Closure type constructors. - , tUse, tDeepUse - - -- * Witness type constructors. - , tPure - , tEmpty - , tGlobal, tDeepGlobal - , tConst, tDeepConst - , tMutable, tDeepMutable - , tLazy, tHeadLazy - , tManifest - , tConData0, tConData1) -where -import DDC.Type.Exp -import qualified DDC.Type.Sum as Sum - - --- Binds ---------------------------------------------------------------------- --- | Take the variable name of a bind. --- If this is an anonymous binder then there won't be a name. -takeNameOfBind :: Bind n -> Maybe n -takeNameOfBind bb - = case bb of - BName n _ -> Just n - BAnon _ -> Nothing - BNone _ -> Nothing - - --- | Take the type of a bind. -typeOfBind :: Bind n -> Type n -typeOfBind bb - = case bb of - BName _ t -> t - BAnon t -> t - BNone t -> t - - --- | Replace the type of a bind with a new one. -replaceTypeOfBind :: Type n -> Bind n -> Bind n -replaceTypeOfBind t bb - = case bb of - BName n _ -> BName n t - BAnon _ -> BAnon t - BNone _ -> BNone t - - --- Binders -------------------------------------------------------------------- --- | Take the binder of a bind. -binderOfBind :: Bind n -> Binder n -binderOfBind bb - = case bb of - BName n _ -> RName n - BAnon _ -> RAnon - BNone _ -> RNone - - --- | Make a bind from a binder and its type. -makeBindFromBinder :: Binder n -> Type n -> Bind n -makeBindFromBinder bb t - = case bb of - RName n -> BName n t - RAnon -> BAnon t - RNone -> BNone t - - --- | Make lists of binds that have the same type. -partitionBindsByType :: Eq n => [Bind n] -> [([Binder n], Type n)] -partitionBindsByType [] = [] -partitionBindsByType (b:bs) - = let t = typeOfBind b - bsSame = takeWhile (\b' -> typeOfBind b' == t) bs - rs = map binderOfBind (b:bsSame) - in (rs, t) : partitionBindsByType (drop (length bsSame) bs) - - --- Bounds --------------------------------------------------------------------- --- | Take the type of a bound variable. -typeOfBound :: Bound n -> Type n -typeOfBound uu - = case uu of - UName _ t -> t - UPrim _ t -> t - UIx _ t -> t - - --- | Take the name of bound variable. --- If this is a deBruijn index then there won't be a name. -takeNameOfBound :: Bound n -> Maybe n -takeNameOfBound uu - = case uu of - UName n _ -> Just n - UPrim n _ -> Just n - UIx _ _ -> Nothing - - --- | Replace the type of a bound with a new one. -replaceTypeOfBound :: Type n -> Bound n -> Bound n -replaceTypeOfBound t uu - = case uu of - UName n _ -> UName n t - UPrim n _ -> UPrim n t - UIx i _ -> UIx i t - - --- | Check whether a bound maches a bind. --- `UName` and `BName` match if they have the same name. --- @UIx 0 _@ and @BAnon _@ always match. --- Yields `False` for other combinations of bounds and binds. -boundMatchesBind :: Eq n => Bound n -> Bind n -> Bool -boundMatchesBind u b - = case (u, b) of - (UName n1 _, BName n2 _) -> n1 == n2 - (UIx 0 _, BAnon _ ) -> True - _ -> False - - --- | Check whether a named bound matches a named bind. --- Yields `False` if they are not named or have different names. -namedBoundMatchesBind :: Eq n => Bound n -> Bind n -> Bool -namedBoundMatchesBind u b - = case (u, b) of - (UName n1 _, BName n2 _) -> n1 == n2 - _ -> False - - - --- | Convert a `Bound` to a `Bind`, ready for substitution. --- --- Returns `UName` for `BName`, @UIx 0@ for `BAnon` --- and `Nothing` for `BNone`, because there's nothing to substitute. -takeSubstBoundOfBind :: Bind n -> Maybe (Bound n) -takeSubstBoundOfBind bb - = case bb of - BName n t -> Just $ UName n t - BAnon t -> Just $ UIx 0 t - BNone _ -> Nothing - - --- Variables ------------------------------------------------------------------ --- | Construct a deBruijn index. -tIx :: Kind n -> Int -> Type n -tIx k i = TVar (UIx i k) - - --- Applications --------------------------------------------------------------- --- | Construct an empty type sum. -tBot :: Kind n -> Type n -tBot k = TSum $ Sum.empty k - - --- | Construct a type application. -tApp, ($:) :: Type n -> Type n -> Type n -tApp = TApp -($:) = TApp - --- | Construct a sequence of type applications. -tApps :: Type n -> [Type n] -> Type n -tApps t1 ts = foldl TApp t1 ts - - --- | Flatten a sequence ot type applications into the function part and --- arguments, if any. -takeTApps :: Type n -> [Type n] -takeTApps tt - = case tt of - TApp t1 t2 -> takeTApps t1 ++ [t2] - _ -> [tt] - - --- | Flatten a sequence of type applications, returning the type constructor --- and arguments, if there is one. -takeTyConApps :: Type n -> Maybe (TyCon n, [Type n]) -takeTyConApps tt - = case takeTApps tt of - TCon tc : args -> Just $ (tc, args) - _ -> Nothing - - --- | Flatten a sequence of type applications, returning the type constructor --- and arguments, if there is one. Only accept data type constructors. -takeDataTyConApps :: Type n -> Maybe (TyCon n, [Type n]) -takeDataTyConApps tt - = case takeTApps tt of - TCon tc : args - | TyConBound (UName _ t) <- tc - , TCon (TyConKind KiConData) <- takeResultKind t - -> Just (tc, args) - - | TyConBound (UPrim _ t) <- tc - , TCon (TyConKind KiConData) <- takeResultKind t - -> Just (tc, args) - - _ -> Nothing - - --- Foralls -------------------------------------------------------------------- --- | Build an anonymous type abstraction, with a single parameter. -tForall :: Kind n -> (Type n -> Type n) -> Type n -tForall k f - = TForall (BAnon k) (f (TVar (UIx 0 k))) - - --- | Build an anonymous type abstraction, with several parameters. -tForalls :: [Kind n] -> ([Type n] -> Type n) -> Type n -tForalls ks f - = let bs = [BAnon k | k <- ks] - us = reverse [TVar (UIx n k) | k <- ks | n <- [0..]] - in foldr TForall (f us) bs - - --- | Split nested foralls from the front of a type, --- or `Nothing` if there was no outer forall. -takeTForalls :: Type n -> Maybe ([Bind n], Type n) -takeTForalls tt - = let go bs (TForall b t) = go (b:bs) t - go bs t = (reverse bs, t) - in case go [] tt of - ([], _) -> Nothing - (bs, body) -> Just (bs, body) - - --- Sums ----------------------------------------------------------------------- -tSum :: Ord n => Kind n -> [Type n] -> Type n -tSum k ts - = TSum (Sum.fromList k ts) - - --- Function Constructors ------------------------------------------------------ --- | Construct a kind function. -kFun :: Kind n -> Kind n -> Kind n -kFun k1 k2 = ((TCon $ TyConKind KiConFun)`TApp` k1) `TApp` k2 - -infixr `kFun` - - --- | Construct some kind functions. -kFuns :: [Kind n] -> Kind n -> Kind n -kFuns [] k1 = k1 -kFuns (k:ks) k1 = k `kFun` kFuns ks k1 - - --- | Destruct a kind function -takeKFun :: Kind n -> Maybe (Kind n, Kind n) -takeKFun kk - = case kk of - TApp (TApp (TCon (TyConKind KiConFun)) k1) k2 - -> Just (k1, k2) - _ -> Nothing - - --- | Destruct a chain of kind functions into the arguments -takeKFuns :: Kind n -> ([Kind n], Kind n) -takeKFuns kk - = case kk of - TApp (TApp (TCon (TyConKind KiConFun)) k1) k2 - | (ks, k2') <- takeKFuns k2 - -> (k1 : ks, k2') - - _ -> ([], kk) - - --- | Like `takeKFuns`, but return argument and return kinds in the same list. -takeKFuns' :: Kind n -> [Kind n] -takeKFuns' kk - | (ks, k1) <- takeKFuns kk - = ks ++ [k1] - - --- | Take the result kind of a kind function, or return the same kind --- unharmed if it's not a kind function. -takeResultKind :: Kind n -> Kind n -takeResultKind kk - = case kk of - TApp (TApp (TCon (TyConKind KiConFun)) _) k2 - -> takeResultKind k2 - _ -> kk - - --- | Construct a value type function, --- with the provided effect and closure. -tFun :: Type n -> Effect n -> Closure n -> Type n -> Type n -tFun t1 eff clo t2 - = (TCon $ TyConSpec TcConFun) `tApps` [t1, eff, clo, t2] - -infixr `tFun` - - --- | Destruct the type of a value function. -takeTFun :: Type n -> Maybe (Type n, Effect n, Closure n, Type n) -takeTFun tt - = case tt of - TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFun)) t1) eff) clo) t2 - -> Just (t1, eff, clo, t2) - _ -> Nothing - - --- | Destruct the type of a value function, returning just the argument --- and result types. -takeTFunArgResult :: Type n -> ([Type n], Type n) -takeTFunArgResult tt - = case tt of - TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFun)) t1) _eff) _clo) t2 - -> let (tsMore, tResult) = takeTFunArgResult t2 - in (t1 : tsMore, tResult) - - _ -> ([], tt) - - --- | Construct a pure and empty value type function. -tFunPE :: Type n -> Type n -> Type n -tFunPE t1 t2 = tFun t1 (tBot kEffect) (tBot kClosure) t2 - - --- | Construct a witness implication type. -tImpl :: Type n -> Type n -> Type n -tImpl t1 t2 - = ((TCon $ TyConWitness TwConImpl) `tApp` t1) `tApp` t2 - -infixr `tImpl` - - --- Level 3 constructors (sorts) ----------------------------------------------- -sComp = TCon $ TyConSort SoConComp -sProp = TCon $ TyConSort SoConProp - - --- Level 2 constructors (kinds) ----------------------------------------------- -kData = TCon $ TyConKind KiConData -kRegion = TCon $ TyConKind KiConRegion -kEffect = TCon $ TyConKind KiConEffect -kClosure = TCon $ TyConKind KiConClosure -kWitness = TCon $ TyConKind KiConWitness - - --- Level 1 constructors (witness and computation types) ----------------------- - --- Effect type constructors -tRead = tcCon1 TcConRead -tHeadRead = tcCon1 TcConHeadRead -tDeepRead = tcCon1 TcConDeepRead -tWrite = tcCon1 TcConWrite -tDeepWrite = tcCon1 TcConDeepWrite -tAlloc = tcCon1 TcConAlloc -tDeepAlloc = tcCon1 TcConDeepAlloc - --- Closure type constructors. -tUse = tcCon1 TcConUse -tDeepUse = tcCon1 TcConDeepUse - --- Witness type constructors. -tPure = twCon1 TwConPure -tEmpty = twCon1 TwConEmpty -tGlobal = twCon1 TwConGlobal -tDeepGlobal = twCon1 TwConDeepGlobal -tConst = twCon1 TwConConst -tDeepConst = twCon1 TwConDeepConst -tMutable = twCon1 TwConMutable -tDeepMutable = twCon1 TwConDeepMutable -tLazy = twCon1 TwConLazy -tHeadLazy = twCon1 TwConHeadLazy -tManifest = twCon1 TwConManifest - -tcCon1 tc t = (TCon $ TyConSpec tc) `tApp` t -twCon1 tc t = (TCon $ TyConWitness tc) `tApp` t - - --- | Build a nullary type constructor of the given kind. -tConData0 :: n -> Kind n -> Type n -tConData0 n k = TCon (TyConBound (UName n k)) - - --- | Build a type constructor application of one argumnet. -tConData1 :: n -> Kind n -> Type n -> Type n -tConData1 n k t1 = TApp (TCon (TyConBound (UName n k))) t1 - - diff --git a/DDC/Type/DataDef.hs b/DDC/Type/DataDef.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/DataDef.hs @@ -0,0 +1,273 @@ + +-- | Algebraic data type definitions. +module DDC.Type.DataDef + ( DataDef (..) + , kindOfDataDef + , dataTypeOfDataDef + , dataCtorNamesOfDataDef + , makeDataDefAlg + , makeDataDefAbs + + -- * Data type definition table + , DataDefs (..) + + , DataMode (..) + , emptyDataDefs + , insertDataDef + , unionDataDefs + , fromListDataDefs + + , DataType (..) + , kindOfDataType + , lookupModeOfDataType + + , DataCtor (..) + , typeOfDataCtor) +where +import DDC.Type.Exp +import DDC.Type.Exp.Simple.Compounds +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import Control.Monad +import Control.DeepSeq + + +--------------------------------------------------------------------------------------------------- +-- | The definition of a single data type. +data DataDef n + = DataDef + { -- | Name of the data type. + dataDefTypeName :: !n + + -- | Binders for type parameters. + , dataDefParams :: ![Bind n] + + -- | Constructors of the data type, + -- or Nothing if the data type is algbraic but there are too many + -- constructors to list (like with `Int`). + , dataDefCtors :: !(Maybe [DataCtor n]) + + -- | Whether the data type is algebraic. + -- These can be deconstructed with 'case' expressions. + , dataDefIsAlgebraic :: Bool } + deriving Show + + +instance NFData n => NFData (DataDef n) where + rnf !def + = rnf (dataDefTypeName def) + `seq` rnf (dataDefParams def) + `seq` rnf (dataDefCtors def) + `seq` rnf (dataDefIsAlgebraic def) + + +-- | Get the kind of the type constructor defined by a `DataDef`. +kindOfDataDef :: DataDef n -> Kind n +kindOfDataDef def + = let ksParam = map typeOfBind $ dataDefParams def + in kFuns ksParam kData + + +-- | Get the type associated with a data definition, +-- that is, the type produced by the constructors. +dataTypeOfDataDef :: DataDef n -> Type n +dataTypeOfDataDef def + = let usParam = takeSubstBoundsOfBinds $ dataDefParams def + ksParam = map typeOfBind $ dataDefParams def + tc = TyConBound (UName (dataDefTypeName def)) + (kFuns ksParam kData) + in tApps (TCon tc) (map TVar usParam) + + +-- | Get the list of data constructor names that this type defines, +-- or Nothing if there are too many to list. +dataCtorNamesOfDataDef :: DataDef n -> Maybe [n] +dataCtorNamesOfDataDef def + = case dataDefCtors def of + Nothing -> Nothing + Just ctors -> Just $ map dataCtorName ctors + + +-- | Shortcut for constructing a `DataDef` for an algebraic type. +-- +-- Values of algebraic type can be deconstructed with case-expressions. +makeDataDefAlg + :: n -- ^ Name of data type. + -> [Bind n] -- ^ Type parameters. + -> Maybe [(n, [Type n])] + -- ^ Constructor names and field types, + -- or `Nothing` if there are too many to list. + -> DataDef n + +makeDataDefAlg nData bsParam Nothing + = DataDef + { dataDefTypeName = nData + , dataDefParams = bsParam + , dataDefCtors = Nothing + , dataDefIsAlgebraic = True } + +makeDataDefAlg nData bsParam (Just ntsField) + = let usParam = takeSubstBoundsOfBinds bsParam + ksParam = map typeOfBind bsParam + tc = TyConBound (UName nData) + (kFuns ksParam kData) + + tResult = tApps (TCon tc) (map TVar usParam) + + ctors = [ DataCtor n tag tsField tResult nData bsParam + | tag <- [0..] + | (n, tsField) <- ntsField] + in DataDef + { dataDefTypeName = nData + , dataDefParams = bsParam + , dataDefCtors = Just ctors + , dataDefIsAlgebraic = True } + + +-- | Shortcut for constructing a `DataDef` for an abstract type. +-- +-- Values of abstract type cannot be deconstructed with case-expressions. +makeDataDefAbs :: n -> [Bind n] -> DataDef n +makeDataDefAbs nData bsParam + = DataDef + { dataDefTypeName = nData + , dataDefParams = bsParam + , dataDefCtors = Just [] + , dataDefIsAlgebraic = False } + + +-- DataDefs --------------------------------------------------------------------------------------- +-- | A table of data type definitions, +-- unpacked into type and data constructors so we can find them easily. +data DataDefs n + = DataDefs + { dataDefsTypes :: !(Map n (DataType n)) + , dataDefsCtors :: !(Map n (DataCtor n)) } + deriving Show + + +-- | The mode of a data type records how many data constructors there are. +-- This can be set to 'Large' for large primitive types like Int and Float. +-- In this case we don't ever expect them all to be enumerated +-- as case alternatives. +data DataMode n + = DataModeSmall ![n] + | DataModeLarge + deriving Show + + +-- | Describes a data type constructor, used in the `DataDefs` table. +data DataType n + = DataType + { -- | Name of data type constructor. + dataTypeName :: !n + + -- | Kinds of type parameters to constructor. + , dataTypeParams :: ![Bind n] + + -- | Names of data constructors of this data type, + -- or `Nothing` if it has infinitely many constructors. + , dataTypeMode :: !(DataMode n) + + -- | Whether the data type is algebraic. + , dataTypeIsAlgebraic :: Bool } + deriving Show + + +-- | Describes a data constructor, used in the `DataDefs` table. +data DataCtor n + = DataCtor + { -- | Name of data constructor. + dataCtorName :: !n + + -- | Tag of constructor (order in data type declaration) + , dataCtorTag :: !Integer + + -- | Field types of constructor. + , dataCtorFieldTypes :: ![Type n] + + -- | Result type of constructor. + , dataCtorResultType :: !(Type n) + + -- | Name of result type of constructor. + , dataCtorTypeName :: !n + + -- | Parameters of data type + , dataCtorTypeParams :: ![Bind n] } + deriving Show + + +-- | Get the type of `DataCtor` +typeOfDataCtor :: DataCtor n -> Type n +typeOfDataCtor ctor + = let Just t = tFunOfList ( dataCtorFieldTypes ctor + ++ [dataCtorResultType ctor] ) + in foldr TForall t (dataCtorTypeParams ctor) + + +instance NFData n => NFData (DataCtor n) where + rnf (DataCtor n t fs tR nT bsParam) + = rnf n `seq` rnf t `seq` rnf fs `seq` rnf tR `seq` rnf nT `seq` rnf bsParam + + +instance Ord n => Monoid (DataDefs n) where + mempty = emptyDataDefs + mappend = unionDataDefs + + +-- | An empty table of data type definitions. +emptyDataDefs :: DataDefs n +emptyDataDefs + = DataDefs + { dataDefsTypes = Map.empty + , dataDefsCtors = Map.empty } + + +-- | Union two `DataDef` tables. +unionDataDefs :: Ord n => DataDefs n -> DataDefs n -> DataDefs n +unionDataDefs defs1 defs2 + = DataDefs + { dataDefsTypes = Map.union (dataDefsTypes defs1) (dataDefsTypes defs2) + , dataDefsCtors = Map.union (dataDefsCtors defs1) (dataDefsCtors defs2) } + + +-- | Insert a data type definition into some DataDefs. +insertDataDef :: Ord n => DataDef n -> DataDefs n -> DataDefs n +insertDataDef (DataDef nType bsParam mCtors isAlg) dataDefs + = let defType = DataType + { dataTypeName = nType + , dataTypeParams = bsParam + , dataTypeMode = defMode + , dataTypeIsAlgebraic = isAlg } + + defMode = case mCtors of + Nothing -> DataModeLarge + Just ctors -> DataModeSmall (map dataCtorName ctors) + + in dataDefs + { dataDefsTypes = Map.insert nType defType (dataDefsTypes dataDefs) + , dataDefsCtors = Map.union (dataDefsCtors dataDefs) + $ Map.fromList [(n, def) + | def@(DataCtor n _ _ _ _ _) <- concat $ maybeToList mCtors ]} + + +-- | Build a `DataDefs` table from a list of `DataDef` +fromListDataDefs :: Ord n => [DataDef n] -> DataDefs n +fromListDataDefs defs + = foldr insertDataDef emptyDataDefs defs + + +-- | Yield the list of data constructor names for some data type, +-- or `Nothing` for large types with too many constructors to list. +lookupModeOfDataType :: Ord n => n -> DataDefs n -> Maybe (DataMode n) +lookupModeOfDataType n defs + = liftM dataTypeMode $ Map.lookup n (dataDefsTypes defs) + + +-- | Get the kind of the type constructor defined by a `DataDef`. +kindOfDataType :: DataType n -> Kind n +kindOfDataType def + = let ksParam = map typeOfBind $ dataTypeParams def + in kFuns ksParam kData + diff --git a/DDC/Type/Env.hs b/DDC/Type/Env.hs --- a/DDC/Type/Env.hs +++ b/DDC/Type/Env.hs @@ -8,24 +8,44 @@ -- module DDC.Type.Env ( Env(..) + , SuperEnv + , KindEnv + , TypeEnv + + -- * Construction , empty - , extend, extends - , setPrimFun, isPrim - , fromList + , singleton + , extend + , extends , union - , member, memberBind - , lookup, lookupName + , unions + + -- * Conversion + , fromList + , fromListNT + , fromTypeMap + + -- * Projections , depth - , lift - , wrapTForalls) + , member + , memberBind + , lookup + , lookupName + + -- * Primitives + , setPrimFun + , isPrim + + -- * Lifting + , lift) where import DDC.Type.Exp -import DDC.Type.Transform.LiftT +import DDC.Type.Transform.BoundT import Data.Maybe -import Data.Map (Map) -import Prelude hiding (lookup) -import qualified Data.Map as Map -import qualified Prelude as P +import Data.Map (Map) +import Prelude hiding (lookup) +import qualified Data.Map.Strict as Map +import qualified Prelude as P import Control.Monad @@ -33,18 +53,28 @@ data Env n = Env { -- | Types of named binders. - envMap :: Map n (Type n) + envMap :: !(Map n (Type n)) -- | Types of anonymous deBruijn binders. - , envStack :: [Type n] + , envStack :: ![Type n] -- | The length of the above stack. - , envStackLength :: Int + , envStackLength :: !Int -- | Types of baked in, primitive names. - , envPrimFun :: n -> Maybe (Type n) } + , envPrimFun :: !(n -> Maybe (Type n)) } +-- | Type synonym to improve readability. +type SuperEnv n = Env n + +-- | Type synonym to improve readability. +type KindEnv n = Env n + +-- | Type synonym to improve readability. +type TypeEnv n = Env n + + -- | An empty environment. empty :: Env n empty = Env @@ -54,6 +84,12 @@ , envPrimFun = \_ -> Nothing } +-- | Construct a singleton type environment. +singleton :: Ord n => Bind n -> Env n +singleton b + = extend b empty + + -- | Extend an environment with a new binding. -- Replaces bindings with the same name already in the environment. extend :: Ord n => Bind n -> Env n -> Env n @@ -90,6 +126,18 @@ = foldr extend empty bs +-- | Convert a list of name and types into an environment +fromListNT :: Ord n => [(n, Type n)] -> Env n +fromListNT nts + = fromList [BName n t | (n, t) <- nts] + + +-- | Convert a map of names to types to a environment. +fromTypeMap :: Map n (Type n) -> Env n +fromTypeMap m + = empty { envMap = m} + + -- | Combine two environments. -- If both environments have a binding with the same name, -- then the one in the second environment takes preference. @@ -102,6 +150,13 @@ , envPrimFun = \n -> envPrimFun env2 n `mplus` envPrimFun env1 n } +-- | Combine multiple environments, +-- with the latter ones taking preference. +unions :: Ord n => [Env n] -> Env n +unions envs + = foldr union empty envs + + -- | Check whether a bound variable is present in an environment. member :: Ord n => Bound n -> Env n -> Bool member uu env @@ -121,21 +176,19 @@ lookup :: Ord n => Bound n -> Env n -> Maybe (Type n) lookup uu env = case uu of - UName n _ + UName n -> Map.lookup n (envMap env) `mplus` envPrimFun env n - UIx i _ - -> P.lookup i (zip [0..] (envStack env)) - - UPrim n _ - -> envPrimFun env n + UIx i -> P.lookup i (zip [0..] (envStack env)) + UPrim n _ -> envPrimFun env n -- | Lookup a bound name from an environment. lookupName :: Ord n => n -> Env n -> Maybe (Type n) lookupName n env - = Map.lookup n (envMap env) + = Map.lookup n (envMap env) + `mplus` (envPrimFun env n) -- | Yield the total depth of the deBruijn stack. @@ -144,8 +197,13 @@ -- | Lift all free deBruijn indices in the environment by the given number of steps. --- TODO: Delay this, only lift when we extract the final type. --- will also need to update the 'member' function. +--- +-- ISSUE #276: Delay lifting of indices in type environments. +-- The 'lift' function on type environments applies to every member of +-- the environment. We'd get better complexity by recording how many +-- levels all types should be lifted by, and only applying the real lift +-- function when the type is finally extracted. +-- lift :: Ord n => Int -> Env n -> Env n lift n env = Env @@ -153,15 +211,4 @@ , envStack = map (liftT n) (envStack env) , envStackLength = envStackLength env , envPrimFun = envPrimFun env } - - --- | Wrap locally bound (non primitive) variables defined in an environment --- around a type as new foralls. -wrapTForalls :: Ord n => Env n -> Type n -> Type n -wrapTForalls env tBody - = let bsNamed = [BName b t | (b, t) <- Map.toList $ envMap env ] - bsAnon = [BAnon t | t <- envStack env] - - tInner = foldr TForall tBody (reverse bsAnon) - in foldr TForall tInner bsNamed diff --git a/DDC/Type/Equiv.hs b/DDC/Type/Equiv.hs deleted file mode 100644 --- a/DDC/Type/Equiv.hs +++ /dev/null @@ -1,149 +0,0 @@ - -module DDC.Type.Equiv - (equivT) -where -import DDC.Type.Exp -import DDC.Type.Compounds -import DDC.Type.Transform.Crush -import DDC.Type.Transform.Trim -import DDC.Base.Pretty -import Data.Maybe -import qualified DDC.Type.Sum as Sum - - --- | Check equivalence of types. --- --- Checks equivalence up to alpha-renaming, as well as crushing of effects --- and trimming of closures. --- --- * Return `False` if we find any free variables. --- --- * We assume the types are well-kinded, so that the type annotations on --- bound variables match the binders. If this is not the case then you get --- an indeterminate result. --- -equivT :: (Ord n, Pretty n) => Type n -> Type n -> Bool -equivT t1 t2 - = equivT' [] 0 [] 0 t1 t2 - - -equivT' :: (Ord n, Pretty n) - => [Bind n] -> Int - -> [Bind n] -> Int - -> Type n -> Type n - -> Bool - -equivT' stack1 depth1 stack2 depth2 t1 t2 - = let t1' = unpackSumT $ crushSomeT t1 - t2' = unpackSumT $ crushSomeT t2 - in case (t1', t2') of - (TVar u1, TVar u2) - -- Bound variables are name-equivalent. - | u1 == u2 -> True - - -- Variables aren't name equivalent, - -- but would be equivalent if we renamed them. - | depth1 == depth2 - , Just (ix1, t1a) <- getBindType stack1 u1 - , Just (ix2, t2a) <- getBindType stack2 u2 - , ix1 == ix2 - -> equivT' stack1 depth1 stack2 depth2 t1a t2a - - -- Constructor names must be equal. - (TCon tc1, TCon tc2) - -> tc1 == tc2 - - -- Push binders on the stack as we enter foralls. - (TForall b11 t12, TForall b21 t22) - | equivT (typeOfBind b11) (typeOfBind b21) - -> equivT' (b11 : stack1) (depth1 + 1) - (b21 : stack2) (depth2 + 1) - t12 t22 - - -- Decend into applications. - (TApp t11 t12, TApp t21 t22) - -> equivT' stack1 depth1 stack2 depth2 t11 t21 - && equivT' stack1 depth1 stack2 depth2 t12 t22 - - -- Sums are equivalent if all of their components are. - (TSum ts1, TSum ts2) - -> let ts1' = Sum.toList ts1 - ts2' = Sum.toList ts2 - equiv = equivT' stack1 depth1 stack2 depth2 - - -- If all the components of the sum were in the element - -- arrays then they come out of Sum.toList sorted - -- and we can compare corresponding pairs. - checkFast = and $ zipWith equiv ts1' ts2' - - -- If any of the components use a higher kinded type variable - -- like (c : % ~> !) then they won't nessesarally be sorted, - -- so we need to do this slower O(n^2) check. - checkSlow = and [ or (map (equiv t1c) ts2') | t1c <- ts1' ] - && and [ or (map (equiv t2c) ts1') | t2c <- ts2' ] - - in (length ts1' == length ts2') - && (checkFast || checkSlow) - - (_, _) -> False - - --- | Unpack single element sums into plain types. -unpackSumT :: Type n -> Type n -unpackSumT (TSum ts) - | [t] <- Sum.toList ts = t -unpackSumT tt = tt - - --- | Crush compound effects and closure terms. --- We check for a crushable term before calling crushT because that function --- will recursively crush the components. --- As equivT is already recursive, we don't want a doubly-recursive function --- that tries to re-crush the same non-crushable type over and over. --- -crushSomeT :: (Ord n, Pretty n) => Type n -> Type n -crushSomeT tt - = case tt of - (TApp (TCon tc) _) - -> case tc of - TyConSpec TcConDeepRead -> crushEffect tt - TyConSpec TcConDeepWrite -> crushEffect tt - TyConSpec TcConDeepAlloc -> crushEffect tt - - -- If a closure is miskinded then 'trimClosure' - -- can return Nothing, so we just leave the term untrimmed. - TyConSpec TcConDeepUse -> fromMaybe tt (trimClosure tt) - - TyConWitness TwConDeepGlobal -> crushEffect tt - _ -> tt - - _ -> tt - - --- | Lookup the type of a bound thing from the binder stack. --- The binder stack contains the binders of all the `TForall`s we've --- entered under so far. -getBindType :: Eq n => [Bind n] -> Bound n -> Maybe (Int, Type n) -getBindType bs' u - = go 0 bs' - where go n (BName n1 t : bs) - | UName n2 _ <- u - , n1 == n2 = Just (n, t) - | otherwise = go (n + 1) bs - - - go n (BAnon t : bs) - | UIx i _ <- u - , i == 0 = Just (n, t) - - | UIx i _ <- u - , i < 0 = Nothing - - | otherwise = go (n + 1) bs - - - go n (BNone _ : bs) - = go (n + 1) bs - - go _ [] = Nothing - diff --git a/DDC/Type/Exp.hs b/DDC/Type/Exp.hs --- a/DDC/Type/Exp.hs +++ b/DDC/Type/Exp.hs @@ -1,10 +1,7 @@ module DDC.Type.Exp ( -- * Types, Kinds, and Sorts - Binder (..) - , Bind (..) - , Bound (..) - , Type (..) + Type (..) , Kind, Sort , Region, Effect, Closure , TypeSum (..), TyConHash(..), TypeSumVarCon(..) @@ -12,260 +9,11 @@ , SoCon (..) , KiCon (..) , TwCon (..) - , TcCon (..)) + , TcCon (..) + , Binder (..) + , Bind (..) + , Bound (..)) where -import Data.Array -import Data.Map (Map) -import Data.Set (Set) - - --- Bind ----------------------------------------------------------------------- --- | A variable binder. -data Binder n - = RNone - | RAnon - | RName n - deriving Show - - --- | A variable binder with its type. -data Bind n - -- | A variable with no uses in the body doesn't need a name. - = BNone (Type n) - - -- | Nameless variable on the deBruijn stack. - | BAnon (Type n) - - -- | Named variable in the environment. - | BName n (Type n) - deriving Show - - - --- | A bound occurrence of a variable, with its type. --- --- If variable hasn't been annotated with its real type then this --- can be `tBot` (an empty sum). - -data Bound n - -- | Nameless variable that should be on the deBruijn stack. - = UIx Int (Type n) - - -- | Named variable that should be in the environment. - | UName n (Type n) - - -- | Named primitive that is not bound in the environment. - -- Prims aren't every counted as being free. - | UPrim n (Type n) - deriving Show - - --- Types ---------------------------------------------------------------------- --- | A value type, kind, or sort. --- --- We use the same data type to represent all three universes, as they have --- a similar algebraic structure. --- -data Type n - -- | Variable. - = TVar (Bound n) - - -- | Constructor. - | TCon (TyCon n) - - -- | Abstraction. - | TForall (Bind n) (Type n) - - -- | Application. - | TApp (Type n) (Type n) - - -- | Least upper bound. - | TSum (TypeSum n) - deriving Show - - -type Sort n = Type n -type Kind n = Type n -type Region n = Type n -type Effect n = Type n -type Closure n = Type n - - --- Type Sums ------------------------------------------------------------------ --- | A least upper bound of several types. --- --- We keep type sums in this normalised format instead of joining them --- together with a binary operator (like @(+)@). This makes sums easier to work --- with, as a given sum type often only has a single physical representation. -data TypeSum n - = TypeSum - { -- | The kind of the elements in this sum. - typeSumKind :: Kind n - - -- | Where we can see the outer constructor of a type, its argument - -- is inserted into this array. This handles common cases like - -- Read, Write, Alloc effects. - , typeSumElems :: Array TyConHash (Set (TypeSumVarCon n)) - - -- | A map for named type variables. - , typeSumBoundNamed :: Map n (Kind n) - - -- | A map for anonymous type variables. - , typeSumBoundAnon :: Map Int (Kind n) - - -- | Types that can't be placed in the other fields go here. - -- - -- INVARIANT: this list doesn't contain more `TSum`s. - , typeSumSpill :: [Type n] } - deriving (Show) - - --- | Hash value used to insert types into the `typeSumElems` array of a `TypeSum`. -data TyConHash - = TyConHash !Int - deriving (Eq, Show, Ord, Ix) - - --- | Wraps a variable or constructor that can be added the `typeSumElems` array. -data TypeSumVarCon n - = TypeSumVar (Bound n) - | TypeSumCon (Bound n) - deriving Show - - --- TyCon ---------------------------------------------------------------------- --- | Kind, type and witness constructors. --- --- These are grouped to make it easy to determine the universe that they --- belong to. --- -data TyCon n - -- | (level 3) Builtin Sort constructors. - = TyConSort SoCon - - -- | (level 2) Builtin Kind constructors. - | TyConKind KiCon - - -- | (level 1) Builtin Spec constructors for the types of witnesses. - | TyConWitness TwCon - - -- | (level 1) Builtin Spec constructors for types of other kinds. - | TyConSpec TcCon - - -- | User defined and primitive constructors. - | TyConBound (Bound n) - deriving Show - - --- | Sort constructor. -data SoCon - -- | Sort of witness kinds. - = SoConProp -- '@@' - - -- | Sort of computation kinds. - | SoConComp -- '**' - deriving (Eq, Show) - - --- | Kind constructor. -data KiCon - -- | Function kind constructor. - -- This is only well formed when it is fully applied. - = KiConFun -- (~>) - - -- Witness kinds ------------------------ - -- | Kind of witnesses. - | KiConWitness -- '@ :: @@' - - -- Computation kinds --------------------- - -- | Kind of data values. - | KiConData -- '* :: **' - - -- | Kind of regions. - | KiConRegion -- '% :: **' - - -- | Kind of effects. - | KiConEffect -- '! :: **' - - -- | Kind of closures. - | KiConClosure -- '$ :: **' - deriving (Eq, Show) - - --- | Witness type constructors. -data TwCon - -- Witness implication. - = TwConImpl -- :: '(=>) :: * ~> *' - - -- | Purity of some effect. - | TwConPure -- :: ! ~> @ - - -- | Emptiness of some closure. - | TwConEmpty -- :: $ ~> @ - - -- | Globalness of some region. - | TwConGlobal -- :: % ~> @ - - -- | Globalness of material regions in some type. - | TwConDeepGlobal -- :: * ~> @ - - -- | Constancy of some region. - | TwConConst -- :: % ~> @ - - -- | Constancy of material regions in some type - | TwConDeepConst -- :: * ~> @ - - -- | Mutability of some region. - | TwConMutable -- :: % ~> @ - - -- | Mutability of material regions in some type. - | TwConDeepMutable -- :: * ~> @ - - -- | Laziness of some region. - | TwConLazy -- :: % ~> @ - - -- | Laziness of the primary region in some type. - | TwConHeadLazy -- :: * ~> @ - - -- | Manifestness of some region (not lazy). - | TwConManifest -- :: % ~> @ - deriving (Eq, Show) - - --- | Other constructors at the spec level. -data TcCon - -- Data type constructors --------------- - -- | The function type constructor is baked in so we - -- represent it separately. - = TcConFun -- '(->) :: * ~> * ~> ! ~> $ ~> *' - - -- Effect type constructors ------------- - -- | Read of some region. - | TcConRead -- :: '% ~> !' - - -- | Read the head region in a data type. - | TcConHeadRead -- :: '* ~> !' - - -- | Read of all material regions in a data type. - | TcConDeepRead -- :: '* ~> !' - - -- | Write of some region. - | TcConWrite -- :: '% ~> !' - - -- | Write to all material regions in some data type. - | TcConDeepWrite -- :: '* ~> !' - - -- | Allocation into some region. - | TcConAlloc -- :: '% ~> !' - - -- | Allocation into all material regions in some data type. - | TcConDeepAlloc -- :: '* ~> !' - - -- Closure type constructors ------------ - -- | Region is captured in a closure. - | TcConUse -- :: '% ~> $' - - -- | All material regions in a data type are captured in a closure. - | TcConDeepUse -- :: '* ~> $' - deriving (Eq, Show) +import DDC.Type.Exp.Simple.Exp +import DDC.Type.Exp.Simple.NFData () 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/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/Parser.hs b/DDC/Type/Parser.hs deleted file mode 100644 --- a/DDC/Type/Parser.hs +++ /dev/null @@ -1,236 +0,0 @@ - --- | Parser for type expressions. -module DDC.Type.Parser - ( module DDC.Base.Parser - , Parser - , pType, pTypeAtom, pTypeApp - , pBinder - , pIndex - , pTok, pTokAs) -where -import DDC.Core.Parser.Tokens -import DDC.Type.Exp -import DDC.Type.Compounds -import DDC.Base.Parser (()) -import qualified DDC.Base.Parser as P -import qualified DDC.Type.Sum as TS - - --- | Parser of type tokens. -type Parser n a - = P.Parser (Tok n) a - - --- | Top level parser for types. -pType :: Ord n => Parser n (Type n) -pType = pTypeSum - "a type" - - --- | Parse a type sum. -pTypeSum :: Ord n => Parser n (Type n) -pTypeSum - = do t1 <- pTypeForall - P.choice - [ -- Type sums. - -- T2 + T3 - do pTok KPlus - t2 <- pTypeSum - return $ TSum $ TS.fromList (tBot sComp) [t1, t2] - - , do return t1 ] - "a type" - - --- | Parse a binder. -pBinder :: Ord n => Parser n (Binder n) -pBinder - = P.choice - -- Named binders. - [ do v <- pVar - return $ RName v - - -- Anonymous binders. - , do pTok KHat - return $ RAnon - - -- Vacant binders. - , do pTok KUnderscore - return $ RNone ] - "a binder" - - --- | Parse a quantified type. -pTypeForall :: Ord n => Parser n (Type n) -pTypeForall - = P.choice - [ -- Universal quantification. - -- [v1 v1 ... vn : T1]. T2 - do pTok KSquareBra - bs <- P.many1 pBinder - pTok KColon - k <- pTypeSum - pTok KSquareKet - pTok KDot - - body <- pTypeForall - - return $ foldr TForall body - $ map (\b -> makeBindFromBinder b k) bs - - -- Body type - , do pTypeFun] - "a type" - - --- | Parse a function type. -pTypeFun :: Ord n => Parser n (Type n) -pTypeFun - = do t1 <- pTypeApp - P.choice - [ -- T1 ~> T2 - do pTok KArrowTilde - t2 <- pTypeFun - return $ TApp (TApp (TCon (TyConKind KiConFun)) t1) t2 - - -- T1 => T2 - , do pTok KArrowEquals - t2 <- pTypeFun - return $ TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2 - - -- T1 -> T2 - , do pTok KArrowDash - t2 <- pTypeFun - return $ t1 `tFunPE` t2 - - -- T1 -(TSUM | TSUM)> t2 - , do pTok KDash - pTok KRoundBra - eff <- pTypeSum - pTok KBar - clo <- pTypeSum - pTok KRoundKet - pTok KAngleKet - t2 <- pTypeFun - return $ tFun t1 eff clo t2 - - - -- Body type - , do return t1 ] - "an atomic type or type application" - - --- | Parse a type application. -pTypeApp :: Ord n => Parser n (Type n) -pTypeApp - = do (t:ts) <- P.many1 pTypeAtom - return $ foldl TApp t ts - "an atomic type or type application" - - --- | Parse a variable, constructor or parenthesised type. -pTypeAtom :: Ord n => Parser n (Type n) -pTypeAtom - = P.choice - -- (~>) and (=>) and (->) and (TYPE2) - [ do pTok KRoundBra - P.choice - [ do pTok KArrowTilde - pTok KRoundKet - return (TCon $ TyConKind KiConFun) - - , do pTok KArrowEquals - pTok KRoundKet - return (TCon $ TyConWitness TwConImpl) - - , do pTok KArrowDash - pTok KRoundKet - return (TCon $ TyConSpec TcConFun) - - , do t <- pTypeSum - pTok KRoundKet - return t - ] - - -- Named type constructors - , do tc <- pTcCon - return $ TCon (TyConSpec tc) - - , do tc <- pTwCon - return $ TCon (TyConWitness tc) - - , do tc <- pTyConNamed - return $ TCon tc - - -- Symbolic constructors. - , do pTokAs KSortComp (TCon $ TyConSort SoConComp) - , do pTokAs KSortProp (TCon $ TyConSort SoConProp) - , do pTokAs KKindValue (TCon $ TyConKind KiConData) - , do pTokAs KKindRegion (TCon $ TyConKind KiConRegion) - , do pTokAs KKindEffect (TCon $ TyConKind KiConEffect) - , do pTokAs KKindClosure (TCon $ TyConKind KiConClosure) - , do pTokAs KKindWitness (TCon $ TyConKind KiConWitness) - - -- Bottoms. - , do pTokAs KBotEffect (tBot kEffect) - , do pTokAs KBotClosure (tBot kClosure) - - -- Bound occurrence of a variable. - -- We don't know the kind of this variable yet, so fill in the - -- field with the bottom element of computation kinds. This isn't - -- really part of the language, but makes sense implentation-wise. - , do v <- pVar - return $ TVar (UName v (tBot sComp)) - - , do i <- pIndex - return $ TVar (UIx (fromIntegral i) (tBot sComp)) - ] - "an atomic type" - - -------------------------------------------------------------------------------- --- | Parse a builtin `TcCon` -pTcCon :: Parser n TcCon -pTcCon = P.pTokMaybe f - "a type constructor" - where f (KA (KTcConBuiltin c)) = Just c - f _ = Nothing - --- | Parse a builtin `TwCon` -pTwCon :: Parser n TwCon -pTwCon = P.pTokMaybe f - "a witness constructor" - where f (KA (KTwConBuiltin c)) = Just c - f _ = Nothing - --- | Parse a user `TcCon` -pTyConNamed :: Parser n (TyCon n) -pTyConNamed - = P.pTokMaybe f - "a type constructor" - where f (KN (KCon n)) = Just (TyConBound (UName n (tBot kData))) - f _ = Nothing - --- | Parse a variable. -pVar :: Parser n n -pVar = P.pTokMaybe f - "a variable" - where f (KN (KVar n)) = Just n - f _ = Nothing - --- | Parse a deBruijn index -pIndex :: Parser n Int -pIndex = P.pTokMaybe f - "an index" - where f (KA (KIndex i)) = Just i - f _ = Nothing - --- | Parse an atomic token. -pTok :: TokAtom -> Parser n () -pTok k = P.pTok (KA k) - - --- | Parse an atomic token and return some value. -pTokAs :: TokAtom -> a -> Parser n a -pTokAs k x = P.pTokAs (KA k) x - diff --git a/DDC/Type/Predicates.hs b/DDC/Type/Predicates.hs deleted file mode 100644 --- a/DDC/Type/Predicates.hs +++ /dev/null @@ -1,98 +0,0 @@ - --- | Predicates on type expressions. -module DDC.Type.Predicates - ( isBot - , isAtomT - , isDataKind - , isRegionKind - , isEffectKind - , isClosureKind - , isWitnessKind - , isAlgDataType) -where -import DDC.Type.Exp -import DDC.Type.Compounds -import qualified DDC.Type.Sum as T - - --- Atoms ---------------------------------------------------------------------- --- | Test if some type is an empty TSum -isBot :: Type n -> Bool -isBot tt - | TSum ss <- tt - , [] <- T.toList ss - = True - - | otherwise = False - - --- | Check whether a type is a `TVar`, `TCon` or is Bottom. -isAtomT :: Type n -> Bool -isAtomT tt - = case tt of - TVar{} -> True - TCon{} -> True - _ -> isBot tt - - --- Kinds ---------------------------------------------------------------------- --- | Check if some kind is the data kind. -isDataKind :: Kind n -> Bool -isDataKind tt - = case tt of - TCon (TyConKind KiConData) -> True - _ -> False - - --- | Check if some kind is the region kind. -isRegionKind :: Region n -> Bool -isRegionKind tt - = case tt of - TCon (TyConKind KiConRegion) -> True - _ -> False - - --- | Check if some kind is the effect kind. -isEffectKind :: Kind n -> Bool -isEffectKind tt - = case tt of - TCon (TyConKind KiConEffect) -> True - _ -> False - - --- | Check if some kind is the closure kind. -isClosureKind :: Kind n -> Bool -isClosureKind tt - = case tt of - TCon (TyConKind KiConClosure) -> True - _ -> False - - --- | Check if some kind is the witness kind. -isWitnessKind :: Kind n -> Bool -isWitnessKind tt - = case tt of - TCon (TyConKind KiConWitness) -> True - _ -> False - - --- Data Types ----------------------------------------------------------------- --- | Check whether this type is that of algebraic data. --- --- It needs to have an explicit data constructor out the front, --- and not a type variable. The constructor must not be the function --- constructor, and must return a value of kind '*'. - --- Algebraic data types are all built from constructors --- that have '*' as their result kind. --- The function constructor (->) also has this result kind, --- but it is in `TyConComp`, so is easy to ignore. -isAlgDataType :: Eq n => Type n -> Bool -isAlgDataType tt - | Just (tc, _) <- takeTyConApps tt - , TyConBound u <- tc - = takeResultKind (typeOfBound u) == kData - - | otherwise - = False - diff --git a/DDC/Type/Pretty.hs b/DDC/Type/Pretty.hs deleted file mode 100644 --- a/DDC/Type/Pretty.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} -module DDC.Type.Pretty - (module DDC.Base.Pretty) -where -import DDC.Type.Exp -import DDC.Type.Predicates -import DDC.Type.Compounds -import DDC.Base.Pretty -import qualified DDC.Type.Sum as Sum - -stage = "DDC.Type.Pretty" - --- Bind ----------------------------------------------------------------------- -instance (Pretty n, Eq n) => Pretty (Bind n) where - ppr bb - = case bb of - BName v t -> ppr v <+> text ":" <+> ppr t - BAnon t -> text "^" <+> text ":" <+> ppr t - BNone t -> text "_" <+> text ":" <+> ppr t - - --- Binder --------------------------------------------------------------------- -instance Pretty n => Pretty (Binder n) where - ppr bb - = case bb of - RName v -> ppr v - RAnon -> text "^" - RNone -> text "_" - - --- | Pretty print a binder, adding spaces after names. --- The RAnon and None binders don't need spaces, as they're single symbols. -pprBinderSep :: Pretty n => Binder n -> Doc -pprBinderSep bb - = case bb of - RName v -> ppr v - RAnon -> text "^" - RNone -> text "_" - - --- | Print a group of binders with the same type. -pprBinderGroup :: (Pretty n, Eq n) => ([Binder n], Type n) -> Doc -pprBinderGroup (rs, t) - = (brackets $ (sep $ map pprBinderSep rs) <+> text ":" <+> ppr t) - <> dot - - --- Bound ---------------------------------------------------------------------- -instance (Pretty n, Eq n) => Pretty (Bound n) where - ppr nn - = case nn of --- UName n t -> parens (ppr n <> text ":" <> ppr t) - UName n _ -> ppr n - - - UPrim n _ -> ppr n --- UIx i t -> parens (text "^" <> ppr i <> text ":" <> ppr t) - UIx i _ -> text "^" <> ppr i - - --- Type ----------------------------------------------------------------------- -instance (Pretty n, Eq n) => Pretty (Type n) where - pprPrec d tt - = case tt of - -- Full application of function constructors are printed infix. - TApp (TApp (TCon (TyConKind KiConFun)) k1) k2 - -> pprParen (d > 5) - $ ppr k1 <+> text "~>" <+> ppr k2 - - TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2 - -> pprParen (d > 5) - $ pprPrec 6 t1 <+> text "=>" pprPrec 5 t2 - - TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFun)) t1) eff) clo) t2 - | isBot eff, isBot clo - -> pprParen (d > 5) - $ pprPrec 6 t1 <+> text "->" pprPrec 5 t2 - - | otherwise - -> pprParen (d > 5) - $ pprPrec 6 t1 - <+> text "-(" <> ppr eff <> text " | " <> ppr clo <> text ")>" - pprPrec 5 t2 - - -- Standard types. - TCon tc -> ppr tc - TVar b -> ppr b - - TForall b t - | Just (bsMore, tBody) <- takeTForalls t - -> let groups = partitionBindsByType (b:bsMore) - in pprParen (d > 5) - $ (cat $ map pprBinderGroup groups) <> ppr tBody - - | otherwise - -> pprParen (d > 5) - $ brackets (ppr b) <> dot <> ppr t - - TApp t1 t2 - -> pprParen (d > 10) - $ ppr t1 <+> pprPrec 11 t2 - - TSum ts - | isBot tt - -> ppr (Sum.kindOfSum ts) <> text "0" - - | otherwise - -> pprParen (d > 9) $ ppr ts - - -instance (Pretty n, Eq n) => Pretty (TypeSum n) where - ppr ss - = case Sum.toList ss of - [] | isEffectKind $ Sum.kindOfSum ss -> text "!0" - | isClosureKind $ Sum.kindOfSum ss -> text "$0" - | isDataKind $ Sum.kindOfSum ss -> text "*0" - | otherwise -> error $ stage ++ ": malformed sum" - - ts -> sep $ punctuate (text " +") (map ppr ts) - - --- TyCon ---------------------------------------------------------------------- -instance (Eq n, Pretty n) => Pretty (TyCon n) where - ppr tt - = case tt of - TyConSort sc -> ppr sc - TyConKind kc -> ppr kc - TyConWitness tc -> ppr tc - TyConSpec tc -> ppr tc - TyConBound u -> ppr u - - -instance Pretty SoCon where - ppr sc - = case sc of - SoConComp -> text "**" - SoConProp -> text "@@" - - -instance Pretty KiCon where - ppr kc - = case kc of - KiConFun -> text "(~>)" - KiConData -> text "*" - KiConRegion -> text "%" - KiConEffect -> text "!" - KiConClosure -> text "$" - KiConWitness -> text "@" - - -instance Pretty TwCon where - ppr tw - = case tw of - TwConImpl -> text "(=>)" - TwConPure -> text "Pure" - TwConEmpty -> text "Empty" - TwConGlobal -> text "Global" - TwConDeepGlobal -> text "DeepGlobal" - TwConConst -> text "Const" - TwConDeepConst -> text "DeepConst" - TwConMutable -> text "Mutable" - TwConDeepMutable-> text "DeepMutable" - TwConLazy -> text "Lazy" - TwConHeadLazy -> text "HeadLazy" - TwConManifest -> text "Manifest" - - -instance Pretty TcCon where - ppr tc - = case tc of - TcConFun -> text "(->)" - TcConRead -> text "Read" - TcConHeadRead -> text "HeadRead" - TcConDeepRead -> text "DeepRead" - TcConWrite -> text "Write" - TcConDeepWrite -> text "DeepWrite" - TcConAlloc -> text "Alloc" - TcConDeepAlloc -> text "DeepAlloc" - TcConUse -> text "Use" - TcConDeepUse -> text "DeepUse" - - diff --git a/DDC/Type/Rewrite.hs b/DDC/Type/Rewrite.hs deleted file mode 100644 --- a/DDC/Type/Rewrite.hs +++ /dev/null @@ -1,264 +0,0 @@ - --- | Rewriting of variable binders to anonymous form to avoid capture. -module DDC.Type.Rewrite - ( Rewrite(..) - , Sub(..) - , BindStack(..) - , pushBind - , pushBinds - , substBound - - , bind1, bind0, bind0s - , use1, use0) -where -import DDC.Core.Exp -import DDC.Type.Compounds -import Data.List -import Data.Set (Set) -import qualified DDC.Type.Sum as Sum -import qualified Data.Set as Set - - --- | Substitution state. --- Keeps track of the binders in the environment that have been rewrittten --- to avoid variable capture or spec binder shadowing. -data Sub n - = Sub - { -- | Bound variable that we're substituting for. - subBound :: Bound n - - -- | We've decended past a binder that shadows the one that we're - -- substituting for. We're no longer substituting, but still may - -- need to anonymise variables in types. - -- This can only happen for level-0 named binders. - , subShadow0 :: Bool - - -- | Level-1 names that need to be rewritten to avoid capture. - , subConflict1 :: Set n - - -- | Level-0 names that need to be rewritten to avoid capture. - , subConflict0 :: Set n - - -- | Rewriting stack for level-1 names. - , subStack1 :: BindStack n - - -- | Rewriting stack for level-0 names. - , subStack0 :: BindStack n } - - --- | Stack of anonymous binders that we've entered under during substitution. -data BindStack n - = BindStack - { -- | Holds anonymous binders that were already in the program, - -- as well as named binders that are being rewritten to anonymous ones. - -- In the resulting expression all these binders will be anonymous. - stackBinds :: [Bind n] - - -- | Holds all binders, independent of whether they are being rewritten or not. - , stackAll :: [Bind n] - - -- | Number of `BAnon` in `stackBinds`. - , stackAnons :: Int - - -- | Number of `BName` in `stackBinds`. - , stackNamed :: Int } - - --- | Push several binds onto the bind stack, --- anonymyzing them if need be to avoid variable capture. -pushBinds :: Ord n => Set n -> BindStack n -> [Bind n] -> (BindStack n, [Bind n]) -pushBinds fns stack bs - = mapAccumL (pushBind fns) stack bs - - --- | Push a bind onto a bind stack, --- anonymizing it if need be to avoid variable capture. -pushBind - :: Ord n - => Set n -- ^ Names that need to be rewritten. - -> BindStack n -- ^ Current bind stack. - -> Bind n -- ^ Bind to push. - -> (BindStack n, Bind n) -- ^ New stack and possibly anonymised bind. - -pushBind fns bs@(BindStack stack env dAnon dName) bb - = case bb of - -- Push already anonymous bind on stack. - BAnon t - -> ( BindStack (BAnon t : stack) (BAnon t : env) (dAnon + 1) dName - , BAnon t) - - -- If the binder needs to be rewritten then push the original name on the - -- 'stackBinds' to remember this. - BName n t - | Set.member n fns - -> ( BindStack (BName n t : stack) (BAnon t : env) dAnon (dName + 1) - , BAnon t) - - | otherwise - -> ( BindStack stack (BName n t : env) dAnon dName - , bb) - - -- Binder was a wildcard. - _ -> (bs, bb) - - - --- | Compare a `Bound` against the one we're substituting for. -substBound - :: Ord n - => BindStack n -- ^ Current Bind stack during substitution. - -> Bound n -- ^ Bound we're substituting for. - -> Bound n -- ^ Bound we're looking at now. - -> Either - (Bound n) -- Bound doesn't match, but replace with this one. - Int -- Bound matches, drop the thing being substituted and - -- and lift indices this many steps. - -substBound (BindStack binds _ dAnon dName) u u' - -- Bound name matches the one that we're substituting for. - | UName n1 _ <- u - , UName n2 _ <- u' - , n1 == n2 - = Right (dAnon + dName) - - -- Bound index matches the one that we're substituting for. - | UIx i1 _ <- u - , UIx i2 _ <- u' - , i1 + dAnon == i2 - = Right (dAnon + dName) - - -- The Bind for this name was rewritten to avoid variable capture, - -- so we also have to update the bound occurrence. - | UName _ t <- u' - , Just ix <- findIndex (boundMatchesBind u') binds - = Left $ UIx ix t - - -- Bound index doesn't match, but lower this index by one to account - -- for the removal of the outer binder. - | UIx i2 t <- u' - , i2 > dAnon - , cutOffset <- case u of - UIx{} -> 1 - _ -> 0 - = Left $ UIx (i2 + dName - cutOffset) t - - -- Some name that didn't match. - | otherwise - = Left u' - - -------------------------------------------------------------------------------- --- | Push a level-1 binder on the rewrite stack. -bind1 :: Ord n => Sub n -> Bind n -> (Sub n, Bind n) -bind1 sub b - = let (stackT', b') = pushBind (subConflict1 sub) (subStack1 sub) b - in (sub { subStack1 = stackT' }, b') - - --- | Push a level-0 binder on the rewrite stack. -bind0 :: Ord n => Sub n -> Bind n -> (Sub n, Bind n) -bind0 sub b - = let b1 = rewriteWith sub b - (stackX', b2) = pushBind (subConflict0 sub) (subStack0 sub) b1 - in ( sub { subStack0 = stackX' - , subShadow0 = subShadow0 sub - || namedBoundMatchesBind (subBound sub) b2 } - , b2) - - --- | Push some level-0 binders on the rewrite stack. -bind0s :: Ord n => Sub n -> [Bind n] -> (Sub n, [Bind n]) -bind0s = mapAccumL bind0 - - --- | Rewrite a use of a level-1 binder if need be. -use1 :: Ord n => Sub n -> Bound n -> Bound n -use1 sub u - | UName _ t <- u - , BindStack binds _ _ _ <- subStack1 sub - , Just ix <- findIndex (boundMatchesBind u) binds - = UIx ix t - - | otherwise - = u - - --- | Rewrite the use of a level-0 binder if need be. -use0 :: Ord n => Sub n -> Bound n -> Bound n -use0 sub u - | UName _ t <- u - , BindStack binds _ _ _ <- subStack0 sub - , Just ix <- findIndex (boundMatchesBind u) binds - = UIx ix (rewriteWith sub t) - - | otherwise - = rewriteWith sub u - - -------------------------------------------------------------------------------- -class Rewrite (c :: * -> *) where - -- | Rewrite names in some thing to anonymous form if they conflict with --- any names in the `Sub` state. - rewriteWith :: Ord n => Sub n -> c n -> c n - - -instance Rewrite Bind where - rewriteWith sub bb - = replaceTypeOfBind (rewriteWith sub (typeOfBind bb)) bb - - -instance Rewrite Bound where - rewriteWith sub uu - = replaceTypeOfBound (rewriteWith sub (typeOfBound uu)) uu - - -instance Rewrite LetMode where - rewriteWith sub lm - = case lm of - LetStrict -> lm - LetLazy (Just t) -> LetLazy (Just $ rewriteWith sub t) - LetLazy Nothing -> LetLazy Nothing - - -instance Rewrite Cast where - rewriteWith sub cc - = let down = rewriteWith sub - in case cc of - CastWeakenEffect eff -> CastWeakenEffect (down eff) - CastWeakenClosure clo -> CastWeakenClosure (down clo) - CastPurify w -> CastPurify (down w) - CastForget w -> CastForget (down w) - - -instance Rewrite Type where - rewriteWith sub tt - = let down = rewriteWith - in case tt of - TVar u -> TVar (use1 sub u) - TCon{} -> tt - - TForall b t - -> let (sub1, b') = bind1 sub b - t' = down sub1 t - in TForall b' t' - - TApp t1 t2 -> TApp (down sub t1) (down sub t2) - TSum ts -> TSum (down sub ts) - - -instance Rewrite TypeSum where - rewriteWith sub ts - = Sum.fromList (Sum.kindOfSum ts) - $ map (rewriteWith sub) - $ Sum.toList ts - - -instance Rewrite Witness where - rewriteWith sub ww - = let down = rewriteWith - in case ww of - WVar u -> WVar (use0 sub u) - WCon{} -> ww - WApp w1 w2 -> WApp (down sub w1) (down sub w2) - WJoin w1 w2 -> WJoin (down sub w1) (down sub w2) - WType t -> WType (down sub t) 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 @@ -2,32 +2,48 @@ -- | Utilities for working with `TypeSum`s. -- module DDC.Type.Sum - ( empty + ( -- * Constructors + empty , singleton - , elem - , insert - , delete , union , unions - , difference + , insert + + -- * Conversion + , toList + , fromList + + -- * Projection , kindOfSum - , toList, fromList - , hashTyCon, hashTyConRange - , unhashTyCon - , takeSumArrayElem - , makeSumArrayElem) + , elem + + -- * Deletion + , delete + , difference + + -- * Hashing + , hashTyCon + , hashTyConRange + , unhashTyCon) where import DDC.Type.Exp import Data.Array -import qualified Data.List as L -import qualified Data.Map as Map -import qualified Data.Set as Set -import Prelude hiding (elem) +import qualified Data.List as L +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Prelude hiding (elem) -- | Construct an empty type sum of the given kind. empty :: Kind n -> TypeSum n -empty k = TypeSum +empty k = TypeSumBot k + + +-- | Construct an empty type sum of the given kind, but in `TypeSumSet` form. +-- This isn't exported. +emptySet :: Kind n -> TypeSum n +emptySet k + = TypeSumSet { typeSumKind = k , typeSumElems = listArray hashTyConRange (repeat Set.empty) , typeSumBoundNamed = Map.empty @@ -50,17 +66,15 @@ -- * May return False if the first argument is miskinded but still -- alpha-equivalent to some component of the sum. elem :: (Eq n, Ord n) => Type n -> TypeSum n -> Bool -elem t ts +elem _ TypeSumBot{} = False +elem t ts@TypeSumSet{} = case t of - TVar (UName n _) -> Map.member n (typeSumBoundNamed ts) + TVar (UName n) -> Map.member n (typeSumBoundNamed ts) + TVar (UIx i) -> Map.member i (typeSumBoundAnon ts) TVar (UPrim n _) -> Map.member n (typeSumBoundNamed ts) - TVar (UIx i _) -> Map.member i (typeSumBoundAnon ts) TCon{} -> L.elem t (typeSumSpill ts) - -- Foralls can't be a part of well-kinded sums. - -- Just check whether the types are strucutrally equal - -- without worring about alpha-equivalence. - TForall{} -> L.elem t (typeSumSpill ts) + TAbs{} -> L.elem t (typeSumSpill ts) TApp (TCon _) _ | Just (h, vc) <- takeSumArrayElem t @@ -69,6 +83,11 @@ TApp{} -> L.elem t (typeSumSpill ts) + -- Foralls can't be a part of well-kinded sums. + -- Just check whether the types are strucutrally equal + -- without worring about alpha-equivalence. + TForall{} -> L.elem t (typeSumSpill ts) + -- Treat bottom effect and closures as always -- being part of the sum. TSum ts1 @@ -86,18 +105,18 @@ -- | Insert a new element into a sum. insert :: Ord n => Type n -> TypeSum n -> TypeSum n -insert t ts - = case t of - TVar (UName n k) -> ts { typeSumBoundNamed = Map.insert n k (typeSumBoundNamed ts) } - TVar (UPrim n k) -> ts { typeSumBoundNamed = Map.insert n k (typeSumBoundNamed ts) } - TVar (UIx i k) -> ts { typeSumBoundAnon = Map.insert i k (typeSumBoundAnon ts) } - TCon{} -> ts { typeSumSpill = t : typeSumSpill ts } +insert t (TypeSumBot k) = insert t (emptySet k) +insert t ts@TypeSumSet{} + = let k = typeSumKind ts + in case t of + TVar (UName n) -> ts { typeSumBoundNamed = Map.insert n k (typeSumBoundNamed ts) } + TVar (UIx i) -> ts { typeSumBoundAnon = Map.insert i k (typeSumBoundAnon ts) } + TVar (UPrim n _)-> ts { typeSumBoundNamed = Map.insert n k (typeSumBoundNamed ts) } - -- Foralls can't be part of well-kinded sums. - -- Just add them to the splill lists so that we can still - -- pretty print such mis-kinded types. - TForall{} -> ts { typeSumSpill = t : typeSumSpill ts } + TCon{} -> ts { typeSumSpill = L.nub $ t : typeSumSpill ts } + TAbs{} -> ts { typeSumSpill = L.nub $ t : typeSumSpill ts } + TApp (TCon _) _ | Just (h, vc) <- takeSumArrayElem t , tsThere <- typeSumElems ts ! h @@ -105,27 +124,36 @@ then ts else ts { typeSumElems = (typeSumElems ts) // [(h, Set.insert vc tsThere)] } - TApp{} -> ts { typeSumSpill = t : typeSumSpill ts } + TApp{} -> ts { typeSumSpill = L.nub $ t : typeSumSpill ts } + + -- Foralls can't be part of well-kinded sums. + -- Just add them to the splill lists so that we can still + -- pretty print such mis-kinded types. + TForall{} -> ts { typeSumSpill = L.nub $ t : typeSumSpill ts } TSum ts' -> foldr insert ts (toList ts') -- | Delete an element from a sum. delete :: Ord n => Type n -> TypeSum n -> TypeSum n -delete t ts +delete _ ts@TypeSumBot{} = ts +delete t ts@TypeSumSet{} = case t of - TVar (UName n _) -> ts { typeSumBoundNamed = Map.delete n (typeSumBoundNamed ts) } - TVar (UPrim n _) -> ts { typeSumBoundNamed = Map.delete n (typeSumBoundNamed ts) } - TVar (UIx i _) -> ts { typeSumBoundAnon = Map.delete i (typeSumBoundAnon ts) } - TCon{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } - TForall{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } + TVar (UName n) -> ts { typeSumBoundNamed = Map.delete n (typeSumBoundNamed ts) } + TVar (UIx i) -> ts { typeSumBoundAnon = Map.delete i (typeSumBoundAnon ts) } + TVar (UPrim n _)-> ts { typeSumBoundNamed = Map.delete n (typeSumBoundNamed ts) } + TCon{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } + + TAbs{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } TApp (TCon _) _ | Just (h, vc) <- takeSumArrayElem t , tsThere <- typeSumElems ts ! h -> ts { typeSumElems = (typeSumElems ts) // [(h, Set.delete vc tsThere)] } - TApp{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } + TApp{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } + + TForall{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } TSum ts' -> foldr delete ts (toList ts') @@ -157,7 +185,10 @@ -- | Flatten out a sum, yielding a list of individual terms. toList :: TypeSum n -> [Type n] -toList TypeSum +toList TypeSumBot{} + = [] + +toList TypeSumSet { typeSumKind = _kind , typeSumElems = sumElems , typeSumBoundNamed = named @@ -166,8 +197,8 @@ = [ makeSumArrayElem h vc | (h, ts) <- assocs sumElems, vc <- Set.toList ts] - ++ [TVar $ UName n k | (n, k) <- Map.toList named] - ++ [TVar $ UIx i k | (i, k) <- Map.toList anon] + ++ [TVar $ UName n | (n, _) <- Map.toList named] + ++ [TVar $ UIx i | (i, _) <- Map.toList anon] ++ spill @@ -194,8 +225,6 @@ TcConWrite -> Just $ TyConHash 2 TcConDeepWrite -> Just $ TyConHash 3 TcConAlloc -> Just $ TyConHash 4 - TcConUse -> Just $ TyConHash 5 - TcConDeepUse -> Just $ TyConHash 6 _ -> Nothing @@ -216,12 +245,10 @@ 2 -> TcConWrite 3 -> TcConDeepWrite 4 -> TcConAlloc - 5 -> TcConUse - 6 -> TcConDeepUse -- This should never happen, because we only produce hashes -- with the above 'hashTyCon' function. - _ -> error $ "DDC.Type.Sum: bad TyConHash " ++ show i + _ -> error $ "ddc-core.unhashTyCon: bad TyConHash " ++ show i -- | If this type can be put in one of our arrays then split it @@ -231,7 +258,7 @@ | Just h <- hashTyCon tc = case t2 of TVar u -> Just (h, TypeSumVar u) - TCon (TyConBound u) -> Just (h, TypeSumCon u) + TCon (TyConBound u k) -> Just (h, TypeSumCon u k) _ -> Nothing takeSumArrayElem _ = Nothing @@ -243,7 +270,7 @@ = let tc = unhashTyCon h in case vc of TypeSumVar u -> TApp (TCon tc) (TVar u) - TypeSumCon u -> TApp (TCon tc) (TCon (TyConBound u)) + TypeSumCon u k -> TApp (TCon tc) (TCon (TyConBound u k)) -- Type Equality -------------------------------------------------------------- @@ -268,6 +295,7 @@ -- Unwrap single element sums into plain types. where normalise (TSum ts) | [t'] <- toList ts = t' + | [] <- toList ts = TSum $ empty (typeSumKind ts) normalise t' = t' @@ -280,25 +308,47 @@ , [] <- toList ts2 = typeSumKind ts1 == typeSumKind ts2 - -- If the sum has elements, then compare them directly and ignore the + | TypeSumBot{} <- normalise ts1 + , TypeSumBot{} <- normalise ts2 + = typeSumKind ts1 == typeSumKind ts2 + + -- If both sums have elements, then compare them directly and ignore the -- kind. This allows us to use (tBot sComp) as the typeSumKind field -- when we want to compute the real kind based on the elements. - | otherwise + | TypeSumSet{} <- ts1 + , TypeSumSet{} <- ts2 = typeSumElems ts1 == typeSumElems ts2 && typeSumBoundNamed ts1 == typeSumBoundNamed ts2 && typeSumBoundAnon ts1 == typeSumBoundAnon ts2 && typeSumSpill ts1 == typeSumSpill ts2 + -- One is a set and one is bottom, so they are not equal. + | otherwise + = False + where normalise ts + | [] <- toList ts = empty (typeSumKind ts) + normalise ts = ts + + instance Ord n => Ord (Bound n) where - compare (UName n1 _) (UName n2 _) = compare n1 n2 - compare (UIx i1 _) (UIx i2 _) = compare i1 i2 - compare (UPrim n1 _) (UPrim n2 _) = compare n1 n2 - compare (UIx _ _) _ = LT - compare (UName _ _) (UIx _ _) = GT - compare (UName _ _) (UPrim _ _) = LT - compare (UPrim _ _) _ = GT + compare (UName n1) (UName n2) = compare n1 n2 + compare (UIx i1) (UIx i2) = compare i1 i2 + compare (UPrim n1 _) (UPrim n2 _) = compare n1 n2 + compare UIx{} _ = LT + compare UName{} UIx{} = GT + compare UName{} UPrim{} = LT + compare UPrim{} _ = GT -deriving instance Eq n => Eq (TypeSumVarCon n) -deriving instance Ord n => Ord (TypeSumVarCon n) + +instance Eq n => Eq (TypeSumVarCon n) where + (==) (TypeSumVar u1) (TypeSumVar u2) = u1 == u2 + (==) (TypeSumCon u1 _) (TypeSumCon u2 _) = u1 == u2 + (==) _ _ = False + +instance Ord n => Ord (TypeSumVarCon n) where + compare (TypeSumVar u1) (TypeSumVar u2) = compare u1 u2 + compare (TypeSumCon u1 _) (TypeSumCon u2 _) = compare u1 u2 + compare (TypeSumVar _) _ = LT + compare (TypeSumCon _ _) _ = GT 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,152 +0,0 @@ -module DDC.Type.Transform.Crush - (crushEffect) -where -import DDC.Type.Predicates -import DDC.Type.Compounds -import DDC.Type.Exp -import qualified DDC.Type.Sum as Sum - - --- | Crush compound effect terms into their components. --- --- This is like `trimClosure` but for effects instead of closures. --- --- For example, crushing @DeepRead (List r1 (Int r2))@ yields @(Read r1 + Read r2)@. --- -crushEffect :: Ord n => Effect n -> Effect n -crushEffect tt - = case tt of - TVar{} -> tt - TCon{} -> tt - TForall b t - -> TForall b (crushEffect t) - - TSum ts - -> TSum - $ Sum.fromList (Sum.kindOfSum ts) - $ map crushEffect - $ Sum.toList ts - - TApp t1 t2 - -- Head Read. - | Just (TyConSpec TcConHeadRead, [t]) <- takeTyConApps tt - -> case takeTyConApps t of - - -- Type has a head region. - Just (TyConBound u, (tR : _)) - | (k1 : _, _) <- takeKFuns (typeOfBound u) - , isRegionKind k1 - -> tRead tR - - -- Type has no head region. - -- This happens with case () of { ... } - Just (TyConBound _, []) -> tBot kEffect - - _ -> tt - - -- Deep Read. - -- See Note: Crushing with higher kinded type vars. - | Just (TyConSpec TcConDeepRead, [t]) <- takeTyConApps tt - -> case takeTyConApps t of - Just (TyConBound u, ts) - | (ks, _) <- takeKFuns (typeOfBound u) - , length ks == length ts - , Just effs <- sequence $ zipWith makeDeepRead ks ts - -> crushEffect $ TSum $ Sum.fromList kEffect effs - - _ -> tt - - -- Deep Write - -- See Note: Crushing with higher kinded type vars. - | Just (TyConSpec TcConDeepWrite, [t]) <- takeTyConApps tt - -> case takeTyConApps t of - Just (TyConBound u, ts) - | (ks, _) <- takeKFuns (typeOfBound u) - , length ks == length ts - , Just effs <- sequence $ zipWith makeDeepWrite ks ts - -> crushEffect $ TSum $ Sum.fromList kEffect effs - - _ -> tt - - -- Deep Alloc - -- See Note: Crushing with higher kinded type vars. - | Just (TyConSpec TcConDeepAlloc, [t]) <- takeTyConApps tt - -> case takeTyConApps t of - Just (TyConBound u, ts) - | (ks, _) <- takeKFuns (typeOfBound u) - , length ks == length ts - , Just effs <- sequence $ zipWith makeDeepAlloc ks ts - -> crushEffect $ TSum $ Sum.fromList kEffect effs - - _ -> tt - - -- TODO: we're hijacking crushEffect to work on witnesses as well. - -- we should split this into another function. - -- Deep Global - -- See Note: Crushing with higher kinded type vars. - | Just (TyConWitness TwConDeepGlobal, [t]) <- takeTyConApps tt - -> case takeTyConApps t of - Just (TyConBound u, ts) - | (ks, _) <- takeKFuns (typeOfBound u) - , length ks == length ts - , Just props <- sequence $ zipWith makeDeepGlobal ks ts - -> crushEffect $ TSum $ Sum.fromList kWitness props - - _ -> tt - - | otherwise - -> TApp (crushEffect t1) (crushEffect t2) - - --- | If this type has first order kind then wrap with the --- appropriate read effect. -makeDeepRead :: Kind n -> Type n -> Maybe (Effect n) -makeDeepRead k t - | isRegionKind k = Just $ tRead t - | isDataKind k = Just $ tDeepRead t - | isClosureKind k = Just $ tBot kEffect - | isEffectKind k = Just $ tBot kEffect - | otherwise = Nothing - - --- | If this type has first order kind then wrap with the --- appropriate read effect. -makeDeepWrite :: Kind n -> Type n -> Maybe (Effect n) -makeDeepWrite k t - | isRegionKind k = Just $ tWrite t - | isDataKind k = Just $ tDeepWrite t - | isClosureKind k = Just $ tBot kEffect - | isEffectKind k = Just $ tBot kEffect - | otherwise = Nothing - - --- | If this type has first order kind then wrap with the --- appropriate read effect. -makeDeepAlloc :: Kind n -> Type n -> Maybe (Effect n) -makeDeepAlloc k t - | isRegionKind k = Just $ tAlloc t - | isDataKind k = Just $ tDeepAlloc t - | isClosureKind k = Just $ tBot kEffect - | isEffectKind k = Just $ tBot kEffect - | otherwise = Nothing - - --- | If this type has first order kind then wrap with the --- appropriate read effect. -makeDeepGlobal :: Kind n -> Type n -> Maybe (Type n) -makeDeepGlobal k t - | isRegionKind k = Just $ tGlobal t - | isDataKind k = Just $ tDeepGlobal t - | isClosureKind k = Nothing - | isEffectKind k = Just $ tBot kEffect - | otherwise = Nothing - - -{- [Note: Crushing with higher kinded type vars] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We can't just look at the free variables here and wrap Read and DeepRead constructors - around them, as the type may contain higher kinded type variables such as: (t a). - Instead, we'll only crush the effect when all variable have first-order kind. - When comparing types with higher order variables, we'll have to use the type - equivalence checker, instead of relying on the effects to be pre-crushed. --} 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,12 +5,16 @@ where import DDC.Type.Exp import DDC.Type.Transform.SubstituteT -import DDC.Base.Pretty (Pretty) -- | Instantiate a type with an argument. -- The type to be instantiated must have an outer forall, else `Nothing`. -instantiateT :: (Ord n, Pretty n) => Type n -> Type n -> Maybe (Type n) +instantiateT + :: Ord n + => Type n -- ^ Type to instantiate. + -> Type n -- ^ Argument type. + -> Maybe (Type n) + instantiateT (TForall b tBody) t2 = Just $ substituteT b t2 tBody instantiateT _ _ = Nothing @@ -18,7 +22,12 @@ -- | Instantiate a type with several arguments. -- The type to be instantiated must have at least as many outer foralls -- as provided type arguments, else `Nothing`. -instantiateTs :: (Ord n, Pretty n) => Type n -> [Type n] -> Maybe (Type n) +instantiateTs + :: Ord n + => Type n -- ^ Type to instantiate. + -> [Type n] -- ^ Argument types. + -> Maybe (Type n) + instantiateTs t [] = Just t instantiateTs t (tArg:tsArgs) = case instantiateT t tArg of 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,63 +0,0 @@ - --- | Lifting of deBruijn indices in a type. ---- --- TODO: merge this code with LowerT -module DDC.Type.Transform.LiftT - (LiftT(..)) -where -import DDC.Type.Exp -import DDC.Type.Compounds -import qualified DDC.Type.Sum as Sum - - -class LiftT (c :: * -> *) where - - -- | Lift type indices that are at least a certain depth by the given number of levels. - liftAtDepthT - :: forall n. Ord n - => Int -- ^ Number of levels to lift. - -> Int -- ^ Current binding depth. - -> c n -- ^ Lift type indices in this thing. - -> c n - - -- | Wrapper for `liftAtDepthT` that starts at depth 0. - liftT :: forall n. Ord n - => Int -- ^ Number of levels to lift - -> c n -- ^ Lift type indices in this thing. - -> c n - - liftT n xx = liftAtDepthT n 0 xx - - -instance LiftT Bind where - liftAtDepthT n d bb - = replaceTypeOfBind (liftAtDepthT n d $ typeOfBind bb) bb - - -instance LiftT Bound where - liftAtDepthT n d uu - = case uu of - UName{} -> uu - UPrim{} -> uu - UIx i t - | d <= i -> UIx (i + n) t - | otherwise -> uu - - -instance LiftT Type where - liftAtDepthT n d tt - = let down = liftAtDepthT n - in case tt of - TVar u -> TVar (down d u) - TCon{} -> tt - TForall b t -> TForall (down d b) (down (d + 1) t) - TApp t1 t2 -> TApp (down d t1) (down d t2) - TSum ss -> TSum (down d ss) - - -instance LiftT TypeSum where - liftAtDepthT n d ss - = Sum.fromList (liftAtDepthT n d $ Sum.kindOfSum ss) - $ map (liftAtDepthT n d) - $ Sum.toList ss - diff --git a/DDC/Type/Transform/LowerT.hs b/DDC/Type/Transform/LowerT.hs deleted file mode 100644 --- a/DDC/Type/Transform/LowerT.hs +++ /dev/null @@ -1,63 +0,0 @@ - --- | Lowering of deBruijn indices in a type. ---- --- TODO: merge this code with LiftT. -module DDC.Type.Transform.LowerT - (LowerT(..)) -where -import DDC.Type.Exp -import DDC.Type.Compounds -import qualified DDC.Type.Sum as Sum - - -class LowerT (c :: * -> *) where - - -- | Lower type indices that are at least a certain depth by the given number of levels. - lowerAtDepthT - :: forall n. Ord n - => Int -- ^ Number of levels to lower. - -> Int -- ^ Current binding depth. - -> c n -- ^ Lower type indices in this thing. - -> c n - - -- | Wrapper for `lowerAtDepthT` that starts at depth 0. - lowerT :: forall n. Ord n - => Int -- ^ Number of levels to lower. - -> c n -- ^ Lower type indices in this thing. - -> c n - - lowerT n xx = lowerAtDepthT n 0 xx - - -instance LowerT Bind where - lowerAtDepthT n d bb - = replaceTypeOfBind (lowerAtDepthT n d $ typeOfBind bb) bb - - -instance LowerT Bound where - lowerAtDepthT n d uu - = case uu of - UName{} -> uu - UPrim{} -> uu - UIx i t - | d <= i -> UIx (i - n) t - | otherwise -> uu - - -instance LowerT Type where - lowerAtDepthT n d tt - = let down = lowerAtDepthT n - in case tt of - TVar uu -> TVar (down d uu) - TCon{} -> tt - TForall b t -> TForall (down d b) (down (d + 1) t) - TApp t1 t2 -> TApp (down d t1) (down d t2) - TSum ss -> TSum (down d ss) - - -instance LowerT TypeSum where - lowerAtDepthT n d ss - = Sum.fromList (lowerAtDepthT n d $ Sum.kindOfSum ss) - $ map (lowerAtDepthT n d) - $ Sum.toList ss - diff --git a/DDC/Type/Transform/Rename.hs b/DDC/Type/Transform/Rename.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Transform/Rename.hs @@ -0,0 +1,252 @@ + +-- | Renaming of variable binders to anonymous form to avoid capture. +module DDC.Type.Transform.Rename + ( Rename(..) + + -- * Substitution states + , Sub(..) + + -- * Binding stacks + , BindStack(..) + , pushBind + , pushBinds + , substBound + + -- * Rewriting binding occurences + , bind1, bind1s, bind0, bind0s + + -- * Rewriting bound occurences + , use1, use0) +where +import DDC.Type.Exp.Simple +import Data.List +import Data.Set (Set) +import qualified DDC.Type.Sum as Sum +import qualified Data.Set as Set + + +------------------------------------------------------------------------------- +class Rename (c :: * -> *) where + -- | Rewrite names in some thing to anonymous form if they conflict with +-- any names in the `Sub` state. We use this to avoid variable capture +-- during substitution. + renameWith :: Ord n => Sub n -> c n -> c n + + +instance Rename Type where + renameWith sub tt + = {-# SCC renameWith #-} + let down = renameWith + in case tt of + TVar u -> TVar (use1 sub u) + + TCon{} -> tt + + TAbs b t + -> let (sub1, b') = bind1 sub b + t' = down sub1 t + in TAbs b' t' + + TApp t1 t2 -> TApp (down sub t1) (down sub t2) + + TForall b t + -> let (sub1, b') = bind1 sub b + t' = down sub1 t + in TForall b' t' + + TSum ts -> TSum (down sub ts) + + +instance Rename TypeSum where + renameWith sub ts + = Sum.fromList (Sum.kindOfSum ts) + $ map (renameWith sub) + $ Sum.toList ts + + +instance Rename Bind where + renameWith sub bb + = replaceTypeOfBind (renameWith sub (typeOfBind bb)) bb + + +------------------------------------------------------------------------------- +-- | Substitution state. +-- Keeps track of the binders in the environment that have been rewrittten +-- to avoid variable capture or spec binder shadowing. +data Sub n + = Sub + { -- | Bound variable that we're substituting for. + subBound :: !(Bound n) + + -- | We've decended past a binder that shadows the one that we're + -- substituting for. We're no longer substituting, but still may + -- need to anonymise variables in types. + -- This can only happen for level-0 named binders. + , subShadow0 :: !Bool + + -- | Level-1 names that need to be rewritten to avoid capture. + , subConflict1 :: !(Set n) + + -- | Level-0 names that need to be rewritten to avoid capture. + , subConflict0 :: !(Set n) + + -- | Rewriting stack for level-1 names. + , subStack1 :: !(BindStack n) + + -- | Rewriting stack for level-0 names. + , subStack0 :: !(BindStack n) } + + +-- | Stack of anonymous binders that we've entered under during substitution. +data BindStack n + = BindStack + { -- | Holds anonymous binders that were already in the program, + -- as well as named binders that are being rewritten to anonymous ones. + -- In the resulting expression all these binders will be anonymous. + stackBinds :: ![Bind n] + + -- | Holds all binders, independent of whether they are being rewritten or not. + , stackAll :: ![Bind n] + + -- | Number of `BAnon` in `stackBinds`. + , stackAnons :: !Int + + -- | Number of `BName` in `stackBinds`. + , stackNamed :: !Int } + + +-- | Push several binds onto the bind stack, +-- anonymyzing them if need be to avoid variable capture. +pushBinds :: Ord n => Set n -> BindStack n -> [Bind n] -> (BindStack n, [Bind n]) +pushBinds fns stack bs + = mapAccumL (pushBind fns) stack bs + + +-- | Push a bind onto a bind stack, +-- anonymizing it if need be to avoid variable capture. +pushBind + :: Ord n + => Set n -- ^ Names that need to be rewritten. + -> BindStack n -- ^ Current bind stack. + -> Bind n -- ^ Bind to push. + -> (BindStack n, Bind n) -- ^ New stack and possibly anonymised bind. + +pushBind fns bs@(BindStack stack env dAnon dName) bb + = case bb of + -- Push already anonymous bind on stack. + BAnon t + -> ( BindStack (BAnon t : stack) (BAnon t : env) (dAnon + 1) dName + , BAnon t) + + -- If the binder needs to be rewritten then push the original name on the + -- 'stackBinds' to remember this. + BName n t + | Set.member n fns + -> ( BindStack (BName n t : stack) (BAnon t : env) dAnon (dName + 1) + , BAnon t) + + | otherwise + -> ( BindStack stack (BName n t : env) dAnon dName + , bb) + + -- Binder was a wildcard. + _ -> (bs, bb) + + + +-- | Compare a `Bound` against the one we're substituting for. +substBound + :: Ord n + => BindStack n -- ^ Current Bind stack during substitution. + -> Bound n -- ^ Bound we're substituting for. + -> Bound n -- ^ Bound we're looking at now. + -> Either + (Bound n) -- Bound doesn't match, but replace with this one. + Int -- Bound matches, drop the thing being substituted and + -- and lift indices this many steps. + +substBound (BindStack binds _ dAnon dName) u u' + -- Bound name matches the one that we're substituting for. + | UName n1 <- u + , UName n2 <- u' + , n1 == n2 + = Right (dAnon + dName) + + -- Bound index matches the one that we're substituting for. + | UIx i1 <- u + , UIx i2 <- u' + , i1 + dAnon == i2 + = Right (dAnon + dName) + + -- The Bind for this name was rewritten to avoid variable capture, + -- so we also have to update the bound occurrence. + | UName _ <- u' + , Just ix <- findIndex (boundMatchesBind u') binds + = Left $ UIx ix + + -- Bound index doesn't match, but lower this index by one to account + -- for the removal of the outer binder. + | UIx i2 <- u' + , i2 > dAnon + , cutOffset <- case u of + UIx{} -> 1 + _ -> 0 + = Left $ UIx (i2 + dName - cutOffset) + + -- Some name that didn't match. + | otherwise + = Left u' + + +------------------------------------------------------------------------------- +-- | Push a level-1 binder on the rewrite stack. +bind1 :: Ord n => Sub n -> Bind n -> (Sub n, Bind n) +bind1 sub b + = let (stackT', b') = pushBind (subConflict1 sub) (subStack1 sub) b + in (sub { subStack1 = stackT' }, b') + + +-- | Push some level-1 binders on the rewrite stack. +bind1s :: Ord n => Sub n -> [Bind n] -> (Sub n, [Bind n]) +bind1s = mapAccumL bind1 + + +-- | Push a level-0 binder on the rewrite stack. +bind0 :: Ord n => Sub n -> Bind n -> (Sub n, Bind n) +bind0 sub b + = let b1 = renameWith sub b + (stackX', b2) = pushBind (subConflict0 sub) (subStack0 sub) b1 + in ( sub { subStack0 = stackX' + , subShadow0 = subShadow0 sub + || namedBoundMatchesBind (subBound sub) b2 } + , b2) + + +-- | Push some level-0 binders on the rewrite stack. +bind0s :: Ord n => Sub n -> [Bind n] -> (Sub n, [Bind n]) +bind0s = mapAccumL bind0 + + +-- | Rewrite the use of a level-1 binder if need be. +use1 :: Ord n => Sub n -> Bound n -> Bound n +use1 sub u + | UName _ <- u + , BindStack binds _ _ _ <- subStack1 sub + , Just ix <- findIndex (boundMatchesBind u) binds + = UIx ix + + | otherwise + = u + + +-- | Rewrite the use of a level-0 binder if need be. +use0 :: Ord n => Sub n -> Bound n -> Bound n +use0 sub u + | UName _ <- u + , BindStack binds _ _ _ <- subStack0 sub + , Just ix <- findIndex (boundMatchesBind u) binds + = UIx ix + + | otherwise + = u + 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,18 +2,22 @@ module DDC.Type.Transform.SpreadT (SpreadT(..)) where +import DDC.Type.DataDef import DDC.Type.Exp -import DDC.Type.Env (Env) +import DDC.Type.Env (TypeEnv) import qualified DDC.Type.Env as Env import qualified DDC.Type.Sum as T +import qualified Data.Map as Map class SpreadT (c :: * -> *) where - -- | Spread type annotations from variable binders in to the bound - -- occurrences. + -- | Rewrite `UName` bounds to `UPrim` bounds and attach their types. + -- Primitives have their types attached because they are so common in the + -- language, their types are closed, and we don't want to keep having to + -- look them up from the environment. spreadT :: forall n. Ord n - => Env n -> c n -> c n + => TypeEnv n -> c n -> c n instance SpreadT Type where @@ -22,11 +26,16 @@ TVar u -> TVar $ spreadT kenv u TCon tc -> TCon $ spreadT kenv tc + TAbs b t + -> let b' = spreadT kenv b + in TAbs b' $ spreadT (Env.extend b' kenv) t + + TApp t1 t2 -> TApp (spreadT kenv t1) (spreadT kenv t2) + TForall b t -> let b' = spreadT kenv b in TForall b' $ spreadT (Env.extend b' kenv) t - TApp t1 t2 -> TApp (spreadT kenv t1) (spreadT kenv t2) TSum ss -> TSum (spreadT kenv ss) @@ -47,21 +56,50 @@ instance SpreadT Bound where spreadT kenv uu - | Just t' <- Env.lookup uu kenv = case uu of - UIx ix _ -> UIx ix t' - UPrim n _ -> UPrim n t' - UName n _ - -> if Env.isPrim kenv n - then UPrim n t' - else UName n t' - - | otherwise = uu + UIx{} -> uu + UPrim{} -> uu + UName n + -> case Env.envPrimFun kenv n of + Nothing -> UName n + Just t -> UPrim n t + instance SpreadT TyCon where spreadT kenv tc = case tc of - TyConBound u -> TyConBound (spreadT kenv u) + TyConBound (UName n) _ + -> case Env.envPrimFun kenv n of + Nothing -> tc + Just t -> TyConBound (UPrim n t) t + _ -> tc + + +instance SpreadT DataDef where + spreadT kenv def@DataDef{} + = def + { dataDefCtors + = case dataDefCtors def of + Nothing -> Nothing + Just ctors -> Just (map (spreadT kenv) ctors) } + + +instance SpreadT DataDefs where + spreadT kenv defs + = defs + { dataDefsTypes = Map.map (spreadT kenv) (dataDefsTypes defs) + , dataDefsCtors = Map.map (spreadT kenv) (dataDefsCtors defs) } + + +instance SpreadT DataType where + spreadT _kenv dt = dt + + +instance SpreadT DataCtor where + spreadT kenv dc@DataCtor{} + = dc + { dataCtorFieldTypes = map (spreadT kenv) (dataCtorFieldTypes dc) + , dataCtorResultType = spreadT kenv (dataCtorResultType dc) } 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 @@ -1,23 +1,20 @@ -- | Capture avoiding substitution of types in types. module DDC.Type.Transform.SubstituteT - ( SubstituteT(..) - , substituteT + ( substituteT , substituteTs , substituteBoundT + , SubstituteT(..) , BindStack(..) , pushBind , pushBinds , substBound) where -import DDC.Type.Exp -import DDC.Type.Compounds import DDC.Core.Collect -import DDC.Type.Transform.LiftT -import DDC.Type.Transform.Crush -import DDC.Type.Transform.Trim -import DDC.Type.Rewrite +import DDC.Type.Transform.BoundT +import DDC.Type.Transform.Rename +import DDC.Type.Exp.Simple import Data.Maybe import qualified DDC.Type.Sum as Sum import qualified DDC.Type.Env as Env @@ -25,7 +22,7 @@ import Data.Set (Set) --- | Substitute a `Type` for the `Bound` corresponding to some `Bind` in a thing. +-- | Substitute a `Type` for the `Bound` corresponding to a `Bind` in a thing. substituteT :: (SubstituteT c, Ord n) => Bind n -> Type n -> c n -> c n substituteT b t x = case takeSubstBoundOfBind b of @@ -58,15 +55,15 @@ class SubstituteT (c :: * -> *) where -- | Substitute a type into some thing. - -- In the target, if we find a named binder that would capture a free variable - -- in the type to substitute, then we rewrite that binder to anonymous form, - -- avoiding the capture. + -- In the target, if we find a named binder that would capture a free + -- variable in the type to substitute, then we rewrite that binder to + -- anonymous form, avoiding the capture. substituteWithT :: forall n. Ord n - => Bound n -- ^ Bound variable that we're subsituting into. - -> Type n -- ^ Type to substitute. - -> Set n -- ^ Names of free varaibles in the type to substitute. - -> BindStack n -- ^ Bind stack. + => Bound n -- ^ Bound variable that we're subsituting into. + -> Type n -- ^ Type to substitute. + -> Set n -- ^ Names of free varaibles in the type to substitute. + -> BindStack n -- ^ Bind stack. -> c n -> c n @@ -81,32 +78,29 @@ substituteWithT u t fns stack tt = let down = substituteWithT u t fns stack in case tt of - TCon{} -> tt - - -- Crush out compound effects and closures as we substitute them. - TApp t1 t2 - -> case t1 of - TCon (TyConSpec TcConHeadRead) - -> crushEffect (TApp t1 (down t2)) - - TCon (TyConSpec TcConDeepRead) - -> crushEffect (TApp t1 (down t2)) + TCon{} -> tt - TCon (TyConSpec TcConDeepWrite) - -> crushEffect (TApp t1 (down t2)) + TVar u' + -> case substBound stack u u' of + Left u'' -> TVar u'' + Right n -> liftT n t - TCon (TyConSpec TcConDeepAlloc) - -> crushEffect (TApp t1 (down t2)) + TAbs b tBody + | namedBoundMatchesBind u b -> tt + | otherwise + -> let -- Substitute into the annotation on the binder. + bSub = down b - -- If the closure is miskinded then trimClosure can - -- return Nothing, so we leave it untrimmed. - TCon (TyConSpec TcConDeepUse) - -> fromMaybe tt (trimClosure (TApp t1 (down t2))) + -- Push bind onto stack, and anonymise to avoid capture. + (stack', b') = pushBind fns stack bSub + + -- Substitute into body. + tBody' = substituteWithT u t fns stack' tBody - _ -> TApp (down t1) (down t2) + in TAbs b' tBody' - TSum ss - -> TSum (down ss) + TApp t1 t2 + -> TApp (down t1) (down t2) TForall b tBody | namedBoundMatchesBind u b -> tt @@ -114,7 +108,7 @@ -> let -- Substitute into the annotation on the binder. bSub = down b - -- Push bind onto stack, and anonymise to avoid capture if needed + -- Push bind onto stack, and anonymise to avoid capture. (stack', b') = pushBind fns stack bSub -- Substitute into body. @@ -122,10 +116,7 @@ in TForall b' tBody' - TVar u' - -> case substBound stack u u' of - Left u'' -> TVar u'' - Right n -> liftT n t + TSum ss -> TSum (down ss) instance SubstituteT TypeSum where 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,163 +0,0 @@ - -module DDC.Type.Transform.Trim - (trimClosure) -where -import DDC.Core.Collect -import DDC.Type.Check.CheckCon -import DDC.Type.Exp -import DDC.Type.Compounds -import DDC.Type.Predicates -import Control.Monad -import Data.Set (Set) -import qualified DDC.Type.Env as Env -import qualified DDC.Type.Sum as Sum -import qualified Data.Set as Set - - --- | Trim compound closures into their components. --- --- This is like `crushEffect`, but for closures instead of effects. --- --- For example, trimming @Int r2 -(Read r1 | Use r1)> Int r2@ yields just @Use r1@. --- Only @r1@ might contain an actual store object that is reachable from a function --- closure with such a type. --- --- This function assumes the closure is well-kinded, and may return `Nothing` if --- this is not the case. -trimClosure - :: Ord n - => Closure n - -> Maybe (Closure n) - -trimClosure cc - = liftM TSum $ trimToSumC cc - - --- | Trim a closure down to a closure sum. --- May return 'Nothing' if the closure is mis-kinded. -trimToSumC - :: forall n. Ord n - => Closure n -> Maybe (TypeSum n) - -trimToSumC cc - = case cc of - -- Keep closure variables. - TVar{} -> Just $ Sum.singleton kClosure cc - - -- There aren't any naked constructors of closure type. - -- If we find a constructor the closure is miskinded. - TCon{} -> Nothing - - -- The body of a forall should have data or witness kind. - -- If we find a forall then the closure is miskinded. - TForall{} -> Nothing - - -- Keep use constructor applied to a region. - TApp (TCon (TyConSpec TcConUse)) _ - -> Just $ Sum.singleton kClosure cc - - -- Trim DeepUse constructor applied to a data type. - TApp (TCon (TyConSpec TcConDeepUse)) t2 - -> Just $ trimDeepUsedD t2 - - -- Some other constructor we don't know about, - -- perhaps using a type variable of higher kind. - TApp{} -> Just $ Sum.singleton kClosure cc - - -- Trim components of a closure sum and rebuild the sum. - TSum ts - -> case sequence $ map trimToSumC $ Sum.toList ts of - Nothing -> Nothing - Just sums -> Just $ Sum.fromList kClosure - $ concatMap Sum.toList sums - - --- | Trim the argument of a DeepUsed constructor down to a closure sum. --- The argument is of data kind. -trimDeepUsedD - :: forall n. Ord n - => Type n -> TypeSum n - -trimDeepUsedD tt - = case tt of - -- Keep type variables. - TVar{} -> Sum.singleton kClosure $ tDeepUse tt - - -- Naked data constructors like 'Unit' don't contain region variables, - -- but the interpreter uses constructors of region kind to encode - -- region handes, that we need to keep. - TCon tc - | Just k <- takeKindOfTyCon tc - , isRegionKind k - -> Sum.singleton kClosure $ tDeepUse tt - - | otherwise - -> Sum.empty kClosure - - -- Add locally bound variable to the environment. - -- See Note: Trimming Foralls. - TForall{} - -> let ns = freeT Env.empty tt :: Set (Bound n) - in if Set.size ns == 0 - then Sum.empty kClosure - else Sum.singleton kClosure $ tDeepUse tt - - -- Trim function constructors. - -- See Note: Material variables and the interpreter - TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFun)) _t1) _eff) clo) _t2 - -> Sum.singleton kClosure clo - - -- Trim a type application. - -- See Note: Trimming with higher kinded type vars. - TApp{} - -> case takeTyConApps tt of - Just (tc, args) - | Just k <- takeKindOfTyCon tc - , Just cs <- sequence $ zipWith makeUsed (takeKFuns' k) args - -> Sum.fromList kClosure cs - - _ -> Sum.singleton kClosure $ tDeepUse tt - - -- We shouldn't get sums of data types in regular code, - -- but the (tBot kData) form might appear in debugging. - TSum{} -> Sum.singleton kClosure $ tDeepUse tt - - --- | Make the appropriate Use term for a type of the given kind, or `Nothing` if --- there isn't one. Also recursively trim types of data kind. -makeUsed :: (Eq n, Ord n) => Kind n -> Type n -> Maybe (Closure n) -makeUsed k t - | isRegionKind k = Just $ tUse t - | isDataKind k = Just $ TSum $ trimDeepUsedD t - | isEffectKind k = Just $ tBot kClosure - | isClosureKind k = Just $ t - | otherwise = Nothing - - -{- [Note: Trimming with higher kinded type vars] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We can't just look at the free variables here and wrap Use and DeepUse constructors - around them, as the type may contain higher kinded type variables such as: (t a). - We cannot simply drop such variables, as they may be substituted for types that - contain components that we must keep in the closure. To handle this, when we see - higher kinded type varibles we preserve the entire type application, which is - DeepUse (t a) in this example. - - [Note: Trimming Foralls] - ~~~~~~~~~~~~~~~~~~~~~~~~ - For now we just drop the forall if the free vars list is empty. This is ok because - we only do this at top-level, so don't need to lower debruijn indices to account for - deleted intermediate quantifiers. - - [Note: Material variables and the interpreter] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Even though we're not tracking material vars properly yet, - for the interpreter we need to ignore the non-material parameters of the - function constructor so that we can treat store location constructors as - having an empty closure. For example: - - L2# :: Int R1# -> Int R1# - - This does not capture the R1# region, even the handle for it is in its type. --} - 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 @@ --- | Universes of the Disciple Core language. module DDC.Type.Universe ( Universe(..) + , universeUp , universeFromType3 , universeFromType2 , universeFromType1 , universeOfType) where import DDC.Type.Exp -import DDC.Type.Compounds +import DDC.Data.Pretty +import DDC.Type.Env as Env import qualified DDC.Type.Sum as T -- | Universes of the Disciple Core language. data Universe + -- | A numbered universe (levels 4..) + = UniverseLevel Int + -- | (level 3). The universe of sorts. -- Sorts classify kinds. - = UniverseSort + | UniverseSort -- | (level 2). The universe of kinds. -- Kinds classify specifications. @@ -45,6 +49,29 @@ deriving (Show, Eq) +instance Pretty Universe where + ppr u + = case u of + UniverseLevel i -> text "Universe" <> int i + UniverseSort -> text "Sort" + UniverseKind -> text "Kind" + UniverseSpec -> text "Spec" + UniverseWitness -> text "Witness" + UniverseData -> text "Data" + + +-- | Take the next highest universe of the given one. +universeUp :: Universe -> Universe +universeUp uu + = case uu of + UniverseLevel n -> UniverseLevel (n + 1) + UniverseSort -> UniverseLevel 4 + UniverseKind -> UniverseSort + UniverseSpec -> UniverseKind + UniverseWitness -> UniverseSpec + UniverseData -> UniverseSpec + + -- | Given the type of the type of the type of some thing (up three levels), -- yield the universe of the original thing, or `Nothing` it was badly formed. universeFromType3 :: Type n -> Maybe Universe @@ -61,6 +88,7 @@ universeFromType2 tt = case tt of TVar _ -> Nothing + TCon (TyConSort _) -> Just UniverseSpec TCon (TyConKind kc) @@ -69,48 +97,69 @@ KiConData -> Just UniverseData _ -> Nothing - TCon (TyConWitness _) -> Nothing - TCon (TyConSpec _) -> Nothing - TCon (TyConBound _) -> Nothing - TForall _ _ -> Nothing + TCon TyConWitness{} -> Nothing + TCon TyConSpec{} -> Nothing + TCon TyConBound{} -> Nothing + TCon TyConExists{} -> Nothing + + TAbs{} -> Nothing TApp _ t2 -> universeFromType2 t2 + TForall{} -> Nothing TSum _ -> Nothing -- | Given the type of some thing (up one level), -- yield the universe of the original thing, or `Nothing` if it was badly formed. -universeFromType1 :: Type n -> Maybe Universe -universeFromType1 tt +universeFromType1 :: Ord n => Env n -> Type n -> Maybe Universe +universeFromType1 kenv tt = case tt of - TVar u -> universeFromType2 (typeOfBound u) - TCon (TyConSort _) -> Just UniverseKind - TCon (TyConKind _) -> Just UniverseSpec - TCon (TyConWitness _) -> Just UniverseWitness - TCon (TyConSpec TcConFun) -> Just UniverseData - TCon (TyConSpec _) -> Nothing - TCon (TyConBound u) -> universeFromType2 (typeOfBound u) - TForall _ t2 -> universeFromType1 t2 - TApp _ t2 -> universeFromType1 t2 - TSum _ -> Nothing + TVar n + -> case Env.lookup n kenv of + Nothing -> Nothing + Just k -> universeFromType2 k + TCon (TyConSort _) -> Just UniverseKind + TCon (TyConKind _) -> Just UniverseSpec + TCon (TyConWitness _) -> Just UniverseWitness + + TCon (TyConSpec TcConUnit) -> Just UniverseData + TCon (TyConSpec TcConFun) -> Just UniverseData + TCon (TyConSpec TcConSusp) -> Just UniverseData + TCon (TyConSpec _) -> Nothing + + TCon (TyConBound _ k) -> universeFromType2 k + TCon (TyConExists _ k) -> universeFromType2 k + TAbs b t2 -> universeFromType1 (Env.extend b kenv) t2 + TApp t1 _ -> universeFromType1 kenv t1 + TForall b t2 -> universeFromType1 (Env.extend b kenv) t2 + TSum _ -> Nothing + + -- | Yield the universe of some type. -- -- @ universeOfType (tBot kEffect) = UniverseSpec -- universeOfType kRegion = UniverseKind -- @ -- -universeOfType :: Type n -> Maybe Universe -universeOfType tt +universeOfType :: Ord n => Env n -> Type n -> Maybe Universe +universeOfType kenv tt = case tt of - TVar u -> universeFromType1 (typeOfBound u) + TVar n + -> case Env.lookup n kenv of + Nothing -> Nothing + Just k -> universeFromType1 kenv k + TCon (TyConSort _) -> Just UniverseSort TCon (TyConKind _) -> Just UniverseKind TCon (TyConWitness _) -> Just UniverseSpec TCon (TyConSpec _) -> Just UniverseSpec - TCon (TyConBound u) -> universeFromType1 (typeOfBound u) - TForall _ t2 -> universeOfType t2 - TApp _ t2 -> universeOfType t2 - TSum ss -> universeFromType1 (T.kindOfSum ss) + TCon (TyConBound _ k) -> universeFromType1 kenv k + TCon (TyConExists _ k) -> universeFromType1 kenv k + + TAbs b t2 -> universeOfType (Env.extend b kenv) t2 + TApp _ t2 -> universeOfType kenv t2 + TForall b t2 -> universeOfType (Env.extend b kenv) t2 + TSum ss -> universeFromType1 kenv (T.kindOfSum ss) 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-2012 The Disciplined Disciple Compiler Strike Force +Copyrite (K) 2007-2016 The Disciplined Disciple Compiler Strike Force All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy @@ -13,18 +13,4 @@ The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - -------------------------------------------------------------------------------- -Under Australian law copyright is free and automatic. -By contributing to DDC authors grant all rights they have regarding their -contributions to the other members of the Disciplined Disciple Compiler Strike -Force, past, present and future, as well as placing their contributions under -the above license. - -Use "darcs show authors" to get a list of Strike Force members. - -------------------------------------------------------------------------------- -Redistributions of libraries in ./external are governed by their own licenses: - - - TinyPTC GNU Lesser General Public License - 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.2.1.2 +Version: 0.4.3.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -9,92 +9,242 @@ Stability: experimental Category: Compilers/Interpreters Homepage: http://disciple.ouroborus.net -Bug-reports: disciple@ouroborus.net -Synopsis: Disciple Core language and type checker. +Synopsis: Disciplined Disciple Compiler core language and type checker. Description: - Disciple Core is an explicitly typed language based on System-F2, intended - as an intermediate representation for a compiler. In addition to the features of - System-F2 it supports region, effect and closure typing. Evaluation order is - left-to-right call-by-value by default, but explicit lazy evaluation is also supported. - There is also a capability system to track whether objects are mutable or constant, - and to ensure that computations that perform visible side effects are not suspended with - lazy evaluation. + Disciple Core is an explicitly typed language based on System-F2, + intended as an intermediate representation for a compiler. In addition + to the polymorphism of System-F2 it supports region, effect and closure + typing. Evaluation order is left-to-right call-by-value by default. + There is a capability system to track whether objects are mutable or + constant, and to ensure that computations that perform visible side + effects are not reordered inappropriately. - See the @ddci-core@ package for a user-facing interpreter. + See the @ddc-tools@ package for a user-facing interpreter and compiler. Library Build-Depends: - base == 4.6.*, + base >= 4.6 && < 4.10, + array >= 0.4 && < 0.6, + deepseq >= 1.3 && < 1.5, containers == 0.5.*, - array == 0.4.*, - transformers == 0.3.*, - mtl == 2.1.*, - ddc-base == 0.2.1.* + directory == 1.2.*, + text >= 1.0 && < 1.3, + transformers == 0.5.*, + mtl >= 2.2 && < 2.3, + inchworm >= 1.0.2 && < 1.1, + filepath >= 1.4.1 && < 1.5, + wl-pprint >= 1.2 && < 1.3, + parsec >= 3.1 && < 3.2 Exposed-modules: - DDC.Core.Check.CheckExp - DDC.Core.Check.CheckWitness - DDC.Core.Check.Error - DDC.Core.Check.TaggedClosure - DDC.Core.Parser.Lexer - DDC.Core.Parser.Tokens - DDC.Core.Transform.LiftW - DDC.Core.Transform.LiftX + DDC.Control.Check + DDC.Control.Panic + DDC.Control.Parser + + DDC.Core.Collect.Support + DDC.Core.Collect.BindStruct + DDC.Core.Collect.FreeT + DDC.Core.Collect.FreeX + + DDC.Core.Env.EnvT + DDC.Core.Env.EnvX + + DDC.Core.Exp.Annot.AnT + DDC.Core.Exp.Annot.AnTEC + DDC.Core.Exp.Annot.Context + DDC.Core.Exp.Annot.Ctx + + DDC.Core.Exp.Generic.BindStruct + + DDC.Core.Exp.Annot + DDC.Core.Exp.Generic + DDC.Core.Exp.Literal + + DDC.Core.Lexer.Offside + DDC.Core.Lexer.Tokens + DDC.Core.Lexer.Unicode + + DDC.Core.Transform.BoundT + DDC.Core.Transform.BoundX + DDC.Core.Transform.MapT + DDC.Core.Transform.Reannotate + DDC.Core.Transform.Rename DDC.Core.Transform.SpreadX DDC.Core.Transform.SubstituteTX DDC.Core.Transform.SubstituteWX DDC.Core.Transform.SubstituteXX + + DDC.Core.Call DDC.Core.Check DDC.Core.Collect - DDC.Core.Compounds - DDC.Core.DataDef DDC.Core.Exp - DDC.Core.Pretty - DDC.Core.Predicates + DDC.Core.Fragment + DDC.Core.Lexer + DDC.Core.Load + DDC.Core.Module DDC.Core.Parser - DDC.Type.Check.Monad - DDC.Type.Transform.Crush + DDC.Core.Pretty + + DDC.Data.Canned + DDC.Data.Env + DDC.Data.ListUtils + DDC.Data.Name + DDC.Data.Pretty + DDC.Data.SourcePos + + DDC.Type.Exp.Flat.Exp + DDC.Type.Exp.Flat.Pretty + + DDC.Type.Exp.Generic.Binding + DDC.Type.Exp.Generic.Compounds + DDC.Type.Exp.Generic.Exp + DDC.Type.Exp.Generic.NFData + DDC.Type.Exp.Generic.Predicates + DDC.Type.Exp.Generic.Pretty + + DDC.Type.Exp.Simple.Compounds + DDC.Type.Exp.Simple.Equiv + DDC.Type.Exp.Simple.Exp + DDC.Type.Exp.Simple.Predicates + DDC.Type.Exp.Simple.Subsumes + + DDC.Type.Exp.Flat + DDC.Type.Exp.Generic + DDC.Type.Exp.Pretty + DDC.Type.Exp.Simple + DDC.Type.Exp.TyCon + + DDC.Type.Transform.BoundT DDC.Type.Transform.Instantiate - DDC.Type.Transform.LiftT - DDC.Type.Transform.LowerT + DDC.Type.Transform.Rename DDC.Type.Transform.SpreadT DDC.Type.Transform.SubstituteT - DDC.Type.Transform.Trim - DDC.Type.Check - DDC.Type.Compounds + + DDC.Type.Bind + DDC.Type.DataDef DDC.Type.Env - DDC.Type.Equiv DDC.Type.Exp - DDC.Type.Parser - DDC.Type.Predicates - DDC.Type.Rewrite - DDC.Type.Subsumes DDC.Type.Sum DDC.Type.Universe + DDC.Version + + Other-modules: - DDC.Core.Check.ErrorMessage - DDC.Type.Check.CheckCon - DDC.Type.Check.CheckError - DDC.Type.Pretty - + DDC.Core.Check.Context.Apply + DDC.Core.Check.Context.Base + DDC.Core.Check.Context.Effect + DDC.Core.Check.Context.Elem + DDC.Core.Check.Context.Mode + + DDC.Core.Check.Error.ErrorData + DDC.Core.Check.Error.ErrorDataMessage + DDC.Core.Check.Error.ErrorExp + DDC.Core.Check.Error.ErrorExpMessage + DDC.Core.Check.Error.ErrorType + DDC.Core.Check.Error.ErrorTypeMessage + + DDC.Core.Check.Judge.Kind.TyCon + + DDC.Core.Check.Judge.Type.AppT + DDC.Core.Check.Judge.Type.AppX + DDC.Core.Check.Judge.Type.Base + DDC.Core.Check.Judge.Type.Case + DDC.Core.Check.Judge.Type.Cast + DDC.Core.Check.Judge.Type.DaCon + DDC.Core.Check.Judge.Type.LamT + DDC.Core.Check.Judge.Type.LamX + DDC.Core.Check.Judge.Type.Let + DDC.Core.Check.Judge.Type.LetPrivate + DDC.Core.Check.Judge.Type.Sub + DDC.Core.Check.Judge.Type.VarCon + DDC.Core.Check.Judge.Type.Witness + + DDC.Core.Check.Judge.DataDefs + DDC.Core.Check.Judge.EqT + DDC.Core.Check.Judge.Inst + DDC.Core.Check.Judge.Kind + DDC.Core.Check.Judge.Module + DDC.Core.Check.Judge.Sub + DDC.Core.Check.Judge.Witness + + DDC.Core.Check.Base + DDC.Core.Check.Config + DDC.Core.Check.Context + DDC.Core.Check.Error + DDC.Core.Check.Exp + + DDC.Core.Exp.Annot.Exp + DDC.Core.Exp.Annot.Compounds + DDC.Core.Exp.Annot.Predicates + DDC.Core.Exp.Annot.Pretty + + DDC.Core.Exp.Generic.Exp + DDC.Core.Exp.Generic.Compounds + DDC.Core.Exp.Generic.Predicates + DDC.Core.Exp.Generic.Pretty + + DDC.Core.Exp.DaCon + DDC.Core.Exp.WiCon + + DDC.Core.Fragment.Compliance + DDC.Core.Fragment.Error + DDC.Core.Fragment.Feature + DDC.Core.Fragment.Profile + + DDC.Core.Lexer.Token.Builtin + DDC.Core.Lexer.Token.Index + DDC.Core.Lexer.Token.Keyword + DDC.Core.Lexer.Token.Literal + DDC.Core.Lexer.Token.Names + DDC.Core.Lexer.Token.Operator + DDC.Core.Lexer.Token.Symbol + + DDC.Core.Module.Export + DDC.Core.Module.Import + DDC.Core.Module.Name + + DDC.Core.Parser.Base + DDC.Core.Parser.Context + DDC.Core.Parser.DataDef + DDC.Core.Parser.Exp + DDC.Core.Parser.ExportSpec + DDC.Core.Parser.ImportSpec + DDC.Core.Parser.Module + DDC.Core.Parser.Param + DDC.Core.Parser.Type + DDC.Core.Parser.Witness + + DDC.Type.Exp.Simple.NFData + DDC.Type.Exp.Simple.Pretty + GHC-options: -Wall -fno-warn-orphans - -fno-warn-missing-signatures -fno-warn-unused-do-bind + -fno-warn-missing-methods + -fno-warn-missing-signatures + -fno-warn-missing-pattern-synonym-signatures + -fno-warn-redundant-constraints Extensions: - ParallelListComp - PatternGuards - RankNTypes - FlexibleContexts - FlexibleInstances + NoMonomorphismRestriction + FunctionalDependencies MultiParamTypeClasses UndecidableInstances - KindSignatures - NoMonomorphismRestriction ScopedTypeVariables StandaloneDeriving + DeriveDataTypeable + FlexibleInstances + ParallelListComp + FlexibleContexts + ConstraintKinds DoAndIfThenElse - + PatternSynonyms + KindSignatures + PatternGuards + BangPatterns + InstanceSigs + ViewPatterns + RankNTypes +