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/Check.hs b/DDC/Core/Check.hs --- a/DDC/Core/Check.hs +++ b/DDC/Core/Check.hs @@ -1,4 +1,3 @@ - -- | Type checker for the Disciple Core language. -- -- The functions in this module do not check for language fragment compliance. @@ -15,6 +14,12 @@ -- * Checking Modules , checkModule + -- * Checking Types + , checkType, checkTypeM + , checkSpec + , kindOfSpec + , sortOfKind + -- * Checking Expressions , Mode (..) , Demand (..) @@ -24,16 +29,72 @@ , checkWitness, typeOfWitness , typeOfWiCon + -- * Kinds of Constructors + , takeSortOfKiCon + , kindOfTwCon + , kindOfTcCon + -- * Annotations , AnTEC(..) -- * Error messages - , Error (..)) + , Error (..) + , ErrorType (..) + , ErrorData (..)) where +import DDC.Core.Check.Judge.Kind +import DDC.Core.Check.Judge.Kind.TyCon +import DDC.Core.Check.Judge.Module +import DDC.Core.Check.Judge.Witness import DDC.Core.Check.Error -import DDC.Core.Check.ErrorMessage () -import DDC.Core.Check.Module import DDC.Core.Check.Exp -import DDC.Core.Check.Witness import DDC.Core.Check.Base - + + +-- | Check a type in the given universe with the given environment +-- Returns the updated type and its classifier (a kind or sort), +-- depeding on the universe of the type being checked. +checkType :: (Ord n, Show n, Pretty n) + => Config n -> Universe -> Type n + -> Either (Error a n) (Type n, Type n) + +checkType config uni tt + = evalCheck (mempty, 0, 0) + $ do (t, k, _) <- checkTypeM config emptyContext uni tt Recon + return (t, k) + + +-- | Check a spec in the given environment, returning an error or its kind. +checkSpec :: (Ord n, Show n, Pretty n) + => Config n -> Type n + -> Either (Error a n) (Type n, Kind n) + +checkSpec config tt + = evalCheck (mempty, 0, 0) + $ do (t, k, _) <- checkTypeM config emptyContext UniverseSpec tt Recon + return (t, k) + + +-- | Check a spec in an empty environment, returning an error or its kind. +kindOfSpec + :: (Ord n, Show n, Pretty n) + => Config n -> Type n + -> Either (Error a n) (Kind n) + +kindOfSpec config tt + = evalCheck (mempty, 0, 0) + $ do (_, k, _) <- checkTypeM config emptyContext UniverseSpec tt Recon + return k + + +-- | Check a kind in an empty environment, returning an error or its sort. +sortOfKind + :: (Ord n, Show n, Pretty n) + => Config n -> Kind n + -> Either (Error a n) (Sort n) + +sortOfKind config tt + = evalCheck (mempty, 0, 0) + $ do (_, s, _) <- checkTypeM config emptyContext UniverseKind tt Recon + return s + diff --git a/DDC/Core/Check/Base.hs b/DDC/Core/Check/Base.hs --- a/DDC/Core/Check/Base.hs +++ b/DDC/Core/Check/Base.hs @@ -13,25 +13,20 @@ , CheckTrace (..) , ctrace - , checkTypeM - , checkBindM - -- Things defined elsewhere. , throw, runCheck, evalCheck - , KindEnv, TypeEnv + , EnvX, EnvT, TypeEnv, KindEnv , Set , module DDC.Core.Check.Error , module DDC.Core.Collect , module DDC.Core.Pretty , module DDC.Core.Exp.Annot - , module DDC.Type.Check.Context + , module DDC.Core.Check.Context + , module DDC.Type.DataDef - , module DDC.Type.Equiv , module DDC.Type.Universe - , module DDC.Type.Compounds - , module DDC.Type.Predicates - , module DDC.Type.Exp - , module DDC.Base.Pretty + , module DDC.Type.Exp.Simple + , module DDC.Data.Pretty , module DDC.Data.ListUtils , module Control.Monad , module Data.Maybe) @@ -40,26 +35,26 @@ import DDC.Core.Collect import DDC.Core.Pretty import DDC.Core.Exp.Annot -import DDC.Type.Check.Context -import DDC.Type.Check (Config (..), configOfProfile) -import DDC.Type.Env (KindEnv, TypeEnv) +import DDC.Core.Check.Context +import DDC.Core.Check.Config +import DDC.Core.Env.EnvT (EnvT) +import DDC.Core.Env.EnvX (EnvX) + +import DDC.Type.Env (TypeEnv, KindEnv) import DDC.Type.DataDef -import DDC.Type.Equiv import DDC.Type.Universe -import DDC.Type.Compounds -import DDC.Type.Predicates -import DDC.Type.Exp -import DDC.Base.Pretty -import DDC.Control.Monad.Check (throw, runCheck, evalCheck) +import DDC.Type.Exp.Simple +import DDC.Control.Check (throw, runCheck, evalCheck) +import DDC.Data.Pretty import DDC.Data.ListUtils + import Control.Monad -import Data.Monoid hiding ((<>)) +import Data.Monoid hiding ((<>)) import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as Set -import qualified DDC.Type.Check as T -import qualified DDC.Control.Monad.Check as G -import Prelude hiding ((<$>)) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified DDC.Control.Check as G +import Prelude hiding ((<$>)) -- | Type checker monad. @@ -88,7 +83,7 @@ applyContext ctx tt = case applyContextEither ctx Set.empty tt of Left (tExt, tBind) - -> throw $ ErrorType $ T.ErrorInfinite tExt tBind + -> throw $ ErrorType $ ErrorTypeInfinite tExt tBind Right t -> return t @@ -97,7 +92,7 @@ applySolved ctx tt = case applySolvedEither ctx Set.empty tt of Left (tExt, tBind) - -> throw $ ErrorType $ T.ErrorInfinite tExt tBind + -> throw $ ErrorType $ ErrorTypeInfinite tExt tBind Right t -> return t @@ -126,57 +121,4 @@ let tr' = tr { checkTraceDoc = checkTraceDoc tr <$> doc' } G.put (tr', ix, pos) return () - - --- Bind ----------------------------------------------------------------------- --- | Check the type of a bind. -checkBindM - :: (Ord n, Show n, Pretty n) - => Config n -- ^ Checker configuration. - -> KindEnv n -- ^ Global kind environment. - -> Context n -- ^ Local context. - -> Universe -- ^ Universe for the type of the bind. - -> Bind n -- ^ Check this bind. - -> Mode n -- ^ Mode for bidirectional checking. - -> CheckM a n (Bind n, Type n, Context n) - -checkBindM config kenv ctx uni bb mode - = do (t', k, ctx') <- checkTypeM config kenv ctx uni - (typeOfBind bb) mode - return (replaceTypeOfBind t' bb, k, ctx') - - --- Type ----------------------------------------------------------------------- --- | Check a type in the exp checking monad, returning its kind. -checkTypeM - :: (Ord n, Show n, Pretty n) - => Config n -- ^ Checker configuration. - -> KindEnv n -- ^ Global kind environment. - -> Context n -- ^ Local context. - -> Universe -- ^ Universe the type is supposed to be in. - -> Type n -- ^ Check this type. - -> Mode n -- ^ Mode for bidirectional checking - -> CheckM a n (Type n, Kind n, Context n) - -checkTypeM config kenv ctx uni tt mode - = do - -- Run the inner type/kind checker computation, - -- giving it our current values for the existential and position - -- generators. - (tr, ix, pos) <- G.get - - let ((ix', pos'), result) - = G.runCheck (ix, pos) - $ T.checkTypeM config kenv ctx uni tt mode - - G.put (tr, ix', pos') - - -- If the type/kind checker returns an error then wrap it - -- so we can throw it from our exp/type checker. - case result of - Left err - -> throw $ ErrorType err - - Right (t, k, ctx') - -> return (t, k, ctx') 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,380 +1,17 @@ -- | Errors produced when checking core expressions. module DDC.Core.Check.Error - (Error(..)) + ( Error (..) + , ErrorType (..) + , ErrorData (..)) where -import DDC.Core.Exp -import DDC.Type.Universe -import qualified DDC.Type.Check as T - - --- | All the things that can go wrong when type checking an expression --- or witness. -data Error a n - -- Type ------------------------------------------- - -- | Found a kind error when checking a type. - = ErrorType - { errorTypeError :: T.Error n } - - -- | Found an error in the data type definitions. - | ErrorData - { errorData :: T.ErrorData n } - - -- Module ----------------------------------------- - -- | Exported value is undefined. - | ErrorExportUndefined - { errorName :: n } - - -- | Exported name is exported multiple times. - | ErrorExportDuplicate - { errorName :: n } - - -- | Type signature of exported binding does not match the type at - -- the definition site. - | ErrorExportMismatch - { errorName :: n - , errorExportType :: Type n - , errorDefType :: Type n } - - -- | Imported name is imported multiple times. - | ErrorImportDuplicate - { errorName :: n } - - -- | An imported 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 - , errorCtorFields :: Int - , errorPatternFields :: Int } - - -- | A case-expression where the pattern types could not be instantiated - -- with the arguments of the scrutinee type. - | ErrorCaseCannotInstantiate - { errorAnnot :: a - , errorChecking :: Exp a n - , errorTypeScrutinee :: Type n - , errorTypeCtor :: Type n } - - -- | A case-expression where the type of the scrutinee does not match - -- the type of the pattern. - | ErrorCaseScrutineeTypeMismatch - { errorAnnot :: a - , errorChecking :: Exp a n - , errorTypeScrutinee :: Type n - , errorTypePattern :: Type n } - - -- | A case-expression where the annotation on a pattern variable binder - -- does not match the field type of the constructor. - | ErrorCaseFieldTypeMismatch - { errorAnnot :: a - , errorChecking :: Exp a n - , errorTypeAnnot :: Type n - , errorTypeField :: Type n } - - -- | A case-expression where the result types of the alternatives are not - -- identical. - | ErrorCaseAltResultMismatch - { errorAnnot :: a - , errorChecking :: Exp a n - , errorAltType1 :: Type n - , errorAltType2 :: Type n } - - - -- Casts ------------------------------------------ - -- | A weakeff-cast where the type provided does not have effect kind. - | ErrorWeakEffNotEff - { errorAnnot :: a - , errorChecking :: Exp a n - , errorEffect :: Effect n - , errorKind :: Kind n } - - -- | A run cast applied to a non-suspension. - | ErrorRunNotSuspension - { errorAnnot :: a - , errorChecking :: Exp a n - , errorType :: Type n } - - -- | A run cast where the context does not support the suspended effect. - | ErrorRunNotSupported - { errorAnnot :: a - , errorChecking :: Exp a n - , errorEffect :: Effect n } +import DDC.Core.Check.Error.ErrorExp +import DDC.Core.Check.Error.ErrorExpMessage () - -- | A run cast where we cannot infer the type of the suspended computation - -- and thus cannot check if its effects are suppored by the context. - | ErrorRunCannotInfer - { errorAnnot :: a - , errorExp :: Exp a n } +import DDC.Core.Check.Error.ErrorType +import DDC.Core.Check.Error.ErrorTypeMessage () - -- Types ------------------------------------------ - -- | Found a naked `XType` that wasn't the argument of an application. - | ErrorNakedType - { errorAnnot :: a - , errorChecking :: Exp a n } +import DDC.Core.Check.Error.ErrorData +import DDC.Core.Check.Error.ErrorDataMessage () - -- Witnesses -------------------------------------- - -- | Found a naked `XWitness` that wasn't the argument of an application. - | ErrorNakedWitness - { errorAnnot :: a - , errorChecking :: Exp a n } - deriving (Show) 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,427 +0,0 @@ --- | Errors produced when checking core expressions. -module DDC.Core.Check.ErrorMessage - (Error(..)) -where -import DDC.Core.Pretty -import DDC.Core.Check.Error -import DDC.Type.Compounds -import DDC.Type.Universe - - -instance (Pretty a, Show n, Eq n, Pretty n) - => Pretty (Error a n) where - ppr err - = case err of - ErrorType err' - -> ppr err' - - ErrorData err' - -> ppr err' - - -- Modules --------------------------------------- - ErrorExportUndefined n - -> vcat [ text "Exported name '" <> ppr n <> text "' is undefined." ] - - ErrorExportDuplicate n - -> vcat [ text "Duplicate exported name '" <> ppr n <> text "'."] - - ErrorExportMismatch n tExport tDef - -> vcat [ text "Type of exported name does not match type of definition." - , text " with binding: " <> ppr n - , text " type of export: " <> ppr tExport - , text " type of definition: " <> ppr tDef ] - - ErrorImportDuplicate n - -> vcat [ text "Duplicate imported name '" <> ppr n <> text "'."] - - ErrorImportCapNotEffect n - -> vcat [ text "Imported capability '" - <> ppr n - <> text "' does not have kind Effect." ] - - ErrorImportValueNotData n - -> vcat [ text "Imported value '" - <> ppr n - <> text "' does not have kind Data." ] - - - -- Exp -------------------------------------------- - ErrorMismatch a tInferred tExpected xx - -> vcat [ ppr a - , text "Type mismatch." - , text " inferred type: " <> ppr tInferred - , text " expected type: " <> ppr tExpected - , empty - , text "with: " <> align (ppr xx) ] - - - -- Variable --------------------------------------- - ErrorUndefinedVar a u universe - -> case universe of - UniverseSpec - -> vcat [ ppr a - , text "Undefined spec variable: " <> ppr u ] - - UniverseData - -> vcat [ ppr a - , text "Undefined value variable: " <> ppr u ] - - UniverseWitness - -> vcat [ ppr a - , text "Undefined witness variable: " <> ppr u ] - - -- Universes other than the above don't have variables, - -- but let's not worry about that here. - _ -> vcat [ ppr a - , text "Undefined variable: " <> ppr u ] - - - -- Constructor ------------------------------------ - ErrorUndefinedCtor a xx - -> vcat [ ppr a - , text "Undefined data constructor: " <> ppr xx ] - - - -- Application ------------------------------------ - ErrorAppMismatch a xx t1 t2 - -> vcat [ ppr a - , text "Type mismatch in application." - , text " Function expects: " <> ppr t1 - , text " but argument is: " <> ppr t2 - , empty - , text "with: " <> align (ppr xx) ] - - ErrorAppNotFun a xx t1 - -> vcat [ ppr a - , text "Cannot apply non-function" - , text " of type: " <> ppr t1 - , empty - , text "with: " <> align (ppr xx) ] - - ErrorAppCannotInferPolymorphic a xx - -> vcat [ ppr a - , text "Cannot infer the type of a polymorphic expression." - , text " Please supply type annotations to constrain the functional" - , text " part to have a quantified type." - , text "with: " <> align (ppr xx) ] - - - -- Lambda ----------------------------------------- - ErrorLamShadow a xx b - -> vcat [ ppr a - , text "Cannot shadow named spec variable." - , text " binder: " <> ppr b - , text " is already in the environment." - , text "with: " <> align (ppr xx) ] - - ErrorLamNotPure a xx universe eff - -> vcat - [ ppr a - , text "Impure" <+> ppr universe <+> text "abstraction" - , text " has effect: " <> ppr eff - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLamBindBadKind a xx t1 k1 - -> vcat [ ppr a - , text "Function parameter has invalid kind." - , text " The function parameter: " <> ppr t1 - , text " has kind: " <> ppr k1 - , text " but it must be: Data or Witness" - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLamBodyNotData a xx b1 t2 k2 - -> vcat [ ppr a - , text "Result of function does not have data kind." - , text " In function with binder: " <> ppr b1 - , text " the result has type: " <> ppr t2 - , text " with kind: " <> ppr k2 - , text " but it must be: Data" - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLamParamUnannotated a xx b1 - -> vcat [ ppr a - , text "Missing type annotation on function parameter." - , text " With paramter: " <> ppr b1 - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLAMParamUnannotated a xx - -> vcat [ ppr a - , text "Type abstraction is missing a kind annotation." - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLAMParamBadSort a xx b s - -> vcat [ ppr a - , text "Kind annotation of type parameter has a bad sort." - , text " Parameter: " <> ppr b - , text " has sort: " <> ppr s - , empty - , text "with: " <> align (ppr xx) ] - - - -- Let -------------------------------------------- - ErrorLetMismatch a xx b t - -> vcat [ ppr a - , text "Type mismatch in let-binding." - , text " The binder: " <> ppr (binderOfBind b) - , text " has type: " <> ppr (typeOfBind b) - , text " but the body has type: " <> ppr t - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetBindingNotData a xx b k - -> vcat [ ppr a - , text "Let binding does not have data kind." - , text " The binding for: " <> ppr (binderOfBind b) - , text " has type: " <> ppr (typeOfBind b) - , text " with kind: " <> ppr k - , text " but it must be: Data " - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetBodyNotData a xx t k - -> vcat [ ppr a - , text "Let body does not have data kind." - , text " Body of let has type: " <> ppr t - , text " with kind: " <> ppr k - , text " but it must be: Data " - , empty - , text "with: " <> align (ppr xx) ] - - - -- Letrec ----------------------------------------- - ErrorLetrecRebound a xx b - -> vcat [ ppr a - , text "Redefined binder '" <> ppr b <> text "' in letrec." - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetrecMissingAnnot a b xx - -> vcat [ ppr a - , text "Missing or incomplete type annotation on recursive let-binding '" - <> ppr (binderOfBind b) <> text "'." - , text "Recursive functions must have full type annotations." - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetrecBindingNotLambda a xx x - -> vcat [ ppr a - , text "Letrec can only bind lambda abstractions." - , text " This is not one: " <> ppr x - , empty - , text "with: " <> align (ppr xx) ] - - - -- Letregion -------------------------------------- - ErrorLetRegionsNotRegion a xx bs ks - -> vcat [ ppr a - , text "Letregion binders do not have region kind." - , text " Region binders: " <> (hcat $ map ppr bs) - , text " has kinds: " <> (hcat $ map ppr ks) - , text " but they must all be: Region" - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetRegionsRebound a xx bs - -> vcat [ ppr a - , text "Region variables shadow existing ones." - , text " Region variables: " <> (hcat $ map ppr bs) - , text " are already in environment" - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetRegionFree a xx bs t - -> vcat [ ppr a - , text "Region variables escape scope of private." - , text " The region variables: " <> (hcat $ map ppr bs) - , text " is free in the body type: " <> ppr t - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetRegionWitnessInvalid a xx b - -> vcat [ ppr a - , text "Invalid witness type with private." - , text " The witness: " <> ppr b - , text " cannot be created with a private" - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetRegionWitnessConflict a xx b1 b2 - -> vcat [ ppr a - , text "Conflicting witness types with private." - , text " Witness binding: " <> ppr b1 - , text " conflicts with: " <> ppr b2 - , empty - , text "with: " <> align (ppr xx) ] - - ErrorLetRegionsWitnessOther a xx bs1 b2 - -> vcat [ ppr a - , text "Witness type is not for bound regions." - , text " private binds: " <> (hsep $ map ppr bs1) - , text " but witness type is: " <> ppr b2 - , empty - , text "with: " <> align (ppr xx) ] - - - -- Witnesses -------------------------------------- - ErrorWAppMismatch a ww t1 t2 - -> vcat [ ppr a - , text "Type mismatch in witness application." - , text " Constructor expects: " <> ppr t1 - , text " but argument is: " <> ppr t2 - , empty - , text "with: " <> align (ppr ww) ] - - ErrorWAppNotCtor a ww t1 t2 - -> vcat [ ppr a - , text "Type cannot apply non-constructor witness" - , text " of type: " <> ppr t1 - , text " to argument of type: " <> ppr t2 - , empty - , text "with: " <> align (ppr ww) ] - - 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 ------------------------------- - ErrorCaseScrutineeNotAlgebraic a xx tScrutinee - -> vcat [ ppr a - , text "Scrutinee of case expression is not algebraic data." - , text " Scrutinee type: " <> ppr tScrutinee - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseScrutineeTypeUndeclared a xx tScrutinee - -> vcat [ ppr a - , text "Type of scrutinee does not have a data declaration." - , text " Scrutinee type: " <> ppr tScrutinee - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseNoAlternatives a xx - -> vcat [ ppr a - , text "Case expression does not have any alternatives." - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseNonExhaustive a xx ns - -> vcat [ ppr a - , text "Case alternatives are non-exhaustive." - , text " Constructors not matched: " - <> (sep $ punctuate comma $ map ppr ns) - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseNonExhaustiveLarge a xx - -> vcat [ ppr a - , text "Case alternatives are non-exhaustive." - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseOverlapping a xx - -> vcat [ ppr a - , text "Case alternatives are overlapping." - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseTooManyBinders a xx uCtor iCtorFields iPatternFields - -> vcat [ ppr a - , text "Pattern has more binders than there are fields in the constructor." - , text " Contructor: " <> ppr uCtor - , text " has: " <> ppr iCtorFields - <+> text "fields" - , text " but there are: " <> ppr iPatternFields - <+> text "binders in the pattern" - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseCannotInstantiate a xx tScrutinee tCtor - -> vcat [ ppr a - , text "Cannot instantiate constructor type with scrutinee type args." - , text " Either the constructor has an invalid type," - , text " or the type of the scrutinee does not match the type of the pattern." - , text " Scrutinee type: " <> ppr tScrutinee - , text " Constructor type: " <> ppr tCtor - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseScrutineeTypeMismatch a xx tScrutinee tPattern - -> vcat [ ppr a - , text "Scrutinee type does not match result of pattern type." - , text " Scrutinee type: " <> ppr tScrutinee - , text " Pattern type: " <> ppr tPattern - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseFieldTypeMismatch a xx tAnnot tField - -> vcat [ ppr a - , text "Annotation on pattern variable does not match type of field." - , text " Annotation type: " <> ppr tAnnot - , text " Field type: " <> ppr tField - , empty - , text "with: " <> align (ppr xx) ] - - ErrorCaseAltResultMismatch a xx t1 t2 - -> vcat [ ppr a - , text "Mismatch in alternative result types." - , text " Type of alternative: " <> ppr t1 - , text " does not match: " <> ppr t2 - , empty - , text "with: " <> align (ppr xx) ] - - - -- Casts ------------------------------------------ - ErrorWeakEffNotEff a xx eff k - -> vcat [ ppr a - , text "Type provided for a 'weakeff' does not have effect kind." - , text " Type: " <> ppr eff - , text " has kind: " <> ppr k - , empty - , text "with: " <> align (ppr xx) ] - - ErrorRunNotSuspension a xx t - -> vcat [ ppr a - , text "Expression to run is not a suspension." - , text " Type: " <> ppr t - , empty - , text "with: " <> align (ppr xx) ] - - ErrorRunNotSupported a xx eff - -> vcat [ ppr a - , text "Effect of computation not supported by context." - , text " Effect: " <> ppr eff - , empty - , text "with: " <> align (ppr xx) ] - - ErrorRunCannotInfer a xx - -> vcat [ ppr a - , text "Cannot infer type of suspended computation." - , empty - , text "with: " <> align (ppr xx) ] - - - -- Type ------------------------------------------- - ErrorNakedType a xx - -> vcat [ ppr a - , text "Found naked type in core program." - , empty - , text "with: " <> align (ppr xx) ] - - - -- Witness ---------------------------------------- - ErrorNakedWitness a xx - -> vcat [ ppr a - , text "Found naked witness in core program." - , empty - , text "with: " <> align (ppr xx) ] - diff --git a/DDC/Core/Check/Exp.hs b/DDC/Core/Check/Exp.hs --- a/DDC/Core/Check/Exp.hs +++ b/DDC/Core/Check/Exp.hs @@ -46,7 +46,6 @@ import DDC.Core.Check.Judge.Type.Witness import DDC.Core.Check.Judge.Type.Base import DDC.Core.Transform.MapT -import qualified DDC.Type.Env as Env -- Wrappers ------------------------------------------------------------------- @@ -64,9 +63,8 @@ checkExp :: (Show a, Ord n, Show n, Pretty n) => Config n -- ^ Static configuration. - -> KindEnv n -- ^ Starting kind environment. - -> TypeEnv n -- ^ Starting type environment. - -> Mode n -- ^ Check mode. + -> 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. @@ -75,7 +73,7 @@ , Effect n) -- Effect of expression. , CheckTrace) -- Type checker debug trace. -checkExp !config !kenv !tenv !mode !demand !xx +checkExp !config !env !mode !demand !xx = (result, ct) where ((ct, _, _), result) @@ -84,10 +82,11 @@ -- Check the expression, using the monadic checking function. (xx', t, effs, ctx) <- checkExpM - (makeTable config - (Env.union kenv (configPrimKinds config)) - (Env.union tenv (configPrimTypes config))) - emptyContext mode demand xx + (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. @@ -110,14 +109,13 @@ -- | Like `checkExp`, but only return the value type of an expression. typeOfExp :: (Show a, Ord n, Pretty n, Show n) - => Config n -- ^ Static configuration. - -> KindEnv n -- ^ Starting Kind environment - -> TypeEnv n -- ^ Starting Type environment. - -> Exp a n -- ^ Expression to check. + => Config n -- ^ Static configuration. + -> EnvX n -- ^ Environment of expresion. + -> Exp a n -- ^ Expression to check. -> Either (Error a n) (Type n) -typeOfExp !config !kenv !tenv !xx - = case fst $ checkExp config kenv tenv Recon DemandNone xx of +typeOfExp !config !env !xx + = case fst $ checkExp config env Recon DemandNone xx of Left err -> Left err Right (_, t, _) -> Right t @@ -155,12 +153,10 @@ -- Table ---------------------------------------------------------------------- -makeTable :: Config n -> KindEnv n -> TypeEnv n -> Table a n -makeTable config kenv tenv +makeTable :: Config n -> Table a n +makeTable config = Table { tableConfig = config - , tableKindEnv = kenv - , tableTypeEnv = tenv , tableCheckExp = checkExpM , tableCheckVarCon = checkVarCon , tableCheckAppT = checkAppT 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/Eq.hs b/DDC/Core/Check/Judge/Eq.hs deleted file mode 100644 --- a/DDC/Core/Check/Judge/Eq.hs +++ /dev/null @@ -1,177 +0,0 @@ - -module DDC.Core.Check.Judge.Eq - (makeEq) -where -import DDC.Core.Check.Base -import qualified DDC.Type.Sum as Sum - - --- | Make two types equivalent to each other, --- or throw the provided error if this is not possible. -makeEq :: (Eq n, Ord n, Pretty n, Show n) - => Config n - -> a - -> Context n - -> Type n - -> Type n - -> Error a n - -> CheckM a n (Context n) - -makeEq config a ctx0 tL tR err - - -- EqLSolve - | Just iL <- takeExists tL - , not $ isTExists tR - = do let Just ctx1 = updateExists [] iL tR ctx0 - - ctrace $ vcat - [ text "** EqLSolve" - , text " LEFT: " <> ppr tL - , text " RIGHT: " <> ppr tR - , indent 4 $ ppr ctx0 - , indent 4 $ ppr ctx1 - , empty ] - - return ctx1 - - - -- EqRSolve - | Just iR <- takeExists tR - , not $ isTExists tL - = do let Just ctx1 = updateExists [] iR tL ctx0 - - ctrace $ vcat - [ text "** EqRSolve" - , text " LEFT: " <> ppr tL - , text " RIGHT: " <> ppr tR - , indent 4 $ ppr ctx0 - , indent 4 $ ppr ctx1 - , empty ] - - return ctx1 - - - -- EqLReach - -- Both types are existentials, and the left is bound earlier in the stack. - -- CAREFUL: The returned location is relative to the top of the stack, - -- hence we need lL > lR here. - | Just iL <- takeExists tL, Just lL <- locationOfExists iL ctx0 - , Just iR <- takeExists tR, Just lR <- locationOfExists iR ctx0 - , lL > lR - = do let Just ctx1 = updateExists [] iR tL ctx0 - - ctrace $ vcat - [ text "** EqLReach" - , text " LEFT: " <> ppr tL - , text " RIGHT: " <> ppr tR - , indent 4 $ ppr ctx0 - , indent 4 $ ppr ctx1 - , empty ] - - return ctx1 - - -- EqRReach - -- Both types are existentials, and the right is bound earlier in the stack. - -- CAREFUL: The returned location is relative to the top of the stack, - -- hence we need lR > lL here. - | Just iL <- takeExists tL, Just lL <- locationOfExists iL ctx0 - , Just iR <- takeExists tR, Just lR <- locationOfExists iR ctx0 - , lR > lL - = do let Just ctx1 = updateExists [] iL tR ctx0 - - ctrace $ vcat - [ text "** EqRReach" - , text " LEFT: " <> ppr tL - , text " RIGHT: " <> ppr tR - , indent 4 $ ppr ctx0 - , indent 4 $ ppr ctx1 - , empty ] - - return ctx1 - - - -- EqVar - | TVar u1 <- tL - , TVar u2 <- tR - , u1 == u2 - = do - ctrace $ vcat - [ text "** EqVar" - , text " LEFT: " <> ppr tL - , text " RIGHT: " <> ppr tR - , indent 4 $ ppr ctx0 - , empty ] - - return ctx0 - - - -- EqCon - | TCon tc1 <- tL - , TCon tc2 <- tR - , equivTyCon tc1 tc2 - = do - ctrace $ vcat - [ text "** EqCon" - , text " LEFT: " <> ppr tL - , text " RIGHT: " <> ppr tR - , indent 4 $ ppr ctx0 - , empty ] - - return ctx0 - - - -- EqApp - | TApp tL1 tL2 <- tL - , TApp tR1 tR2 <- tR - = do - ctrace $ vcat - [ text "*> EqApp" - , empty ] - - ctx1 <- makeEq config a ctx0 tL1 tR1 err - tL2' <- applyContext ctx1 tL2 - tR2' <- applyContext ctx1 tR2 - ctx2 <- makeEq config a ctx1 tL2' tR2' err - - ctrace $ vcat - [ text "*< EqApp" - , text " LEFT: " <> ppr tL - , text " RIGHT: " <> ppr tR - , indent 4 $ ppr ctx0 - , indent 4 $ ppr ctx2 - , empty ] - - return ctx2 - - - -- EqEquiv - | equivT tL tR - = do ctrace $ vcat - [ text "** EqEquiv" ] - - return ctx0 - - - -- Error - | otherwise - = do let caps = configGlobalCaps config - let tL' = crushEffect caps $ unpackSumT tL - let tR' = crushEffect caps $ unpackSumT tR - - ctrace $ vcat - [ text "DDC.Core.Check.Exp.Inst.makeEq: no match" - , text " LEFT: " <> (text $ show tL) - , text " RIGHT: " <> (text $ show tR) - , text " LEFTC: " <> (text $ show tL') - , text " RIGHTC: " <> (text $ show tR') - , indent 2 $ ppr ctx0 ] - - throw err - - --- | Unpack single element sums into plain types. -unpackSumT :: Type n -> Type n -unpackSumT (TSum ts) - | [t] <- Sum.toList ts = t -unpackSumT tt = tt - diff --git a/DDC/Core/Check/Judge/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/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 --- a/DDC/Core/Check/Judge/Sub.hs +++ b/DDC/Core/Check/Judge/Sub.hs @@ -1,207 +1,324 @@ module DDC.Core.Check.Judge.Sub - ( makeSub) + (makeSub) where import DDC.Type.Transform.SubstituteT +import DDC.Core.Check.Judge.EqT import DDC.Core.Exp.Annot.AnTEC -import DDC.Core.Check.Judge.Eq import DDC.Core.Check.Judge.Inst import DDC.Core.Check.Base +import qualified DDC.Core.Check.Context as Context +import qualified DDC.Core.Env.EnvT as EnvT +import qualified Data.Map.Strict as Map +import qualified DDC.Type.Sum as Sum -- | Make the left type a subtype of the right type, -- or throw the provided error if this is not possible. +-- +-- The inferred type may already be a subtype of the expected type, +-- and in that case we don't need to do anything extra. +-- +-- If the inferred type is a 'S e a' computation type and the expected +-- type is 'a' then we can force the inferred type to be the expected one +-- by running the computation. In this case we end up with more effects. +-- makeSub :: (Eq n, Ord n, Show n, Pretty n) - => Config n - -> a - -> Context n - -> Exp (AnTEC a n) n - -> Type n - -> Type n - -> Error a n + => 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 - , Context n) + ( Exp (AnTEC a n) n -- Expression after instantiations and running. + , TypeSum n -- More effects we might get from running the computation. + , Context n) -- Output context. -- NOTE: The order of cases matters here. -- For example, we do something different when both sides are -- existentials, vs the case when only one side is an existential. -makeSub config a ctx0 xL tL tR err +makeSub config a ctx0 x0 xL tL tR err - -- SubCon - -- Both sides are the same type constructor. - | TCon tc1 <- tL - , TCon tc2 <- tR - , equivTyCon tc1 tc2 + -- Sub_SynL + -- Expand type synonym on the left. + | TCon (TyConBound (UName n) _) <- tL + , Just tL' <- Map.lookup n $ EnvT.envtEquations + $ Context.contextEnvT ctx0 = do ctrace $ vcat - [ text "** SubCon" - , text " xL: " <> ppr xL - , text " tL: " <> ppr tL - , text " tR: " <> ppr tR - , indent 4 $ ppr ctx0 + [ text "** Sub_SynL" + , text " tL: " <> ppr tL + , text " tL': " <> ppr tL' + , text " tR: " <> ppr tR , empty ] - return (xL, ctx0) + makeSub config a ctx0 x0 xL tL' tR err - -- SubVar - -- Both sides are the same (rigid) type variable. - | TVar u1 <- tL - , TVar u2 <- tR - , u1 == u2 + -- Sub_SynR + -- Expand type synonym on the right. + | TCon (TyConBound (UName n) _) <- tR + , Just tR' <- Map.lookup n $ EnvT.envtEquations + $ Context.contextEnvT ctx0 = do ctrace $ vcat - [ text "** SubVar" - , text " xL: " <> ppr xL - , text " tL: " <> ppr tL - , text " tR: " <> ppr tR - , indent 4 $ ppr ctx0 + [ text "** Sub_SynR" + , text " tL: " <> ppr tL + , text " tR: " <> ppr tR + , text " tR': " <> ppr tR , empty ] - return (xL, ctx0) + makeSub config a ctx0 x0 xL tL tR' err - -- SubExVar - -- Both sides are the same existential. + -- Sub_ExVar + -- Both sides are already the same existential, + -- so we don't need to do anything further. | Just iL <- takeExists tL , Just iR <- takeExists tR , iL == iR = do ctrace $ vcat - [ text "** SubExVar" - , text " xL: " <> ppr xL + [ text "** Sub_ExVar" , text " tL: " <> ppr tL , text " tR: " <> ppr tR - , indent 4 $ ppr ctx0 - , empty ] - - return (xL, ctx0) - - - -- SubEquiv - -- Both sides are equivalent - | equivT tL tR - = do - ctrace $ vcat - [ text "** SubEquiv" , text " xL: " <> ppr xL - , text " tL: " <> ppr tL - , text " tR: " <> ppr tR , indent 4 $ ppr ctx0 , empty ] - return (xL, ctx0) + return ( xL + , Sum.empty kEffect + , ctx0) -- SubInstL - -- Left is an existential. + -- Left is an existential. | isTExists tL = do ctx1 <- makeInst config a ctx0 tR tL err ctrace $ vcat - [ text "** SubInstL" - , text " xL: " <> ppr xL + [ text "** Sub_InstL" , text " tL: " <> ppr tL , text " tR: " <> ppr tR + , text " xL: " <> ppr xL , indent 4 $ ppr ctx0 , indent 4 $ ppr ctx1 , empty ] - return (xL, ctx1) + return ( xL + , Sum.empty kEffect + , ctx1) -- SubInstR - -- Right is an existential. + -- Right is an existential. | isTExists tR = do ctx1 <- makeInst config a ctx0 tL tR err ctrace $ vcat - [ text "** SubInstR" - , text " xL: " <> ppr xL + [ text "** Sub_InstR" , text " tL: " <> ppr tL , text " tR: " <> ppr tR + , text " xL: " <> ppr xL , indent 4 $ ppr ctx0 , indent 4 $ ppr ctx1 , empty ] - return (xL, ctx1) + return ( xL + , Sum.empty kEffect + , ctx1) - -- SubArr - -- Both sides are arrow types. - | Just (tL1, tL2) <- takeTFun tL - , Just (tR1, tR2) <- takeTFun tR + -- 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 - ctrace $ vcat - [ text "*> SubArr" + -- 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 ] - (_, ctx1) <- makeSub config a ctx0 xL tR1 tL1 err - tL2' <- applyContext ctx1 tL2 - tR2' <- applyContext ctx1 tR2 - (_, ctx2) <- makeSub config a ctx1 xL tL2' tR2' err + 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 "*< SubArr" + [ 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, ctx2) + return ( xL + , Sum.union effs1 effs2 + , ctx2) + -- Sub_Run + -- The left (inferred) type is a suspension, but the right it not. + -- We run the suspension to get the result value and check if the + -- result has the expected type. Running the suspension causes some more + -- effects which we pass pack to the caller. + -- + | Just (tEffect, tResult) <- takeTSusp tL + , Nothing <- takeTSusp tR + = do + ctrace $ vcat + [ text "** Sub_Run" + , text " tL: " <> ppr tL + , text " tR: " <> ppr tR + , text " xL: " <> ppr xL + , text " tEffect: " <> ppr tEffect + , text " tResult: " <> ppr tResult + , empty ] - -- SubApp - -- Both sides are type applications. - -- Assumes non-function type constructors are invariant. + let aRun = AnTEC tResult tEffect (tBot kClosure) a + let xL_run = XCast aRun CastRun xL + + (xL2, eff2, ctx2) + <- makeSub config a ctx0 x0 xL_run tResult tR err + + let eff = Sum.unions kEffect + [ Sum.singleton kEffect tEffect + , eff2 ] + + return ( xL2 + , eff + , ctx2) + + + -- Sub_App + -- ISSUE #379: Track variance information in type synonyms. + -- We're treating all non-function types as invariant, so use makeEqT + -- rather than checking for subsumption. + -- | TApp tL1 tL2 <- tL , TApp tR1 tR2 <- tR = do ctrace $ vcat - [ text "*> SubApp" + [ text "*> Sub_App" + , text " tL: " <> ppr tL + , text " tR: " <> ppr tR + , text " xL: " <> ppr xL , empty ] - ctx1 <- makeEq config a ctx0 tL1 tR1 err + ctx1 <- makeEqT config ctx0 tL1 tR1 err tL2' <- applyContext ctx1 tL2 tR2' <- applyContext ctx1 tR2 - ctx2 <- makeEq config a ctx1 tL2' tR2' err + ctx2 <- makeEqT config ctx1 tL2' tR2' err ctrace $ vcat - [ text "*< SubApp" - , text " xL: " <> ppr xL - , text " tL: " <> ppr tL - , text " tR: " <> ppr tR + [ text "*< Sub_App" , indent 4 $ ppr ctx0 , indent 4 $ ppr ctx1 , indent 4 $ ppr ctx2 , empty ] - return (xL, ctx2) + return ( xL + , Sum.empty kEffect + , ctx2) - -- SubForall - -- Left side is a forall type. + -- Sub_ForallL + -- Left (inferred) type is a forall type. + -- Apply the expression to a new existential to instantiate it, + -- then check the new instantiated type against the expected one. + -- | TForall b t1 <- tL = do - ctrace $ vcat - [ text "*> SubForall" - , empty ] - -- 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. + -- to match the right. The new existential is used to constrain the + -- expected type, so it needs to be in the correct scope. let (ctx1, pos1) = markContext ctx0 - let ctx2 = pushExists iA ctx1 + let ctx2 = pushExistsScope iA (slurpExists tR) ctx1 -- Wrap the expression with a type application to cause -- the instantiation. @@ -211,31 +328,88 @@ let aArg = AnTEC (typeOfBind b) (tBot kEffect) (tBot kClosure) a let xL1 = XApp aFn xL (XType aArg tA) - (xL2, ctx3) <- makeSub config a ctx2 xL1 t1' tR err + (xL2, effs3, ctx3) + <- makeSub config a ctx2 x0 xL1 t1' tR err -- Pop the existential and constraints above it back off -- the stack. let ctx4 = popToPos pos1 ctx3 ctrace $ vcat - [ text "*< SubForall" - , text " xL: " <> ppr xL - , text " LEFT: " <> ppr tL - , text " RIGHT: " <> ppr tR - , text " xL2: " <> ppr xL2 + [ 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, ctx4) + return ( xL2 + , effs3 + , ctx4) - -- Error + -- 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 "DDC.Core.Check.Exp.Inst.makeSub: no match" - , text " LEFT: " <> ppr tL - , text " RIGHT: " <> ppr tR ] + = 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 --- a/DDC/Core/Check/Judge/Type/AppT.hs +++ b/DDC/Core/Check/Judge/Type/AppT.hs @@ -13,7 +13,6 @@ xx@(XApp aApp xFn (XType aArg tArg)) = do let config = tableConfig table - let kenv = tableKindEnv table -- Check the functional expression. (xFn', tFn, effsFn, ctx1) @@ -21,7 +20,7 @@ -- Check the argument. (tArg', kArg, ctx2) - <- checkTypeM config kenv ctx1 UniverseSpec tArg Recon + <- checkTypeM config ctx1 UniverseSpec tArg Recon -- Determine the type of the result. -- The function must have a quantified type, which we then instantiate @@ -63,12 +62,12 @@ (\z -> XApp z xFn' (XType aArg' tArg')) tResult effsFn ctx2 -checkAppT !table !ctx0 Synth demand +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 + <- tableCheckExp table table ctx0 (Synth []) demand xFn -- Apply the type argument to the type of the function. tFn' <- applyContext ctx1 tFn @@ -145,11 +144,10 @@ -- with the supplied type argument. | TForall b11 t12 <- tFn = do let config = tableConfig table - let kenv = tableKindEnv table -- The kind of the argument must match the annotation on the quantifier. (tArg', kArg, ctx1) - <- checkTypeM config kenv ctx0 UniverseSpec tArg + <- checkTypeM config ctx0 UniverseSpec tArg (Check (typeOfBind b11)) -- Instantiate the type of the function with the type argument. diff --git a/DDC/Core/Check/Judge/Type/AppX.hs b/DDC/Core/Check/Judge/Type/AppX.hs --- a/DDC/Core/Check/Judge/Type/AppX.hs +++ b/DDC/Core/Check/Judge/Type/AppX.hs @@ -11,7 +11,8 @@ -- | Check a value expression application. checkAppX :: Checker a n -checkAppX !table !ctx Recon demand +checkAppX !table !ctx + Recon demand xx@(XApp a xFn xArg) = do -- Check the functional expression. @@ -26,7 +27,7 @@ (tResult, effsLatent) <- case splitFunType tFn of Just (tParam, effs, _, tResult) - | tParam `equivT` tArg + | equivT (contextEnvT ctx2) tParam tArg -> return (tResult, effs) | otherwise @@ -46,33 +47,39 @@ ctx2 -checkAppX !table !ctx0 Synth demand +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 Synth demand xFn + <- 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 + <- synthAppArg table a xx + ctx1 demand isScope xFn' tFn' effsFn xArg ctrace $ vcat [ text "*< App Synth" - , text " demand : " <> (text $ show demand) + , 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 + , 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 ] @@ -80,12 +87,13 @@ return (xResult, tResult, esResult, ctx2) -checkAppX !table !ctx (Check tExpected) demand +checkAppX !table !ctx + (Check tExpected) demand xx@(XApp a _ _) = do ctrace $ vcat [ text "*> App Check" - , text " tExpected: " <> ppr tExpected + , text " tExpected = " <> ppr tExpected , empty ] result <- checkSub table a ctx demand xx tExpected @@ -109,6 +117,7 @@ -> 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. @@ -119,7 +128,10 @@ , TypeSum n -- Effect of result. , Context n) -- Result context. -synthAppArg table a xx ctx0 demand xFn tFn effsFn xArg +synthAppArg table + a xx ctx0 + demand isScope + xFn tFn effsFn xArg -- Rule (App Synth exists) -- Functional type is an existential. @@ -127,6 +139,8 @@ = 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. @@ -153,11 +167,11 @@ 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 + , 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 ] @@ -170,18 +184,15 @@ -- We need to inject a new type argument. | TForall b tBody <- tFn = do - ctrace $ vcat - [ text "*> App Synth Forall" - , empty ] - - -- Make a new existential for the type of the argument, - -- and push it onto the context. + -- Make a new existential for the type of the argument, and push it + -- onto the context. The new existential may appear in some other + -- type constraint, so make sure to add it to the correct scope. iA <- newExists (typeOfBind b) - let tA = typeOfExists iA - let ctx1 = pushExists iA ctx0 + let tA = typeOfExists iA + let ctx1 = pushExistsScope iA isScope ctx0 -- Instantiate the type of the function with the new existential. - let tBody' = substituteT b tA tBody + let tBody' = substituteT b tA tBody -- Add the missing type application. -- Because we were applying a function to an expression argument, @@ -191,21 +202,33 @@ 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 xFnTy tBody' effsFn xArg + <- synthAppArg table a xx ctx1 demand isScope xFnTy tBody' effsFn xArg -- Result expression. - ctrace $ vcat [ text "*< App Synth Forall" - , text " xFn : " <> ppr xFn - , text " tFn : " <> ppr tFn - , text " xArg : " <> ppr xArg - , text " xResult : " <> ppr xResult - , text " tResult : " <> ppr tResult + , 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 ] @@ -218,6 +241,9 @@ = do ctrace $ vcat [ text "*> App Synth Fun" + , text " demand = " <> ppr demand + , text " scope = " <> ppr isScope + , text " tFn = " <> ppr tFn , empty ] -- Check the argument. @@ -272,12 +298,14 @@ ctrace $ vcat [ text "*< App Synth Fun" , indent 4 $ ppr xx - , text " xArg : " <> ppr xArg - , text " tFn' : " <> ppr tFn' - , text " tArg' : " <> ppr tArg' - , text " xArg' : " <> ppr xArg' - , text " xExpRun : " <> ppr xExpRun - , text " tExpRun : " <> ppr tExpRun + , 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 ] diff --git a/DDC/Core/Check/Judge/Type/Base.hs b/DDC/Core/Check/Judge/Type/Base.hs --- a/DDC/Core/Check/Judge/Type/Base.hs +++ b/DDC/Core/Check/Judge/Type/Base.hs @@ -5,13 +5,17 @@ , Table (..) , returnX , runForDemand + , isHoleT + , checkTypeM + , checkBindM - , module DDC.Core.Check.Base , module DDC.Core.Check.Judge.Inst , module DDC.Core.Check.Judge.Sub - , module DDC.Core.Check.Judge.Eq - , module DDC.Core.Check.Witness + , module DDC.Core.Check.Judge.EqT + , module DDC.Core.Check.Judge.Witness , module DDC.Core.Check.Error + , module DDC.Core.Check.Base + , module DDC.Core.Transform.Reannotate , module DDC.Core.Transform.SubstituteTX , module DDC.Core.Exp.Annot.AnTEC @@ -20,16 +24,18 @@ , module DDC.Type.Transform.Instantiate , module DDC.Type.Transform.BoundT) where -import DDC.Core.Check.Base import DDC.Core.Check.Judge.Inst import DDC.Core.Check.Judge.Sub -import DDC.Core.Check.Judge.Eq -import DDC.Core.Check.Witness +import DDC.Core.Check.Judge.EqT +import DDC.Core.Check.Judge.Witness import DDC.Core.Check.Error +import DDC.Core.Check.Base + import DDC.Core.Transform.Reannotate import DDC.Core.Transform.SubstituteTX import DDC.Core.Exp.Annot.AnTEC +import DDC.Core.Check.Judge.Kind import DDC.Type.Transform.SubstituteT import DDC.Type.Transform.Instantiate import DDC.Type.Transform.BoundT @@ -44,7 +50,11 @@ | 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) @@ -75,8 +85,6 @@ data Table a n = Table { tableConfig :: Config n - , tableKindEnv :: KindEnv n - , tableTypeEnv :: TypeEnv n , tableCheckExp :: Checker a n , tableCheckVarCon :: Checker a n , tableCheckAppT :: Checker a n @@ -160,4 +168,32 @@ = 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 --- a/DDC/Core/Check/Judge/Type/Case.hs +++ b/DDC/Core/Check/Judge/Type/Case.hs @@ -2,17 +2,27 @@ module DDC.Core.Check.Judge.Type.Case (checkCase) where +import DDC.Core.Check.Judge.Kind +import DDC.Core.Check.Judge.EqT import DDC.Core.Check.Judge.Type.Base -import qualified DDC.Type.Sum as Sum -import qualified Data.Map as Map -import Data.List as L +import DDC.Type.Exp.Simple.Equiv +import qualified DDC.Type.Sum as Sum +import qualified DDC.Core.Env.EnvX as EnvX +import qualified Data.Map as Map +import Data.List as L + --------------------------------------------------------------------------------------------------- checkCase :: Checker a n checkCase !table !ctx0 mode demand xx@(XCase a xDiscrim alts) = do - let config = tableConfig table + 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 @@ -31,11 +41,17 @@ (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 + <- case takeTyConApps tDiscrim' of Just (tc, ts) -- The unit data type. | TyConSpec TcConUnit <- tc @@ -44,17 +60,16 @@ -- User defined or imported data types. | TyConBound (UName nTyCon) _ <- tc - , Just dataType <- Map.lookup nTyCon - $ dataDefsTypes $ configDataDefs config + , Just dataType <- Map.lookup nTyCon $ dataDefsTypes dataDefs , k <- kindOfDataType dataType , takeResultKind k == kData - -> return ( lookupModeOfDataType nTyCon (configDataDefs config) + -> return ( lookupModeOfDataType nTyCon dataDefs , ts ) -- Primitive data types. | TyConBound (UPrim nTyCon _) k <- tc , takeResultKind k == kData - -> return ( lookupModeOfDataType nTyCon (configDataDefs config) + -> return ( lookupModeOfDataType nTyCon dataDefs , ts ) _ -> throw $ ErrorCaseScrutineeNotAlgebraic a xx tDiscrim @@ -72,7 +87,7 @@ <- case mode of Recon -> return (mode, ctx2) Check{} -> return (mode, ctx2) - Synth + Synth{} -> do iA <- newExists kData let tA = typeOfExists iA let ctx3 = pushExists iA ctx2 @@ -89,7 +104,7 @@ tsAlts' <- mapM (applyContext ctx4) tsAlts let tAlt : _ = tsAlts' forM_ tsAlts' $ \tAlt' - -> when (not $ equivT tAlt tAlt') + -> when (not $ equivT (contextEnvT ctx4) tAlt tAlt') $ throw $ ErrorCaseAltResultMismatch a xx tAlt tAlt' -- Check for overlapping alternatives. @@ -105,14 +120,14 @@ -- Effect of overall expression. let effTotal - = crushEffect (configGlobalCaps config) + = crushEffect (contextEnvT ctx4) $ TSum $ Sum.unions kEffect $ effsDiscrim : effsMatch : effss ctrace $ vcat - [ text "* Case" - , text " modeDiscrim" <+> ppr modeDiscrim - , text " tAlt = " <+> ppr tAlt + [ text "*< Case" + , text " modeDiscrim" <+> ppr modeDiscrim + , text " tAlt = " <+> ppr tAlt , indent 2 $ ppr ctx0 , indent 2 $ ppr ctx1 , indent 2 $ ppr ctx2 @@ -159,24 +174,36 @@ -- This will be done by checkAltsM when we check each individual -- pattern type against the type of the scrutinee. let pats = map patOfAlt alts - tsPats <- liftM catMaybes $ mapM (dataTypeOfPat table a) pats + tsPats <- liftM catMaybes $ mapM (dataTypeOfPat table ctx a) pats case tsPats of -- We only have a default pattern, -- so will need to synthesise the type of the discrim without -- an expected type. [] - -> return (Synth, ctx) + -> return (Synth [], ctx) -- We have at least one non-default pattern, which we can use to -- determine how many existentials are needed to instantiate -- the quantifiers of its type. tPat : _ | Just (bs, tBody) <- takeTForalls tPat + , Check tExpect <- mode + , Just iExpect <- takeExists tExpect -> do -- existentials for all of the type parameters. - is <- mapM (\_ -> newExists kData) bs + is <- mapM (\b -> newExists (typeOfBind b)) bs let ts = map typeOfExists is + let ctx' = foldl (\ctxx i -> pushExistsBefore i iExpect ctxx) ctx is + let tBody' = substituteTs (zip bs ts) tBody + return (Check tBody', ctx') + + + | Just (bs, tBody) <- takeTForalls tPat + -> do + -- existentials for all of the type parameters. + is <- mapM (\b -> newExists (typeOfBind b)) bs + let ts = map typeOfExists is let ctx' = foldl (flip pushExists) ctx is let tBody' = substituteTs (zip bs ts) tBody return (Check tBody', ctx') @@ -244,15 +271,21 @@ 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 a (PData dc bsArg) + 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 tCtor tDiscrim + <- if equivT (contextEnvT ctx0) tCtor tDiscrim then return tCtor else case instantiateTs tCtor tsArgs of Nothing -> throw $ ErrorCaseCannotInstantiate a xx tDiscrim tCtor @@ -265,7 +298,7 @@ -- 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) + when (not $ equivT (contextEnvT ctx0) tDiscrim tResult) $ throw $ ErrorCaseScrutineeTypeMismatch a xx tDiscrim tResult @@ -284,21 +317,21 @@ ctx0 -- Extend the environment with the field types. - let bsArg' = zipWith replaceTypeOfBind tsFields bsArg - let (ctx2, posArg) = markContext ctx1 - let ctxArg = pushTypes bsArg' ctx2 + let bsArg' = zipWith replaceTypeOfBind tsFields bsArg + let ctxArg = pushTypes bsArg' ctx1 -- Check the body in this new environment. - (xBody', tBody, effsBody, ctxBody) - <- tableCheckExp table table ctxArg mode demand xBody + let (ctxBody, posArg) = markContext ctxArg + (xBody', tBody, effsBody, ctxBody') + <- tableCheckExp table table ctxBody mode demand xBody - tBody' <- applyContext ctxBody tBody + tBody' <- applyContext ctxBody' tBody -- Pop the argument types from the context. - let ctx_cut = popToPos posArg ctxBody + let ctx_cut = popToPos posArg ctxBody' ctrace $ vcat - [ text "* Alt" + [ text "*< Alt" , ppr alt , text " MODE: " <+> ppr mode , text " tBody': " <+> ppr tBody' @@ -344,18 +377,23 @@ = return (tActual, ctx) -- With bidirectional checking, annotations on fields can refine the - -- inferred type for the overal expression. + -- inferred type for the overall expression. | bidir - = do ctx' <- makeEq (tableConfig table) a ctx tAnnot tActual - $ ErrorCaseFieldTypeMismatch a xx tAnnot tActual + = do -- Check the type of the annotation. + let config = tableConfig table + (tAnnot', _, ctx2) + <- checkTypeM config ctx UniverseSpec tAnnot (Synth []) - tField <- applyContext ctx' tActual - return (tField, ctx') + ctx3 <- makeEqT (tableConfig table) ctx2 tAnnot' tActual + $ ErrorCaseFieldTypeMismatch a xx tAnnot' tActual + tField <- applyContext ctx3 tActual + return (tField, ctx3) + -- In Recon mode, if there is an annotation on the field then it needs -- to exactly match the inferred type of the field. | not bidir - , equivT tActual tAnnot + , equivT (contextEnvT ctx) tActual tAnnot = return (tAnnot, ctx) -- Annotation does not match actual type. @@ -372,26 +410,25 @@ 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 a (PData dc _) +ctorTypeOfPat _table ctx a (PData dc _) = case dc of DaConUnit -> return $ Just $ tUnit DaConPrim{} -> return $ Just $ daConType dc DaConBound n -- Types of algebraic data ctors should be in the defs table. - | Just ctor <- Map.lookup n - $ dataDefsCtors - $ configDataDefs $ tableConfig table + | Just ctor <- Map.lookup n $ dataDefsCtors $ contextDataDefs ctx -> return $ Just $ typeOfDataCtor ctor | otherwise -> throw $ ErrorUndefinedCtor a $ XCon a dc -ctorTypeOfPat _table _a PDefault +ctorTypeOfPat _table _ctx _a PDefault = return Nothing @@ -404,12 +441,13 @@ dataTypeOfPat :: Ord n => Table a n -- ^ Checker table. + -> Context n -- ^ Type Checker context. -> a -- ^ Annotation for error messages. -> Pat n -- ^ Pattern. -> CheckM a n (Maybe (Type n)) -dataTypeOfPat table a pat - = do mtCtor <- ctorTypeOfPat table a pat +dataTypeOfPat table ctx a pat + = do mtCtor <- ctorTypeOfPat table ctx a pat case mtCtor of Nothing -> return Nothing diff --git a/DDC/Core/Check/Judge/Type/Cast.hs b/DDC/Core/Check/Judge/Type/Cast.hs --- a/DDC/Core/Check/Judge/Type/Cast.hs +++ b/DDC/Core/Check/Judge/Type/Cast.hs @@ -2,6 +2,8 @@ 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 @@ -11,18 +13,18 @@ -- WeakenEffect --------------------------------------------------------------- -- Weaken the effect of an expression. -checkCast !table !ctx0 mode _demand +checkCast !table !ctx0 + mode _demand xx@(XCast a (CastWeakenEffect eff) x1) = do let config = tableConfig table - let kenv = tableKindEnv table -- Check the effect term. (eff', kEff, ctx1) - <- checkTypeM config kenv ctx0 UniverseSpec eff + <- checkTypeM config ctx0 UniverseSpec eff $ case mode of Recon -> Recon - Synth -> Check kEffect - Check _ -> Check kEffect + Synth{} -> Check kEffect + Check{} -> Check kEffect -- Check the body. (x1', t1, effs, ctx2) @@ -45,14 +47,13 @@ -- EXPERIMENTAL: The Tetra language doesn't have purification casts yet, -- so proper type inference isn't implemented. -- -checkCast !table !ctx mode _demand +checkCast !table !ctx + mode _demand xx@(XCast a (CastPurify w) x1) = do let config = tableConfig table - let kenv = tableKindEnv table - let tenv = tableTypeEnv table -- Check the witness. - (w', tW) <- checkWitnessM config kenv tenv ctx w + (w', tW) <- checkWitnessM config ctx w let wTEC = reannotate fromAnT w' -- Check the body. @@ -73,7 +74,8 @@ -- Box ------------------------------------------------------------------------ -- Box a computation, -- capturing its effects in a computation type. -checkCast !table ctx0 mode _demand +checkCast !table ctx0 + mode _demand xx@(XCast a CastBox x1) = case mode of Check tExpected @@ -82,11 +84,12 @@ -- Check the body. (x1', tBody, effs, ctx1) - <- tableCheckExp table table ctx0 Synth DemandRun x1 + <- tableCheckExp table table ctx0 + (Synth $ slurpExists tExpected) DemandRun x1 let effs_crush = Sum.fromList kEffect - [ crushEffect (configGlobalCaps config) (TSum effs)] + [ crushEffect (contextEnvT ctx0) (TSum effs)] -- The actual type is (S eff tBody). tBody' <- applyContext ctx1 tBody @@ -97,8 +100,8 @@ -- We're treating the S constructor as invariant in both positions, -- so we use 'makeEq' here instead of 'makeSub' tExpected' <- applyContext ctx1 tExpected - ctx2 <- makeEq config a ctx1 tActual tExpected' - $ ErrorMismatch a tActual tExpected' xx + ctx2 <- makeEqT config ctx1 tActual tExpected' + $ ErrorMismatch a tActual tExpected' xx returnX a (\z -> XCast z CastBox x1') tExpected (Sum.empty kEffect) ctx2 @@ -106,15 +109,13 @@ -- Recon and Synth mode. _ -> do - let config = tableConfig table - -- Check the body. (x1', t1, effs, ctx1) <- tableCheckExp table table ctx0 mode DemandRun x1 let effs_crush = Sum.fromList kEffect - [ crushEffect (configGlobalCaps config) (TSum effs)] + [ crushEffect (contextEnvT ctx1) (TSum effs)] -- The result type is (S effs a). let tS = tApps (TCon (TyConSpec TcConSusp)) @@ -154,11 +155,12 @@ _ -> throw $ ErrorRunNotSuspension a xx tBody - Synth + Synth{} -> do -- Synthesize a type for the body. (xBody', tBody, effs, ctx1) - <- tableCheckExp table table ctx0 Synth DemandNone xBody + <- tableCheckExp table table ctx0 + mode DemandNone xBody -- Run the body, -- which needs to have been resolved to a computation type. @@ -229,7 +231,7 @@ -> CheckM a n () checkEffectSupported _config a xx ctx eff - = case effectSupported eff ctx of + = case effectSupported ctx eff of Nothing -> return () Just effBad -> throw $ ErrorRunNotSupported a xx effBad diff --git a/DDC/Core/Check/Judge/Type/DaCon.hs b/DDC/Core/Check/Judge/Type/DaCon.hs --- a/DDC/Core/Check/Judge/Type/DaCon.hs +++ b/DDC/Core/Check/Judge/Type/DaCon.hs @@ -6,17 +6,17 @@ import qualified Data.Map as Map import Prelude as L - -- | Check a data constructor, returning its type. checkDaConM :: (Ord n, Eq n, Show n) => Config n + -> Context n -- ^ Type checker context. -> Exp a n -- ^ The full expression for error messages. -> a -- ^ Annotation for error messages. - -> DaCon n -- ^ Data constructor to check. + -> DaCon n (Type n) -- ^ Data constructor to check. -> CheckM a n (Type n) -checkDaConM config xx a dc +checkDaConM _config ctx xx a dc = case dc of -- Type type of the unit data constructor is baked-in. DaConUnit @@ -34,11 +34,10 @@ DaConPrim { daConName = nCtor , daConType = t } -> let tResult = snd $ takeTFunArgResult $ eraseTForalls t - defs = configDataDefs config in case liftM fst $ takeTyConApps tResult of Just (TyConBound u _) - | Just nType <- takeNameOfBound u - , Just dataType <- Map.lookup nType (dataDefsTypes defs) + | Just nType <- takeNameOfBound u + , Just dataType <- Map.lookup nType $ dataDefsTypes $ contextDataDefs ctx -> case dataTypeMode dataType of DataModeSmall nsCtors | L.elem nCtor nsCtors -> return t @@ -51,7 +50,7 @@ -- Bound data constructors are always algebraic and Small, so there needs -- to be a data definition that gives the type of the constructor. DaConBound { daConName = nCtor } - -> case Map.lookup nCtor (dataDefsCtors $ configDataDefs config) of + -> case Map.lookup nCtor (dataDefsCtors $ contextDataDefs ctx) of Just ctor -> return $ typeOfDataCtor ctor Nothing -> throw $ ErrorUndefinedCtor a xx diff --git a/DDC/Core/Check/Judge/Type/LamT.hs b/DDC/Core/Check/Judge/Type/LamT.hs --- a/DDC/Core/Check/Judge/Type/LamT.hs +++ b/DDC/Core/Check/Judge/Type/LamT.hs @@ -20,7 +20,6 @@ -- the formal parameter must have a kind annotation: eg (/\v : K. x2) checkLAM !table !ctx0 a b1 x2 Recon = do let config = tableConfig table - let kenv = tableKindEnv table let xx = XLAM a b1 x2 -- Check the parameter ------------------ @@ -31,12 +30,12 @@ -- The parameter must have an explict kind annotation. let kA = typeOfBind b1 - when (isBot kA) + when (isHoleT config kA) $ throw $ ErrorLAMParamUnannotated a xx -- Check the kind annotation is well-sorted. (kA', sA, ctxA) - <- checkTypeM config kenv ctx0 UniverseKind kA Recon + <- checkTypeM config ctx0 UniverseKind kA Recon let b1' = replaceTypeOfBind kA' b1 @@ -58,7 +57,7 @@ -- Reconstruct the kind of the body. (t2', k2, ctx6) - <- checkTypeM config kenv ctx5 UniverseSpec t2 Recon + <- checkTypeM config ctx5 UniverseSpec t2 Recon -- The type of the body must have data kind. when (not $ isDataKind k2) @@ -88,9 +87,8 @@ tResult (Sum.empty kEffect) ctx_cut -checkLAM !table !ctx0 a b1 x2 Synth +checkLAM !table !ctx0 a b1 x2 (Synth {}) = do let config = tableConfig table - let kenv = tableKindEnv table let xx = XLAM a b1 x2 -- Check the parameter ------------------ @@ -102,7 +100,7 @@ -- If the annotation is missing then make a new existential for it. let kA = typeOfBind b1 (kA', sA, ctxA) - <- if isBot kA + <- if isHoleT config kA then do iA <- newExists sComp let kA' = typeOfExists iA @@ -110,7 +108,7 @@ return (kA', sComp, ctxA) else - checkTypeM config kenv ctx0 UniverseKind kA Synth + checkTypeM config ctx0 UniverseKind kA (Synth []) let b1' = replaceTypeOfBind kA' b1 @@ -127,14 +125,14 @@ -- 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 + <- 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 kenv ctx5 UniverseSpec t2' (Check kData) + <- checkTypeM config ctx5 UniverseSpec t2' (Check kData) -- The body of a spec abstraction must be pure. when (e2 /= Sum.empty kEffect) @@ -162,7 +160,6 @@ checkLAM !table !ctx0 a b1 x2 (Check (TForall b tBody)) = do let config = tableConfig table - let kenv = tableKindEnv table let xx = XLAM a b1 x2 -- Check the parameter ------------------ @@ -179,19 +176,19 @@ -- If both the kind annotation is missing and there is no -- expected kind then we need to make an existential for it. (kA', sA, ctxA) - <- if (isBot kParam && isBot kExpected) + <- if (isHoleT config kParam && isHoleT config kExpected) then do iA <- newExists sComp let kA' = typeOfExists iA let ctxA = pushExists iA ctx0 return (kA', sComp, ctxA) - else if isBot kExpected + else if isHoleT config kExpected then do - checkTypeM config kenv ctx0 UniverseKind kParam Synth + checkTypeM config ctx0 UniverseKind kParam (Synth []) else do - checkTypeM config kenv ctx0 UniverseKind kExpected Synth + checkTypeM config ctx0 UniverseKind kExpected (Synth []) let b1' = replaceTypeOfBind kA' b1 @@ -223,7 +220,7 @@ -- This is needed when the type of the body is an existential -- which doesn't yet have a resolved kind. (t2', _k2, ctx6) - <- checkTypeM config kenv ctx5 UniverseSpec t2 (Check kData) + <- checkTypeM config ctx5 UniverseSpec t2 (Check kData) -- The body of a spec abstraction must be pure. when (e2 /= Sum.empty kEffect) diff --git a/DDC/Core/Check/Judge/Type/LamX.hs b/DDC/Core/Check/Judge/Type/LamX.hs --- a/DDC/Core/Check/Judge/Type/LamX.hs +++ b/DDC/Core/Check/Judge/Type/LamX.hs @@ -22,7 +22,6 @@ checkLam !table !a !ctx !b1 !x2 !Recon = do let config = tableConfig table - let kenv = tableKindEnv table let xx = XLam a b1 x2 -- Check the parameter ------------------ @@ -33,7 +32,7 @@ $ throw $ ErrorLamParamUnannotated a xx b1 -- Determine the kind of the parameter. - (t1', k1, _) <- checkTypeM config kenv ctx UniverseSpec t1 Recon + (t1', k1, _) <- checkTypeM config ctx UniverseSpec t1 Recon let b1' = replaceTypeOfBind t1' b1 -- Check the body ----------------------- @@ -49,10 +48,10 @@ let e2_crush = Sum.fromList kEffect - [ crushEffect (configGlobalCaps config) (TSum e2)] + [ crushEffect (contextEnvT ctx2) (TSum e2)] -- The body of the function must produce data. - (_, k2, _) <- checkTypeM config kenv ctx2 UniverseSpec t2 Recon + (_, k2, _) <- checkTypeM config ctx2 UniverseSpec t2 Recon when (not $ isDataKind k2) $ throw $ ErrorLamBodyNotData a xx b1 t2 k2 @@ -74,14 +73,14 @@ -- 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 +checkLam !table !a !ctx !b1 !x2 !(Synth {}) = do ctrace $ vcat [ text "*> Lam SYNTH" - , text " in bind = " <+> ppr b1 ] + , text " in bind = " <+> ppr b1 + , empty ] let config = tableConfig table - let kenv = tableKindEnv table let xx = XLam a b1 x2 -- Check the parameter ------------------ @@ -89,7 +88,7 @@ -- If there isn't an existing annotation then make an existential. (b1', t1', k1, ctx1) - <- if isBot t1 + <- if isHoleT config t1 then do -- There is no annotation at all, so make an existential. -- Missing anotations are assumed to have kind Data. @@ -105,7 +104,7 @@ -- The parameter must have Data or Witness kind, -- which is checked by 'makeFunctionType' below. (t1', k1, ctx1) - <- checkTypeM config kenv ctx UniverseSpec t1 Synth + <- checkTypeM config ctx UniverseSpec t1 (Synth []) let b1' = replaceTypeOfBind t1' b1 return (b1', t1', k1, ctx1) @@ -130,7 +129,7 @@ let e2_crush = Sum.fromList kEffect - [ crushEffect (configGlobalCaps config) (TSum e2)] + [ crushEffect (contextEnvT ctx4) (TSum e2)] -- Force the kind of the body to be Data. -- This constrains the kind of polymorpic variables that are used @@ -138,7 +137,7 @@ -- We know \x. can't bind a witness here. t2'' <- applyContext ctx4 t2' (_, _, ctx5) - <- checkTypeM config kenv ctx4 UniverseSpec t2'' (Check kData) + <- checkTypeM config ctx4 UniverseSpec t2'' (Check kData) -- Build the result type ------------- -- If the kind of the parameter is unconstrained then default it @@ -147,8 +146,8 @@ (k1'', ctx6) <- if isTExists k1' then do - ctx6 <- makeEq config a ctx5 k1' kData - $ ErrorMismatch a k1' kData xx + ctx6 <- makeEqT config ctx5 k1' kData + $ ErrorMismatch a k1' kData xx k1'' <- applyContext ctx6 k1' @@ -196,7 +195,6 @@ , empty ] let config = tableConfig table - let kenv = tableKindEnv table let xx = XLam a b1 x2 -- Check the parameter ------------------ @@ -207,12 +205,12 @@ -- If it does have an annotation, then the annotation also needs -- to match the expected type. (b1', t1', ctx0) - <- if isBot t1 + <- if isHoleT config t1 then return (replaceTypeOfBind tX1 b1, tX1, ctx) else do - ctx0 <- makeEq config a ctx t1 tX1 - $ ErrorMismatch a t1 tExpected (XLam a b1 x2) + ctx0 <- makeEqT config ctx t1 tX1 + $ ErrorMismatch a t1 tExpected (XLam a b1 x2) return (b1, t1, ctx0) -- Check the body ---------------------- @@ -238,14 +236,14 @@ let es2Actual_crushed = Sum.fromList kEffect - [ crushEffect (configGlobalCaps config) (TSum es2Actual)] + [ 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' <- makeEq config a ctx2 e2Expected e2Actual_crushed - $ ErrorMismatch a e2Actual_crushed e2Expected x2 + ctx2' <- makeEqT config ctx2 e2Expected e2Actual_crushed + $ ErrorMismatch a e2Actual_crushed e2Expected x2 return (x2', t2', es2Actual_crushed, ctx2') @@ -256,7 +254,7 @@ let es2Actual_crushed = Sum.fromList kEffect - [ crushEffect (configGlobalCaps config) (TSum es2Actual)] + [ crushEffect (contextEnvT ctx2) (TSum es2Actual)] return (x2', t2', es2Actual_crushed, ctx2) @@ -266,18 +264,18 @@ -- We know \x. can't bind a witness here. t2' <- applyContext ctx2 t2 (_, _, ctx3) - <- checkTypeM config kenv ctx2 UniverseSpec t2' (Check kData) + <- checkTypeM config ctx2 UniverseSpec t2' (Check kData) -- Make the result type ----------------- -- If the kind of the parameter is unconstrained then default it -- to Data. This handles "/\f. \(a : f Int#). ()" - (_, k1, _) <- checkTypeM config kenv ctx3 UniverseSpec t1' Synth + (_, k1, _) <- checkTypeM config ctx3 UniverseSpec t1' (Synth []) k1' <- applyContext ctx3 k1 (k1'', ctx4) <- if isTExists k1' then do - ctx4 <- makeEq config a ctx3 k1' kData - $ ErrorMismatch a k1' kData xx + ctx4 <- makeEqT config ctx3 k1' kData + $ ErrorMismatch a k1' kData xx k1'' <- applyContext ctx4 k1' @@ -305,8 +303,8 @@ -- The `makeFunction` can also insert implicit box casts, so we -- need to check that the result of doing this is as expected. -- - ctx5 <- makeEq config a ctx4 tAbs tExpected - $ ErrorMismatch a tAbs tExpected xx + ctx5 <- makeEqT config ctx4 tAbs tExpected + $ ErrorMismatch a tAbs tExpected xx tAbs' <- applyContext ctx4 tAbs diff --git a/DDC/Core/Check/Judge/Type/Let.hs b/DDC/Core/Check/Judge/Type/Let.hs --- a/DDC/Core/Check/Judge/Type/Let.hs +++ b/DDC/Core/Check/Judge/Type/Let.hs @@ -24,7 +24,6 @@ , empty] let config = tableConfig table - let kenv = tableKindEnv table -- Check the bindings ------------------- -- Decide whether to use bidirectional type inference when checking @@ -33,7 +32,7 @@ = case mode of Recon -> False Check{} -> True - Synth -> True + Synth{} -> True (lts', _bs', effsBinds, pos1, ctx1) <- checkLetsM useBidirChecking xx table ctx0 demand lts @@ -52,7 +51,7 @@ -- The body must have data kind. (tBodyChecked, kBody, ctx3) - <- checkTypeM config kenv ctx2 UniverseSpec tBody + <- checkTypeM config ctx2 UniverseSpec tBody $ case mode of Recon -> Recon _ -> Check kData @@ -66,7 +65,7 @@ -- Run the body if needed --------------- (xBodyRun, tBodyRun, eBodyRun) <- case mode of - Synth -> runForDemand (tableConfig table) a demand + Synth{} -> runForDemand (tableConfig table) a demand xBody' tBody' (TSum effsBody) _ -> return (xBody', tBody', TSum effsBody) @@ -130,7 +129,6 @@ | False <- bidir = do let config = tableConfig table - let kenv = tableKindEnv table let a = annotOfExp xx -- Reconstruct the type of the binding. @@ -139,7 +137,7 @@ -- The kind of the binding must be Data. (_, kBind', _) - <- checkTypeM config kenv ctx1 UniverseSpec tBind Recon + <- checkTypeM config ctx1 UniverseSpec tBind Recon when (not $ isDataKind kBind') $ throw $ ErrorLetBindingNotData a xx b kBind' @@ -147,7 +145,7 @@ -- If there is a type annotation on the binding then this -- must match the reconstructed type. when (not $ isBot (typeOfBind b)) - $ if equivT (typeOfBind b) tBind + $ if equivT (contextEnvT ctx0) (typeOfBind b) tBind then return () else (throw $ ErrorLetMismatch a xx b tBind) @@ -169,7 +167,6 @@ | True <- bidir = do let config = tableConfig table - let kenv = tableKindEnv table let a = annotOfExp xx -- If the binder has a type annotation then we use that as the expected @@ -179,13 +176,13 @@ (mode, ctx1) <- if isBot tAnnot -- There is no annotation on the binder. - then return (Synth, ctx0) + then return (Synth [], ctx0) -- Check the type annotation on the binder, -- expecting the kind to be Data. else do (tAnnot', _kAnnot, ctx1) - <- checkTypeM config kenv ctx0 UniverseSpec tAnnot (Check kData) + <- checkTypeM config ctx0 UniverseSpec tAnnot (Check kData) return (Check tAnnot', ctx1) ctrace $ vcat @@ -312,7 +309,6 @@ return (b' : moar, ctx'') config = tableConfig table - kenv = tableKindEnv table checkRecBind b ctx = case bidir of @@ -325,7 +321,7 @@ -- Check the type on the binder. (b', k, ctx') - <- checkBindM config kenv ctx UniverseSpec b Recon + <- checkBindM config ctx UniverseSpec b Recon -- The type on the binder must have kind Data. when (not $ isDataKind k) @@ -348,7 +344,7 @@ | otherwise -> do (b0, _k, ctx1) - <- checkBindM config kenv ctx UniverseSpec b (Check kData) + <- checkBindM config ctx UniverseSpec b (Check kData) let t0 = typeOfBind b0 t1 <- applyContext ctx1 t0 @@ -397,7 +393,7 @@ -- Check the annotation on the binder matches the reconstructed -- type of the binding. - when (not $ equivT (typeOfBind b) t) + when (not $ equivT (contextEnvT ctx') (typeOfBind b) t) $ throw $ ErrorLetMismatch a xBind b t -- Reconstructing the types of binders adds missing kind info to diff --git a/DDC/Core/Check/Judge/Type/LetPrivate.hs b/DDC/Core/Check/Judge/Type/LetPrivate.hs --- a/DDC/Core/Check/Judge/Type/LetPrivate.hs +++ b/DDC/Core/Check/Judge/Type/LetPrivate.hs @@ -2,11 +2,14 @@ module DDC.Core.Check.Judge.Type.LetPrivate (checkLetPrivate) where +import DDC.Core.Check.Judge.Kind +import DDC.Core.Check.Judge.EqT import DDC.Core.Check.Judge.Type.Base -import qualified DDC.Type.Sum as Sum -import qualified DDC.Type.Env as Env -import qualified Data.Set as Set -import Data.List as L +import qualified DDC.Core.Env.EnvT as EnvT +import qualified DDC.Type.Sum as Sum +import qualified DDC.Type.Env as Env +import qualified Data.Set as Set +import Data.List as L checkLetPrivate :: Checker a n @@ -20,7 +23,6 @@ us -> do let config = tableConfig table - let kenv = tableKindEnv table let depth = length $ map isBAnon bsRgn ctrace $ vcat @@ -36,7 +38,7 @@ -- These must already set to kind Region. (bsRgn', _, _) <- liftM unzip3 - $ mapM (\b -> checkBindM config kenv ctx UniverseKind b Recon) + $ mapM (\b -> checkBindM config ctx UniverseKind b Recon) bsRgn let ksRgn = map typeOfBind bsRgn' @@ -58,12 +60,12 @@ let ctx2 = liftTypes depth ctx1 (bsWit', _, _) <- liftM unzip3 - $ mapM (\b -> checkBindM config kenv ctx2 UniverseSpec b Recon) + $ mapM (\b -> checkBindM config ctx2 UniverseSpec b Recon) bsWit -- Check that the witnesses bound here are for the region, -- and they don't conflict with each other. - checkWitnessBindsM config a kenv ctx xx us bsWit' + checkWitnessBindsM config a ctx xx us bsWit' -- Check the body expression. -- We always want to do this in 'Synth' mode as the expected @@ -72,11 +74,11 @@ -- construct. let ctx3 = pushTypes bsWit' ctx2 (xBody3, tBody3, effs3, ctx4) - <- tableCheckExp table table ctx3 Synth demand x + <- tableCheckExp table table ctx3 (Synth []) demand x -- The body type must have data kind. (tBody4, kBody4, ctx5) - <- checkTypeM config kenv ctx4 UniverseSpec tBody3 + <- checkTypeM config ctx4 UniverseSpec tBody3 $ case mode of Recon -> Recon _ -> Check kData @@ -109,7 +111,7 @@ -- Check that the result matches any expected type. ctx6 <- case mode of Check tExpected - -> do makeEq config a ctx5 tExpected tBody_final + -> do makeEqT config ctx5 tExpected tBody_final $ ErrorMismatch a tExpected tBody_final xx _ -> return ctx5 @@ -158,14 +160,13 @@ :: (Show n, Ord n) => Config n -- ^ Type checker config. -> a -- ^ Annotation for error messages. - -> KindEnv n -- ^ Kind Environment. -> Context n -- ^ Context -> Exp a n -- ^ The whole expression, for error messages. -> [Bound n] -- ^ Region variables bound in the letregion. -> [Bind n] -- ^ Other witness bindings in the same set. -> CheckM a n () -checkWitnessBindsM !config !a !kenv !ctx !xx !uRegions !bsWit +checkWitnessBindsM !config !a !ctx !xx !uRegions !bsWit = mapM_ checkWitnessBindM bsWit where -- Check if some type variable or constructor is already in the @@ -174,13 +175,13 @@ inEnv tt = case tt of TVar u' - | Env.member u' kenv -> True - | memberKind u' ctx -> True + | EnvT.member u' (contextEnvT ctx) -> True + | memberKind u' ctx -> True TCon (TyConBound u' _) - | Env.member u' kenv -> True - | memberKind u' ctx -> True - _ -> False + | EnvT.member u' (contextEnvT ctx) -> True + | memberKind u' ctx -> True + _ -> False -- Check the argument of a witness type is for the region we're @@ -240,4 +241,6 @@ -> 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 --- a/DDC/Core/Check/Judge/Type/Sub.hs +++ b/DDC/Core/Check/Judge/Type/Sub.hs @@ -3,6 +3,9 @@ (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. @@ -12,40 +15,154 @@ [ text "*> Sub Check" , text " demand: " <> (text $ show demand) , text " tExpect: " <> (ppr tExpect) + , indent 4 $ ppr ctx0 , empty ] let config = tableConfig table - (xx1, tSynth, eff, ctx1) - <- tableCheckExp table table ctx0 Synth demand xx0 + -- 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' <- applyContext ctx1 tSynth - tExpect' <- applyContext ctx1 tExpect + 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) + , text " demand: " <> (text $ show demand) + , text " tExpect: " <> ppr tExpect_ctx1 + , text " tSynth: " <> ppr tSynth_ctx1 + , text " tDequant: " <> ppr tDequant , empty ] - (xx2, ctx2) <- makeSub config a - ctx1 xx1 tSynth' tExpect' - $ ErrorMismatch a tSynth' tExpect' xx0 + -- 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 " 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 ctx2 + , indent 4 $ ppr ctx3 , empty ] returnX a (\_ -> xx2) tExpect - eff ctx2 + effs' ctx3 + + +dequantify !_table !aApp ctx0 iBefore xx0 tSynth tExpect + | TCon (TyConExists _n _k) <- tExpect + , shouldDequantifyX xx0 + = do + (bsParam, tBody) <- stripQuantifiers ctx0 tSynth + case bsParam of + [] -> return (xx0, tSynth, ctx0) + _ -> addTypeApps aApp ctx0 iBefore xx0 (reverse bsParam) tBody + + | otherwise + = return (xx0, tSynth, ctx0) + + +shouldDequantifyX :: Exp a n -> Bool +shouldDequantifyX xx + = case xx of + XLAM{} -> False + _ -> True + + +-- | Apply the given expression to existentials to instantiate its type. +-- +-- The new existentials are inserted into the context just before +-- the given one so that the context scoping works out. +-- +addTypeApps + :: Ord n + => a -- ^ Annotation for new AST nodes. + -> Context n -- ^ Current type checker context. + -> Exists n -- ^ Add new existentials before this one. + -> Exp (AnTEC a n) n -- ^ Expression to add type applications to. + -> [Bind n] -- ^ Forall quantifiers. + -> Type n -- ^ Body of the forall. + -> CheckM a n + ( Exp (AnTEC a n) n + , Type n + , Context n) + +addTypeApps !_aApp ctx0 _ xx0 [] tBody + = return (xx0, tBody, ctx0) + +addTypeApps !aApp ctx0 iBefore xx0 (bParam : bsParam) tBody + = do + let kParam = typeOfBind bParam + + (xx1, tBody', ctx1) + <- addTypeApps aApp ctx0 iBefore xx0 bsParam tBody + + iArg <- newExists kParam + let tArg = typeOfExists iArg + let ctx2 = pushExistsBefore iArg iBefore ctx1 + + let tResult = substituteT bParam tArg tBody' + + let aApp' = AnTEC tResult (tBot kEffect) (tBot kClosure) aApp + let aArg' = AnTEC kParam (tBot kEffect) (tBot kClosure) aApp + let xx2 = XApp aApp' xx1 (XType aArg' tArg) + + return (xx2, tResult, ctx2) + + +-- | Strip quantifiers from the front of a type, looking through any type synonyms. +-- +-- ISSUE #385: Make type inference work for non trivial type synonyms. +-- If the synonym is higher kinded then we need to reduce the application. +-- trying to strip the TForall. +-- +stripQuantifiers + :: Ord n + => Context n + -> Type n + -> CheckM a n ([Bind n], Type n) + +stripQuantifiers ctx tt + = case tt of + -- Look through type synonyms. + TCon (TyConBound (UName n) _) + | Just tt' <- Map.lookup n + $ EnvT.envtEquations $ contextEnvT ctx + -> stripQuantifiers ctx tt' + + -- Strip quantifier. + TForall bParam tBody + -> do (bsParam, tBody') + <- stripQuantifiers ctx tBody + return (bParam : bsParam, tBody') + + _ -> return ([], tt) + + diff --git a/DDC/Core/Check/Judge/Type/VarCon.hs b/DDC/Core/Check/Judge/Type/VarCon.hs --- a/DDC/Core/Check/Judge/Type/VarCon.hs +++ b/DDC/Core/Check/Judge/Type/VarCon.hs @@ -5,11 +5,12 @@ import DDC.Core.Check.Judge.Type.DaCon import DDC.Core.Check.Judge.Type.Sub import DDC.Core.Check.Judge.Type.Base -import qualified DDC.Type.Env as Env -import qualified DDC.Type.Sum as Sum -import qualified Data.Map as Map +import qualified DDC.Core.Env.EnvX as EnvX +import qualified DDC.Type.Sum as Sum +import qualified Data.Map as Map +------------------------------------------------------------------------------- checkVarCon :: Checker a n -- variables ------------------------------------ @@ -37,7 +38,7 @@ ctx -- Look in the global environment. - | Just t <- Env.lookup u (tableTypeEnv table) + | Just t <- EnvX.lookupX u (contextEnvX ctx) = case mode of -- Check subsumption against an existing type. -- This may instantiate existentials in the exising type. @@ -63,34 +64,45 @@ -- constructors --------------------------------- -checkVarCon !table !ctx mode demand xx@(XCon a dc) - -- For recon and synthesis we already know what type the constructor - -- should have, so we can use that. - | mode == Recon || mode == Synth - = do - let config = tableConfig table - let defs = configDataDefs config +-- Recon or Synth the type of a constructor. +checkVarCon !table !ctx mode@Recon _demand xx@(XCon a dc) + = do let config = tableConfig table - -- All data constructors need to have valid type annotations. - tCtor - <- case dc of - DaConUnit -> return tUnit + -- Lookup the type of the constructor from the environment. + tCtor <- checkDaConType config ctx a dc - DaConPrim{} -> return $ daConType dc + ctrace $ vcat + [ text "** Con" + , text " MODE: " <> ppr mode + , indent 4 $ ppr xx + , text " tCon: " <> ppr tCtor + , indent 4 $ ppr ctx + , empty ] - DaConBound n - -- Types of algebraic data ctors should be in the defs table. - | Just ctor <- Map.lookup n (dataDefsCtors defs) - -> return $ typeOfDataCtor ctor + -- Type of the data constructor. + returnX a + (\z -> XCon z dc) + tCtor + (Sum.empty kEffect) + ctx - | otherwise - -> throw $ ErrorUndefinedCtor a $ XCon a dc - -- Check that the constructor is in the data type declarations. - checkDaConM config xx a dc +-- Check a constructor against an expected type. +checkVarCon !table !ctx (Check tExpect) demand xx@(XCon a _) + = checkSub table a ctx demand xx tExpect + +-- Synthesise the type of a data constructor. +checkVarCon !table !ctx mode@(Synth {}) _demand xx@(XCon a dc) + = do + let config = tableConfig table + + -- All data constructors need to have valid type annotations. + tCtor <- checkDaConType config ctx a dc + ctrace $ vcat [ text "** Con" + , text " MODE: " <> ppr mode , indent 4 $ ppr xx , text " tCon: " <> ppr tCtor , indent 4 $ ppr ctx @@ -103,14 +115,30 @@ (Sum.empty kEffect) ctx - -- Check subsumption against an existing type. - -- This may instantiate existentials in the exising type. - | otherwise - , Check tExpect <- mode - = checkSub table a ctx demand xx tExpect - -- 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 --- a/DDC/Core/Check/Judge/Type/Witness.hs +++ b/DDC/Core/Check/Judge/Type/Witness.hs @@ -2,7 +2,7 @@ module DDC.Core.Check.Judge.Type.Witness (checkWit) where -import DDC.Core.Check.Witness +import DDC.Core.Check.Judge.Witness import DDC.Core.Check.Judge.Type.Base import qualified DDC.Type.Sum as Sum @@ -11,11 +11,9 @@ checkWit !table !ctx _mode _demand (XWitness a w1) = do let config = tableConfig table - let kenv = tableKindEnv table - let tenv = tableTypeEnv table -- Check the witness. - (w1', t1) <- checkWitnessM config kenv tenv ctx w1 + (w1', t1) <- checkWitnessM config ctx w1 let w1TEC = reannotate fromAnT w1' returnX a 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/Module.hs b/DDC/Core/Check/Module.hs deleted file mode 100644 --- a/DDC/Core/Check/Module.hs +++ /dev/null @@ -1,506 +0,0 @@ - -module DDC.Core.Check.Module - ( checkModule - , checkModuleM) -where -import DDC.Core.Check.Base (checkTypeM, applySolved) -import DDC.Core.Check.Exp -import DDC.Core.Check.Error -import DDC.Core.Transform.Reannotate -import DDC.Core.Transform.MapT -import DDC.Core.Module -import DDC.Core.Exp -import DDC.Type.Check.Context -import DDC.Type.Check.Data -import DDC.Type.Compounds -import DDC.Type.Predicates -import DDC.Type.DataDef -import DDC.Type.Equiv -import DDC.Type.Universe -import DDC.Base.Pretty -import DDC.Type.Env (KindEnv, TypeEnv) -import DDC.Control.Monad.Check (runCheck, throw) -import DDC.Data.ListUtils -import Control.Monad -import qualified DDC.Type.Env as Env -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 - (configPrimKinds config) - (configPrimTypes 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. - -> KindEnv n -- ^ Starting kind environment. - -> TypeEnv n -- ^ Starting type environment. - -> Module a n -- ^ Module to check. - -> Mode n -- ^ Type checker mode. - -> CheckM a n (Module (AnTEC a n) n) - -checkModuleM !config !kenv !tenv mm@ModuleCore{} !mode - = do - -- Check kinds of imported types ------------------ - nksImported' <- checkImportTypes config mode - $ moduleImportTypes mm - - - -- Check imported data type defs ------------------ - let defsImported = moduleImportDataDefs mm - defsImported' <- case checkDataDefs config defsImported of - (err : _, _) -> throw $ ErrorData err - ([], defsImported') -> return defsImported' - - - -- Build the imported defs and kind environment. - -- This contains kinds of type visible in the imported values. - let config_import = config - { configDataDefs = unionDataDefs (configDataDefs config) - (fromListDataDefs defsImported') } - let kenv_import = Env.union kenv - $ Env.fromList [ BName n (kindOfImportType isrc) - | (n, isrc) <- nksImported' ] - - - -- Check types of imported capabilities ----------- - ntsImportCap' <- checkImportCaps config_import kenv_import mode - $ moduleImportCaps mm - - let bsImportCap = [ BName n (typeOfImportCap isrc) - | (n, isrc) <- ntsImportCap' ] - - -- Check types of imported values ----------------- - ntsImportValue' <- checkImportValues config_import kenv_import mode - $ moduleImportValues mm - - - -- Check the local data type defs ----------------- - let defsLocal = moduleDataDefsLocal mm - defsLocal' <- case checkDataDefs config defsLocal of - (err : _, _) -> throw $ ErrorData err - ([], defsLocal') -> return defsLocal' - - - - -- Build the top-level config, defs and environments. - -- These contain names that are visible to bindings in the module. - let defs_top = unionDataDefs (configDataDefs config) - $ unionDataDefs (fromListDataDefs defsImported') - (fromListDataDefs defsLocal') - - let caps_top = Env.fromList - $ [BName n t | (n, ImportCapAbstract t) <- ntsImportCap' ] - - let config_top = config - { configDataDefs = defs_top - , configGlobalCaps = caps_top } - - let kenv_top = kenv_import - - let tenv_top = Env.unions - [ tenv - , Env.fromList [ BName n (typeOfImportValue isrc) - | (n, isrc) <- ntsImportValue' ] - - , Env.fromList [ BName n (typeOfImportCap isrc) - | (n, isrc) <- ntsImportCap' ] - ] - - let ctx_top = pushTypes bsImportCap emptyContext - - -- Check the sigs of exported types --------------- - esrcsType' <- checkExportTypes config_top - $ moduleExportTypes mm - - - -- Check the sigs of exported values -------------- - esrcsValue' <- checkExportValues config_top kenv_top - $ moduleExportValues mm - - - -- Check the body of the module ------------------- - (x', _, _effs, ctx) - <- checkExpM (makeTable config_top kenv_top tenv_top) - ctx_top mode DemandNone (moduleBody mm) - - -- Apply the final context to the annotations in expressions. - let applyToAnnot (AnTEC t0 e0 _ 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 = nksImported' - , moduleImportCaps = ntsImportCap' - , moduleImportValues = ntsImportValue' - , 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. - tenv_binds <- checkModuleBinds - (moduleExportTypes mm_inferred) - (moduleExportValues mm_inferred) - xx_annot - - -- Build the environment containing all names that can be exported. - let tenv_exportable = Env.union tenv_top tenv_binds - - -- Check that all exported bindings are defined by the module, - -- either directly as bindings, or by importing them from somewhere else. - -- Header modules don't need to contain the complete set of bindings, - -- but all other modules do. - when (not $ moduleIsHeader mm_inferred) - $ mapM_ (checkBindDefined tenv_exportable) - $ map fst $ moduleExportValues mm_inferred - - -- If exported names are missing types then fill them in. - let updateExportSource e - | ExportSourceLocalNoType n <- e - , Just t <- Env.lookup (UName n) tenv_exportable - = ExportSourceLocal n t - - | otherwise = e - - let esrcsValue_updated - = [ (n, updateExportSource e) | (n, e) <- esrcsValue' ] - - -- Return the checked bindings as they have explicit type annotations. - let mm_final - = mm_inferred - { moduleExportValues = esrcsValue_updated } - - return mm_final - - ---------------------------------------------------------------------------------------------------- --- | Check exported types. -checkExportTypes - :: (Show n, Pretty n, Ord n) - => Config n - -> [(n, ExportSource n)] - -> CheckM a n [(n, ExportSource n)] - -checkExportTypes config nesrcs - = let check (n, esrc) - | Just k <- takeTypeOfExportSource esrc - = do (k', _, _) <- checkTypeM config Env.empty emptyContext UniverseKind k Recon - return $ (n, mapTypeOfExportSource (const k') esrc) - - | otherwise - = return (n, esrc) - in do - -- Check for duplicate exports. - let dups = findDuplicates $ map fst nesrcs - (case takeHead dups of - Just n -> throw $ ErrorExportDuplicate n - _ -> return ()) - - - -- Check the kinds of the export specs. - mapM check nesrcs - - ---------------------------------------------------------------------------------------------------- --- | Check exported types. -checkExportValues - :: (Show n, Pretty n, Ord n) - => Config n -> KindEnv n - -> [(n, ExportSource n)] - -> CheckM a n [(n, ExportSource n)] - -checkExportValues config kenv nesrcs - = let check (n, esrc) - | Just t <- takeTypeOfExportSource esrc - = do (t', _, _) <- checkTypeM config kenv emptyContext UniverseSpec t Recon - return $ (n, mapTypeOfExportSource (const t') esrc) - - | otherwise - = return (n, esrc) - - in do - -- Check for duplicate exports. - let dups = findDuplicates $ map fst nesrcs - (case takeHead dups of - Just n -> throw $ ErrorExportDuplicate n - _ -> return ()) - - -- Check the types of the exported values. - mapM check nesrcs - - ---------------------------------------------------------------------------------------------------- --- | Check kinds of imported types. -checkImportTypes - :: (Ord n, Show n, Pretty n) - => Config n -> Mode n - -> [(n, ImportType n)] - -> CheckM a n [(n, ImportType n)] - -checkImportTypes config mode nisrcs - = let - -- 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 Env.empty emptyContext 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 k1 k2 - compat (ImportTypeBoxed k1) (ImportTypeBoxed k2) = equivT 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 types of imported capabilities. -checkImportCaps - :: (Ord n, Show n, Pretty n) - => Config n -> KindEnv n -> Mode n - -> [(n, ImportCap n)] - -> CheckM a n [(n, ImportCap n)] - -checkImportCaps config kenv mode nisrcs - = let - -- Checker mode to use. - modeCheckImportCaps - = case mode of - Recon -> Recon - _ -> Check kEffect - - -- Check an import definition. - check (n, isrc) - = do let t = typeOfImportCap isrc - (t', k, _) <- checkTypeM config kenv emptyContext UniverseSpec - t modeCheckImportCaps - - -- In Recon mode we need to post-check that the imported - -- capability really has kind Effect. - -- - -- In Check mode we pass down the expected kind, - -- so this is checked locally. - -- - when (not $ isEffectKind k) - $ throw $ ErrorImportCapNotEffect n - - return (n, mapTypeOfImportCap (const t') isrc) - - -- Pack down duplicate import definitions. - -- We can import the same capability via multiple modules, - -- which is ok provided all instances have the same type. - pack !mm [] - = return $ Map.toList mm - - pack !mm ((n, isrc) : nis) - = case Map.lookup n mm of - Just isrc' - | compat isrc isrc' -> pack mm nis - | otherwise -> throw $ ErrorImportDuplicate n - - Nothing -> pack (Map.insert n isrc mm) nis - - -- Check if two imported capabilities of the same name are compatiable. - -- The same import definition can appear multiple times provided each - -- instance has the same name and type. - compat (ImportCapAbstract t1) (ImportCapAbstract t2) = equivT t1 t2 - - in do - -- Check all the imports individually. - nisrcs' <- mapM check nisrcs - - -- Check that imports with the same name are compatable, - -- and pack down duplicates. - pack Map.empty nisrcs' - - ---------------------------------------------------------------------------------------------------- --- | Check types of imported values. -checkImportValues - :: (Ord n, Show n, Pretty n) - => Config n -> KindEnv n -> Mode n - -> [(n, ImportValue n)] - -> CheckM a n [(n, ImportValue n)] - -checkImportValues config kenv mode nisrcs - = let - -- 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 kenv emptyContext 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 t1 t2 && a1 == a2 - - compat (ImportValueSea _ t1) - (ImportValueSea _ t2) - = equivT 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 - => [(n, ExportSource n)] -- ^ Exported types. - -> [(n, ExportSource n)] -- ^ Exported values - -> Exp (AnTEC a n) n - -> CheckM a n (TypeEnv n) -- ^ Environment of top-level bindings - -- defined by the module - -checkModuleBinds !ksExports !tsExports !xx - = case xx of - XLet _ (LLet b _) x2 - -> do checkModuleBind ksExports tsExports b - env <- checkModuleBinds ksExports tsExports x2 - return $ Env.extend b env - - XLet _ (LRec bxs) x2 - -> do mapM_ (checkModuleBind ksExports tsExports) $ map fst bxs - env <- checkModuleBinds ksExports tsExports x2 - return $ Env.extends (map fst bxs) env - - XLet _ (LPrivate _ _ _) x2 - -> checkModuleBinds ksExports tsExports x2 - - _ -> return Env.empty - - --- | If some bind is exported, then check that it matches the exported version. -checkModuleBind - :: Ord n - => [(n, ExportSource n)] -- ^ Exported types. - -> [(n, ExportSource n)] -- ^ Exported values. - -> Bind n - -> CheckM a n () - -checkModuleBind !_ksExports !tsExports !b - | BName n tDef <- b - = case join $ liftM takeTypeOfExportSource $ lookup n tsExports of - Nothing -> return () - Just tExport - | equivT tDef tExport -> return () - | otherwise -> throw $ ErrorExportMismatch n tExport tDef - - -- Only named bindings can be exported, - -- so we don't need to worry about non-named ones. - | otherwise - = return () - - ---------------------------------------------------------------------------------------------------- --- | Check that an exported top-level value is actually defined by the module. -checkBindDefined - :: Ord n - => TypeEnv n -- ^ Types defined by the module. - -> n -- ^ Name of an exported binding. - -> CheckM a n () - -checkBindDefined env n - = case Env.lookup (UName n) env of - Just _ -> return () - _ -> throw $ ErrorExportUndefined n - diff --git a/DDC/Core/Check/Witness.hs b/DDC/Core/Check/Witness.hs deleted file mode 100644 --- a/DDC/Core/Check/Witness.hs +++ /dev/null @@ -1,133 +0,0 @@ --- | Type checker for witness expressions. -module DDC.Core.Check.Witness - ( checkWitness - , checkWitnessM - , typeOfWitness - , typeOfWiCon) -where -import DDC.Core.Exp.Annot.AnT -import DDC.Core.Check.Error -import DDC.Core.Check.ErrorMessage () -import DDC.Core.Check.Base -import DDC.Type.Transform.SubstituteT -import qualified DDC.Type.Env as Env - - --- Wrappers -------------------------------------------------------------------- --- | Check a witness. --- --- If it's good, you get a new version with types attached to all the bound --- variables, as well as the type of the overall witness. --- --- If it's bad, you get a description of the error. --- --- The returned expression has types attached to all variable occurrences, --- so you can call `typeOfWitness` on any open subterm. --- --- The kinds and types of primitives are added to the environments --- automatically, you don't need to supply these as part of the --- starting environments. --- -checkWitness - :: (Ord n, Show n, Pretty n) - => Config n -- ^ Static configuration. - -> KindEnv n -- ^ Starting Kind Environment. - -> TypeEnv n -- ^ Strating Type Environment. - -> Witness a n -- ^ Witness to check. - -> Either (Error a n) - ( Witness (AnT a n) n - , Type n) - -checkWitness config kenv tenv xx - = evalCheck (mempty, 0, 0) - $ checkWitnessM config kenv tenv emptyContext xx - - --- | Like `checkWitness`, but check in an empty environment. --- --- As this function is not given an environment, the types of free variables --- must be attached directly to the bound occurrences. --- This attachment is performed by `checkWitness` above. --- -typeOfWitness - :: (Ord n, Show n, Pretty n) - => Config n - -> Witness a n - -> Either (Error a n) (Type n) - -typeOfWitness config ww - = case checkWitness config Env.empty Env.empty ww of - Left err -> Left err - Right (_, t) -> Right t - - ------------------------------------------------------------------------------- --- | Like `checkWitness` but using the `CheckM` monad to manage errors. -checkWitnessM - :: (Ord n, Show n, Pretty n) - => Config n -- ^ Data type definitions. - -> KindEnv n -- ^ Kind environment. - -> TypeEnv n -- ^ Type environment. - -> Context n -- ^ Input context - -> Witness a n -- ^ Witness to check. - -> CheckM a n - ( Witness (AnT a n) n - , Type n) - -checkWitnessM !_config !_kenv !tenv !ctx (WVar a u) - -- Witness is defined locally. - | Just t <- lookupType u ctx - = return ( WVar (AnT t a) u, t) - - -- Witness is defined globally. - | Just t <- Env.lookup u tenv - = return ( WVar (AnT t a) u, t) - - | otherwise - = throw $ ErrorUndefinedVar a u UniverseWitness - -checkWitnessM !_config !_kenv !_tenv !_ctx (WCon a wc) - = let t' = typeOfWiCon wc - in return ( WCon (AnT t' a) wc - , t') - --- witness-type application -checkWitnessM !config !kenv !tenv !ctx ww@(WApp a1 w1 (WType a2 t2)) - = do (w1', t1) <- checkWitnessM config kenv tenv ctx w1 - (t2', k2, _) <- checkTypeM config kenv ctx UniverseSpec t2 Recon - case t1 of - TForall b11 t12 - | typeOfBind b11 == k2 - -> let t' = substituteT b11 t2' t12 - in return ( WApp (AnT t' a1) w1' (WType (AnT k2 a2) t2') - , t') - - | otherwise -> throw $ ErrorWAppMismatch a1 ww (typeOfBind b11) k2 - _ -> throw $ ErrorWAppNotCtor a1 ww t1 t2' - --- witness-witness application -checkWitnessM !config !kenv !tenv !ctx ww@(WApp a w1 w2) - = do (w1', t1) <- checkWitnessM config kenv tenv ctx w1 - (w2', t2) <- checkWitnessM config kenv tenv ctx w2 - case t1 of - TApp (TApp (TCon (TyConWitness TwConImpl)) t11) t12 - | t11 == t2 - -> return ( WApp (AnT t12 a) w1' w2' - , t12) - - | otherwise -> throw $ ErrorWAppMismatch a ww t11 t2 - _ -> throw $ ErrorWAppNotCtor a ww t1 t2 - --- embedded types -checkWitnessM !config !kenv !_tenv !ctx (WType a t) - = do (t', k, _) <- checkTypeM config kenv ctx UniverseSpec t Recon - return ( WType (AnT k a) t' - , k) - - --- | Take the type of a witness constructor. -typeOfWiCon :: WiCon n -> Type n -typeOfWiCon wc - = case wc of - WiConBound _ t -> t - diff --git a/DDC/Core/Collect.hs b/DDC/Core/Collect.hs --- a/DDC/Core/Collect.hs +++ b/DDC/Core/Collect.hs @@ -2,18 +2,24 @@ -- | Collecting sets of variables and constructors. module DDC.Core.Collect ( -- * Free Variables - freeT + freeT, freeVarsT , freeX -- * Bounds and Binds , collectBound , collectBinds + -- * Abstract Binding Structures + , BindTree (..) + , BindWay (..) + , BoundLevel (..) + , BindStruct (..) + -- * Support , Support (..) , SupportX (..)) where -import DDC.Core.Collect.Free -import DDC.Core.Collect.Free.Simple () +import DDC.Core.Collect.FreeX +import DDC.Core.Collect.FreeT +import DDC.Core.Collect.BindStruct import DDC.Core.Collect.Support -import DDC.Type.Collect diff --git a/DDC/Core/Collect/BindStruct.hs b/DDC/Core/Collect/BindStruct.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Collect/BindStruct.hs @@ -0,0 +1,176 @@ + +-- | Collecting sets of variables and constructors. +module DDC.Core.Collect.BindStruct + ( BindTree (..) + , BindWay (..) + , BoundLevel (..) + , BindStruct (..) + , isBoundExpWit + , boundLevelOfBindWay + , bindDefT + + , freeT + , freeOfTreeT + + , collectBound + , collectBinds) +where +import DDC.Type.Exp +import DDC.Type.Env (Env) +import qualified DDC.Type.Env as Env +import qualified Data.Set as Set +import Data.Set (Set) + + +------------------------------------------------------------------------------- +-- | A description of the binding structure of some type or expression. +data BindTree n + -- | An abstract binding expression. + = BindDef BindWay [Bind n] [BindTree n] + + -- | Use of a variable. + | BindUse BoundLevel (Bound n) + + -- | Use of a constructor. + | BindCon BoundLevel (Bound n) (Maybe (Kind n)) + deriving (Eq, Show) + + +-- | Describes how a variable was bound. +data BindWay + = BindTAbs + | BindForall + | BindLAM + | BindLam + | BindLet + | BindLetRec + | BindLetRegions + | BindLetRegionWith + | BindCasePat + deriving (Eq, Show) + + +-- | What level this binder is at. +data BoundLevel + = BoundSpec + | BoundExp + | BoundWit + deriving (Eq, Show) + + +-- | Check if a boundlevel is expression or witness +isBoundExpWit :: BoundLevel -> Bool +isBoundExpWit BoundExp = True +isBoundExpWit BoundWit = True +isBoundExpWit _ = False + + +-- | Get the `BoundLevel` corresponding to a `BindWay`. +boundLevelOfBindWay :: BindWay -> BoundLevel +boundLevelOfBindWay way + = case way of + BindTAbs -> BoundSpec + BindForall -> BoundSpec + BindLAM -> BoundSpec + BindLam -> BoundExp + BindLet -> BoundExp + BindLetRec -> BoundExp + BindLetRegions -> BoundSpec + BindLetRegionWith -> BoundExp + BindCasePat -> BoundExp + + +-- BindStruct ----------------------------------------------------------------- +class BindStruct c n | c -> n where + slurpBindTree :: c -> [BindTree n] + + +-- | Helper for constructing the `BindTree` for a type binder. +bindDefT :: BindStruct c n + => BindWay -> [Bind n] -> [c] -> BindTree n +bindDefT way bs xs + = BindDef way bs $ concatMap slurpBindTree xs + + +-- freeT ---------------------------------------------------------------------- +-- | Collect the free Spec variables in a thing (level-1). +freeT :: (BindStruct c n, Ord n) + => Env n -> c -> Set (Bound n) +freeT tenv xx = Set.unions $ map (freeOfTreeT tenv) $ slurpBindTree xx + +freeOfTreeT :: Ord n => Env n -> BindTree n -> Set (Bound n) +freeOfTreeT kenv tt + = case tt of + BindDef way bs ts + | BoundSpec <- boundLevelOfBindWay way + , kenv' <- Env.extends bs kenv + -> Set.unions $ map (freeOfTreeT kenv') ts + + BindDef _ _ ts + -> Set.unions $ map (freeOfTreeT kenv) ts + + BindUse BoundSpec u + | Env.member u kenv -> Set.empty + | otherwise -> Set.singleton u + _ -> Set.empty + + +-- collectBound --------------------------------------------------------------- +-- | Collect all the bound variables in a thing, +-- independent of whether they are free or not. +collectBound + :: (BindStruct c n, Ord n) + => c -> Set (Bound n) + +collectBound + = Set.unions . map collectBoundOfTree . slurpBindTree + +collectBoundOfTree :: Ord n => BindTree n -> Set (Bound n) +collectBoundOfTree tt + = case tt of + BindDef _ _ ts -> Set.unions $ map collectBoundOfTree ts + BindUse _ u -> Set.singleton u + BindCon _ u _ -> Set.singleton u + + +-- collectSpecBinds ----------------------------------------------------------- +-- | Collect all the spec and exp binders in a thing. +collectBinds + :: (BindStruct c n, Ord n) + => c + -> ([Bind n], [Bind n]) + +collectBinds thing + = let tree = slurpBindTree thing + in ( concatMap collectSpecBindsOfTree tree + , concatMap collectExpBindsOfTree tree) + + +collectSpecBindsOfTree :: Ord n => BindTree n -> [Bind n] +collectSpecBindsOfTree tt + = case tt of + BindDef way bs ts + | BoundSpec <- boundLevelOfBindWay way + -> concat ( bs + : map collectSpecBindsOfTree ts) + + | otherwise + -> concatMap collectSpecBindsOfTree ts + + _ -> [] + + +collectExpBindsOfTree :: Ord n => BindTree n -> [Bind n] +collectExpBindsOfTree tt + = case tt of + BindDef way bs ts + | BoundExp <- boundLevelOfBindWay way + -> concat ( bs + : map collectExpBindsOfTree ts) + + | otherwise + -> concatMap collectExpBindsOfTree ts + + _ -> [] + + diff --git a/DDC/Core/Collect/Free.hs b/DDC/Core/Collect/Free.hs deleted file mode 100644 --- a/DDC/Core/Collect/Free.hs +++ /dev/null @@ -1,119 +0,0 @@ --- | Collecting sets of variables and constructors. -module DDC.Core.Collect.Free - ( freeX - , bindDefX) -where -import DDC.Type.Collect -import DDC.Type.Compounds -import DDC.Core.Module -import DDC.Core.Exp -import DDC.Type.Env (Env) -import qualified DDC.Type.Env as Env -import qualified Data.Set as Set -import Data.Set (Set) -import Data.Maybe -import Control.Monad - - --- freeX ---------------------------------------------------------------------- --- | Collect the free Data and Witness variables in a thing (level-0). -freeX :: (BindStruct c 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/Free/Simple.hs b/DDC/Core/Collect/Free/Simple.hs deleted file mode 100644 --- a/DDC/Core/Collect/Free/Simple.hs +++ /dev/null @@ -1,77 +0,0 @@ --- | Collecting sets of variables and constructors. -module DDC.Core.Collect.Free.Simple - () -where -import DDC.Type.Collect -import DDC.Core.Collect.Free -import DDC.Core.Exp.Simple.Exp - - --- Exp ------------------------------------------------------------------------ -instance BindStruct (Exp a n) n where - slurpBindTree xx - = case xx of - XAnnot _ x - -> slurpBindTree x - XVar u - -> [BindUse BoundExp u] - - XCon dc - -> case dc of - DaConBound n -> [BindCon BoundExp (UName n) Nothing] - _ -> [] - - XApp x1 x2 -> slurpBindTree x1 ++ slurpBindTree x2 - XLAM b x -> [bindDefT BindLAM [b] [x]] - XLam b x -> [bindDefX BindLam [b] [x]] - - XLet (LLet b x1) x2 - -> slurpBindTree x1 - ++ [bindDefX BindLet [b] [x2]] - - XLet (LRec bxs) x2 - -> [bindDefX BindLetRec - (map fst bxs) - (map snd bxs ++ [x2])] - - XLet (LPrivate bsR mtExtend bs) x2 - -> (case mtExtend of - Nothing -> [] - Just tR -> slurpBindTree tR) - ++ [ BindDef BindLetRegions bsR - [bindDefX BindLetRegionWith bs [x2]] ] - - 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 - WAnnot _ w -> slurpBindTree w - diff --git a/DDC/Core/Collect/FreeT.hs b/DDC/Core/Collect/FreeT.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Collect/FreeT.hs @@ -0,0 +1,79 @@ + +module DDC.Core.Collect.FreeT + ( FreeVarConT(..) + , freeVarsT) +where +import DDC.Core.Collect.BindStruct +import DDC.Type.Exp +import DDC.Type.Env (KindEnv) +import Data.Set (Set) +import qualified DDC.Type.Env as Env +import qualified DDC.Type.Sum as Sum +import qualified Data.Set as Set + + +-- | Collect the free type variables in a type. +freeVarsT + :: Ord n + => KindEnv n -> Type n + -> Set (Bound n) +freeVarsT kenv tt + = fst $ freeVarConT kenv tt + + +instance BindStruct (Type n) n where + slurpBindTree tt + = case tt of + TVar u -> [BindUse BoundSpec u] + TCon tc -> slurpBindTree tc + TAbs b t -> [bindDefT BindTAbs [b] [t]] + TApp t1 t2 -> slurpBindTree t1 ++ slurpBindTree t2 + TForall b t -> [bindDefT BindForall [b] [t]] + TSum ts -> concatMap slurpBindTree $ Sum.toList ts + + +instance BindStruct (TyCon n) n where + slurpBindTree tc + = case tc of + TyConBound u k -> [BindCon BoundSpec u (Just k)] + _ -> [] + + +class FreeVarConT (c :: * -> *) where + -- | Collect the free type variables and constructors used in a thing. + freeVarConT + :: Ord n + => KindEnv n -> c n + -> (Set (Bound n), Set (Bound n)) + + +instance FreeVarConT Type where + freeVarConT kenv tt + = case tt of + TVar u + -> if Env.member u kenv + then (Set.empty, Set.empty) + else (Set.singleton u, Set.empty) + + TCon tc + | TyConBound u _ <- tc -> (Set.empty, Set.singleton u) + | otherwise -> (Set.empty, Set.empty) + + TAbs b t + -> freeVarConT (Env.extend b kenv) t + + TApp t1 t2 + -> let (vs1, cs1) = freeVarConT kenv t1 + (vs2, cs2) = freeVarConT kenv t2 + in ( Set.union vs1 vs2 + , Set.union cs1 cs2) + + TForall b t + -> freeVarConT (Env.extend b kenv) t + + TSum ts + -> let (vss, css) = unzip $ map (freeVarConT kenv) + $ Sum.toList ts + in (Set.unions vss, Set.unions css) + + diff --git a/DDC/Core/Collect/FreeX.hs b/DDC/Core/Collect/FreeX.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Collect/FreeX.hs @@ -0,0 +1,120 @@ +-- | Collecting sets of variables and constructors. +module DDC.Core.Collect.FreeX + ( freeX + , bindDefX) +where +import DDC.Type.Exp.Simple +import DDC.Core.Collect.BindStruct +import DDC.Core.Collect.FreeT () +import DDC.Core.Module +import DDC.Core.Exp +import DDC.Type.Env (Env) +import qualified DDC.Type.Env as Env +import qualified Data.Set as Set +import Data.Set (Set) +import Data.Maybe +import Control.Monad + + +-- freeX ---------------------------------------------------------------------- +-- | Collect the free Data and Witness variables in a thing (level-0). +freeX :: (BindStruct c n, Ord n) + => Env n -> c -> Set (Bound n) +freeX tenv xx = Set.unions $ map (freeOfTreeX tenv) $ slurpBindTree xx + +freeOfTreeX :: Ord n => Env n -> BindTree n -> Set (Bound n) +freeOfTreeX tenv tt + = {-# SCC freeOfTreeX #-} + case tt of + BindDef way bs ts + | isBoundExpWit $ boundLevelOfBindWay way + , tenv' <- Env.extends bs tenv + -> Set.unions $ map (freeOfTreeX tenv') ts + + BindDef _ _ ts + -> Set.unions $ map (freeOfTreeX tenv) ts + + BindUse bl u + | isBoundExpWit bl + , Env.member u tenv -> Set.empty + | isBoundExpWit bl -> Set.singleton u + _ -> Set.empty + + +-- Module --------------------------------------------------------------------- +instance BindStruct (Module a n) n where + slurpBindTree mm + = slurpBindTree $ moduleBody mm + + +-- Exp ------------------------------------------------------------------------ +instance BindStruct (Exp a n) n where + slurpBindTree xx + = case xx of + XVar _ u + -> [BindUse BoundExp u] + + XCon _ dc + -> case dc of + DaConBound n -> [BindCon BoundExp (UName n) Nothing] + _ -> [] + + XApp _ x1 x2 -> slurpBindTree x1 ++ slurpBindTree x2 + XLAM _ b x -> [bindDefT BindLAM [b] [x]] + XLam _ b x -> [bindDefX BindLam [b] [x]] + + XLet _ (LLet b x1) x2 + -> slurpBindTree x1 + ++ [bindDefX BindLet [b] [x2]] + + XLet _ (LRec bxs) x2 + -> [bindDefX BindLetRec + (map fst bxs) + (map snd bxs ++ [x2])] + + XLet _ (LPrivate b mT bs) x2 + -> (concat $ liftM slurpBindTree $ maybeToList mT) + ++ [ BindDef BindLetRegions b + [bindDefX BindLetRegionWith bs [x2]]] + + XCase _ x alts -> slurpBindTree x ++ concatMap slurpBindTree alts + XCast _ c x -> slurpBindTree c ++ slurpBindTree x + XType _ t -> slurpBindTree t + XWitness _ w -> slurpBindTree w + + +instance BindStruct (Cast a n) n where + slurpBindTree cc + = case cc of + CastWeakenEffect eff -> slurpBindTree eff + CastPurify w -> slurpBindTree w + CastBox -> [] + CastRun -> [] + + +instance BindStruct (Alt a n) n where + slurpBindTree alt + = case alt of + AAlt PDefault x + -> slurpBindTree x + + AAlt (PData _ bs) x + -> [bindDefX BindCasePat bs [x]] + + +instance BindStruct (Witness a n) n where + slurpBindTree ww + = case ww of + WVar _ u -> [BindUse BoundWit u] + WCon{} -> [] + WApp _ w1 w2 -> slurpBindTree w1 ++ slurpBindTree w2 + WType _ t -> slurpBindTree t + + +-- | Helper for constructing the `BindTree` for an expression or witness binder. +bindDefX :: BindStruct c n + => BindWay -> [Bind n] -> [c] -> BindTree n +bindDefX way bs xs + = BindDef way bs + $ concatMap (slurpBindTree . typeOfBind) bs + ++ concatMap slurpBindTree xs diff --git a/DDC/Core/Collect/Support.hs b/DDC/Core/Collect/Support.hs --- a/DDC/Core/Collect/Support.hs +++ b/DDC/Core/Collect/Support.hs @@ -6,7 +6,7 @@ where import DDC.Core.Module import DDC.Core.Exp.Annot -import DDC.Type.Collect.FreeT +import DDC.Core.Collect.FreeT import Data.Set (Set) import DDC.Type.Env (KindEnv, TypeEnv) import qualified DDC.Type.Env as Env 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/Annot.hs b/DDC/Core/Exp/Annot.hs --- a/DDC/Core/Exp/Annot.hs +++ b/DDC/Core/Exp/Annot.hs @@ -23,7 +23,7 @@ --------------------------------------- -- * Predicates - , module DDC.Type.Predicates + , module DDC.Type.Exp.Simple.Predicates -- ** Atoms , isXVar, isXCon @@ -53,7 +53,7 @@ --------------------------------------- -- * Compounds - , module DDC.Type.Compounds + , module DDC.Type.Exp.Simple.Compounds -- ** Annotations , annotOfExp @@ -118,6 +118,6 @@ import DDC.Core.Exp.Annot.Exp import DDC.Core.Exp.Annot.Compounds import DDC.Core.Exp.Annot.Predicates -import DDC.Type.Compounds -import DDC.Type.Predicates +import DDC.Type.Exp.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 --- a/DDC/Core/Exp/Annot/AnT.hs +++ b/DDC/Core/Exp/Annot/AnT.hs @@ -3,7 +3,7 @@ (AnT (..)) where import DDC.Type.Exp -import DDC.Base.Pretty +import DDC.Data.Pretty import Control.DeepSeq import Data.Typeable diff --git a/DDC/Core/Exp/Annot/AnTEC.hs b/DDC/Core/Exp/Annot/AnTEC.hs --- a/DDC/Core/Exp/Annot/AnTEC.hs +++ b/DDC/Core/Exp/Annot/AnTEC.hs @@ -3,9 +3,8 @@ ( AnTEC (..) , fromAnT) where -import DDC.Type.Compounds -import DDC.Type.Exp -import DDC.Base.Pretty +import DDC.Type.Exp.Simple +import DDC.Data.Pretty import Control.DeepSeq import Data.Typeable import DDC.Core.Exp.Annot.AnT (AnT) diff --git a/DDC/Core/Exp/Annot/Compounds.hs b/DDC/Core/Exp/Annot/Compounds.hs --- a/DDC/Core/Exp/Annot/Compounds.hs +++ b/DDC/Core/Exp/Annot/Compounds.hs @@ -4,7 +4,7 @@ -- For the annotated version of the AST. -- module DDC.Core.Exp.Annot.Compounds - ( module DDC.Type.Compounds + ( module DDC.Type.Exp.Simple.Compounds -- * Annotations , annotOfExp @@ -66,7 +66,7 @@ where import DDC.Core.Exp.Annot.Exp import DDC.Core.Exp.DaCon -import DDC.Type.Compounds +import DDC.Type.Exp.Simple.Compounds -- Annotations ---------------------------------------------------------------- @@ -251,7 +251,7 @@ -- and its arguments. -- -- Returns `Nothing` if the expression isn't a constructor application. -takeXConApps :: Exp a n -> Maybe (DaCon n, [Exp a n]) +takeXConApps :: Exp a n -> Maybe (DaCon n (Type n), [Exp a n]) takeXConApps xx = case takeXAppsAsList xx of XCon _ dc : xs -> Just (dc, xs) diff --git a/DDC/Core/Exp/Annot/Context.hs b/DDC/Core/Exp/Annot/Context.hs --- a/DDC/Core/Exp/Annot/Context.hs +++ b/DDC/Core/Exp/Annot/Context.hs @@ -15,16 +15,13 @@ import DDC.Core.Exp.Annot.Exp import DDC.Core.Exp.Annot.Ctx import DDC.Core.Exp.Annot.Compounds -import DDC.Type.Env (KindEnv, TypeEnv) -import qualified DDC.Type.Env as Env - +import DDC.Core.Env.EnvX (EnvX) +import qualified DDC.Core.Env.EnvX as EnvX data Context a n = Context - { contextKindEnv :: KindEnv n - , contextTypeEnv :: TypeEnv n - , contextGlobalCaps :: TypeEnv n - , contextCtx :: Ctx a n } + { contextEnv :: EnvX n + , contextCtx :: Ctx a n } -- | Enter the body of a type lambda. @@ -34,8 +31,8 @@ -> (Context a n -> Exp a n -> b) -> b enterLAM c a b x f - = let c' = c { contextKindEnv = Env.extend b (contextKindEnv c) - , contextCtx = CtxLAM (contextCtx c) a b } + = let c' = c { contextEnv = EnvX.extendT b (contextEnv c) + , contextCtx = CtxLAM (contextCtx c) a b } in f c' x @@ -46,8 +43,8 @@ -> (Context a n -> Exp a n -> b) -> b enterLam c a b x f - = let c' = c { contextTypeEnv = Env.extend b (contextTypeEnv c) - , contextCtx = CtxLam (contextCtx c) a b } + = let c' = c { contextEnv = EnvX.extendX b (contextEnv c) + , contextCtx = CtxLam (contextCtx c) a b } in f c' x @@ -82,8 +79,9 @@ enterLetBody c a lts x f = let (bs1, bs0) = bindsOfLets lts - c' = c { contextKindEnv = Env.extends bs1 (contextKindEnv c) - , contextTypeEnv = Env.extends bs0 (contextTypeEnv c) + c' = c { contextEnv = EnvX.extendsX bs0 + $ EnvX.extendsT bs1 + $ contextEnv c , contextCtx = CtxLetBody (contextCtx c) a lts } in f c' x @@ -108,9 +106,9 @@ enterLetLRec c a bxsBefore b x bxsAfter xBody f = let bsBefore = map fst bxsBefore bsAfter = map fst bxsAfter - c' = c { contextTypeEnv = Env.extends (bsBefore ++ [b] ++ bsAfter) - (contextTypeEnv c) - , contextCtx = CtxLetLRec (contextCtx c) a + c' = c { contextEnv = EnvX.extendsX (bsBefore ++ [b] ++ bsAfter) + (contextEnv c) + , contextCtx = CtxLetLRec (contextCtx c) a bxsBefore b bxsAfter xBody } in f c' x @@ -135,8 +133,8 @@ enterCaseAlt c a xScrut altsBefore w x altsAfter f = let bs = bindsOfPat w - c' = c { contextTypeEnv = Env.extends bs (contextTypeEnv c) - , contextCtx = CtxCaseAlt (contextCtx c) a + c' = c { contextEnv = EnvX.extendsX bs (contextEnv c) + , contextCtx = CtxCaseAlt (contextCtx c) a xScrut altsBefore w altsAfter } in f c' x diff --git a/DDC/Core/Exp/Annot/Ctx.hs b/DDC/Core/Exp/Annot/Ctx.hs --- a/DDC/Core/Exp/Annot/Ctx.hs +++ b/DDC/Core/Exp/Annot/Ctx.hs @@ -8,22 +8,19 @@ , takeTopLetEnvNamesOfCtx , encodeCtx) where -import DDC.Type.DataDef import DDC.Core.Exp.Annot.Exp -import DDC.Type.Env (KindEnv, TypeEnv) -import Data.Set (Set) -import qualified DDC.Type.Env as Env -import qualified Data.Set as Set -import qualified Data.Map as Map +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 - { ctxDataDefs :: !(DataDefs n) - , ctxKindEnv :: !(KindEnv n) - , ctxTypeEnv :: !(TypeEnv n) } + { ctxEnvX :: !(EnvX n) } -- | Body of a type abstraction. | CtxLAM !(Ctx a n) !a @@ -70,6 +67,7 @@ !(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 @@ -88,12 +86,10 @@ -- | Get the top level of a context. -topOfCtx :: Ctx a n - -> (DataDefs n, KindEnv n, TypeEnv n) - +topOfCtx :: Ctx a n -> EnvX n topOfCtx ctx = case ctx of - CtxTop defs kenv tenv -> (defs, kenv, tenv) + CtxTop env -> env CtxLAM c _ _ -> topOfCtx c CtxLam c _ _ -> topOfCtx c CtxAppLeft c _ _ -> topOfCtx c @@ -152,19 +148,19 @@ = eatCtx ctx0 where eatCtx ctx = case ctx of - CtxTop _ _ tenv + CtxTop env -> Set.fromList - $ Map.keys $ Env.envMap tenv + $ Map.keys $ EnvX.envxMap env - CtxLetLLet (CtxTop _ _ tenv) _ b xBody + CtxLetLLet (CtxTop env) _ b xBody -> Set.unions - [ Set.fromList $ Map.keys $ Env.envMap tenv + [ Set.fromList $ Map.keys $ EnvX.envxMap env , eatBind b , eatExp xBody] - CtxLetLRec (CtxTop _ _ tenv) _ bxsBefore b bxsAfter xBody + CtxLetLRec (CtxTop env) _ bxsBefore b bxsAfter xBody -> Set.unions - [ Set.fromList $ Map.keys $ Env.envMap tenv + [ Set.fromList $ Map.keys $ EnvX.envxMap env , Set.unions $ map (eatBind . fst) bxsBefore , eatBind b , Set.unions $ map (eatBind . fst) bxsAfter diff --git a/DDC/Core/Exp/Annot/Exp.hs b/DDC/Core/Exp/Annot/Exp.hs --- a/DDC/Core/Exp/Annot/Exp.hs +++ b/DDC/Core/Exp/Annot/Exp.hs @@ -48,13 +48,13 @@ = XVar !a !(Bound n) -- | Data constructor or literal. - | XCon !a !(DaCon n) + | XCon !a !(DaCon n (Type n)) -- | Type abstraction (level-1). - | XLAM !a !(Bind n) !(Exp a n) + | XLAM !a !(Bind n) !(Exp a n) -- | Value and Witness abstraction (level-0). - | XLam !a !(Bind n) !(Exp a n) + | XLam !a !(Bind n) !(Exp a n) -- | Application. | XApp !a !(Exp a n) !(Exp a n) @@ -102,7 +102,7 @@ = PDefault -- | Match a data constructor and bind its arguments. - | PData !(DaCon n) ![Bind n] + | PData !(DaCon n (Type n)) ![Bind n] deriving (Show, Eq) diff --git a/DDC/Core/Exp/Annot/Predicates.hs b/DDC/Core/Exp/Annot/Predicates.hs --- a/DDC/Core/Exp/Annot/Predicates.hs +++ b/DDC/Core/Exp/Annot/Predicates.hs @@ -1,7 +1,7 @@ -- | Simple predicates on core expressions. module DDC.Core.Exp.Annot.Predicates - ( module DDC.Type.Predicates + ( module DDC.Type.Exp.Simple.Predicates -- * Atoms , isXVar, isXCon @@ -30,7 +30,7 @@ , isXWitness) where import DDC.Core.Exp.Annot.Exp -import DDC.Type.Predicates +import DDC.Type.Exp.Simple.Predicates -- Atoms ---------------------------------------------------------------------- diff --git a/DDC/Core/Exp/Annot/Pretty.hs b/DDC/Core/Exp/Annot/Pretty.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/Annot/Pretty.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | Pretty printing for annotated expressions. +module DDC.Core.Exp.Annot.Pretty + ( module DDC.Data.Pretty + , PrettyMode (..)) +where +import DDC.Core.Exp.Annot +import DDC.Type.Exp.Simple.Pretty () +import DDC.Data.Pretty +import Data.List +import Prelude hiding ((<$>)) + + +-- Exp -------------------------------------------------------------------------------------------- +instance (Pretty n, Eq n) => Pretty (Exp a n) where + data PrettyMode (Exp a n) + = PrettyModeExp + { modeExpLets :: PrettyMode (Lets a n) + , modeExpAlt :: PrettyMode (Alt a n) + + -- Display types on primitive variables. + , modeExpVarTypes :: Bool + + -- Display types on primitive constructors. + , modeExpConTypes :: Bool + + -- Use 'letcase' for single alternative case expressions. + , modeExpUseLetCase :: Bool } + + + pprDefaultMode + = PrettyModeExp + { modeExpLets = pprDefaultMode + , modeExpAlt = pprDefaultMode + , modeExpConTypes = False + , modeExpVarTypes = False + , modeExpUseLetCase = False } + + + pprModePrec mode d xx + = let pprX = pprModePrec mode 0 + pprLts = pprModePrec (modeExpLets mode) 0 + pprAlt = pprModePrec (modeExpAlt mode) 0 + in case xx of + + XVar _ u + | modeExpVarTypes mode + , Just t <- takeTypeOfBound u + -> parens $ ppr u <> text ":" <+> ppr t + + | otherwise + -> ppr u + + XCon _ dc + | modeExpConTypes mode + , Just t <- takeTypeOfDaCon dc + -> parens $ ppr dc <> text ":" <+> ppr t + + | otherwise + -> ppr dc + + XLAM{} + -> let Just (bs, xBody) = takeXLAMs xx + groups = partitionBindsByType bs + in pprParen' (d > 1) + $ (cat $ map (pprBinderGroup (text "Λ")) groups) + <> (if isXLAM xBody then empty + else if isXLam xBody then line + else if isSimpleX xBody then space + else line) + <> pprX xBody + + XLam{} + -> let Just (bs, xBody) = takeXLams xx + groups = partitionBindsByType bs + in pprParen' (d > 1) + $ (cat $ map (pprBinderGroup (text "\955")) groups) + <> breakWhen (not $ isSimpleX xBody) + <> pprX xBody + + XApp _ x1 x2 + -> pprParen' (d > 10) + $ pprModePrec mode 10 x1 + <> nest 4 (breakWhen (not $ isSimpleX x2) + <> pprModePrec mode 11 x2) + + XLet _ lts x + -> pprParen' (d > 2) + $ pprLts lts <+> text "in" + <$> pprX x + + -- Print single alternative case expressions as 'letcase'. + -- case x1 of { C v1 v2 -> x2 } + -- => letcase C v1 v2 <- x1 in x2 + XCase _ x1 [AAlt p x2] + | modeExpUseLetCase mode + -> pprParen' (d > 2) + $ text "letcase" <+> ppr p + <+> nest 2 (breakWhen (not $ isSimpleX x1) + <> text "=" <+> align (pprX x1)) + <+> text "in" + <$> pprX x2 + + XCase _ x alts + -> pprParen' (d > 2) + $ (nest 2 $ text "case" <+> ppr x <+> text "of" <+> lbrace <> line + <> (vcat $ punctuate semi $ map pprAlt alts)) + <> line + <> rbrace + + XCast _ CastBox x + -> pprParen' (d > 2) + $ text "box" <$> pprX x + + XCast _ CastRun x + -> pprParen' (d > 2) + $ text "run" <+> pprX x + + XCast _ cc x + -> pprParen' (d > 2) + $ ppr cc <+> text "in" + <$> pprX x + + XType _ t -> text "[" <> ppr t <> text "]" + XWitness _ w -> text "<" <> ppr w <> text ">" + + +-- Pat -------------------------------------------------------------------------------------------- +instance (Pretty n, Eq n) => Pretty (Pat n) where + ppr pp + = case pp of + PDefault -> text "_" + PData u bs -> ppr u <+> sep (map pprPatBind bs) + + +-- | Pretty print a binder, +-- showing its type annotation only if it's not bottom. +pprPatBind :: (Eq n, Pretty n) => Bind n -> Doc +pprPatBind b + | isBot (typeOfBind b) = ppr $ binderOfBind b + | otherwise = parens $ ppr b + + +-- Alt -------------------------------------------------------------------------------------------- +instance (Pretty n, Eq n) => Pretty (Alt a n) where + data PrettyMode (Alt a n) + = PrettyModeAlt + { modeAltExp :: PrettyMode (Exp a n) } + + pprDefaultMode + = PrettyModeAlt + { modeAltExp = pprDefaultMode } + + pprModePrec mode _ (AAlt p x) + = let pprX = pprModePrec (modeAltExp mode) 0 + in ppr p <+> nest 1 (line <> nest 3 (text "->" <+> pprX x)) + + +-- DaCon ------------------------------------------------------------------------------------------ +instance (Pretty n, Eq n) => Pretty (DaCon n (Type n)) where + ppr dc + = case dc of + DaConUnit -> text "()" + DaConPrim n _ -> ppr n + DaConBound n -> ppr n + + +-- Cast ------------------------------------------------------------------------------------------- +instance (Pretty n, Eq n) => Pretty (Cast a n) where + ppr cc + = case cc of + CastWeakenEffect eff + -> text "weakeff" <+> brackets (ppr eff) + + CastPurify w + -> text "purify" <+> angles (ppr w) + + CastBox + -> text "box" + + CastRun + -> text "run" + + +-- Lets ------------------------------------------------------------------------------------------- +instance (Pretty n, Eq n) => Pretty (Lets a n) where + data PrettyMode (Lets a n) + = PrettyModeLets + { modeLetsExp :: PrettyMode (Exp a n) + , modeLetsSuppressTypes :: Bool } + + pprDefaultMode + = PrettyModeLets + { modeLetsExp = pprDefaultMode + , modeLetsSuppressTypes = False } + + pprModePrec mode _ lts + = let pprX = pprModePrec (modeLetsExp mode) 0 + in case lts of + LLet b x + -> let bHasType = not $ isBot (typeOfBind b) + + dBind = if modeLetsSuppressTypes mode || (not bHasType) + then ppr (binderOfBind b) + else ppr b + + in text "let" + <+> align ( (padL 7 dBind) + <> nest (if bHasType then 2 else 6 ) + ( breakWhen bHasType + <> text "=" <+> align (pprX x))) + + LRec bxs + -> let pprLetRecBind (b, x) + = ppr (binderOfBind b) + <> text ":" <+> ppr (typeOfBind b) + <> nest 2 ( breakWhen (not $ isSimpleX x) + <> text "=" <+> align (pprX x)) + + in (nest 2 $ text "letrec" + <+> lbrace + <> ( line + <> (vcat $ punctuate (semi <> line) + $ map pprLetRecBind bxs))) + <$> rbrace + + LPrivate bs Nothing [] + -> text "private" + <+> (hcat $ punctuate space (map (ppr . binderOfBind) bs)) + + LPrivate bs Nothing bws + -> text "private" + <+> (hcat $ punctuate space (map (ppr . binderOfBind) bs)) + <+> text "with" + <+> braces (cat $ punctuate (text "; ") $ map pprWitBind bws) + + LPrivate bs (Just parent) [] + -> text "extend" + <+> ppr parent + <+> text "using" + <+> (hcat $ punctuate space (map (ppr . binderOfBind) bs)) + + LPrivate bs (Just parent) bws + -> text "extend" + <+> ppr parent + <+> text "using" + <+> (hcat $ punctuate space (map (ppr . binderOfBind) bs)) + <+> text "with" + <+> braces (cat $ punctuate (text "; ") $ map pprWitBind bws) + + +-- | When we pretty print witness binders, +-- suppress the underscore when there is no name. +pprWitBind :: (Eq n, Pretty n) => Bind n -> Doc +pprWitBind b + = case b of + BNone t -> ppr t + _ -> ppr b + + +-- Witness ---------------------------------------------------------------------------------------- +instance (Pretty n, Eq n) => Pretty (Witness a n) where + pprPrec d ww + = case ww of + WVar _ n -> ppr n + WCon _ wc -> ppr wc + WApp _ w1 w2 -> pprParen (d > 10) (ppr w1 <+> pprPrec 11 w2) + WType _ t -> text "[" <> ppr t <> text "]" + + +instance (Pretty n, Eq n) => Pretty (WiCon n) where + ppr wc + = case wc of + WiConBound u _ -> ppr u + + +-- Binder ----------------------------------------------------------------------------------------- +pprBinder :: Pretty n => Binder n -> Doc +pprBinder bb + = case bb of + RName v -> ppr v + RAnon -> text "^" + RNone -> text "_" + + +-- | Print a group of binders with the same type. +pprBinderGroup + :: (Pretty n, Eq n) + => Doc -> ([Binder n], Type n) -> Doc + +pprBinderGroup lam (rs, t) + = lam + <> parens ((hsep $ map pprBinder rs) <> text ":" <+> ppr t) + <> dot + + +-- Utils ------------------------------------------------------------------------------------------ +breakWhen :: Bool -> Doc +breakWhen True = line +breakWhen False = space + + +isSimpleX :: Exp a n -> Bool +isSimpleX xx + = case xx of + XVar{} -> True + XCon{} -> True + XType{} -> True + XWitness{} -> True + XApp _ x1 x2 -> isSimpleX x1 && isAtomX x2 + _ -> False + + +parens' :: Doc -> Doc +parens' d = lparen <> nest 1 d <> rparen + + +-- | Wrap a `Doc` in parens if the predicate is true. +pprParen' :: Bool -> Doc -> Doc +pprParen' b c + = if b then parens' c + else c + diff --git a/DDC/Core/Exp/DaCon.hs b/DDC/Core/Exp/DaCon.hs --- a/DDC/Core/Exp/DaCon.hs +++ b/DDC/Core/Exp/DaCon.hs @@ -7,13 +7,12 @@ , takeNameOfDaCon , takeTypeOfDaCon) where -import DDC.Type.Compounds -import DDC.Type.Exp +import DDC.Type.Exp.Simple import Control.DeepSeq -- | Data constructors. -data DaCon n +data DaCon n t -- | Baked in unit data constructor. = DaConUnit @@ -30,7 +29,7 @@ daConName :: !n -- | Type of the data constructor. - , daConType :: !(Type n) + , daConType :: !t } -- | Data constructor that has a data type declaration. @@ -41,7 +40,7 @@ deriving (Show, Eq) -instance NFData n => NFData (DaCon n) where +instance (NFData n, NFData t) => NFData (DaCon n t) where rnf !dc = case dc of DaConUnit -> () @@ -51,7 +50,7 @@ -- | Take the name of data constructor, -- if there is one. -takeNameOfDaCon :: DaCon n -> Maybe n +takeNameOfDaCon :: DaCon n t -> Maybe n takeNameOfDaCon dc = case dc of DaConUnit -> Nothing @@ -61,7 +60,7 @@ -- | Take the type annotation of a data constructor, -- if we know it locally. -takeTypeOfDaCon :: DaCon n -> Maybe (Type n) +takeTypeOfDaCon :: DaCon n (Type n) -> Maybe (Type n) takeTypeOfDaCon dc = case dc of DaConUnit -> Just $ tUnit @@ -70,6 +69,6 @@ -- | The unit data constructor. -dcUnit :: DaCon n +dcUnit :: DaCon n t dcUnit = DaConUnit 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 --- a/DDC/Core/Exp/Generic/BindStruct.hs +++ b/DDC/Core/Exp/Generic/BindStruct.hs @@ -3,8 +3,8 @@ module DDC.Core.Exp.Generic.BindStruct where import DDC.Core.Exp.Generic.Exp import DDC.Core.Exp.DaCon -import DDC.Core.Collect.Free -import DDC.Type.Collect +import DDC.Core.Collect.FreeX +import DDC.Core.Collect.BindStruct import qualified DDC.Type.Exp as T import Data.Maybe diff --git a/DDC/Core/Exp/Generic/Compounds.hs b/DDC/Core/Exp/Generic/Compounds.hs --- a/DDC/Core/Exp/Generic/Compounds.hs +++ b/DDC/Core/Exp/Generic/Compounds.hs @@ -5,7 +5,7 @@ -- For the generic version of the AST. -- module DDC.Core.Exp.Generic.Compounds - ( module DDC.Type.Compounds + ( module DDC.Type.Exp.Simple.Compounds -- * Abstractions , makeXAbs, takeXAbs @@ -24,7 +24,8 @@ where import DDC.Core.Exp.Generic.Exp import DDC.Core.Exp.DaCon -import DDC.Type.Compounds +import DDC.Type.Exp.Simple.Compounds +import DDC.Type.Exp.Simple.Exp import Data.Maybe @@ -131,7 +132,7 @@ -- | Flatten an application of a data constructor into the constructor itself -- and its arguments, or `Nothing` if this is not an application of a -- data constructor. -takeXConApps :: GExp l -> Maybe (DaCon l, [GArg l]) +takeXConApps :: GExp l -> Maybe (DaCon l (Type l), [GArg l]) takeXConApps xx = case xx of XApp (XCon c) a2 diff --git a/DDC/Core/Exp/Generic/Exp.hs b/DDC/Core/Exp/Generic/Exp.hs --- a/DDC/Core/Exp/Generic/Exp.hs +++ b/DDC/Core/Exp/Generic/Exp.hs @@ -1,12 +1,12 @@ {-# LANGUAGE TypeFamilies, UndecidableInstances #-} --- | Generic expression representation. +-- | 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 @@ -18,8 +18,8 @@ type family GPrim l ---------------------------------------------------------------------------------------------------- --- | Generic expression representation. +------------------------------------------------------------------------------- +-- | Generic term expression representation. data GExp l -- | An annotated expression. = XAnnot !(GAnnot l) !(GExp l) @@ -28,7 +28,7 @@ | XPrim !(GPrim l) -- | Data constructor. - | XCon !(DaCon l) + | XCon !(DaCon l (T.Type l)) -- | Value or Witness variable (level-0). | XVar !(GBound l) @@ -88,7 +88,8 @@ -- | Recursive binding. | LRec ![(GBind l, GExp l)] - -- | Introduce a private region variable and witnesses to its properties. + -- | Introduce a private region variable and witnesses to + -- its properties. | LPrivate ![GBind l] !(Maybe (T.Type l)) ![GBind l] @@ -103,7 +104,7 @@ = PDefault -- | Match a data constructor and bind its arguments. - | PData !(DaCon l) ![GBind l] + | PData !(DaCon l (T.Type l)) ![GBind l] -- | Type casts. @@ -145,10 +146,13 @@ = 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)) + = ( 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) diff --git a/DDC/Core/Exp/Generic/Predicates.hs b/DDC/Core/Exp/Generic/Predicates.hs --- a/DDC/Core/Exp/Generic/Predicates.hs +++ b/DDC/Core/Exp/Generic/Predicates.hs @@ -1,7 +1,7 @@ -- | Simple predicates on core expressions. module DDC.Core.Exp.Generic.Predicates - ( module DDC.Type.Predicates + ( module DDC.Type.Exp.Simple.Predicates -- * Atoms , isXVar, isXCon @@ -20,7 +20,7 @@ , isPDefault) where import DDC.Core.Exp.Generic.Exp -import DDC.Type.Predicates +import DDC.Type.Exp.Simple.Predicates -- Atoms ---------------------------------------------------------------------- diff --git a/DDC/Core/Exp/Generic/Pretty.hs b/DDC/Core/Exp/Generic/Pretty.hs --- a/DDC/Core/Exp/Generic/Pretty.hs +++ b/DDC/Core/Exp/Generic/Pretty.hs @@ -4,7 +4,9 @@ import DDC.Core.Exp.Generic.Predicates import DDC.Core.Exp.Generic.Exp import DDC.Core.Exp.DaCon -import DDC.Type.Pretty +import DDC.Type.Exp.Simple () +import DDC.Type.Exp.Simple.Exp +import DDC.Data.Pretty import Prelude hiding ((<$>)) @@ -181,11 +183,13 @@ 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))) + <+> align ( ppr b + <> nest 2 ( -- breakWhen (not $ isSimpleX x) + text "=" <+> align (pprX x))) LRec bxs -> let pprLetRecBind (b, x) @@ -243,7 +247,7 @@ -- DaCon ------------------------------------------------------------------------------------------ -instance PrettyLanguage l => Pretty (DaCon l) where +instance PrettyLanguage l => Pretty (DaCon l (Type l)) where ppr dc = case dc of DaConUnit -> text "()" 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/Simple/Compounds.hs b/DDC/Core/Exp/Simple/Compounds.hs deleted file mode 100644 --- a/DDC/Core/Exp/Simple/Compounds.hs +++ /dev/null @@ -1,288 +0,0 @@ - --- | Utilities for constructing and destructing compound expressions. --- --- For the Simple version of the AST. -module DDC.Core.Exp.Simple.Compounds - ( module DDC.Type.Compounds - - -- * Lambdas - , xLAMs - , xLams - , makeXLamFlags - , takeXLAMs - , takeXLams - , takeXLamFlags - - -- * Applications - , xApps - , takeXApps - , takeXApps1 - , takeXAppsAsList - , takeXConApps - , takeXPrimApps - - -- * Lets - , xLets - , splitXLets - , bindsOfLets - , specBindsOfLets - , valwitBindsOfLets - - -- * Patterns - , bindsOfPat - - -- * Alternatives - , takeCtorNameOfAlt - - -- * Witnesses - , wApp - , wApps - , takeXWitness - , takeWAppsAsList - , takePrimWiConApps - - -- * Types - , takeXType - - -- * Data Constructors - , xUnit, dcUnit - , takeNameOfDaCon - , takeTypeOfDaCon) -where -import DDC.Type.Exp -import DDC.Core.Exp.Simple.Exp -import DDC.Core.Exp.DaCon -import DDC.Type.Compounds - - --- Lambdas --------------------------------------------------------------------- --- | Make some nested type lambdas. -xLAMs :: [Bind n] -> Exp a n -> Exp a n -xLAMs bs x - = foldr XLAM x bs - - --- | Make some nested value or witness lambdas. -xLams :: [Bind n] -> Exp a n -> Exp a n -xLams bs x - = foldr XLam x bs - - --- | Split type lambdas from the front of an expression, --- or `Nothing` if there aren't any. -takeXLAMs :: Exp a n -> Maybe ([Bind n], Exp a n) -takeXLAMs xx - = let go bs (XLAM b x) = go (b:bs) x - go bs x = (reverse bs, x) - in case go [] xx of - ([], _) -> Nothing - (bs, body) -> Just (bs, body) - - --- | Split nested value or witness lambdas from the front of an expression, --- or `Nothing` if there aren't any. -takeXLams :: Exp a n -> Maybe ([Bind n], Exp a n) -takeXLams xx - = let go bs (XLam b x) = go (b:bs) x - go bs x = (reverse bs, x) - in case go [] xx of - ([], _) -> Nothing - (bs, body) -> Just (bs, body) - - --- | Make some nested lambda abstractions, --- using a flag to indicate whether the lambda is a --- level-1 (True), or level-0 (False) binder. -makeXLamFlags :: [(Bool, Bind n)] -> Exp a n -> Exp a n -makeXLamFlags fbs x - = foldr (\(f, b) x' - -> if f then XLAM b x' - else XLam b x') - x fbs - - --- | Split nested lambdas from the front of an expression, --- with a flag indicating whether the lambda was a level-1 (True), --- or level-0 (False) binder. -takeXLamFlags :: Exp a n -> Maybe ([(Bool, Bind n)], Exp a n) -takeXLamFlags xx - = let go bs (XLAM b x) = go ((True, b):bs) x - go bs (XLam b x) = go ((False, b):bs) x - go bs x = (reverse bs, x) - in case go [] xx of - ([], _) -> Nothing - (bs, body) -> Just (bs, body) - - --- Applications --------------------------------------------------------------- --- | Build sequence of value applications. -xApps :: Exp a n -> [Exp a n] -> Exp a n -xApps t1 ts = foldl XApp t1 ts - - --- | Flatten an application into the function part and its arguments. --- --- Returns `Nothing` if there is no outer application. -takeXApps :: Exp a n -> Maybe (Exp a n, [Exp a n]) -takeXApps xx - = case takeXAppsAsList xx of - (x1 : xsArgs) -> Just (x1, xsArgs) - _ -> Nothing - - --- | Flatten an application into the function part and its arguments. --- --- This is like `takeXApps` above, except we know there is at least one argument. -takeXApps1 :: Exp a n -> Exp a n -> (Exp a n, [Exp a n]) -takeXApps1 x1 x2 - = case takeXApps x1 of - Nothing -> (x1, [x2]) - Just (x11, x12s) -> (x11, x12s ++ [x2]) - - --- | Flatten an application into the function parts and arguments, if any. -takeXAppsAsList :: Exp a n -> [Exp a n] -takeXAppsAsList xx - = case xx of - XApp x1 x2 -> takeXAppsAsList x1 ++ [x2] - _ -> [xx] - - --- | Flatten an application of a primop into the variable --- and its arguments. --- --- Returns `Nothing` if the expression isn't a primop application. -takeXPrimApps :: Exp a n -> Maybe (n, [Exp a n]) -takeXPrimApps xx - = case takeXAppsAsList xx of - XVar (UPrim p _) : xs -> Just (p, xs) - _ -> Nothing - --- | Flatten an application of a data constructor into the constructor --- and its arguments. --- --- Returns `Nothing` if the expression isn't a constructor application. -takeXConApps :: Exp a n -> Maybe (DaCon n, [Exp a n]) -takeXConApps xx - = case takeXAppsAsList xx of - XCon dc : xs -> Just (dc, xs) - _ -> Nothing - - --- Lets ----------------------------------------------------------------------- --- | Wrap some let-bindings around an expression. -xLets :: [Lets a n] -> Exp a n -> Exp a n -xLets lts x - = foldr XLet x lts - - --- | Split let-bindings from the front of an expression, if any. -splitXLets :: Exp a n -> ([Lets a n], Exp a n) -splitXLets xx - = case xx of - XLet lts x - -> let (lts', x') = splitXLets x - in (lts : lts', x') - - _ -> ([], xx) - - --- | Take the binds of a `Lets`. --- --- The level-1 and level-0 binders are returned separately. -bindsOfLets :: Lets a n -> ([Bind n], [Bind n]) -bindsOfLets ll - = case ll of - LLet b _ -> ([], [b]) - LRec bxs -> ([], map fst bxs) - LPrivate bs _ bbs -> (bs, bbs) - - --- | Like `bindsOfLets` but only take the spec (level-1) binders. -specBindsOfLets :: Lets a n -> [Bind n] -specBindsOfLets ll - = case ll of - LLet _ _ -> [] - LRec _ -> [] - LPrivate bs _ _ -> bs - - --- | Like `bindsOfLets` but only take the value and witness (level-0) binders. -valwitBindsOfLets :: Lets a n -> [Bind n] -valwitBindsOfLets ll - = case ll of - LLet b _ -> [b] - LRec bxs -> map fst bxs - LPrivate _ _ bs -> bs - - --- Alternatives --------------------------------------------------------------- --- | Take the constructor name of an alternative, if there is one. -takeCtorNameOfAlt :: Alt a n -> Maybe n -takeCtorNameOfAlt aa - = case aa of - AAlt (PData dc _) _ -> takeNameOfDaCon dc - _ -> Nothing - - --- Patterns ------------------------------------------------------------------- --- | Take the binds of a `Pat`. -bindsOfPat :: Pat n -> [Bind n] -bindsOfPat pp - = case pp of - PDefault -> [] - PData _ bs -> bs - - --- Witnesses ------------------------------------------------------------------ --- | Construct a witness application -wApp :: Witness a n -> Witness a n -> Witness a n -wApp = WApp - - --- | Construct a sequence of witness applications -wApps :: Witness a n -> [Witness a n] -> Witness a n -wApps = foldl wApp - - --- | Take the witness from an `XWitness` argument, if any. -takeXWitness :: Exp a n -> Maybe (Witness a n) -takeXWitness xx - = case xx of - XWitness t -> Just t - _ -> Nothing - - --- | Flatten an application into the function parts and arguments, if any. -takeWAppsAsList :: Witness a n -> [Witness a n] -takeWAppsAsList ww - = case ww of - WApp w1 w2 -> takeWAppsAsList w1 ++ [w2] - _ -> [ww] - - --- | Flatten an application of a witness into the witness constructor --- name and its arguments. --- --- Returns nothing if there is no witness constructor in head position. -takePrimWiConApps :: Witness a n -> Maybe (n, [Witness a n]) -takePrimWiConApps ww - = case takeWAppsAsList ww of - WCon wc : args | WiConBound (UPrim n _) _ <- wc - -> Just (n, args) - _ -> Nothing - - --- Types ---------------------------------------------------------------------- --- | Take the type from an `XType` argument, if any. -takeXType :: Exp a n -> Maybe (Type n) -takeXType xx - = case xx of - XType t -> Just t - _ -> Nothing - - --- Units ----------------------------------------------------------------------- --- | Construct a value of unit type. -xUnit :: Exp a n -xUnit = XCon dcUnit diff --git a/DDC/Core/Exp/Simple/Exp.hs b/DDC/Core/Exp/Simple/Exp.hs deleted file mode 100644 --- a/DDC/Core/Exp/Simple/Exp.hs +++ /dev/null @@ -1,196 +0,0 @@ - --- | Core language AST with a separate node to hold annotations. --- --- This version of the AST is used when generating code where most or all --- of the annotations would be empty. General purpose transformations should --- deal with the fully annotated version of the AST instead. --- -module DDC.Core.Exp.Simple.Exp - ( module DDC.Type.Exp - - -- * Expressions - , Exp (..) - , Cast (..) - , Lets (..) - , Alt (..) - , Pat (..) - - -- * Witnesses - , Witness (..) - - -- * Data Constructors - , DaCon (..) - - -- * Witness Constructors - , WiCon (..)) -where -import DDC.Core.Exp.WiCon -import DDC.Core.Exp.DaCon -import DDC.Type.Exp -import DDC.Type.Sum () -import Control.DeepSeq - - --- Values --------------------------------------------------------------------- --- | Well-typed expressions have types of kind `Data`. -data Exp a n - -- | Annotation. - = XAnnot a (Exp a n) - - -- | Value variable or primitive operation. - | XVar !(Bound n) - - -- | Data constructor or literal. - | XCon !(DaCon n) - - -- | Type abstraction (level-1). - | XLAM !(Bind n) !(Exp a n) - - -- | Value and Witness abstraction (level-0). - | XLam !(Bind n) !(Exp a n) - - -- | Application. - | XApp !(Exp a n) !(Exp a n) - - -- | Possibly recursive bindings. - | XLet !(Lets a n) !(Exp a n) - - -- | Case branching. - | XCase !(Exp a n) ![Alt a n] - - -- | Type cast. - | XCast !(Cast a n) !(Exp a n) - - -- | Type can appear as the argument of an application. - | XType !(Type n) - - -- | Witness can appear as the argument of an application. - | XWitness !(Witness a n) - deriving (Show, Eq) - - --- | Possibly recursive bindings. -data Lets a n - -- | Non-recursive expression binding. - = LLet !(Bind n) !(Exp a n) - - -- | Recursive binding of lambda abstractions. - | LRec ![(Bind n, Exp a n)] - - -- | Bind a local region variable, - -- and witnesses to its properties. - | LPrivate ![Bind n] !(Maybe (Type n)) ![Bind n] - deriving (Show, Eq) - - --- | Case alternatives. -data Alt a n - = AAlt !(Pat n) !(Exp a n) - deriving (Show, Eq) - - --- | Pattern matching. -data Pat n - -- | The default pattern always succeeds. - = PDefault - - -- | Match a data constructor and bind its arguments. - | PData !(DaCon n) ![Bind n] - deriving (Show, Eq) - - --- | When a witness exists in the program it guarantees that a --- certain property of the program is true. -data Witness a n - = WAnnot a (Witness a n) - - -- | Witness variable. - | WVar !(Bound n) - - -- | Witness constructor. - | WCon !(WiCon n) - - -- | Witness application. - | WApp !(Witness a n) !(Witness a n) - - -- | Type can appear as the argument of an application. - | WType !(Type n) - deriving (Show, Eq) - - --- | Type casts. -data Cast a n - -- | Weaken the effect of an expression. - -- The given effect is added to the effect - -- of the body. - = CastWeakenEffect !(Effect n) - - -- | Purify the effect (action) of an expression. - | CastPurify !(Witness a n) - - -- | Box up a computation, - -- capturing its effects in the S computation type. - | CastBox - - -- | Run a computation, - -- releasing its effects into the environment. - | CastRun - deriving (Show, Eq) - - --- NFData --------------------------------------------------------------------- -instance (NFData a, NFData n) => NFData (Exp a n) where - rnf xx - = case xx of - XAnnot a x -> rnf a `seq` rnf x - XVar u -> rnf u - XCon dc -> rnf dc - XLAM b x -> rnf b `seq` rnf x - XLam b x -> rnf b `seq` rnf x - XApp x1 x2 -> rnf x1 `seq` rnf x2 - XLet lts x -> rnf lts `seq` rnf x - XCase x alts -> rnf x `seq` rnf alts - XCast c x -> rnf c `seq` rnf x - XType t -> rnf t - XWitness w -> rnf w - - -instance (NFData a, NFData n) => NFData (Cast a n) where - rnf cc - = case cc of - CastWeakenEffect e -> rnf e - CastPurify w -> rnf w - CastBox -> () - CastRun -> () - - -instance (NFData a, NFData n) => NFData (Lets a n) where - rnf lts - = case lts of - LLet b x -> rnf b `seq` rnf x - LRec bxs -> rnf bxs - LPrivate bs1 t2 bs3 -> rnf bs1 `seq` rnf t2 `seq` rnf bs3 - - -instance (NFData a, NFData n) => NFData (Alt a n) where - rnf aa - = case aa of - AAlt w x -> rnf w `seq` rnf x - - -instance NFData n => NFData (Pat n) where - rnf pp - = case pp of - PDefault -> () - PData dc bs -> rnf dc `seq` rnf bs - - -instance (NFData a, NFData n) => NFData (Witness a n) where - rnf ww - = case ww of - WAnnot a w -> rnf a `seq` rnf w - WVar u -> rnf u - WCon c -> rnf c - WApp w1 w2 -> rnf w1 `seq` rnf w2 - WType t -> rnf t - diff --git a/DDC/Core/Fragment.hs b/DDC/Core/Fragment.hs --- a/DDC/Core/Fragment.hs +++ b/DDC/Core/Fragment.hs @@ -31,7 +31,6 @@ import DDC.Core.Module import DDC.Core.Exp import DDC.Core.Lexer -import DDC.Data.Token -- | Carries all the information we need to work on a particular @@ -49,11 +48,11 @@ -- | Lex module source into tokens, -- given the source name and starting line number. - , fragmentLexModule :: String -> Int -> String -> [Token (Tok n)] + , fragmentLexModule :: String -> Int -> String -> [Located (Token n)] -- | Lex expression source into tokens, -- given the source name and starting line number. - , fragmentLexExp :: String -> Int -> String -> [Token (Tok n)] + , fragmentLexExp :: String -> Int -> String -> [Located (Token n)] -- | Perform language fragment specific checks on a module. , fragmentCheckModule :: forall a. Module a n -> Maybe (err a) diff --git a/DDC/Core/Fragment/Profile.hs b/DDC/Core/Fragment/Profile.hs --- a/DDC/Core/Fragment/Profile.hs +++ b/DDC/Core/Fragment/Profile.hs @@ -9,13 +9,13 @@ , 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 -import Data.Text (Text) -- | The fragment profile describes the language features and @@ -45,8 +45,12 @@ -- to be filled in by the type checker. , profileNameIsHole :: !(Maybe (n -> Bool)) - -- | Embed a literal string in a name. - , profileMakeStringName :: Maybe (SourcePos -> Text -> n) } + -- | 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`. @@ -69,7 +73,7 @@ , profilePrimTypes = Env.empty , profileTypeIsUnboxed = const False , profileNameIsHole = Nothing - , profileMakeStringName = Nothing } + , profileMakeLiteralName = Nothing } -- | A flattened set of features, for easy lookup. diff --git a/DDC/Core/Lexer.hs b/DDC/Core/Lexer.hs --- a/DDC/Core/Lexer.hs +++ b/DDC/Core/Lexer.hs @@ -8,22 +8,27 @@ -- module DDC.Core.Lexer ( module DDC.Core.Lexer.Tokens - , module DDC.Core.Lexer.Names + , Located (..) -- * Lexer , lexModuleWithOffside , lexExp) where +import DDC.Core.Lexer.Token.Builtin +import DDC.Core.Lexer.Token.Index +import DDC.Core.Lexer.Token.Keyword +import DDC.Core.Lexer.Token.Literal +import DDC.Core.Lexer.Token.Names +import DDC.Core.Lexer.Token.Operator +import DDC.Core.Lexer.Token.Symbol + import DDC.Core.Lexer.Offside -import DDC.Core.Lexer.Comments -import DDC.Core.Lexer.Names import DDC.Core.Lexer.Tokens import DDC.Data.SourcePos -import DDC.Data.Token -import Data.Char -import Data.Text (Text) -import qualified Data.Text as T -import Data.Monoid +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 ----------------------------------------------------------------------------------------- @@ -35,17 +40,22 @@ :: FilePath -- ^ Path to source file, for error messages. -> Int -- ^ Starting line number. -> String -- ^ String containing program text. - -> [Token (Tok String)] + -> [Located (Token String)] lexModuleWithOffside sourceName lineStart str - = {-# SCC lexWithOffside #-} - applyOffside [] [] + = applyOffside [] [] $ addStarts - $ dropComments + $ dropUnused $ lexText sourceName lineStart - $ T.pack str + $ 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. -- @@ -54,16 +64,21 @@ lexExp :: FilePath -- ^ Path to source file, for error messages. -> Int -- ^ Starting line number. -> String -- ^ String containing program text. - -> [Token (Tok String)] + -> [Located (Token String)] lexExp sourceName lineStart str - = {-# SCC lexExp #-} - dropNewLines - $ dropComments + = dropUnused $ lexText sourceName lineStart - $ T.pack str + $ 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. -- @@ -75,241 +90,103 @@ lexText :: String -- ^ Name of source file, which is attached to the tokens. -> Int -- ^ Starting line number. -> Text -- ^ Text to tokenize. - -> [Token (Tok String)] - -lexText sourceName lineStart xx - = lexWord lineStart 1 xx - where - - lexWord :: Int -> Int -> Text -> [Token (Tok String)] - lexWord line column w - = match w - where - tok t = Token t (SourcePos sourceName line column) - tokM = tok . KM - tokA = tok . KA - tokN = tok . KN - - lexMore n rest - = lexWord line (column + n) rest - - lexUpto pat rest - = case dropWhile (not . T.isPrefixOf pat) (T.tails rest) of - x : _ -> x - _ -> T.empty - - txt = T.pack - prefix str = T.stripPrefix (T.pack str) - - match cs - | T.null cs - = [] + -> [Located (Token String)] - -- Whitespace - | Just (' ', rest) <- T.uncons cs - = lexMore 1 rest +lexText filePath nStart txt + = let (toks, locEnd, strLeftover) + = System.unsafePerformIO + $ I.scanListIO + (I.Location nStart 1) + I.bumpLocationWithChar + (Text.unpack txt) + (scanner filePath) - | Just ('\t', rest) <- T.uncons cs - = lexMore 8 rest + I.Location lineEnd colEnd = locEnd + spEnd = SourcePos filePath lineEnd colEnd - -- Meta tokens - | Just rest <- T.stripPrefix (txt "{-#") cs - , (prag, rest') <- T.breakOn (txt "#-}") rest - , rest'' <- T.drop 3 rest' - , len <- 3 + T.length prag + 3 - = tokA (KPragma prag) : lexMore len rest'' + in case strLeftover of + [] -> toks + str -> toks ++ [Located spEnd (KErrorJunk (take 10 str))] - | Just rest <- T.stripPrefix (txt "{-") cs - = tokM KCommentBlockStart : lexMore 2 (lexUpto (txt "-}") rest) - - | Just rest <- T.stripPrefix (txt "-}") cs - = tokM KCommentBlockEnd : lexMore 2 rest - - | Just cs1 <- T.stripPrefix (txt "--") cs - , (_junk, rest) <- T.span (/= '\n') cs1 - = tokM KCommentLineStart : lexMore 2 rest - - | Just ('\n', rest) <- T.uncons cs - = tokM KNewLine : lexWord (line + 1) 1 rest - - -- Double character symbols. - | not (T.compareLength cs 2 == LT) - , (cs1, rest) <- T.splitAt 2 cs - , Just t - <- case T.unpack cs1 of - "[:" -> Just KSquareColonBra - ":]" -> Just KSquareColonKet - "{:" -> Just KBraceColonBra - ":}" -> Just KBraceColonKet - "~>" -> Just KArrowTilde - "->" -> Just KArrowDash - "<-" -> Just KArrowDashLeft - "=>" -> Just KArrowEquals - "/\\" -> Just KBigLambdaSlash - "()" -> Just KDaConUnit - _ -> Nothing - = tokA t : lexMore 2 rest +-- | Scanner for core tokens tokens. +type Scanner a + = I.Scanner IO I.Location [Char] a - -- Wrapped operator symbols. - -- This needs to come before lexing single character symbols. - | Just ('(', cs1) <- T.uncons cs - , Just (c, cs2) <- T.uncons cs1 - , isOpStart c - , (body, cs3) <- T.span isOpBody cs2 - , Just (')', rest) <- T.uncons cs3 - = tokA (KOpVar (T.unpack (T.cons c body))) - : lexMore (2 + T.length (T.cons c body)) rest - - -- Literal numeric values - -- This needs to come before the rule for '-' - | Just (c, cs1) <- T.uncons cs - , isDigit c - , (body, rest) <- T.span isLitBody cs1 - = let str = T.unpack (T.cons c body) - in tokN (KLit str) : lexMore (length str) rest - - | Just ('-', cs1) <- T.uncons cs - , Just (c, _) <- T.uncons cs1 - , isDigit c - = let (body, rest) = T.span isLitBody cs1 - str = T.unpack (T.cons '-' body) - in tokN (KLit str) : lexMore (length str) rest - - -- Literal strings. - -- We force these to be null terminated so the representation is compatable - -- with C string functions. - | Just ('\"', cc) <- T.uncons cs - = let - eat n acc xs - | Just ('\\', xs1) <- T.uncons xs - , Just ('"', xs2) <- T.uncons xs1 - = eat (n + 2) ('"' : acc) xs2 - - | Just ('\\', xs1) <- T.uncons xs - , Just ('n', xs2) <- T.uncons xs1 - = eat (n + 2) ('\n' : acc) xs2 - - | Just ('"', xs1) <- T.uncons xs - = tokA (KString (T.pack (reverse acc))) - : lexWord line (column + n) xs1 - - | Just (c, xs1) <- T.uncons xs - = eat (n + 1) (c : acc) xs1 - - | otherwise - = [tok $ KErrorUnterm (T.unpack cs)] - - in eat 0 [] cc - - -- Operator symbols. - | Just (c, cs1) <- T.uncons cs - , isOpStart c - , (body, rest) <- T.span isOpBody cs1 - , sym <- T.cons c body - , sym /= T.pack "=" - , sym /= T.pack "|" - = tokA (KOp (T.unpack sym)) : lexMore (1 + T.length body) rest - - -- Single character symbols. - | Just (c, rest) <- T.uncons cs - , Just t - <- case c of - '(' -> Just KRoundBra - ')' -> Just KRoundKet - '[' -> Just KSquareBra - ']' -> Just KSquareKet - '{' -> Just KBraceBra - '}' -> Just KBraceKet - '.' -> Just KDot - ',' -> Just KComma - ';' -> Just KSemiColon - '\\' -> Just KBackSlash - '=' -> Just KEquals - '|' -> Just KBar - _ -> Nothing - = tokA t : lexMore 1 rest - - -- Debruijn indices - | Just ('^', cs1) <- T.uncons cs - , (ds, rest) <- T.span isDigit cs1 - , T.length ds >= 1 - = tokA (KIndex (read (T.unpack ds))) : lexMore (1 + T.length ds) rest - - -- Operator body symbols. - | Just ('^', rest) <- T.uncons cs - = tokA KHat : lexMore 1 rest - - -- Lambdas - | Just ('λ', rest) <- T.uncons cs - = tokA KLambda : lexMore 1 rest - - | Just ('Λ', rest) <- T.uncons cs - = tokA KBigLambda : lexMore 1 rest +------------------------------------------------------------------------------- +-- | Scanner for source and core files. +-- +-- The lexical structure for source and core is a bit different, +-- but close enough that there's no point writing a separate lexer yet. +-- +scanner :: FilePath + -> Scanner (Located (Token String)) +scanner fileName + = let + stamp :: (I.Location, a) -> Located a + stamp (I.Location line col, token) + = Located (SourcePos fileName line col) token + {-# INLINE stamp #-} - -- Bottoms - | Just rest <- prefix "Pure" cs - = tokA KBotEffect : lexMore 4 rest + stamp' :: (a -> b) + -> (I.Location, a) -> Located b + stamp' k (I.Location line col, token) + = Located (SourcePos fileName line col) (k token) + {-# INLINE stamp' #-} - | Just rest <- prefix "Empty" cs - = tokA KBotClosure : lexMore 5 rest + in I.skip (\c -> c == ' ' || c == '\t') + $ I.alts + [ -- Newlines are scanned to their own tokens because + -- the transform that manages the offside rule uses them. + fmap stamp + $ I.from (\c -> case c of + '\n' -> return $ KM KNewLine + _ -> Nothing) - -- Named Constructors - | Just (c, cs1) <- T.uncons cs - , isConStart c - , (body, rest) <- T.span isConBody cs1 - , (body', rest') <- case T.uncons rest of - Just ('\'', rest') -> (body <> T.pack "'", rest') - Just ('#', rest') -> (body <> T.pack "#", rest') - _ -> (body, rest) - = let readNamedCon s - | Just socon <- readSoConBuiltin s - = tokA (KSoConBuiltin socon) : lexMore (length s) rest' + -- Scan comments into their own tokens, + -- these then get dropped by the dropComments function. + , fmap (stamp' (KM . KComment)) $ I.scanHaskellCommentLine + , fmap (stamp' (KM . KComment)) $ I.scanHaskellCommentBlock - | Just kicon <- readKiConBuiltin s - = tokA (KKiConBuiltin kicon) : lexMore (length s) rest' + -- deBruijn indices. + -- Needs to come before scanSymbol as '^' is also an operator. + , fmap (stamp' (KA . KIndex)) $ scanIndex - | Just twcon <- readTwConBuiltin s - = tokA (KTwConBuiltin twcon) : lexMore (length s) rest' - - | Just tccon <- readTcConBuiltin s - = tokA (KTcConBuiltin tccon) : lexMore (length s) rest' - - | Just con <- readCon s - = tokN (KCon con) : lexMore (length s) rest' - - | otherwise - = [tok (KErrorJunk [c])] - - in readNamedCon (T.unpack (T.cons c body')) + -- Literal values. + , fmap (stamp' (\(l, b) -> KA (KLiteral l b))) + $ scanLiteral - -- Keywords, Named Variables and Witness constructors - | Just (c, cs1) <- T.uncons cs - , isVarStart c - , (body, rest) <- T.span isVarBody cs1 - , (body', rest') <- case T.uncons rest of - Just ('#', rest') -> (body <> T.pack "#", rest') - _ -> (body, rest) - = let readNamedVar s - | "_" <- s - = tokA KUnderscore : lexMore (length s) rest' + -- Infix operators. + -- Needs to come before scanSymbol because operators + -- like "==" are parsed atomically rather than as + -- two separate '=' symbols. + , fmap (stamp' (KA . KOp)) $ scanInfixOperator - | Just t <- lookup s keywords - = tok t : lexMore (length s) rest' - - | Just v <- readVar s - = tokN (KVar v) : lexMore (length s) rest' + -- Prefix operators. + , fmap (stamp' (KA . KOpVar)) $ scanPrefixOperator - | otherwise - = [tok (KErrorJunk [c])] + -- The unit value. + -- Needs to come before scanSymbol because the "()" + -- lexeme is parsed atomically rather than as + -- separate '(' and ')' symbols. + , fmap stamp + $ I.froms (Just 2) + (\ss -> if ss == "()" + then Just (KA $ KBuiltin $ BDaConUnit) + else Nothing) - in readNamedVar (T.unpack (T.cons c body')) + -- Symbolic tokens like punctuation. + , fmap (stamp' (KA . KSymbol)) $ scanSymbol - -- Some unrecognised character. - | otherwise - = case T.unpack cs of - (c : _) -> [tok $ KErrorJunk [c]] - _ -> [tok $ KErrorJunk []] + -- Named things. + -- Keywords have the same lexical structure as variables as + -- they all start with a lower-case letter. We need to check + -- for keywords before accepting a variable. + , fmap (stamp' (KA . KBuiltin)) $ scanBuiltin + , fmap (stamp' (KA . KKeyword)) $ scanKeyword + , fmap (stamp' (KN . KCon)) $ scanConName + , fmap (stamp' (KN . KVar)) $ scanVarName + ] diff --git a/DDC/Core/Lexer/Comments.hs b/DDC/Core/Lexer/Comments.hs deleted file mode 100644 --- a/DDC/Core/Lexer/Comments.hs +++ /dev/null @@ -1,64 +0,0 @@ - -module DDC.Core.Lexer.Comments - ( dropComments - , dropNewLines) -where -import DDC.Core.Lexer.Tokens -import DDC.Data.Token -import DDC.Data.SourcePos - - --- | Drop all the comments and newline tokens in this stream. -dropComments - :: Eq n => [Token (Tok n)] -> [Token (Tok n)] - -dropComments [] = [] -dropComments (t@(Token tok sourcePos) : xs) - = case tok of - KM KCommentLineStart - -> dropComments $ dropWhile (\t' -> not $ isToken t' (KM KNewLine)) xs - - KM KCommentBlockStart - -> dropComments $ dropCommentBlock sourcePos xs t - - _ -> t : dropComments xs - - --- | Drop block comments form a token stream. -dropCommentBlock - :: Eq n - => SourcePos -- ^ Position of outer-most block comment start. - -> [Token (Tok n)] - -> Token (Tok n) - -> [Token (Tok n)] - -dropCommentBlock spStart [] _terr - = [Token (KM KCommentUnterminated) spStart] - -dropCommentBlock spStart (t@(Token tok _) : xs) terr - = case tok of - -- enter into nested block comments. - KM KCommentBlockStart - -> dropCommentBlock spStart (dropCommentBlock spStart xs t) terr - - -- outer-most block comment has ended. - KM KCommentBlockEnd - -> xs - - _ -> dropCommentBlock spStart xs terr - - --- | Drop newline tokens from this list. -dropNewLines :: Eq n => [Token (Tok n)] -> [Token (Tok n)] -dropNewLines [] = [] -dropNewLines (t:ts) - | isToken t (KM KNewLine) - = dropNewLines ts - - | otherwise - = t : dropNewLines ts - - -isToken :: Eq n => Token (Tok n) -> Tok n -> Bool -isToken (Token tok _) tok2 = tok == tok2 - diff --git a/DDC/Core/Lexer/Names.hs b/DDC/Core/Lexer/Names.hs deleted file mode 100644 --- a/DDC/Core/Lexer/Names.hs +++ /dev/null @@ -1,297 +0,0 @@ - -module DDC.Core.Lexer.Names - ( -- * Keywords - keywords - - -- * Builtin constructors - , readSoConBuiltin - , readKiConBuiltin - , readTwConBuiltin - , readTcConBuiltin - - -- * Variable names - , isVarName - , isVarStart - , isVarBody - , readVar - - -- * Constructor names - , isConName - , isConStart - , isConBody - , readCon - - -- * Operator names - , isOpName - , isOpStart - , isOpBody - - -- * Literal names - , isLitName - , isLitStart - , isLitBody) -where -import DDC.Core.Exp -import DDC.Core.Lexer.Tokens -import DDC.Core.Lexer.Unicode -import DDC.Data.ListUtils -import Data.Char -import Data.List -import qualified Data.Set as Set - - ---------------------------------------------------------------------------------------------------- --- | Textual keywords in the core language. -keywords :: [(String, Tok n)] -keywords - = [ ("module", KA KModule) - , ("import", KA KImport) - , ("export", KA KExport) - , ("foreign", KA KForeign) - , ("type", KA KType) - , ("value", KA KValue) - , ("capability", KA KCapability) - , ("data", KA KData) - , ("in", KA KIn) - , ("of", KA KOf) - , ("letrec", KA KLetRec) - , ("letcase", KA KLetCase) - , ("private", KA KPrivate) - , ("extend", KA KExtend) - , ("using", KA KUsing) - , ("withregion", KA KWithRegion) - , ("let", KA KLet) - , ("case", KA KCase) - , ("purify", KA KPurify) - , ("box", KA KBox) - , ("run", KA KRun) - , ("weakeff", KA KWeakEff) - , ("with", KA KWith) - , ("where", KA KWhere) - , ("do", KA KDo) - , ("match", KA KMatch) - , ("if", KA KIf) - , ("then", KA KThen) - , ("else", KA KElse) - , ("otherwise", KA KOtherwise) ] - - --- | Read a named sort constructor. -readSoConBuiltin :: String -> Maybe SoCon -readSoConBuiltin ss - = case ss of - "Prop" -> Just SoConProp - "Comp" -> Just SoConComp - _ -> Nothing - - --- | Read a named kind constructor. -readKiConBuiltin :: String -> Maybe KiCon -readKiConBuiltin ss - = case ss of - "Witness" -> Just KiConWitness - "Data" -> Just KiConData - "Region" -> Just KiConRegion - "Effect" -> Just KiConEffect - "Closure" -> Just KiConClosure - _ -> Nothing - - --- | Read a named witness type constructor. -readTwConBuiltin :: String -> Maybe TwCon -readTwConBuiltin ss - = case ss of - "Const" -> Just TwConConst - "DeepConst" -> Just TwConDeepConst - "Mutable" -> Just TwConMutable - "DeepMutable" -> Just TwConDeepMutable - "Purify" -> Just TwConPure - "Disjoint" -> Just TwConDisjoint - "Distinct" -> Just (TwConDistinct 2) - _ -> readTwConWithArity ss - - -readTwConWithArity :: String -> Maybe TwCon -readTwConWithArity ss - | Just n <- stripPrefix "Distinct" ss - , all isDigit n - - = Just (TwConDistinct $ read n) - | otherwise = Nothing - - --- | Read a builtin type constructor with a non-symbolic name. --- ie not '->'. -readTcConBuiltin :: String -> Maybe TcCon -readTcConBuiltin ss - = case ss of - "Unit" -> Just TcConUnit - "S" -> Just TcConSusp - "Read" -> Just TcConRead - "HeadRead" -> Just TcConHeadRead - "DeepRead" -> Just TcConDeepRead - "Write" -> Just TcConWrite - "DeepWrite" -> Just TcConDeepWrite - "Alloc" -> Just TcConAlloc - "DeepAlloc" -> Just TcConDeepAlloc - _ -> Nothing - - - --- Variable names --------------------------------------------------------------------------------- --- | String is a variable name -isVarName :: String -> Bool -isVarName str - = case str of - [] -> False - c : cs - | isVarStart c - , and (map isVarBody cs) - -> True - - | _ : _ <- cs - , Just initCs <- takeInit cs - , isVarStart c - , and (map isVarBody initCs) - , last cs == '#' - -> True - - | otherwise - -> False - - --- | Charater can start a variable name. -isVarStart :: Char -> Bool -isVarStart c - = isLower c - || c == '?' - || c == '_' - - --- | Character can be part of a variable body. -isVarBody :: Char -> Bool -isVarBody c - = isUpper c - || isLower c - || isDigit c - || c == '_' - || c == '\'' - || c == '$' - - --- | Read a named, user defined variable. -readVar :: String -> Maybe String -readVar ss - | isVarName ss = Just ss - | otherwise = Nothing - - --- Constructor names ------------------------------------------------------------------------------ --- | String is a constructor name. -isConName :: String -> Bool -isConName str - = case str of - [] -> False - c : cs - | isConStart c - , and (map isConBody cs) - -> True - - | _ : _ <- cs - , Just initCs <- takeInit cs - , isConStart c - , and (map isConBody initCs) - , last cs == '#' - -> True - - | otherwise - -> False - --- | Character can start a constructor name. -isConStart :: Char -> Bool -isConStart = isUpper - - --- | Charater can be part of a constructor body. -isConBody :: Char -> Bool -isConBody c - = isUpper c - || isLower c - || isDigit c - || c == '_' - - --- | Read a named, user defined `TcCon`. -readCon :: String -> Maybe String -readCon ss - | isConName ss = Just ss - | otherwise = Nothing - - --- Operator names --------------------------------------------------------------------------------- --- | String is the name of some operator. -isOpName :: String -> Bool -isOpName str - = case str of - [] -> False - c : cs - | isOpStart c - , and (map isOpBody cs) - -> True - - | otherwise - -> False - - --- | Character can start an operator. -isOpStart :: Char -> Bool -isOpStart c - = c == '~' || c == '!' || c == '@' || c == '#' - || c == '$' || c == '%' || c == '&' - || c == '*' || c == '-' || c == '+' || c == '=' - || c == ':' || c == '/' || c == '|' - || c == '<' || c == '>' - || 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 == '<' || c == '>' - || Set.member c unicodeOperatorsInfix - - --- Literal names ---------------------------------------------------------------------------------- --- | String is the name of a literal. -isLitName :: String -> Bool -isLitName str - = case str of - [] -> False - c : cs - | isLitStart c - , and (map isLitBody cs) - -> True - - | otherwise - -> False - --- | Character can start a literal. -isLitStart :: Char -> Bool -isLitStart c - = isDigit c - || c == '-' - --- | Character can be part of a literal body. -isLitBody :: Char -> Bool -isLitBody c - = isDigit c - || c == 'b' || c == 'o' || c == 'x' - || c == 'w' || c == 'f' || c == 'i' || c == 's' - || c == '.' - || c == '#' - || c == '\'' - diff --git a/DDC/Core/Lexer/Offside.hs b/DDC/Core/Lexer/Offside.hs --- a/DDC/Core/Lexer/Offside.hs +++ b/DDC/Core/Lexer/Offside.hs @@ -7,13 +7,12 @@ where import DDC.Core.Lexer.Tokens import DDC.Data.SourcePos -import DDC.Data.Token --------------------------------------------------------------------------------------------------- -- | Holds a real token or start symbol which is used to apply the offside rule. data Lexeme n - = LexemeToken (Token (Tok n)) + = LexemeToken (Located (Token n)) | LexemeStartLine Int -- | Signal that we're starting a block in this column. @@ -31,6 +30,7 @@ type Context = Int + -- | Apply the offside rule to this token stream. -- -- It should have been processed with addStarts first to add the @@ -45,15 +45,16 @@ => [Paren] -- ^ What parenthesis we're inside. -> [Context] -- ^ Current layout context. -> [Lexeme n] -- ^ Input lexemes. - -> [Token (Tok n)] + -> [Located (Token n)] -- Wait for the module header before we start applying the real offside rule. -- This allows us to write 'module Name with letrec' all on the same line. applyOffside ps [] (LexemeToken t : ts) - | isToken t (KA KModule) + | isKeyword t EModule || isKNToken t = t : applyOffside ps [] ts + -- Enter into a top-level block in the module, and start applying the -- offside rule within it. -- The blocks are introduced by: @@ -64,30 +65,26 @@ applyOffside ps [] ls | LexemeToken t1 : (LexemeStartBlock n) : ls' <- ls - , isToken t1 (KA KExport) - || isToken t1 (KA KImport) - || isToken t1 (KA KLetRec) - || isToken t1 (KA KWhere) - = t1 : newCBra ls' - : applyOffside (ParenBrace : ps) [n] ls' + , isKeyword t1 EExport + || isKeyword t1 EImport + || isKeyword t1 ELetRec + || isKeyword t1 EWhere + = t1 : newCBra ls' : applyOffside (ParenBrace : ps) [n] ls' -- (import | export) (type | value) { ... } | LexemeToken t1 : LexemeToken t2 : LexemeStartBlock n : ls' <- ls - , isToken t1 (KA KImport) || isToken t1 (KA KExport) - , isToken t2 (KA KType) || isToken t2 (KA KValue) - = t1 : t2 : newCBra ls' - : applyOffside (ParenBrace : ps) [n] ls' + , isKeyword t1 EImport || isKeyword t1 EExport + , isKeyword t2 EType || isKeyword t2 EValue + = t1 : t2 : newCBra ls' : applyOffside (ParenBrace : ps) [n] ls' -- (import | export) foreign X (type | capability | value) { ... } | LexemeToken t1 : LexemeToken t2 : LexemeToken t3 : LexemeToken t4 : LexemeStartBlock n : ls' <- ls - , isToken t1 (KA KImport) || isToken t1 (KA KExport) - , isToken t2 (KA KForeign) - , isToken t4 (KA KType) || isToken t4 (KA KCapability) || isToken t4 (KA KValue) - = t1 : t2 : t3 : t4 : newCBra ls' - : applyOffside (ParenBrace : ps) [n] ls' - + , isKeyword t1 EImport || isKeyword t1 EExport + , isKeyword t2 EForeign + , isKeyword t4 EType || isKeyword t4 ECapability || isKeyword t4 EValue + = t1 : t2 : t3 : t4 : newCBra ls' : applyOffside (ParenBrace : ps) [n] ls' -- At top level without a context. -- Skip over everything until we get the 'with' in 'module Name with ...'' @@ -152,12 +149,12 @@ -- push context for explicit open brace applyOffside ps ms - (LexemeToken t@Token { tokenTok = KA KBraceBra } : ts) + (LexemeToken t@(Located _ (KA (KSymbol SBraceBra))) : ts) = t : applyOffside (ParenBrace : ps) (0 : ms) ts -- pop context from explicit close brace applyOffside ps mm - (LexemeToken t@Token { tokenTok = KA KBraceKet } : ts) + (LexemeToken t@(Located _ (KA (KSymbol SBraceKet))) : ts) -- make sure that explict open braces match explicit close braces | 0 : ms <- mm @@ -171,19 +168,19 @@ -- push context for explict open paren. applyOffside ps ms - (LexemeToken t@Token { tokenTok = KA KRoundBra } : ts) + ( LexemeToken t@(Located _ (KA (KSymbol SRoundBra))) : ts) = t : applyOffside (ParenRound : ps) ms ts -- force close of block on close paren. -- This partially handles the crazy (Note 5) rule from the Haskell98 standard. applyOffside (ParenBrace : ps) (m : ms) - (lt@(LexemeToken Token { tokenTok = KA KRoundKet }) : ts) + (lt@(LexemeToken (Located _ (KA (KSymbol SRoundKet)))) : ts) | m /= 0 = newCKet ts : applyOffside ps ms (lt : ts) -- pop context for explicit close paren. applyOffside (ParenRound : ps) ms - (LexemeToken t@Token { tokenTok = KA KRoundKet } : ts) + ( LexemeToken t@(Located _ (KA (KSymbol SRoundKet))) : ts) = t : applyOffside ps ms ts -- pass over tokens. @@ -197,20 +194,27 @@ = newCKet [] : applyOffside ps ms [] +isKeyword (Located _ tok) k + = case tok of + KA (KKeyword k') -> k == k' + _ -> False + + + -- addStarts -------------------------------------------------------------------------------------- -- | Add block and line start tokens to this stream. -- -- This is identical to the definition in the Haskell98 report, -- except that we also use multi-token starting strings like -- 'imports' 'foreign' 'type'. -addStarts :: (Eq n, Show n) => [Token (Tok n)] -> [Lexeme n] +addStarts :: (Eq n, Show n) => [Located (Token n)] -> [Lexeme n] addStarts ts = case dropNewLines ts of -- If the first lexeme of a module is not '{' then start a new block. (t1 : tsRest) - | not $ or $ map (isToken t1) [KA KBraceBra] - -> LexemeStartBlock (tokenColumn t1) : addStarts' (t1 : tsRest) + | not $ or $ map (isToken t1) [KA (KSymbol SBraceBra)] + -> LexemeStartBlock (columnOfLocated t1) : addStarts' (t1 : tsRest) | otherwise -> addStarts' (t1 : tsRest) @@ -219,7 +223,7 @@ [] -> [] -addStarts' :: Eq n => [Token (Tok n)] -> [Lexeme n] +addStarts' :: Eq n => [Located (Token n)] -> [Lexeme n] addStarts' ts -- Block started at end of input. | Just (ts1, ts2) <- splitBlockStart ts @@ -232,27 +236,27 @@ -- insert a new one. | Just (ts1, ts2) <- splitBlockStart ts , t2 : tsRest <- dropNewLines ts2 - , not $ isToken t2 (KA KBraceBra) + , not $ isToken t2 (KA (KSymbol SBraceBra)) = [LexemeToken t | t <- ts1] - ++ [LexemeStartBlock (tokenColumn t2)] + ++ [LexemeStartBlock (columnOfLocated t2)] ++ addStarts' (t2 : tsRest) -- check for start of list | t1 : ts' <- ts - , isToken t1 (KA KBraceBra) + , isToken t1 (KA (KSymbol SBraceBra)) = LexemeToken t1 : addStarts' ts' -- check for end of list | t1 : ts' <- ts - , isToken t1 (KA KBraceKet) + , isToken t1 (KA (KSymbol SBraceKet)) = LexemeToken t1 : addStarts' ts' -- check for start of new line | t1 : ts' <- ts , isToken t1 (KM KNewLine) , t2 : tsRest <- dropNewLines ts' - , not $ isToken t2 (KA KBraceBra) - = LexemeStartLine (tokenColumn t2) + , not $ isToken t2 (KA (KSymbol SBraceBra)) + = LexemeStartLine (columnOfLocated t2) : addStarts' (t2 : tsRest) -- eat up trailine newlines @@ -270,7 +274,7 @@ -- | Drop newline tokens at the front of this stream. -dropNewLines :: Eq n => [Token (Tok n)] -> [Token (Tok n)] +dropNewLines :: Eq n => [Located (Token n)] -> [Located (Token n)] dropNewLines [] = [] dropNewLines (t1:ts) | isToken t1 (KM KNewLine) @@ -295,58 +299,80 @@ -- | Check if a token is one that starts a block of statements. splitBlockStart - :: [Token (Tok n)] - -> Maybe ([Token (Tok n)], [Token (Tok n)]) + :: [Located (Token n)] + -> Maybe ([Located (Token n)], [Located (Token n)]) splitBlockStart toks -- export type - | t1@Token { tokenTok = KA KExport } : t2@Token { tokenTok = KA KType } : ts + | t1@(Located _ (KA (KKeyword EExport))) + : t2@(Located _ (KA (KKeyword EType))) + : ts <- toks = Just ([t1, t2], ts) -- export value - | t1@Token { tokenTok = KA KExport } : t2@Token { tokenTok = KA KValue } : ts + | t1@(Located _ (KA (KKeyword EExport))) + : t2@(Located _ (KA (KKeyword EValue))) + : ts <- toks = Just ([t1, t2], ts) -- export foreign X value - | t1@Token { tokenTok = KA KExport } : t2@Token { tokenTok = KA KForeign } - : t3 : t4@Token { tokenTok = KA KValue } : ts + | t1@(Located _ (KA (KKeyword EExport))) + : t2@(Located _ (KA (KKeyword EForeign))) + : t3 + : t4@(Located _ (KA (KKeyword EValue))) + : ts <- toks = Just ([t1, t2, t3, t4], ts) -- import type - | t1@Token { tokenTok = KA KImport } : t2@Token { tokenTok = KA KType } : ts + | t1@(Located _ (KA (KKeyword EImport))) + : t2@(Located _ (KA (KKeyword EType))) + : ts <- toks = Just ([t1, t2], ts) -- import value - | t1@Token { tokenTok = KA KImport } : t2@Token { tokenTok = KA KValue } : ts + | t1@(Located _ (KA (KKeyword EImport))) + : t2@(Located _ (KA (KKeyword EValue))) + : ts <- toks = Just ([t1, t2], ts) -- import data - | t1@Token { tokenTok = KA KImport } : t2@Token { tokenTok = KA KData } : ts + | t1@(Located _ (KA (KKeyword EImport))) + : t2@(Located _ (KA (KKeyword EData))) + : ts <- toks = Just ([t1, t2], ts) -- import foreign X type - | t1@Token { tokenTok = KA KImport } : t2@Token { tokenTok = KA KForeign } - : t3 : t4@Token { tokenTok = KA KType } : ts + | t1@(Located _ (KA (KKeyword EImport))) + : t2@(Located _ (KA (KKeyword EForeign))) + : t3 + : t4@(Located _ (KA (KKeyword EType))) + : ts <- toks = Just ([t1, t2, t3, t4], ts) -- import foreign X capability - | t1@Token { tokenTok = KA KImport } : t2@Token { tokenTok = KA KForeign } - : t3 : t4@Token { tokenTok = KA KCapability } : ts + | t1@(Located _ (KA (KKeyword EImport))) + : t2@(Located _ (KA (KKeyword EForeign))) + : t3 + : t4@(Located _ (KA (KKeyword ECapability))) + : ts <- toks = Just ([t1, t2, t3, t4], ts) -- import foreign X value - | t1@Token { tokenTok = KA KImport} : t2@Token { tokenTok = KA KForeign} - : t3 : t4@Token { tokenTok = KA KValue } : ts + | t1@(Located _ (KA (KKeyword EImport))) + : t2@(Located _ (KA (KKeyword EForeign))) + : t3 + : t4@(Located _ (KA (KKeyword EValue))) + : ts <- toks = Just ([t1, t2, t3, t4], ts) - | t1@Token { tokenTok = KA KDo } : ts <- toks = Just ([t1], ts) - | t1@Token { tokenTok = KA KOf } : ts <- toks = Just ([t1], ts) - | t1@Token { tokenTok = KA KLetRec } : ts <- toks = Just ([t1], ts) - | t1@Token { tokenTok = KA KWhere } : ts <- toks = Just ([t1], ts) - | t1@Token { tokenTok = KA KExport } : ts <- toks = Just ([t1], ts) - | t1@Token { tokenTok = KA KImport } : ts <- toks = Just ([t1], ts) - | t1@Token { tokenTok = KA KMatch } : ts <- toks = Just ([t1], ts) + | t1@(Located _ (KA (KKeyword EDo))) : ts <- toks = Just ([t1], ts) + | t1@(Located _ (KA (KKeyword EOf))) : ts <- toks = Just ([t1], ts) + | t1@(Located _ (KA (KKeyword ELetRec))) : ts <- toks = Just ([t1], ts) + | t1@(Located _ (KA (KKeyword EWhere))) : ts <- toks = Just ([t1], ts) + | t1@(Located _ (KA (KKeyword EExport))) : ts <- toks = Just ([t1], ts) + | t1@(Located _ (KA (KKeyword EImport))) : ts <- toks = Just ([t1], ts) + | t1@(Located _ (KA (KKeyword EMatch))) : ts <- toks = Just ([t1], ts) | otherwise = Nothing @@ -354,47 +380,52 @@ -- Utils ------------------------------------------------------------------------------------------ -- | Test whether this wrapper token matches. -isToken :: Eq n => Token (Tok n) -> Tok n -> Bool -isToken (Token tok _) tok2 = tok == tok2 +isToken :: Eq n => Located (Token n) -> Token n -> Bool +isToken (Located _ tok) tok2 + = tok == tok2 -- | Test whether this wrapper token matches. -isKNToken :: Eq n => Token (Tok n) -> Bool -isKNToken (Token (KN _) _) = True +isKNToken :: Eq n => Located (Token n) -> Bool +isKNToken (Located _ (KN _)) = True isKNToken _ = False -- | When generating new source tokens, take the position from the first -- non-newline token in this list -newCBra :: [Lexeme n] -> Token (Tok n) +newCBra :: [Lexeme n] -> Located (Token n) newCBra ts - = (takeTok ts) { tokenTok = KA KBraceBra } + = case takeTok ts of + Located sp _ -> Located sp (KA (KSymbol SBraceBra)) -newCKet :: [Lexeme n] -> Token (Tok n) +newCKet :: [Lexeme n] -> Located (Token n) newCKet ts - = (takeTok ts) { tokenTok = KA KBraceKet } + = case takeTok ts of + Located sp _ -> Located sp (KA (KSymbol SBraceKet)) -newSemiColon :: [Lexeme n] -> Token (Tok n) -newSemiColon ts - = (takeTok ts) { tokenTok = KA KSemiColon } +newSemiColon :: [Lexeme n] -> Located (Token n) +newSemiColon ts + = case takeTok ts of + Located sp _ -> Located sp (KA (KSymbol SSemiColon)) -- | This is injected by `applyOffside` when it finds an explit close -- brace in a position where it would close a synthetic one. -newOffsideClosingBrace :: [Lexeme n] -> Token (Tok n) +newOffsideClosingBrace :: [Lexeme n] -> Located (Token n) newOffsideClosingBrace ts - = (takeTok ts) { tokenTok = KM KOffsideClosingBrace } + = case takeTok ts of + Located sp _ -> Located sp (KM KOffsideClosingBrace) -takeTok :: [Lexeme n] -> Token (Tok n) +takeTok :: [Lexeme n] -> Located (Token n) takeTok [] - = Token (KErrorJunk "") (SourcePos "" 0 0) + = Located (SourcePos "" 0 0) (KErrorJunk "") takeTok (l : ls) = case l of - LexemeToken (Token { tokenTok = KM KNewLine }) + LexemeToken (Located _ (KM KNewLine)) -> takeTok ls LexemeToken t -> t diff --git a/DDC/Core/Lexer/Token/Builtin.hs b/DDC/Core/Lexer/Token/Builtin.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Token/Builtin.hs @@ -0,0 +1,111 @@ + +module DDC.Core.Lexer.Token.Builtin + ( Builtin (..) + , sayBuiltin + , scanBuiltin + , acceptBuiltin) +where +import DDC.Core.Lexer.Token.Names +import DDC.Core.Exp +import DDC.Data.Pretty +import Text.Lexer.Inchworm.Char +import qualified Data.List as List +import qualified Data.Char as Char + + +------------------------------------------------------------------------------- +-- | Builtin name tokens. +data Builtin + = BSoCon SoCon + | BKiCon KiCon + | BTwCon TwCon + | BTcCon TcCon + + | BPure + | BEmpty + + | BDaConUnit + deriving (Eq, Show) + + +------------------------------------------------------------------------------- +-- | Yield the string name of a Builtin. +sayBuiltin :: Builtin -> String +sayBuiltin bb + = case bb of + BSoCon sc -> renderPlain $ ppr sc + BKiCon ki -> renderPlain $ ppr ki + BTwCon kw -> renderPlain $ ppr kw + BTcCon tc -> renderPlain $ ppr tc + BPure -> "Pure" + BEmpty -> "Empty" + BDaConUnit -> "()" + + +------------------------------------------------------------------------------- +-- | Scanner for builtin names. +scanBuiltin :: Scanner IO Location [Char] (Location, Builtin) +scanBuiltin + = munchPred Nothing matchConName acceptBuiltin + + +-- | Accept a builtin name. +acceptBuiltin :: String -> Maybe Builtin +acceptBuiltin str + | Just cc <- acceptTwConWithArity str + = Just (BTwCon cc) + +acceptBuiltin str + = case str of + -- Sort constructors. + "Prop" -> Just (BSoCon SoConProp) + "Comp" -> Just (BSoCon SoConComp) + + -- Kind constructors. + "Witness" -> Just (BKiCon KiConWitness) + "Data" -> Just (BKiCon KiConData) + "Region" -> Just (BKiCon KiConRegion) + "Effect" -> Just (BKiCon KiConEffect) + "Closure" -> Just (BKiCon KiConClosure) + + -- Witness type constructors. + "Const" -> Just (BTwCon TwConConst) + "DeepConst" -> Just (BTwCon TwConDeepConst) + "Mutable" -> Just (BTwCon TwConMutable) + "DeepMutable" -> Just (BTwCon TwConDeepMutable) + "Purify" -> Just (BTwCon TwConPure) + "Disjoint" -> Just (BTwCon TwConDisjoint) + "Distinct" -> Just (BTwCon (TwConDistinct 2)) + + -- Type constructors. + "Unit" -> Just (BTcCon (TcConUnit)) + "S" -> Just (BTcCon (TcConSusp)) + "Read" -> Just (BTcCon (TcConRead)) + "HeadRead" -> Just (BTcCon (TcConHeadRead)) + "DeepRead" -> Just (BTcCon (TcConDeepRead)) + "Write" -> Just (BTcCon (TcConWrite)) + "DeepWrite" -> Just (BTcCon (TcConDeepWrite)) + "Alloc" -> Just (BTcCon (TcConAlloc)) + "DeepAlloc" -> Just (BTcCon (TcConDeepAlloc)) + + -- Builtin types. + "Pure" -> Just BPure + "Empty" -> Just BEmpty + + -- Builtin values. + "()" -> Just BDaConUnit + + _ -> Nothing + + +acceptTwConWithArity :: String -> Maybe TwCon +acceptTwConWithArity ss + | Just n <- List.stripPrefix "Distinct" ss + , not $ null n + , all Char.isDigit n + = Just (TwConDistinct $ read n) + + | otherwise + = Nothing + + diff --git a/DDC/Core/Lexer/Token/Index.hs b/DDC/Core/Lexer/Token/Index.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Token/Index.hs @@ -0,0 +1,21 @@ + +module DDC.Core.Lexer.Token.Index + (scanIndex) +where +import Text.Lexer.Inchworm.Char as I +import qualified Data.Char as Char + + +-- | Scan a deBruijn index. +scanIndex :: Scanner IO Location [Char] (I.Location, Int) +scanIndex + = I.munchPred Nothing matchIndex acceptIndex + where + matchIndex 0 '^' = True + matchIndex 0 _ = False + matchIndex _ c = Char.isDigit c + + acceptIndex ('^': xs) + | not $ null xs = return (read xs) + acceptIndex _ = Nothing + diff --git a/DDC/Core/Lexer/Token/Keyword.hs b/DDC/Core/Lexer/Token/Keyword.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Token/Keyword.hs @@ -0,0 +1,139 @@ + +module DDC.Core.Lexer.Token.Keyword + ( Keyword (..) + , sayKeyword + , scanKeyword) +where +import Text.Lexer.Inchworm.Char +import DDC.Core.Lexer.Token.Names + + +------------------------------------------------------------------------------- +-- | Keyword tokens. +data Keyword + -- core keywords. + = EModule + | EImport + | EExport + | EForeign + | EType + | ECapability + | EValue + | EData + | EWith + | EWhere + | EIn + | ELet + | ELetCase + | ELetRec + | EPrivate + | EExtend + | EUsing + | ECase + | EOf + | EWeakEff + | EWeakClo + | EPurify + | EForget + | EBox + | ERun + + -- sugar keywords. + | EDo + | EMatch + | EIf + | EThen + | EElse + | EOtherwise + deriving (Eq, Show) + + +------------------------------------------------------------------------------- +-- | Yield the string name of a keyword. +sayKeyword :: Keyword -> String +sayKeyword kw + = case kw of + -- core keywords. + EBox -> "box" + ECapability -> "capability" + ECase -> "case" + EData -> "data" + EExport -> "export" + EExtend -> "extend" + EForeign -> "foreign" + EForget -> "forget" + EImport -> "import" + EIn -> "in" + ELet -> "let" + ELetCase -> "letcase" + ELetRec -> "letrec" + EModule -> "module" + EOf -> "of" + EPrivate -> "private" + EPurify -> "purify" + ERun -> "run" + EType -> "type" + EValue -> "value" + EWhere -> "where" + EWeakClo -> "weakclo" + EWeakEff -> "weakeff" + EWith -> "with" + EUsing -> "using" + + -- sugar keywords + EDo -> "do" + EElse -> "else" + EIf -> "if" + EMatch -> "match" + EOtherwise -> "otherwise" + EThen -> "then" + + + +------------------------------------------------------------------------------- +-- | Scanner for a `Keyword`. +scanKeyword :: Scanner IO Location [Char] (Location, Keyword) +scanKeyword + = munchPred Nothing matchVarName acceptKeyword + +-- | Accept a keyword token. +acceptKeyword :: String -> Maybe Keyword +acceptKeyword str + = case str of + -- core keywords + "box" -> Just EBox + "capability" -> Just ECapability + "case" -> Just ECase + "data" -> Just EData + "export" -> Just EExport + "extend" -> Just EExtend + "foreign" -> Just EForeign + "forget" -> Just EForget + "import" -> Just EImport + "in" -> Just EIn + "let" -> Just ELet + "letcase" -> Just ELetCase + "letrec" -> Just ELetRec + "module" -> Just EModule + "of" -> Just EOf + "private" -> Just EPrivate + "purify" -> Just EPurify + "run" -> Just ERun + "type" -> Just EType + "value" -> Just EValue + "where" -> Just EWhere + "weakclo" -> Just EWeakClo + "weakeff" -> Just EWeakEff + "with" -> Just EWith + "using" -> Just EUsing + + -- sugar keywords + "do" -> Just EDo + "else" -> Just EElse + "if" -> Just EIf + "match" -> Just EMatch + "otherwise" -> Just EOtherwise + "then" -> Just EThen + + _ -> Nothing + diff --git a/DDC/Core/Lexer/Token/Literal.hs b/DDC/Core/Lexer/Token/Literal.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Token/Literal.hs @@ -0,0 +1,246 @@ + +module DDC.Core.Lexer.Token.Literal + ( Literal (..) + , scanLiteral + + , isLitName + , isLitStart + , isLitBody + + , readLitInteger + , readLitNat + , readLitInt + , readLitSize + , readLitWordOfBits + , readLitFloatOfBits + , readBinary + , readHex) +where +import DDC.Core.Exp.Literal +import Text.Lexer.Inchworm.Char +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Data.Text as Text + + +-- Literal -------------------------------------------------------------------- +scanLiteral :: Scanner IO Location [Char] (Location, (Literal, Bool)) +scanLiteral + = alts [ munchPred Nothing matchLiteral acceptLiteral + + -- Character literals with Haskell style escape codes. + , do (loc, c) <- scanHaskellChar + alts [ do _ <- satisfies (\c' -> c' == '#') + return (loc, (LChar c, True)) + + , do return (loc, (LChar c, False)) ] + + -- String literals with Haskell style escape codes. + , do (loc, str) <- scanHaskellString + alts [ do _ <- satisfies (\c -> c == '#') + return (loc, (LString (Text.pack str), True)) + + , do return (loc, (LString (Text.pack str), False)) + ] + ] + + +-- | Match a literal character. +matchLiteral :: Int -> Char -> Bool +matchLiteral 0 c = isLitStart c +matchLiteral _ c = isLitBody c + + +-- | Accept a literal. +acceptLiteral :: String -> Maybe (Literal, Bool) +acceptLiteral str + | ('#' : str') <- reverse str + , Just lit <- acceptLit (reverse str') + = Just (lit, True) + + | Just lit <- acceptLit str + = Just (lit, False) + + | otherwise + = Nothing + where acceptLit str' + | Just i <- readLitNat str' = Just (LNat i) + | Just i <- readLitInt str' = Just (LInt i) + | Just i <- readLitSize str' = Just (LSize i) + | Just (u, b) <- readLitWordOfBits str' = Just (LWord u b) + | Just (f, b) <- readLitFloatOfBits str' = Just (LFloat f b) + | otherwise = Nothing + + +------------------------------------------------------------------------------- +-- | String is the name of a literal. +isLitName :: String -> Bool +isLitName str + = case str of + [] -> False + c : cs + | isLitStart c + , and (map isLitBody cs) + -> True + + | otherwise + -> False + + +-- | Character can start a literal. +isLitStart :: Char -> Bool +isLitStart c + = Char.isDigit c + || c == '-' + + +-- | Character can be part of a literal body. +isLitBody :: Char -> Bool +isLitBody c + = Char.isDigit c + || c == 'b' || c == 'o' || c == 'x' + || c == 'w' || c == 'f' || c == 'i' || c == 's' + || c == '.' + || c == '#' + || c == '\'' + + + +------------------------------------------------------------------------------- +-- | Read a signed integer. +readLitInteger :: String -> Maybe Integer +readLitInteger [] = Nothing +readLitInteger str@(c:cs) + | '-' <- c + , all Char.isDigit cs + = Just $ read str + + | all Char.isDigit cs + = Just $ read str + + | otherwise + = Nothing + + +-- | Read an integer with an explicit format specifier like @1234i@. +readLitNat :: String -> Maybe Integer +readLitNat str1 + | (ds, "") <- List.span Char.isDigit str1 + , not $ null ds + = Just $ read ds + + | otherwise + = Nothing + + +-- | Read an integer literal with an explicit format specifier like @1234i@. +readLitInt :: String -> Maybe Integer +readLitInt str1 + | '-' : str2 <- str1 + , (ds, "i") <- List.span Char.isDigit str2 + , not $ null ds + = Just $ negate $ read ds + + | (ds, "i") <- List.span Char.isDigit str1 + , not $ null ds + = Just $ read ds + + | otherwise + = Nothing + + +-- | Read an size literal with an explicit format specifier like @1234s@. +readLitSize :: String -> Maybe Integer +readLitSize str1 + | '-' : str2 <- str1 + , (ds, "s") <- List.span Char.isDigit str2 + , not $ null ds + = Just $ negate $ read ds + + | (ds, "s") <- List.span Char.isDigit str1 + , not $ null ds + = Just $ read ds + + | otherwise + = Nothing + + +-- | Read a word with an explicit format speficier. +readLitWordOfBits :: String -> Maybe (Integer, Int) +readLitWordOfBits str1 + -- binary like 0b01001w32 + | Just str2 <- List.stripPrefix "0b" str1 + , (ds, str3) <- List.span (\c -> c == '0' || c == '1') str2 + , not $ null ds + , Just str4 <- List.stripPrefix "w" str3 + , (bs, "") <- List.span Char.isDigit str4 + , not $ null bs + , bits <- read bs + , length ds <= bits + = Just (readBinary ds, bits) + + -- hex like 0x0ffw32 + | Just str2 <- List.stripPrefix "0x" str1 + , (ds, str3) <- List.span (\c -> elem c ['0' .. '9'] + || elem c ['A' .. 'F'] + || elem c ['a' .. 'f']) str2 + , not $ null ds + , Just str4 <- List.stripPrefix "w" str3 + , (bs, "") <- List.span Char.isDigit str4 + , not $ null bs + , bits <- read bs + , length ds <= bits + = Just (readHex ds, bits) + + -- decimal like 1234w32 + | (ds, str2) <- List.span Char.isDigit str1 + , not $ null ds + , Just str3 <- List.stripPrefix "w" str2 + , (bs, "") <- List.span Char.isDigit str3 + , not $ null bs + = Just (read ds, read bs) + + | otherwise + = Nothing + + +-- | Read a float literal with an explicit format specifier like @123.00f32#@. +readLitFloatOfBits :: String -> Maybe (Double, Int) +readLitFloatOfBits str1 + | '-' : str2 <- str1 + , Just (d, bs) <- readLitFloatOfBits str2 + = Just (negate d, bs) + + | (ds1, str2) <- List.span Char.isDigit str1 + , not $ null ds1 + , Just str3 <- List.stripPrefix "." str2 + , (ds2, str4) <- List.span Char.isDigit str3 + , not $ null ds2 + , Just str5 <- List.stripPrefix "f" str4 + , (bs, "") <- List.span Char.isDigit str5 + , not $ null bs + = Just (read (ds1 ++ "." ++ ds2), read bs) + + | otherwise + = Nothing + + +-- | Read a binary string as a number. +readBinary :: Num a => String -> a +readBinary digits + = List.foldl' (\acc b -> if b then 2 * acc + 1 else 2 * acc) 0 + $ map (/= '0') digits + + +-- | Read a hex string as a number. +readHex :: (Enum a, Num a) => String -> a +readHex digits + = List.foldl' (\acc d -> let Just v = lookup d table + in 16 * acc + v) 0 + $ digits + + where table + = zip ['0' .. '9'] [0 .. 9] + ++ zip ['a' .. 'f'] [10 .. 15] + ++ zip ['A' .. 'F'] [10 .. 15] + diff --git a/DDC/Core/Lexer/Token/Names.hs b/DDC/Core/Lexer/Token/Names.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Token/Names.hs @@ -0,0 +1,141 @@ + +module DDC.Core.Lexer.Token.Names + ( -- * Variable names + scanVarName + , matchVarName + , acceptVarName + , isVarName + , isVarStart + , isVarBody + + -- * Constructor names + , scanConName + , matchConName + , acceptConName + , isConName + , isConStart + , isConBody) +where +import Text.Lexer.Inchworm.Char +import DDC.Data.ListUtils +import qualified Data.Char as Char + + +-- Variable names --------------------------------------------------------------------------------- +-- | Scanner for variable anmes. +scanVarName :: Scanner IO Location [Char] (Location, String) +scanVarName + = munchPred Nothing matchVarName acceptVarName + + +-- | Match a variable name. +matchVarName :: Int -> Char -> Bool +matchVarName 0 c = isVarStart c +matchVarName _ c = isVarBody c + + +-- | Accept a variable name. +acceptVarName :: String -> Maybe String +acceptVarName ss + | isVarName ss = Just ss + | otherwise = Nothing + + +-- | Check if this string is a variable name. +isVarName :: String -> Bool +isVarName str + = case str of + [] -> False + c : cs + | isVarStart c + , and (map isVarBody cs) + -> True + + | _ : _ <- cs + , Just initCs <- takeInit cs + , isVarStart c + , and (map isVarBody initCs) + , last cs == '#' + -> True + + | otherwise + -> False + + +-- | Charater can start a variable name. +isVarStart :: Char -> Bool +isVarStart c + = Char.isLower c + || c == '?' + || c == '_' + + +-- | Character can be part of a variable body. +isVarBody :: Char -> Bool +isVarBody c + = Char.isUpper c + || Char.isLower c + || Char.isDigit c + || c == '_' + || c == '\'' + || c == '$' + || c == '#' + + +-- Constructor names ------------------------------------------------------------------------------ +-- | Scanner for constructor names. +scanConName :: Scanner IO Location [Char] (Location, String) +scanConName + = munchPred Nothing matchConName acceptConName + + +-- | Match a constructor name. +matchConName :: Int -> Char -> Bool +matchConName 0 c = isConStart c +matchConName _ c = isConBody c + + +-- | Accept a constructor name. +acceptConName :: String -> Maybe String +acceptConName ss + | isConName ss = Just ss + | otherwise = Nothing + + +-- | String is a constructor name. +isConName :: String -> Bool +isConName str + = case str of + [] -> False + c : cs + | isConStart c + , and (map isConBody cs) + -> True + + | _ : _ <- cs + , Just initCs <- takeInit cs + , isConStart c + , and (map isConBody initCs) + , last cs == '#' + -> True + + | otherwise + -> False + + +-- | Character can start a constructor name. +isConStart :: Char -> Bool +isConStart + = Char.isUpper + + +-- | Charater can be part of a constructor body. +isConBody :: Char -> Bool +isConBody c + = Char.isUpper c + || Char.isLower c + || Char.isDigit c + || c == '_' + || c == '\'' + || c == '#' + diff --git a/DDC/Core/Lexer/Token/Operator.hs b/DDC/Core/Lexer/Token/Operator.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Token/Operator.hs @@ -0,0 +1,110 @@ + +module DDC.Core.Lexer.Token.Operator + ( scanPrefixOperator + , scanInfixOperator + , acceptInfixOperator + , isOpName + , isOpStart + , isOpBody) +where +import Text.Lexer.Inchworm.Char +import DDC.Core.Lexer.Unicode +import qualified Data.Set as Set +import qualified Data.List as List + + +------------------------------------------------------------------------------- +-- | Scanner for operators used prefix. +scanPrefixOperator :: Scanner IO Location [Char] (Location, String) +scanPrefixOperator + = munchPred Nothing matchPrefixOperator acceptPrefixOperator + + +-- | Patch a prefix operator name. +matchPrefixOperator :: Int -> Char -> Bool +matchPrefixOperator 0 c = c == '(' +matchPrefixOperator _ c = isOpBody c || c == ')' + + +-- | Accept a prefix operator name. +acceptPrefixOperator :: String -> Maybe String +acceptPrefixOperator str + | '(' : cs1 <- str + , c : cs2 <- cs1 + , isOpStart c + , (body , cs3) <- List.span isOpBody cs2 + , ')' : [] <- cs3 + , not $ null (c : body) + = Just (c : body) + + | otherwise + = Nothing + + + +------------------------------------------------------------------------------- +-- | Scanner for operators used infix. +scanInfixOperator :: Scanner IO Location [Char] (Location, String) +scanInfixOperator + = munchPred Nothing matchInfixOperator acceptInfixOperator + + +-- | Match an operator name. +matchInfixOperator :: Int -> Char -> Bool +matchInfixOperator 0 c = isOpStart c +matchInfixOperator _ c = isOpBody c + + +-- | Accept an operator name. +acceptInfixOperator :: String -> Maybe String +acceptInfixOperator str + = case str of + "=" -> Nothing + "|" -> Nothing + "~>" -> Nothing + "->" -> Nothing + "<-" -> Nothing + "=>" -> Nothing + "/\\" -> Nothing + _ -> Just str + + +-- | String is the name of some operator. +isOpName :: String -> Bool +isOpName str + = case str of + [] -> False + c : cs + | isOpStart c + , and (map isOpBody cs) + -> True + + | otherwise + -> False + + +-- | Character can start an operator. +isOpStart :: Char -> Bool +isOpStart c + = c == '~' || c == '!' || c == '#' + || c == '$' || c == '%' || c == '&' + || c == '*' || c == '-' || c == '+' || c == '=' + || c == ':' || c == '/' || c == '|' + || c == '<' || c == '>' + || Set.member c unicodeOperatorsInfix + + +-- | Character can be part of an operator body. +isOpBody :: Char -> Bool +isOpBody c + = c == '~' || c == '!' || c == '#' + || c == '$' || c == '%' || c == '&' + || c == '*' || c == '-' || c == '+' || c == '=' + || c == ':' || c == '?' || c == '/' || c == '|' + || c == '<' || c == '>' + || c == '\\' + || Set.member c unicodeOperatorsInfix + + + + diff --git a/DDC/Core/Lexer/Token/Symbol.hs b/DDC/Core/Lexer/Token/Symbol.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Token/Symbol.hs @@ -0,0 +1,166 @@ + +module DDC.Core.Lexer.Token.Symbol + ( Symbol (..) + , saySymbol + , scanSymbol + , acceptSymbol1 + , acceptSymbol2) +where +import Text.Lexer.Inchworm.Char + + +------------------------------------------------------------------------------- +-- | Symbol tokens. +data Symbol + -- Single char parenthesis + = SRoundBra -- ^ Like '(' + | SRoundKet -- ^ Like ')' + | SSquareBra -- ^ Like '[' + | SSquareKet -- ^ Like ']' + | SBraceBra -- ^ Like '{' + | SBraceKet -- ^ Like '}' + + -- Compound parenthesis + | SSquareColonBra -- ^ Like '[:' + | SSquareColonKet -- ^ Like ':]' + | SBraceColonBra -- ^ Like '{:' + | SBraceColonKet -- ^ Like ':}' + + -- Compound symbols. + | SBigLambdaSlash -- ^ Like '/\\' + | SArrowTilde -- ^ Like '~>' + | SArrowDashRight -- ^ Like '->' + | SArrowDashLeft -- ^ Like '<-' + | SArrowEquals -- ^ Like '=>' + + -- Other punctuation. + | SAt -- ^ Like '@' + | SHat -- ^ Like '^' + | SDot -- ^ Like '.' + | SBar -- ^ Like '|' + | SComma -- ^ Like ',' + | SEquals -- ^ Like '=' + | SLambda -- ^ Like 'λ' + | SSemiColon -- ^ Like ';' + | SBackSlash -- ^ Like '\\' + | SBigLambda -- ^ Like 'Λ' + | SUnderscore -- ^ Like '_' + deriving (Eq, Show) + + +------------------------------------------------------------------------------- +-- | Yield the string name of a symbol token. +saySymbol :: Symbol -> String +saySymbol pp + = case pp of + -- Single character symbols. + SRoundBra -> "(" + SRoundKet -> ")" + SSquareBra -> "[" + SSquareKet -> "]" + SBraceBra -> "{" + SBraceKet -> "}" + + -- Compound parenthesis. + SSquareColonBra -> "[:" + SSquareColonKet -> ":]" + SBraceColonBra -> "{:" + SBraceColonKet -> ":}" + + -- Compound symbols. + SBigLambdaSlash -> "/\\" + SArrowTilde -> "~>" + SArrowDashRight -> "->" + SArrowDashLeft -> "<-" + SArrowEquals -> "=>" + + -- Other punctuation. + SAt -> "@" + SHat -> "^" + SDot -> "." + SBar -> "|" + SComma -> "," + SEquals -> "=" + SLambda -> "λ" + SSemiColon -> ";" + SBackSlash -> "\\" + SBigLambda -> "Λ" + SUnderscore -> "_" + + +------------------------------------------------------------------------------- +-- | Scanner for a `Symbol`. +scanSymbol :: Scanner IO Location [Char] (Location, Symbol) +scanSymbol + = alt (munchPred Nothing matchSymbol2 acceptSymbol2) + (from acceptSymbol1) + + +-- | Match a potential symbol character. +matchSymbol2 :: Int -> Char -> Bool +matchSymbol2 0 c + = case c of + '[' -> True + '{' -> True + ':' -> True + '/' -> True + '~' -> True + '-' -> True + '<' -> True + '=' -> True + _ -> False + +matchSymbol2 1 c + = case c of + ']' -> True + '}' -> True + ':' -> True + '\\' -> True + '>' -> True + '-' -> True + _ -> False + +matchSymbol2 _ _ + = False + + +-- | Accept a double character symbol. +acceptSymbol2 :: String -> Maybe Symbol +acceptSymbol2 ss + = case ss of + "[:" -> Just SSquareColonBra + ":]" -> Just SSquareColonKet + "{:" -> Just SBraceColonBra + ":}" -> Just SBraceColonKet + "/\\" -> Just SBigLambdaSlash + "~>" -> Just SArrowTilde + "->" -> Just SArrowDashRight + "<-" -> Just SArrowDashLeft + "=>" -> Just SArrowEquals + _ -> Nothing + + +-- | Accept a single character symbol. +acceptSymbol1 :: Char -> Maybe Symbol +acceptSymbol1 c + = case c of + '(' -> Just SRoundBra + ')' -> Just SRoundKet + '[' -> Just SSquareBra + ']' -> Just SSquareKet + '{' -> Just SBraceBra + '}' -> Just SBraceKet + 'λ' -> Just SLambda + 'Λ' -> Just SBigLambda + '\\' -> Just SBackSlash + '@' -> Just SAt + '^' -> Just SHat + '.' -> Just SDot + '|' -> Just SBar + ',' -> Just SComma + '=' -> Just SEquals + ';' -> Just SSemiColon + '_' -> Just SUnderscore + '→' -> Just SArrowDashRight + '←' -> Just SArrowDashLeft + _ -> Nothing diff --git a/DDC/Core/Lexer/Tokens.hs b/DDC/Core/Lexer/Tokens.hs --- a/DDC/Core/Lexer/Tokens.hs +++ b/DDC/Core/Lexer/Tokens.hs @@ -1,24 +1,61 @@ module DDC.Core.Lexer.Tokens - ( -- * Tokens - Tok (..) - , renameTok - , describeTok + ( Located (..) + , columnOfLocated - -- * Meta Tokens - , TokMeta (..) - , describeTokMeta + -- * Tokens + , Token (..) + , TokenMeta (..) + , TokenAtom (..) + , TokenNamed (..) - -- * Atomic Tokens - , TokAtom (..) - , describeTokAtom + , Keyword (..) + , Symbol (..) + , Builtin (..) + , Literal (..) - -- * Named Tokens - , TokNamed (..) - , describeTokNamed) + -- ** Description + , describeToken + , describeTokenMeta + , describeTokenAtom + , describeTokenNamed + , sayKeyword + , saySymbol + , sayBuiltin + + -- ** Renaming + , renameToken + + -- ** Predicates + , isVarName + , isVarStart + , isVarBody + + , isConName + , isConStart + , isConBody + + , isLitName + , isLitStart + , isLitBody + + -- ** Literal Reading + , readLitInteger + , readLitNat + , readLitInt + , readLitSize + , readLitWordOfBits + , readLitFloatOfBits + , readBinary + , readHex) where +import DDC.Data.SourcePos +import DDC.Core.Lexer.Token.Symbol +import DDC.Core.Lexer.Token.Keyword +import DDC.Core.Lexer.Token.Builtin +import DDC.Core.Lexer.Token.Literal +import DDC.Core.Lexer.Token.Names import DDC.Core.Pretty -import DDC.Core.Exp import Control.Monad import Data.Text (Text) import qualified Data.Text as T @@ -50,37 +87,37 @@ Pragma -> "pragma" --- Tok ------------------------------------------------------------------------ +-- Token ------------------------------------------------------------------------ -- | Tokens accepted by the core language parser. -data Tok n +data Token n -- | Some junk symbol that isn't part of the language. - = KErrorJunk String + = KErrorJunk String -- | The first part of an unterminated string. | KErrorUnterm String -- | Meta tokens contain out-of-band information that is eliminated -- before parsing proper. - | KM !TokMeta + | KM !TokenMeta -- | Atomic tokens are keywords, punctuation and baked-in -- constructor names. - | KA !TokAtom + | KA !TokenAtom -- | A named token that is specific to the language fragment -- (maybe it's a primop), or a user defined name. - | KN !(TokNamed n) + | KN !(TokenNamed n) deriving (Eq, Show) -- | Apply a function to all the names in a `Tok`. -renameTok +renameToken :: Ord n2 => (n1 -> Maybe n2) - -> Tok n1 - -> Maybe (Tok n2) + -> Token n1 + -> Maybe (Token n2) -renameTok f kk +renameToken f kk = case kk of KErrorJunk s -> Just $ KErrorJunk s @@ -90,29 +127,29 @@ KM t -> Just $ KM t KA t -> Just $ KA t - KN t -> liftM KN $ renameTokNamed f t + KN t -> liftM KN $ renameTokenNamed f t -- | Describe a token for parser error messages. -describeTok :: Pretty n => Tok n -> String -describeTok kk +describeToken :: Pretty n => Token n -> String +describeToken kk = case kk of KErrorJunk c -> "character " ++ show c KErrorUnterm _ -> "unterminated string" - KM tm -> describeTokMeta tm - KA ta -> describeTokAtom ta - KN tn -> describeTokNamed tn + KM tm -> describeTokenMeta tm + KA ta -> describeTokenAtom ta + KN tn -> describeTokenNamed tn -- TokMeta -------------------------------------------------------------------- -- | Meta tokens contain out-of-band information that is -- eliminated before parsing proper. -data TokMeta +data TokenMeta = KNewLine - | KCommentLineStart - | KCommentBlockStart - | KCommentBlockEnd + -- | Comment string. + | KComment String + -- | This is injected by `dropCommentBlock` when it finds -- an unterminated block comment. | KCommentUnterminated @@ -124,13 +161,11 @@ -- | Describe a TokMeta, for lexer error messages. -describeTokMeta :: TokMeta -> String -describeTokMeta tm +describeTokenMeta :: TokenMeta -> String +describeTokenMeta tm = case tm of KNewLine -> "new line" - KCommentLineStart -> "comment start" - KCommentBlockStart -> "block comment start" - KCommentBlockEnd -> "block comment end" + KComment{} -> "comment" KCommentUnterminated -> "unterminated block comment" KOffsideClosingBrace -> "closing brace" @@ -139,269 +174,79 @@ -- | Atomic tokens are keywords, punctuation and baked-in constructor names. -- They don't contain user-defined names or primops specific to the -- language fragment. -data TokAtom - ----------------------------------------- - -- Single char parenthesis - = KRoundBra -- ^ Like '(' - | KRoundKet -- ^ Like ')' - | KSquareBra -- ^ Like '[' - | KSquareKet -- ^ Like ']' - | KBraceBra -- ^ Like '{' - | KBraceKet -- ^ Like '}' - - -- Compound parenthesis - | KSquareColonBra -- ^ Like '[:' - | KSquareColonKet -- ^ Like ':]' - | KBraceColonBra -- ^ Like '{:' - | KBraceColonKet -- ^ Like ':}' - - ----------------------------------------- - -- Operator symbols - -- These can be used as part of an infix operator. - | KOp String -- ^ Naked operator, like in 1 + 2. - | KOpVar String -- ^ Wrapped operator, like in (+) 1 2. - - ----------------------------------------- - -- Operator body symbols. - -- These can be used in an operator body, but cannot start an operator. - - -- Allowing '^' to start an operator causes problems in type signatures. - -- We end up lexing a '^^^' operator with '[^^^ : Int]' - -- and a '^:' operator in '[^:Int]' - | KHat - - ----------------------------------------- - -- Punctuation symbols. - -- These cannot be used as part of an infix operator. - - -- Allowing '.' in an operator conflicts with trailing big-lambdas. - -- We end up lexing './' as an operator in '\(x:Int)./\(a : Data)' - | KDot - - | KComma - | KSemiColon - | KUnderscore - | KBackSlash - | KEquals - | KBar - - ----------------------------------------- - -- Compound symbols. - | KBigLambdaSlash - | KBigLambda - | KLambda - - ----------------------------------------- - -- symbolic constructors - | KArrowTilde - | KArrowDash - | KArrowDashLeft - | KArrowEquals - - ----------------------------------------- - -- bottoms - | KBotEffect - | KBotClosure - - ----------------------------------------- - -- core keywords - | KModule - | KImport - | KExport - | KForeign - | KType - | KCapability - | KValue - | KData - | KWith - | KWhere - | KIn - | KLet - | KLetCase - | KLetRec - | KPrivate - | KExtend - | KUsing - | KWithRegion - | KCase - | KOf - | KWeakEff - | KWeakClo - | KPurify - | KForget - | KBox - | KRun - - ----------------------------------------- - -- sugar keywords - | KDo - | KMatch - | KIf - | KThen - | KElse - | KOtherwise - - ----------------------------------------- - -- debruijn indices - | KIndex Int +data TokenAtom + -- | Pragmas. + = KPragma Text - -- literal strings - | KString Text + -- | Symbols. + | KSymbol Symbol - -- pragmas - | KPragma Text + -- | Keywords. + | KKeyword Keyword - ----------------------------------------- - -- builtin names - -- sort constructors. - | KSoConBuiltin SoCon + -- | Builtin names. + | KBuiltin Builtin - -- kind constructors. - | KKiConBuiltin KiCon + -- | Infix operators, like in 1 + 2. + | KOp String - -- witness type constructors. - | KTwConBuiltin TwCon + -- | Wrapped operator, like in (+) 1 2. + | KOpVar String - -- other builtin spec constructors. - | KTcConBuiltin TcCon + -- | Debrujn indices. + | KIndex Int - -- the unit data constructor. - | KDaConUnit + -- | Literal values. + | KLiteral + Literal -- Literal value. + Bool -- Trailing '#' prim specifier. deriving (Eq, Show) -- | Describe a `TokAtom`, for parser error messages. -describeTokAtom :: TokAtom -> String -describeTokAtom ta - = let (family, str) = describeTokAtom' ta +describeTokenAtom :: TokenAtom -> String +describeTokenAtom ta + = let (family, str) = describeTokenAtom' ta in describeTokenFamily family ++ " " ++ show str -describeTokAtom' :: TokAtom -> (TokenFamily, String) -describeTokAtom' ta +describeTokenAtom' :: TokenAtom -> (TokenFamily, String) +describeTokenAtom' ta = case ta of - -- parens - KRoundBra -> (Symbol, "(") - KRoundKet -> (Symbol, ")") - KSquareBra -> (Symbol, "[") - KSquareKet -> (Symbol, "]") - KBraceBra -> (Symbol, "{") - KBraceKet -> (Symbol, "}") - - -- compound parens - KSquareColonBra -> (Symbol, "[:") - KSquareColonKet -> (Symbol, ":]") - KBraceColonBra -> (Symbol, "{:") - KBraceColonKet -> (Symbol, ":}") + KPragma p -> (Pragma, "{-#" ++ T.unpack p ++ "#-}") + KSymbol ss -> (Symbol, saySymbol ss) + KKeyword kw -> (Keyword, sayKeyword kw) + KBuiltin bb -> (Constructor, sayBuiltin bb) + KOp op -> (Symbol, op) + KOpVar op -> (Symbol, "(" ++ op ++ ")") + KIndex i -> (Index, "^" ++ show i) + KLiteral l b -> (Literal, show (l, b)) - -- operator symbols - KOp op -> (Symbol, op) - KOpVar op -> (Symbol, "(" ++ op ++ ")") - - -- operator body symbols - KHat -> (Symbol, "^") - -- punctuation symbols - KDot -> (Symbol, ".") - KComma -> (Symbol, ",") - KSemiColon -> (Symbol, ";") - KUnderscore -> (Symbol, "_") - - KBackSlash -> (Symbol, "\\") - KLambda -> (Symbol, "λ") - - KBigLambdaSlash -> (Symbol, "/\\") - KBigLambda -> (Symbol, "Λ") - - KEquals -> (Symbol, "=") - KBar -> (Symbol, "|") - - -- symbolic constructors - KArrowTilde -> (Constructor, "~>") - KArrowDash -> (Constructor, "->") - KArrowDashLeft -> (Constructor, "<-") - KArrowEquals -> (Constructor, "=>") - - -- bottoms - KBotEffect -> (Constructor, "Pure") - KBotClosure -> (Constructor, "Empty") - - -- expression keywords - KModule -> (Keyword, "module") - KImport -> (Keyword, "import") - KExport -> (Keyword, "export") - KForeign -> (Keyword, "foreign") - KType -> (Keyword, "type") - KCapability -> (Keyword, "capability") - KValue -> (Keyword, "value") - KData -> (Keyword, "data") - KWith -> (Keyword, "with") - KWhere -> (Keyword, "where") - KIn -> (Keyword, "in") - KLet -> (Keyword, "let") - KLetCase -> (Keyword, "letcase") - KLetRec -> (Keyword, "letrec") - KPrivate -> (Keyword, "private") - KExtend -> (Keyword, "extend") - KUsing -> (Keyword, "using") - KWithRegion -> (Keyword, "withregion") - KCase -> (Keyword, "case") - KOf -> (Keyword, "of") - KWeakEff -> (Keyword, "weakeff") - KWeakClo -> (Keyword, "weakclo") - KPurify -> (Keyword, "purify") - KForget -> (Keyword, "forget") - KBox -> (Keyword, "box") - KRun -> (Keyword, "run") - - -- sugar keywords - KDo -> (Keyword, "do") - KMatch -> (Keyword, "match") - KIf -> (Keyword, "if") - KThen -> (Keyword, "then") - KElse -> (Keyword, "else") - KOtherwise -> (Keyword, "otherwise") - - -- debruijn indices - KIndex i -> (Index, "^" ++ show i) - KString s -> (Literal, show s) - KPragma p -> (Pragma, "{-#" ++ T.unpack p ++ "#-}") - - -- builtin names - KSoConBuiltin so -> (Constructor, renderPlain $ ppr so) - KKiConBuiltin ki -> (Constructor, renderPlain $ ppr ki) - KTwConBuiltin tw -> (Constructor, renderPlain $ ppr tw) - KTcConBuiltin tc -> (Constructor, renderPlain $ ppr tc) - KDaConUnit -> (Constructor, "()") - - -- TokNamed ------------------------------------------------------------------- -- | A token with a user-defined name. -data TokNamed n +data TokenNamed n = KCon n | KVar n - | KLit n deriving (Eq, Show) -- | Describe a `TokNamed`, for parser error messages. -describeTokNamed :: Pretty n => TokNamed n -> String -describeTokNamed tn +describeTokenNamed :: Pretty n => TokenNamed n -> String +describeTokenNamed tn = case tn of KCon n -> renderPlain $ text "constructor" <+> (dquotes $ ppr n) KVar n -> renderPlain $ text "variable" <+> (dquotes $ ppr n) - KLit n -> renderPlain $ text "literal" <+> (dquotes $ ppr n) -- | Apply a function to all the names in a `TokNamed`. -renameTokNamed +renameTokenNamed :: Ord n2 => (n1 -> Maybe n2) - -> TokNamed n1 - -> Maybe (TokNamed n2) + -> TokenNamed n1 + -> Maybe (TokenNamed n2) -renameTokNamed f kk +renameTokenNamed f kk = case kk of KCon c -> liftM KCon $ f c KVar c -> liftM KVar $ f c - KLit c -> liftM KLit $ f c diff --git a/DDC/Core/Load.hs b/DDC/Core/Load.hs --- a/DDC/Core/Load.hs +++ b/DDC/Core/Load.hs @@ -35,15 +35,14 @@ import DDC.Type.Transform.SpreadT import DDC.Type.Universe import DDC.Core.Module -import DDC.Base.Pretty -import DDC.Data.Token +import DDC.Data.Pretty import DDC.Core.Fragment (Fragment) +import qualified DDC.Core.Env.EnvX as EnvX import qualified DDC.Core.Fragment as F import qualified DDC.Core.Parser as C import qualified DDC.Core.Check as C -import qualified DDC.Type.Check as T -import qualified DDC.Type.Env as Env -import qualified DDC.Base.Parser as BP +import qualified DDC.Control.Parser as BP +import qualified Data.Map.Strict as Map import Data.Map.Strict (Map) import System.Directory @@ -53,7 +52,7 @@ data Error n err = ErrorRead !String | ErrorParser !BP.ParseError - | ErrorCheckType !(T.Error n) + | ErrorCheckType !(C.Error BP.SourcePos n) | ErrorCheckExp !(C.Error BP.SourcePos n) | ErrorCompliance !(F.Error (C.AnTEC BP.SourcePos n) n) | ErrorFragment !(err (C.AnTEC BP.SourcePos n)) @@ -140,7 +139,7 @@ => Fragment n err -- ^ Language fragment definition. -> FilePath -- ^ Path to source file for error messages. -> Mode n -- ^ Type checker mode. - -> [Token (Tok n)] -- ^ Source tokens. + -> [Located (Token n)] -- ^ Source tokens. -> ( Either (Error n err) (Module (C.AnTEC BP.SourcePos n) n) , Maybe CheckTrace) @@ -156,7 +155,7 @@ -- Parse the tokens. goParse toks - = case BP.runTokenParser describeTok sourceName + = case BP.runTokenParser describeToken sourceName (C.pModule (C.contextOfProfile profile)) toks of Left err -> (Left (ErrorParser err), Nothing) @@ -211,7 +210,7 @@ -- We add their exports to the environment. -> FilePath -- ^ Path to source file for error messages. -> Mode n -- ^ Type checker mode. - -> [Token (Tok n)] -- ^ Source tokens. + -> [Located (Token n)] -- ^ Source tokens. -> ( Either (Error n err) (Exp (C.AnTEC BP.SourcePos n) n) , Maybe CheckTrace) @@ -222,12 +221,19 @@ -- Type checker profile, kind and type environments. profile = F.fragmentProfile fragment config = C.configOfProfile profile - kenv = modulesExportTypes modules $ profilePrimKinds profile - tenv = modulesExportValues modules $ profilePrimTypes profile + + envx = modulesEnvX + (profilePrimKinds profile) + (profilePrimTypes profile) + (profilePrimDataDefs profile) + (Map.elems modules) + kenv = EnvX.kindEnvOfEnvX envx + tenv = EnvX.typeEnvOfEnvX envx + -- Parse the tokens. goParse toks - = case BP.runTokenParser describeTok sourceName + = case BP.runTokenParser describeToken sourceName (C.pExp (C.contextOfProfile profile)) toks of Left err -> (Left (ErrorParser err), Nothing) @@ -235,7 +241,7 @@ -- Check the kind of the type. goCheckType x - = case C.checkExp config kenv tenv mode C.DemandNone x of + = case C.checkExp config envx mode C.DemandNone x of (Left err, ct) -> (Left (ErrorCheckExp err), Just ct) (Right (x', _, _), ct) -> goCheckCompliance ct x' @@ -274,7 +280,7 @@ => Fragment n err -- ^ Language fragment definition. -> Universe -- ^ Universe this type is supposed to be in. -> FilePath -- ^ Path to source file for error messages. - -> [Token (Tok n)] -- ^ Source tokens. + -> [Located (Token n)] -- ^ Source tokens. -> Either (Error n err) (Type n, Kind n) @@ -285,7 +291,7 @@ -- Parse the tokens. goParse toks - = case BP.runTokenParser describeTok sourceName + = case BP.runTokenParser describeToken sourceName (C.pType (C.contextOfProfile profile)) toks of Left err -> Left (ErrorParser err) @@ -293,7 +299,7 @@ -- Check the kind of the type. goCheckType t - = case T.checkType (T.configOfProfile profile) Env.empty uni t of + = case C.checkType (C.configOfProfile profile) uni t of Left err -> Left (ErrorCheckType err) Right (t', k) -> Right (t', k) @@ -318,7 +324,7 @@ :: (Eq n, Ord n, Show n, Pretty n) => Fragment n err -- ^ Language fragment profile. -> FilePath -- ^ Path to source file for error messages. - -> [Token (Tok n)] -- ^ Source tokens. + -> [Located (Token n)] -- ^ Source tokens. -> Either (Error n err) (Witness (AnT BP.SourcePos n) n, Type n) @@ -327,12 +333,18 @@ where -- Type checker config, kind and type environments. profile = F.fragmentProfile fragment config = C.configOfProfile profile - kenv = profilePrimKinds profile - tenv = profilePrimTypes profile + env = EnvX.fromPrimEnvs + (profilePrimKinds profile) + (profilePrimTypes profile) + (profilePrimDataDefs profile) + + kenv = profilePrimKinds profile + tenv = profilePrimTypes profile + -- Parse the tokens. goParse toks - = case BP.runTokenParser describeTok sourceName + = case BP.runTokenParser describeToken sourceName (C.pWitness (C.contextOfProfile profile)) toks of Left err -> Left (ErrorParser err) @@ -340,7 +352,7 @@ -- Check the kind of the type. goCheckType w - = case C.checkWitness config kenv tenv w of + = case C.checkWitness config env w of Left err -> Left (ErrorCheckExp err) Right (w', t) -> Right (w', t) diff --git a/DDC/Core/Module.hs b/DDC/Core/Module.hs --- a/DDC/Core/Module.hs +++ b/DDC/Core/Module.hs @@ -1,11 +1,12 @@ - module DDC.Core.Module ( -- * Modules Module (..) , isMainModule , moduleDataDefs - , moduleKindEnv - , moduleTypeEnv + , moduleTypeDefs + , moduleKindEnv, moduleTypeEnv + , moduleEnvT, moduleEnvX + , modulesEnvT, modulesEnvX , moduleTopBinds , moduleTopBindTypes , mapTopBinds @@ -19,7 +20,8 @@ , ModuleName (..) , readModuleName , isMainModuleName - + , moduleNameMatchesPath + -- * Qualified names. , QualName (..) @@ -52,9 +54,14 @@ 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 @@ -73,28 +80,34 @@ -- Exports ------------------ -- | Kinds of exported types. - , moduleExportTypes :: ![(n, ExportSource n)] + , moduleExportTypes :: ![(n, ExportSource n (Type n))] -- | Types of exported values. - , moduleExportValues :: ![(n, ExportSource n)] + , moduleExportValues :: ![(n, ExportSource n (Type n))] -- Imports ------------------ -- | Define imported types. - , moduleImportTypes :: ![(n, ImportType n)] + , moduleImportTypes :: ![(n, ImportType n (Type n))] -- | Define imported capabilities. - , moduleImportCaps :: ![(n, ImportCap n)] + , moduleImportCaps :: ![(n, ImportCap n (Type n))] -- | Define imported values. - , moduleImportValues :: ![(n, ImportValue n)] + , 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. @@ -113,7 +126,9 @@ `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) @@ -131,6 +146,12 @@ $ (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 @@ -145,6 +166,141 @@ 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. diff --git a/DDC/Core/Module/Export.hs b/DDC/Core/Module/Export.hs --- a/DDC/Core/Module/Export.hs +++ b/DDC/Core/Module/Export.hs @@ -4,16 +4,15 @@ , takeTypeOfExportSource , mapTypeOfExportSource) where -import DDC.Type.Exp import Control.DeepSeq -- | Define thing exported from a module. -data ExportSource n +data ExportSource n t -- | A name defined in this module, with an explicit type. = ExportSourceLocal { exportSourceLocalName :: n - , exportSourceLocalType :: Type 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 @@ -23,7 +22,7 @@ deriving Show -instance NFData n => NFData (ExportSource n) where +instance (NFData n, NFData t) => NFData (ExportSource n t) where rnf es = case es of ExportSourceLocal n t -> rnf n `seq` rnf t @@ -31,7 +30,7 @@ -- | Take the type of an imported thing, if there is one. -takeTypeOfExportSource :: ExportSource n -> Maybe (Type n) +takeTypeOfExportSource :: ExportSource n t -> Maybe t takeTypeOfExportSource es = case es of ExportSourceLocal _ t -> Just t @@ -39,7 +38,7 @@ -- | Apply a function to any type in an ExportSource. -mapTypeOfExportSource :: (Type n -> Type n) -> ExportSource n -> ExportSource n +mapTypeOfExportSource :: (t -> t) -> ExportSource n t -> ExportSource n t mapTypeOfExportSource f esrc = case esrc of ExportSourceLocal n t -> ExportSourceLocal n (f t) diff --git a/DDC/Core/Module/Import.hs b/DDC/Core/Module/Import.hs --- a/DDC/Core/Module/Import.hs +++ b/DDC/Core/Module/Import.hs @@ -16,13 +16,12 @@ , mapTypeOfImportValue) where import DDC.Core.Module.Name -import DDC.Type.Exp import Control.DeepSeq -- ImportType ------------------------------------------------------------------------------------- --- | Define a foreign type being imported into a module. -data ImportType n +-- | 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, @@ -32,7 +31,7 @@ -- its associated values. -- = ImportTypeAbstract - { importTypeAbstractType :: !(Kind n) } + { importTypeAbstractType :: !t } -- | Type of some boxed data. -- @@ -43,11 +42,11 @@ -- This is used when importing data types defined in Salt modules. -- | ImportTypeBoxed - { importTypeBoxed :: !(Kind n) } + { importTypeBoxed :: !t } deriving Show -instance NFData n => NFData (ImportType n) where +instance (NFData n, NFData t) => NFData (ImportType n t) where rnf is = case is of ImportTypeAbstract k -> rnf k @@ -55,7 +54,7 @@ -- | Take the kind of an `ImportType`. -kindOfImportType :: ImportType n -> Kind n +kindOfImportType :: ImportType n t -> t kindOfImportType src = case src of ImportTypeAbstract k -> k @@ -63,7 +62,7 @@ -- | Apply a function to the kind of an `ImportType` -mapKindOfImportType :: (Kind n -> Kind n) -> ImportType n -> ImportType n +mapKindOfImportType :: (t -> t) -> ImportType n t -> ImportType n t mapKindOfImportType f isrc = case isrc of ImportTypeAbstract k -> ImportTypeAbstract (f k) @@ -72,30 +71,30 @@ -- ImportCapability ------------------------------------------------------------------------------- -- | Define a foreign capability being imported into a module. -data ImportCap n +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 :: !(Type n) } + { importCapAbstractType :: !t } deriving Show -instance NFData n => NFData (ImportCap n) where +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 -> Type n +typeOfImportCap :: ImportCap n t -> t typeOfImportCap ii = case ii of ImportCapAbstract t -> t -- | Apply a function to the type in an `ImportCapability`. -mapTypeOfImportCap :: (Type n -> Type n) -> ImportCap n -> ImportCap n +mapTypeOfImportCap :: (t -> t) -> ImportCap n t -> ImportCap n t mapTypeOfImportCap f ii = case ii of ImportCapAbstract t -> ImportCapAbstract (f t) @@ -103,7 +102,7 @@ -- ImportValue ------------------------------------------------------------------------------------ -- | Define a foreign value being imported into a module. -data ImportValue n +data ImportValue n t -- | Value imported from a module that we compiled ourselves. = ImportValueModule { -- | Name of the module that we're importing from. @@ -113,7 +112,7 @@ , importValueModuleVar :: !n -- | Type of the value that we're importing. - , importValueModuleType :: !(Type n) + , importValueModuleType :: !t -- | Calling convention for this value, -- including the number of type parameters, value parameters, and boxings. @@ -126,11 +125,11 @@ importValueSeaVar :: !String -- | Type of the value that we're importing. - , importValueSeaType :: !(Type n) } + , importValueSeaType :: !t } deriving Show -instance NFData n => NFData (ImportValue n) where +instance (NFData n, NFData t) => NFData (ImportValue n t) where rnf is = case is of ImportValueModule mn n t mAV @@ -141,7 +140,7 @@ -- | Take the type of an imported thing. -typeOfImportValue :: ImportValue n -> Type n +typeOfImportValue :: ImportValue n t -> t typeOfImportValue src = case src of ImportValueModule _ _ t _ -> t @@ -149,7 +148,7 @@ -- | Apply a function to the type in an ImportValue. -mapTypeOfImportValue :: (Type n -> Type n) -> ImportValue n -> ImportValue n +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 diff --git a/DDC/Core/Module/Name.hs b/DDC/Core/Module/Name.hs --- a/DDC/Core/Module/Name.hs +++ b/DDC/Core/Module/Name.hs @@ -3,11 +3,14 @@ ( 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 ------------------------------------------------------------------------------------- @@ -42,6 +45,31 @@ = 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 --------------------------------------------------------------------------------------- diff --git a/DDC/Core/Parser.hs b/DDC/Core/Parser.hs --- a/DDC/Core/Parser.hs +++ b/DDC/Core/Parser.hs @@ -33,7 +33,6 @@ -- * Constructors , pCon, pConSP , pLit, pLitSP - , pString, pStringSP -- * Variables , pIndex, pIndexSP @@ -46,6 +45,7 @@ , pOpVarSP -- * Raw Tokens + , pSym, pKey , pTok, pTokSP , pTokAs) diff --git a/DDC/Core/Parser/Base.hs b/DDC/Core/Parser/Base.hs --- a/DDC/Core/Parser/Base.hs +++ b/DDC/Core/Parser/Base.hs @@ -6,31 +6,31 @@ , pName , pCon, pConSP , pLit, pLitSP - , pString, pStringSP , pIndex, pIndexSP , pVar, pVarSP, pVarNamedSP + , pKey, pSym , pTok, pTokSP , pTokAs, pTokAsSP , pOpSP , pOpVarSP , pPragmaSP) where -import DDC.Base.Pretty +import DDC.Data.Pretty import DDC.Core.Module import DDC.Core.Lexer.Tokens -import DDC.Base.Parser ((), SourcePos) +import DDC.Control.Parser ((), SourcePos) import Data.Text (Text) -import qualified DDC.Base.Parser as P +import qualified DDC.Control.Parser as P -- | A parser of core language tokens. type Parser n a - = P.Parser (Tok n) a + = P.Parser (Token n) a -- | Parse a module name. pModuleName :: Pretty n => Parser n ModuleName pModuleName - = do ms <- P.sepBy1 pModuleName1 (pTok KDot) + = do ms <- P.sepBy1 pModuleName1 (pTok (KSymbol SDot)) return $ ModuleName $ concat $ map (\(ModuleName ss) -> ss) ms @@ -43,10 +43,10 @@ -- These names are lexed as constructors -- but can be part of a module name. - f (KA (KSoConBuiltin c)) = Just $ ModuleName [ renderPlain $ ppr c ] - f (KA (KKiConBuiltin c)) = Just $ ModuleName [ renderPlain $ ppr c ] - f (KA (KTwConBuiltin c)) = Just $ ModuleName [ renderPlain $ ppr c ] - f (KA (KTcConBuiltin c)) = Just $ ModuleName [ renderPlain $ ppr c ] + f (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 @@ -54,7 +54,7 @@ pQualName :: Pretty n => Parser n (QualName n) pQualName = do mn <- pModuleName - pTok KDot + pTok (KSymbol SDot) n <- pName return $ QualName mn n @@ -79,31 +79,17 @@ -- | Parse a literal. -pLit :: Parser n n +pLit :: Parser n (Literal, Bool) pLit = P.pTokMaybe f - where f (KN (KLit n)) = Just n - f _ = Nothing + where f (KA (KLiteral l b)) = Just (l, b) + f _ = Nothing -- | Parse a numeric literal, with source position. -pLitSP :: Parser n (n, SourcePos) +pLitSP :: Parser n ((Literal, Bool), SourcePos) pLitSP = P.pTokMaybeSP f - where f (KN (KLit n)) = Just n - f _ = Nothing - - --- | Parse a literal. -pString :: Parser n Text -pString = P.pTokMaybe f - where f (KA (KString tx)) = Just tx - f _ = Nothing - - --- | Parse a literal string, with source position. -pStringSP :: Parser n (Text, SourcePos) -pStringSP = P.pTokMaybeSP f - where f (KA (KString tx)) = Just tx - f _ = Nothing + where f (KA (KLiteral l b)) = Just (l, b) + f _ = Nothing -- | Parse a variable. @@ -166,24 +152,35 @@ where f (KA (KPragma txt)) = Just txt f _ = Nothing +------------------------------------------------------------------------------- +-- | Parse a `Symbol`. +pSym :: Symbol -> Parser n SourcePos +pSym ss = P.pTokSP (KA (KSymbol ss)) + +-- | Parse a `Keyword`. +pKey :: Keyword -> Parser n SourcePos +pKey kw = P.pTokSP (KA (KKeyword kw)) + + +------------------------------------------------------------------------------- -- | Parse an atomic token. -pTok :: TokAtom -> Parser n () +pTok :: TokenAtom -> Parser n () pTok k = P.pTok (KA k) -- | Parse an atomic token, yielding its source position. -pTokSP :: TokAtom -> Parser n SourcePos +pTokSP :: TokenAtom -> Parser n SourcePos pTokSP k = P.pTokSP (KA k) -- | Parse an atomic token and return some value. -pTokAs :: TokAtom -> a -> Parser n a +pTokAs :: TokenAtom -> a -> Parser n a pTokAs k x = P.pTokAs (KA k) x -- | Parse an atomic token and return source position and value. -pTokAsSP :: TokAtom -> a -> Parser n (a, SourcePos) +pTokAsSP :: TokenAtom -> a -> Parser n (a, SourcePos) pTokAsSP k x = P.pTokAsSP (KA k) x diff --git a/DDC/Core/Parser/Context.hs b/DDC/Core/Parser/Context.hs --- a/DDC/Core/Parser/Context.hs +++ b/DDC/Core/Parser/Context.hs @@ -3,10 +3,11 @@ ( Context (..) , contextOfProfile) where +import DDC.Core.Exp.Literal import DDC.Core.Fragment import DDC.Data.SourcePos -import Data.Text (Text) + -- | Configuration and information from the context. -- Used for context sensitive parsing. data Context n @@ -15,24 +16,33 @@ , contextTrackedClosures :: Bool , contextFunctionalEffects :: Bool , contextFunctionalClosures :: Bool - , contextMakeStringName :: Maybe (SourcePos -> Text -> n) } + -- | 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 + { contextTrackedEffects + = featuresTrackedEffects + $ profileFeatures profile - , contextTrackedClosures = featuresTrackedClosures - $ profileFeatures profile + , contextTrackedClosures + = featuresTrackedClosures + $ profileFeatures profile - , contextFunctionalEffects = featuresFunctionalEffects - $ profileFeatures profile + , contextFunctionalEffects + = featuresFunctionalEffects + $ profileFeatures profile - , contextFunctionalClosures = featuresFunctionalClosures - $ profileFeatures profile + , contextFunctionalClosures + = featuresFunctionalClosures + $ profileFeatures profile - , contextMakeStringName = profileMakeStringName profile + , contextMakeLiteralName + = profileMakeLiteralName profile } diff --git a/DDC/Core/Parser/DataDef.hs b/DDC/Core/Parser/DataDef.hs --- a/DDC/Core/Parser/DataDef.hs +++ b/DDC/Core/Parser/DataDef.hs @@ -10,24 +10,25 @@ import DDC.Core.Lexer.Tokens import DDC.Type.DataDef import Control.Monad -import qualified DDC.Base.Parser as P +import qualified DDC.Control.Parser as P pDataDef :: Ord n => Context n -> Parser n (DataDef n) pDataDef c - = do pTokSP KData + = do pTokSP (KKeyword EData) nData <- pName bsParam <- liftM concat $ P.many (pDataParam c) P.choice [ -- Data declaration with constructors that have explicit types. - do pTok KWhere - pTok KBraceBra - ctors <- P.sepEndBy1 (pDataCtor c nData bsParam) (pTok KSemiColon) + do pKey EWhere + pSym SBraceBra + ctors <- P.sepEndBy1 (pDataCtor c nData bsParam) + (pSym SSemiColon) let ctors' = [ ctor { dataCtorTag = tag } | ctor <- ctors | tag <- [0..] ] - pTok KBraceKet + pSym SBraceKet return $ DataDef { dataDefTypeName = nData , dataDefParams = bsParam @@ -47,11 +48,11 @@ -- | Parse a type parameter to a data type. pDataParam :: Ord n => Context n -> Parser n [Bind n] pDataParam c - = do pTok KRoundBra + = do pSym SRoundBra ns <- P.many1 pName pTokSP (KOp ":") k <- pType c - pTok KRoundKet + pSym SRoundKet return [BName n k | n <- ns] diff --git a/DDC/Core/Parser/Exp.hs b/DDC/Core/Parser/Exp.hs --- a/DDC/Core/Parser/Exp.hs +++ b/DDC/Core/Parser/Exp.hs @@ -16,9 +16,9 @@ import DDC.Core.Parser.Context import DDC.Core.Parser.Base import DDC.Core.Lexer.Tokens -import DDC.Base.Parser ((), SourcePos) -import qualified DDC.Base.Parser as P -import qualified DDC.Type.Compounds as T +import DDC.Control.Parser ((), SourcePos) +import qualified DDC.Control.Parser as P +import qualified DDC.Type.Exp.Simple as T import Control.Monad.Except @@ -29,76 +29,76 @@ = P.choice -- Level-0 lambda abstractions -- (λBIND.. . EXP) or (\BIND.. . EXP) - [ do sp <- P.choice [ pTokSP KLambda, pTokSP KBackSlash] + [ do sp <- P.choice [ pSym SLambda, pSym SBackSlash] bs <- liftM concat $ P.many1 (pBinds c) - pTok KDot + pSym SDot xBody <- pExp c return $ foldr (XLam sp) xBody bs -- Level-1 lambda abstractions. -- (ΛBINDS.. . EXP) or (/\BIND.. . EXP) - , do sp <- P.choice [ pTokSP KBigLambda, pTokSP KBigLambdaSlash] + , do sp <- P.choice [ pSym SBigLambda, pSym SBigLambdaSlash] bs <- liftM concat $ P.many1 (pBinds c) - pTok KDot + pSym SDot xBody <- pExp c return $ foldr (XLAM sp) xBody bs -- let expression , do (lts, sp) <- pLetsSP c - pTok KIn + pKey EIn x2 <- pExp c return $ XLet sp lts x2 -- do { STMTS } -- Sugar for a let-expression. - , do pTok KDo - pTok KBraceBra + , do pKey EDo + pSym SBraceBra xx <- pStmts c - pTok KBraceKet + pSym SBraceKet return $ xx -- case EXP of { ALTS } - , do sp <- pTokSP KCase + , do sp <- pKey ECase x <- pExp c - pTok KOf - pTok KBraceBra - alts <- P.sepEndBy1 (pAlt c) (pTok KSemiColon) - pTok KBraceKet + pKey EOf + pSym SBraceBra + alts <- P.sepEndBy1 (pAlt c) (pSym SSemiColon) + pSym SBraceKet return $ XCase sp x alts -- letcase PAT = EXP in EXP , do -- Sugar for a single-alternative case expression. - sp <- pTokSP KLetCase + sp <- pKey ELetCase p <- pPat c - pTok KEquals + pSym SEquals x1 <- pExp c - pTok KIn + pKey EIn x2 <- pExp c return $ XCase sp x1 [AAlt p x2] -- weakeff [TYPE] in EXP - , do sp <- pTokSP KWeakEff - pTok KSquareBra + , do sp <- pKey EWeakEff + pSym SSquareBra t <- pType c - pTok KSquareKet - pTok KIn + pSym SSquareKet + pKey EIn x <- pExp c return $ XCast sp (CastWeakenEffect t) x -- purify WITNESS in EXP - , do sp <- pTokSP KPurify + , do sp <- pKey EPurify w <- pWitness c - pTok KIn + pTok (KKeyword EIn) x <- pExp c return $ XCast sp (CastPurify w) x -- box EXP - , do sp <- pTokSP KBox + , do sp <- pKey EBox x <- pExp c return $ XCast sp CastBox x -- run EXP - , do sp <- pTokSP KRun + , do sp <- pKey ERun x <- pExp c return $ XCast sp CastRun x @@ -128,27 +128,27 @@ pArgSPs c = P.choice -- [TYPE] - [ do sp <- pTokSP KSquareBra + [ do sp <- pSym SSquareBra t <- pType c - pTok KSquareKet + pSym SSquareKet return [(XType sp t, sp)] -- [: TYPE0 TYPE0 ... :] - , do sp <- pTokSP KSquareColonBra + , do sp <- pSym SSquareColonBra ts <- P.many1 (pTypeAtom c) - pTok KSquareColonKet + pSym SSquareColonKet return [(XType sp t, sp) | t <- ts] -- {WITNESS} - , do sp <- pTokSP KBraceBra + , do sp <- pSym SBraceBra w <- pWitness c - pTok KBraceKet + pSym SBraceKet return [(XWitness sp w, sp)] -- {: WITNESS0 WITNESS0 ... :} - , do sp <- pTokSP KBraceColonBra + , do sp <- pSym SBraceColonBra ws <- P.many1 (pWitnessAtom c) - pTok KBraceColonKet + pSym SBraceColonKet return [(XWitness sp w, sp) | w <- ws] -- EXP0 @@ -175,36 +175,34 @@ pExpAtomSP c = P.choice -- (EXP2) - [ do sp <- pTokSP KRoundBra + [ do sp <- pSym SRoundBra t <- pExp c - pTok KRoundKet + pSym SRoundKet return (t, sp) -- The unit data constructor. - , do sp <- pTokSP KDaConUnit + , do sp <- pTokSP (KBuiltin BDaConUnit) return (XCon sp dcUnit, sp) -- Named algebraic constructors. - , do (con, sp) <- pConSP + , do (con, sp) <- pConSP return (XCon sp (DaConBound con), sp) -- Literals. -- The attached type is set to Bottom for now, which needs -- to be filled in later by the Spread transform. - , do (lit, sp) <- pLitSP - return (XCon sp (DaConPrim lit (T.tBot T.kData)), sp) - - , do (tx, sp) <- pStringSP - let Just mkString = contextMakeStringName c - let lit = mkString sp tx - return (XCon sp (DaConPrim lit (T.tBot T.kData)), sp) + , do ((lit, bPrim), sp) <- pLitSP + let Just mkLit = contextMakeLiteralName c + case mkLit sp lit bPrim of + Just name -> return (XCon sp (DaConPrim name (T.tBot T.kData)), sp) + Nothing -> P.unexpected "literal" -- Debruijn indices - , do (i, sp) <- pIndexSP + , do (i, sp) <- pIndexSP return (XVar sp (UIx i), sp) -- Variables - , do (var, sp) <- pVarSP + , do (var, sp) <- pVarSP return (XVar sp (UName var), sp) ] @@ -216,7 +214,7 @@ pAlt :: Ord n => Context n -> Parser n (Alt SourcePos n) pAlt c = do p <- pPat c - pTok KArrowDash + pSym SArrowDashRight x <- pExp c return $ AAlt p x @@ -226,18 +224,21 @@ => Context n -> Parser n (Pat n) pPat c = P.choice - [ -- Wildcard - do pTok KUnderscore + [ -- Wildcard Pattern: _ + do pSym SUnderscore return $ PDefault -- LIT , do -- The attached type is set to Bottom for now, which needs -- to be filled in later by the Spread transform. - nLit <- pLit - return $ PData (DaConPrim nLit (T.tBot T.kData)) [] + ((lit, bPrim), sp) <- pLitSP + let Just mkLit = contextMakeLiteralName c + case mkLit sp lit bPrim of + Just nLit -> return $ PData (DaConPrim nLit (T.tBot T.kData)) [] + _ -> P.unexpected "literal" -- Unit - , do pTok KDaConUnit + , do pTok (KBuiltin BDaConUnit) return $ PData dcUnit [] -- CON BIND BIND ... @@ -258,11 +259,11 @@ return [T.makeBindFromBinder b (T.tBot T.kData) | b <- bs] -- Binder with type, wrapped in parens. - , do pTok KRoundBra + , do pSym SRoundBra bs <- P.many1 pBinder pTok (KOp ":") t <- pType c - pTok KRoundKet + pSym SRoundKet return [T.makeBindFromBinder b t | b <- bs] ] @@ -275,17 +276,17 @@ pLetsSP c = P.choice [ -- non-recursive let. - do sp <- pTokSP KLet + do sp <- pTokSP (KKeyword ELet) (b1, x1) <- pLetBinding c return (LLet b1 x1, sp) -- recursive let. - , do sp <- pTokSP KLetRec + , do sp <- pTokSP (KKeyword ELetRec) P.choice -- Multiple bindings in braces - [ do pTok KBraceBra - lets <- P.sepEndBy1 (pLetBinding c) (pTok KSemiColon) - pTok KBraceKet + [ do pSym SBraceBra + lets <- P.sepEndBy1 (pLetBinding c) (pSym SSemiColon) + pSym SBraceKet return (LRec lets, sp) -- A single binding without braces. @@ -295,11 +296,13 @@ -- Private region binding. -- private BINDER+ (with { BINDER : TYPE ... })? in EXP - , do sp <- pTokSP KPrivate + , do sp <- pTokSP (KKeyword EPrivate) -- new private region names. brs <- P.manyTill pBinder - $ P.try $ P.lookAhead $ P.choice [pTok KIn, pTok KWith] + $ P.try $ P.lookAhead $ P.choice + [ pTok (KKeyword EIn) + , pTok (KKeyword EWith) ] let bs = map (flip T.makeBindFromBinder T.kRegion) brs @@ -309,16 +312,19 @@ -- Extend an existing region. -- extend BINDER+ using TYPE (with { BINDER : TYPE ...})? in EXP - , do sp <- pTokSP KExtend + , do sp <- pTokSP (KKeyword EExtend) -- parent region t <- pType c - pTok KUsing + pTok (KKeyword EUsing) -- new private region names. brs <- P.manyTill pBinder $ P.try $ P.lookAhead - $ P.choice [pTok KUsing, pTok KWith, pTok KIn] + $ P.choice + [ pTok (KKeyword EUsing) + , pTok (KKeyword EWith) + , pTok (KKeyword EIn) ] let bs = map (flip T.makeBindFromBinder T.kRegion) brs @@ -335,8 +341,8 @@ pLetWits c bs mParent = P.choice - [ do pTok KWith - pTok KBraceBra + [ do pKey EWith + pSym SBraceBra wits <- P.sepBy (P.choice [ -- Named witness binder. do b <- pBinder @@ -347,8 +353,8 @@ -- Ambient witness binding, use for capabilities. , do t <- pTypeApp c return $ BNone t ]) - (pTok KSemiColon) - pTok KBraceKet + (pSym SSemiColon) + pSym SBraceKet return (LPrivate bs mParent wits) , do return (LPrivate bs mParent []) @@ -367,9 +373,9 @@ P.choice [ do -- Binding with full type signature. -- BINDER : TYPE = EXP - pTok (KOp ":") + pTok (KOp ":") t <- pType c - pTok KEquals + pSym SEquals xBody <- pExp c return $ (T.makeBindFromBinder b t, xBody) @@ -379,7 +385,7 @@ -- This form can't be used with letrec as we can't use it -- to build the full type sig for the let-bound variable. -- BINDER = EXP - pTok KEquals + pSym SEquals xBody <- pExp c let t = T.tBot T.kData return $ (T.makeBindFromBinder b t, xBody) @@ -396,7 +402,7 @@ -- BINDER PARAM1 PARAM2 .. PARAMN : TYPE = EXP pTok (KOp ":") tBody <- pType c - sp <- pTokSP KEquals + sp <- pSym SEquals xBody <- pExp c let x = expOfParams sp ps xBody @@ -408,7 +414,7 @@ -- but we can create lambda abstractions with the given -- parameter types. -- BINDER PARAM1 PARAM2 .. PARAMN = EXP - , do sp <- pTokSP KEquals + , do sp <- pSym SEquals xBody <- pExp c let x = expOfParams sp ps xBody @@ -434,7 +440,7 @@ -- P.try $ do br <- pBinder - sp <- pTokSP KEquals + sp <- pSym SEquals x1 <- pExp c let t = T.tBot T.kData let b = T.makeBindFromBinder br t @@ -446,9 +452,9 @@ -- as a function name in a non-binding statement. , P.try $ do p <- pPat c - sp <- pTokSP KArrowDashLeft + sp <- pSym SArrowDashLeft x1 <- pExp c - pTok KElse + pTok (KKeyword EElse) x2 <- pExp c return $ StmtMatch sp p x1 x2 @@ -461,7 +467,7 @@ -- | Parse some statements. pStmts :: Ord n => Context n -> Parser n (Exp SourcePos n) pStmts c - = do stmts <- P.sepEndBy1 (pStmt c) (pTok KSemiColon) + = do stmts <- P.sepEndBy1 (pStmt c) (pSym SSemiColon) case makeStmts stmts of Nothing -> P.unexpected "do-block must end with a statement" Just x -> return x diff --git a/DDC/Core/Parser/ExportSpec.hs b/DDC/Core/Parser/ExportSpec.hs --- a/DDC/Core/Parser/ExportSpec.hs +++ b/DDC/Core/Parser/ExportSpec.hs @@ -8,14 +8,15 @@ import DDC.Core.Parser.Context import DDC.Core.Parser.Base import DDC.Core.Lexer.Tokens -import DDC.Base.Pretty +import DDC.Type.Exp.Simple +import DDC.Data.Pretty import Control.Monad -import qualified DDC.Base.Parser as P +import qualified DDC.Control.Parser as P -- An exported thing. data ExportSpec n - = ExportValue n (ExportSource n) + = ExportValue n (ExportSource n (Type n)) -- | Parse some export specifications. @@ -24,23 +25,28 @@ => Context n -> Parser n [ExportSpec n] pExportSpecs c - = do pTok KExport + = do pTok (KKeyword EExport) P.choice [ -- export value { (NAME :: TYPE)+ } - do P.choice [ pTok KValue, return () ] - pTok KBraceBra - specs <- P.sepEndBy1 (pExportValue c) (pTok KSemiColon) - pTok KBraceKet + 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 pTok KForeign + , do pKey EForeign dst <- liftM (renderIndent . ppr) pName - pTok KValue - pTok KBraceBra - specs <- P.sepEndBy1 (pExportForeignValue c dst) (pTok KSemiColon) - pTok KBraceKet + pKey EValue + pSym SBraceBra + specs <- P.sepEndBy1 (pExportForeignValue c dst) + (pSym SSemiColon) + pSym SBraceKet return specs ] diff --git a/DDC/Core/Parser/ImportSpec.hs b/DDC/Core/Parser/ImportSpec.hs --- a/DDC/Core/Parser/ImportSpec.hs +++ b/DDC/Core/Parser/ImportSpec.hs @@ -9,9 +9,10 @@ import DDC.Core.Parser.Base import DDC.Core.Parser.DataDef import DDC.Core.Lexer.Tokens -import DDC.Base.Pretty +import DDC.Type.Exp.Simple +import DDC.Data.Pretty import Control.Monad -import qualified DDC.Base.Parser as P +import qualified DDC.Control.Parser as P --------------------------------------------------------------------------------------------------- @@ -22,10 +23,20 @@ -- buckets if it wants to. -- data ImportSpec n - = ImportType n (ImportType n) - | ImportCap n (ImportCap n) - | ImportValue n (ImportValue n) - | ImportData (DataDef 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 @@ -37,45 +48,58 @@ pImportSpecs c = do -- import ... - pTok KImport + pTok (KKeyword EImport) P.choice [ -- data ... do def <- pDataDef c return [ ImportData def ] - -- import value { (NAME :: TYPE)+ } - , do P.choice [ pTok KValue, return () ] - pTok KBraceBra - specs <- P.sepEndBy1 (pImportValue c) (pTok KSemiColon) - pTok KBraceKet + -- 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 KForeign + , do pTok (KKeyword EForeign) src <- liftM (renderIndent . ppr) pName P.choice [ -- import foreign MODE type { (NAME : TYPE)+ } - do pTok KType - pTok KBraceBra - sigs <- P.sepEndBy1 (pImportForeignType c src) (pTok KSemiColon) - pTok KBraceKet - return sigs + do pKey EType + pSym SBraceBra + sigs <- P.sepEndBy1 (pImportForeignType c src) (pSym SSemiColon) + pSym SBraceKet + return sigs -- import foreign MODE capability { (NAME : TYPE)+ } - , do pTok KCapability - pTok KBraceBra - sigs <- P.sepEndBy1 (pImportForeignCap c src) (pTok KSemiColon) - pTok KBraceKet - return sigs + , do pKey ECapability + pSym SBraceBra + sigs <- P.sepEndBy1 (pImportForeignCap c src) (pSym SSemiColon) + pSym SBraceKet + return sigs -- import foreign MODE value { (NAME : TYPE)+ } - , do pTok KValue - pTok KBraceBra - sigs <- P.sepEndBy1 (pImportForeignValue c src) (pTok KSemiColon) - pTok KBraceKet - return sigs + , do pKey EValue + pSym SBraceBra + sigs <- P.sepEndBy1 (pImportForeignValue c src) (pSym SSemiColon) + pSym SBraceKet + return sigs ] ] P. "something to import" @@ -96,7 +120,7 @@ = do n <- pName pTokSP (KOp ":") k <- pType c - return $ ImportType n (ImportTypeAbstract k) + 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. @@ -104,7 +128,7 @@ = do n <- pName pTokSP (KOp ":") k <- pType c - return $ ImportType n (ImportTypeBoxed k) + return $ ImportForeignType n (ImportTypeBoxed k) | otherwise = P.unexpected "import mode for foreign type." @@ -123,13 +147,28 @@ = do n <- pName pTokSP (KOp ":") t <- pType c - return $ ImportCap n (ImportCapAbstract t) + 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. @@ -145,7 +184,7 @@ = do n <- pName pTokSP (KOp ":") t <- pType c - return (ImportValue n (ImportValueModule (ModuleName []) n t Nothing)) + return $ ImportForeignValue n (ImportValueModule (ModuleName []) n t Nothing) -- | Parse a foreign value import spec. @@ -159,11 +198,12 @@ pTokSP (KOp ":") k <- pType c - -- ISSUE #327: Allow external symbol to be specified - -- with foreign C imports and exports. + -- 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 $ ImportValue n (ImportValueSea symbol k) + return $ ImportForeignValue n (ImportValueSea symbol k) | otherwise = P.unexpected "import mode for foreign value." diff --git a/DDC/Core/Parser/Module.hs b/DDC/Core/Parser/Module.hs --- a/DDC/Core/Parser/Module.hs +++ b/DDC/Core/Parser/Module.hs @@ -12,11 +12,11 @@ import DDC.Core.Module import DDC.Core.Lexer.Tokens import DDC.Core.Exp.Annot -import DDC.Base.Pretty +import DDC.Data.Pretty import Data.Char import qualified Data.Map as Map -import qualified DDC.Base.Parser as P import qualified Data.Text as T +import qualified DDC.Control.Parser as P -- | Parse a core module. @@ -24,16 +24,17 @@ => Context n -> Parser n (Module P.SourcePos n) pModule c - = do sp <- pTokSP KModule + = 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 defsLocal = [def | HeadDataDef def <- heads ] + 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. @@ -41,8 +42,8 @@ = Map.fromList [ (n, (iTypes, iValues, iBoxes )) | HeadPragmaArity n iTypes iValues iBoxes <- heads ] - let attachAritySpec (ImportValue n (ImportValueModule mn v t _)) - = ImportValue n (ImportValueModule mn v t (Map.lookup n importArities)) + let attachAritySpec (ImportForeignValue n (ImportValueModule mn v t _)) + = ImportForeignValue n (ImportValueModule mn v t (Map.lookup n importArities)) attachAritySpec spec = spec @@ -55,10 +56,10 @@ -- If not, then it is a module header, which doesn't need bindings. (lts, isHeader) <- P.choice - [ do pTok KWith + [ do pTok (KKeyword EWith) -- LET;+ - lts <- P.sepBy1 (pLetsSP c) (pTok KIn) + lts <- P.sepBy1 (pLetsSP c) (pTok (KKeyword EIn)) return (lts, False) , do return ([], True) ] @@ -71,22 +72,34 @@ { moduleName = name , moduleIsHeader = isHeader , moduleExportTypes = [] - , moduleExportValues = [(n, s) | ExportValue n s <- exportSpecs] - , moduleImportTypes = [(n, s) | ImportType n s <- importSpecs] - , moduleImportCaps = [(n, s) | ImportCap n s <- importSpecs] - , moduleImportValues = [(n, s) | ImportValue n s <- importSpecs] - , moduleImportDataDefs = [def | ImportData def <- importSpecs] - , moduleDataDefsLocal = defsLocal + , 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) - -- | Number of type parameters, value parameters, and boxes for some super. + -- | 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 @@ -96,18 +109,35 @@ pHeadDecl ctx = P.choice - [ do def <- pDataDef ctx - return $ HeadDataDef def - - , do imports <- pImportSpecs ctx + [ do imports <- pImportSpecs ctx return $ HeadImportSpecs imports , do exports <- pExportSpecs ctx return $ HeadExportSpecs exports - , do pHeadPragma ctx ] + , 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 @@ -119,10 +149,9 @@ | all isDigit strTypes , all isDigit strValues , all isDigit strBoxes - , Just makeStringName <- contextMakeStringName ctx - -> return $ HeadPragmaArity - (makeStringName sp (T.pack name)) + , Just makeLitName <- contextMakeLiteralName ctx + , Just n <- makeLitName sp (LString (T.pack name)) True + -> return $ HeadPragmaArity n (read strTypes) (read strValues) (read strBoxes) _ -> P.unexpected $ "pragma " ++ "{-# " ++ T.unpack txt ++ "#-}" - diff --git a/DDC/Core/Parser/Param.hs b/DDC/Core/Parser/Param.hs --- a/DDC/Core/Parser/Param.hs +++ b/DDC/Core/Parser/Param.hs @@ -9,10 +9,10 @@ import DDC.Core.Exp import DDC.Core.Parser.Type import DDC.Core.Parser.Context -import DDC.Core.Parser.Base (Parser) +import DDC.Core.Parser.Base import DDC.Core.Lexer.Tokens -import qualified DDC.Base.Parser as P -import qualified DDC.Type.Compounds as T +import qualified DDC.Type.Exp.Simple as T +import qualified DDC.Control.Parser as P -- | Specification of a function parameter. @@ -104,39 +104,39 @@ = P.choice -- Type parameter -- [BIND1 BIND2 .. BINDN : TYPE] - [ do pTok KSquareBra + [ do pSym SSquareBra bs <- P.many1 pBinder pTok (KOp ":") t <- pType c - pTok KSquareKet + pSym SSquareKet return [ ParamType b | b <- zipWith T.makeBindFromBinder bs (repeat t)] -- Witness parameter -- {BIND : TYPE} - , do pTok KBraceBra + , do pSym SBraceBra b <- pBinder pTok (KOp ":") t <- pType c - pTok KBraceKet + pSym SBraceKet return [ ParamWitness $ T.makeBindFromBinder b t] -- Value parameter with type annotations. -- (BIND1 BIND2 .. BINDN : TYPE) -- (BIND1 BIND2 .. BINDN : TYPE) { TYPE | TYPE } - , do pTok KRoundBra + , do pSym SRoundBra bs <- P.many1 pBinder pTok (KOp ":") t <- pType c - pTok KRoundKet + pSym SRoundKet (eff, clo) <- P.choice - [ do pTok KBraceBra + [ do pSym SBraceBra eff' <- pType c - pTok KBar + pSym SBar clo' <- pType c - pTok KBraceKet + pSym SBraceKet return (eff', clo') , do return (T.tBot T.kEffect, T.tBot T.kClosure) ] diff --git a/DDC/Core/Parser/Type.hs b/DDC/Core/Parser/Type.hs --- a/DDC/Core/Parser/Type.hs +++ b/DDC/Core/Parser/Type.hs @@ -12,10 +12,9 @@ import DDC.Core.Parser.Context import DDC.Core.Parser.Base import DDC.Core.Lexer.Tokens -import DDC.Type.Exp -import DDC.Type.Compounds -import DDC.Base.Parser (()) -import qualified DDC.Base.Parser as P +import DDC.Type.Exp.Simple +import DDC.Control.Parser (()) +import qualified DDC.Control.Parser as P import qualified DDC.Type.Sum as TS @@ -54,11 +53,11 @@ return $ RName v -- Anonymous binders. - , do pTok KHat + , do pSym SHat return $ RAnon -- Vacant binders. - , do pTok KUnderscore + , do pSym SUnderscore return $ RNone ] "a binder" @@ -69,14 +68,26 @@ => Context n -> Parser n (Type n) pTypeForall c = P.choice - [ -- Universal quantification. + [ -- Type abstraction. + do pSym SLambda + bs <- P.many1 pBinder + pTok (KOp ":") + k <- pTypeSum c + pSym SDot + + tBody <- pTypeForall c + + return $ foldr TAbs tBody + $ map (\b -> makeBindFromBinder b k) bs + + -- Universal quantification. -- [v1 v1 ... vn : T1]. T2 - do pTok KSquareBra + , do pSym SSquareBra bs <- P.many1 pBinder pTok (KOp ":") k <- pTypeSum c - pTok KSquareKet - pTok KDot + pSym SSquareKet + pSym SDot body <- pTypeForall c @@ -97,17 +108,17 @@ = do t1 <- pTypeApp c P.choice [ -- T1 ~> T2 - do pTok KArrowTilde + do pSym SArrowTilde t2 <- pTypeForall c return $ TApp (TApp (TCon (TyConKind KiConFun)) t1) t2 -- T1 => T2 - , do pTok KArrowEquals + , do pSym SArrowEquals t2 <- pTypeForall c return $ TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2 -- T1 -> T2 - , do pTok KArrowDash + , do pSym SArrowDashRight t2 <- pTypeForall c return $ t1 `tFun` t2 @@ -146,9 +157,9 @@ return (TCon $ TyConSpec TcConFun) -- (TYPE2) - , do pTok KRoundBra + , do pSym SRoundBra t <- pTypeSum c - pTok KRoundKet + pSym SRoundKet return t -- Named type constructors @@ -168,8 +179,8 @@ return $ TCon tc -- Bottoms. - , do pTokAs KBotEffect (tBot kEffect) - , do pTokAs KBotClosure (tBot kClosure) + , do pTokAs (KBuiltin BPure) (tBot kEffect) + , do pTokAs (KBuiltin BEmpty) (tBot kClosure) -- Bound occurrence of a variable. -- We don't know the kind of this variable yet, so fill in the @@ -189,32 +200,32 @@ pSoCon :: Parser n SoCon pSoCon = P.pTokMaybe f "a sort constructor" - where f (KA (KSoConBuiltin c)) = Just c - f _ = Nothing + where f (KA (KBuiltin (BSoCon c))) = Just c + f _ = Nothing -- | Parse a builtin kind constructor. pKiCon :: Parser n KiCon pKiCon = P.pTokMaybe f "a kind constructor" - where f (KA (KKiConBuiltin c)) = Just c - f _ = Nothing + where f (KA (KBuiltin (BKiCon c))) = Just c + f _ = Nothing -- | Parse a builtin type constructor. pTcCon :: Parser n TcCon pTcCon = P.pTokMaybe f "a type constructor" - where f (KA (KTcConBuiltin c)) = Just c - f _ = Nothing + where f (KA (KBuiltin (BTcCon c))) = Just c + f _ = Nothing -- | Parse a builtin witness type constructor. pTwCon :: Parser n TwCon pTwCon = P.pTokMaybe f "a witness constructor" - where f (KA (KTwConBuiltin c)) = Just c - f _ = Nothing + where f (KA (KBuiltin (BTwCon c))) = Just c + f _ = Nothing -- | Parse a user defined type constructor. diff --git a/DDC/Core/Parser/Witness.hs b/DDC/Core/Parser/Witness.hs --- a/DDC/Core/Parser/Witness.hs +++ b/DDC/Core/Parser/Witness.hs @@ -9,9 +9,9 @@ import DDC.Core.Parser.Base import DDC.Core.Lexer.Tokens import DDC.Core.Exp -import DDC.Base.Parser ((), SourcePos) -import qualified DDC.Base.Parser as P -import qualified DDC.Type.Compounds as T +import DDC.Control.Parser ((), SourcePos) +import qualified DDC.Control.Parser as P +import qualified DDC.Type.Exp.Simple as T import Control.Monad @@ -56,9 +56,9 @@ pWitnessArgSP c = P.choice [ -- [TYPE] - do sp <- pTokSP KSquareBra + do sp <- pSym SSquareBra t <- pType c - pTok KSquareKet + pSym SSquareKet return (WType sp t, sp) -- WITNESS @@ -84,9 +84,9 @@ pWitnessAtomSP c = P.choice -- (WITNESS) - [ do sp <- pTokSP KRoundBra + [ do sp <- pSym SRoundBra w <- pWitness c - pTok KRoundKet + pSym SRoundKet return (w, sp) -- Named constructors diff --git a/DDC/Core/Pretty.hs b/DDC/Core/Pretty.hs --- a/DDC/Core/Pretty.hs +++ b/DDC/Core/Pretty.hs @@ -2,19 +2,21 @@ -- | Pretty printing for core modules and expressions. module DDC.Core.Pretty - ( module DDC.Type.Pretty - , module DDC.Base.Pretty + ( module DDC.Type.Exp.Simple.Pretty + , module DDC.Data.Pretty , PrettyMode (..) - , pprExportType - , pprExportValue - , pprImportType - , pprImportValue) + , pprExportType, pprExportValue + , pprImportType, pprImportValue + , pprDataDef, pprDataCtor + , pprTypeDef) where import DDC.Core.Module -import DDC.Core.Exp.Annot +import DDC.Core.Exp.Annot.Exp +import DDC.Core.Exp.Annot.Pretty +import DDC.Core.Exp.Annot.Compounds +import DDC.Type.Exp.Simple.Pretty import DDC.Type.DataDef -import DDC.Type.Pretty -import DDC.Base.Pretty +import DDC.Data.Pretty import Data.List import Prelude hiding ((<$>)) @@ -48,7 +50,9 @@ , moduleImportCaps = importCaps , moduleImportValues = importValues , moduleImportDataDefs = importData + , moduleImportTypeDefs = importType , moduleDataDefsLocal = localData + , moduleTypeDefsLocal = localType , moduleBody = body } = {-# SCC "ppr[Module]" #-} let @@ -81,7 +85,7 @@ | modeModuleSuppressImports mode = empty - -- If there are no imports or exports then suppress printint. + -- If there are no imports or exports then suppress printing. | null exportTypes, null exportValues , null importTypes, null importCaps, null importValues = empty @@ -94,19 +98,32 @@ docsDataImport | null importData = empty | otherwise - = line <> vsep (map (\i -> text "import" <+> (ppr i)) $ importData) + = line <> vsep (map (\i -> text "import" <+> ppr i) $ importData) docsDataLocal | null localData = empty | otherwise = line <> vsep (map ppr localData) - + + -- Type Definitions ----- + docsTypeImport + | null importType = empty + | otherwise + = line <> vsep (map (\i -> text "import" <+> pprTypeDef i) $ importType) + + docsTypeLocal + | null localType = empty + | otherwise + = line <> vsep (map pprTypeDef localType) + pprLts = pprModePrec (modeModuleLets mode) 0 in text "module" <+> ppr name <+> docsImportsExports <> docsDataImport <> docsDataLocal + <> docsTypeImport + <> docsTypeLocal <> (case lts of [] -> empty [LRec[]] -> empty @@ -115,7 +132,7 @@ -- Exports ---------------------------------------------------------------------------------------- -- | Pretty print an exported type definition. -pprExportType :: (Pretty n, Eq n) => (n, ExportSource n) -> Doc +pprExportType :: (Pretty n, Pretty t) => (n, ExportSource n t) -> Doc pprExportType (n, esrc) = case esrc of ExportSourceLocal _n k @@ -126,7 +143,7 @@ -- | Pretty print an exported value definition. -pprExportValue :: (Pretty n, Eq n) => (n, ExportSource n) -> Doc +pprExportValue :: (Pretty n, Pretty t) => (n, ExportSource n t) -> Doc pprExportValue (n, esrc) = case esrc of ExportSourceLocal _n t @@ -138,7 +155,7 @@ -- Imports ---------------------------------------------------------------------------------------- -- | Pretty print a type import. -pprImportType :: (Pretty n, Eq n) => (n, ImportType n) -> Doc +pprImportType :: (Pretty n, Pretty t) => (n, ImportType n t) -> Doc pprImportType (n, isrc) = case isrc of ImportTypeAbstract k @@ -153,7 +170,7 @@ -- | Pretty print a capability import. -pprImportCap :: (Pretty n, Eq n) => (n, ImportCap n) -> Doc +pprImportCap :: (Pretty n, Pretty t) => (n, ImportCap n t) -> Doc pprImportCap (n, isrc) = case isrc of ImportCapAbstract t @@ -163,7 +180,7 @@ -- | Pretty print a value import. -pprImportValue :: (Pretty n, Eq n) => (n, ImportValue n) -> Doc +pprImportValue :: (Pretty n, Pretty t) => (n, ImportValue n t) -> Doc pprImportValue (n, isrc) = case isrc of ImportValueModule _mn _nSrc t Nothing @@ -186,9 +203,13 @@ -- DataDef ---------------------------------------------------------------------------------------- instance (Pretty n, Eq n) => Pretty (DataDef n) where - pprPrec _ def - = {-# SCC "ppr[DataDef]" #-} - (text "data" + pprPrec _ def = pprDataDef def + + +-- | Pretty print a data type definition. +pprDataDef :: (Pretty n, Eq n) => DataDef n -> Doc +pprDataDef def + = (text "data" <+> hsep ( ppr (dataDefTypeName def) : map (parens . ppr) (dataDefParams def)) <+> text "where" @@ -200,326 +221,31 @@ Nothing -> text "LARGE") - <> line - <> rbrace - <> line + <> line <> rbrace <> line -- DataCtor --------------------------------------------------------------------------------------- instance (Pretty n, Eq n) => Pretty (DataCtor n) where - pprPrec _ ctor + pprPrec _ def = pprDataCtor def + + +-- | Pretty print a data constructor definition. +pprDataCtor :: (Pretty n, Eq n) => DataCtor n -> Doc +pprDataCtor ctor = ppr (dataCtorName ctor) <+> text ":" <+> (hsep $ punctuate (text " ->") $ (map (pprPrec 6) - ( dataCtorFieldTypes ctor + ( dataCtorFieldTypes ctor ++ [dataCtorResultType ctor]))) --- Exp -------------------------------------------------------------------------------------------- -instance (Pretty n, Eq n) => Pretty (Exp a n) where - data PrettyMode (Exp a n) - = PrettyModeExp - { modeExpLets :: PrettyMode (Lets a n) - , modeExpAlt :: PrettyMode (Alt a n) - - -- Display types on primitive variables. - , modeExpVarTypes :: Bool - - -- Display types on primitive constructors. - , modeExpConTypes :: Bool - - -- Use 'letcase' for single alternative case expressions. - , modeExpUseLetCase :: Bool } - - - pprDefaultMode - = PrettyModeExp - { modeExpLets = pprDefaultMode - , modeExpAlt = pprDefaultMode - , modeExpConTypes = False - , modeExpVarTypes = False - , modeExpUseLetCase = False } - - - pprModePrec mode d xx - = let pprX = pprModePrec mode 0 - pprLts = pprModePrec (modeExpLets mode) 0 - pprAlt = pprModePrec (modeExpAlt mode) 0 - in case xx of - - XVar _ u - | modeExpVarTypes mode - , Just t <- takeTypeOfBound u - -> parens $ ppr u <> text " : " <> ppr t - - | otherwise - -> ppr u - - XCon _ dc - | modeExpConTypes mode - , Just t <- takeTypeOfDaCon dc - -> parens $ ppr dc <> text " : " <> ppr t - - | otherwise - -> ppr dc - - XLAM{} - -> let Just (bs, xBody) = takeXLAMs xx - groups = partitionBindsByType bs - in pprParen' (d > 1) - $ (cat $ map (pprBinderGroup (text "Λ")) groups) - <> (if isXLAM xBody then empty - else if isXLam xBody then line - 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) 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 dBind = if isBot (typeOfBind b) - || modeLetsSuppressTypes mode - then ppr (binderOfBind b) - else ppr b - in text "let" - <+> align ( dBind - <> nest 2 ( breakWhen (not $ isSimpleX x) - <> text "=" <+> align (pprX x))) - - LRec bxs - -> let pprLetRecBind (b, x) - = ppr (binderOfBind b) - <+> text ":" - <+> ppr (typeOfBind b) - <> nest 2 ( breakWhen (not $ isSimpleX x) - <> text "=" <+> align (pprX x)) - - in (nest 2 $ text "letrec" - <+> lbrace - <> ( line - <> (vcat $ punctuate (semi <> line) - $ map pprLetRecBind bxs))) - <$> rbrace - - LPrivate bs Nothing [] - -> text "private" - <+> (hcat $ punctuate space (map (ppr . binderOfBind) bs)) - - LPrivate bs Nothing bws - -> text "private" - <+> (hcat $ punctuate space (map (ppr . binderOfBind) bs)) - <+> text "with" - <+> braces (cat $ punctuate (text "; ") $ map pprWitBind bws) - - LPrivate bs (Just parent) [] - -> text "extend" - <+> ppr parent - <+> text "using" - <+> (hcat $ punctuate space (map (ppr . binderOfBind) bs)) - - LPrivate bs (Just parent) bws - -> text "extend" - <+> ppr parent - <+> text "using" - <+> (hcat $ punctuate space (map (ppr . binderOfBind) bs)) - <+> text "with" - <+> braces (cat $ punctuate (text "; ") $ map pprWitBind bws) - - --- | 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 - +-- TypeDef ----------------------------------------------------------------------------------------- +-- | Pretty print a type definition. +pprTypeDef :: (Pretty n, Eq n) => (n, (Kind n, Type n)) -> Doc +pprTypeDef (n, (k, t)) + = text "type" <+> ppr n + <+> text ":" <+> ppr k + <+> text "=" <+> ppr t + <> semi <> line --- | Wrap a `Doc` in parens if the predicate is true. -pprParen' :: Bool -> Doc -> Doc -pprParen' b c - = if b then parens' c - else c diff --git a/DDC/Core/Transform/Annotate.hs b/DDC/Core/Transform/Annotate.hs deleted file mode 100644 --- a/DDC/Core/Transform/Annotate.hs +++ /dev/null @@ -1,88 +0,0 @@ - -module DDC.Core.Transform.Annotate - (Annotate (..)) -where -import qualified DDC.Core.Exp.Annot.Exp as A -import qualified DDC.Core.Exp.Simple.Exp as S - - --- | Convert the `Simple` version of the AST to the `Annot` version, --- using a the provided default annotation value. -class Annotate - (c1 :: * -> * -> *) - (c2 :: * -> * -> *) | c1 -> c2 - where - annotate :: a -> c1 a n -> c2 a n - - -instance Annotate S.Exp A.Exp where - annotate def xx - = let down = annotate def - in case xx of - S.XAnnot _ (S.XAnnot a x) -> down (S.XAnnot a x) - S.XAnnot a (S.XVar u) -> A.XVar a u - S.XAnnot a (S.XCon dc) -> A.XCon a dc - S.XAnnot a (S.XLAM b x) -> A.XLAM a b (down x) - S.XAnnot a (S.XLam b x) -> A.XLam a b (down x) - S.XAnnot a (S.XApp x1 x2) -> A.XApp a (down x1) (down x2) - S.XAnnot a (S.XLet lts x) -> A.XLet a (down lts) (down x) - S.XAnnot a (S.XCase x alts) -> A.XCase a (down x) (map down alts) - S.XAnnot a (S.XCast c x) -> A.XCast a (down c) (down x) - S.XAnnot a (S.XType t) -> A.XType a t - S.XAnnot a (S.XWitness w) -> A.XWitness a (down w) - - S.XVar u -> A.XVar def u - S.XCon dc -> A.XCon def dc - S.XLAM b x -> A.XLAM def b (down x) - S.XLam b x -> A.XLam def b (down x) - S.XApp x1 x2 -> A.XApp def (down x1) (down x2) - S.XLet lts x -> A.XLet def (down lts) (down x) - S.XCase x alts -> A.XCase def (down x) (map down alts) - S.XCast c x -> A.XCast def (down c) (down x) - S.XType t -> A.XType def t - S.XWitness w -> A.XWitness def (down w) - - -instance Annotate S.Cast A.Cast where - annotate def cc - = let down = annotate def - in case cc of - S.CastWeakenEffect eff -> A.CastWeakenEffect eff - S.CastPurify w -> A.CastPurify (down w) - S.CastBox -> A.CastBox - S.CastRun -> A.CastRun - - -instance Annotate S.Lets A.Lets where - annotate def lts - = let down = annotate def - in case lts of - S.LLet b x -> A.LLet b (down x) - S.LRec bxs -> A.LRec [(b, down x) | (b, x) <- bxs] - S.LPrivate bks mT bts -> A.LPrivate bks mT bts - - -instance Annotate S.Alt A.Alt where - annotate def alt - = let down = annotate def - in case alt of - S.AAlt S.PDefault x -> A.AAlt A.PDefault (down x) - S.AAlt (S.PData dc bs) x -> A.AAlt (A.PData dc bs) (down x) - - -instance Annotate S.Witness A.Witness where - annotate def wit - = let down = annotate def - in case wit of - S.WAnnot _ (S.WAnnot a x) -> down (S.WAnnot a x) - S.WAnnot a (S.WVar u) -> A.WVar a u - S.WAnnot a (S.WCon wc) -> A.WCon a wc - S.WAnnot a (S.WApp w1 w2) -> A.WApp a (down w1) (down w2) - S.WAnnot a (S.WType t) -> A.WType a t - - S.WVar u -> A.WVar def u - S.WCon dc -> A.WCon def dc - S.WApp x1 x2 -> A.WApp def (down x1) (down x2) - S.WType t -> A.WType def t - - diff --git a/DDC/Core/Transform/Deannotate.hs b/DDC/Core/Transform/Deannotate.hs deleted file mode 100644 --- a/DDC/Core/Transform/Deannotate.hs +++ /dev/null @@ -1,75 +0,0 @@ - -module DDC.Core.Transform.Deannotate - (Deannotate(..)) -where -import qualified DDC.Core.Exp.Annot.Exp as A -import qualified DDC.Core.Exp.Simple.Exp as S - - --- | Convert the `Annot` version of the AST to the `Simple` version, --- using the provided function to decide when to keep the annotation. -class Deannotate - (c1 :: * -> * -> *) - (c2 :: * -> * -> *) | c1 -> c2 - where - deannotate :: (a -> Maybe a) -> c1 a n -> c2 a n - - -instance Deannotate A.Exp S.Exp where - deannotate f xx - = let down = deannotate f - wrap a x = case f a of - Nothing -> x - Just a' -> S.XAnnot a' x - in case xx of - A.XVar a u -> wrap a (S.XVar u) - A.XCon a dc -> wrap a (S.XCon dc) - A.XLAM a b x -> wrap a (S.XLAM b (down x)) - A.XLam a b x -> wrap a (S.XLam b (down x)) - A.XApp a x1 x2 -> wrap a (S.XApp (down x1) (down x2)) - A.XLet a lts x2 -> wrap a (S.XLet (down lts) (down x2)) - A.XCase a x alts -> wrap a (S.XCase (down x) (map down alts)) - A.XCast a cc x -> wrap a (S.XCast (down cc) (down x)) - A.XType a t -> wrap a (S.XType t) - A.XWitness a w -> wrap a (S.XWitness (down w)) - - -instance Deannotate A.Lets S.Lets where - deannotate f lts - = let down = deannotate f - in case lts of - A.LLet b x -> S.LLet b (down x) - A.LRec bxs -> S.LRec [(b, down x) | (b, x) <- bxs] - A.LPrivate bks mt bts -> S.LPrivate bks mt bts - - -instance Deannotate A.Alt S.Alt where - deannotate f aa - = case aa of - A.AAlt A.PDefault x -> S.AAlt S.PDefault (deannotate f x) - A.AAlt (A.PData dc bs) x -> S.AAlt (S.PData dc bs) (deannotate f x) - - -instance Deannotate A.Witness S.Witness where - deannotate f ww - = let down = deannotate f - wrap a x = case f a of - Nothing -> x - Just a' -> S.WAnnot a' x - in case ww of - A.WVar a u -> wrap a (S.WVar u) - A.WCon a wc -> wrap a (S.WCon wc) - A.WApp a w1 w2 -> wrap a (S.WApp (down w1) (down w2)) - A.WType a t -> wrap a (S.WType t) - - -instance Deannotate A.Cast S.Cast where - deannotate f cc - = let down = deannotate f - in case cc of - A.CastWeakenEffect e -> S.CastWeakenEffect e - A.CastPurify w -> S.CastPurify (down w) - A.CastBox -> S.CastBox - A.CastRun -> S.CastRun - - diff --git a/DDC/Core/Transform/Reannotate.hs b/DDC/Core/Transform/Reannotate.hs --- a/DDC/Core/Transform/Reannotate.hs +++ b/DDC/Core/Transform/Reannotate.hs @@ -20,16 +20,16 @@ instance Reannotate Module where reannotateM f (ModuleCore name isHeader - exportKinds exportTypes - importKinds importCaps importTypes importDataDefs - dataDefsLocal + 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 - dataDefsLocal + importKinds importCaps importTypes importDataDefs importTypeDefs + dataDefsLocal typeDefsLocal body' 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 @@ -33,33 +33,41 @@ = moduleIsHeader mm , moduleExportTypes - = map (liftSnd $ spreadT kenv) + = map (liftSnd $ spreadExportSourceT kenv) $ moduleExportTypes mm , moduleExportValues - = map (liftSnd $ spreadT kenv) + = map (liftSnd $ spreadExportSourceT kenv) $ moduleExportValues mm , moduleImportTypes - = map (liftSnd $ spreadX kenv tenv) + = map (liftSnd $ spreadImportTypeT kenv tenv) $ moduleImportTypes mm , moduleImportCaps - = map (liftSnd $ spreadX kenv tenv) + = map (liftSnd $ spreadImportCapX kenv tenv) $ moduleImportCaps mm , moduleImportValues - = map (liftSnd $ spreadX kenv tenv) + = 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 @@ -67,8 +75,7 @@ --------------------------------------------------------------------------------------------------- -instance SpreadT ExportSource where - spreadT kenv esrc +spreadExportSourceT kenv esrc = case esrc of ExportSourceLocal n t -> ExportSourceLocal n (spreadT kenv t) @@ -78,8 +85,7 @@ --------------------------------------------------------------------------------------------------- -instance SpreadX ImportType where - spreadX kenv _tenv isrc +spreadImportTypeT kenv _tenv isrc = case isrc of ImportTypeAbstract t -> ImportTypeAbstract (spreadT kenv t) @@ -89,16 +95,14 @@ --------------------------------------------------------------------------------------------------- -instance SpreadX ImportCap where - spreadX kenv _tenv isrc +spreadImportCapX kenv _tenv isrc = case isrc of ImportCapAbstract t -> ImportCapAbstract (spreadT kenv t) --------------------------------------------------------------------------------------------------- -instance SpreadX ImportValue where - spreadX kenv _tenv isrc +spreadImportValueX kenv _tenv isrc = case isrc of ImportValueModule mn n t mArity -> ImportValueModule mn n (spreadT kenv t) mArity @@ -114,7 +118,7 @@ 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 @@ -138,8 +142,7 @@ --------------------------------------------------------------------------------------------------- -instance SpreadX DaCon where - spreadX _kenv tenv dc +spreadDaCon _kenv tenv dc = case dc of DaConUnit -> dc @@ -178,7 +181,7 @@ = let down x = spreadX kenv tenv x in case pat of PDefault -> PDefault - PData u bs -> PData (down u) (map down bs) + PData u bs -> PData (spreadDaCon kenv tenv u) (map down bs) --------------------------------------------------------------------------------------------------- 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 @@ -12,7 +12,7 @@ where import DDC.Core.Collect import DDC.Core.Exp.Annot.Exp -import DDC.Type.Compounds +import DDC.Type.Exp.Simple import DDC.Type.Transform.SubstituteT import DDC.Type.Transform.Rename import Data.Maybe 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 @@ -13,7 +13,7 @@ import DDC.Core.Collect import DDC.Core.Transform.Rename import DDC.Core.Transform.BoundX -import DDC.Type.Compounds +import DDC.Type.Exp.Simple import Data.Maybe import qualified DDC.Type.Env as Env import qualified Data.Set as Set 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 @@ -14,11 +14,11 @@ import DDC.Core.Exp.Annot.Exp import DDC.Core.Collect import DDC.Core.Transform.BoundX -import DDC.Type.Compounds import DDC.Core.Transform.SubstituteWX import DDC.Core.Transform.SubstituteTX import DDC.Type.Transform.SubstituteT import DDC.Type.Transform.Rename +import DDC.Type.Exp.Simple import Data.Maybe import qualified DDC.Type.Env as Env import qualified Data.Set as Set diff --git a/DDC/Data/Canned.hs b/DDC/Data/Canned.hs new file mode 100644 --- /dev/null +++ b/DDC/Data/Canned.hs @@ -0,0 +1,13 @@ + +module DDC.Data.Canned + (Canned(..)) +where + +-- | This function has a show instance that prints \"CANNED\" for any contained +-- type. We use it to wrap functional fields in data types that we still want +-- to derive Show instances for. +data Canned a + = Canned a + +instance Show (Canned a) where + show _ = "CANNED" diff --git a/DDC/Data/Env.hs b/DDC/Data/Env.hs new file mode 100644 --- /dev/null +++ b/DDC/Data/Env.hs @@ -0,0 +1,174 @@ + +-- | Generic environment that handles both named and anonymous +-- de-bruijn binders. +module DDC.Data.Env + ( -- * Types + Bind (..) + , Bound (..) + , Env (..) + + -- * Conversion + , fromList + , fromNameList + , fromNameMap + + -- * Constructors + , empty + , singleton + , extend, extends + , union, unions + + -- * Lookup + , member + , lookup + , lookupName, lookupIx + , depth) +where +import Data.Maybe +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import qualified Prelude as P +import Prelude hiding (lookup) + + +------------------------------------------------------------------------------- +-- | A binding occurrence of a variable. +data Bind n + -- | No binding, or alternatively, bind a fresh name that has + -- no bound uses. + = BNone + + -- | Anonymous binder. + | BAnon + + -- | Named binder. + | BName !n + deriving (Eq, Ord, Show) + + +-- | A bound occurrence of a variable. +data Bound n + -- | Index an anonymous binder. + = UIx !Int + + -- | Named variable. + | UName !n + deriving (Eq, Ord, Show) + + +-- | Generic environment that maps a variable to a thing of type @a@. +data Env n a + = Env + { -- | Named things. + envMap :: !(Map n a) + + -- | Anonymous things. + , envStack :: ![a] + + -- | Length of the stack. + , envStackLength :: !Int } + + +------------------------------------------------------------------------------- +-- | Convert a list of `Bind`s to an environment. +fromList :: Ord n => [(Bind n, a)] -> Env n a +fromList bs + = foldr (uncurry extend) empty bs + + +-- | Convert a list of `Bind`s to an environment. +fromNameList :: Ord n => [(n, a)] -> Env n a +fromNameList bs + = foldr (uncurry extend) empty + $ [(BName n, x) | (n, x) <- bs ] + + +-- | Convert a map of things to an environment. +fromNameMap :: Map n a -> Env n a +fromNameMap m + = empty { envMap = m } + + +--------------------------------------------------------------------------------- +-- | An empty environment, with nothing in it. +empty :: Env n a +empty = Env + { envMap = Map.empty + , envStack = [] + , envStackLength = 0 } + + +-- | Construct a singleton environment. +singleton :: Ord n => Bind n -> a -> Env n a +singleton b x + = extend b x empty + + +-- | Extend an environment with a new binding. +-- Replaces bindings with the same name already in the environment. +extend :: Ord n => Bind n -> a -> Env n a -> Env n a +extend bb x env + = case bb of + BNone{} -> env + + BAnon -> env { envStack = x : envStack env + , envStackLength = envStackLength env + 1 } + + BName n -> env { envMap = Map.insert n x (envMap env) } + + +-- | Extend an environment with a list of new bindings. +-- Replaces bindings with the same name already in the environment. +extends :: Ord n => [(Bind n, a)] -> Env n a -> Env n a +extends bs env + = foldl (flip (uncurry extend)) env bs + + +-- | Combine two environments. +-- If both environments have a binding with the same name, +-- then the one in the second environment takes preference. +union :: Ord n => Env n a -> Env n a -> Env n a +union env1 env2 + = Env + { envMap = envMap env1 `Map.union` envMap env2 + , envStack = envStack env2 ++ envStack env1 + , envStackLength = envStackLength env2 + envStackLength env1 } + + +-- | Combine multiple environments, +-- with the latter ones taking preference. +unions :: Ord n => [Env n a] -> Env n a +unions envs + = foldr union empty envs + + +-- | Check whether a bound variable is present in an environment. +member :: Ord n => Bound n -> Env n a -> Bool +member uu env + = isJust $ lookup uu env + + +-- | Lookup a bound variable from an environment. +lookup :: Ord n => Bound n -> Env n a -> Maybe a +lookup uu env + = case uu of + UIx i -> P.lookup i (zip [0..] (envStack env)) + UName n -> Map.lookup n (envMap env) + + +-- | Lookup a value from the environment based on its name. +lookupName :: Ord n => n -> Env n a -> Maybe a +lookupName n env + = Map.lookup n (envMap env) + + +-- | Lookup a value from the environment based on its index. +lookupIx :: Ord n => Int -> Env n a -> Maybe a +lookupIx ix env + = P.lookup ix (zip [0..] (envStack env)) + + +-- | Yield the total depth of the anonymous stack. +depth :: Env n a -> Int +depth env = envStackLength env + diff --git a/DDC/Data/ListUtils.hs b/DDC/Data/ListUtils.hs new file mode 100644 --- /dev/null +++ b/DDC/Data/ListUtils.hs @@ -0,0 +1,75 @@ + +-- | Replacements for unhelpful Haskell list functions. +-- If the standard versions are passed an empty list then we don't +-- get a proper source location. +module DDC.Data.ListUtils + ( takeHead + , takeTail + , takeInit + , takeMaximum + , index + , findDuplicates + , stripSuffix) +where +import Data.List +import qualified Data.Set as Set + + +-- | Take the head of a list, or `Nothing` if it's empty. +takeHead :: [a] -> Maybe a +takeHead xs + = case xs of + [] -> Nothing + _ -> Just (head xs) + + +-- | Take the tail of a list, or `Nothing` if it's empty. +takeTail :: [a] -> Maybe [a] +takeTail xs + = case xs of + [] -> Nothing + _ -> Just (tail xs) + + +-- | Take the init of a list, or `Nothing` if it's empty. +takeInit :: [a] -> Maybe [a] +takeInit xs + = case xs of + [] -> Nothing + _ -> Just (init xs) + + +-- | Take the maximum of a list, or `Nothing` if it's empty. +takeMaximum :: Ord a => [a] -> Maybe a +takeMaximum xs + = case xs of + [] -> Nothing + _ -> Just (maximum xs) + + +-- | Retrieve the element at the given index, +-- or `Nothing if it's not there. +index :: [a] -> Int -> Maybe a +index [] _ = Nothing +index (x : _) 0 = Just x +index (_ : xs) i = index xs (i - 1) + + + +-- | Find the duplicate values in a list. +findDuplicates :: Ord n => [n] -> [n] +findDuplicates xx + = go (Set.fromList xx) xx + where go _ [] = [] + go ss (x : xs) + | Set.member x ss = go (Set.delete x ss) xs + | otherwise = x : go ss xs + + +-- | Drops the given suffix from a list. +stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] +stripSuffix suff xx + = case stripPrefix (reverse suff) (reverse xx) of + Nothing -> Nothing + Just xs -> Just $ reverse xs + diff --git a/DDC/Data/Name.hs b/DDC/Data/Name.hs new file mode 100644 --- /dev/null +++ b/DDC/Data/Name.hs @@ -0,0 +1,25 @@ + +module DDC.Data.Name + ( StringName (..) + , CompoundName (..)) +where + +class StringName n where + -- | Produce a flat string from a name. + -- The resulting string should be re-lexable as a bindable name. + stringName :: n -> String + + +-- | Compound names can be extended to create new names. +-- This is useful when generating fresh names during program transformation. +class CompoundName n where + -- | Build a new name based on the given one. + extendName :: n -> String -> n + + -- | Build a new name from the given string. + newVarName :: String -> n + + -- | Split the extension string from a name. + splitName :: n -> Maybe (n, String) + + diff --git a/DDC/Data/Pretty.hs b/DDC/Data/Pretty.hs new file mode 100644 --- /dev/null +++ b/DDC/Data/Pretty.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | Pretty printer utilities. +-- +-- This is a re-export of Daan Leijen's pretty printer package (@wl-pprint@), +-- but with a `Pretty` class that includes a `pprPrec` function. +module DDC.Data.Pretty + ( module Text.PrettyPrint.Leijen + , Pretty(..) + , pprParen + , padL + + -- * Rendering + , RenderMode (..) + , render + , renderPlain + , renderIndent + , putDoc, putDocLn) +where +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Text.PrettyPrint.Leijen as P +import Text.PrettyPrint.Leijen + hiding (Pretty(..), renderPretty, putDoc) + +-- Utils --------------------------------------------------------------------- +-- | Wrap a `Doc` in parens if the predicate is true. +pprParen :: Bool -> Doc -> Doc +pprParen b c + = if b then parens c + else c + + +-- Pretty Class -------------------------------------------------------------- +class Pretty a where + data PrettyMode a + pprDefaultMode :: PrettyMode a + + ppr :: a -> Doc + ppr = pprPrec 0 + + pprPrec :: Int -> a -> Doc + pprPrec p = pprModePrec pprDefaultMode p + + pprModePrec :: PrettyMode a -> Int -> a -> Doc + pprModePrec _ _ x = ppr x + + +instance Pretty () where + ppr = text . show + +instance Pretty Bool where + ppr = text . show + +instance Pretty Int where + ppr = text . show + +instance Pretty Integer where + ppr = text . show + +instance Pretty Char where + ppr = text . show + +instance Pretty a => Pretty [a] where + ppr xs = encloseSep lbracket rbracket comma + $ map ppr xs + +instance Pretty a => Pretty (Set a) where + ppr xs = encloseSep lbracket rbracket comma + $ map ppr $ Set.toList xs + +instance (Pretty a, Pretty b) => Pretty (a, b) where + ppr (a, b) = parens $ ppr a <> comma <> ppr b + + +padL :: Int -> Doc -> Doc +padL n d + = let len = length $ renderPlain d + pad = n - len + in if pad > 0 + then d <> text (replicate pad ' ') + else d + + +-- Rendering ------------------------------------------------------------------ +-- | How to pretty print a doc. +data RenderMode + -- | Render the doc with indenting. + = RenderPlain + + -- | Render the doc without indenting. + | RenderIndent + deriving (Eq, Show) + + +-- | Render a doc with the given mode. +render :: RenderMode -> Doc -> String +render mode doc + = case mode of + RenderPlain -> eatSpace True $ displayS (renderCompact doc) "" + RenderIndent -> displayS (P.renderPretty 0.8 100000 doc) "" + + where eatSpace :: Bool -> String -> String + eatSpace _ [] = [] + eatSpace True (c:cs) + = case c of + ' ' -> eatSpace True cs + '\n' -> eatSpace True cs + _ -> c : eatSpace False cs + + eatSpace False (c:cs) + = case c of + ' ' -> ' ' : eatSpace True cs + '\n' -> ' ' : eatSpace True cs + _ -> c : eatSpace False cs + + +-- | Convert a `Doc` to a string without indentation. +renderPlain :: Doc -> String +renderPlain = render RenderPlain + + +-- | Convert a `Doc` to a string with indentation +renderIndent :: Doc -> String +renderIndent = render RenderIndent + + +-- | Put a `Doc` to `stdout` using the given mode. +putDoc :: RenderMode -> Doc -> IO () +putDoc mode doc + = putStr $ render mode doc + +-- | Put a `Doc` to `stdout` using the given mode. +putDocLn :: RenderMode -> Doc -> IO () +putDocLn mode doc + = putStrLn $ render mode doc + + + diff --git a/DDC/Data/SourcePos.hs b/DDC/Data/SourcePos.hs new file mode 100644 --- /dev/null +++ b/DDC/Data/SourcePos.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE TypeFamilies #-} +module DDC.Data.SourcePos + ( SourcePos (..) + , Located (..) + , sourcePosOfLocated + , parsecSourcePosOfLocated + , nameOfLocated + , lineOfLocated + , columnOfLocated + , valueOfLocated) +where +import DDC.Data.Pretty +import Control.DeepSeq +import qualified Text.Parsec.Pos as Parsec + +-- | A position in a source file. +-- +-- If there is no file path then we assume that the input has been read +-- from an interactive session and display '''' when pretty printing. +data SourcePos + = SourcePos + { sourcePosSource :: String + , sourcePosLine :: Int + , sourcePosColumn :: Int } + deriving (Eq, Show) + + +instance NFData SourcePos where + rnf (SourcePos str l c) + = rnf str `seq` rnf l `seq` rnf c + + +instance Pretty SourcePos where + -- Suppress printing of line and column number when they are both zero. + -- File line numbers officially start from 1, so having 0 0 probably + -- means this isn't real information. + ppr (SourcePos source 0 0) + = text $ source + + ppr (SourcePos source l c) + = text $ source ++ ":" ++ show l ++ ":" ++ show c + + +-- | A located thing. +data Located a + = Located !SourcePos !a + deriving (Eq, Show) + + +-- | Take the source position of a located thing. +sourcePosOfLocated :: Located a -> SourcePos +sourcePosOfLocated (Located sp _) = sp + + +-- | Take the parsec source position of a located thing. +parsecSourcePosOfLocated :: Located a -> Parsec.SourcePos +parsecSourcePosOfLocated + (Located (SourcePos name l col) _) + = Parsec.newPos name l col + + +-- | Yield the source name of a located thing. +nameOfLocated :: Located a -> String +nameOfLocated (Located (SourcePos name _ _) _) = name + + +-- | Yield the line number of a located thing. +lineOfLocated :: Located a -> Int +lineOfLocated (Located (SourcePos _ l _) _) = l + + +-- | Yield the column number of a located thing. +columnOfLocated :: Located a -> Int +columnOfLocated (Located (SourcePos _ _ c) _) = c + + +-- | Yield the contained value of a located thing. +valueOfLocated :: Located a -> a +valueOfLocated (Located _ x) = x diff --git a/DDC/Type/Check.hs b/DDC/Type/Check.hs deleted file mode 100644 --- a/DDC/Type/Check.hs +++ /dev/null @@ -1,88 +0,0 @@ --- | Check the kind of a type. -module DDC.Type.Check - ( Config (..) - , configOfProfile - - -- * Checking types. - , checkType - , checkTypeM - - -- * Wrappers for specific universes. - , checkSpec - , kindOfSpec - , sortOfKind - - -- * Kinds of Constructors - , takeSortOfKiCon - , kindOfTwCon - , kindOfTcCon - - -- * Errors - , Error (..) - , ErrorData (..)) -where -import DDC.Type.Check.Judge.Kind -import DDC.Type.Check.Context -import DDC.Type.Check.Error -import DDC.Type.Check.ErrorMessage () -import DDC.Type.Check.CheckCon -import DDC.Type.Check.Config -import DDC.Type.Universe -import DDC.Type.Exp -import DDC.Base.Pretty -import DDC.Type.Pretty () -import DDC.Type.Env (KindEnv) -import DDC.Control.Monad.Check (evalCheck) -import qualified DDC.Type.Env as Env - - --- | Check a type in the given universe with the given environment --- Returns the updated type and its classifier (a kind or sort), --- depeding on the universe of the type being checked. -checkType :: (Ord n, Show n, Pretty n) - => Config n -> KindEnv n -> Universe -> Type n - -> Either (Error n) (Type n, Type n) - -checkType config env uni tt - = evalCheck (0, 0) - $ do (t, k, _) <- checkTypeM config env emptyContext - uni tt Recon - return (t, k) - - --- | Check a spec in the given environment, returning an error or its kind. -checkSpec :: (Ord n, Show n, Pretty n) - => Config n -> KindEnv n -> Type n - -> Either (Error n) (Type n, Kind n) - -checkSpec config env tt - = evalCheck (0, 0) - $ do (t, k, _) <- checkTypeM config env emptyContext - UniverseSpec tt Recon - return (t, k) - - --- | Check a spec in an empty environment, returning an error or its kind. -kindOfSpec - :: (Ord n, Show n, Pretty n) - => Config n -> Type n - -> Either (Error n) (Kind n) - -kindOfSpec config tt - = evalCheck (0, 0) - $ do (_, k, _) <- checkTypeM config Env.empty emptyContext - UniverseSpec tt Recon - return k - - --- | Check a kind in an empty environment, returning an error or its sort. -sortOfKind - :: (Ord n, Show n, Pretty n) - => Config n -> Kind n - -> Either (Error n) (Sort n) - -sortOfKind config tt - = evalCheck (0, 0) - $ do (_, s, _) <- checkTypeM config Env.empty emptyContext - UniverseKind tt Recon - return s diff --git a/DDC/Type/Check/Base.hs b/DDC/Type/Check/Base.hs deleted file mode 100644 --- a/DDC/Type/Check/Base.hs +++ /dev/null @@ -1,75 +0,0 @@ - -module DDC.Type.Check.Base - ( CheckM - , newExists - , newPos - , applyContext - , applySolved - - , throw - - , module DDC.Type.Check.Context - , module DDC.Type.Check.Error - , module DDC.Type.Predicates - , module DDC.Type.Compounds - , module DDC.Type.Equiv - , module DDC.Type.Exp - , module DDC.Base.Pretty) -where -import DDC.Type.Check.Context -import DDC.Type.Check.Error -import DDC.Type.Predicates -import DDC.Type.Compounds -import DDC.Type.Equiv -import DDC.Type.Exp -import DDC.Base.Pretty -import DDC.Control.Monad.Check (throw) -import qualified Data.Set as Set -import qualified DDC.Control.Monad.Check as G - - --- | The type checker monad. -type CheckM n = G.CheckM (Int, Int) (Error n) - - --- | Allocate a new existential of sort Comp. --- Kind inference is only useful for type variables of kind Comp, --- because we don't write functions that have polymorphic witness --- type variables. -newExists :: Sort n -> CheckM n (Exists n) -newExists s - = do (ix, pos) <- G.get - G.put (ix + 1, pos) - return (Exists ix s) - - --- Allocate a new context stack position. -newPos :: CheckM n Pos -newPos - = do (ix, pos) <- G.get - G.put (ix, pos + 1) - return (Pos pos) - - --- | Apply the checker context to a type. -applyContext :: Ord n => Context n -> Type n -> CheckM n (Type n) -applyContext ctx tt - = case applyContextEither ctx Set.empty tt of - - -- We found an infinite path when trying to complete this - -- substitution. We get back the existential and the type for it. - Left (tExt, tBind) - -> throw $ ErrorInfinite tExt tBind - Right t -> return t - - --- | Substitute solved constraints into a type. -applySolved :: Ord n => Context n -> Type n -> CheckM n (Type n) -applySolved ctx tt - = case applySolvedEither ctx Set.empty tt of - - -- We found an infinite path when trying to complete this - -- substitution. We get back the existential and the type for it. - Left (tExt, tBind) - -> throw $ ErrorInfinite tExt tBind - Right t -> return t diff --git a/DDC/Type/Check/CheckCon.hs b/DDC/Type/Check/CheckCon.hs deleted file mode 100644 --- a/DDC/Type/Check/CheckCon.hs +++ /dev/null @@ -1,69 +0,0 @@ - -module DDC.Type.Check.CheckCon - ( takeKindOfTyCon - , takeSortOfKiCon - , kindOfTwCon - , kindOfTcCon) -where -import DDC.Type.Exp -import DDC.Type.Compounds - - --- | Take the kind of a `TyCon`, if there is one. -takeKindOfTyCon :: TyCon n -> Maybe (Kind n) -takeKindOfTyCon tt - = case tt of - -- Sorts don't have a higher classification. - TyConSort _ -> Nothing - - TyConKind kc -> takeSortOfKiCon kc - TyConWitness tc -> Just $ kindOfTwCon tc - TyConSpec tc -> Just $ kindOfTcCon tc - TyConBound _ k -> Just k - TyConExists _ k -> Just k - - --- | Take the superkind of an atomic kind constructor. --- --- Yields `Nothing` for the kind function (~>) as it doesn't have a sort --- without being fully applied. -takeSortOfKiCon :: KiCon -> Maybe (Sort n) -takeSortOfKiCon kc - = case kc of - KiConFun -> Nothing - KiConData -> Just sComp - KiConRegion -> Just sComp - KiConEffect -> Just sComp - KiConClosure -> Just sComp - KiConWitness -> Just sProp - - --- | Take the kind of a witness type constructor. -kindOfTwCon :: TwCon -> Kind n -kindOfTwCon tc - = case tc of - TwConImpl -> kWitness `kFun` kWitness `kFun` kWitness - TwConPure -> kEffect `kFun` kWitness - 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/Type/Check/Config.hs b/DDC/Type/Check/Config.hs deleted file mode 100644 --- a/DDC/Type/Check/Config.hs +++ /dev/null @@ -1,89 +0,0 @@ - -module DDC.Type.Check.Config - ( Config (..) - , configOfProfile) -where -import DDC.Type.DataDef -import DDC.Type.Env (KindEnv, TypeEnv) -import qualified DDC.Type.Env as Env -import qualified DDC.Core.Fragment as F - - --- Config --------------------------------------------------------------------- --- | Static configuration for the type checker. --- These fields don't change as we decend into the tree. --- --- The starting configuration should be converted from the profile that --- defines the language fragment you are checking. --- See "DDC.Core.Fragment" and use `configOfProfile` below. -data Config n - = Config - { -- | Kinds of primitive types. - configPrimKinds :: KindEnv n - - -- | Types of primitive operators. - , configPrimTypes :: TypeEnv n - - -- | Data type definitions. - , configDataDefs :: DataDefs n - - -- | Types of globally available capabilities. - -- - -- The inferred types of computations do not contain these - -- capabilities as they are always available and thus do not - -- need to be tracked in types. - , configGlobalCaps :: TypeEnv n - - -- | This name represents some hole in the expression that needs - -- to be filled in by the type checker. - , configNameIsHole :: Maybe (n -> Bool) - - -- | Track effect type information. - , configTrackedEffects :: Bool - - -- | 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 - , configDataDefs = F.profilePrimDataDefs profile - , configGlobalCaps = Env.empty - , 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/Type/Check/Context.hs b/DDC/Type/Check/Context.hs deleted file mode 100644 --- a/DDC/Type/Check/Context.hs +++ /dev/null @@ -1,610 +0,0 @@ - -module DDC.Type.Check.Context - ( Mode (..) - - -- * Existentials - , Exists (..) - , typeOfExists - , takeExists - - , Elem (..) - , Role (..) - , Context (..) - , emptyContext - - -- Positions - , Pos (..) - , markContext - , popToPos - - -- Pushing - , pushType, pushTypes, memberType - , pushKind, pushKinds, memberKind, memberKindBind - , pushExists - - -- Lookup - , lookupType - , lookupKind - , lookupExistsEq - - -- Existentials - , locationOfExists - , updateExists - - , applyContextEither - , applySolvedEither - , effectSupported - - , liftTypes - , lowerTypes) -where -import DDC.Type.Exp -import DDC.Type.Pretty -import DDC.Type.Transform.BoundT -import DDC.Type.Equiv -import DDC.Type.Compounds -import DDC.Base.Pretty () -import Data.Maybe -import qualified DDC.Type.Sum as Sum -import qualified Data.IntMap.Strict as IntMap -import Data.IntMap.Strict (IntMap) -import qualified Data.Set as Set -import Data.Set (Set) -import Prelude hiding ((<$>)) - - --- Mode ----------------------------------------------------------------------- --- | What mode we're performing type checking/inference in. -data Mode n - -- | Reconstruct the type of the expression, requiring type annotations - -- on parameters as well as type applications to already be present. - = Recon - - -- | The ascending smoke of incense. - -- Synthesise the type of the expression, producing unification - -- variables for bidirectional type inference. - -- - | Synth - - -- | The descending tongue of flame. - -- Check the type of an expression against this expected type, and - -- unify expected types into unification variables for bidirecional - -- type inference. - | Check (Type n) - deriving (Show, Eq) - - -instance (Eq n, Pretty n) => Pretty (Mode n) where - ppr mode - = case mode of - Recon -> text "RECON" - Synth -> text "SYNTH" - Check t -> text "CHECK" <+> parens (ppr t) - - --- Exists --------------------------------------------------------------------- --- | An existential variable. -data Exists n - = Exists !Int !(Kind n) - deriving (Show) - -instance Eq (Exists n) where - (==) (Exists i1 _) (Exists i2 _) = i1 == i2 - (/=) (Exists i1 _) (Exists i2 _) = i1 /= i2 - - -instance Ord (Exists n) where - compare (Exists i1 _) (Exists i2 _) - = compare i1 i2 - - -instance Pretty (Exists n) where - ppr (Exists i _) = text "?" <> ppr i - - --- | Wrap an existential variable into a type. -typeOfExists :: Exists n -> Type n -typeOfExists (Exists n k) - = TCon (TyConExists n k) - - --- | Take an Exists from a type. -takeExists :: Type n -> Maybe (Exists n) -takeExists tt - = case tt of - TCon (TyConExists n k) -> Just (Exists n k) - _ -> Nothing - - --- Context -------------------------------------------------------------------- --- | The type checker context. --- --- Holds a position counter and a stack of elements. --- The top of the stack is at the front of the list. --- -data Context n - = Context - { -- | Fresh name generator for context positions. - contextGenPos :: !Int - - -- | Fresh name generator for existential variables. - , contextGenExists :: !Int - - -- | The current context stack. - , contextElems :: ![Elem n] - - -- | Types of solved existentials. - -- When solved constraints are popped from the main context stack - -- they are added to this map. The map is used to fill in type - -- annotations after type inference proper. It's not used as part - -- of the main algorithm. - , contextSolved :: IntMap (Type n) } - deriving Show - - -instance (Pretty n, Eq n) => Pretty (Context n) where - ppr (Context genPos genExists ls _solved) - = text "Context " - <$> text " genPos = " <> int genPos - <$> text " genExists = " <> int genExists - <$> indent 2 - (vcat $ [int i <> (indent 4 $ ppr l) - | l <- reverse ls - | i <- [0..]]) - - --- Positions ------------------------------------------------------------------- --- | A position in the type checker context. --- A position is used to record a particular position in the context stack, --- so that we can pop elements higher than it. -data Pos - = Pos !Int - deriving (Show, Eq) - -instance Pretty Pos where - ppr (Pos p) - = text "*" <> int p - - --- Elem ----------------------------------------------------------------------- --- | An element in the type checker context. -data Elem n - -- | A context position marker. - = ElemPos !Pos - - -- | Kind of some variable. - | ElemKind !(Bind n) !Role - - -- | Type of some variable. - | ElemType !(Bind n) - - -- | Existential variable declaration - | ElemExistsDecl !(Exists n) - - -- | Existential variable solved to some monotype. - | ElemExistsEq !(Exists n) !(Type n) - deriving (Show, Eq) - - --- | The role of some type variable. -data Role - -- | Concrete type variables are region variables that have been introduced - -- in an enclosing lexical scope. All the capabilities for these will - -- also be in the context. - = RoleConcrete - - -- | Abstract type variables are the ones that are bound by type abstraction - -- Inside the body of a type abstraction we can assume a region supports - -- any given capability. We only need to worry about if it really does - -- when we actually run the enclosed computation. - | RoleAbstract - deriving (Show, Eq) - - -instance (Pretty n, Eq n) => Pretty (Elem n) where - ppr ll - = case ll of - ElemPos p - -> ppr p - - ElemKind b role - -> ppr (binderOfBind b) - <+> text "::" - <+> (ppr $ typeOfBind b) - <+> text "@" <> ppr role - - ElemType b - -> ppr (binderOfBind b) - <+> text "::" - <+> (ppr $ typeOfBind b) - - ElemExistsDecl i - -> ppr i - - ElemExistsEq i t - -> ppr i <+> text "=" <+> ppr t - - -instance Pretty Role where - ppr role - = case role of - RoleConcrete -> text "Concrete" - RoleAbstract -> text "Abstract" - - --- Empty ---------------------------------------------------------------------- --- | An empty context. -emptyContext :: Context n -emptyContext - = Context 0 0 [] IntMap.empty - - --- Push ----------------------------------------------------------------------- --- | Push the type of some value variable onto the context. -pushType :: Bind n -> Context n -> Context n -pushType b ctx - = ctx { contextElems = ElemType b : contextElems ctx } - - --- | Push many types onto the context. -pushTypes :: [Bind n] -> Context n -> Context n -pushTypes bs ctx - = foldl (flip pushType) ctx bs - - --- | Push the kind of some type variable onto the context. -pushKind :: Bind n -> Role -> Context n -> Context n -pushKind b role ctx - = ctx { contextElems = ElemKind b role : contextElems ctx } - - --- | Push many kinds onto the context. -pushKinds :: [(Bind n, Role)] -> Context n -> Context n -pushKinds brs ctx - = foldl (\ctx' (b, r) -> pushKind b r ctx') ctx brs - - --- | Push an existential declaration onto the context. --- If this is not an existential then `error`. -pushExists :: Exists n -> Context n -> Context n -pushExists i ctx - = ctx { contextElems = ElemExistsDecl i : contextElems ctx } - - --- Mark / Pop ----------------------------------------------------------------- --- | Mark the context with a new position. -markContext :: Context n -> (Context n, Pos) -markContext ctx - = let p = contextGenPos ctx - pos = Pos p - in ( ctx { contextGenPos = p + 1 - , contextElems = ElemPos pos : contextElems ctx } - , pos ) - - --- | Pop elements from a context to get back to the given position. -popToPos :: Pos -> Context n -> Context n -popToPos pos ctx - = ctx { contextElems = go $ contextElems ctx } - where - go [] = [] - - go (ElemPos pos' : ls) - | pos' == pos = ls - | otherwise = go ls - - go (_ : ls) = go ls - - --- Lookup --------------------------------------------------------------------- --- | Given a bound level-0 (value) variable, lookup its type (level-1) --- from the context. -lookupType :: Eq n => Bound n -> Context n -> Maybe (Type n) -lookupType u ctx - = case u of - UPrim{} -> Nothing - UName n -> goName n (contextElems ctx) - UIx ix -> goIx ix 0 (contextElems ctx) - where - goName _n [] = Nothing - goName n (ElemType (BName n' t) : ls) - | n == n' = Just t - | otherwise = goName n ls - goName n (_ : ls) - = goName n ls - - - goIx _ix _d [] = Nothing - goIx ix d (ElemType (BAnon t) : ls) - | ix == d = Just t - | otherwise = goIx ix (d + 1) ls - goIx ix d (_ : ls) - = goIx ix d ls - - --- | Given a bound level-1 (type) variable, lookup its kind (level-2) from --- the context. -lookupKind :: Eq n => Bound n -> Context n -> Maybe (Kind n, Role) -lookupKind u ctx - = case u of - UPrim{} -> Nothing - UName n -> goName n (contextElems ctx) - UIx ix -> goIx ix 0 (contextElems ctx) - where - goName _n [] = Nothing - goName n (ElemKind (BName n' t) role : ls) - | n == n' = Just (t, role) - | otherwise = goName n ls - goName n (_ : ls) - = goName n ls - - - goIx _ix _d [] = Nothing - goIx ix d (ElemKind (BAnon t) role : ls) - | ix == d = Just (t, role) - | otherwise = goIx ix (d + 1) ls - goIx ix d (_ : ls) - = goIx ix d ls - - --- | Lookup the type bound to an existential, if any. -lookupExistsEq :: Exists n -> Context n -> Maybe (Type n) -lookupExistsEq i ctx - = go (contextElems ctx) - where go [] = Nothing - go (ElemExistsEq i' t : _) - | i == i' = Just t - go (_ : ls) = go ls - - --- Member --------------------------------------------------------------------- --- | See if this type variable is in the context. -memberType :: Eq n => Bound n -> Context n -> Bool -memberType u ctx = isJust $ lookupType u ctx - - --- | See if this kind variable is in the context. -memberKind :: Eq n => Bound n -> Context n -> Bool -memberKind u ctx = isJust $ lookupKind u ctx - - --- | See if the name on a named binder is in the contexts. --- Returns False for non-named binders. -memberKindBind :: Eq n => Bind n -> Context n -> Bool -memberKindBind b ctx - = case b of - BName n _ -> memberKind (UName n) ctx - _ -> False - - --- Existentials---------------------------------------------------------------- - --- | Get the numeric location of an existential in the context stack, --- or Nothing if it's not there. Returned value is relative to the TOP --- of the stack, so the top element has location 0. -locationOfExists - :: Exists n - -> Context n - -> Maybe Int - -locationOfExists x ctx - = go 0 (contextElems ctx) - where go !_ix [] = Nothing - - go !ix (ElemExistsDecl x' : moar) - | x == x' = Just ix - | otherwise = go (ix + 1) moar - - go !ix (ElemExistsEq x' _ : moar) - | x == x' = Just ix - | otherwise = go (ix + 1) moar - - go !ix (_ : moar) - = go (ix + 1) moar - - --- | Update (solve) an existential in the context stack. --- --- If the existential is not part of the context then `Nothing`. -updateExists - :: [Exists n] -- ^ Other existential declarations to add before the - -- updated one. - -> Exists n -- ^ Existential to update. - -> Type n -- ^ New monotype. - -> Context n - -> Maybe (Context n) - -updateExists isMore iEx@(Exists iEx' _) tEx ctx - = case go $ contextElems ctx of - Just elems' - -> Just $ ctx { contextElems = elems' - , contextSolved = IntMap.insert iEx' tEx (contextSolved ctx) } - Nothing -> Nothing - where - go ll - = case ll of - l@ElemPos{} : ls - | Just ls' <- go ls -> Just (l : ls') - - l@ElemKind{} : ls - | Just ls' <- go ls -> Just (l : ls') - - l@ElemType{} : ls - | Just ls' <- go ls -> Just (l : ls') - - l@(ElemExistsDecl i) : ls - | i == iEx - -> Just $ (ElemExistsEq i tEx : [ElemExistsDecl n' | n' <- isMore]) ++ ls - - | Just ls' <- go ls -> Just (l : ls') - - l@ElemExistsEq{} : ls - | Just ls' <- go ls -> Just (l : ls') - - _ -> Just ll -- Nothing - - --- Lifting -------------------------------------------------------------------- --- | Lift free debruijn indices in types by the given number of levels. -liftTypes :: Ord n => Int -> Context n -> Context n -liftTypes n ctx - = ctx { contextElems = go $ contextElems ctx } - where - go [] = [] - go (ElemType b : ls) = ElemType (liftT n b) : go ls - go (l:ls) = l : go ls - - --- Lowering -------------------------------------------------------------------- --- | Lower free debruijn indices in types by the given number of levels. -lowerTypes :: Ord n => Int -> Context n -> Context n -lowerTypes n ctx - = ctx { contextElems = go $ contextElems ctx } - where - go [] = [] - go (ElemType b : ls) = ElemType (lowerT n b) : go ls - go (l:ls) = l : go ls - - --- Apply ---------------------------------------------------------------------- --- | Apply a context to a type, updating any existentials in the type. This --- uses just the solved constraints on the stack, but not in the solved set. --- --- 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 - - TForall b t - -> do tb' <- applySolvedEither ctx is (typeOfBind b) - let b' = replaceTypeOfBind tb' b - t' <- applySolvedEither ctx is t - return $ TForall b' t' - - TApp t1 t2 - -> do t1' <- applySolvedEither ctx is t1 - t2' <- applySolvedEither ctx is t2 - return $ TApp t1' t2' - - 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 - - TForall b t - -> do tb' <- applySolvedEither ctx is (typeOfBind b) - let b' = replaceTypeOfBind tb' b - t' <- applySolvedEither ctx is t - return $ TForall b' t' - - TApp t1 t2 - -> do t1' <- applySolvedEither ctx is t1 - t2' <- applySolvedEither ctx is t2 - return $ TApp t1' t2' - - TSum ts - -> do tss' <- mapM (applySolvedEither ctx is) - $ Sum.toList ts - - return $ TSum - $ Sum.fromList (Sum.kindOfSum ts) tss' - - --- Support -------------------------------------------------------------------- --- | Check whether this effect is supported by the given context. --- This is used when effects are treated as capabilities. --- --- 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) - => Effect n - -> Context n - -> Maybe (Effect n) - -effectSupported eff ctx - -- Check that all the components of a sum are supported. - | TSum ts <- eff - = listToMaybe $ concat [ maybeToList $ effectSupported e ctx - | e <- Sum.toList ts ] - - -- Abstract effects are fine. - -- We'll find out if it is really supported once it's instantiated. - | TVar {} <- eff - = Nothing - - -- 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] - , any (\b -> equivT (typeOfBind b) eff) - [ b | ElemType b <- contextElems 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/Type/Check/Data.hs b/DDC/Type/Check/Data.hs deleted file mode 100644 --- a/DDC/Type/Check/Data.hs +++ /dev/null @@ -1,180 +0,0 @@ - -module DDC.Type.Check.Data - (checkDataDefs) -where -import DDC.Type.Check.Error -import DDC.Type.Check.Config -import DDC.Type.Equiv -import DDC.Type.DataDef -import DDC.Base.Pretty -import Data.Maybe -import Data.Set (Set) -import qualified DDC.Type.Env as Env -import qualified Data.Set as Set -import qualified Data.Map as Map - -------------------------------------------------------------------------------- --- | Check some data type definitions. -checkDataDefs - :: (Ord n, Show n, Pretty n) - => Config n - -> [DataDef n] - -> ([ErrorData n], [DataDef n]) - -checkDataDefs config defs - = let - -- Get the list of type and data constructors which the module - -- cannot re-define locally. - - -- Primitive type constructors. - primTypeCtors - = Set.fromList - $ Map.keys $ Env.envMap $ configPrimKinds config - - -- Primitive data type constructors - primDataTypeCtors - = Set.fromList - $ Map.keys $ dataDefsTypes $ configDataDefs config - - -- Primitive data constructors - primDataCtors - = Set.fromList - $ Map.keys $ dataDefsCtors $ configDataDefs config - - in checkDataDefs' - (Set.union primTypeCtors primDataTypeCtors) - primDataCtors - [] [] - defs - - -checkDataDefs' - :: (Ord n, Show n, Pretty n) - => Set n -- ^ Names of existing data types. - -> Set n -- ^ Names of existing data constructor. - -> [ErrorData n] -- ^ Errors found so far. - -> [DataDef n] -- ^ Checked data defs. - -> [DataDef n] -- ^ Data defs still to check. - -> ([ErrorData n], [DataDef n]) - -checkDataDefs' nsTypes nsCtors errs dsChecked ds - -- We've checked all the defs. - | [] <- ds - = (reverse errs, reverse dsChecked) - - -- Keep checking defs. - | d : ds' <- ds - = case checkDataDef nsTypes nsCtors d of - - -- There are errors in this def. - Left errs' - -> checkDataDefs' - (Set.insert (dataDefTypeName d) nsTypes) - (Set.fromList $ fromMaybe [] $ dataCtorNamesOfDataDef d) - (errs ++ errs') dsChecked ds' - - -- This def is ok. - Right d' - -> checkDataDefs' - (Set.insert (dataDefTypeName d') nsTypes) - (Set.fromList $ fromMaybe [] $ dataCtorNamesOfDataDef d) - errs (d' : dsChecked) ds' - - | otherwise - = error "ddc-core.checkDataDefs: bogus warning suppression" - - --- DataDef -------------------------------------------------------------------- --- | Check a data type definition. -checkDataDef - :: (Ord n, Show n, Pretty n) - => Set n -- ^ Names of existing data types. - -> Set n -- ^ Names of existing data constructors. - -> DataDef n -- ^ Data type definition to check. - -> Either [ErrorData n] (DataDef n) - -checkDataDef nsTypes nsCtors def - - -- Check the data type name is not already defined. - | Set.member (dataDefTypeName def) nsTypes - = Left [ErrorDataDupTypeName (dataDefTypeName def)] - - -- No data constructors to check. - | Nothing <- dataDefCtors def - = Right def - - -- Check the data constructors. - | Just ctors <- dataDefCtors def - = case checkDataCtors nsCtors [] def [] ctors of - Left errs -> Left errs - Right ctors' -> Right $ def { dataDefCtors = Just ctors' } - - | otherwise - = error "ddc-core.checkDataDef: bogus warning suppression" - - --- Ctors ---------------------------------------------------------------------- --- | Check the data constructor definitions from a single data type. -checkDataCtors - :: (Ord n, Show n, Pretty n) - => Set n -- ^ Names of existing data constructors. - -> [ErrorData n] -- ^ Errors found so far. - -> DataDef n -- ^ The DataDef these constructors relate to. - -> [DataCtor n] -- ^ Checked constructor defs. - -> [DataCtor n] -- ^ Constructor defs still to check. - -> Either [ErrorData n] [DataCtor n] - -checkDataCtors nsCtors errs def csChecked cs - -- We've checked all the constructors and there were no errors. - | [] <- cs, [] <- errs - = Right (reverse csChecked) - - -- We've checked all the constructors and there were errors with some of them. - | [] <- cs - = Left (reverse errs) - - -- Keep checking constructors. - | c : cs' <- cs - = case checkDataCtor nsCtors def c of - Left err -> checkDataCtors - (Set.insert (dataCtorName c) nsCtors) - (err : errs) def csChecked cs' - - Right c' -> checkDataCtors - (Set.insert (dataCtorName c') nsCtors) - errs def (c' : csChecked) cs' - - | otherwise - = error "ddc-core.checkDataCtors: bogus warning suppression" - - --- Ctor ----------------------------------------------------------------------- --- | Check a single data constructor definition. -checkDataCtor - :: (Ord n, Show n, Pretty n) - => Set n -- ^ Names of existing data constructors. - -> DataDef n -- ^ Def of data type for this constructor. - -> DataCtor n -- ^ Data constructor to check. - -> Either (ErrorData n) (DataCtor n) - -checkDataCtor nsCtors def ctor - - -- Check the constructor name is not already defined. - | Set.member (dataCtorName ctor) nsCtors - = Left $ ErrorDataDupCtorName (dataCtorName ctor) - - -- Check that the constructor produces a value of the associated data type. - | not $ equivT (dataTypeOfDataDef def) (dataCtorResultType ctor) - = Left $ ErrorDataWrongResult - (dataCtorName ctor) - (dataCtorResultType ctor) (dataTypeOfDataDef def) - - -- This constructor looks ok. - | otherwise - = Right ctor - - - - - - diff --git a/DDC/Type/Check/Error.hs b/DDC/Type/Check/Error.hs deleted file mode 100644 --- a/DDC/Type/Check/Error.hs +++ /dev/null @@ -1,114 +0,0 @@ - --- | Errors produced when checking types. -module DDC.Type.Check.Error - ( Error (..) - , ErrorData (..)) -where -import DDC.Type.Universe -import DDC.Type.Exp - - --- | Things that can go wrong when checking the kind of at type. -data Error n - -- Generic Problems --------------------- - -- | Tried to check a type using the wrong universe, - -- for example: asking for the kind of a kind. - = ErrorUniverseMalfunction - { errorType :: Type n - , errorUniverse :: Universe } - - -- | Generic kind mismatch. - | ErrorMismatch - { errorUniverse :: Universe - , errorInferred :: Type n - , errorExpected :: Type n - , errorChecking :: Type n } - - -- | Cannot construct infinite type. - | ErrorInfinite - { errorTypeVar :: Type n - , errorTypeBind :: Type n } - - -- Variables ---------------------------- - -- | An undefined type variable. - | ErrorUndefined - { errorBound :: Bound n } - - - -- Constructors ------------------------- - -- | Found an unapplied kind function constructor. - | ErrorUnappliedKindFun - - -- | Found a naked sort constructor. - | ErrorNakedSort - { errorSort :: Sort n } - - -- | An undefined type constructor. - | ErrorUndefinedTypeCtor - { errorBound :: Bound n } - - - -- Applications ------------------------- - -- | A type application where the thing being applied is not a function. - | ErrorAppNotFun - { errorChecking :: Type n - , errorFunType :: Type n - , errorFunTypeKind :: Kind n - , errorArgType :: Type n } - - -- | A type application where the parameter and argument kinds don't match. - | ErrorAppArgMismatch - { errorChecking :: Type n - , errorFunType :: Type n - , errorFunKind :: Kind n - , errorArgType :: Type n - , errorArgKind :: Kind n } - - -- | A witness implication where the premise or conclusion has an - -- invalid kind. - | ErrorWitnessImplInvalid - { errorChecking :: Type n - , errorLeftType :: Type n - , errorLeftKind :: Kind n - , errorRightType :: Type n - , errorRightKind :: Kind n } - - - -- Quantifiers -------------------------- - -- | A forall where the body does not have data or witness kind. - | ErrorForallKindInvalid - { errorChecking :: Type n - , errorBody :: Type n - , errorKind :: Kind n } - - - -- Sums --------------------------------- - -- | A type sum where the components have differing kinds. - | ErrorSumKindMismatch - { errorKindExpected :: Kind n - , errorTypeSum :: TypeSum n - , errorKinds :: [Kind n] } - - -- | A type sum that does not have effect or closure kind. - | ErrorSumKindInvalid - { errorCheckingSum :: TypeSum n - , errorKind :: Kind n } - deriving Show - - --- | Things that can go wrong when checking data type definitions. -data ErrorData n - -- | A duplicate data type constructor name. - = ErrorDataDupTypeName - { errorDataDupTypeName :: n } - - -- | A duplicate data constructor name. - | ErrorDataDupCtorName - { errorDataCtorName :: n } - - -- | A data constructor with the wrong result type. - | ErrorDataWrongResult - { errorDataCtorName :: n - , errorDataCtorResultActual :: Type n - , errorDataCtorResultExpected :: Type n } - deriving Show diff --git a/DDC/Type/Check/ErrorMessage.hs b/DDC/Type/Check/ErrorMessage.hs deleted file mode 100644 --- a/DDC/Type/Check/ErrorMessage.hs +++ /dev/null @@ -1,124 +0,0 @@ - --- | Errors produced when checking types. -module DDC.Type.Check.ErrorMessage where -import DDC.Type.Check.Error -import DDC.Type.Universe -import DDC.Type.Compounds -import DDC.Type.Pretty - - -instance (Eq n, Show n, Pretty n) => Pretty (Error n) where - ppr err - = case err of - -- Generic Problems --------------------- - ErrorUniverseMalfunction t u - -> vcat [ text "Universe malfunction." - , text " Type: " <> ppr t - , text " is not in universe: " <> ppr u ] - - ErrorMismatch uni tInferred tExpected tt - -> let (thing, thing') - = case uni of - UniverseSpec -> ("Kind", "kind") - UniverseKind -> ("Sort", "sort") - _ -> ("Type", "type") - in vcat - [ text thing <+> text "mismatch." - , text " Expected" - <+> text thing' <> text ":" <+> ppr tExpected - , text " does not match inferred" - <+> text thing' <> text ":" <+> ppr tInferred - , empty - , text "with: " <> align (ppr tt) ] - - ErrorInfinite tExt tBind - -> vcat [ text "Cannot construct infinite type." - , text " " <> ppr tExt <+> text "=" <+> ppr tBind ] - - -- Variables ---------------------------- - ErrorUndefined u - -> text "Undefined type variable: " <> ppr u - - - -- Constructors ------------------------- - ErrorUnappliedKindFun - -> text "Can't take sort of unapplied kind function constructor." - - ErrorNakedSort s - -> text "Can't check a naked sort: " <> ppr s - - ErrorUndefinedTypeCtor u - -> text "Undefined type constructor: " <> ppr u - - - -- Applications ------------------------- - ErrorAppNotFun tt t1 k1 t2 - -> vcat [ text "Type function used in application has invalid kind." - , text " In application: " <> ppr tt - , text " cannot apply type: " <> ppr t1 - , text " of kind: " <> ppr k1 - , text " to type: " <> ppr t2 ] - - ErrorAppArgMismatch tt tFn kFn tArg kArg - -> vcat [ text "Kind mismatch in type application." - , text " In application: " <> ppr tt - , text " cannot apply type: " <> ppr tFn - , text " with kind: " <> ppr kFn - , text " to argument: " <> ppr tArg - , text " with kind: " <> ppr kArg ] - - - ErrorWitnessImplInvalid tt t1 k1 t2 k2 - -> vcat [ text "Invalid args for witness implication." - , text " left type: " <> ppr t1 - , text " has kind: " <> ppr k1 - , text " right type: " <> ppr t2 - , text " has kind: " <> ppr k2 - , text " when checking: " <> ppr tt ] - - - -- Quantifiers -------------------------- - ErrorForallKindInvalid tt t k - -> vcat [ text "Invalid kind for body of quantified type." - , text " the body type: " <> ppr t - , text " has kind: " <> ppr k - , text " but it must be Data or Prop" - , text " when checking: " <> ppr tt ] - - - -- Sums --------------------------------- - ErrorSumKindMismatch k ts ks - -> vcat $ [ text "Kind mismatch in type sum." - , text " found multiple types: " <> ppr ts - , text " with differing kinds: " <> ppr ks ] - ++ (if k /= tBot sComp - then [text " expected kind: " <> ppr k ] - else []) - - ErrorSumKindInvalid ts k - -> vcat [ text "Invalid kind for type sum." - , text " the type sum: " <> ppr ts - , text " has kind: " <> ppr k - , text " but it must be Effect or Closure" ] - - -instance (Eq n, Show n, Pretty n) => Pretty (ErrorData n) where - ppr err - = case err of - ErrorDataDupTypeName n - -> vcat [ text "Duplicate data type definition." - , text " A constructor with name: " <> ppr n - , text " is already defined." ] - - ErrorDataDupCtorName n - -> vcat [ text "Duplicate data constructor definition." - , text " A constructor with name: " <> ppr n - , text " is already defined." ] - - - ErrorDataWrongResult n tActual tExpected - -> vcat [ text "Invalid result type for data constructor." - , text " The data constructor: " <> ppr n - , text " has result type: " <> ppr tActual - , text " but the enclosing type is: " <> ppr tExpected ] - diff --git a/DDC/Type/Check/Judge/Eq.hs b/DDC/Type/Check/Judge/Eq.hs deleted file mode 100644 --- a/DDC/Type/Check/Judge/Eq.hs +++ /dev/null @@ -1,79 +0,0 @@ - -module DDC.Type.Check.Judge.Eq - (makeEq) -where -import DDC.Type.Check.Config -import DDC.Type.Check.Base - - --- | Make two types equivalent to each other, --- or throw the provided error if this is not possible. -makeEq :: (Eq n, Ord n, Pretty n) - => Config n - -> Context n - -> Type n - -> Type n - -> Error n - -> CheckM n (Context n) - -makeEq config ctx0 tL tR err - - -- EqLSolve - | Just iL <- takeExists tL - , not $ isTExists tR - = do let Just ctx1 = updateExists [] iL tR ctx0 - return ctx1 - - -- EqRSolve - | Just iR <- takeExists tR - , not $ isTExists tL - = do let Just ctx1 = updateExists [] iR tL ctx0 - return ctx1 - - -- EqLReach - -- Both types are existentials, and the left is bound earlier in the stack. - -- CAREFUL: The returned location is relative to the top of the stack, - -- hence we need lL > lR here. - | Just iL <- takeExists tL, Just lL <- locationOfExists iL ctx0 - , Just iR <- takeExists tR, Just lR <- locationOfExists iR ctx0 - , lL > lR - = do let Just ctx1 = updateExists [] iR tL ctx0 - return ctx1 - - -- EqRReach - -- Both types are existentials, and the right is bound earlier in the stack. - -- CAREFUL: The returned location is relative to the top of the stack, - -- hence we need lR > lL here. - | Just iL <- takeExists tL, Just lL <- locationOfExists iL ctx0 - , Just iR <- takeExists tR, Just lR <- locationOfExists iR ctx0 - , lR > lL - = do let Just ctx1 = updateExists [] iL tR ctx0 - return ctx1 - - -- EqVar - | TVar u1 <- tL - , TVar u2 <- tR - , u1 == u2 - = return ctx0 - - -- EqCon - | TCon tc1 <- tL - , TCon tc2 <- tR - , equivTyCon tc1 tc2 - = return ctx0 - - -- EqApp - | TApp tL1 tL2 <- tL - , TApp tR1 tR2 <- tR - = do - ctx1 <- makeEq config ctx0 tL1 tR1 err - tL2' <- applyContext ctx1 tL2 - tR2' <- applyContext ctx1 tR2 - ctx2 <- makeEq config ctx0 tL2' tR2' err - - return ctx2 - - -- Error - | otherwise - = throw err - diff --git a/DDC/Type/Check/Judge/Kind.hs b/DDC/Type/Check/Judge/Kind.hs deleted file mode 100644 --- a/DDC/Type/Check/Judge/Kind.hs +++ /dev/null @@ -1,640 +0,0 @@ -module DDC.Type.Check.Judge.Kind - (checkTypeM) -where -import DDC.Type.DataDef -import DDC.Type.Check.Context -import DDC.Type.Check.Error -import DDC.Type.Check.ErrorMessage () -import DDC.Type.Check.CheckCon -import DDC.Type.Check.Config -import DDC.Type.Check.Base -import DDC.Type.Check.Judge.Eq -import DDC.Type.Universe -import Data.List -import Control.Monad -import DDC.Type.Pretty () -import DDC.Type.Env (KindEnv) -import qualified DDC.Type.Sum as TS -import qualified DDC.Type.Env as Env -import qualified Data.Map as Map - - --- | Check a type returning its kind, or a kind returning its sort. --- --- The unverse of the thing to check is directly specified, and if the --- thing is not actually in this universe they you'll get an error. --- --- We track what universe the provided kind is in for defence against --- transform bugs. Types like ([a : [b : Data]. b]. a -> a), should not be --- accepted by the source parser, but may be created by bogus program --- transformations. Quantifiers cannot be used at the kind level, so it's --- better to fail early. ---- --- Note that when comparing kinds, we can just use plain equality --- (==) instead of equivT. This is because kinds do not contain quantifiers --- that need to be compared up to alpha-equivalence, nor do they contain --- crushable components terms. --- -checkTypeM - :: (Ord n, Show n, Pretty n) - => Config n -- ^ Type checker configuration. - -> KindEnv n -- ^ Top-level kind environment. - -> Context n -- ^ Local context. - -> Universe -- ^ What universe the type to check is in. - -> Type n -- ^ The type to check (can be a Spec or Kind) - -> Mode n -- ^ Type checker mode. - -> CheckM n - ( Type n - , Kind n - , Context n) - --- Variables ------------------------------------ -checkTypeM config env ctx0 uni tt@(TVar u) mode - - -- Kind holes. - -- This is some kind that we were explicitly told to infer, - -- so make a new existential for it. - | UniverseKind <- uni - , Just n <- takeNameOfBound u - , Just isHole <- configNameIsHole config - , isHole n - = case mode of - -- We don't infer kind holes in recon mode. - -- The program should have complete kind annotations. - Recon - -> do throw $ ErrorUndefined u - - -- Synthesised kinds are assumed to have sort Comp. - Synth - -> do i <- newExists sComp - let t = typeOfExists i - let ctx' = pushExists i ctx0 - return (t, sComp, ctx') - - -- We have an expected sort for the existential, - -- so use that. - Check sExpected - -> do i <- newExists sExpected - let t = typeOfExists i - let ctx' = pushExists i ctx0 - return (t, sExpected, ctx') - - -- Spec holes. - -- This is some spec that we were explicitly told to infer, - -- so make an existential for it. - | UniverseSpec <- uni - , Just n <- takeNameOfBound u - , Just isHole <- configNameIsHole config - , isHole n - = case mode of - -- We don't infer spec holes in recon mode. - -- The program should have complete spec annotations. - Recon - -> do throw $ ErrorUndefined u - - -- Synthesised types could have an arbitrary kind, - -- so we need to make two existentials. - Synth - -> do iK <- newExists sComp - let k = typeOfExists iK - let ctx1 = pushExists iK ctx0 - - iT <- newExists k - let t = typeOfExists iT - let ctx2 = pushExists iT ctx1 - - return (t, k, ctx2) - - -- We have an expected kind for the existential, - -- so use that. - Check kExpected - -> do iT <- newExists kExpected - let t = typeOfExists iT - let ctx1 = pushExists iT ctx0 - return (t, kExpected, ctx1) - - - -- Some variable defined in an environment, - -- or a primitive variable with its kind directly attached. - | UniverseSpec <- uni - = let - -- Get the actual kind of the variable, - -- according to the kind environment. - getActual - -- A variable in the local environment. - | Just (k, _role) <- lookupKind u ctx0 - = return k - - -- A variable in the global environment. - | Just k <- Env.lookup u env - = return k - - -- A primitive type variable with its kind directly attached, but where - -- the variable is not also in the kind environment. This is a hack used - -- for static used for static region variables in the evaluator. - -- We make them constructors rather than variables so that we don't need - -- to have a data constructor definition for each one. - | UPrim _ k <- u - = return k - - -- Type variable is no where to be found. - | otherwise - = throw $ ErrorUndefined u - - in do - kActual <- getActual - 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 <- makeEq config ctx0 kActual' kExpected' - $ ErrorMismatch uni kActual' kExpected' tt - - return (tt, kActual', ctx1) - - _ -> return (tt, kActual', ctx0) - - -- Type variables are not a part of this universe. - | otherwise - = throw $ ErrorUniverseMalfunction tt uni - - --- Constructors --------------------------------- -checkTypeM config env ctx0 uni tt@(TCon tc) mode - = let - -- Get the actual kind of the constructor, - -- according to the constructor definition. - getActual - -- Sort constructors don't have a higher classification. - -- We should never try to check these. - | TyConSort _ <- tc - , UniverseSort <- uni - = throw $ ErrorNakedSort tt - - -- Baked-in kind constructors. - -- We can't sort-check a naked kind function constructor because - -- the sort of a fully applied one depends on the argument kind. - | TyConKind kc <- tc - , UniverseKind <- uni - = case takeSortOfKiCon kc of - Just s -> return (tt, s) - Nothing -> throw $ ErrorUnappliedKindFun - - -- Baked-in witness type constructors. - | TyConWitness tcw <- tc - , UniverseSpec <- uni - = return (tt, kindOfTwCon tcw) - - -- Baked-in spec type constructors. - | TyConSpec tcc <- tc - , UniverseSpec <- uni - = return (tt, kindOfTcCon tcc) - - -- Fragment specific, or user defined constructors. - | TyConBound u k <- tc - = case u of - UName n - -- User defined data type constructors must be in the set of - -- data defs. Attach the real kind why we're here. - | Just def <- Map.lookup n - $ dataDefsTypes $ configDataDefs config - , UniverseSpec <- uni - -> let k' = kindOfDataType def - in return (TCon (TyConBound u k'), k') - - -- The kinds of abstract imported type constructors are in the - -- global kind environment. - | Just k' <- Env.lookupName n env - , UniverseSpec <- uni - -> return (TCon (TyConBound u k'), k') - - -- We don't have a type for this constructor. - | otherwise - -> throw $ ErrorUndefinedTypeCtor u - - -- The kinds of primitive type constructors are directly attached. - UPrim{} -> return (tt, k) - - -- Type constructors are always defined at top-level and not - -- by anonymous debruijn binding. - UIx{} -> throw $ ErrorUndefinedTypeCtor u - - -- Existentials can be either in the Spec or Kind universe, - -- and their kinds/sorts are directly attached. - | TyConExists _ t <- tc - , uni == UniverseSpec || uni == UniverseKind - = return (tt, t) - - -- Whatever constructor we were given wasn't in the expected universe. - | otherwise - = throw $ ErrorUniverseMalfunction tt uni - in do - -- Get the actual kind/sort of the constructor according to the - -- constructor definition. - (tt', kActual) <- getActual - 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 <- makeEq config ctx0 kActual' kExpected' - $ ErrorMismatch uni kActual' kExpected' tt - return (tt', kActual', ctx1) - - -- In Recon and Synth mode just return the actual kind. - _ -> return (tt', kActual', ctx0) - - --- Quantifiers ---------------------------------- -checkTypeM config kenv ctx0 uni@UniverseSpec - tt@(TForall b1 t2) mode - = case mode of - Recon - -> do - -- Check the binder is well sorted. - let t1 = typeOfBind b1 - _ <- checkTypeM config kenv ctx0 UniverseKind t1 Recon - - -- Check the body with the binder in scope. - let (ctx1, pos1) = markContext ctx0 - let ctx2 = pushKind b1 RoleAbstract ctx1 - (t2', k2, ctx3) <- checkTypeM config kenv ctx2 UniverseSpec t2 Recon - - -- The body must have kind Data or Witness. - k2' <- applyContext ctx3 k2 - when ( not (isDataKind k2') - && not (isWitnessKind k2')) - $ throw $ ErrorForallKindInvalid tt t2 k2' - - -- Pop the quantified type off the context. - let ctx_cut = popToPos pos1 ctx3 - - return (TForall b1 t2', k2', ctx_cut) - - Synth - -> do - -- Synthesise a sort for the binder. - let k1 = typeOfBind b1 - (k1', _s1, ctx1) <- checkTypeM config kenv ctx0 UniverseKind k1 Synth - - let b1' = replaceTypeOfBind k1' b1 - - -- Check the body with the binder in scope. - let (ctx2, pos1) = markContext ctx1 - let ctx3 = pushKind b1' RoleAbstract ctx2 - (t2', k2, ctx4) <- checkTypeM config kenv ctx3 UniverseSpec t2 Synth - - -- If the kind of the body is unconstrained then default it to Data. - -- See [Note: Defaulting the kind of quantified types] - k2' <- applyContext ctx4 k2 - (k2'', ctx5) - <- if isTExists k2' - then do - ctx5 <- makeEq config ctx4 k2' kData - $ ErrorMismatch 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 $ ErrorForallKindInvalid tt t2 k2'' - - -- Pop the quantified type off the context. - let ctx_cut = popToPos pos1 ctx5 - - return (TForall b1' t2', k2'', ctx_cut) - - Check kExpected - -> do - -- Synthesise a sort for the binder. - let k1 = typeOfBind b1 - (k1', _s1, ctx1) <- checkTypeM config kenv ctx0 UniverseKind k1 Synth - - let b1' = replaceTypeOfBind k1' b1 - - -- Check the body with the binder in scope. - let (ctx2, pos1) = markContext ctx1 - let ctx3 = pushKind b1' RoleAbstract ctx2 - (t2', k2, ctx4) <- checkTypeM config kenv ctx3 UniverseSpec t2 Synth - - -- In Check mode if *both* the current kind of the body and the expected - -- kind are existentials then force them both to be data. Otherwise make - -- the kind of the body the same as the expected kind. - -- See [Note: Defaulting the kind of quantified types] - k2' <- applyContext ctx4 k2 - (k2'', ctx5) - <- if isTExists k2' && isTExists kExpected - then do - ctx' <- makeEq config ctx4 k2' kExpected - $ ErrorMismatch uni k2' kExpected tt - - ctx5 <- makeEq config ctx' k2' kData - $ ErrorMismatch uni k2' kData tt - - k2'' <- applyContext ctx5 k2' - return (k2'', ctx5) - - else do - ctx5 <- makeEq config ctx4 k2' kExpected - $ ErrorMismatch 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 $ ErrorForallKindInvalid tt t2 k2' - - -- Pop the quantified type off the context. - let ctx_cut = popToPos pos1 ctx5 - - return (TForall b1' t2', k2'', ctx_cut) - - --- Applications --------------------------------- --- Applications of the kind function constructor are handled directly --- because the constructor doesn't have a sort by itself. --- The sort of a kind function is the sort of the result. -checkTypeM config kenv ctx0 uni@UniverseKind - tt@(TApp (TApp (TCon (TyConKind KiConFun)) k1) k2) mode - = case mode of - Recon - -> do - _ <- checkTypeM config kenv ctx0 uni k1 Recon - (_, s2, _) <- checkTypeM config kenv ctx0 uni k2 Recon - return (tt, s2, ctx0) - - Synth - -> do - (k1', _, ctx1) <- checkTypeM config kenv ctx0 uni k1 Synth - (k2', s2, ctx2) <- checkTypeM config kenv ctx1 uni k2 Synth - return (kFun k1' k2', s2, ctx2) - - Check sExpected - -> do - (k1', _, ctx1) <- checkTypeM config kenv ctx0 uni k1 Synth - (k2', s2, ctx2) <- checkTypeM config kenv ctx1 uni k2 (Check sExpected) - return (kFun k1' k2', s2, ctx2) - - --- The implication constructor is overloaded and can have the --- following kinds: --- (=>) :: @ ~> @ ~> @, for witness constructors. --- (=>) :: @ ~> * ~> *, for functions that take witnesses. -checkTypeM config env ctx0 uni@UniverseSpec - tt@(TApp (TApp tC@(TCon (TyConWitness TwConImpl)) t1) t2) mode - = case mode of - Recon - -> do - (t1', k1, ctx1) <- checkTypeM config env ctx0 uni t1 Recon - (t2', k2, ctx2) <- checkTypeM config env ctx1 uni t2 Recon - - let tt' = TApp (TApp tC t1') t2' - - if isWitnessKind k1 && isWitnessKind k2 - then return (tt', kWitness, ctx2) - else if isWitnessKind k1 && isDataKind k2 - then return (tt', kData, ctx2) - else throw $ ErrorWitnessImplInvalid tt t1 k1 t2 k2 - - Synth - -> do - (t1', _k1, ctx1) <- checkTypeM config env ctx0 uni t1 Synth - (t2', k2, ctx2) <- checkTypeM config env ctx1 uni t2 Synth - - return (tImpl t1' t2', k2, ctx2) - - Check kExpected - -> do - (t1', _k1, ctx1) <- checkTypeM config env ctx0 uni t1 Synth - (t2', k2, ctx2) <- checkTypeM config env ctx1 uni t2 (Check kExpected) - - return (tImpl t1' t2', k2, ctx2) - - --- General type application. -checkTypeM config kenv ctx0 UniverseSpec - tt@(TApp tFn tArg) mode - = case mode of - Recon - -> do - -- Check the kind of the functional part. - (tFn', kFn, ctx1) - <- checkTypeM config kenv ctx0 UniverseSpec tFn Recon - - -- Check the kind of the argument. - (tArg', kArg, ctx2) - <- checkTypeM config kenv ctx1 UniverseSpec tArg Recon - - -- The kind of the parameter must match that of the argument - case kFn of - TApp (TApp (TCon (TyConKind KiConFun)) kParam) kBody - | equivT kParam kArg - -> return (tApp tFn' tArg', kBody, ctx2) - - | otherwise - -> throw $ ErrorAppArgMismatch tt tFn' kFn tArg' kArg - - _ -> throw $ ErrorAppNotFun tt tFn' kFn tArg' - - Synth - -> do - -- Synthesise a kind for the functional part. - (tFn', kFn, ctx1) - <- checkTypeM config kenv ctx0 UniverseSpec tFn Synth - - -- Apply the argument to the function. - kFn' <- applyContext ctx1 kFn - (kResult, tArg', ctx2) - <- synthTAppArg config kenv 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 kenv 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 <- makeEq config ctx1 k1' kExpected' - $ ErrorMismatch UniverseSpec k1' kExpected' tt - - return (t1', k1', ctx2) - - --- Sums ----------------------------------------- -checkTypeM config kenv ctx0 UniverseSpec tt@(TSum ss) mode - = case mode of - Recon - -> do - -- Check all the elements, - -- threading the context from left to right. - (ts', ks, ctx1) - <- checkTypesM config kenv ctx0 UniverseSpec Recon - $ TS.toList ss - - -- Check that all the types in the sum have the same kind. - let kExpect = TS.kindOfSum ss - k' <- case nub ks of - [] -> return $ TS.kindOfSum ss - [k] -> return k - _ -> throw $ ErrorSumKindMismatch kExpect ss ks - - -- Check that the kind of the elements is a valid one. - -- Only effects and closures can be summed. - if (k' == kEffect || k' == kClosure) - then return (TSum (TS.fromList k' ts'), k', ctx1) - else throw $ ErrorSumKindInvalid ss k' - - Synth - -> do - -- Synthesise a kind for all the elements, - -- threading the context from left to right. - (ts, ks, ctx1) - <- checkTypesM config kenv ctx0 UniverseSpec Synth - $ TS.toList ss - - case ks of - -- Force all elements to have the same kind as the first one. - -- Note that (TS.kindOfSum ts) will be Bot in an unannotated program, - -- so we can't use that directly. - k : _ksMore - -> do - (ts'', _, ctx2) - <- checkTypesM config kenv ctx1 UniverseSpec (Check k) ts - k' <- applyContext ctx2 k - return (TSum (TS.fromList k' ts''), k', ctx2) - - -- If the sum does not contain an attached kind, and there are no elements - -- then default it to Effect kind. This shouldn't happen in a well formed - -- program, but might in a generated one. - [] | isBot (TS.kindOfSum ss) - -> return ( TSum (TS.fromList kEffect []) - , kEffect, ctx0) - | otherwise - -> return ( TSum (TS.empty (TS.kindOfSum ss)) - , TS.kindOfSum ss, ctx0) - - Check kExpected - -> do - -- Synthesise a kind for the overall type. - (t1', k1, ctx1) - <- checkTypeM config kenv ctx0 UniverseSpec tt Synth - - -- Force the synthesised kind to match the expected one. - k1' <- applyContext ctx1 k1 - kExpected' <- applyContext ctx1 kExpected - ctx2 <- makeEq config ctx1 k1' kExpected' - $ ErrorMismatch UniverseSpec k1' kExpected' tt - - return (t1', k1, ctx2) - - --- Whatever type we were given wasn't in the specified universe. -checkTypeM _ _ _ uni tt _mode - = throw $ ErrorUniverseMalfunction tt uni - - -------------------------------------------------------------------------------- --- | Like `checkTypeM` but do several, chaining the contexts appropriately. -checkTypesM - :: (Ord n, Show n, Pretty n) - => Config n -- ^ Type checker configuration. - -> KindEnv n -- ^ Top-level kind environment. - -> Context n -- ^ Local context. - -> Universe -- ^ What universe the types to check are in. - -> Mode n -- ^ Type checker mode. - -> [Type n] -- ^ The types to check. - -> CheckM n - ( [Type n] - , [Kind n] - , Context n) - -checkTypesM _ _ ctx0 _ _ [] - = return ([], [], ctx0) - -checkTypesM config kenv ctx0 uni mode (t : ts) - = do (t', k', ctx1) <- checkTypeM config kenv ctx0 uni t mode - (ts', ks', ctx') <- checkTypesM config kenv ctx1 uni mode ts - return (t' : ts', k' : ks', ctx') - - -------------------------------------------------------------------------------- --- | Synthesise the type of a kind function applied to its argument. -synthTAppArg - :: (Show n, Ord n, Pretty n) - => Config n - -> KindEnv n - -> Context n - -> Type n -- Type function. - -> Kind n -- Kind of functional part. - -> Type n -- Type argument. - -> CheckM n - ( Kind n -- Kind of result. - , Type n -- Checked type argument. - , Context n) -- Result context. - -synthTAppArg config kenv ctx0 tFn kFn tArg - - | Just iFn <- takeExists kFn - = do - -- New existential for the kind of the function parameter. - iParam <- newExists sComp - let kParam = typeOfExists iParam - - -- New existential for the kind of the function body - iBody <- newExists sComp - let kBody = typeOfExists iBody - - -- Update the context with the new constraint. - let Just ctx1 = updateExists [iBody, iParam] iFn - (kFun kParam kBody) ctx0 - - -- Check the argument under the new context. - (tArg', _kArg, ctx2) - <- checkTypeM config kenv ctx1 UniverseSpec tArg (Check kParam) - - return (kBody, tArg', ctx2) - - - | TApp (TApp (TCon (TyConKind KiConFun)) kParam) kBody <- kFn - = do - -- The kind of the argument must match the parameter kind - (tArg', _kArg, ctx1) - <- checkTypeM config kenv ctx0 UniverseSpec tArg (Check kParam) - - return (kBody, tArg', ctx1) - - | otherwise - = throw $ ErrorAppNotFun (TApp tFn tArg) tFn kFn tArg - - --- [Note: Defaulting the kind of quantified types] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- For expressions like: --- /\a. \(x : [b : Data]. a). () --- --- The kind of 'a' must be Data because 'x' is used as a parameter of a function --- abstraction. If the kind of the body of a quantified type is unconstrained --- then we default it to data. --- --- Although the types of witness constructors have quantified types, --- those types are primitive, so we never need to do type inference for them. --- There aren't any cases where defaulting the kind of a quantified type to --- Data would be the wrong thing to do. --- diff --git a/DDC/Type/Collect.hs b/DDC/Type/Collect.hs deleted file mode 100644 --- a/DDC/Type/Collect.hs +++ /dev/null @@ -1,195 +0,0 @@ - --- | Collecting sets of variables and constructors. -module DDC.Type.Collect - ( freeT - , freeVarsT - - , FreeVarConT (..) - - , collectBound - , collectBinds - , BindTree (..) - , BindWay (..) - , BindStruct (..) - - , BoundLevel (..) - , isBoundExpWit - , boundLevelOfBindWay - , bindDefT) -where -import DDC.Type.Exp -import DDC.Type.Collect.FreeT -import DDC.Type.Env (Env) -import qualified DDC.Type.Env as Env -import qualified DDC.Type.Sum as Sum -import qualified Data.Set as Set -import Data.Set (Set) - - -------------------------------------------------------------------------------- --- | A description of the binding structure of some type or expression. -data BindTree n - -- | An abstract binding expression. - = BindDef BindWay [Bind n] [BindTree n] - - -- | Use of a variable. - | BindUse BoundLevel (Bound n) - - -- | Use of a constructor. - | BindCon BoundLevel (Bound n) (Maybe (Kind n)) - deriving (Eq, Show) - - --- | Describes how a variable was bound. -data BindWay - = BindForall - | BindLAM - | BindLam - | BindLet - | BindLetRec - | BindLetRegions - | BindLetRegionWith - | BindCasePat - deriving (Eq, Show) - - --- | What level this binder is at. -data BoundLevel - = BoundSpec - | BoundExp - | BoundWit - deriving (Eq, Show) - - --- | Check if a boundlevel is expression or witness -isBoundExpWit :: BoundLevel -> Bool -isBoundExpWit BoundExp = True -isBoundExpWit BoundWit = True -isBoundExpWit _ = False - - --- | Get the `BoundLevel` corresponding to a `BindWay`. -boundLevelOfBindWay :: BindWay -> BoundLevel -boundLevelOfBindWay way - = case way of - BindForall -> BoundSpec - BindLAM -> BoundSpec - BindLam -> BoundExp - BindLet -> BoundExp - BindLetRec -> BoundExp - BindLetRegions -> BoundSpec - BindLetRegionWith -> BoundExp - BindCasePat -> BoundExp - - --- BindStruct ----------------------------------------------------------------- -class BindStruct c n | c -> n where - slurpBindTree :: c -> [BindTree n] - - -instance BindStruct (Type n) n 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 n) n where - slurpBindTree tc - = case tc of - TyConBound u k -> [BindCon BoundSpec u (Just k)] - _ -> [] - - --- | Helper for constructing the `BindTree` for a type binder. -bindDefT :: BindStruct c n - => BindWay -> [Bind n] -> [c] -> BindTree n -bindDefT way bs xs - = BindDef way bs $ concatMap slurpBindTree xs - - --- freeT ---------------------------------------------------------------------- --- | Collect the free Spec variables in a thing (level-1). -freeT :: (BindStruct c n, Ord n) - => Env n -> c -> Set (Bound n) -freeT tenv xx = Set.unions $ map (freeOfTreeT tenv) $ slurpBindTree xx - -freeOfTreeT :: Ord n => Env n -> BindTree n -> Set (Bound n) -freeOfTreeT kenv tt - = case tt of - BindDef way bs ts - | BoundSpec <- boundLevelOfBindWay way - , kenv' <- Env.extends bs kenv - -> Set.unions $ map (freeOfTreeT kenv') ts - - BindDef _ _ ts - -> Set.unions $ map (freeOfTreeT kenv) ts - - BindUse BoundSpec u - | Env.member u kenv -> Set.empty - | otherwise -> Set.singleton u - _ -> Set.empty - - --- collectBound --------------------------------------------------------------- --- | Collect all the bound variables in a thing, --- independent of whether they are free or not. -collectBound - :: (BindStruct c n, Ord n) - => c -> Set (Bound n) - -collectBound - = Set.unions . map collectBoundOfTree . slurpBindTree - -collectBoundOfTree :: Ord n => BindTree n -> Set (Bound n) -collectBoundOfTree tt - = case tt of - BindDef _ _ ts -> Set.unions $ map collectBoundOfTree ts - BindUse _ u -> Set.singleton u - BindCon _ u _ -> Set.singleton u - - --- collectSpecBinds ----------------------------------------------------------- --- | Collect all the spec and exp binders in a thing. -collectBinds - :: (BindStruct c n, Ord n) - => c - -> ([Bind n], [Bind n]) - -collectBinds thing - = let tree = slurpBindTree thing - in ( concatMap collectSpecBindsOfTree tree - , concatMap collectExpBindsOfTree tree) - - -collectSpecBindsOfTree :: Ord n => BindTree n -> [Bind n] -collectSpecBindsOfTree tt - = case tt of - BindDef way bs ts - | BoundSpec <- boundLevelOfBindWay way - -> concat ( bs - : map collectSpecBindsOfTree ts) - - | otherwise - -> concatMap collectSpecBindsOfTree ts - - _ -> [] - - -collectExpBindsOfTree :: Ord n => BindTree n -> [Bind n] -collectExpBindsOfTree tt - = case tt of - BindDef way bs ts - | BoundExp <- boundLevelOfBindWay way - -> concat ( bs - : map collectExpBindsOfTree ts) - - | otherwise - -> concatMap collectExpBindsOfTree ts - - _ -> [] - - diff --git a/DDC/Type/Collect/FreeT.hs b/DDC/Type/Collect/FreeT.hs deleted file mode 100644 --- a/DDC/Type/Collect/FreeT.hs +++ /dev/null @@ -1,57 +0,0 @@ - -module DDC.Type.Collect.FreeT - ( FreeVarConT(..) - , freeVarsT) -where -import DDC.Type.Exp -import Data.Set (Set) -import DDC.Type.Env (KindEnv) -import qualified DDC.Type.Env as Env -import qualified DDC.Type.Sum as Sum -import qualified Data.Set as Set - - --- | Collect the free type variables in a type. -freeVarsT - :: Ord n - => KindEnv n -> Type n - -> Set (Bound n) -freeVarsT kenv tt - = fst $ freeVarConT kenv tt - - -class FreeVarConT (c :: * -> *) where - -- | Collect the free type variables and constructors used in a thing. - freeVarConT - :: Ord n - => KindEnv n -> c n - -> (Set (Bound n), Set (Bound n)) - - -instance FreeVarConT Type where - freeVarConT kenv tt - = case tt of - TVar u - -> if Env.member u kenv - then (Set.empty, Set.empty) - else (Set.singleton u, Set.empty) - - TCon tc - | TyConBound u _ <- tc -> (Set.empty, Set.singleton u) - | otherwise -> (Set.empty, Set.empty) - - TForall b t - -> freeVarConT (Env.extend b kenv) t - - TApp t1 t2 - -> let (vs1, cs1) = freeVarConT kenv t1 - (vs2, cs2) = freeVarConT kenv t2 - in ( Set.union vs1 vs2 - , Set.union cs1 cs2) - - TSum ts - -> let (vss, css) = unzip $ map (freeVarConT kenv) - $ Sum.toList ts - in (Set.unions vss, Set.unions css) - - diff --git a/DDC/Type/Compounds.hs b/DDC/Type/Compounds.hs deleted file mode 100644 --- a/DDC/Type/Compounds.hs +++ /dev/null @@ -1,630 +0,0 @@ -{-# OPTIONS -fno-warn-missing-signatures #-} -module DDC.Type.Compounds - ( -- * Binds - takeNameOfBind - , typeOfBind - , replaceTypeOfBind - - -- * Binders - , binderOfBind - , makeBindFromBinder - , partitionBindsByType - - -- * Bounds - , takeNameOfBound - , takeTypeOfBound - , boundMatchesBind - , namedBoundMatchesBind - , takeSubstBoundOfBind - , takeSubstBoundsOfBinds - , replaceTypeOfBound - - -- * Kinds - , kFun - , kFuns - , takeKFun - , takeKFuns - , takeKFuns' - , takeResultKind - - -- * Quantifiers - , tForall, tForall' - , tForalls, tForalls' - , takeTForalls, eraseTForalls - - -- * Sums - , tBot - , tSum - - -- * Applications - , tApp, ($:) - , tApps, takeTApps - , takeTyConApps - , takePrimTyConApps - , takeDataTyConApps - , takePrimeRegion - - -- * Functions - , tFun - , tFunOfList - , 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 - , tConData0, tConData1) -where -import DDC.Type.Exp -import qualified DDC.Type.Sum as Sum - - --- Binds ---------------------------------------------------------------------- --- | Take the variable name of a bind. --- If this is an anonymous binder then there won't be a name. -takeNameOfBind :: Bind n -> Maybe n -takeNameOfBind bb - = case bb of - BName n _ -> Just n - BAnon _ -> Nothing - BNone _ -> Nothing - - --- | Take the type of a bind. -typeOfBind :: Bind n -> Type n -typeOfBind bb - = case bb of - BName _ t -> t - BAnon t -> t - BNone t -> t - - --- | Replace the type of a bind with a new one. -replaceTypeOfBind :: Type n -> Bind n -> Bind n -replaceTypeOfBind t bb - = case bb of - BName n _ -> BName n t - BAnon _ -> BAnon t - BNone _ -> BNone t - - --- Binders -------------------------------------------------------------------- --- | Take the binder of a bind. -binderOfBind :: Bind n -> Binder n -binderOfBind bb - = case bb of - BName n _ -> RName n - BAnon _ -> RAnon - BNone _ -> RNone - - --- | Make a bind from a binder and its type. -makeBindFromBinder :: Binder n -> Type n -> Bind n -makeBindFromBinder bb t - = case bb of - RName n -> BName n t - RAnon -> BAnon t - RNone -> BNone t - - --- | Make lists of binds that have the same type. -partitionBindsByType :: Eq n => [Bind n] -> [([Binder n], Type n)] -partitionBindsByType [] = [] -partitionBindsByType (b:bs) - = let t = typeOfBind b - bsSame = takeWhile (\b' -> typeOfBind b' == t) bs - rs = map binderOfBind (b:bsSame) - in (rs, t) : partitionBindsByType (drop (length bsSame) bs) - - --- Bounds --------------------------------------------------------------------- --- | Take the name of bound variable. --- If this is a deBruijn index then there won't be a name. -takeNameOfBound :: Bound n -> Maybe n -takeNameOfBound uu - = case uu of - UName n -> Just n - UPrim n _ -> Just n - UIx{} -> Nothing - - --- | Get the attached type of a `Bound`, if any. -takeTypeOfBound :: Bound n -> Maybe (Type n) -takeTypeOfBound uu - = case uu of - UName{} -> Nothing - UPrim _ t -> Just t - UIx{} -> Nothing - - --- | Check whether a bound maches a bind. --- `UName` and `BName` match if they have the same name. --- @UIx 0 _@ and @BAnon _@ always match. --- Yields `False` for other combinations of bounds and binds. -boundMatchesBind :: Eq n => Bound n -> Bind n -> Bool -boundMatchesBind u b - = case (u, b) of - (UName n1, BName n2 _) -> n1 == n2 - (UIx 0, BAnon _) -> True - _ -> False - - --- | Check whether a named bound matches a named bind. --- Yields `False` if they are not named or have different names. -namedBoundMatchesBind :: Eq n => Bound n -> Bind n -> Bool -namedBoundMatchesBind u b - = case (u, b) of - (UName n1, BName n2 _) -> n1 == n2 - _ -> False - - --- | Convert a `Bind` to a `Bound`, ready for substitution. --- --- Returns `UName` for `BName`, @UIx 0@ for `BAnon` --- and `Nothing` for `BNone`, because there's nothing to substitute. -takeSubstBoundOfBind :: Bind n -> Maybe (Bound n) -takeSubstBoundOfBind bb - = case bb of - BName n _ -> Just $ UName n - BAnon _ -> Just $ UIx 0 - BNone _ -> Nothing - - --- | Convert some `Bind`s to `Bounds` -takeSubstBoundsOfBinds :: [Bind n] -> [Bound n] -takeSubstBoundsOfBinds bs - = go 1 bs - where go _level [] = [] - go level (BName n _ : bs') = UName n : go level bs' - go level (BAnon _ : bs') = UIx (len - level) : go (level + 1) bs' - go level (BNone _ : bs') = go level bs' - - len = length [ () | BAnon _ <- bs] - - --- | If this `Bound` is a `UPrim` then replace it's embedded type with a new --- one, otherwise return it unharmed. -replaceTypeOfBound :: Type n -> Bound n -> Bound n -replaceTypeOfBound t uu - = case uu of - UName{} -> uu - UPrim n _ -> UPrim n t - UIx{} -> uu - - --- Variables ------------------------------------------------------------------ --- | Construct a deBruijn index. -tIx :: Kind n -> Int -> Type n -tIx _ i = TVar (UIx i) - - --- Existentials --------------------------------------------------------------- --- | Take an existential variable from a type. -takeTExists :: Type n -> Maybe Int -takeTExists tt - = case tt of - TCon (TyConExists n _) -> Just n - _ -> Nothing - - --- Applications --------------------------------------------------------------- --- | Construct an empty type sum. -tBot :: Kind n -> Type n -tBot k = TSum $ Sum.empty k - - --- | Construct a type application. -tApp, ($:) :: Type n -> Type n -> Type n -tApp = TApp -($:) = TApp - --- | Construct a sequence of type applications. -tApps :: Type n -> [Type n] -> Type n -tApps t1 ts = foldl TApp t1 ts - - --- | Flatten a sequence ot type applications into the function part and --- arguments, if any. -takeTApps :: Type n -> [Type n] -takeTApps tt - = case tt of - TApp t1 t2 -> takeTApps t1 ++ [t2] - _ -> [tt] - - --- | Flatten a sequence of type applications, returning the type constructor --- and arguments, if there is one. -takeTyConApps :: Type n -> Maybe (TyCon n, [Type n]) -takeTyConApps tt - = case takeTApps tt of - TCon tc : args -> Just $ (tc, args) - _ -> Nothing - - --- | Flatten a sequence of type applications, returning the type constructor --- and arguments, if there is one. Only accept primitive type constructors. -takePrimTyConApps :: Type n -> Maybe (n, [Type n]) -takePrimTyConApps tt - = case takeTApps tt of - TCon tc : args - | TyConBound (UPrim n _) _ <- tc - -> Just (n, args) - - _ -> Nothing - - --- | Flatten a sequence of type applications, returning the type constructor --- and arguments, if there is one. Only accept data type constructors. -takeDataTyConApps :: Type n -> Maybe (TyCon n, [Type n]) -takeDataTyConApps tt - = case takeTApps tt of - TCon tc : args - | TyConBound (UName{}) k <- tc - , TCon (TyConKind KiConData) <- takeResultKind k - -> Just (tc, args) - - _ -> Nothing - - --- | Take the prime region variable of a data type. --- This corresponds to the region the outermost constructor is allocated into. -takePrimeRegion :: Type n -> Maybe (Type n) -takePrimeRegion tt - = case takeTApps tt of - TCon _ : tR@(TVar _) : _ - -> Just tR - - _ -> Nothing - - --- Foralls -------------------------------------------------------------------- --- | Build an anonymous type abstraction, with a single parameter. -tForall :: Kind n -> (Type n -> Type n) -> Type n -tForall k f - = TForall (BAnon k) (f (TVar (UIx 0))) - --- | Build an anonymous type abstraction, with a single parameter. --- Starting the next index from the given value. -tForall' :: Int -> Kind n -> (Type n -> Type n) -> Type n -tForall' ix k f - = TForall (BAnon k) (f (TVar (UIx ix))) - - --- | Build an anonymous type abstraction, with several parameters. --- Starting the next index from the given value. -tForalls :: [Kind n] -> ([Type n] -> Type n) -> Type n -tForalls ks f - = let bs = [BAnon k | k <- ks] - us = map (\i -> TVar (UIx i)) [0 .. (length ks - 1)] - in foldr TForall (f $ reverse us) bs - - --- | Build an anonymous type abstraction, with several parameters. --- Starting the next index from the given value. -tForalls' :: Int -> [Kind n] -> ([Type n] -> Type n) -> Type n -tForalls' ix ks f - = let bs = [BAnon k | k <- ks] - us = map (\i -> TVar (UIx i)) [ix .. ix + (length ks - 1)] - in foldr TForall (f $ reverse us) bs - - --- | Split nested foralls from the front of a type, --- or `Nothing` if there was no outer forall. -takeTForalls :: Type n -> Maybe ([Bind n], Type n) -takeTForalls tt - = let go bs (TForall b t) = go (b:bs) t - go bs t = (reverse bs, t) - in case go [] tt of - ([], _) -> Nothing - (bs, body) -> Just (bs, body) - - --- | Erase all `TForall` quantifiers from a type. -eraseTForalls :: Ord n => Type n -> Type n -eraseTForalls tt - = case tt of - TVar{} -> tt - TCon{} -> tt - TForall _ t -> eraseTForalls t - TApp t1 t2 -> TApp (eraseTForalls t1) (eraseTForalls t2) - TSum ts -> TSum $ Sum.fromList (Sum.kindOfSum ts) - $ map eraseTForalls $ Sum.toList ts - - --- Sums ----------------------------------------------------------------------- -tSum :: Ord n => Kind n -> [Type n] -> Type n -tSum k ts - = TSum (Sum.fromList k ts) - - --- Unit ----------------------------------------------------------------------- -tUnit :: Type n -tUnit = TCon (TyConSpec TcConUnit) - - --- Function Constructors ------------------------------------------------------ --- | Construct a kind function. -kFun :: Kind n -> Kind n -> Kind n -kFun k1 k2 = ((TCon $ TyConKind KiConFun)`TApp` k1) `TApp` k2 -infixr `kFun` - - --- | Construct some kind functions. -kFuns :: [Kind n] -> Kind n -> Kind n -kFuns [] k1 = k1 -kFuns (k:ks) k1 = k `kFun` kFuns ks k1 - - --- | Destruct a kind function -takeKFun :: Kind n -> Maybe (Kind n, Kind n) -takeKFun kk - = case kk of - TApp (TApp (TCon (TyConKind KiConFun)) k1) k2 - -> Just (k1, k2) - _ -> Nothing - - --- | Destruct a chain of kind functions into the arguments -takeKFuns :: Kind n -> ([Kind n], Kind n) -takeKFuns kk - = case kk of - TApp (TApp (TCon (TyConKind KiConFun)) k1) k2 - | (ks, k2') <- takeKFuns k2 - -> (k1 : ks, k2') - - _ -> ([], kk) - - --- | Like `takeKFuns`, but return argument and return kinds in the same list. -takeKFuns' :: Kind n -> [Kind n] -takeKFuns' kk - | (ks, k1) <- takeKFuns kk - = ks ++ [k1] - - --- | Take the result kind of a kind function, or return the same kind --- unharmed if it's not a kind function. -takeResultKind :: Kind n -> Kind n -takeResultKind kk - = case kk of - TApp (TApp (TCon (TyConKind KiConFun)) _) k2 - -> takeResultKind k2 - _ -> kk - - --- Function types ------------------------------------------------------------- --- | Construct a pure function type. -tFun :: Type n -> Type n -> Type n -tFun t1 t2 - = (TCon $ TyConSpec TcConFun) `tApps` [t1, t2] -infixr `tFun` - - --- | Construct a 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) ----------------------------------------------- -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 - --- Witness type constructors. -tPure = twCon1 TwConPure -tConst = twCon1 TwConConst -tDeepConst = twCon1 TwConDeepConst -tMutable = twCon1 TwConMutable -tDeepMutable = twCon1 TwConDeepMutable -tDistinct n = twCon2 (TwConDistinct n) - -tcCon1 tc t = (TCon $ TyConSpec tc) `tApp` t -twCon1 tc t = (TCon $ TyConWitness tc) `tApp` t - -twCon2 tc ts = tApps (TCon $ TyConWitness tc) ts - - --- | Build a nullary type constructor of the given kind. -tConData0 :: n -> Kind n -> Type n -tConData0 n k = TCon (TyConBound (UName n) k) - - --- | Build a type constructor application of one argumnet. -tConData1 :: n -> Kind n -> Type n -> Type n -tConData1 n k t1 = TApp (TCon (TyConBound (UName n) k)) t1 - diff --git a/DDC/Type/DataDef.hs b/DDC/Type/DataDef.hs --- a/DDC/Type/DataDef.hs +++ b/DDC/Type/DataDef.hs @@ -11,7 +11,6 @@ -- * Data type definition table , DataDefs (..) - , DataMode (..) , emptyDataDefs , insertDataDef @@ -26,7 +25,7 @@ , typeOfDataCtor) where import DDC.Type.Exp -import DDC.Type.Compounds +import DDC.Type.Exp.Simple.Compounds import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.Maybe @@ -228,7 +227,7 @@ -- | Union two `DataDef` tables. unionDataDefs :: Ord n => DataDefs n -> DataDefs n -> DataDefs n unionDataDefs defs1 defs2 - = DataDefs + = DataDefs { dataDefsTypes = Map.union (dataDefsTypes defs1) (dataDefsTypes defs2) , dataDefsCtors = Map.union (dataDefsCtors defs1) (dataDefsCtors defs2) } diff --git a/DDC/Type/Env.hs b/DDC/Type/Env.hs --- a/DDC/Type/Env.hs +++ b/DDC/Type/Env.hs @@ -22,6 +22,7 @@ -- * Conversion , fromList + , fromListNT , fromTypeMap -- * Projections @@ -36,9 +37,6 @@ , isPrim -- * Lifting - , wrapTForalls - - -- * Wrapping , lift) where import DDC.Type.Exp @@ -128,6 +126,12 @@ = foldr extend empty bs +-- | Convert a list of name and types into an environment +fromListNT :: Ord n => [(n, Type n)] -> Env n +fromListNT nts + = fromList [BName n t | (n, t) <- nts] + + -- | Convert a map of names to types to a environment. fromTypeMap :: Map n (Type n) -> Env n fromTypeMap m @@ -183,7 +187,8 @@ -- | Lookup a bound name from an environment. lookupName :: Ord n => n -> Env n -> Maybe (Type n) lookupName n env - = Map.lookup n (envMap env) + = Map.lookup n (envMap env) + `mplus` (envPrimFun env n) -- | Yield the total depth of the deBruijn stack. @@ -206,15 +211,4 @@ , envStack = map (liftT n) (envStack env) , envStackLength = envStackLength env , envPrimFun = envPrimFun env } - - --- | Wrap locally bound (non primitive) variables defined in an environment --- around a type as new foralls. -wrapTForalls :: Ord n => Env n -> Type n -> Type n -wrapTForalls env tBody - = let bsNamed = [BName b t | (b, t) <- Map.toList $ envMap env ] - bsAnon = [BAnon t | t <- envStack env] - - tInner = foldr TForall tBody (reverse bsAnon) - in foldr TForall tInner bsNamed diff --git a/DDC/Type/Equiv.hs b/DDC/Type/Equiv.hs deleted file mode 100644 --- a/DDC/Type/Equiv.hs +++ /dev/null @@ -1,302 +0,0 @@ - -module DDC.Type.Equiv - ( equivT - , equivWithBindsT - , equivTyCon - - , crushSomeT - , crushEffect) -where -import DDC.Type.Predicates -import DDC.Type.Compounds -import DDC.Type.Bind -import DDC.Type.Exp -import DDC.Type.Env (TypeEnv) -import qualified DDC.Type.Env as Env -import qualified DDC.Type.Sum as Sum -import qualified Data.Map as Map - - ---------------------------------------------------------------------------------------------------- --- | Check equivalence of types. --- --- Checks equivalence up to alpha-renaming, as well as crushing of effects --- and trimming of closures. --- --- * Return `False` if we find any free variables. --- --- * We assume the types are well-kinded, so that the type annotations on --- bound variables match the binders. If this is not the case then you get --- an indeterminate result. --- -equivT :: Ord n => Type n -> Type n -> Bool -equivT t1 t2 - = equivWithBindsT [] [] t1 t2 - --- | Like `equivT` but take the initial stacks of type binders. -equivWithBindsT - :: Ord n - => [Bind n] - -> [Bind n] - -> Type n - -> Type n - -> Bool - -equivWithBindsT stack1 stack2 t1 t2 - = let t1' = unpackSumT $ crushSomeT Env.empty t1 - t2' = unpackSumT $ crushSomeT Env.empty t2 - - in case (t1', t2') of - (TVar u1, TVar u2) - -- Free variables are name-equivalent, bound variables aren't: - -- (forall a. a) != (forall b. a) - | Nothing <- getBindType stack1 u1 - , Nothing <- getBindType stack2 u2 - , u1 == u2 -> checkBounds u1 u2 True - - -- Both variables are bound in foralls, so check the stack - -- to see if they would be equivalent if we named them. - | Just (ix1, t1a) <- getBindType stack1 u1 - , Just (ix2, t2a) <- getBindType stack2 u2 - , ix1 == ix2 - -> checkBounds u1 u2 - $ equivWithBindsT stack1 stack2 t1a t2a - - | otherwise - -> checkBounds u1 u2 - $ False - - -- Constructor names must be equal. - (TCon tc1, TCon tc2) - -> equivTyCon tc1 tc2 - - -- Push binders on the stack as we enter foralls. - (TForall b11 t12, TForall b21 t22) - | equivT (typeOfBind b11) (typeOfBind b21) - -> equivWithBindsT - (b11 : stack1) - (b21 : stack2) - t12 t22 - - -- Decend into applications. - (TApp t11 t12, TApp t21 t22) - -> equivWithBindsT stack1 stack2 t11 t21 - && equivWithBindsT stack1 stack2 t12 t22 - - -- Sums are equivalent if all of their components are. - (TSum ts1, TSum ts2) - -> let ts1' = Sum.toList ts1 - ts2' = Sum.toList ts2 - - -- If all the components of the sum were in the element - -- arrays then they come out of Sum.toList sorted - -- and we can compare corresponding pairs. - checkFast = and $ zipWith (equivWithBindsT stack1 stack2) ts1' ts2' - - -- If any of the components use a higher kinded type variable - -- like (c : % ~> !) then they won't nessesarally be sorted, - -- so we need to do this slower O(n^2) check. - -- Make sure to get the bind stacks the right way around here. - checkSlow = and [ or (map (equivWithBindsT stack1 stack2 t1c) ts2') - | t1c <- ts1' ] - && and [ or (map (equivWithBindsT stack2 stack1 t2c) ts1') - | t2c <- ts2' ] - - in (length ts1' == length ts2') - && (checkFast || checkSlow) - - (_, _) -> False - - --- | If we have a UName and UPrim with the same name then these won't match --- even though they pretty print the same. This will only happen due to --- a compiler bugs, but is very confusing when it does, so we check for --- this case explicitly. -checkBounds :: Eq n => Bound n -> Bound n -> a -> a -checkBounds u1 u2 x - = case (u1, u2) of - (UName n2, UPrim n1 _) - | n1 == n2 -> die - - (UPrim n1 _, UName n2) - | n1 == n2 -> die - - _ -> x - where - die = error $ unlines - [ "DDC.Type.Equiv" - , " Found a primitive and non-primitive bound variable with the same name."] - - --- | Unpack single element sums into plain types. -unpackSumT :: Type n -> Type n -unpackSumT (TSum ts) - | [t] <- Sum.toList ts = t -unpackSumT tt = tt - - --- TyCon --- | Check if two `TyCons` are equivalent. --- We need to handle `TyConBound` specially incase it's kind isn't attached, -equivTyCon :: Eq n => TyCon n -> TyCon n -> Bool -equivTyCon tc1 tc2 - = case (tc1, tc2) of - (TyConBound u1 _, TyConBound u2 _) -> u1 == u2 - _ -> tc1 == tc2 - - - ---------------------------------------------------------------------------------------------------- --- | Crush compound effects and closure terms. --- We check for a crushable term before calling crushT because that function --- will recursively crush the components. --- As equivT is already recursive, we don't want a doubly-recursive function --- that tries to re-crush the same non-crushable type over and over. --- -crushSomeT :: Ord n => TypeEnv n -> Type n -> Type n -crushSomeT caps tt - = {-# SCC crushSomeT #-} - case tt of - TApp (TCon tc) _ - -> case tc of - TyConSpec TcConDeepRead -> crushEffect caps tt - TyConSpec TcConDeepWrite -> crushEffect caps tt - TyConSpec TcConDeepAlloc -> crushEffect caps tt - _ -> tt - - _ -> tt - - --- | Crush compound effect terms into their components. --- --- For example, crushing @DeepRead (List r1 (Int r2))@ yields @(Read r1 + Read r2)@. --- -crushEffect - :: Ord n - => TypeEnv n -- ^ Globally available capabilities. - -> Effect n -- ^ Type to crush. - -> Effect n - -crushEffect caps tt - = {-# SCC crushEffect #-} - case tt of - TVar{} -> tt - TCon{} -> tt - - TForall b t - -> TForall b $ crushEffect caps t - - TSum ts - -> TSum - $ Sum.fromList (Sum.kindOfSum ts) - $ map (crushEffect caps) - $ Sum.toList ts - - TApp{} - | or [equivT tt t | (_, t) <- Map.toList $ Env.envMap caps] - -> tSum kEffect [] - - TApp t1 t2 - -- Head Read. - | Just (TyConSpec TcConHeadRead, [t]) <- takeTyConApps tt - -> case takeTyConApps t of - - -- Type has a head region. - Just (TyConBound _ k, (tR : _)) - | (k1 : _, _) <- takeKFuns k - , isRegionKind k1 - -> tRead tR - - -- Type has no head region. - -- This happens with case () of { ... } - Just (TyConSpec TcConUnit, []) - -> tBot kEffect - - Just (TyConBound _ _, _) - -> tBot kEffect - - _ -> tt - - -- Deep Read. - -- See Note: Crushing with higher kinded type vars. - | Just (TyConSpec TcConDeepRead, [t]) <- takeTyConApps tt - -> case takeTyConApps t of - Just (TyConBound _ k, ts) - | (ks, _) <- takeKFuns k - , length ks == length ts - , Just effs <- sequence $ zipWith makeDeepRead ks ts - -> crushEffect caps $ TSum $ Sum.fromList kEffect effs - - _ -> tt - - -- Deep Write - -- See Note: Crushing with higher kinded type vars. - | Just (TyConSpec TcConDeepWrite, [t]) <- takeTyConApps tt - -> case takeTyConApps t of - Just (TyConBound _ k, ts) - | (ks, _) <- takeKFuns k - , length ks == length ts - , Just effs <- sequence $ zipWith makeDeepWrite ks ts - -> crushEffect caps $ TSum $ Sum.fromList kEffect effs - - _ -> tt - - -- Deep Alloc - -- See Note: Crushing with higher kinded type vars. - | Just (TyConSpec TcConDeepAlloc, [t]) <- takeTyConApps tt - -> case takeTyConApps t of - Just (TyConBound _ k, ts) - | (ks, _) <- takeKFuns k - , length ks == length ts - , Just effs <- sequence $ zipWith makeDeepAlloc ks ts - -> crushEffect caps $ TSum $ Sum.fromList kEffect effs - - _ -> tt - - - | otherwise - -> TApp (crushEffect caps t1) (crushEffect caps t2) - - --- | If this type has first order kind then wrap with the --- appropriate read effect. -makeDeepRead :: Kind n -> Type n -> Maybe (Effect n) -makeDeepRead k t - | isRegionKind k = Just $ tRead t - | isDataKind k = Just $ tDeepRead t - | isClosureKind k = Just $ tBot kEffect - | isEffectKind k = Just $ tBot kEffect - | otherwise = Nothing - - --- | If this type has first order kind then wrap with the --- appropriate read effect. -makeDeepWrite :: Kind n -> Type n -> Maybe (Effect n) -makeDeepWrite k t - | isRegionKind k = Just $ tWrite t - | isDataKind k = Just $ tDeepWrite t - | isClosureKind k = Just $ tBot kEffect - | isEffectKind k = Just $ tBot kEffect - | otherwise = Nothing - - --- | If this type has first order kind then wrap with the --- appropriate read effect. -makeDeepAlloc :: Kind n -> Type n -> Maybe (Effect n) -makeDeepAlloc k t - | isRegionKind k = Just $ tAlloc t - | isDataKind k = Just $ tDeepAlloc t - | isClosureKind k = Just $ tBot kEffect - | isEffectKind k = Just $ tBot kEffect - | otherwise = Nothing - - - -{- [Note: Crushing with higher kinded type vars] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We can't just look at the free variables here and wrap Read and DeepRead constructors - around them, as the type may contain higher kinded type variables such as: (t a). - Instead, we'll only crush the effect when all variable have first-order kind. - When comparing types with higher order variables, we'll have to use the type - equivalence checker, instead of relying on the effects to be pre-crushed. --} diff --git a/DDC/Type/Exp.hs b/DDC/Type/Exp.hs --- a/DDC/Type/Exp.hs +++ b/DDC/Type/Exp.hs @@ -14,6 +14,6 @@ , Bind (..) , Bound (..)) where -import DDC.Type.Exp.Base -import DDC.Type.Exp.NFData () +import DDC.Type.Exp.Simple.Exp +import DDC.Type.Exp.Simple.NFData () diff --git a/DDC/Type/Exp/Base.hs b/DDC/Type/Exp/Base.hs deleted file mode 100644 --- a/DDC/Type/Exp/Base.hs +++ /dev/null @@ -1,267 +0,0 @@ - -module DDC.Type.Exp.Base - ( Binder (..) - , Bind (..) - , Bound (..) - , Type (..) - , Sort - , Kind - , Region - , Effect - , Closure - , TypeSum (..) - , TyConHash (..) - , TypeSumVarCon (..) - , TyCon (..) - , SoCon (..) - , KiCon (..) - , TwCon (..) - , TcCon (..)) -where -import Data.Array -import Data.Map.Strict (Map) -import Data.Set (Set) - - -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 - -- | Variable. - = TVar !(Bound n) - - -- | Constructor. - | TCon !(TyCon n) - - -- | Abstraction. - | TForall !(Bind n) !(Type n) - - -- | Application. - | TApp !(Type n) !(Type n) - - -- | Least upper bound. - | TSum !(TypeSum n) - deriving Show - - -type Sort n = Type n -type Kind n = Type n -type Region n = Type n -type Effect n = Type n -type Closure n = Type n - - --- Type Sums ------------------------------------------------------------------ --- | A least upper bound of several types. --- --- We keep type sums in this normalised format instead of joining them --- together with a binary operator (like @(+)@). This makes sums easier to work --- with, as a given sum type often only has a single physical representation. -data TypeSum n - = TypeSumBot - { typeSumKind :: !(Kind n) } - - | TypeSumSet - { -- | The kind of the elements in this sum. - typeSumKind :: !(Kind n) - - -- | Where we can see the outer constructor of a type, its argument - -- is inserted into this array. This handles common cases like - -- Read, Write, Alloc effects. - , typeSumElems :: !(Array TyConHash (Set (TypeSumVarCon n))) - - -- | A map for named type variables. - , typeSumBoundNamed :: !(Map n (Kind n)) - - -- | A map for anonymous type variables. - , typeSumBoundAnon :: !(Map Int (Kind n)) - - -- | Types that can't be placed in the other fields go here. - -- - -- INVARIANT: this list doesn't contain more `TSum`s. - , typeSumSpill :: ![Type n] } - deriving Show - - --- | Hash value used to insert types into the `typeSumElems` array of a `TypeSum`. -data TyConHash - = TyConHash !Int - deriving (Eq, Show, Ord, Ix) - - --- | Wraps a variable or constructor that can be added the `typeSumElems` array. -data TypeSumVarCon n - = TypeSumVar !(Bound n) - | TypeSumCon !(Bound n) !(Kind n) - deriving Show - - --- TyCon ---------------------------------------------------------------------- --- | Kind, type and witness constructors. --- --- These are grouped to make it easy to determine the universe that they --- belong to. --- -data TyCon n - -- | (level 3) Builtin Sort constructors. - = TyConSort !SoCon - - -- | (level 2) Builtin Kind constructors. - | TyConKind !KiCon - - -- | (level 1) Builtin Spec constructors for the types of witnesses. - | TyConWitness !TwCon - - -- | (level 1) Builtin Spec constructors for types of other kinds. - | TyConSpec !TcCon - - -- | User defined type constructor. - | TyConBound !(Bound n) !(Kind n) - - -- | An existentially quantified name, with its kind. - -- Used during type checking, but not accepted in source programs. - | TyConExists !Int !(Kind n) - deriving Show - - --- | Sort constructor. -data SoCon - -- | Sort of witness kinds. - = SoConProp -- 'Prop' - - -- | Sort of computation kinds. - | SoConComp -- 'Comp' - deriving (Eq, Show) - - --- | Kind constructor. -data KiCon - -- | Function kind constructor. - -- This is only well formed when it is fully applied. - = KiConFun -- (~>) - - -- Witness kinds ------------------------ - -- | Kind of witnesses. - | KiConWitness -- 'Witness :: Prop' - - -- Computation kinds --------------------- - -- | Kind of data values. - | KiConData -- 'Data :: Comp' - - -- | Kind of regions. - | KiConRegion -- 'Region :: Comp' - - -- | Kind of effects. - | KiConEffect -- 'Effect :: Comp' - - -- | Kind of closures. - | KiConClosure -- 'Closure :: Comp' - deriving (Eq, Show) - - --- | Witness type constructors. -data TwCon - -- Witness implication. - = TwConImpl -- :: '(=>) :: Witness ~> Data' - - -- | Purity of some effect. - | TwConPure -- :: Effect ~> Witness - - -- | 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, 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, Show) - diff --git a/DDC/Type/Exp/Flat.hs b/DDC/Type/Exp/Flat.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Flat.hs @@ -0,0 +1,7 @@ + +module DDC.Type.Exp.Flat + ( module DDC.Type.Exp.Flat.Exp + , module DDC.Type.Exp.Flat.Pretty) +where +import DDC.Type.Exp.Flat.Exp +import DDC.Type.Exp.Flat.Pretty diff --git a/DDC/Type/Exp/Flat/Exp.hs b/DDC/Type/Exp/Flat/Exp.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Flat/Exp.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TypeFamilies #-} +module DDC.Type.Exp.Flat.Exp + ( module DDC.Type.Exp.Generic.Exp + , Flat(..) + , Type, TyCon) +where +import DDC.Type.Exp.Generic.Exp +import Data.Text (Text) + +data Flat + = Flat + deriving Show + + +type Type = GType Flat +type TyCon = GTyCon Flat + +type instance GTAnnot Flat = () +type instance GTBindVar Flat = Text +type instance GTBoundVar Flat = Text +type instance GTBindCon Flat = Text +type instance GTBoundCon Flat = Text +type instance GTPrim Flat = Text + diff --git a/DDC/Type/Exp/Flat/Pretty.hs b/DDC/Type/Exp/Flat/Pretty.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Flat/Pretty.hs @@ -0,0 +1,13 @@ + +module DDC.Type.Exp.Flat.Pretty + (module DDC.Type.Exp.Generic.Pretty) +where +import DDC.Type.Exp.Generic.Pretty +import DDC.Data.Pretty +import Data.Text (Text) +import qualified Data.Text as T + + +instance Pretty Text where + ppr tt = text $ T.unpack tt + diff --git a/DDC/Type/Exp/Generic.hs b/DDC/Type/Exp/Generic.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Generic.hs @@ -0,0 +1,42 @@ + +module DDC.Type.Exp.Generic + ( -- * Abstract Syntax + -- ** Type Families + GTAnnot + , GTBindVar, GTBoundVar + , GTBindCon, GTBoundCon + , GTPrim + + -- ** Core Syntax + , GType (..), GTyCon (..) + + -- ** Syntactic Sugar + , pattern TFun + , pattern TUnit + , pattern TVoid + , pattern TBot + , pattern TPrim + + -- * Compounds + -- ** Type Applications + , makeTApps, takeTApps + + -- ** Function Types + , makeTFun, makeTFuns + , takeTFun, takeTFuns, takeTFuns' + + -- ** Forall Types + , makeTForall, takeTForall + + -- ** Exists Types + , makeTExists, takeTExists + + -- * Type Classes + , Binding (..) + , Anon (..) + , ShowGType) +where +import DDC.Type.Exp.Generic.Exp +import DDC.Type.Exp.Generic.Binding +import DDC.Type.Exp.Generic.Compounds + diff --git a/DDC/Type/Exp/Generic/Binding.hs b/DDC/Type/Exp/Generic/Binding.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Generic/Binding.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TypeFamilies #-} +module DDC.Type.Exp.Generic.Binding + ( Binding (..) + , Anon (..)) +where +import DDC.Type.Exp.Generic.Exp + + +-- Binding -------------------------------------------------------------------- +-- | Class of languages that include name binding. +class Binding l where + + -- | Get the bound occurrence that matches the given binding occurrence. + boundOfBind :: l -> GTBindVar l -> GTBoundVar l + + -- | Check if the given bound occurence matches a binding occurrence. + boundMatchesBind :: l -> GTBindVar l -> GTBoundVar l -> Bool + + +-- Anon ----------------------------------------------------------------------- +-- | Class of languages that support anonymous binding. +class Anon l where + + -- | Evaluate a function given a new anonymous binding and matching + -- bound occurrence. + withBinding :: l -> (GTBindVar l -> GTBoundVar l -> a) -> a + withBinding l f = withBindings l 1 (\[b] [u] -> f b u) + + withBindings :: l -> Int -> ([GTBindVar l] -> [GTBoundVar l] -> a) -> a diff --git a/DDC/Type/Exp/Generic/Compounds.hs b/DDC/Type/Exp/Generic/Compounds.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Generic/Compounds.hs @@ -0,0 +1,261 @@ +{-# OPTIONS -fno-warn-missing-signatures #-} +module DDC.Type.Exp.Generic.Compounds + ( -- * Destructors + takeTCon + , takeTVar + , takeTAbs + , takeTApp + + -- * Type Applications + , makeTApps, takeTApps + + -- * Function Types + , makeTFun, makeTFuns, makeTFuns', (~>) + , takeTFun, takeTFuns, takeTFuns' + + -- * Forall Types + , makeTForall, makeTForalls + , takeTForall + + -- * Exists Types + , makeTExists, takeTExists + + -- * Union types + , takeTUnion + , makeTUnions, takeTUnions + , splitTUnionsOfKind) +where +import DDC.Type.Exp.Generic.Exp +import DDC.Type.Exp.Generic.Binding + + +-- Destructors ---------------------------------------------------------------- +-- | Take a type constructor, looking through annotations. +takeTCon :: GType l -> Maybe (GTyCon l) +takeTCon tt + = case tt of + TAnnot _ t -> takeTCon t + TCon tc -> Just tc + _ -> Nothing + + +-- | Take a type variable, looking through annotations. +takeTVar :: GType l -> Maybe (GTBoundVar l) +takeTVar tt + = case tt of + TAnnot _ t -> takeTVar t + TVar u -> Just u + _ -> Nothing + + +-- | Take a type abstraction, looking through annotations. +takeTAbs :: GType l -> Maybe (GTBindVar l, GType l, GType l) +takeTAbs tt + = case tt of + TAnnot _ t -> takeTAbs t + TAbs b k t -> Just (b, k, t) + _ -> Nothing + + +-- | Take a type application, looking through annotations. +takeTApp :: GType l -> Maybe (GType l, GType l) +takeTApp tt + = case tt of + TAnnot _ t -> takeTApp t + TApp t1 t2 -> Just (t1, t2) + _ -> Nothing + + +-- Type Applications ---------------------------------------------------------- +-- | Construct a sequence of type applications. +makeTApps :: GType l -> [GType l] -> GType l +makeTApps t1 ts = foldl TApp t1 ts + + +-- | Flatten a sequence of type applications into the function part and +-- arguments, if any. +takeTApps :: GType l -> [GType l] +takeTApps tt + = case takeTApp tt of + Just (t1, t2) -> takeTApps t1 ++ [t2] + _ -> [tt] + + +-- Function Types ------------------------------------------------------------- +-- | Construct a function type with the given parameter and result type. +makeTFun :: GType l -> GType l -> GType l +makeTFun t1 t2 = TFun t1 t2 +infixr `makeTFun` + +(~>) = makeTFun +infixr ~> + +-- | Like `makeFun` but taking a list of parameter types. +makeTFuns :: [GType l] -> GType l -> GType l +makeTFuns [] t1 = t1 +makeTFuns (t:ts) t1 = t `makeTFun` makeTFuns ts t1 + + +-- | Like `makeTFuns` but taking the parameter and return types as a list. +makeTFuns' :: [GType l] -> Maybe (GType l) +makeTFuns' [] = Nothing +makeTFuns' [_] = Nothing +makeTFuns' ts + = let (tR : tAs) = reverse ts + in Just $ makeTFuns (reverse tAs) tR + + +-- | Destruct a function type into its parameter and result types, +-- returning `Nothing` if this isn't a function type. +takeTFun :: GType l -> Maybe (GType l, GType l) +takeTFun tt + | Just (t1f, t2) <- takeTApp tt + , Just (TCon TyConFun, t1) <- takeTApp t1f + = Just (t1, t2) + + | otherwise + = Nothing + + +-- | Destruct a function type into into all its parameters and result type, +-- returning an empty parameter list if this isn't a function type. +takeTFuns :: GType l -> ([GType l], GType l) +takeTFuns tt + = case takeTFun tt of + Just (t1, t2) + | (ts, t2') <- takeTFuns t2 + -> (t1 : ts, t2') + + _ -> ([], tt) + + +-- | Like `takeFuns`, but yield the parameter and return types in the same list. +takeTFuns' :: GType l -> [GType l] +takeTFuns' tt + = let (ts, t1) = takeTFuns tt + in ts ++ [t1] + + +-- Forall types --------------------------------------------------------------- +-- | Construct a forall quantified type using an anonymous binder. +makeTForall :: Anon l => l -> GType l -> (GType l -> GType l) -> GType l +makeTForall l k makeBody + = withBinding l $ \b u + -> TApp (TCon (TyConForall k)) (TAbs b k (makeBody (TVar u))) + + +-- | Construct a forall quantified type using some anonymous binders. +makeTForalls :: Anon l => l -> [GType l] -> ([GType l] -> GType l) -> GType l +makeTForalls l ks makeBody + = withBindings l (length ks) $ \bs us + -> foldr (\(k, b) t -> TApp (TCon (TyConForall k)) (TAbs b k t)) + (makeBody $ reverse $ map TVar us) + (zip ks bs) + + +-- | Destruct a forall quantified type, if this is one. +-- +-- The kind we return comes from the abstraction rather than the +-- Forall constructor. +takeTForall :: GType l -> Maybe (GType l, GTBindVar l, GType l) +takeTForall tt + | Just (t1, t2) <- takeTApp tt + , Just (TyConForall _) <- takeTCon t1 + , Just (b, k, t) <- takeTAbs t2 + = Just (k, b, t) + + | otherwise + = Nothing + + +-- Exists types --------------------------------------------------------------- +-- | Construct an exists quantified type using an anonymous binder. +makeTExists :: Anon l => l -> GType l -> (GType l -> GType l) -> GType l +makeTExists l k makeBody + = withBinding l $ \b u + -> TApp (TCon (TyConExists k)) (TAbs b k (makeBody (TVar u))) + + +-- | Destruct an exists quantified type, if this is one. +-- +-- The kind we return comes from the abstraction rather than the +-- Exists constructor. +takeTExists :: GType l -> Maybe (GType l, GTBindVar l, GType l) +takeTExists tt + | Just (t1, t2) <- takeTApp tt + , Just (TyConExists _) <- takeTCon t1 + , Just (b, k, t) <- takeTAbs t2 + = Just (k, b, t) + + | otherwise + = Nothing + + +-- Bot Types ------------------------------------------------------------------ +-- | Take a bottom type, looking through annotations. +takeTBot :: GType l -> Maybe (GType l) +takeTBot tt + = case tt of + TAnnot _ t -> takeTBot t + TCon (TyConBot k) -> Just k + _ -> Nothing + + +-- Union types ------------------------------------------------------------------ +-- | Take the kind, left and right types from a union type. +takeTUnion :: GType l -> Maybe (GType l, GType l, GType l) +takeTUnion tt + | Just (ts1, t2) <- takeTApp tt + , Just (ts, t1) <- takeTApp ts1 + , Just (TyConUnion k) <- takeTCon ts + = Just (k, t1, t2) + + | otherwise + = Nothing + + +-- | Make a union type from a kind and list of component types. +makeTUnions :: GType l -> [GType l] -> GType l +makeTUnions k tss + = case tss of + [] -> TBot k + [t1] -> t1 + (t1 : ts) -> foldr (TUnion k) t1 ts + + +-- | Split a union type into its components. +-- If this is not a union, or is an ill kinded union then Nothing. +takeTUnions :: Eq (GType l) => GType l -> Maybe (GType l, [GType l]) +takeTUnions tt + | Just k <- takeTBot tt + = Just (k, []) + + | Just (k, t1, t2) <- takeTUnion tt + , Just ts1 <- splitTUnionsOfKind k t1 + , Just ts2 <- splitTUnionsOfKind k t2 + = Just (k, ts1 ++ ts2) + + | otherwise + = Nothing + + +-- | Split a union of the given kind into its components. +-- When we split a sum we need to check that the kind attached +-- to the sum type constructor is the one that we were expecting, +-- otherwise we risk splitting ill-kinded sums without noticing it. +splitTUnionsOfKind :: Eq (GType l) => GType l -> GType l -> Maybe [GType l] +splitTUnionsOfKind k t + | Just k' <- takeTBot t + = if k == k' + then return [] + else Nothing + + | Just (k', t1, t2) <- takeTUnion t + = if k == k' + then do t1s <- splitTUnionsOfKind k t1 + t2s <- splitTUnionsOfKind k t2 + return $ t1s ++ t2s + else Nothing + + | otherwise + = Just [t] diff --git a/DDC/Type/Exp/Generic/Exp.hs b/DDC/Type/Exp/Generic/Exp.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Generic/Exp.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE TypeFamilies, UndecidableInstances #-} + +-- Generic type expression representation. +module DDC.Type.Exp.Generic.Exp + ( -- * Type Families + GTAnnot + , GTBindVar, GTBoundVar + , GTBindCon, GTBoundCon + , GTPrim + + -- * Abstract Syntax + , GType (..) + , GTyCon (..) + + -- * Syntactic Sugar + , pattern TApp2 + , pattern TApp3 + , pattern TApp4 + , pattern TApp5 + + , pattern TVoid + , pattern TUnit + , pattern TFun + , pattern TBot + , pattern TUnion + , pattern TPrim + + -- * Classes + , ShowGType) +where + + +--------------------------------------------------------------------------------------------------- +-- Type functions associated with the language AST. + +-- | Yield the type of annotations. +type family GTAnnot l + +-- | Yield the type of binding occurrences of variables. +type family GTBindVar l + +-- | Yield the type of bound occurrences of variables. +type family GTBoundVar l + +-- | Yield the type of binding occurrences of constructors. +type family GTBindCon l + +-- | Yield the type of bound occurrences of constructors. +type family GTBoundCon l + +-- | Yield the type of primitive type names. +type family GTPrim l + + +--------------------------------------------------------------------------------------------------- +-- | Generic type expression representation. +data GType l + -- | An annotated type. + = TAnnot !(GTAnnot l) (GType l) + + -- | Type constructor or literal. + | TCon !(GTyCon l) + + -- | Type variable. + | TVar !(GTBoundVar l) + + -- | Type abstracton. + | TAbs !(GTBindVar l) (GType l) (GType l) + + -- | Type application. + | TApp !(GType l) (GType l) + + +-- | Applcation of a type to two arguments. +pattern TApp2 t0 t1 t2 = TApp (TApp t0 t1) t2 + +-- | Applcation of a type to three arguments. +pattern TApp3 t0 t1 t2 t3 = TApp (TApp (TApp t0 t1) t2) t3 + +-- | Applcation of a type to four arguments. +pattern TApp4 t0 t1 t2 t3 t4 = TApp (TApp (TApp (TApp t0 t1) t2) t3) t4 + +-- | Applcation of a type to five arguments. +pattern TApp5 t0 t1 t2 t3 t4 t5 = TApp (TApp (TApp (TApp (TApp t0 t1) t2) t3) t4) t5 + + +deriving instance + ( Eq (GTAnnot l), Eq (GTyCon l) + , Eq (GTBindVar l), Eq (GTBoundVar l)) + => Eq (GType l) + + +--------------------------------------------------------------------------------------------------- +-- | Wrapper for primitive constructors that adds the ones +-- common to SystemFω based languages. +data GTyCon l + -- | The void constructor. + = TyConVoid + + -- | The unit constructor. + | TyConUnit + + -- | The function constructor. + | TyConFun + + -- | Take the least upper bound at the given kind. + | TyConUnion !(GType l) + + -- | The least element of the given kind. + | TyConBot !(GType l) + + -- | The universal quantifier with a parameter of the given kind. + | TyConForall !(GType l) + + -- | The existential quantifier with a parameter of the given kind. + | TyConExists !(GType l) + + -- | Primitive constructor. + | TyConPrim !(GTPrim l) + + -- | Bound constructor. + | TyConBound !(GTBoundCon l) + + +deriving instance + (Eq (GType l), Eq (GTPrim l), Eq (GTBoundCon l)) + => Eq (GTyCon l) + + +--------------------------------------------------------------------------------------------------- +-- | Representation of the void type. +pattern TVoid = TCon TyConVoid + +-- | Representation of the unit type. +pattern TUnit = TCon TyConUnit + +-- | Representation of the function type. +pattern TFun t1 t2 = TApp (TApp (TCon TyConFun) t1) t2 + +-- | Representation of the bottom type at a given kind. +pattern TBot k = TCon (TyConBot k) + +-- | Representation of a union of two types. +pattern TUnion k t1 t2 = TApp (TApp (TCon (TyConUnion k)) t1) t2 + +-- | Representation of primitive type constructors. +pattern TPrim p = TCon (TyConPrim p) + + +--------------------------------------------------------------------------------------------------- +-- | Synonym for show constraints of all language types. +type ShowGType l + = ( Show l + , Show (GTAnnot l) + , Show (GTBindVar l), Show (GTBoundVar l) + , Show (GTBindCon l), Show (GTBoundCon l) + , Show (GTPrim l)) + +deriving instance ShowGType l => Show (GType l) +deriving instance ShowGType l => Show (GTyCon l) + diff --git a/DDC/Type/Exp/Generic/NFData.hs b/DDC/Type/Exp/Generic/NFData.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Generic/NFData.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE UndecidableInstances #-} + +module DDC.Type.Exp.Generic.NFData where +import DDC.Type.Exp.Generic.Exp +import Control.DeepSeq + + +type NFDataLanguage l + = ( NFData l + , NFData (GTAnnot l) + , NFData (GTBindVar l), NFData (GTBoundVar l) + , NFData (GTBindCon l), NFData (GTBoundCon l) + , NFData (GTPrim l)) + + +instance NFDataLanguage l => NFData (GType l) where + rnf xx + = case xx of + TAnnot a t -> rnf a `seq` rnf t + TCon tc -> rnf tc + TVar bv -> rnf bv + TAbs bv k t -> rnf bv `seq` rnf k `seq` rnf t + TApp t1 t2 -> rnf t1 `seq` rnf t2 + + +instance NFDataLanguage l => NFData (GTyCon l) where + rnf xx + = case xx of + TyConUnit -> () + TyConVoid -> () + TyConFun -> () + TyConUnion t -> rnf t + TyConBot t -> rnf t + TyConForall t -> rnf t + TyConExists t -> rnf t + TyConPrim p -> rnf p + TyConBound bc -> rnf bc + diff --git a/DDC/Type/Exp/Generic/Predicates.hs b/DDC/Type/Exp/Generic/Predicates.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Generic/Predicates.hs @@ -0,0 +1,16 @@ + +-- | Predicates on type expressions. +module DDC.Type.Exp.Generic.Predicates + (isAtomT) +where +import DDC.Type.Exp.Generic.Exp + + +-- | Check whether a type is a `TVar` or `TCon`. +isAtomT :: GType l -> Bool +isAtomT tt + = case tt of + TAnnot _ t -> isAtomT t + TCon{} -> True + TVar{} -> True + _ -> False diff --git a/DDC/Type/Exp/Generic/Pretty.hs b/DDC/Type/Exp/Generic/Pretty.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Generic/Pretty.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE TypeFamilies, UndecidableInstances #-} + +module DDC.Type.Exp.Generic.Pretty + ( PrettyConfig + , pprRawT + , pprRawPrecT + , pprRawC) +where +import DDC.Type.Exp.Generic.Exp +import DDC.Data.Pretty + + +-- | Synonym for pretty constraints on the configurable types. +type PrettyConfig l + = ( Pretty (GTAnnot l) + , Pretty (GTBindVar l), Pretty (GTBoundVar l) + , Pretty (GTBindCon l), Pretty (GTBoundCon l) + , Pretty (GTPrim l)) + + +-- | Pretty print a type using the generic, raw syntax. +pprRawT :: PrettyConfig l => GType l -> Doc +pprRawT tt = pprRawPrecT 0 tt + + +-- | Like `pprRawT`, but take the initial precedence. +pprRawPrecT :: PrettyConfig l => Int -> GType l -> Doc +pprRawPrecT d tt + = case tt of + TAnnot a t + -> braces (ppr a) + <+> pprRawT t + + TCon c -> pprRawC c + TVar u -> ppr u + + TAbs b k t + -> pprParen (d > 1) + $ text "λ" <> ppr b <> text ":" <+> pprRawT k <> text "." <+> pprRawT t + + TApp t1 t2 + -> pprParen (d > 10) + $ pprRawT t1 <+> pprRawPrecT 11 t2 + + +-- | Pretty print a type constructor using the generic, raw syntax. +pprRawC :: PrettyConfig l => GTyCon l -> Doc +pprRawC cc + = case cc of + TyConFun -> text "→" + TyConUnit -> text "1" + TyConVoid -> text "0" + TyConUnion k -> text "∨" <> braces (pprRawT k) + TyConBot k -> text "⊥" <> braces (pprRawT k) + TyConForall k -> text "∀" <> braces (pprRawT k) + TyConExists k -> text "∃" <> braces (pprRawT k) + TyConPrim p -> ppr p + TyConBound u -> ppr u + diff --git a/DDC/Type/Exp/NFData.hs b/DDC/Type/Exp/NFData.hs deleted file mode 100644 --- a/DDC/Type/Exp/NFData.hs +++ /dev/null @@ -1,93 +0,0 @@ - -module DDC.Type.Exp.NFData where -import DDC.Type.Exp.Base -import Control.DeepSeq - - -instance NFData n => NFData (Binder n) where - rnf bb - = case bb of - RNone -> () - RAnon -> () - RName n -> rnf n - - -instance NFData n => NFData (Bind n) where - rnf bb - = case bb of - BNone t -> rnf t - BAnon t -> rnf t - BName n t -> rnf n `seq` rnf t - - -instance NFData n => NFData (Bound n) where - rnf uu - = case uu of - UIx i -> rnf i - UName n -> rnf n - UPrim u t -> rnf u `seq` rnf t - - -instance NFData n => NFData (Type n) where - rnf tt - = case tt of - TVar u -> rnf u - TCon tc -> rnf tc - TForall b t -> rnf b `seq` rnf t - TApp t1 t2 -> rnf t1 `seq` rnf t2 - TSum ts -> rnf ts - - -instance NFData n => NFData (TypeSum n) where - rnf !ts - = case ts of - TypeSumBot{} - -> rnf (typeSumKind ts) - - TypeSumSet{} - -> rnf (typeSumKind ts) - `seq` rnf (typeSumElems ts) - `seq` rnf (typeSumBoundNamed ts) - `seq` rnf (typeSumBoundAnon ts) - `seq` rnf (typeSumSpill ts) - - -instance NFData TyConHash where - rnf (TyConHash i) - = rnf i - - -instance NFData n => NFData (TypeSumVarCon n) where - rnf ts - = case ts of - TypeSumVar u -> rnf u - TypeSumCon u k -> rnf u `seq` rnf k - - -instance NFData n => NFData (TyCon n) where - rnf tc - = case tc of - TyConSort con -> rnf con - TyConKind con -> rnf con - TyConWitness con -> rnf con - TyConSpec con -> rnf con - TyConBound con k -> rnf con `seq` rnf k - TyConExists n k -> rnf n `seq` rnf k - - -instance NFData SoCon where - rnf !_ = () - - -instance NFData KiCon where - rnf !_ = () - - -instance NFData TwCon where - rnf !_ = () - - -instance NFData TcCon where - rnf !_ = () - - diff --git a/DDC/Type/Exp/Pretty.hs b/DDC/Type/Exp/Pretty.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Pretty.hs @@ -0,0 +1,51 @@ + +module DDC.Type.Exp.Pretty where +import DDC.Type.Exp.TyCon +import DDC.Data.Pretty + + +instance Pretty SoCon where + ppr sc + = case sc of + SoConComp -> text "Comp" + SoConProp -> text "Prop" + + +instance Pretty KiCon where + ppr kc + = case kc of + KiConFun -> text "(~>)" + KiConData -> text "Data" + KiConRegion -> text "Region" + KiConEffect -> text "Effect" + KiConClosure -> text "Closure" + KiConWitness -> text "Witness" + + +instance Pretty TwCon where + ppr tw + = case tw of + TwConImpl -> text "(=>)" + TwConPure -> text "Purify" + TwConConst -> text "Const" + TwConDeepConst -> text "DeepConst" + TwConMutable -> text "Mutable" + TwConDeepMutable-> text "DeepMutable" + TwConDistinct n -> text "Distinct" <> ppr n + TwConDisjoint -> text "Disjoint" + + +instance Pretty TcCon where + ppr tc + = case tc of + TcConUnit -> text "Unit" + TcConFun -> text "(->)" + TcConSusp -> text "S" + TcConRead -> text "Read" + TcConHeadRead -> text "HeadRead" + TcConDeepRead -> text "DeepRead" + TcConWrite -> text "Write" + TcConDeepWrite -> text "DeepWrite" + TcConAlloc -> text "Alloc" + TcConDeepAlloc -> text "DeepAlloc" + diff --git a/DDC/Type/Exp/Simple.hs b/DDC/Type/Exp/Simple.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Simple.hs @@ -0,0 +1,176 @@ + +module DDC.Type.Exp.Simple + ( ------------------------------------------------- + -- * Abstract Syntax + -- ** Types + Type (..) + , TypeSum (..) + , TyConHash (..) + , TypeSumVarCon (..) + + -- ** Binding + , Binder (..) + , Bind (..) + , Bound (..) + + -- ** Constructors + , TyCon (..) + , SoCon (..) + , KiCon (..) + , TwCon (..) + , TcCon (..) + + -- ** Aliases + , Sort, Kind + , Region, Effect, Closure + + + ------------------------------------------------- + -- * Predicates + , -- ** Binders + isBNone + , isBAnon + , isBName + + -- ** Atoms + , isTVar + , isBot + , isAtomT + , isTExists + + -- ** Kinds + , isDataKind + , isRegionKind + , isEffectKind + , isClosureKind + , isWitnessKind + + -- ** Data Types + , isAlgDataType + , isWitnessType + , isConstWitType + , isMutableWitType + , isDistinctWitType + + -- ** Effect Types + , isReadEffect + , isWriteEffect + , isAllocEffect + , isSomeReadEffect + , isSomeWriteEffect + , isSomeAllocEffect + + --------------------------------------------------- + -- * Relations + -- ** Equivalence + , equivT + , equivWithBindsT + , equivTyCon + + -- ** Subsumption + , subsumesT + + --------------------------------------------------- + -- * Transforms + -- ** Crushing + , crushSomeT + , crushEffect + + --------------------------------------------------- + -- * Compounds + -- ** Binds + , takeNameOfBind + , typeOfBind + , replaceTypeOfBind + + -- ** Binders + , binderOfBind + , makeBindFromBinder + , partitionBindsByType + + -- ** Bounds + , takeNameOfBound + , takeTypeOfBound + , boundMatchesBind + , namedBoundMatchesBind + , takeSubstBoundOfBind + , takeSubstBoundsOfBinds + , replaceTypeOfBound + + -- ** Sorts + , sComp, sProp + + -- ** Kinds + , kData, kRegion, kEffect, kClosure, kWitness + , kFun + , kFuns + , takeKFun + , takeKFuns + , takeKFuns' + , takeResultKind + + -- ** Quantifiers + , tForall, tForall' + , tForalls, tForalls' + , takeTForalls, eraseTForalls + + -- ** Sums + , tBot + , tSum + + -- ** Applications + , tApp, ($:) + , tApps, takeTApps + , takeTyConApps + , takePrimTyConApps + , takeDataTyConApps + , takePrimeRegion + + -- ** Functions + , tFun + , tFunOfList + , tFunOfParamResult + , takeTFun + , takeTFunArgResult + , takeTFunWitArgResult + , takeTFunAllArgResult + , arityOfType + , dataArityOfType + + -- ** Suspensions + , tSusp + , takeTSusp + , takeTSusps + + -- ** Implications + , tImpl + + -- ** Units + , tUnit + + -- ** Variables + , tIx + , takeTExists + + -- ** Effect types + , tRead, tDeepRead, tHeadRead + , tWrite, tDeepWrite + , tAlloc, tDeepAlloc + + -- ** Witness types + , tPure + , tConst, tDeepConst + , tMutable, tDeepMutable + , tDistinct + , tConData0, tConData1) +where +import DDC.Type.Exp.Simple.Exp +import DDC.Type.Exp.Simple.NFData () +import DDC.Type.Exp.Simple.Pretty () +import DDC.Type.Exp.Simple.Predicates +import DDC.Type.Exp.Simple.Compounds +import DDC.Type.Exp.Simple.Equiv +import DDC.Type.Exp.Simple.Subsumes + + + diff --git a/DDC/Type/Exp/Simple/Compounds.hs b/DDC/Type/Exp/Simple/Compounds.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Simple/Compounds.hs @@ -0,0 +1,663 @@ +{-# OPTIONS -fno-warn-missing-signatures #-} +module DDC.Type.Exp.Simple.Compounds + ( -- * Binds + takeNameOfBind + , typeOfBind + , replaceTypeOfBind + + -- * Binders + , binderOfBind + , makeBindFromBinder + , partitionBindsByType + + -- * Bounds + , takeNameOfBound + , takeTypeOfBound + , boundMatchesBind + , namedBoundMatchesBind + , takeSubstBoundOfBind + , takeSubstBoundsOfBinds + , replaceTypeOfBound + + -- * Kinds + , kFun, kFuns + , takeKFun + , takeKFuns, takeKFuns' + , takeResultKind + + -- * Quantifiers + , tForall, tForall' + , tForalls, tForalls' + , takeTForalls, eraseTForalls + + -- * Sums + , tBot + , tSum + + -- * Applications + , tApp, ($:) + , tApps, takeTApps + , takeTyConApps + , takePrimTyConApps + , takeDataTyConApps + , takePrimeRegion + + -- * Functions + , tFun + , tFunOfList + , tFunOfParamResult + , takeTFun + , takeTFunArgResult + , takeTFunWitArgResult + , takeTFunAllArgResult + , arityOfType + , dataArityOfType + + -- * Suspensions + , tSusp + , takeTSusp + , takeTSusps + + -- * Implications + , tImpl + + -- * Units + , tUnit + + -- * Variables + , tIx + , takeTExists + + -- * Sort construction + , sComp, sProp + + -- * Kind construction + , kData, kRegion, kEffect, kClosure, kWitness + + -- * Effect type constructors + , tRead, tDeepRead, tHeadRead + , tWrite, tDeepWrite + , tAlloc, tDeepAlloc + + -- * Witness type constructors + , tPure + , tConst, tDeepConst + , tMutable, tDeepMutable + , tDistinct + + -- * Type constructor wrappers. + , tConData0, tConData1) +where +import DDC.Type.Exp +import qualified DDC.Type.Sum as Sum + + +-- Binds ---------------------------------------------------------------------- +-- | Take the variable name of a bind. +-- If this is an anonymous binder then there won't be a name. +takeNameOfBind :: Bind n -> Maybe n +takeNameOfBind bb + = case bb of + BName n _ -> Just n + BAnon _ -> Nothing + BNone _ -> Nothing + + +-- | Take the type of a bind. +typeOfBind :: Bind n -> Type n +typeOfBind bb + = case bb of + BName _ t -> t + BAnon t -> t + BNone t -> t + + +-- | Replace the type of a bind with a new one. +replaceTypeOfBind :: Type n -> Bind n -> Bind n +replaceTypeOfBind t bb + = case bb of + BName n _ -> BName n t + BAnon _ -> BAnon t + BNone _ -> BNone t + + +-- Binders -------------------------------------------------------------------- +-- | Take the binder of a bind. +binderOfBind :: Bind n -> Binder n +binderOfBind bb + = case bb of + BName n _ -> RName n + BAnon _ -> RAnon + BNone _ -> RNone + + +-- | Make a bind from a binder and its type. +makeBindFromBinder :: Binder n -> Type n -> Bind n +makeBindFromBinder bb t + = case bb of + RName n -> BName n t + RAnon -> BAnon t + RNone -> BNone t + + +-- | Make lists of binds that have the same type. +partitionBindsByType :: Eq n => [Bind n] -> [([Binder n], Type n)] +partitionBindsByType [] = [] +partitionBindsByType (b:bs) + = let t = typeOfBind b + bsSame = takeWhile (\b' -> typeOfBind b' == t) bs + rs = map binderOfBind (b:bsSame) + in (rs, t) : partitionBindsByType (drop (length bsSame) bs) + + +-- Bounds --------------------------------------------------------------------- +-- | Take the name of bound variable. +-- If this is a deBruijn index then there won't be a name. +takeNameOfBound :: Bound n -> Maybe n +takeNameOfBound uu + = case uu of + UName n -> Just n + UPrim n _ -> Just n + UIx{} -> Nothing + + +-- | Get the attached type of a `Bound`, if any. +takeTypeOfBound :: Bound n -> Maybe (Type n) +takeTypeOfBound uu + = case uu of + UName{} -> Nothing + UPrim _ t -> Just t + UIx{} -> Nothing + + +-- | Check whether a bound maches a bind. +-- `UName` and `BName` match if they have the same name. +-- @UIx 0 _@ and @BAnon _@ always match. +-- Yields `False` for other combinations of bounds and binds. +boundMatchesBind :: Eq n => Bound n -> Bind n -> Bool +boundMatchesBind u b + = case (u, b) of + (UName n1, BName n2 _) -> n1 == n2 + (UIx 0, BAnon _) -> True + _ -> False + + +-- | Check whether a named bound matches a named bind. +-- Yields `False` if they are not named or have different names. +namedBoundMatchesBind :: Eq n => Bound n -> Bind n -> Bool +namedBoundMatchesBind u b + = case (u, b) of + (UName n1, BName n2 _) -> n1 == n2 + _ -> False + + +-- | Convert a `Bind` to a `Bound`, ready for substitution. +-- +-- Returns `UName` for `BName`, @UIx 0@ for `BAnon` +-- and `Nothing` for `BNone`, because there's nothing to substitute. +takeSubstBoundOfBind :: Bind n -> Maybe (Bound n) +takeSubstBoundOfBind bb + = case bb of + BName n _ -> Just $ UName n + BAnon _ -> Just $ UIx 0 + BNone _ -> Nothing + + +-- | Convert some `Bind`s to `Bounds` +takeSubstBoundsOfBinds :: [Bind n] -> [Bound n] +takeSubstBoundsOfBinds bs + = go 1 bs + where go _level [] = [] + go level (BName n _ : bs') = UName n : go level bs' + go level (BAnon _ : bs') = UIx (len - level) : go (level + 1) bs' + go level (BNone _ : bs') = go level bs' + + len = length [ () | BAnon _ <- bs] + + +-- | If this `Bound` is a `UPrim` then replace it's embedded type with a new +-- one, otherwise return it unharmed. +replaceTypeOfBound :: Type n -> Bound n -> Bound n +replaceTypeOfBound t uu + = case uu of + UName{} -> uu + UPrim n _ -> UPrim n t + UIx{} -> uu + + +-- Variables ------------------------------------------------------------------ +-- | Construct a deBruijn index. +tIx :: Kind n -> Int -> Type n +tIx _ i = TVar (UIx i) + + +-- Existentials --------------------------------------------------------------- +-- | Take an existential variable from a type. +takeTExists :: Type n -> Maybe Int +takeTExists tt + = case tt of + TCon (TyConExists n _) -> Just n + _ -> Nothing + + +-- Applications --------------------------------------------------------------- +-- | Construct an empty type sum. +tBot :: Kind n -> Type n +tBot k = TSum $ Sum.empty k + + +-- | Construct a type application. +tApp, ($:) :: Type n -> Type n -> Type n +tApp = TApp +($:) = TApp + + +-- | Construct a sequence of type applications. +tApps :: Type n -> [Type n] -> Type n +tApps t1 ts = foldl TApp t1 ts + + +-- | Flatten a sequence ot type applications into the function part and +-- arguments, if any. +takeTApps :: Type n -> [Type n] +takeTApps tt + = case tt of + TApp t1 t2 -> takeTApps t1 ++ [t2] + _ -> [tt] + + +-- | Flatten a sequence of type applications, returning the type constructor +-- and arguments, if there is one. +takeTyConApps :: Type n -> Maybe (TyCon n, [Type n]) +takeTyConApps tt + = case takeTApps tt of + TCon tc : args -> Just $ (tc, args) + _ -> Nothing + + +-- | Flatten a sequence of type applications, returning the type constructor +-- and arguments, if there is one. Only accept primitive type constructors. +takePrimTyConApps :: Type n -> Maybe (n, [Type n]) +takePrimTyConApps tt + = case takeTApps tt of + TCon tc : args + | TyConBound (UPrim n _) _ <- tc + -> Just (n, args) + _ -> Nothing + + +-- | Flatten a sequence of type applications, returning the type constructor +-- and arguments, if there is one. Only accept data type constructors. +takeDataTyConApps :: Type n -> Maybe (TyCon n, [Type n]) +takeDataTyConApps tt + = case takeTApps tt of + TCon tc : args + | TyConBound (UName{}) k <- tc + , TCon (TyConKind KiConData) <- takeResultKind k + -> Just (tc, args) + _ -> Nothing + + +-- | Take the prime region variable of a data type. +-- This corresponds to the region the outermost constructor is allocated into. +takePrimeRegion :: Type n -> Maybe (Type n) +takePrimeRegion tt + = case takeTApps tt of + TCon _ : tR@(TVar _) : _ + -> Just tR + _ -> Nothing + + +-- Foralls -------------------------------------------------------------------- +-- | Build an anonymous type abstraction, with a single parameter. +tForall :: Kind n -> (Type n -> Type n) -> Type n +tForall k f + = TForall (BAnon k) (f (TVar (UIx 0))) + +-- | Build an anonymous type abstraction, with a single parameter. +-- Starting the next index from the given value. +tForall' :: Int -> Kind n -> (Type n -> Type n) -> Type n +tForall' ix k f + = TForall (BAnon k) (f (TVar (UIx ix))) + + +-- | Build an anonymous type abstraction, with several parameters. +-- Starting the next index from the given value. +tForalls :: [Kind n] -> ([Type n] -> Type n) -> Type n +tForalls ks f + = let bs = [BAnon k | k <- ks] + us = map (\i -> TVar (UIx i)) [0 .. (length ks - 1)] + in foldr TForall (f $ reverse us) bs + + +-- | Build an anonymous type abstraction, with several parameters. +-- Starting the next index from the given value. +tForalls' :: Int -> [Kind n] -> ([Type n] -> Type n) -> Type n +tForalls' ix ks f + = let bs = [BAnon k | k <- ks] + us = map (\i -> TVar (UIx i)) [ix .. ix + (length ks - 1)] + in foldr TForall (f $ reverse us) bs + + +-- | Split nested foralls from the front of a type, +-- or `Nothing` if there was no outer forall. +takeTForalls :: Type n -> Maybe ([Bind n], Type n) +takeTForalls tt + = let go bs (TForall b t) = go (b:bs) t + go bs t = (reverse bs, t) + in case go [] tt of + ([], _) -> Nothing + (bs, body) -> Just (bs, body) + + +-- | Erase all `TForall` quantifiers from a type. +eraseTForalls :: Ord n => Type n -> Type n +eraseTForalls tt + = case tt of + TVar{} -> tt + TCon{} -> tt + TAbs{} -> tt + TApp t1 t2 -> TApp (eraseTForalls t1) (eraseTForalls t2) + TForall _ t -> eraseTForalls t + TSum ts -> TSum $ Sum.fromList (Sum.kindOfSum ts) + $ map eraseTForalls $ Sum.toList ts + + +-- Sums ----------------------------------------------------------------------- +tSum :: Ord n => Kind n -> [Type n] -> Type n +tSum k ts = TSum (Sum.fromList k ts) + + +-- Unit ----------------------------------------------------------------------- +-- | The unit type. +tUnit :: Type n +tUnit = TCon (TyConSpec TcConUnit) + + +-- Function Constructors ------------------------------------------------------ +-- | Construct a kind function. +kFun :: Kind n -> Kind n -> Kind n +kFun k1 k2 = ((TCon $ TyConKind KiConFun)`TApp` k1) `TApp` k2 +infixr `kFun` + + +-- | Construct some kind functions. +kFuns :: [Kind n] -> Kind n -> Kind n +kFuns [] k1 = k1 +kFuns (k:ks) k1 = k `kFun` kFuns ks k1 + + +-- | Destruct a kind function +takeKFun :: Kind n -> Maybe (Kind n, Kind n) +takeKFun kk + = case kk of + TApp (TApp (TCon (TyConKind KiConFun)) k1) k2 + -> Just (k1, k2) + _ -> Nothing + + +-- | Destruct a chain of kind functions into the arguments +takeKFuns :: Kind n -> ([Kind n], Kind n) +takeKFuns kk + = case kk of + TApp (TApp (TCon (TyConKind KiConFun)) k1) k2 + | (ks, k2') <- takeKFuns k2 + -> (k1 : ks, k2') + + _ -> ([], kk) + + +-- | Like `takeKFuns`, but return argument and return kinds in the same list. +takeKFuns' :: Kind n -> [Kind n] +takeKFuns' kk + | (ks, k1) <- takeKFuns kk + = ks ++ [k1] + + +-- | Take the result kind of a kind function, or return the same kind +-- unharmed if it's not a kind function. +takeResultKind :: Kind n -> Kind n +takeResultKind kk + = case kk of + TApp (TApp (TCon (TyConKind KiConFun)) _) k2 + -> takeResultKind k2 + _ -> kk + + +-- Function types ------------------------------------------------------------- +-- | Construct a pure function type. +tFun :: Type n -> Type n -> Type n +tFun t1 t2 + = (TCon $ TyConSpec TcConFun) `tApps` [t1, t2] +infixr `tFun` + + +-- | Construct a function type from a list of parameter types and the +-- return type. +tFunOfParamResult :: [Type n] -> Type n -> Type n +tFunOfParamResult tsArg tResult + = let tFuns' [] = tResult + tFuns' (t': ts') = t' `tFun` tFuns' ts' + in tFuns' tsArg + + +-- | Construct a function type from a list containing the parameter +-- and return types. Yields `Nothing` if the list is empty. +tFunOfList :: [Type n] -> Maybe (Type n) +tFunOfList ts + = case reverse ts of + [] -> Nothing + (t : tsArgs) + -> let tFuns' [] = t + tFuns' (t' : ts') = t' `tFun` tFuns' ts' + in Just $ tFuns' (reverse tsArgs) + + +-- | Yield the argument and result type of a function type. +takeTFun :: Type n -> Maybe (Type n, Type n) +takeTFun tt + = case tt of + TApp (TApp (TCon (TyConSpec TcConFun)) t1) t2 + -> Just (t1, t2) + _ -> Nothing + + +-- | Destruct the type of a function, returning just the argument and result types. +takeTFunArgResult :: Type n -> ([Type n], Type n) +takeTFunArgResult tt + = case tt of + TApp (TApp (TCon (TyConSpec TcConFun)) t1) t2 + -> let (tsMore, tResult) = takeTFunArgResult t2 + in (t1 : tsMore, tResult) + _ -> ([], tt) + + +-- | Destruct the type of a function, +-- returning the witness argument, value argument and result types. +-- The function type must have the witness implications before +-- the value arguments, eg @T1 => T2 -> T3 -> T4 -> T5@. +takeTFunWitArgResult :: Type n -> ([Type n], [Type n], Type n) +takeTFunWitArgResult tt + = case tt of + TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2 + -> let (twsMore, tvsMore, tResult) = takeTFunWitArgResult t2 + in (t1 : twsMore, tvsMore, tResult) + + _ -> let (tvsMore, tResult) = takeTFunArgResult tt + in ([], tvsMore, tResult) + + +-- | Destruct the type of a possibly polymorphic function +-- returning all kinds of quantifiers, witness arguments, +-- and value arguments in the order they appear, along with +-- the type of the result. +takeTFunAllArgResult :: Type n -> ([Type n], Type n) +takeTFunAllArgResult tt + = case tt of + TVar{} -> ([], tt) + TCon{} -> ([], tt) + + TForall b t + -> let (tsMore, tResult) = takeTFunAllArgResult t + in (typeOfBind b : tsMore, tResult) + + TApp (TApp (TCon (TyConSpec TcConFun)) t1) t2 + -> let (tsMore, tResult) = takeTFunAllArgResult t2 + in (t1 : tsMore, tResult) + + TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2 + -> let (tsMore, tResult) = takeTFunAllArgResult t2 + in (t1 : tsMore, tResult) + + _ -> ([], tt) + + +-- | Determine the arity of an expression by looking at its type. +-- Count all the function arrows, and foralls. +-- +-- This assumes the type is in prenex form, meaning that all the quantifiers +-- are at the front. +arityOfType :: Type n -> Int +arityOfType tt + = case tt of + TForall _ t -> 1 + arityOfType t + t -> length $ fst $ takeTFunArgResult t + + +-- | The data arity of a type is the number of data values it takes. +-- Unlike `arityOfType` we ignore type and witness parameters. +dataArityOfType :: Type n -> Int +dataArityOfType tt + = case tt of + TVar{} -> 0 + TCon{} -> 0 + + TForall _ t -> dataArityOfType t + + TApp (TApp (TCon (TyConSpec TcConFun)) _) t2 + -> 1 + dataArityOfType t2 + + TApp (TApp (TCon (TyConWitness TwConImpl)) _) t2 + -> dataArityOfType t2 + + _ -> 0 + + +-- Implications --------------------------------------------------------------- +-- | Construct a witness implication type. +tImpl :: Type n -> Type n -> Type n +tImpl t1 t2 + = ((TCon $ TyConWitness TwConImpl) `tApp` t1) `tApp` t2 +infixr `tImpl` + + +-- Suspensions ---------------------------------------------------------------- +-- | Construct a suspension type. +tSusp :: Effect n -> Type n -> Type n +tSusp tE tA + = (TCon $ TyConSpec TcConSusp) `tApp` tE `tApp` tA + + +-- | Take the effect and result type of a suspension type. +takeTSusp :: Type n -> Maybe (Effect n, Type n) +takeTSusp tt + = case tt of + TApp (TApp (TCon (TyConSpec TcConSusp)) tE) tA + -> Just (tE, tA) + _ -> Nothing + + +-- | Split off enclosing suspension types. +takeTSusps :: Type n -> ([Effect n], Type n) +takeTSusps tt + = case tt of + TApp (TApp (TCon (TyConSpec TcConSusp)) tE) tRest + -> let (tEs, tA) = takeTSusps tRest + in (tE : tEs, tA) + _ -> ([], tt) + + +-- Level 3 constructors (sorts) ----------------------------------------------- +-- | Sort of kinds of computational types. +sComp = TCon $ TyConSort SoConComp + +-- | Sort of kinds of propositional types. +sProp = TCon $ TyConSort SoConProp + + +-- Level 2 constructors (kinds) ----------------------------------------------- +-- | Kind of data types. +kData = TCon $ TyConKind KiConData + +-- | Kind of region types. +kRegion = TCon $ TyConKind KiConRegion + +-- | Kind of effect types. +kEffect = TCon $ TyConKind KiConEffect + +-- | Kind of closure types. +kClosure = TCon $ TyConKind KiConClosure + +-- | Kind of witness types. +kWitness = TCon $ TyConKind KiConWitness + + +-- Level 1 constructors (witness and computation types) ----------------------- +-- Effect type constructors +-- | Read effect type constructor. +tRead = tcCon1 TcConRead + +-- | Head Read effect type constructor. +tHeadRead = tcCon1 TcConHeadRead + +-- | Deep Read effect type constructor. +tDeepRead = tcCon1 TcConDeepRead + +-- | Write effect type constructor. +tWrite = tcCon1 TcConWrite + +-- | Deep Write effect type constructor. +tDeepWrite = tcCon1 TcConDeepWrite + +-- | Alloc effect type constructor. +tAlloc = tcCon1 TcConAlloc + +-- | Deep Alloc effect type constructor. +tDeepAlloc = tcCon1 TcConDeepAlloc + +-- Witness type constructors. +-- | Pure witness type constructor. +tPure = twCon1 TwConPure + +-- | Const witness type constructor. +tConst = twCon1 TwConConst + +-- | Deep Const witness type constructor. +tDeepConst = twCon1 TwConDeepConst + +-- | Mutable witness type constructor. +tMutable = twCon1 TwConMutable + +-- | Deep Mutable witness type constructor. +tDeepMutable = twCon1 TwConDeepMutable + +-- | Distinct witness type constructor. +tDistinct n = twCon2 (TwConDistinct n) + +-- | Wrap a computation type constructor applied to a single argument. +tcCon1 tc t = (TCon $ TyConSpec tc) `tApp` t + +-- | Wrap a witness type constructor applied to a single argument. +twCon1 tc t = (TCon $ TyConWitness tc) `tApp` t + +-- | Wrap a witness type constructor applied to two arguments. +twCon2 tc ts = tApps (TCon $ TyConWitness tc) ts + +-- | Build a nullary type constructor of the given kind. +tConData0 :: n -> Kind n -> Type n +tConData0 n k = TCon (TyConBound (UName n) k) + +-- | Build a type constructor application of one argumnet. +tConData1 :: n -> Kind n -> Type n -> Type n +tConData1 n k t1 = TApp (TCon (TyConBound (UName n) k)) t1 + diff --git a/DDC/Type/Exp/Simple/Equiv.hs b/DDC/Type/Exp/Simple/Equiv.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Simple/Equiv.hs @@ -0,0 +1,339 @@ + +module DDC.Type.Exp.Simple.Equiv + ( equivT + , equivWithBindsT + , equivTyCon + + , crushHeadT + , crushSomeT + , crushEffect) +where +import DDC.Type.Exp.Simple.Predicates +import DDC.Type.Exp.Simple.Compounds +import DDC.Type.Exp.Simple.Exp +import DDC.Type.Bind +import qualified DDC.Type.Sum as Sum +import qualified Data.Map.Strict as Map + +import DDC.Core.Env.EnvT (EnvT) +import qualified DDC.Core.Env.EnvT as EnvT + + +--------------------------------------------------------------------------------------------------- +-- | Check equivalence of types. +-- +-- Checks equivalence up to alpha-renaming, as well as crushing of effects +-- and trimming of closures. +-- +-- * Return `False` if we find any free variables. +-- +-- * We assume the types are well-kinded, so that the type annotations on +-- bound variables match the binders. If this is not the case then you get +-- an indeterminate result. +-- +equivT :: Ord n + => EnvT n -> Type n -> Type n -> Bool + +equivT env t1 t2 + = equivWithBindsT env [] [] t1 t2 + +-- | Like `equivT` but take the initial stacks of type binders. +equivWithBindsT + :: Ord n + => EnvT n -- ^ Environment of types. + -> [Bind n] -- ^ Stack of binders for first type. + -> [Bind n] -- ^ Stack of binders for second type. + -> Type n -- ^ First type to compare. + -> Type n -- ^ Second type to compare. + -> Bool + +equivWithBindsT env stack1 stack2 t1 t2 + = let t1' = unpackSumT $ crushSomeT env t1 + t2' = unpackSumT $ crushSomeT env t2 + + in case (t1', t2') of + (TVar u1, TVar u2) + -- Free variables are name-equivalent, bound variables aren't: + -- (forall a. a) != (forall b. a) + | Nothing <- getBindType stack1 u1 + , Nothing <- getBindType stack2 u2 + , u1 == u2 -> checkBounds u1 u2 True + + -- Both variables are bound in foralls, so check the stack + -- to see if they would be equivalent if we named them. + | Just (ix1, t1a) <- getBindType stack1 u1 + , Just (ix2, t2a) <- getBindType stack2 u2 + , ix1 == ix2 + -> checkBounds u1 u2 + $ equivWithBindsT env stack1 stack2 t1a t2a + + | otherwise + -> checkBounds u1 u2 + $ False + + -- Lookup type equations. + (TCon (TyConBound (UName n) _), _) + | Just t1'' <- Map.lookup n (EnvT.envtEquations env) + -> equivWithBindsT env stack1 stack2 t1'' t2' + + (_, TCon (TyConBound (UName n) _)) + | Just t2'' <- Map.lookup n (EnvT.envtEquations env) + -> equivWithBindsT env stack1 stack2 t1' t2'' + + -- Constructor names must be equal. + (TCon tc1, TCon tc2) + -> equivTyCon tc1 tc2 + + -- Push binders on the stack as we enter foralls. + (TForall b11 t12, TForall b21 t22) + | equivT env (typeOfBind b11) (typeOfBind b21) + -> equivWithBindsT env + (b11 : stack1) + (b21 : stack2) + t12 t22 + + -- Decend into applications. + (TApp t11 t12, TApp t21 t22) + -> equivWithBindsT env stack1 stack2 t11 t21 + && equivWithBindsT env stack1 stack2 t12 t22 + + -- Sums are equivalent if all of their components are. + (TSum ts1, TSum ts2) + -> let ts1' = Sum.toList ts1 + ts2' = Sum.toList ts2 + + -- If all the components of the sum were in the element + -- arrays then they come out of Sum.toList sorted + -- and we can compare corresponding pairs. + checkFast = and $ zipWith (equivWithBindsT env stack1 stack2) ts1' ts2' + + -- If any of the components use a higher kinded type variable + -- like (c : % ~> !) then they won't nessesarally be sorted, + -- so we need to do this slower O(n^2) check. + -- Make sure to get the bind stacks the right way around here. + checkSlow = and [ or (map (equivWithBindsT env stack1 stack2 t1c) ts2') + | t1c <- ts1' ] + + && and [ or (map (equivWithBindsT env stack2 stack1 t2c) ts1') + | t2c <- ts2' ] + + in (length ts1' == length ts2') + && (checkFast || checkSlow) + + (_, _) -> False + + +-- | If we have a UName and UPrim with the same name then these won't match +-- even though they pretty print the same. This will only happen due to +-- a compiler bugs, but is very confusing when it does, so we check for +-- this case explicitly. +checkBounds :: Eq n => Bound n -> Bound n -> a -> a +checkBounds u1 u2 x + = case (u1, u2) of + (UName n2, UPrim n1 _) + | n1 == n2 -> die + + (UPrim n1 _, UName n2) + | n1 == n2 -> die + + _ -> x + where + die = error $ unlines + [ "DDC.Type.Equiv" + , " Found a primitive and non-primitive bound variable with the same name."] + + +-- | Unpack single element sums into plain types. +unpackSumT :: Type n -> Type n +unpackSumT (TSum ts) + | [t] <- Sum.toList ts = t +unpackSumT tt = tt + + +-- TyCon +-- | Check if two `TyCons` are equivalent. +-- We need to handle `TyConBound` specially incase it's kind isn't attached, +equivTyCon :: Eq n => TyCon n -> TyCon n -> Bool +equivTyCon tc1 tc2 + = case (tc1, tc2) of + (TyConBound u1 _, TyConBound u2 _) -> u1 == u2 + _ -> tc1 == tc2 + + + +--------------------------------------------------------------------------------------------------- +-- | Crush effects in the given type. +crushHeadT :: Ord n => EnvT n -> Type n -> Type n +crushHeadT env tt + = case tt of + TCon (TyConBound (UName n) _) + -> case Map.lookup n (EnvT.envtEquations env) of + Nothing -> tt + Just tt' -> crushHeadT env tt' + + TCon{} -> tt + + TVar{} -> tt + + TAbs{} -> tt + + TApp t1 t2 + -> let t1' = crushHeadT env t1 + t2' = crushHeadT env t2 + in TApp t1' t2' + + TForall{} -> tt + + TSum{} -> tt + + +-- | Crush compound effects and closure terms. +-- We check for a crushable term before calling crushT because that function +-- will recursively crush the components. +-- As equivT is already recursive, we don't want a doubly-recursive function +-- that tries to re-crush the same non-crushable type over and over. +-- +crushSomeT :: Ord n => EnvT n -> Type n -> Type n +crushSomeT env tt + = case tt of + TApp (TCon tc) _ + -> case tc of + TyConSpec TcConDeepRead -> crushEffect env tt + TyConSpec TcConDeepWrite -> crushEffect env tt + TyConSpec TcConDeepAlloc -> crushEffect env tt + _ -> tt + + _ -> tt + + +-- | Crush compound effect terms into their components. +-- +-- For example, crushing @DeepRead (List r1 (Int r2))@ yields @(Read r1 + Read r2)@. +-- +crushEffect :: Ord n => EnvT n -> Effect n -> Effect n +crushEffect env tt + = {-# SCC crushEffect #-} + case tt of + TVar{} -> tt + + TCon{} -> tt + + TApp{} + | or [equivT env tt t | (_, t) <- Map.toList $ EnvT.envtCapabilities env] + -> tSum kEffect [] + + TAbs b t + -> TAbs b $ crushEffect env t + + TApp t1 t2 + -- Head Read. + | Just (TyConSpec TcConHeadRead, [t]) <- takeTyConApps tt + -> case takeTyConApps t of + + -- Type has a head region. + Just (TyConBound _ k, (tR : _)) + | (k1 : _, _) <- takeKFuns k + , isRegionKind k1 + -> tRead tR + + -- Type has no head region. + -- This happens with case () of { ... } + Just (TyConSpec TcConUnit, []) + -> tBot kEffect + + Just (TyConBound _ _, _) + -> tBot kEffect + + _ -> tt + + -- Deep Read. + -- See Note: Crushing with higher kinded type vars. + | Just (TyConSpec TcConDeepRead, [t]) <- takeTyConApps tt + -> case takeTyConApps t of + Just (TyConBound _ k, ts) + | (ks, _) <- takeKFuns k + , length ks == length ts + , Just effs <- sequence $ zipWith makeDeepRead ks ts + -> crushEffect env $ TSum $ Sum.fromList kEffect effs + + _ -> tt + + -- Deep Write + -- See Note: Crushing with higher kinded type vars. + | Just (TyConSpec TcConDeepWrite, [t]) <- takeTyConApps tt + -> case takeTyConApps t of + Just (TyConBound _ k, ts) + | (ks, _) <- takeKFuns k + , length ks == length ts + , Just effs <- sequence $ zipWith makeDeepWrite ks ts + -> crushEffect env $ TSum $ Sum.fromList kEffect effs + + _ -> tt + + -- Deep Alloc + -- See Note: Crushing with higher kinded type vars. + | Just (TyConSpec TcConDeepAlloc, [t]) <- takeTyConApps tt + -> case takeTyConApps t of + Just (TyConBound _ k, ts) + | (ks, _) <- takeKFuns k + , length ks == length ts + , Just effs <- sequence $ zipWith makeDeepAlloc ks ts + -> crushEffect env $ TSum $ Sum.fromList kEffect effs + + _ -> tt + + | otherwise + -> TApp (crushEffect env t1) (crushEffect env t2) + + TForall b t + -> TForall b $ crushEffect env t + + TSum ts + -> TSum + $ Sum.fromList (Sum.kindOfSum ts) + $ map (crushEffect env) + $ Sum.toList ts + + +-- | If this type has first order kind then wrap with the +-- appropriate read effect. +makeDeepRead :: Kind n -> Type n -> Maybe (Effect n) +makeDeepRead k t + | isRegionKind k = Just $ tRead t + | isDataKind k = Just $ tDeepRead t + | isClosureKind k = Just $ tBot kEffect + | isEffectKind k = Just $ tBot kEffect + | otherwise = Nothing + + +-- | If this type has first order kind then wrap with the +-- appropriate read effect. +makeDeepWrite :: Kind n -> Type n -> Maybe (Effect n) +makeDeepWrite k t + | isRegionKind k = Just $ tWrite t + | isDataKind k = Just $ tDeepWrite t + | isClosureKind k = Just $ tBot kEffect + | isEffectKind k = Just $ tBot kEffect + | otherwise = Nothing + + +-- | If this type has first order kind then wrap with the +-- appropriate read effect. +makeDeepAlloc :: Kind n -> Type n -> Maybe (Effect n) +makeDeepAlloc k t + | isRegionKind k = Just $ tAlloc t + | isDataKind k = Just $ tDeepAlloc t + | isClosureKind k = Just $ tBot kEffect + | isEffectKind k = Just $ tBot kEffect + | otherwise = Nothing + + + +{- [Note: Crushing with higher kinded type vars] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We can't just look at the free variables here and wrap Read and DeepRead constructors + around them, as the type may contain higher kinded type variables such as: (t a). + Instead, we'll only crush the effect when all variable have first-order kind. + When comparing types with higher order variables, we'll have to use the type + equivalence checker, instead of relying on the effects to be pre-crushed. +-} diff --git a/DDC/Type/Exp/Simple/Exp.hs b/DDC/Type/Exp/Simple/Exp.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Simple/Exp.hs @@ -0,0 +1,182 @@ + +module DDC.Type.Exp.Simple.Exp + ( Binder (..) + , Bind (..) + , Bound (..) + , Type (..) + , Sort + , Kind + , Region + , Effect + , Closure + , TypeSum (..) + , TyConHash (..) + , TypeSumVarCon (..) + , TyCon (..) + , SoCon (..) + , KiCon (..) + , TwCon (..) + , TcCon (..)) +where +import DDC.Type.Exp.TyCon +import Data.Array +import Data.Map.Strict (Map) +import Data.Set (Set) + + +-- Binder --------------------------------------------------------------------- +data Binder n + = RNone + | RAnon + | RName !n + deriving Show + + +-- Bind ----------------------------------------------------------------------- +-- | A variable binder with its type. +data Bind n + -- | A variable with no uses in the body doesn't need a name. + = BNone !(Type n) + + -- | Nameless variable on the deBruijn stack. + | BAnon !(Type n) + + -- | Named variable in the environment. + | BName n !(Type n) + deriving Show + + + +-- | A bound occurrence of a variable, with its type. +-- +-- If variable hasn't been annotated with its real type then this +-- can be `tBot` (an empty sum). + +data Bound n + -- | Nameless variable that should be on the deBruijn stack. + = UIx !Int + + -- | Named variable that should be in the environment. + | UName !n + + -- | Named primitive that has its type attached to it. + -- The types of primitives must be closed. + | UPrim !n !(Type n) + deriving Show + + +-- Types ---------------------------------------------------------------------- +-- | A value type, kind, or sort. +-- +-- We use the same data type to represent all three universes, as they have +-- a similar algebraic structure. +-- +data Type n + -- | Constructor. + = TCon !(TyCon n) + + -- | Variable. + | TVar !(Bound n) + + -- | Abstraction. + | TAbs !(Bind n) !(Type n) + + -- | Application. + | TApp !(Type n) !(Type n) + + -- | Universal Quantification. + | TForall !(Bind n) !(Type n) + + -- | Least upper bound. + | TSum !(TypeSum n) + deriving Show + + +-- | Sorts are types at level 3. +type Sort n = Type n + +-- | Kinds are types at level 2 +type Kind n = Type n + +-- | Alias for region types. +type Region n = Type n + +-- | Alias for effect types. +type Effect n = Type n + +-- | Alias for closure types. +type Closure n = Type n + + +-- Type Sums ------------------------------------------------------------------ +-- | A least upper bound of several types. +-- +-- We keep type sums in this normalised format instead of joining them +-- together with a binary operator (like @(+)@). This makes sums easier to work +-- with, as a given sum type often only has a single physical representation. +data TypeSum n + = TypeSumBot + { typeSumKind :: !(Kind n) } + + | TypeSumSet + { -- | The kind of the elements in this sum. + typeSumKind :: !(Kind n) + + -- | Where we can see the outer constructor of a type, its argument + -- is inserted into this array. This handles common cases like + -- Read, Write, Alloc effects. + , typeSumElems :: !(Array TyConHash (Set (TypeSumVarCon n))) + + -- | A map for named type variables. + , typeSumBoundNamed :: !(Map n (Kind n)) + + -- | A map for anonymous type variables. + , typeSumBoundAnon :: !(Map Int (Kind n)) + + -- | Types that can't be placed in the other fields go here. + -- + -- INVARIANT: this list doesn't contain more `TSum`s. + , typeSumSpill :: ![Type n] } + deriving Show + + +-- | Hash value used to insert types into the `typeSumElems` array of a `TypeSum`. +data TyConHash + = TyConHash !Int + deriving (Eq, Show, Ord, Ix) + + +-- | Wraps a variable or constructor that can be added the `typeSumElems` array. +data TypeSumVarCon n + = TypeSumVar !(Bound n) + | TypeSumCon !(Bound n) !(Kind n) + deriving Show + + +-- TyCon ---------------------------------------------------------------------- +-- | Kind, type and witness constructors. +-- +-- These are grouped to make it easy to determine the universe that they +-- belong to. +-- +data TyCon n + -- | (level 3) Builtin Sort constructors. + = TyConSort !SoCon + + -- | (level 2) Builtin Kind constructors. + | TyConKind !KiCon + + -- | (level 1) Builtin Spec constructors for the types of witnesses. + | TyConWitness !TwCon + + -- | (level 1) Builtin Spec constructors for types of other kinds. + | TyConSpec !TcCon + + -- | User defined type constructor. + | TyConBound !(Bound n) !(Kind n) + + -- | An existentially quantified name, with its kind. + -- Used during type checking, but not accepted in source programs. + | TyConExists !Int !(Kind n) + deriving Show + diff --git a/DDC/Type/Exp/Simple/NFData.hs b/DDC/Type/Exp/Simple/NFData.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Simple/NFData.hs @@ -0,0 +1,77 @@ + +module DDC.Type.Exp.Simple.NFData where +import DDC.Type.Exp.Simple.Exp +import Control.DeepSeq + + +instance NFData n => NFData (Binder n) where + rnf bb + = case bb of + RNone -> () + RAnon -> () + RName n -> rnf n + + +instance NFData n => NFData (Bind n) where + rnf bb + = case bb of + BNone t -> rnf t + BAnon t -> rnf t + BName n t -> rnf n `seq` rnf t + + +instance NFData n => NFData (Bound n) where + rnf uu + = case uu of + UIx i -> rnf i + UName n -> rnf n + UPrim u t -> rnf u `seq` rnf t + + +instance NFData n => NFData (Type n) where + rnf tt + = case tt of + TVar u -> rnf u + TCon tc -> rnf tc + TAbs b t -> rnf b `seq` rnf t + TApp t1 t2 -> rnf t1 `seq` rnf t2 + TForall b t -> rnf b `seq` rnf t + TSum ts -> rnf ts + + +instance NFData n => NFData (TypeSum n) where + rnf !ts + = case ts of + TypeSumBot{} + -> rnf (typeSumKind ts) + + TypeSumSet{} + -> rnf (typeSumKind ts) + `seq` rnf (typeSumElems ts) + `seq` rnf (typeSumBoundNamed ts) + `seq` rnf (typeSumBoundAnon ts) + `seq` rnf (typeSumSpill ts) + + +instance NFData TyConHash where + rnf (TyConHash i) + = rnf i + + +instance NFData n => NFData (TypeSumVarCon n) where + rnf ts + = case ts of + TypeSumVar u -> rnf u + TypeSumCon u k -> rnf u `seq` rnf k + + +instance NFData n => NFData (TyCon n) where + rnf tc + = case tc of + TyConSort _ -> () + TyConKind _ -> () + TyConWitness _ -> () + TyConSpec _ -> () + TyConBound con k -> rnf con `seq` rnf k + TyConExists n k -> rnf n `seq` rnf k + diff --git a/DDC/Type/Exp/Simple/Predicates.hs b/DDC/Type/Exp/Simple/Predicates.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Simple/Predicates.hs @@ -0,0 +1,263 @@ + +-- | Predicates on type expressions. +module DDC.Type.Exp.Simple.Predicates + ( -- * Binders + isBNone + , isBAnon + , isBName + + -- * Atoms + , isTVar + , isBot + , isAtomT + , isTExists + + -- * Kinds + , isDataKind + , isRegionKind + , isEffectKind + , isClosureKind + , isWitnessKind + + -- * Data Types + , isAlgDataType + , isWitnessType + , isConstWitType + , isMutableWitType + , isDistinctWitType + , isFunishTCon + + -- * Effect Types + , isReadEffect + , isWriteEffect + , isAllocEffect + , isSomeReadEffect + , isSomeWriteEffect + , isSomeAllocEffect) +where +import DDC.Type.Exp +import DDC.Type.Exp.Simple.Compounds +import Data.Maybe +import qualified DDC.Type.Sum as T + + +-- Binders -------------------------------------------------------------------- +isBNone :: Bind n -> Bool +isBNone bb + = case bb of + BNone{} -> True + _ -> False + +isBAnon :: Bind n -> Bool +isBAnon bb + = case bb of + BAnon{} -> True + _ -> False + +isBName :: Bind n -> Bool +isBName bb + = case bb of + BName{} -> True + _ -> False + + +-- Atoms ---------------------------------------------------------------------- +-- | Check whether a type is a `TVar` +isTVar :: Type n -> Bool +isTVar tt + = case tt of + TVar{} -> True + _ -> False + +-- | Test if some type is an empty TSum +isBot :: Type n -> Bool +isBot tt + | TSum ss <- tt + , [] <- T.toList ss + = True + + | otherwise = False + + +-- | Check whether a type is a `TVar`, `TCon` or is Bottom. +isAtomT :: Type n -> Bool +isAtomT tt + = case tt of + TVar{} -> True + TCon{} -> True + _ -> isBot tt + + +-- | Check whether this type is an existential variable. +isTExists :: Type n -> Bool +isTExists tt + = isJust $ takeTExists tt + + +-- Kinds ---------------------------------------------------------------------- +-- | Check if some kind is the data kind. +isDataKind :: Kind n -> Bool +isDataKind tt + = case tt of + TCon (TyConKind KiConData) -> True + _ -> False + + +-- | Check if some kind is the region kind. +isRegionKind :: Region n -> Bool +isRegionKind tt + = case tt of + TCon (TyConKind KiConRegion) -> True + _ -> False + + +-- | Check if some kind is the effect kind. +isEffectKind :: Kind n -> Bool +isEffectKind tt + = case tt of + TCon (TyConKind KiConEffect) -> True + _ -> False + + +-- | Check if some kind is the closure kind. +isClosureKind :: Kind n -> Bool +isClosureKind tt + = case tt of + TCon (TyConKind KiConClosure) -> True + _ -> False + + +-- | Check if some kind is the witness kind. +isWitnessKind :: Kind n -> Bool +isWitnessKind tt + = case tt of + TCon (TyConKind KiConWitness) -> True + _ -> False + + +-- Data Types ----------------------------------------------------------------- +-- | Check whether this type is that of algebraic data. +-- +-- It needs to have an explicit data constructor out the front, +-- and not a type variable. The constructor must not be the function +-- constructor, and must return a value of kind '*'. +--- +-- The function constructor (->) also has this result kind, +-- but it is in `TyConComp`, so is easy to ignore. +isAlgDataType :: Eq n => Type n -> Bool +isAlgDataType tt + | Just (tc, _) <- takeTyConApps tt + , TyConBound _ k <- tc + = takeResultKind k == kData + + | otherwise + = False + +-- | Check whether type is a witness constructor +isWitnessType :: Eq n => Type n -> Bool +isWitnessType tt + = case takeTyConApps tt of + Just (TyConWitness _, _) -> True + _ -> False + + +-- | Check whether this is the type of a @Const@ witness. +isConstWitType :: Eq n => Type n -> Bool +isConstWitType tt + = case takeTyConApps tt of + Just (TyConWitness TwConConst, _) -> True + _ -> False + + +-- | Check whether this is the type of a @Mutable@ witness. +isMutableWitType :: Eq n => Type n -> Bool +isMutableWitType tt + = case takeTyConApps tt of + Just (TyConWitness TwConMutable, _) -> True + _ -> False + + +-- | Check whether this is the type of a @Distinct@ witness. +isDistinctWitType :: Eq n => Type n -> Bool +isDistinctWitType tt + = case takeTyConApps tt of + Just (TyConWitness (TwConDistinct _), _) -> True + _ -> False + + +-- | Check if this is the TyFun or KiFun constructor. +isFunishTCon :: Type n -> Bool +isFunishTCon tt + = case tt of + TCon (TyConSpec TcConFun) -> True + TCon (TyConKind KiConFun) -> True + _ -> False + + +-- Effects -------------------------------------------------------------------- +-- | Check whether this is an atomic read effect. +isReadEffect :: Effect n -> Bool +isReadEffect eff + = case eff of + TApp (TCon (TyConSpec TcConRead)) _ -> True + _ -> False + + +-- | Check whether this is an atomic write effect. +isWriteEffect :: Effect n -> Bool +isWriteEffect eff + = case eff of + TApp (TCon (TyConSpec TcConWrite)) _ -> True + _ -> False + + +-- | Check whether this is an atomic alloc effect. +isAllocEffect :: Effect n -> Bool +isAllocEffect eff + = case eff of + TApp (TCon (TyConSpec TcConAlloc)) _ -> True + _ -> False + + +-- | Check whether an effect is some sort of read effect. +-- Matches @Read@ @HeadRead@ and @DeepRead@. +isSomeReadEffect :: Effect n -> Bool +isSomeReadEffect tt + = case tt of + TApp (TCon (TyConSpec con)) _ + -> case con of + TcConRead -> True + TcConHeadRead -> True + TcConDeepRead -> True + _ -> False + + _ -> False + + +-- | Check whether an effect is some sort of allocation effect. +-- Matches @Alloc@ and @DeepAlloc@ +isSomeWriteEffect :: Effect n -> Bool +isSomeWriteEffect tt + = case tt of + TApp (TCon (TyConSpec con)) _ + -> case con of + TcConWrite -> True + TcConDeepWrite -> True + _ -> False + + _ -> False + + +-- | Check whether an effect is some sort of allocation effect. +-- Matches @Alloc@ and @DeepAlloc@ +isSomeAllocEffect :: Effect n -> Bool +isSomeAllocEffect tt + = case tt of + TApp (TCon (TyConSpec con)) _ + -> case con of + TcConAlloc -> True + TcConDeepAlloc -> True + _ -> False + + _ -> False + diff --git a/DDC/Type/Exp/Simple/Pretty.hs b/DDC/Type/Exp/Simple/Pretty.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Simple/Pretty.hs @@ -0,0 +1,144 @@ + +module DDC.Type.Exp.Simple.Pretty + (module DDC.Data.Pretty) +where +import DDC.Type.Exp.Simple.Exp +import DDC.Type.Exp.Simple.Predicates +import DDC.Type.Exp.Simple.Compounds +import DDC.Type.Exp.Pretty () +import DDC.Data.Pretty +import qualified DDC.Type.Sum as Sum + + +-- Bind ----------------------------------------------------------------------- +instance (Pretty n, Eq n) => Pretty (Bind n) where + ppr bb + = case bb of + BName v t -> ppr v <> pprT t + BAnon t -> text "^" <> pprT t + BNone t -> text "_" <> pprT t + + where pprT t + | isBot t = empty + | otherwise = text ": " <> ppr t + +-- Binder --------------------------------------------------------------------- +instance Pretty n => Pretty (Binder n) where + ppr bb + = case bb of + RName v -> ppr v + RAnon -> text "^" + RNone -> text "_" + + +-- | Pretty print a binder, adding spaces after names. +-- The RAnon and None binders don't need spaces, as they're single symbols. +pprBinderSep :: Pretty n => Binder n -> Doc +pprBinderSep bb + = case bb of + RName v -> ppr v + RAnon -> text "^" + RNone -> text "_" + + +-- | Print a group of binders with the same type. +pprBinderGroup :: (Pretty n, Eq n) => ([Binder n], Type n) -> Doc +pprBinderGroup (rs, t) + = (brackets $ (sep $ map pprBinderSep rs) <> text ":" <+> ppr t) + <> dot + + +-- Bound ---------------------------------------------------------------------- +instance (Pretty n, Eq n) => Pretty (Bound n) where + ppr nn + = case nn of + UName n -> ppr n + UPrim n _ -> ppr n + UIx i -> text "^" <> ppr i + + +-- Type ----------------------------------------------------------------------- +instance (Pretty n, Eq n) => Pretty (Type n) where + pprPrec d tt + = case tt of + -- Standard types. + TCon tc -> ppr tc + + TVar b -> ppr b + + -- Generic abstraction. + TAbs b t + -> pprParen (d > 5) + $ text "λ" <> ppr b <> dot <+> ppr t + + -- Full application of function constructors are printed infix. + TApp (TApp (TCon (TyConKind KiConFun)) k1) k2 + -> pprParen (d > 5) + $ ppr k1 <+> text "~>" <+> ppr k2 + + TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2 + -> pprParen (d > 5) + $ pprPrec 6 t1 <+> text "=>" pprPrec 5 t2 + + -- Pure function. + TApp (TApp (TCon (TyConSpec TcConFun)) t1) t2 + -> pprParen (d > 5) + $ pprPrec 6 t1 <+> text "->" pprPrec 5 t2 + + TApp t1 t2 + -> pprParen (d > 10) + $ ppr t1 <+> pprPrec 11 t2 + + TForall b t + | Just (bsMore, tBody) <- takeTForalls t + -> let groups = partitionBindsByType (b:bsMore) + in pprParen (d > 5) + $ (cat $ map pprBinderGroup groups) <> ppr tBody + + | otherwise + -> pprParen (d > 5) + $ brackets (ppr b) <> dot <> ppr t + + TSum ts + | isBot tt, isEffectKind $ Sum.kindOfSum ts + -> text "Pure" + + | isBot tt, isClosureKind $ Sum.kindOfSum ts + -> text "Empty" + + | isBot tt, isDataKind $ Sum.kindOfSum ts + -> text "Bot" + + | [TCon{}] <- Sum.toList ts + -> ppr ts + + | isBot tt, otherwise + -> parens $ text "Bot: " <> ppr (Sum.kindOfSum ts) + + | otherwise + -> pprParen (d > 9) $ ppr ts + + +instance (Pretty n, Eq n) => Pretty (TypeSum n) where + ppr ss + = case Sum.toList ss of + [] | isEffectKind $ Sum.kindOfSum ss -> text "Pure" + | isClosureKind $ Sum.kindOfSum ss -> text "Empty" + | isDataKind $ Sum.kindOfSum ss -> text "Bot" + + | otherwise + -> parens $ text "Bot: " <> ppr (Sum.kindOfSum ss) + + ts -> sep $ punctuate (text " +") (map ppr ts) + + +instance (Eq n, Pretty n) => Pretty (TyCon n) where + ppr tt + = case tt of + TyConSort sc -> ppr sc + TyConKind kc -> ppr kc + TyConWitness tc -> ppr tc + TyConSpec tc -> ppr tc + TyConBound u _ -> ppr u + TyConExists n _ -> text "?" <> int n + diff --git a/DDC/Type/Exp/Simple/Subsumes.hs b/DDC/Type/Exp/Simple/Subsumes.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Simple/Subsumes.hs @@ -0,0 +1,26 @@ +module DDC.Type.Exp.Simple.Subsumes + (subsumesT) +where +import DDC.Type.Exp.Simple.Equiv +import DDC.Type.Exp.Simple.Predicates +import DDC.Type.Exp.Simple.Exp +import DDC.Core.Env.EnvT (EnvT) +import qualified DDC.Type.Sum as Sum + + +-- | Check whether the first type subsumes the second. +-- +-- Both arguments are converted to sums, and we check that every +-- element of the second sum is equivalent to an element in the first. +-- +-- This only works for well formed types of effect and closure kind. +-- Other types will yield `False`. +subsumesT :: Ord n => EnvT n -> Kind n -> Type n -> Type n -> Bool +subsumesT env k t1 t2 + | isEffectKind k + , ts1 <- Sum.singleton k $ crushEffect env t1 + , ts2 <- Sum.singleton k $ crushEffect env t2 + = and $ [ Sum.elem t ts1 | t <- Sum.toList ts2 ] + + | otherwise + = False diff --git a/DDC/Type/Exp/TyCon.hs b/DDC/Type/Exp/TyCon.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/TyCon.hs @@ -0,0 +1,102 @@ + +module DDC.Type.Exp.TyCon where + + +-- | Sort constructor. +data SoCon + -- | Sort of witness kinds. + = SoConProp -- 'Prop' + + -- | Sort of computation kinds. + | SoConComp -- 'Comp' + deriving (Eq, Ord, Show) + + +-- | Kind constructor. +data KiCon + -- | Function kind constructor. + -- This is only well formed when it is fully applied. + = KiConFun -- (~>) + + -- Witness kinds ------------------------ + -- | Kind of witnesses. + | KiConWitness -- 'Witness :: Prop' + + -- Computation kinds --------------------- + -- | Kind of data values. + | KiConData -- 'Data :: Comp' + + -- | Kind of regions. + | KiConRegion -- 'Region :: Comp' + + -- | Kind of effects. + | KiConEffect -- 'Effect :: Comp' + + -- | Kind of closures. + | KiConClosure -- 'Closure :: Comp' + deriving (Eq, Ord, Show) + + +-- | Witness type constructors. +data TwCon + -- Witness implication. + = TwConImpl -- :: '(=>) :: Witness ~> Data' + + -- | Purity of some effect. + | TwConPure -- :: Effect ~> Witness + + -- | Constancy of some region. + | TwConConst -- :: Region ~> Witness + + -- | Constancy of material regions in some type + | TwConDeepConst -- :: Data ~> Witness + + -- | Mutability of some region. + | TwConMutable -- :: Region ~> Witness + + -- | Mutability of material regions in some type. + | TwConDeepMutable -- :: Data ~> Witness + + -- | Distinctness of some n regions + | TwConDistinct Int -- :: Data ~> [Region] ~> Witness + + -- | Non-interfering effects are disjoint. Used for rewrite rules. + | TwConDisjoint -- :: Effect ~> Effect ~> Witness + deriving (Eq, Ord, Show) + + +-- | Other constructors at the spec level. +data TcCon + -- Data type constructors --------------- + -- | The unit data type constructor is baked in. + = TcConUnit -- 'Unit :: Data' + + -- | Pure function. + | TcConFun -- '(->)' :: Data ~> Data ~> Data + + -- | A suspended computation. + | TcConSusp -- 'S :: Effect ~> Data ~> Data' + + -- Effect type constructors ------------- + -- | Read of some region. + | TcConRead -- :: 'Region ~> Effect' + + -- | Read the head region in a data type. + | TcConHeadRead -- :: 'Data ~> Effect' + + -- | Read of all material regions in a data type. + | TcConDeepRead -- :: 'Data ~> Effect' + + -- | Write of some region. + | TcConWrite -- :: 'Region ~> Effect' + + -- | Write to all material regions in some data type. + | TcConDeepWrite -- :: 'Data ~> Effect' + + -- | Allocation into some region. + | TcConAlloc -- :: 'Region ~> Effect' + + -- | Allocation into all material regions in some data type. + | TcConDeepAlloc -- :: 'Data ~> Effect' + deriving (Eq, Ord, Show) + diff --git a/DDC/Type/Predicates.hs b/DDC/Type/Predicates.hs deleted file mode 100644 --- a/DDC/Type/Predicates.hs +++ /dev/null @@ -1,253 +0,0 @@ - --- | Predicates on type expressions. -module DDC.Type.Predicates - ( -- * Binders - isBNone - , isBAnon - , isBName - - -- * Atoms - , isTVar - , isBot - , isAtomT - , isTExists - - -- * Kinds - , isDataKind - , isRegionKind - , isEffectKind - , isClosureKind - , isWitnessKind - - -- * Data Types - , isAlgDataType - , isWitnessType - , isConstWitType - , isMutableWitType - , isDistinctWitType - - -- * Effect Types - , isReadEffect - , isWriteEffect - , isAllocEffect - , isSomeReadEffect - , isSomeWriteEffect - , isSomeAllocEffect) -where -import DDC.Type.Exp -import DDC.Type.Compounds -import Data.Maybe -import qualified DDC.Type.Sum as T - - --- Binders -------------------------------------------------------------------- -isBNone :: Bind n -> Bool -isBNone bb - = case bb of - BNone{} -> True - _ -> False - -isBAnon :: Bind n -> Bool -isBAnon bb - = case bb of - BAnon{} -> True - _ -> False - -isBName :: Bind n -> Bool -isBName bb - = case bb of - BName{} -> True - _ -> False - - --- Atoms ---------------------------------------------------------------------- --- | Check whether a type is a `TVar` -isTVar :: Type n -> Bool -isTVar tt - = case tt of - TVar{} -> True - _ -> False - --- | Test if some type is an empty TSum -isBot :: Type n -> Bool -isBot tt - | TSum ss <- tt - , [] <- T.toList ss - = True - - | otherwise = False - - --- | Check whether a type is a `TVar`, `TCon` or is Bottom. -isAtomT :: Type n -> Bool -isAtomT tt - = case tt of - TVar{} -> True - TCon{} -> True - _ -> isBot tt - - --- | Check whether this type is an existential variable. -isTExists :: Type n -> Bool -isTExists tt - = isJust $ takeTExists tt - - --- Kinds ---------------------------------------------------------------------- --- | Check if some kind is the data kind. -isDataKind :: Kind n -> Bool -isDataKind tt - = case tt of - TCon (TyConKind KiConData) -> True - _ -> False - - --- | Check if some kind is the region kind. -isRegionKind :: Region n -> Bool -isRegionKind tt - = case tt of - TCon (TyConKind KiConRegion) -> True - _ -> False - - --- | Check if some kind is the effect kind. -isEffectKind :: Kind n -> Bool -isEffectKind tt - = case tt of - TCon (TyConKind KiConEffect) -> True - _ -> False - - --- | Check if some kind is the closure kind. -isClosureKind :: Kind n -> Bool -isClosureKind tt - = case tt of - TCon (TyConKind KiConClosure) -> True - _ -> False - - --- | Check if some kind is the witness kind. -isWitnessKind :: Kind n -> Bool -isWitnessKind tt - = case tt of - TCon (TyConKind KiConWitness) -> True - _ -> False - - --- Data Types ----------------------------------------------------------------- --- | Check whether this type is that of algebraic data. --- --- It needs to have an explicit data constructor out the front, --- and not a type variable. The constructor must not be the function --- constructor, and must return a value of kind '*'. ---- --- The function constructor (->) also has this result kind, --- but it is in `TyConComp`, so is easy to ignore. -isAlgDataType :: Eq n => Type n -> Bool -isAlgDataType tt - | Just (tc, _) <- takeTyConApps tt - , TyConBound _ k <- tc - = takeResultKind k == kData - - | otherwise - = False - --- | Check whether type is a witness constructor -isWitnessType :: Eq n => Type n -> Bool -isWitnessType tt - = case takeTyConApps tt of - Just (TyConWitness _, _) -> True - _ -> False - - --- | Check whether this is the type of a @Const@ witness. -isConstWitType :: Eq n => Type n -> Bool -isConstWitType tt - = case takeTyConApps tt of - Just (TyConWitness TwConConst, _) -> True - _ -> False - - --- | Check whether this is the type of a @Mutable@ witness. -isMutableWitType :: Eq n => Type n -> Bool -isMutableWitType tt - = case takeTyConApps tt of - Just (TyConWitness TwConMutable, _) -> True - _ -> False - - --- | Check whether this is the type of a @Distinct@ witness. -isDistinctWitType :: Eq n => Type n -> Bool -isDistinctWitType tt - = case takeTyConApps tt of - Just (TyConWitness (TwConDistinct _), _) -> True - _ -> False - - --- Effects -------------------------------------------------------------------- --- | Check whether this is an atomic read effect. -isReadEffect :: Effect n -> Bool -isReadEffect eff - = case eff of - TApp (TCon (TyConSpec TcConRead)) _ -> True - _ -> False - - --- | Check whether this is an atomic write effect. -isWriteEffect :: Effect n -> Bool -isWriteEffect eff - = case eff of - TApp (TCon (TyConSpec TcConWrite)) _ -> True - _ -> False - - --- | Check whether this is an atomic alloc effect. -isAllocEffect :: Effect n -> Bool -isAllocEffect eff - = case eff of - TApp (TCon (TyConSpec TcConAlloc)) _ -> True - _ -> False - - --- | Check whether an effect is some sort of read effect. --- Matches @Read@ @HeadRead@ and @DeepRead@. -isSomeReadEffect :: Effect n -> Bool -isSomeReadEffect tt - = case tt of - TApp (TCon (TyConSpec con)) _ - -> case con of - TcConRead -> True - TcConHeadRead -> True - TcConDeepRead -> True - _ -> False - - _ -> False - - --- | Check whether an effect is some sort of allocation effect. --- Matches @Alloc@ and @DeepAlloc@ -isSomeWriteEffect :: Effect n -> Bool -isSomeWriteEffect tt - = case tt of - TApp (TCon (TyConSpec con)) _ - -> case con of - TcConWrite -> True - TcConDeepWrite -> True - _ -> False - - _ -> False - - --- | Check whether an effect is some sort of allocation effect. --- Matches @Alloc@ and @DeepAlloc@ -isSomeAllocEffect :: Effect n -> Bool -isSomeAllocEffect tt - = case tt of - TApp (TCon (TyConSpec con)) _ - -> case con of - TcConAlloc -> True - TcConDeepAlloc -> True - _ -> False - - _ -> False - diff --git a/DDC/Type/Pretty.hs b/DDC/Type/Pretty.hs deleted file mode 100644 --- a/DDC/Type/Pretty.hs +++ /dev/null @@ -1,185 +0,0 @@ - -module DDC.Type.Pretty - (module DDC.Base.Pretty) -where -import DDC.Type.Exp -import DDC.Type.Predicates -import DDC.Type.Compounds -import DDC.Base.Pretty -import qualified DDC.Type.Sum as Sum - - --- Bind ----------------------------------------------------------------------- -instance (Pretty n, Eq n) => Pretty (Bind n) where - ppr bb - = case bb of - BName v t -> ppr v <> 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 - -- 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 - - -- Standard types. - TCon tc -> ppr tc - TVar b -> ppr b - - TForall b t - | Just (bsMore, tBody) <- takeTForalls t - -> let groups = partitionBindsByType (b:bsMore) - in pprParen (d > 5) - $ (cat $ map pprBinderGroup groups) <> ppr tBody - - | otherwise - -> pprParen (d > 5) - $ brackets (ppr b) <> dot <> ppr t - - TApp t1 t2 - -> pprParen (d > 10) - $ ppr t1 <+> pprPrec 11 t2 - - TSum ts - | isBot tt, isEffectKind $ Sum.kindOfSum ts - -> text "Pure" - - | isBot tt, isClosureKind $ Sum.kindOfSum ts - -> text "Empty" - - | isBot tt, isDataKind $ Sum.kindOfSum ts - -> text "Bot" - - | [TCon{}] <- Sum.toList ts - -> ppr ts - - | isBot tt, otherwise - -> parens $ text "Bot : " <> ppr (Sum.kindOfSum ts) - - | otherwise - -> pprParen (d > 9) $ ppr ts - - -instance (Pretty n, Eq n) => Pretty (TypeSum n) where - ppr ss - = case Sum.toList ss of - [] | isEffectKind $ Sum.kindOfSum ss -> text "Pure" - | isClosureKind $ Sum.kindOfSum ss -> text "Empty" - | isDataKind $ Sum.kindOfSum ss -> text "Bot" - - | otherwise - -> parens $ text "Bot : " <> ppr (Sum.kindOfSum ss) - - ts -> sep $ punctuate (text " +") (map ppr ts) - - --- TyCon ---------------------------------------------------------------------- -instance (Eq n, Pretty n) => Pretty (TyCon n) where - ppr tt - = case tt of - TyConSort sc -> ppr sc - TyConKind kc -> ppr kc - TyConWitness tc -> ppr tc - TyConSpec tc -> ppr tc - TyConBound u _ -> ppr u - TyConExists n _ -> text "?" <> int n - - -instance Pretty SoCon where - ppr sc - = case sc of - SoConComp -> text "Comp" - SoConProp -> text "Prop" - - -instance Pretty KiCon where - ppr kc - = case kc of - KiConFun -> text "(~>)" - KiConData -> text "Data" - KiConRegion -> text "Region" - KiConEffect -> text "Effect" - KiConClosure -> text "Closure" - KiConWitness -> text "Witness" - - -instance Pretty TwCon where - ppr tw - = case tw of - TwConImpl -> text "(=>)" - TwConPure -> text "Purify" - 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/Subsumes.hs b/DDC/Type/Subsumes.hs deleted file mode 100644 --- a/DDC/Type/Subsumes.hs +++ /dev/null @@ -1,25 +0,0 @@ -module DDC.Type.Subsumes - (subsumesT) -where -import DDC.Type.Exp -import DDC.Type.Predicates -import DDC.Type.Equiv -import qualified DDC.Type.Sum as Sum -import qualified DDC.Type.Env as Env - --- | 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 Env.empty t1 - , ts2 <- Sum.singleton k $ crushEffect Env.empty t2 - = and $ [ Sum.elem t ts1 | t <- Sum.toList ts2 ] - - | otherwise - = False diff --git a/DDC/Type/Sum.hs b/DDC/Type/Sum.hs --- a/DDC/Type/Sum.hs +++ b/DDC/Type/Sum.hs @@ -74,10 +74,7 @@ TVar (UPrim n _) -> Map.member n (typeSumBoundNamed ts) TCon{} -> L.elem t (typeSumSpill ts) - -- Foralls can't be a part of well-kinded sums. - -- Just check whether the types are strucutrally equal - -- without worring about alpha-equivalence. - TForall{} -> L.elem t (typeSumSpill ts) + TAbs{} -> L.elem t (typeSumSpill ts) TApp (TCon _) _ | Just (h, vc) <- takeSumArrayElem t @@ -86,6 +83,11 @@ TApp{} -> L.elem t (typeSumSpill ts) + -- Foralls can't be a part of well-kinded sums. + -- Just check whether the types are strucutrally equal + -- without worring about alpha-equivalence. + TForall{} -> L.elem t (typeSumSpill ts) + -- Treat bottom effect and closures as always -- being part of the sum. TSum ts1 @@ -110,12 +112,10 @@ TVar (UName n) -> ts { typeSumBoundNamed = Map.insert n k (typeSumBoundNamed ts) } TVar (UIx i) -> ts { typeSumBoundAnon = Map.insert i k (typeSumBoundAnon ts) } TVar (UPrim n _)-> ts { typeSumBoundNamed = Map.insert n k (typeSumBoundNamed ts) } + TCon{} -> ts { typeSumSpill = L.nub $ t : typeSumSpill ts } - -- Foralls can't be part of well-kinded sums. - -- Just add them to the splill lists so that we can still - -- pretty print such mis-kinded types. - TForall{} -> ts { typeSumSpill = L.nub $ t : typeSumSpill ts } + TAbs{} -> ts { typeSumSpill = L.nub $ t : typeSumSpill ts } TApp (TCon _) _ | Just (h, vc) <- takeSumArrayElem t @@ -125,6 +125,11 @@ else ts { typeSumElems = (typeSumElems ts) // [(h, Set.insert vc tsThere)] } TApp{} -> ts { typeSumSpill = L.nub $ t : typeSumSpill ts } + + -- Foralls can't be part of well-kinded sums. + -- Just add them to the splill lists so that we can still + -- pretty print such mis-kinded types. + TForall{} -> ts { typeSumSpill = L.nub $ t : typeSumSpill ts } TSum ts' -> foldr insert ts (toList ts') @@ -138,14 +143,17 @@ TVar (UIx i) -> ts { typeSumBoundAnon = Map.delete i (typeSumBoundAnon ts) } TVar (UPrim n _)-> ts { typeSumBoundNamed = Map.delete n (typeSumBoundNamed ts) } TCon{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } - TForall{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } + + TAbs{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } TApp (TCon _) _ | Just (h, vc) <- takeSumArrayElem t , tsThere <- typeSumElems ts ! h -> ts { typeSumElems = (typeSumElems ts) // [(h, Set.delete vc tsThere)] } - TApp{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } + TApp{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } + + TForall{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } TSum ts' -> foldr delete ts (toList ts') diff --git a/DDC/Type/Transform/BoundT.hs b/DDC/Type/Transform/BoundT.hs --- a/DDC/Type/Transform/BoundT.hs +++ b/DDC/Type/Transform/BoundT.hs @@ -5,8 +5,8 @@ , lowerT, lowerAtDepthT , MapBoundT(..)) where -import DDC.Type.Exp -import DDC.Type.Compounds +import DDC.Type.Exp.Simple.Exp +import DDC.Type.Exp.Simple.Compounds import qualified DDC.Type.Sum as Sum @@ -91,10 +91,10 @@ = case tt of TVar u -> TVar (f d u) TCon{} -> tt - TApp t1 t2 -> TApp (mapBoundAtDepthT f d t1) (mapBoundAtDepthT f d t2) - TSum ss -> TSum (mapBoundAtDepthT f d ss) - TForall b t - -> TForall b (mapBoundAtDepthT f (d + countBAnons [b]) t) + 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 diff --git a/DDC/Type/Transform/Rename.hs b/DDC/Type/Transform/Rename.hs --- a/DDC/Type/Transform/Rename.hs +++ b/DDC/Type/Transform/Rename.hs @@ -18,8 +18,7 @@ -- * Rewriting bound occurences , use1, use0) where -import DDC.Type.Compounds -import DDC.Type.Exp +import DDC.Type.Exp.Simple import Data.List import Data.Set (Set) import qualified DDC.Type.Sum as Sum @@ -40,14 +39,21 @@ let down = renameWith in case tt of TVar u -> TVar (use1 sub u) + TCon{} -> tt + TAbs b t + -> let (sub1, b') = bind1 sub b + t' = down sub1 t + in TAbs b' t' + + TApp t1 t2 -> TApp (down sub t1) (down sub t2) + TForall b t -> let (sub1, b') = bind1 sub b t' = down sub1 t in TForall b' t' - TApp t1 t2 -> TApp (down sub t1) (down sub t2) TSum ts -> TSum (down sub ts) diff --git a/DDC/Type/Transform/SpreadT.hs b/DDC/Type/Transform/SpreadT.hs --- a/DDC/Type/Transform/SpreadT.hs +++ b/DDC/Type/Transform/SpreadT.hs @@ -26,11 +26,16 @@ TVar u -> TVar $ spreadT kenv u TCon tc -> TCon $ spreadT kenv tc + TAbs b t + -> let b' = spreadT kenv b + in TAbs b' $ spreadT (Env.extend b' kenv) t + + TApp t1 t2 -> TApp (spreadT kenv t1) (spreadT kenv t2) + TForall b t -> let b' = spreadT kenv b in TForall b' $ spreadT (Env.extend b' kenv) t - TApp t1 t2 -> TApp (spreadT kenv t1) (spreadT kenv t2) TSum ss -> TSum (spreadT kenv ss) diff --git a/DDC/Type/Transform/SubstituteT.hs b/DDC/Type/Transform/SubstituteT.hs --- a/DDC/Type/Transform/SubstituteT.hs +++ b/DDC/Type/Transform/SubstituteT.hs @@ -11,11 +11,10 @@ , pushBinds , substBound) where -import DDC.Type.Collect -import DDC.Type.Compounds +import DDC.Core.Collect import DDC.Type.Transform.BoundT import DDC.Type.Transform.Rename -import DDC.Type.Exp +import DDC.Type.Exp.Simple import Data.Maybe import qualified DDC.Type.Sum as Sum import qualified DDC.Type.Env as Env @@ -80,17 +79,36 @@ = let down = substituteWithT u t fns stack in case tt of TCon{} -> tt - TApp t1 t2 -> TApp (down t1) (down t2) - TSum ss -> TSum (down ss) + TVar u' + -> case substBound stack u u' of + Left u'' -> TVar u'' + Right n -> liftT n t + + TAbs b tBody + | namedBoundMatchesBind u b -> tt + | otherwise + -> let -- Substitute into the annotation on the binder. + bSub = down b + + -- 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 + + in TAbs b' tBody' + + TApp t1 t2 + -> TApp (down t1) (down t2) + TForall b tBody | namedBoundMatchesBind u b -> tt | otherwise -> 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. @@ -98,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/Universe.hs b/DDC/Type/Universe.hs --- a/DDC/Type/Universe.hs +++ b/DDC/Type/Universe.hs @@ -1,22 +1,26 @@ module DDC.Type.Universe ( Universe(..) + , universeUp , universeFromType3 , universeFromType2 , universeFromType1 , universeOfType) where import DDC.Type.Exp -import DDC.Base.Pretty +import DDC.Data.Pretty import DDC.Type.Env as Env import qualified DDC.Type.Sum as T -- | Universes of the Disciple Core language. data Universe + -- | A numbered universe (levels 4..) + = UniverseLevel Int + -- | (level 3). The universe of sorts. -- Sorts classify kinds. - = UniverseSort + | UniverseSort -- | (level 2). The universe of kinds. -- Kinds classify specifications. @@ -48,6 +52,7 @@ instance Pretty Universe where ppr u = case u of + UniverseLevel i -> text "Universe" <> int i UniverseSort -> text "Sort" UniverseKind -> text "Kind" UniverseSpec -> text "Spec" @@ -55,6 +60,18 @@ UniverseData -> text "Data" +-- | Take the next highest universe of the given one. +universeUp :: Universe -> Universe +universeUp uu + = case uu of + UniverseLevel n -> UniverseLevel (n + 1) + UniverseSort -> UniverseLevel 4 + UniverseKind -> UniverseSort + UniverseSpec -> UniverseKind + UniverseWitness -> UniverseSpec + UniverseData -> UniverseSpec + + -- | Given the type of the type of the type of some thing (up three levels), -- yield the universe of the original thing, or `Nothing` it was badly formed. universeFromType3 :: Type n -> Maybe Universe @@ -71,6 +88,7 @@ universeFromType2 tt = case tt of TVar _ -> Nothing + TCon (TyConSort _) -> Just UniverseSpec TCon (TyConKind kc) @@ -83,8 +101,10 @@ TCon TyConSpec{} -> Nothing TCon TyConBound{} -> Nothing TCon TyConExists{} -> Nothing - TForall _ _ -> Nothing + + TAbs{} -> Nothing TApp _ t2 -> universeFromType2 t2 + TForall{} -> Nothing TSum _ -> Nothing @@ -109,8 +129,10 @@ TCon (TyConBound _ k) -> universeFromType2 k TCon (TyConExists _ k) -> universeFromType2 k - TForall b t2 -> universeFromType1 (Env.extend b kenv) t2 + + TAbs b t2 -> universeFromType1 (Env.extend b kenv) t2 TApp t1 _ -> universeFromType1 kenv t1 + TForall b t2 -> universeFromType1 (Env.extend b kenv) t2 TSum _ -> Nothing @@ -134,8 +156,10 @@ TCon (TyConSpec _) -> Just UniverseSpec TCon (TyConBound _ k) -> universeFromType1 kenv k TCon (TyConExists _ k) -> universeFromType1 kenv k - TForall b t2 -> universeOfType (Env.extend b kenv) t2 + + TAbs b t2 -> universeOfType (Env.extend b kenv) t2 TApp _ t2 -> universeOfType kenv t2 + TForall b t2 -> universeOfType (Env.extend b kenv) t2 TSum ss -> universeFromType1 kenv (T.kindOfSum ss) 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-2014 The Disciplined Disciple Compiler Strike Force +Copyrite (K) 2007-2016 The Disciplined Disciple Compiler Strike Force All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy diff --git a/ddc-core.cabal b/ddc-core.cabal --- a/ddc-core.cabal +++ b/ddc-core.cabal @@ -1,5 +1,5 @@ Name: ddc-core -Version: 0.4.2.1 +Version: 0.4.3.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -23,46 +23,49 @@ Library Build-Depends: - base >= 4.6 && < 4.9, - array >= 0.4 && < 0.6, - deepseq >= 1.3 && < 1.5, + base >= 4.6 && < 4.10, + array >= 0.4 && < 0.6, + deepseq >= 1.3 && < 1.5, containers == 0.5.*, directory == 1.2.*, - text >= 1.0 && < 1.3, - transformers == 0.4.*, - mtl == 2.2.1.*, - ddc-base == 0.4.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.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.Compounds DDC.Core.Exp.Annot.Context DDC.Core.Exp.Annot.Ctx - DDC.Core.Exp.Annot.Exp - DDC.Core.Exp.Annot.Predicates - + DDC.Core.Exp.Generic.BindStruct - DDC.Core.Exp.Generic.Compounds - DDC.Core.Exp.Generic.Exp - DDC.Core.Exp.Generic.Predicates - DDC.Core.Exp.Generic.Pretty - DDC.Core.Exp.Simple.Compounds - DDC.Core.Exp.Simple.Exp DDC.Core.Exp.Annot - DDC.Core.Exp + DDC.Core.Exp.Generic + DDC.Core.Exp.Literal - DDC.Core.Lexer.Names + DDC.Core.Lexer.Offside DDC.Core.Lexer.Tokens DDC.Core.Lexer.Unicode - DDC.Core.Transform.Annotate DDC.Core.Transform.BoundT DDC.Core.Transform.BoundX - DDC.Core.Transform.Deannotate DDC.Core.Transform.MapT DDC.Core.Transform.Reannotate DDC.Core.Transform.Rename @@ -74,7 +77,7 @@ DDC.Core.Call DDC.Core.Check DDC.Core.Collect - + DDC.Core.Exp DDC.Core.Fragment DDC.Core.Lexer DDC.Core.Load @@ -82,6 +85,35 @@ DDC.Core.Parser 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.Rename @@ -89,19 +121,31 @@ DDC.Type.Transform.SubstituteT DDC.Type.Bind - DDC.Type.Check - DDC.Type.Collect - DDC.Type.Compounds DDC.Type.DataDef DDC.Type.Env - DDC.Type.Equiv DDC.Type.Exp - DDC.Type.Predicates - DDC.Type.Subsumes DDC.Type.Sum DDC.Type.Universe + DDC.Version + + Other-modules: + DDC.Core.Check.Context.Apply + DDC.Core.Check.Context.Base + DDC.Core.Check.Context.Effect + DDC.Core.Check.Context.Elem + DDC.Core.Check.Context.Mode + + DDC.Core.Check.Error.ErrorData + DDC.Core.Check.Error.ErrorDataMessage + DDC.Core.Check.Error.ErrorExp + DDC.Core.Check.Error.ErrorExpMessage + DDC.Core.Check.Error.ErrorType + DDC.Core.Check.Error.ErrorTypeMessage + + DDC.Core.Check.Judge.Kind.TyCon + DDC.Core.Check.Judge.Type.AppT DDC.Core.Check.Judge.Type.AppX DDC.Core.Check.Judge.Type.Base @@ -115,19 +159,31 @@ DDC.Core.Check.Judge.Type.Sub DDC.Core.Check.Judge.Type.VarCon DDC.Core.Check.Judge.Type.Witness - DDC.Core.Check.Judge.Eq + + DDC.Core.Check.Judge.DataDefs + DDC.Core.Check.Judge.EqT DDC.Core.Check.Judge.Inst + DDC.Core.Check.Judge.Kind + DDC.Core.Check.Judge.Module DDC.Core.Check.Judge.Sub + DDC.Core.Check.Judge.Witness + DDC.Core.Check.Base + DDC.Core.Check.Config + DDC.Core.Check.Context DDC.Core.Check.Error - DDC.Core.Check.ErrorMessage DDC.Core.Check.Exp - DDC.Core.Check.Module - DDC.Core.Check.Witness - DDC.Core.Collect.Free - DDC.Core.Collect.Free.Simple + 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 @@ -136,8 +192,13 @@ DDC.Core.Fragment.Feature DDC.Core.Fragment.Profile - DDC.Core.Lexer.Comments - DDC.Core.Lexer.Offside + DDC.Core.Lexer.Token.Builtin + DDC.Core.Lexer.Token.Index + DDC.Core.Lexer.Token.Keyword + DDC.Core.Lexer.Token.Literal + DDC.Core.Lexer.Token.Names + DDC.Core.Lexer.Token.Operator + DDC.Core.Lexer.Token.Symbol DDC.Core.Module.Export DDC.Core.Module.Import @@ -154,30 +215,17 @@ DDC.Core.Parser.Type DDC.Core.Parser.Witness - DDC.Type.Check.Judge.Eq - DDC.Type.Check.Judge.Kind - DDC.Type.Check.Base - DDC.Type.Check.CheckCon - DDC.Type.Check.Config - DDC.Type.Check.Context - DDC.Type.Check.Data - DDC.Type.Check.Error - DDC.Type.Check.ErrorMessage - - DDC.Type.Collect.FreeT - - DDC.Type.Exp.Base - DDC.Type.Exp.NFData - - DDC.Type.Pretty + DDC.Type.Exp.Simple.NFData + DDC.Type.Exp.Simple.Pretty - GHC-options: -Wall -fno-warn-orphans -fno-warn-unused-do-bind -fno-warn-missing-methods -fno-warn-missing-signatures + -fno-warn-missing-pattern-synonym-signatures + -fno-warn-redundant-constraints Extensions: NoMonomorphismRestriction