diff --git a/DDC/Core/Check.hs b/DDC/Core/Check.hs --- a/DDC/Core/Check.hs +++ b/DDC/Core/Check.hs @@ -1,17 +1,33 @@ --- | Type checker for the Disciple core language. +-- | Type checker for the Disciple Core language. +-- +-- The functions in this module do not check for language fragment compliance. +-- This needs to be done separately via "DDC.Core.Fragment". +-- module DDC.Core.Check - ( -- * Checking Expressions - checkExp, typeOfExp + ( -- * Configuration + Config(..) + , configOfProfile + -- * Checking Modules + , checkModule + + -- * Checking Expressions + , checkExp, typeOfExp + -- * Checking Witnesses , checkWitness, typeOfWitness , typeOfWiCon + -- * Annotations + , AnTEC(..) + -- * Error messages , Error(..)) where import DDC.Core.Check.Error import DDC.Core.Check.ErrorMessage () +import DDC.Core.Check.CheckModule import DDC.Core.Check.CheckExp import DDC.Core.Check.CheckWitness + diff --git a/DDC/Core/Check/CheckDaCon.hs b/DDC/Core/Check/CheckDaCon.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/CheckDaCon.hs @@ -0,0 +1,50 @@ + +module DDC.Core.Check.CheckDaCon + (checkDaConM) +where +import DDC.Core.Check.Error +import DDC.Core.Check.CheckWitness +import DDC.Core.DaCon +import DDC.Core.Exp +import DDC.Type.Compounds +import DDC.Type.DataDef +import DDC.Control.Monad.Check (throw) +import Control.Monad +import Prelude as L +import qualified Data.Map as Map + + +-- | Check a data constructor. +-- The data constructor must be in the set of data type declarations. +checkDaConM + :: (Ord n, Eq n, Show n) + => Config n + -> Exp a n -- ^ The full expression for error messages. + -> DaCon n -- ^ Data constructor to check. + -> CheckM a n () + +checkDaConM _ _ dc + | DaConUnit <- daConName dc + = return () + +checkDaConM config xx dc + | DaConNamed nCtor <- daConName dc + , daConIsAlgebraic dc + = let tResult = snd $ takeTFunArgResult $ eraseTForalls $ typeOfDaCon dc + defs = configPrimDataDefs config + in case liftM fst $ takeTyConApps tResult of + Just (TyConBound u _) + | Just nType <- takeNameOfBound u + , Just dataType <- Map.lookup nType (dataDefsTypes defs) + -> case dataTypeMode dataType of + DataModeSmall nsCtors + | L.elem nCtor nsCtors -> return () + | otherwise -> throw $ ErrorUndefinedCtor xx + + DataModeLarge -> return () + + _ -> throw $ ErrorUndefinedCtor xx + +checkDaConM _ _ _ + = return () + diff --git a/DDC/Core/Check/CheckExp.hs b/DDC/Core/Check/CheckExp.hs --- a/DDC/Core/Check/CheckExp.hs +++ b/DDC/Core/Check/CheckExp.hs @@ -1,946 +1,1120 @@ - --- | Type checker for the Disciple Core language. -module DDC.Core.Check.CheckExp - ( checkExp - , typeOfExp - , CheckM - , checkExpM - , TaggedClosure(..)) -where -import DDC.Core.DataDef -import DDC.Core.Predicates -import DDC.Core.Compounds -import DDC.Core.Exp -import DDC.Core.Pretty -import DDC.Core.Collect -import DDC.Core.Check.Error -import DDC.Core.Check.CheckWitness -import DDC.Core.Check.TaggedClosure -import DDC.Type.Transform.SubstituteT -import DDC.Type.Transform.Crush -import DDC.Type.Transform.Trim -import DDC.Type.Transform.Instantiate -import DDC.Type.Transform.LiftT -import DDC.Type.Transform.LowerT -import DDC.Type.Equiv -import DDC.Type.Universe -import DDC.Type.Compounds -import DDC.Type.Predicates -import DDC.Type.Sum as Sum -import DDC.Type.Env (Env) -import DDC.Type.Check.Monad (result, throw) -import DDC.Base.Pretty () -import Data.Set (Set) -import qualified DDC.Type.Env as Env -import qualified DDC.Type.Check as T -import qualified Data.Set as Set -import qualified Data.Map as Map -import Control.Monad -import Data.List as L -import Data.Maybe - - --- Wrappers ------------------------------------------------------------------- --- | Type check an expression. --- --- If it's good, you get a new version with types attached to all the bound --- variables, as well its the type, effect and closure. --- --- If it's bad, you get a description of the error. --- --- The returned expression has types attached to all variable occurrences, --- so you can call `typeOfExp` on any open subterm. -checkExp - :: (Ord n, Pretty n) - => DataDefs n -- ^ Data type definitions. - -> Env n -- ^ Kind environment. - -> Env n -- ^ Type environment. - -> Exp a n -- ^ Expression to check. - -> Either (Error a n) - ( Exp a n - , Type n - , Effect n - , Closure n) - -checkExp defs kenv tenv xx - = result - $ do (xx', t, effs, clos) <- checkExpM defs kenv tenv xx - return ( xx' - , t - , TSum effs - , closureOfTaggedSet clos) - - --- | Like `checkExp`, but check in an empty environment, --- and only return the value type of an expression. --- --- As this function is not given an environment, the types of free variables --- must be attached directly to the bound occurrences. --- This attachment is performed by `checkExp` above. --- -typeOfExp - :: (Ord n, Pretty n) - => DataDefs n - -> Exp a n - -> Either (Error a n) (Type n) -typeOfExp defs xx - = case checkExp defs Env.empty Env.empty xx of - Left err -> Left err - Right (_, t, _, _) -> Right t - - --- checkExp ------------------------------------------------------------------- --- | Like `checkExp` but using the `CheckM` monad to handle errors. -checkExpM - :: (Ord n, Pretty n) - => DataDefs n -- ^ Data type definitions. - -> Env n -- ^ Kind environment. - -> Env n -- ^ Type environment. - -> Exp a n -- ^ Expression to check. - -> CheckM a n - ( Exp a n - , Type n - , TypeSum n - , Set (TaggedClosure n)) - -checkExpM defs kenv tenv xx - = checkExpM' defs kenv tenv xx -{-} = do (xx', t, eff, clo) <- checkExpM' defs kenv tenv xx - trace (pretty $ vcat - [ text "checkExpM: " <+> ppr xx - , text " :: " <+> ppr t - , text " :!: " <+> ppr eff - , text " :$: " <+> ppr clo - , text ""]) - $ return (xx', t, eff, clo) --} - --- variables ------------------------------------ -checkExpM' _defs _kenv tenv (XVar a u) - = do let tBound = typeOfBound u - let mtEnv = Env.lookup u tenv - - let mkResult - -- When annotation on the bound is bot, - -- then use the type from the environment. - | Just tEnv <- mtEnv - , isBot tBound - = return tEnv - - -- The bound has an explicit type annotation, - -- which matches the one from the environment. - -- - -- When the bound is a deBruijn index we need to lift the - -- annotation on the original binder through any lambdas - -- between the binding occurrence and the use. - | Just tEnv <- mtEnv - , UIx i _ <- u - , equivT tBound (liftT (i + 1) tEnv) - = return tBound - - -- The bound has an explicit type annotation, - -- which matches the one from the environment. - | Just tEnv <- mtEnv - , equivT tBound tEnv - = return tEnv - - -- The bound has an explicit type annotation, - -- which does not match the one from the environment. - -- This shouldn't happen because the parser doesn't add non-bot - -- annotations to bound variables. - | Just tEnv <- mtEnv - = throw $ ErrorVarAnnotMismatch u tEnv - - -- Variable not in environment, so use annotation. - -- This happens when checking open terms. - | otherwise - = return tBound - - tResult <- mkResult - - return ( XVar a u - , tResult - , Sum.empty kEffect - , Set.singleton - $ taggedClosureOfValBound - $ replaceTypeOfBound tResult u) - - --- constructors --------------------------------- -checkExpM' defs _kenv _tenv xx@(XCon a u) - | UName n _ <- u - = case Map.lookup n (dataDefsCtors defs) of - Nothing -> throw $ ErrorUndefinedCtor xx - Just _ - -> return - ( XCon a u - , typeOfBound u - , Sum.empty kEffect - , Set.empty) - - | UPrim{} <- u - = return ( XCon a u - , typeOfBound u - , Sum.empty kEffect - , Set.empty) - - -- Constructors can't be locally bound. - | otherwise - = throw $ ErrorMalformedExp xx - - --- application ------------------------------------ --- value-type application. -checkExpM' defs kenv tenv xx@(XApp a x1 (XType t2)) - = do (x1', t1, effs1, clos1) <- checkExpM defs kenv tenv x1 - k2 <- checkTypeM defs kenv t2 - case t1 of - TForall b11 t12 - | typeOfBind b11 == k2 - -> return ( XApp a x1' (XType t2) - , substituteT b11 t2 t12 - , substituteT b11 t2 effs1 - , clos1 `Set.union` taggedClosureOfTyArg t2) - - | otherwise -> throw $ ErrorAppMismatch xx (typeOfBind b11) t2 - _ -> throw $ ErrorAppNotFun xx t1 t2 - - --- value-witness application. -checkExpM' defs kenv tenv xx@(XApp a x1 (XWitness w2)) - = do (x1', t1, effs1, clos1) <- checkExpM defs kenv tenv x1 - t2 <- checkWitnessM defs kenv tenv w2 - case t1 of - TApp (TApp (TCon (TyConWitness TwConImpl)) t11) t12 - | t11 `equivT` t2 - -> return ( XApp a x1' (XWitness w2) - , t12 - , effs1 - , clos1) - - | otherwise -> throw $ ErrorAppMismatch xx t11 t2 - _ -> throw $ ErrorAppNotFun xx t1 t2 - - --- value-value application. -checkExpM' defs kenv tenv xx@(XApp a x1 x2) - = do (x1', t1, effs1, clos1) <- checkExpM defs kenv tenv x1 - (x2', t2, effs2, clos2) <- checkExpM defs kenv tenv x2 - - -- Note: we don't need to use the closure of the function because - -- all of its components will already be part of clos1 above. - case t1 of - TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFun)) t11) eff) _clo) t12 - | t11 `equivT` t2 - , effs <- Sum.fromList kEffect [eff] - -> return ( XApp a x1' x2' - , t12 - , effs1 `Sum.union` effs2 `Sum.union` effs - , clos1 `Set.union` clos2) - - | otherwise -> throw $ ErrorAppMismatch xx t11 t2 - _ -> throw $ ErrorAppNotFun xx t1 t2 - - --- spec abstraction ----------------------------- -checkExpM' defs kenv tenv xx@(XLAM a b1 x2) - = do let t1 = typeOfBind b1 - _ <- checkTypeM defs kenv t1 - - -- Check the body - let kenv' = Env.extend b1 kenv - let tenv' = Env.lift 1 tenv - (x2', t2, e2, c2) <- checkExpM defs kenv' tenv' x2 - k2 <- checkTypeM defs kenv' t2 - - when (Env.memberBind b1 kenv) - $ throw $ ErrorLamShadow xx b1 - - -- The body of a spec abstraction must be pure. - when (e2 /= Sum.empty kEffect) - $ throw $ ErrorLamNotPure xx (TSum e2) - - -- The body of a spec abstraction must have data kind. - when (not $ isDataKind k2) - $ throw $ ErrorLamBodyNotData xx b1 t2 k2 - - -- Mask closure terms due to locally bound region vars. - let c2_cut = Set.fromList - $ mapMaybe (cutTaggedClosureT b1) - $ Set.toList c2 - - return ( XLAM a b1 x2' - , TForall b1 t2 - , Sum.empty kEffect - , c2_cut) - - --- function abstractions ------------------------ -checkExpM' defs kenv tenv xx@(XLam a b1 x2) - = do let t1 = typeOfBind b1 - k1 <- checkTypeM defs kenv t1 - - -- Check the body. - let tenv' = Env.extend b1 tenv - (x2', t2, e2, c2) <- checkExpM defs kenv tenv' x2 - k2 <- checkTypeM defs kenv t2 - - -- The form of the function constructor depends on what universe the - -- binder is in. - case universeFromType2 k1 of - Just UniverseData - | not $ isDataKind k1 -> throw $ ErrorLamBindNotData xx t1 k1 - | not $ isDataKind k2 -> throw $ ErrorLamBodyNotData xx b1 t2 k2 - | otherwise - -> let - -- Cut closure terms due to locally bound value vars. - -- This also lowers deBruijn indices in un-cut closure terms. - c2_cut = Set.fromList - $ mapMaybe (cutTaggedClosureX b1) - $ Set.toList c2 - - -- Trim the closure before we annotate the returned function - -- type with it. - -- This should always succeed because trimClosure only returns - -- Nothing if the closure is miskinded, and we've already - -- allready checked that. - Just c2_captured - = trimClosure $ closureOfTaggedSet c2_cut - - in return ( XLam a b1 x2' - , tFun t1 (TSum e2) c2_captured t2 - , Sum.empty kEffect - , c2_cut) - - Just UniverseWitness - | e2 /= Sum.empty kEffect -> throw $ ErrorLamNotPure xx (TSum e2) - | not $ isDataKind k2 -> throw $ ErrorLamBodyNotData xx b1 t2 k2 - | otherwise - -> return ( XLam a b1 x2' - , tImpl t1 t2 - , Sum.empty kEffect - , c2) - - _ -> throw $ ErrorMalformedType xx k1 - - --- let -------------------------------------------- -checkExpM' defs kenv tenv xx@(XLet a (LLet mode b11 x12) x2) - = do -- Check the right of the binding. - (x12', t12, effs12, clo12) - <- checkExpM defs kenv tenv x12 - - -- Check binder annotation against the type we inferred for the right. - (b11', k11') - <- checkLetBindOfTypeM xx defs kenv tenv t12 b11 - - -- The right of the binding should have data kind. - when (not $ isDataKind k11') - $ throw $ ErrorLetBindingNotData xx b11' k11' - - -- Check the body expression. - let tenv1 = Env.extend b11' tenv - (x2', t2, effs2, c2) <- checkExpM defs kenv tenv1 x2 - - -- The body should have data kind. - k2 <- checkTypeM defs kenv t2 - when (not $ isDataKind k2) - $ throw $ ErrorLetBodyNotData xx t2 k2 - - -- Mask closure terms due to locally bound value vars. - let c2_cut = Set.fromList - $ mapMaybe (cutTaggedClosureX b11') - $ Set.toList c2 - - -- Check purity and emptiness for lazy bindings. - (case mode of - LetStrict -> return () - LetLazy _ - -> do let eff12' = TSum effs12 - when (not $ isBot eff12') - $ throw $ ErrorLetLazyNotPure xx b11 eff12' - - let clo12' = closureOfTaggedSet clo12 - when (not $ isBot clo12') - $ throw $ ErrorLetLazyNotEmpty xx b11 clo12') - - -- Check region witness for lazy bindings. - (case mode of - LetStrict -> return () - - -- Type of lazy binding has no head region, like Unit and (->). - LetLazy Nothing - -> do case takeDataTyConApps t12 of - Just (_tc, t1 : _) - -> do k1 <- checkTypeM defs kenv t1 - when (isRegionKind k1) - $ throw $ ErrorLetLazyNoWitness xx b11 t12 - - _ -> return () - - -- Type of lazy binding might have a head region, - -- so we need a Lazy witness for it. - LetLazy (Just wit) - -> do tWit <- checkWitnessM defs kenv tenv wit - let tWitExp = case takeDataTyConApps t12 of - Just (_tc, tR : _ts) -> tLazy tR - _ -> tHeadLazy t12 - - when (not $ equivT tWit tWitExp) - $ throw $ ErrorLetLazyWitnessTypeMismatch - xx b11 tWit t12 tWitExp) - - - return ( XLet a (LLet mode b11' x12') x2' - , t2 - , effs12 `Sum.union` effs2 - , clo12 `Set.union` c2_cut) - - --- letrec ----------------------------------------- -checkExpM' defs kenv tenv xx@(XLet a (LRec bxs) xBody) - = do - let (bs, xs) = unzip bxs - - -- Check all the annotations. - ks <- mapM (checkTypeM defs kenv) - $ map typeOfBind bs - - -- Check all the annots have data kind. - zipWithM_ (\b k - -> when (not $ isDataKind k) - $ throw $ ErrorLetBindingNotData xx b k) - bs ks - - -- All right hand sides need to be lambdas. - forM_ xs $ \x - -> when (not $ (isXLam x || isXLAM x)) - $ throw $ ErrorLetrecBindingNotLambda xx x - - -- All variables are in scope in all right hand sides. - let tenv' = Env.extends bs tenv - - -- Check the right hand sides. - (xsRight', tsRight, _effssBinds, clossBinds) - <- liftM unzip4 $ mapM (checkExpM defs kenv tenv') xs - - -- Check annots on binders against inferred types of the bindings. - zipWithM_ (\b t - -> if not $ equivT (typeOfBind b) t - then throw $ ErrorLetMismatch xx b t - else return ()) - bs tsRight - - -- Check the body expression. - (xBody', tBody, effsBody, closBody) - <- checkExpM defs kenv tenv' xBody - - -- The body type must have data kind. - kBody <- checkTypeM defs kenv tBody - when (not $ isDataKind kBody) - $ throw $ ErrorLetBodyNotData xx tBody kBody - - -- Cut closure terms due to locally bound value vars. - -- This also lowers deBruijn indices in un-cut closure terms. - let clos_cut - = Set.fromList - $ mapMaybe (cutTaggedClosureXs bs) - $ Set.toList - $ Set.unions (closBody : clossBinds) - - return ( XLet a (LRec (zip bs xsRight')) xBody' - , tBody - , effsBody - , clos_cut) - - --- letregion -------------------------------------- -checkExpM' defs kenv tenv xx@(XLet a (LLetRegion b bs) x) - = case takeSubstBoundOfBind b of - Nothing -> checkExpM defs kenv tenv x - Just u - -> do - -- Check the type on the region binder. - let k = typeOfBind b - checkTypeM defs kenv k - - -- The binder must have region kind. - when (not $ isRegionKind k) - $ throw $ ErrorLetRegionNotRegion xx b k - - -- We can't shadow region binders because we might have witnesses - -- in the environment that conflict with the ones created here. - when (Env.memberBind b kenv) - $ throw $ ErrorLetRegionRebound xx b - - -- Check the witness types. - let kenv' = Env.extend b kenv - let tenv' = Env.lift 1 tenv - mapM_ (checkTypeM defs kenv') $ map typeOfBind bs - - -- Check that the witnesses bound here are for the region, - -- and they don't conflict with each other. - checkWitnessBindsM xx u bs - - -- Check the body expression. - let tenv2 = Env.extends bs tenv' - (xBody', tBody, effs, clo) <- checkExpM defs kenv' tenv2 x - - -- The body type must have data kind. - kBody <- checkTypeM defs kenv' tBody - when (not $ isDataKind kBody) - $ throw $ ErrorLetBodyNotData xx tBody kBody - - -- The bound region variable cannot be free in the body type. - let fvsT = freeT Env.empty tBody - when (Set.member u fvsT) - $ throw $ ErrorLetRegionFree xx b tBody - - -- Delete effects on the bound region from the result. - let effs' = Sum.delete (tRead (TVar u)) - $ Sum.delete (tWrite (TVar u)) - $ Sum.delete (tAlloc (TVar u)) - $ effs - - -- Delete the bound region variable from the closure. - -- Mask closure terms due to locally bound region vars. - let c2_cut = Set.fromList - $ mapMaybe (cutTaggedClosureT b) - $ Set.toList clo - - return ( XLet a (LLetRegion b bs) xBody' - , lowerT 1 tBody - , lowerT 1 effs' - , c2_cut) - - --- withregion ----------------------------------- -checkExpM' defs kenv tenv xx@(XLet a (LWithRegion u) x) - = do -- Check the type on the region handle. - let k = typeOfBound u - checkTypeM defs kenv k - - -- The handle must have region kind. - when (not $ isRegionKind k) - $ throw $ ErrorWithRegionNotRegion xx u k - - -- Check the body expression. - (xBody', tBody, effs, clo) - <- checkExpM defs kenv tenv x - - -- The body type must have data kind. - kBody <- checkTypeM defs kenv tBody - when (not $ isDataKind kBody) - $ throw $ ErrorLetBodyNotData xx tBody kBody - - -- Delete effects on the bound region from the result. - let tu = TCon $ TyConBound u - let effs' = Sum.delete (tRead tu) - $ Sum.delete (tWrite tu) - $ Sum.delete (tAlloc tu) - $ effs - - -- Delete the bound region handle from the closure. - let clo_masked = Set.delete (GBoundRgnCon u) clo - - return ( XLet a (LWithRegion u) xBody' - , tBody - , effs' - , clo_masked) - - --- case expression ------------------------------ -checkExpM' defs kenv tenv xx@(XCase a xDiscrim alts) - = do - -- Check the discriminant. - (xDiscrim', tDiscrim, effsDiscrim, closDiscrim) - <- checkExpM defs kenv tenv xDiscrim - - -- Split the type into the type constructor names and type parameters. - -- Also check that it's algebraic data, and not a function or effect - -- type etc. - (nTyCon, tsArgs) - <- case takeTyConApps tDiscrim of - Just (tc, ts) - | TyConBound (UName n t) <- tc - , takeResultKind t == kData - -> return (n, ts) - - | TyConBound (UPrim n t) <- tc - , takeResultKind t == kData - -> return (n, ts) - - _ -> throw $ ErrorCaseDiscrimNotAlgebraic xx tDiscrim - - -- Get the mode of the data type, - -- this tells us how many constructors there are. - mode - <- case lookupModeOfDataType nTyCon defs of - Nothing -> throw $ ErrorCaseDiscrimTypeUndeclared xx tDiscrim - Just m -> return m - - -- Check the alternatives. - (alts', ts, effss, closs) - <- liftM unzip4 - $ mapM (checkAltM xx defs kenv tenv tDiscrim tsArgs) alts - - -- There must be at least one alternative - when (null ts) - $ throw $ ErrorCaseNoAlternatives xx - - -- All alternative result types must be identical. - let (tAlt : _) = ts - forM_ ts $ \tAlt' - -> when (not $ equivT tAlt tAlt') - $ throw $ ErrorCaseAltResultMismatch xx tAlt tAlt' - - -- Check for overlapping alternatives. - let pats = [p | AAlt p _ <- alts] - let psDefaults = filter isPDefault pats - let nsCtorsMatched = mapMaybe takeCtorNameOfAlt alts - - -- Alts overlapping because there are multiple defaults. - when (length psDefaults > 1) - $ throw $ ErrorCaseOverlapping xx - - -- Alts overlapping because the same ctor is used multiple times. - when (length (nub nsCtorsMatched) /= length nsCtorsMatched ) - $ throw $ ErrorCaseOverlapping xx - - -- Check for alts overlapping because a default is not last. - -- Also check there is at least one alternative. - (case pats of - [] -> throw $ ErrorCaseNoAlternatives xx - - _ | or $ map isPDefault $ init pats - -> throw $ ErrorCaseOverlapping xx - - | otherwise - -> return ()) - - -- Check the alternatives are exhaustive. - (case mode of - - -- Small types have some finite number of constructors. - DataModeSmall nsCtors - -- If there is a default alternative then we've covered all the - -- possibiliies. We know this we've also checked for overlap. - | any isPDefault [p | AAlt p _ <- alts] - -> return () - - -- Look for unmatched constructors. - | nsCtorsMissing <- nsCtors \\ nsCtorsMatched - , not $ null nsCtorsMissing - -> throw $ ErrorCaseNonExhaustive xx nsCtorsMissing - - -- All constructors were matched. - | otherwise - -> return () - - -- Large types have an effectively infinite number of constructors - -- (like integer literals), so there needs to be a default alt. - DataModeLarge - | any isPDefault [p | AAlt p _ <- alts] -> return () - | otherwise - -> throw $ ErrorCaseNonExhaustiveLarge xx) - - let effsMatch - = Sum.singleton kEffect - $ crushEffect $ tHeadRead tDiscrim - - return ( XCase a xDiscrim' alts' - , tAlt - , Sum.unions kEffect (effsDiscrim : effsMatch : effss) - , Set.unions (closDiscrim : closs) ) - - --- type cast ------------------------------------- --- Weaken an effect, adding in the given terms. -checkExpM' defs kenv tenv xx@(XCast a c@(CastWeakenEffect eff) x1) - = do - -- Check the effect term. - kEff <- checkTypeM defs kenv eff - when (not $ isEffectKind kEff) - $ throw $ ErrorMaxeffNotEff xx eff kEff - - -- Check the body. - (x1', t1, effs, clo) <- checkExpM defs kenv tenv x1 - - return ( XCast a c x1' - , t1 - , Sum.insert eff effs - , clo) - - --- Weaken a closure, adding in the given terms. -checkExpM' defs kenv tenv xx@(XCast a c@(CastWeakenClosure clo2) x1) - = do - -- Check the closure term. - kClo <- checkTypeM defs kenv clo2 - when (not $ isClosureKind kClo) - $ throw $ ErrorMaxcloNotClo xx clo2 kClo - - -- The closure supplied to weakclo can only contain Use terms - -- of region variables. - clos2 - <- case taggedClosureOfWeakClo clo2 of - Nothing -> throw $ ErrorMaxcloMalformed xx clo2 - Just clos2' -> return clos2' - - -- Check the body. - (x1', t1, effs, clos) <- checkExpM defs kenv tenv x1 - - return ( XCast a c x1' - , t1 - , effs - , Set.union clos clos2) - - --- Purify an effect, given a witness that it is pure. -checkExpM' defs kenv tenv xx@(XCast a c@(CastPurify w) x1) - = do tW <- checkWitnessM defs kenv tenv w - (x1', t1, effs, clo) <- checkExpM defs kenv tenv x1 - - effs' <- case tW of - TApp (TCon (TyConWitness TwConPure)) effMask - -> return $ Sum.delete effMask effs - _ -> throw $ ErrorWitnessNotPurity xx w tW - - return ( XCast a c x1' - , t1 - , effs' - , clo) - - --- Forget a closure, given a witness that it is empty. -checkExpM' defs kenv tenv xx@(XCast a c@(CastForget w) x1) - = do tW <- checkWitnessM defs kenv tenv w - (x1', t1, effs, clos) <- checkExpM defs kenv tenv x1 - - clos' <- case tW of - TApp (TCon (TyConWitness TwConEmpty)) cloMask - -> return $ maskFromTaggedSet - (Sum.singleton kClosure cloMask) - clos - - _ -> throw $ ErrorWitnessNotEmpty xx w tW - - return ( XCast a c x1' - , t1 - , effs - , clos') - - --- Type and witness expressions can only appear as the arguments --- to applications. -checkExpM' _defs _kenv _tenv xx@(XType _) - = throw $ ErrorNakedType xx - -checkExpM' _defs _kenv _tenv xx@(XWitness _) - = throw $ ErrorNakedWitness xx - - -------------------------------------------------------------------------------- --- | Check a case alternative. -checkAltM - :: (Pretty n, Ord n) - => Exp a n -- ^ Whole case expression, for error messages. - -> DataDefs n -- ^ Data type definitions. - -> Env n -- ^ Kind environment. - -> Env n -- ^ Type environment. - -> Type n -- ^ Type of discriminant. - -> [Type n] -- ^ Args to type constructor of discriminant. - -> Alt a n -- ^ Alternative to check. - -> CheckM a n - ( Alt a n - , Type n - , TypeSum n - , Set (TaggedClosure n)) - -checkAltM _xx defs kenv tenv _tDiscrim _tsArgs (AAlt PDefault xBody) - = do (xBody', tBody, effBody, cloBody) - <- checkExpM defs kenv tenv xBody - - return ( AAlt PDefault xBody' - , tBody - , effBody - , cloBody) - -checkAltM xx defs kenv tenv tDiscrim tsArgs (AAlt (PData uCon bsArg) xBody) - = do - -- Take the type of the constructor and instantiate it with the - -- type arguments we got from the discriminant. - -- If the ctor type doesn't instantiate then it won't have enough foralls - -- on the front, which should have been checked by the def checker. - let tCtor = typeOfBound uCon - tCtor_inst - <- case instantiateTs tCtor tsArgs of - Nothing -> throw $ ErrorCaseCannotInstantiate xx tDiscrim tCtor - Just t -> return t - - -- Split the constructor type into the field and result types. - let (tsFields_ctor, tResult) - = takeTFunArgResult tCtor_inst - - -- The result type of the constructor must match the discriminant type. - -- If it doesn't then the constructor in the pattern probably isn't for - -- the discriminant type. - when (not $ equivT tDiscrim tResult) - $ throw $ ErrorCaseDiscrimTypeMismatch xx tDiscrim tResult - - -- There must be at least as many fields as variables in the pattern. - -- It's ok to bind less fields than provided by the constructor. - when (length tsFields_ctor < length bsArg) - $ throw $ ErrorCaseTooManyBinders xx uCon - (length tsFields_ctor) - (length bsArg) - - -- Merge the field types we get by instantiating the constructor - -- type with possible annotations from the source program. - -- If the annotations don't match, then we throw an error. - tsFields <- zipWithM (mergeAnnot xx) - (map typeOfBind bsArg) - tsFields_ctor - - -- Extend the environment with the field types. - let bsArg' = zipWith replaceTypeOfBind tsFields bsArg - let tenv' = Env.extends bsArg' tenv - - -- Check the body in this new environment. - (xBody', tBody, effsBody, closBody) - <- checkExpM defs kenv tenv' xBody - - -- Cut closure terms due to locally bound value vars. - -- This also lowers deBruijn indices in un-cut closure terms. - let closBody_cut - = Set.fromList - $ mapMaybe (cutTaggedClosureXs bsArg') - $ Set.toList closBody - - return ( AAlt (PData uCon bsArg') xBody' - , tBody - , effsBody - , closBody_cut) - - --- | Merge a type annotation on a pattern field with a type we get by --- instantiating the constructor type. -mergeAnnot :: Eq n => Exp a n -> Type n -> Type n -> CheckM a n (Type n) -mergeAnnot xx tAnnot tActual - -- Annotation is bottom, so just use the real type. - | isBot tAnnot = return tActual - - -- Annotation matches actual type, all good. - | tAnnot == tActual = return tActual - - -- Annotation does not match actual type. - | otherwise - = throw $ ErrorCaseFieldTypeMismatch xx tAnnot tActual - - -------------------------------------------------------------------------------- --- | Check the set of witness bindings bound in a letregion for conflicts. -checkWitnessBindsM :: Ord n => Exp a n -> Bound n -> [Bind n] -> CheckM a n () -checkWitnessBindsM xx nRegion bsWits - = mapM_ (checkWitnessBindM xx nRegion bsWits) bsWits - - -checkWitnessBindM - :: Ord n - => Exp a n - -> Bound n -- ^ Region variable bound in the letregion. - -> [Bind n] -- ^ Other witness bindings in the same set. - -> Bind n -- ^ The witness binding to check. - -> CheckM a n () - -checkWitnessBindM xx uRegion bsWit bWit - = let btsWit - = [(typeOfBind b, b) | b <- bsWit] - - -- Check the argument of a witness type is for the region we're - -- introducing here. - checkWitnessArg t - = case t of - TVar u' - | uRegion /= u' -> throw $ ErrorLetRegionWitnessOther xx uRegion bWit - | otherwise -> return () - - TCon (TyConBound u') - | uRegion /= u' -> throw $ ErrorLetRegionWitnessOther xx uRegion bWit - | otherwise -> return () - - -- The parser should ensure the right of a witness is a - -- constructor or variable. - _ -> throw $ ErrorLetRegionWitnessInvalid xx bWit - - in case typeOfBind bWit of - TApp (TCon (TyConWitness TwConGlobal)) t2 - -> checkWitnessArg t2 - - TApp (TCon (TyConWitness TwConConst)) t2 - | Just bConflict <- L.lookup (tMutable t2) btsWit - -> throw $ ErrorLetRegionWitnessConflict xx bWit bConflict - | otherwise -> checkWitnessArg t2 - - TApp (TCon (TyConWitness TwConMutable)) t2 - | Just bConflict <- L.lookup (tConst t2) btsWit - -> throw $ ErrorLetRegionWitnessConflict xx bWit bConflict - | otherwise -> checkWitnessArg t2 - - TApp (TCon (TyConWitness TwConLazy)) t2 - | Just bConflict <- L.lookup (tManifest t2) btsWit - -> throw $ ErrorLetRegionWitnessConflict xx bWit bConflict - | otherwise -> checkWitnessArg t2 - - TApp (TCon (TyConWitness TwConManifest)) t2 - | Just bConflict <- L.lookup (tLazy t2) btsWit - -> throw $ ErrorLetRegionWitnessConflict xx bWit bConflict - | otherwise -> checkWitnessArg t2 - - _ -> throw $ ErrorLetRegionWitnessInvalid xx bWit - - -------------------------------------------------------------------------------- --- | Check a type in the exp checking monad. -checkTypeM :: (Ord n, Pretty n) - => DataDefs n - -> Env n - -> Type n - -> CheckM a n (Kind n) - -checkTypeM defs kenv tt - = case T.checkType defs kenv tt of - Left err -> throw $ ErrorType err - Right k -> return k - - -------------------------------------------------------------------------------- --- | Check the type annotation of a let bound variable against the type --- inferred for the right of the binding. --- If the annotation is Bot then we just replace the annotation, --- otherwise it must match that for the right of the binding. -checkLetBindOfTypeM - :: (Eq n, Ord n, Pretty n) - => Exp a n - -> DataDefs n -- Data type definitions. - -> Env n -- Kind environment. - -> Env n -- Type environment. - -> Type n - -> Bind n - -> CheckM a n (Bind n, Kind n) - -checkLetBindOfTypeM xx defs kenv _tenv tRight b - -- If the annotation is Bot then just replace it. - | isBot (typeOfBind b) - = do k <- checkTypeM defs kenv tRight - return ( replaceTypeOfBind tRight b - , k) - - -- The type of the binder must match that of the right of the binding. - | not $ equivT (typeOfBind b) tRight - = throw $ ErrorLetMismatch xx b tRight - - | otherwise - = do k <- checkTypeM defs kenv (typeOfBind b) - return (b, k) - +-- | Type checker for the Disciple Core language. +module DDC.Core.Check.CheckExp + ( Config (..) + , AnTEC (..) + , checkExp + , typeOfExp + , CheckM + , checkExpM + , TaggedClosure(..)) +where +import DDC.Core.Predicates +import DDC.Core.Compounds +import DDC.Core.Collect +import DDC.Core.Pretty +import DDC.Core.Exp +import DDC.Core.Check.Error +import DDC.Core.Check.CheckDaCon +import DDC.Core.Check.CheckWitness +import DDC.Core.Check.TaggedClosure +import DDC.Type.Transform.SubstituteT +import DDC.Type.Transform.Crush +import DDC.Type.Transform.Trim +import DDC.Type.Transform.Instantiate +import DDC.Type.Transform.LiftT +import DDC.Type.DataDef +import DDC.Type.Equiv +import DDC.Type.Universe +import DDC.Type.Sum as Sum +import DDC.Type.Env (Env, KindEnv, TypeEnv) +import DDC.Control.Monad.Check (throw, result) +import Data.Set (Set) +import qualified DDC.Type.Env as Env +import qualified Data.Set as Set +import Control.Monad +import DDC.Data.ListUtils +import Data.List as L +import Data.Maybe +import Data.Typeable +import Control.DeepSeq + + +-- Annot ---------------------------------------------------------------------- +-- | The type checker adds this annotation to every node in the AST, +-- giving its type, effect and closure. +--- +-- NOTE: We wwant to leave the components lazy so that the checker +-- doesn't actualy need to produce the type components if they're +-- not needed. +data AnTEC a n + = AnTEC + { annotType :: (Type n) + , annotEffect :: (Effect n) + , annotClosure :: (Closure n) + , annotTail :: a } + deriving (Show, Typeable) + + +instance (NFData a, NFData n) => NFData (AnTEC a n) where + rnf !an + = rnf (annotType an) + `seq` rnf (annotEffect an) + `seq` rnf (annotClosure an) + `seq` rnf (annotTail an) + + +instance Pretty (AnTEC a n) where + ppr _ = text "AnTEC" + + + +-- Wrappers ------------------------------------------------------------------- +-- | Type check an expression. +-- +-- If it's good, you get a new version with types attached to all the bound +-- variables, as well its the type, effect and closure. +-- +-- If it's bad, you get a description of the error. +-- +-- The returned expression has types attached to all variable occurrences, +-- so you can call `typeOfExp` on any open subterm. +-- +-- The kinds and types of primitives are added to the environments +-- automatically, you don't need to supply these as part of the +-- starting environments. +-- +checkExp + :: (Ord n, Show n, Pretty n) + => Config n -- ^ Static configuration. + -> KindEnv n -- ^ Starting Kind environment. + -> TypeEnv n -- ^ Strating Type environment. + -> Exp a n -- ^ Expression to check. + -> Either (Error a n) + ( Exp (AnTEC a n) n + , Type n + , Effect n + , Closure n) + +checkExp !config !kenv !tenv !xx + = result + $ do (xx', t, effs, clos) + <- checkExpM config + (Env.union kenv (configPrimKinds config)) + (Env.union tenv (configPrimTypes config)) + xx + return ( xx' + , t + , TSum effs + , closureOfTaggedSet clos) + + +-- | Like `checkExp`, but only return the value type of an expression. +typeOfExp + :: (Ord n, Pretty n, Show n) + => Config n -- ^ Static configuration. + -> KindEnv n -- ^ Starting Kind environment + -> TypeEnv n -- ^ Starting Type environment. + -> Exp a n -- ^ Expression to check. + -> Either (Error a n) (Type n) +typeOfExp !config !kenv !tenv !xx + = case checkExp config kenv tenv xx of + Left err -> Left err + Right (_, t, _, _) -> Right t + + +-- checkExp ------------------------------------------------------------------- +-- | Like `checkExp` but using the `CheckM` monad to handle errors. +checkExpM + :: (Show n, Pretty n, Ord n) + => Config n -- ^ Static config. + -> Env n -- ^ Kind environment. + -> Env n -- ^ Type environment. + -> Exp a n -- ^ Expression to check. + -> CheckM a n + ( Exp (AnTEC a n) n + , Type n + , TypeSum n + , Set (TaggedClosure n)) + +checkExpM !config !kenv !tenv !xx + = {-# SCC checkExpM #-} + checkExpM' config kenv tenv xx + +-- variables ------------------------------------ +checkExpM' !_config !_kenv !tenv (XVar a u) + = case Env.lookup u tenv of + Nothing -> throw $ ErrorUndefinedVar u UniverseData + Just t + -> returnX a + (\z -> XVar z u) + t + (Sum.empty kEffect) + (Set.singleton $ taggedClosureOfValBound t u) + + +-- constructors --------------------------------- +checkExpM' !config !_kenv !_tenv xx@(XCon a dc) + = do + -- All data constructors need to have valid type annotations. + when (isBot $ daConType dc) + $ throw $ ErrorUndefinedCtor xx + + -- Check that the constructor is in the data type declarations. + checkDaConM config xx dc + + -- Type of the data constructor. + let tResult + = typeOfDaCon dc + + returnX a + (\z -> XCon z dc) + tResult + (Sum.empty kEffect) + Set.empty + + +-- application ------------------------------------ +-- value-type application. +-- +-- Note: We don't need to substitute into the effect of x1 (effs1) +-- because the body of a type abstraction is required to be pure. +-- +-- We don't need to substitute into the closure either, because +-- the bound type variable is not visible outside the abstraction. +-- thus we can't be sharing objects that have it in its type. +-- +checkExpM' !config !kenv !tenv xx@(XApp a x1 (XType t2)) + = do (x1', t1, effs1, clos1) <- checkExpM config kenv tenv x1 + + -- Check the type argument. + k2 <- checkTypeM config kenv t2 + + -- Take any Use annots from a region arg. + -- This always matches because we just checked 't2' + let Just t2_clo = taggedClosureOfTyArg kenv t2 + + case t1 of + TForall b11 t12 + | typeOfBind b11 == k2 + -> returnX a + (\z -> XApp z x1' (XType t2)) + (substituteT b11 t2 t12) + effs1 + (clos1 `Set.union` t2_clo) + + | otherwise -> throw $ ErrorAppMismatch xx (typeOfBind b11) t2 + _ -> throw $ ErrorAppNotFun xx t1 t2 + + +-- value-witness application. +checkExpM' !config !kenv !tenv xx@(XApp a x1 (XWitness w2)) + = do (x1', t1, effs1, clos1) <- checkExpM config kenv tenv x1 + t2 <- checkWitnessM config kenv tenv w2 + case t1 of + TApp (TApp (TCon (TyConWitness TwConImpl)) t11) t12 + | t11 `equivT` t2 + -> returnX a + (\z -> XApp z x1' (XWitness w2)) + t12 effs1 clos1 + + | otherwise -> throw $ ErrorAppMismatch xx t11 t2 + _ -> throw $ ErrorAppNotFun xx t1 t2 + + +-- value-value application. +checkExpM' !config !kenv !tenv xx@(XApp a x1 x2) + = do (x1', t1, effs1, clos1) <- checkExpM config kenv tenv x1 + (x2', t2, effs2, clos2) <- checkExpM config kenv tenv x2 + + -- Note: we don't need to use the closure of the function because + -- all of its components will already be part of clos1 above. + case t1 of + TApp (TApp (TApp (TApp (TCon (TyConSpec TcConFun)) t11) eff) _clo) t12 + | t11 `equivT` t2 + , effs <- Sum.fromList kEffect [eff] + -> returnX a + (\z -> XApp z x1' x2') + t12 + (effs1 `Sum.union` effs2 `Sum.union` effs) + (clos1 `Set.union` clos2) + + | otherwise -> throw $ ErrorAppMismatch xx t11 t2 + _ -> throw $ ErrorAppNotFun xx t1 t2 + + +-- spec abstraction ----------------------------- +checkExpM' !config !kenv !tenv xx@(XLAM a b1 x2) + = do let t1 = typeOfBind b1 + _ <- checkTypeM config kenv t1 + + -- Check the body + let kenv' = Env.extend b1 kenv + let tenv' = Env.lift 1 tenv + (x2', t2, e2, c2) <- checkExpM config kenv' tenv' x2 + k2 <- checkTypeM config kenv' t2 + + when (Env.memberBind b1 kenv) + $ throw $ ErrorLamShadow xx b1 + + -- The body of a spec abstraction must be pure. + when (e2 /= Sum.empty kEffect) + $ throw $ ErrorLamNotPure xx True (TSum e2) + + -- The body of a spec abstraction must have data kind. + when (not $ isDataKind k2) + $ throw $ ErrorLamBodyNotData xx b1 t2 k2 + + -- Mask closure terms due to locally bound region vars. + let c2_cut = Set.fromList + $ mapMaybe (cutTaggedClosureT b1) + $ Set.toList c2 + + returnX a + (\z -> XLAM z b1 x2') + (TForall b1 t2) + (Sum.empty kEffect) + c2_cut + + +-- function abstraction ------------------------- +checkExpM' !config !kenv !tenv xx@(XLam a b1 x2) + = do + -- Check the type of the binder. + let t1 = typeOfBind b1 + k1 <- checkTypeM config kenv t1 + + -- Check the body. + let tenv' = Env.extend b1 tenv + (x2', t2, e2, c2) <- checkExpM config kenv tenv' x2 + + -- The typing rules guarantee that the checked type of an + -- expression is well kinded, but we need to check it again + -- to find out what that kind is. + k2 <- checkTypeM config kenv t2 + + -- The form of the function constructor depends on what universe the + -- binder is in. + case universeFromType2 k1 of + + -- This is a data abstraction. + Just UniverseData + + -- The body of a data abstraction must accept data. + | not $ isDataKind k1 + -> throw $ ErrorLamBindNotData xx t1 k1 + + -- The body of a data abstraction must produce data. + | not $ isDataKind k2 + -> throw $ ErrorLamBodyNotData xx b1 t2 k2 + + -- Looks good. + | otherwise + -> let + -- Cut closure terms due to locally bound value vars. + -- This also lowers deBruijn indices in un-cut closure terms. + c2_cut = Set.fromList + $ mapMaybe (cutTaggedClosureX b1) + $ Set.toList c2 + + -- Trim the closure before we annotate the returned function + -- type with it. This should always succeed because trimClosure + -- only returns Nothing if the closure is miskinded, and we've + -- already already checked that. + Just c2_captured + + -- If we're suppressing closures then just drop them on the + -- floor. The consumer of this core program doesn't care. + | configSuppressClosures config + = Just $ tBot kClosure + + | otherwise + = trimClosure $ closureOfTaggedSet c2_cut + + in returnX a + (\z -> XLam z b1 x2') + (tFun t1 (TSum e2) c2_captured t2) + (Sum.empty kEffect) + c2_cut + + -- This is a witness abstraction. + Just UniverseWitness + + -- The body of a witness abstraction must be pure. + | e2 /= Sum.empty kEffect + -> throw $ ErrorLamNotPure xx False (TSum e2) + + -- The body of a witness abstraction must produce data. + | not $ isDataKind k2 + -> throw $ ErrorLamBodyNotData xx b1 t2 k2 + + -- Looks good. + | otherwise + -> returnX a + (\z -> XLam z b1 x2') + (tImpl t1 t2) + (Sum.empty kEffect) + c2 + + _ -> throw $ ErrorMalformedType xx k1 + + +-- let -------------------------------------------- +checkExpM' !config !kenv !tenv xx@(XLet a lts x2) + | case lts of + LLet{} -> True + LRec{} -> True + _ -> False + + = do + -- Check the bindings + (lts', bs', effs12, clo12) + <- checkLetsM xx config kenv tenv lts + + -- Check the body expression. + let tenv1 = Env.extends bs' tenv + (x2', t2, effs2, c2) <- checkExpM config kenv tenv1 x2 + + -- The body should have data kind. + k2 <- checkTypeM config kenv t2 + when (not $ isDataKind k2) + $ throw $ ErrorLetBodyNotData xx t2 k2 + + -- Mask closure terms due to locally bound value vars. + let c2_cut = Set.fromList + $ mapMaybe (cutTaggedClosureXs bs') + $ Set.toList c2 + + returnX a + (\z -> XLet z lts' x2') + t2 + (effs12 `Sum.union` effs2) + (clo12 `Set.union` c2_cut) + + +-- letregion -------------------------------------- +checkExpM' !config !kenv !tenv xx@(XLet a (LLetRegions bsRgn bsWit) x) + = case takeSubstBoundsOfBinds bsRgn of + [] -> checkExpM config kenv tenv x + us -> do + -- + let depth = length $ map isBAnon bsRgn + + -- Check the type on the region binders. + let ks = map typeOfBind bsRgn + mapM_ (checkTypeM config kenv) ks + + -- The binders must have region kind. + when (any (not . isRegionKind) ks) + $ throw $ ErrorLetRegionsNotRegion xx bsRgn ks + + -- We can't shadow region binders because we might have witnesses + -- in the environment that conflict with the ones created here. + let rebounds = filter (flip Env.memberBind kenv) bsRgn + when (not $ null rebounds) + $ throw $ ErrorLetRegionsRebound xx rebounds + + -- Check the witness types. + let kenv' = Env.extends bsRgn kenv + let tenv' = Env.lift depth tenv + mapM_ (checkTypeM config kenv') $ map typeOfBind bsWit + + -- Check that the witnesses bound here are for the region, + -- and they don't conflict with each other. + checkWitnessBindsM kenv xx us bsWit + + -- Check the body expression. + let tenv2 = Env.extends bsWit tenv' + (xBody', tBody, effs, clo) <- checkExpM config kenv' tenv2 x + + -- The body type must have data kind. + kBody <- checkTypeM config kenv' tBody + when (not $ isDataKind kBody) + $ throw $ ErrorLetBodyNotData xx tBody kBody + + -- The bound region variable cannot be free in the body type. + let fvsT = freeT Env.empty tBody + when (any (flip Set.member fvsT) us) + $ throw $ ErrorLetRegionFree xx bsRgn tBody + + -- Delete effects on the bound region from the result. + let delEff es u = Sum.delete (tRead (TVar u)) + $ Sum.delete (tWrite (TVar u)) + $ Sum.delete (tAlloc (TVar u)) + $ es + let effs' = foldl delEff effs us + + -- Delete the bound region variable from the closure. + -- Mask closure terms due to locally bound region vars. + let cutClo c r = mapMaybe (cutTaggedClosureT r) c + let c2_cut = Set.fromList + $ foldl cutClo (Set.toList clo) bsRgn + + returnX a + (\z -> XLet z (LLetRegions bsRgn bsWit) xBody') + (lowerT depth tBody) + (lowerT depth effs') + c2_cut + + +-- withregion ----------------------------------- +checkExpM' !config !kenv !tenv xx@(XLet a (LWithRegion u) x) + = do + -- The handle must have region kind. + (case Env.lookup u kenv of + Nothing -> throw $ ErrorUndefinedVar u UniverseSpec + + Just k | not $ isRegionKind k + -> throw $ ErrorWithRegionNotRegion xx u k + + _ -> return ()) + + -- Check the body expression. + (xBody', tBody, effs, clo) + <- checkExpM config kenv tenv x + + -- The body type must have data kind. + kBody <- checkTypeM config kenv tBody + when (not $ isDataKind kBody) + $ throw $ ErrorLetBodyNotData xx tBody kBody + + -- The bound region variable cannot be free in the body type. + let tcs = supportTyCon + $ support Env.empty Env.empty tBody + when (Set.member u tcs) + $ throw $ ErrorWithRegionFree xx u tBody + + -- Delete effects on the bound region from the result. + let tu = TCon $ TyConBound u kRegion + let effs' = Sum.delete (tRead tu) + $ Sum.delete (tWrite tu) + $ Sum.delete (tAlloc tu) + $ effs + + -- Delete the bound region handle from the closure. + let clo_masked = Set.delete (GBoundRgnCon u) clo + + returnX a + (\z -> XLet z (LWithRegion u) xBody') + tBody + effs' + clo_masked + + +-- case expression ------------------------------ +checkExpM' !config !kenv !tenv xx@(XCase a xDiscrim alts) + = do + -- Check the discriminant. + (xDiscrim', tDiscrim, effsDiscrim, closDiscrim) + <- checkExpM config kenv tenv xDiscrim + + -- Split the type into the type constructor names and type parameters. + -- Also check that it's algebraic data, and not a function or effect + -- type etc. + (mmode, tsArgs) + <- case takeTyConApps tDiscrim of + Just (tc, ts) + | TyConSpec TcConUnit <- tc + -> return ( Just (DataModeSmall []) + , [] ) + -- ISSUE #269: Refactor DataModeSmall to hold DaCons instead of names. + -- The DataModeSmall should hold DaCons instead of + -- names, as we don't have a name for Unit. + + | TyConBound (UName nTyCon) k <- tc + , takeResultKind k == kData + -> return ( lookupModeOfDataType nTyCon (configPrimDataDefs config) + , ts ) + + | TyConBound (UPrim nTyCon _) k <- tc + , takeResultKind k == kData + -> return ( lookupModeOfDataType nTyCon (configPrimDataDefs config) + , ts ) + + _ -> throw $ ErrorCaseScrutineeNotAlgebraic xx tDiscrim + + -- Get the mode of the data type, + -- this tells us how many constructors there are. + mode + <- case mmode of + Nothing -> throw $ ErrorCaseScrutineeTypeUndeclared xx tDiscrim + Just m -> return m + + -- Check the alternatives. + (alts', ts, effss, closs) + <- liftM unzip4 + $ mapM (checkAltM xx config kenv tenv tDiscrim tsArgs) alts + + -- There must be at least one alternative + when (null ts) + $ throw $ ErrorCaseNoAlternatives xx + + -- All alternative result types must be identical. + let (tAlt : _) = ts + forM_ ts $ \tAlt' + -> when (not $ equivT tAlt tAlt') + $ throw $ ErrorCaseAltResultMismatch xx tAlt tAlt' + + -- Check for overlapping alternatives. + let pats = [p | AAlt p _ <- alts] + let psDefaults = filter isPDefault pats + let nsCtorsMatched = mapMaybe takeCtorNameOfAlt alts + + -- Alts overlapping because there are multiple defaults. + when (length psDefaults > 1) + $ throw $ ErrorCaseOverlapping xx + + -- Alts overlapping because the same ctor is used multiple times. + when (length (nub nsCtorsMatched) /= length nsCtorsMatched ) + $ throw $ ErrorCaseOverlapping xx + + -- Check for alts overlapping because a default is not last. + -- Also check there is at least one alternative. + (case pats of + [] -> throw $ ErrorCaseNoAlternatives xx + + _ | Just patsInit <- takeInit pats + , or $ map isPDefault $ patsInit + -> throw $ ErrorCaseOverlapping xx + + | otherwise + -> return ()) + + -- Check the alternatives are exhaustive. + (case mode of + + -- Small types have some finite number of constructors. + DataModeSmall nsCtors + -- If there is a default alternative then we've covered all the + -- possibiliies. We know this we've also checked for overlap. + | any isPDefault [p | AAlt p _ <- alts] + -> return () + + -- Look for unmatched constructors. + | nsCtorsMissing <- nsCtors \\ nsCtorsMatched + , not $ null nsCtorsMissing + -> throw $ ErrorCaseNonExhaustive xx nsCtorsMissing + + -- All constructors were matched. + | otherwise + -> return () + + -- Large types have an effectively infinite number of constructors + -- (like integer literals), so there needs to be a default alt. + DataModeLarge + | any isPDefault [p | AAlt p _ <- alts] -> return () + | otherwise + -> throw $ ErrorCaseNonExhaustiveLarge xx) + + let effsMatch + = Sum.singleton kEffect + $ crushEffect $ tHeadRead tDiscrim + + returnX a + (\z -> XCase z xDiscrim' alts') + tAlt + (Sum.unions kEffect (effsDiscrim : effsMatch : effss)) + (Set.unions (closDiscrim : closs)) + + +-- type cast ------------------------------------- +-- Weaken an effect, adding in the given terms. +checkExpM' !config !kenv !tenv xx@(XCast a (CastWeakenEffect eff) x1) + = do + -- Check the effect term. + kEff <- checkTypeM config kenv eff + when (not $ isEffectKind kEff) + $ throw $ ErrorWeakEffNotEff xx eff kEff + + -- Check the body. + (x1', t1, effs, clo) <- checkExpM config kenv tenv x1 + let c' = CastWeakenEffect eff + + returnX a + (\z -> XCast z c' x1') + t1 + (Sum.insert eff effs) + clo + + +-- Weaken a closure, adding in the given terms. +checkExpM' !config !kenv !tenv (XCast a (CastWeakenClosure xs) x1) + = do + -- Check the contained expressions. + (xs', closs) + <- liftM unzip + $ mapM (checkArgM config kenv tenv) xs + + -- Check the body. + (x1', t1, effs, clos) <- checkExpM config kenv tenv x1 + let c' = CastWeakenClosure xs' + + returnX a + (\z -> XCast z c' x1') + t1 + effs + (Set.unions (clos : closs)) + + +-- Purify an effect, given a witness that it is pure. +checkExpM' !config !kenv !tenv xx@(XCast a (CastPurify w) x1) + = do + tW <- checkWitnessM config kenv tenv w + (x1', t1, effs, clo) <- checkExpM config kenv tenv x1 + + effs' <- case tW of + TApp (TCon (TyConWitness TwConPure)) effMask + -> return $ Sum.delete effMask effs + _ -> throw $ ErrorWitnessNotPurity xx w tW + + let c' = CastPurify w + + returnX a + (\z -> XCast z c' x1') + t1 effs' clo + + +-- Forget a closure, given a witness that it is empty. +checkExpM' !config !kenv !tenv xx@(XCast a (CastForget w) x1) + = do + tW <- checkWitnessM config kenv tenv w + (x1', t1, effs, clos) <- checkExpM config kenv tenv x1 + + clos' <- case tW of + TApp (TCon (TyConWitness TwConEmpty)) cloMask + -> return $ maskFromTaggedSet + (Sum.singleton kClosure cloMask) + clos + + _ -> throw $ ErrorWitnessNotEmpty xx w tW + + let c' = CastForget w + + returnX a + (\z -> XCast z c' x1') + t1 effs clos' + + +-- Type and witness expressions can only appear as the arguments +-- to applications. +checkExpM' !_config !_kenv !_tenv xx@(XType _) + = throw $ ErrorNakedType xx + +checkExpM' !_config !_kenv !_tenv xx@(XWitness _) + = throw $ ErrorNakedWitness xx + +checkExpM' _ _ _ _ + = error "checkExpM: bogus warning killer" + + +-- | Like `checkExp` but we allow naked types and witnesses. +checkArgM + :: (Show n, Pretty n, Ord n) + => Config n -- ^ Static config. + -> Env n -- ^ Kind environment. + -> Env n -- ^ Type environment. + -> Exp a n -- ^ Expression to check. + -> CheckM a n + ( Exp (AnTEC a n) n + , Set (TaggedClosure n)) + +checkArgM !config !kenv !tenv !xx + = case xx of + XType t + -> do checkTypeM config kenv t + let Just clo = taggedClosureOfTyArg kenv t + + return ( XType t + , clo) + + XWitness w + -> do checkWitnessM config kenv tenv w + return ( XWitness w + , Set.empty) + + _ -> do + (xx', _, _, clos) <- checkExpM config kenv tenv xx + return ( xx' + , clos) + + +-- | Helper function for building the return value of checkExpM' +-- It builts the AnTEC annotation and attaches it to the new AST node, +-- as well as returning the current effect and closure in the appropriate +-- form as part of the tuple. +returnX :: Ord n + => a + -> (AnTEC a n -> Exp (AnTEC a n) n) + -> Type n + -> TypeSum n + -> Set (TaggedClosure n) + -> CheckM a n + ( Exp (AnTEC a n) n + , Type n + , TypeSum n + , Set (TaggedClosure n)) + +returnX !a !f !t !es !cs + = let e = TSum es + c = closureOfTaggedSet cs + in return (f (AnTEC t e c a) + , t, es, cs) +{-# INLINE returnX #-} + +------------------------------------------------------------------------------- +-- | Check some let bindings. +checkLetsM + :: (Show n, Pretty n, Ord n) + => Exp a n -- ^ Enclosing expression, for error messages. + -> Config n -- ^ Static config. + -> Env n -- ^ Kind environment. + -> Env n -- ^ Type environment. + -> Lets a n + -> CheckM a n + ( Lets (AnTEC a n) n + , [Bind n] + , TypeSum n + , Set (TaggedClosure n)) + +checkLetsM !xx !config !kenv !tenv (LLet mode b11 x12) + = do + -- Check the right of the binding. + (x12', t12, effs12, clo12) + <- checkExpM config kenv tenv x12 + + -- Check binder annotation against the type we inferred for the right. + (b11', k11') + <- checkLetBindOfTypeM xx config kenv tenv t12 b11 + + -- The right of the binding should have data kind. + when (not $ isDataKind k11') + $ throw $ ErrorLetBindingNotData xx b11' k11' + + -- Check purity and emptiness for lazy bindings. + (case mode of + LetStrict -> return () + LetLazy _ + -> do let eff12' = TSum effs12 + when (not $ isBot eff12') + $ throw $ ErrorLetLazyNotPure xx b11 eff12' + + let clo12' = closureOfTaggedSet clo12 + when (not $ isBot clo12') + $ throw $ ErrorLetLazyNotEmpty xx b11 clo12') + + -- Check region witness for lazy bindings. + (case mode of + LetStrict -> return () + + -- Type of lazy binding has no head region, like Unit and (->). + LetLazy Nothing + -> do case takeDataTyConApps t12 of + Just (_tc, t1 : _) + -> do k1 <- checkTypeM config kenv t1 + when (isRegionKind k1) + $ throw $ ErrorLetLazyNoWitness xx b11 t12 + + _ -> return () + + -- Type of lazy binding might have a head region, + -- so we need a Lazy witness for it. + LetLazy (Just wit) + -> do tWit <- checkWitnessM config kenv tenv wit + let tWitExp = case takeDataTyConApps t12 of + Just (_tc, tR : _ts) -> tLazy tR + _ -> tHeadLazy t12 + + when (not $ equivT tWit tWitExp) + $ throw $ ErrorLetLazyWitnessTypeMismatch + xx b11 tWit t12 tWitExp) + + return ( LLet mode b11' x12' + , [b11'] + , effs12 + , clo12) + +-- letrec --------------------------------------- +checkLetsM !xx !config !kenv !tenv (LRec bxs) + = do + let (bs, xs) = unzip bxs + + -- No named binders can be multiply defined. + (case duplicates $ filter isBName bs of + [] -> return () + b : _ -> throw $ ErrorLetrecRebound xx b) + + -- Check the types on all the binders. + ks <- mapM (checkTypeM config kenv) + $ map typeOfBind bs + + -- Check all the binders have data kind. + zipWithM_ (\b k + -> when (not $ isDataKind k) + $ throw $ ErrorLetBindingNotData xx b k) + bs ks + + -- All right hand sides need to be lambdas. + forM_ xs $ \x + -> when (not $ (isXLam x || isXLAM x)) + $ throw $ ErrorLetrecBindingNotLambda xx x + + -- All variables are in scope in all right hand sides. + let tenv' = Env.extends bs tenv + + -- Check the right hand sides. + (xsRight', tsRight, _effssBinds, clossBinds) + <- liftM unzip4 $ mapM (checkExpM config kenv tenv') xs + + -- Check annots on binders against inferred types of the bindings. + zipWithM_ (\b t + -> if not $ equivT (typeOfBind b) t + then throw $ ErrorLetMismatch xx b t + else return ()) + bs tsRight + + -- Cut closure terms due to locally bound value vars. + let clos_cut + = Set.fromList + $ mapMaybe (cutTaggedClosureXs bs) + $ Set.toList + $ Set.unions clossBinds + + return ( LRec (zip bs xsRight') + , zipWith replaceTypeOfBind tsRight bs + , Sum.empty kEffect + , clos_cut) + +checkLetsM _xx _config _kenv _tenv _lts + = error "checkLetsM: case should have been handled in checkExpM" + + +-- | Take elements of a list that have more than once occurrence. +duplicates :: Eq a => [a] -> [a] +duplicates [] = [] +duplicates (x : xs) + | L.elem x xs = x : duplicates (filter (/= x) xs) + | otherwise = duplicates xs + + +------------------------------------------------------------------------------- +-- | Check a case alternative. +checkAltM + :: (Show n, Pretty n, Ord n) + => Exp a n -- ^ Whole case expression, for error messages. + -> Config n -- ^ Data type definitions. + -> Env n -- ^ Kind environment. + -> Env n -- ^ Type environment. + -> Type n -- ^ Type of discriminant. + -> [Type n] -- ^ Args to type constructor of discriminant. + -> Alt a n -- ^ Alternative to check. + -> CheckM a n + ( Alt (AnTEC a n) n + , Type n + , TypeSum n + , Set (TaggedClosure n)) + +checkAltM !_xx !config !kenv !tenv !_tDiscrim !_tsArgs (AAlt PDefault xBody) + = do (xBody', tBody, effBody, cloBody) + <- checkExpM config kenv tenv xBody + + return ( AAlt PDefault xBody' + , tBody + , effBody + , cloBody) + +checkAltM !xx !config !kenv !tenv !tDiscrim !tsArgs (AAlt (PData dc bsArg) xBody) + = do + let Just aCase = takeAnnotOfExp xx + + -- If the data constructor isn't defined then the spread + -- transform won't have given it a proper type. + -- Note that we can't simply check whether the constructor is in the + -- environment because literals like 42# never are. + (if isBot (daConType dc) + then throw $ ErrorUndefinedCtor $ XCon aCase dc + else return ()) + + -- Take the type of the constructor and instantiate it with the + -- type arguments we got from the discriminant. + -- If the ctor type doesn't instantiate then it won't have enough foralls + -- on the front, which should have been checked by the def checker. + let tCtor = daConType dc + + tCtor_inst + <- case instantiateTs tCtor tsArgs of + Nothing -> throw $ ErrorCaseCannotInstantiate xx tDiscrim tCtor + Just t -> return t + + -- Split the constructor type into the field and result types. + let (tsFields_ctor, tResult) + = takeTFunArgResult tCtor_inst + + -- The result type of the constructor must match the discriminant type. + -- If it doesn't then the constructor in the pattern probably isn't for + -- the discriminant type. + when (not $ equivT tDiscrim tResult) + $ throw $ ErrorCaseScrutineeTypeMismatch xx tDiscrim tResult + + -- There must be at least as many fields as variables in the pattern. + -- It's ok to bind less fields than provided by the constructor. + when (length tsFields_ctor < length bsArg) + $ throw $ ErrorCaseTooManyBinders xx dc + (length tsFields_ctor) + (length bsArg) + + -- Merge the field types we get by instantiating the constructor + -- type with possible annotations from the source program. + -- If the annotations don't match, then we throw an error. + tsFields <- zipWithM (mergeAnnot xx) + (map typeOfBind bsArg) + tsFields_ctor + + -- Extend the environment with the field types. + let bsArg' = zipWith replaceTypeOfBind tsFields bsArg + let tenv' = Env.extends bsArg' tenv + + -- Check the body in this new environment. + (xBody', tBody, effsBody, closBody) + <- checkExpM config kenv tenv' xBody + + -- Cut closure terms due to locally bound value vars. + -- This also lowers deBruijn indices in un-cut closure terms. + let closBody_cut + = Set.fromList + $ mapMaybe (cutTaggedClosureXs bsArg') + $ Set.toList closBody + + return ( AAlt (PData dc bsArg') xBody' + , tBody + , effsBody + , closBody_cut) + + +-- | Merge a type annotation on a pattern field with a type we get by +-- instantiating the constructor type. +mergeAnnot :: Eq n => Exp a n -> Type n -> Type n -> CheckM a n (Type n) +mergeAnnot !xx !tAnnot !tActual + -- Annotation is bottom, so just use the real type. + | isBot tAnnot = return tActual + + -- Annotation matches actual type, all good. + | tAnnot == tActual = return tActual + + -- Annotation does not match actual type. + | otherwise + = throw $ ErrorCaseFieldTypeMismatch xx tAnnot tActual + + +------------------------------------------------------------------------------- +-- | Check the set of witness bindings bound in a letregion for conflicts. +checkWitnessBindsM + :: (Show n, Ord n) + => KindEnv n + -> Exp a n + -> [Bound n] + -> [Bind n] + -> CheckM a n () + +checkWitnessBindsM !kenv !xx !nRegions !bsWits + = mapM_ (checkWitnessBindM kenv xx nRegions bsWits) bsWits + + +checkWitnessBindM + :: (Show n, Ord n) + => Env n + -> Exp a n + -> [Bound n] -- ^ Region variables bound in the letregion. + -> [Bind n] -- ^ Other witness bindings in the same set. + -> Bind n -- ^ The witness binding to check. + -> CheckM a n () + +checkWitnessBindM !kenv !xx !uRegions !bsWit !bWit + = let btsWit + = [(typeOfBind b, b) | b <- bsWit] + + -- Check the argument of a witness type is for the region we're + -- introducing here. + checkWitnessArg t + = case t of + TVar u' + | all (/= u') uRegions -> throw $ ErrorLetRegionsWitnessOther xx uRegions bWit + | otherwise -> return () + + TCon (TyConBound u' _) + | all (/= u') uRegions -> throw $ ErrorLetRegionsWitnessOther xx uRegions bWit + | otherwise -> return () + + -- The parser should ensure the right of a witness is a + -- constructor or variable. + _ -> throw $ ErrorLetRegionWitnessInvalid xx bWit + + inEnv t + = case t of + TVar u' | Env.member u' kenv -> True + TCon (TyConBound u' _) | Env.member u' kenv -> True + _ -> False + + in case typeOfBind bWit of + TApp (TCon (TyConWitness TwConGlobal)) t2 + -> checkWitnessArg t2 + + TApp (TCon (TyConWitness TwConConst)) t2 + | Just bConflict <- L.lookup (tMutable t2) btsWit + -> throw $ ErrorLetRegionWitnessConflict xx bWit bConflict + | otherwise -> checkWitnessArg t2 + + TApp (TCon (TyConWitness TwConMutable)) t2 + | Just bConflict <- L.lookup (tConst t2) btsWit + -> throw $ ErrorLetRegionWitnessConflict xx bWit bConflict + | otherwise -> checkWitnessArg t2 + + TApp (TCon (TyConWitness TwConLazy)) t2 + | Just bConflict <- L.lookup (tManifest t2) btsWit + -> throw $ ErrorLetRegionWitnessConflict xx bWit bConflict + | otherwise -> checkWitnessArg t2 + + TApp (TCon (TyConWitness TwConManifest)) t2 + | Just bConflict <- L.lookup (tLazy t2) btsWit + -> throw $ ErrorLetRegionWitnessConflict xx bWit bConflict + | otherwise -> checkWitnessArg t2 + + (takeTyConApps -> Just (TyConWitness (TwConDistinct 2), [t1, t2])) + | inEnv t1 -> checkWitnessArg t2 + | inEnv t2 -> checkWitnessArg t1 + | t1 /= t2 -> mapM_ checkWitnessArg [t1, t2] + | otherwise -> throw $ ErrorLetRegionWitnessInvalid xx bWit + + (takeTyConApps -> Just (TyConWitness (TwConDistinct _), ts)) + -> mapM_ checkWitnessArg ts + + _ -> throw $ ErrorLetRegionWitnessInvalid xx bWit + + +------------------------------------------------------------------------------- +-- | Check the type annotation of a let bound variable against the type +-- inferred for the right of the binding. +-- If the annotation is Bot then we just replace the annotation, +-- otherwise it must match that for the right of the binding. +checkLetBindOfTypeM + :: (Ord n, Show n, Pretty n) + => Exp a n + -> Config n -- Data type definitions. + -> Env n -- Kind environment. + -> Env n -- Type environment. + -> Type n + -> Bind n + -> CheckM a n (Bind n, Kind n) + +checkLetBindOfTypeM !xx !config !kenv !_tenv !tRight b + -- If the annotation is Bot then just replace it. + | isBot (typeOfBind b) + = do k <- checkTypeM config kenv tRight + return ( replaceTypeOfBind tRight b + , k) + + -- The type of the binder must match that of the right of the binding. + | not $ equivT (typeOfBind b) tRight + = throw $ ErrorLetMismatch xx b tRight + + | otherwise + = do k <- checkTypeM config kenv (typeOfBind b) + return (b, k) diff --git a/DDC/Core/Check/CheckModule.hs b/DDC/Core/Check/CheckModule.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Check/CheckModule.hs @@ -0,0 +1,159 @@ + +module DDC.Core.Check.CheckModule + ( checkModule + , checkModuleM) +where +import DDC.Core.Module +import DDC.Core.Exp +import DDC.Core.Check.CheckExp +import DDC.Core.Check.Error +import DDC.Type.Compounds +import DDC.Base.Pretty +import DDC.Type.Equiv +import DDC.Type.Env (KindEnv, TypeEnv) +import DDC.Control.Monad.Check (result, throw) +import Data.Map (Map) +import qualified DDC.Type.Check as T +import qualified DDC.Type.Env as Env +import qualified Data.Map as Map + + +-- Wrappers ------------------------------------------------------------------- +-- | Type check a module. +-- +-- If it's good, you get a new version with types attached to all the bound +-- variables +-- +-- If it's bad, you get a description of the error. +checkModule + :: (Ord n, Show n, Pretty n) + => Config n -- ^ Static configuration. + -> Module a n -- ^ Module to check. + -> Either (Error a n) (Module (AnTEC a n) n) + +checkModule !config !xx + = result + $ checkModuleM + config + (configPrimKinds config) + (configPrimTypes config) + xx + + +-- checkModule ---------------------------------------------------------------- +-- | Like `checkModule` but using the `CheckM` monad to handle errors. +checkModuleM + :: (Ord n, Show n, Pretty n) + => Config n -- ^ Static configuration. + -> KindEnv n -- ^ Starting kind environment. + -> TypeEnv n -- ^ Starting type environment. + -> Module a n -- ^ Module to check. + -> CheckM a n (Module (AnTEC a n) n) + +checkModuleM !config !kenv !tenv mm@ModuleCore{} + = do + -- Convert the imported kind and type map to a list of binds. + let bksImport = [BName n k | (n, (_, k)) <- Map.toList $ moduleImportKinds mm] + let btsImport = [BName n t | (n, (_, t)) <- Map.toList $ moduleImportTypes mm] + + -- Check the imported kinds and types. + -- The imported types are in scope in both imported and exported signatures. + mapM_ (checkTypeM config kenv) $ map typeOfBind bksImport + let kenv' = Env.union kenv $ Env.fromList bksImport + + mapM_ (checkTypeM config kenv') $ map typeOfBind btsImport + let tenv' = Env.union tenv $ Env.fromList btsImport + + -- Check the sigs for exported things. + mapM_ (checkTypeM config kenv') $ Map.elems $ moduleExportKinds mm + mapM_ (checkTypeM config kenv') $ Map.elems $ moduleExportTypes mm + + -- Check our let bindings. + (x', _, _effs, _) <- checkExpM config kenv' tenv' (moduleBody mm) + + -- Check that each exported signature matches the type of its binding. + envDef <- checkModuleBinds (moduleExportKinds mm) (moduleExportTypes mm) x' + + -- Check that all exported bindings are defined by the module. + mapM_ (checkBindDefined envDef) $ Map.keys $ moduleExportTypes mm + + -- Return the checked bindings as they have explicit type annotations. + let mm' = mm { moduleBody = x' } + return mm' + + +-- | Check that the exported signatures match the types of their bindings. +checkModuleBinds + :: Ord n + => Map n (Kind n) -- ^ Kinds of exported types. + -> Map n (Type n) -- ^ Types of exported values. + -> Exp (AnTEC a n) n + -> CheckM a n (TypeEnv n) -- ^ Environment of top-level bindings + -- defined by the module + +checkModuleBinds !ksExports !tsExports !xx + = case xx of + XLet _ (LLet _ b _) x2 + -> do checkModuleBind ksExports tsExports b + env <- checkModuleBinds ksExports tsExports x2 + return $ Env.extend b env + + XLet _ (LRec bxs) x2 + -> do mapM_ (checkModuleBind ksExports tsExports) $ map fst bxs + env <- checkModuleBinds ksExports tsExports x2 + return $ Env.extends (map fst bxs) env + + XLet _ (LLetRegions _ _) x2 + -> checkModuleBinds ksExports tsExports x2 + + _ -> return Env.empty + + +-- | If some bind is exported, then check that it matches the exported version. +checkModuleBind + :: Ord n + => Map n (Kind n) -- ^ Kinds of exported types. + -> Map n (Type n) -- ^ Types of exported values. + -> Bind n + -> CheckM a n () + +checkModuleBind !_ksExports !tsExports !b + | BName n tDef <- b + = case Map.lookup n tsExports of + Nothing -> return () + Just tExport + | equivT tDef tExport -> return () + | otherwise -> throw $ ErrorExportMismatch n tExport tDef + + -- Only named bindings can be exported, + -- so we don't need to worry about non-named ones. + | otherwise + = return () + + +-- | Check that a top-level binding is actually defined by the module. +checkBindDefined + :: Ord n + => TypeEnv n -- ^ Types defined by the module. + -> n -- ^ Name of an exported binding. + -> CheckM a n () + +checkBindDefined env n + = case Env.lookup (UName n) env of + Just _ -> return () + _ -> throw $ ErrorExportUndefined n + + +------------------------------------------------------------------------------- +-- | Check a type in the exp checking monad. +checkTypeM :: (Ord n, Show n, Pretty n) + => Config n + -> KindEnv n + -> Type n + -> CheckM a n (Kind n) + +checkTypeM !config !kenv !tt + = case T.checkType (configPrimDataDefs config) kenv tt of + Left err -> throw $ ErrorType err + Right k -> return k + diff --git a/DDC/Core/Check/CheckWitness.hs b/DDC/Core/Check/CheckWitness.hs --- a/DDC/Core/Check/CheckWitness.hs +++ b/DDC/Core/Check/CheckWitness.hs @@ -1,31 +1,34 @@ - -- | Type checker for witness expressions. module DDC.Core.Check.CheckWitness - ( checkWitness + ( Config(..) + , configOfProfile + + , checkWitness , typeOfWitness , typeOfWiCon , typeOfWbCon , CheckM - , checkWitnessM) + , checkWitnessM + + , checkTypeM) where -import DDC.Core.DataDef import DDC.Core.Exp import DDC.Core.Pretty import DDC.Core.Check.Error -import DDC.Core.Check.ErrorMessage () +import DDC.Core.Check.ErrorMessage () +import DDC.Type.DataDef import DDC.Type.Transform.SubstituteT import DDC.Type.Compounds -import DDC.Type.Predicates -import DDC.Type.Equiv -import DDC.Type.Transform.LiftT -import DDC.Type.Sum as Sum -import DDC.Type.Env (Env) -import DDC.Type.Check.Monad (result, throw) -import DDC.Base.Pretty () -import qualified DDC.Type.Env as Env -import qualified DDC.Type.Check as T -import qualified DDC.Type.Check.Monad as G +import DDC.Type.Universe +import DDC.Type.Sum as Sum +import DDC.Type.Env (KindEnv, TypeEnv) +import DDC.Control.Monad.Check (throw, result) +import DDC.Base.Pretty () +import qualified DDC.Control.Monad.Check as G +import qualified DDC.Type.Env as Env +import qualified DDC.Type.Check as T +import qualified DDC.Core.Fragment as F -- | Type checker monad. @@ -33,6 +36,46 @@ type CheckM a n = G.CheckM (Error a n) +-- Config --------------------------------------------------------------------- +-- | Static configuration for the type checker. +-- These fields don't change as we decend into the tree. +-- +-- The starting configuration should be converted from the profile that +-- defines the language fragment you are checking. +-- See "DDC.Core.Fragment" and use `configOfProfile` below. +data Config n + = Config + { -- | Data type definitions. + configPrimDataDefs :: DataDefs n + + -- | Kinds of primitive types. + , configPrimKinds :: KindEnv n + + -- | Types of primitive operators. + , configPrimTypes :: TypeEnv n + + -- | Suppress all closure information, + -- annotating all functions with an empty closure. + -- + -- This is used when checking the Disciple Core Salt fragment, + -- as transforms in this language don't use the closure + -- information. + , configSuppressClosures :: Bool } + + +-- | Convert a langage profile to a type checker configuration. +configOfProfile :: F.Profile n -> Config n +configOfProfile profile + = Config + { configPrimDataDefs = F.profilePrimDataDefs profile + , configPrimKinds = F.profilePrimKinds profile + , configPrimTypes = F.profilePrimTypes profile + + , configSuppressClosures + = F.featuresUntrackedClosures + $ F.profileFeatures profile } + + -- Wrappers -------------------------------------------------------------------- -- | Check a witness. -- @@ -44,16 +87,20 @@ -- 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, Pretty n) - => DataDefs n -- ^ Data type definitions. - -> Env n -- ^ Kind Environment. - -> Env n -- ^ Type Environment. + :: (Ord n, Show n, Pretty n) + => Config n -- ^ Static configuration. + -> KindEnv n -- ^ Starting Kind Environment. + -> TypeEnv n -- ^ Strating Type Environment. -> Witness n -- ^ Witness to check. -> Either (Error a n) (Type n) -checkWitness defs kenv tenv xx - = result $ checkWitnessM defs kenv tenv xx +checkWitness config kenv tenv xx + = result $ checkWitnessM config kenv tenv xx -- | Like `checkWitness`, but check in an empty environment. @@ -63,78 +110,38 @@ -- This attachment is performed by `checkWitness` above. -- typeOfWitness - :: (Ord n, Pretty n) - => DataDefs n + :: (Ord n, Show n, Pretty n) + => Config n -> Witness n -> Either (Error a n) (Type n) -typeOfWitness defs ww +typeOfWitness config ww = result - $ checkWitnessM defs Env.empty Env.empty ww + $ checkWitnessM config Env.empty Env.empty ww ------------------------------------------------------------------------------ -- | Like `checkWitness` but using the `CheckM` monad to manage errors. checkWitnessM - :: (Ord n, Pretty n) - => DataDefs n -- ^ Data type definitions. - -> Env n -- ^ Kind environment. - -> Env n -- ^ Type environment. + :: (Ord n, Show n, Pretty n) + => Config n -- ^ Data type definitions. + -> KindEnv n -- ^ Kind environment. + -> TypeEnv n -- ^ Type environment. -> Witness n -- ^ Witness to check. -> CheckM a n (Type n) -checkWitnessM _defs _kenv tenv (WVar u) - = do let tBound = typeOfBound u - let mtEnv = Env.lookup u tenv - - let mkResult - -- When annotation on the bound is bot, - -- then use the type from the environment. - | Just tEnv <- mtEnv - , isBot tBound - = return tEnv - - -- The bound has an explicit type annotation, - -- which matches the one from the environment. - -- - -- When the bound is a deBruijn index we need to lift the - -- annotation on the original binder through any lambdas - -- between the binding occurrence and the use. - | Just tEnv <- mtEnv - , UIx i _ <- u - , equivT tBound (liftT (i + 1) tEnv) - = return tBound - - -- The bound has an explicit type annotation, - -- which matches the one from the environment. - | Just tEnv <- mtEnv - , equivT tBound tEnv - = return tEnv - - -- The bound has an explicit type annotation, - -- which does not match the one from the environment. - -- This shouldn't happen because the parser doesn't add non-bot - -- annotations to bound variables. - | Just tEnv <- mtEnv - = throw $ ErrorVarAnnotMismatch u tEnv - - -- Variable not in environment, so use annotation. - -- This happens when checking open terms. - | otherwise - = return tBound - - tResult <- mkResult - return tResult - +checkWitnessM !_config !_kenv !tenv (WVar u) + = case Env.lookup u tenv of + Nothing -> throw $ ErrorUndefinedVar u UniverseWitness + Just t -> return t -checkWitnessM _defs _kenv _tenv (WCon wc) +checkWitnessM !_config !_kenv !_tenv (WCon wc) = return $ typeOfWiCon wc - --- value-type application -checkWitnessM defs kenv tenv ww@(WApp w1 (WType t2)) - = do t1 <- checkWitnessM defs kenv tenv w1 - k2 <- checkTypeM defs kenv t2 +-- witness-type application +checkWitnessM !config !kenv !tenv ww@(WApp w1 (WType t2)) + = do t1 <- checkWitnessM config kenv tenv w1 + k2 <- checkTypeM config kenv t2 case t1 of TForall b11 t12 | typeOfBind b11 == k2 @@ -144,9 +151,9 @@ _ -> throw $ ErrorWAppNotCtor ww t1 t2 -- witness-witness application -checkWitnessM defs kenv tenv ww@(WApp w1 w2) - = do t1 <- checkWitnessM defs kenv tenv w1 - t2 <- checkWitnessM defs kenv tenv w2 +checkWitnessM !config !kenv !tenv ww@(WApp w1 w2) + = do t1 <- checkWitnessM config kenv tenv w1 + t2 <- checkWitnessM config kenv tenv w2 case t1 of TApp (TApp (TCon (TyConWitness TwConImpl)) t11) t12 | t11 == t2 @@ -156,9 +163,9 @@ _ -> throw $ ErrorWAppNotCtor ww t1 t2 -- witness joining -checkWitnessM defs kenv tenv ww@(WJoin w1 w2) - = do t1 <- checkWitnessM defs kenv tenv w1 - t2 <- checkWitnessM defs kenv tenv w2 +checkWitnessM !config !kenv !tenv ww@(WJoin w1 w2) + = do t1 <- checkWitnessM config kenv tenv w1 + t2 <- checkWitnessM config kenv tenv w2 case (t1, t2) of ( TApp (TCon (TyConWitness TwConPure)) eff1 , TApp (TCon (TyConWitness TwConPure)) eff2) @@ -173,8 +180,8 @@ _ -> throw $ ErrorCannotJoin ww w1 t1 w2 t2 -- embedded types -checkWitnessM defs kenv _tenv (WType t) - = checkTypeM defs kenv t +checkWitnessM !config !kenv !_tenv (WType t) + = checkTypeM config kenv t -- | Take the type of a witness constructor. @@ -182,7 +189,7 @@ typeOfWiCon wc = case wc of WiConBuiltin wb -> typeOfWbCon wb - WiConBound u -> typeOfBound u + WiConBound _ t -> t -- | Take the type of a builtin witness constructor. @@ -199,14 +206,14 @@ -- checkType ------------------------------------------------------------------ -- | Check a type in the exp checking monad. checkTypeM - :: (Ord n, Pretty n) - => DataDefs n - -> Env n + :: (Ord n, Show n, Pretty n) + => Config n + -> KindEnv n -> Type n -> CheckM a n (Kind n) -checkTypeM defs kenv tt - = case T.checkType defs kenv tt of +checkTypeM config kenv tt + = case T.checkType (configPrimDataDefs config) kenv tt of Left err -> throw $ ErrorType err Right k -> return k 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 @@ -3,47 +3,65 @@ (Error(..)) where import DDC.Core.Exp +import DDC.Type.Universe import qualified DDC.Type.Check as T -- | All the things that can go wrong when type checking an expression -- or witness. data Error a n + -- Type ------------------------------------------- -- | Found a kind error when checking a type. = ErrorType { errorTypeError :: T.Error n } - -- | Found a malformed expression, - -- and we don't have a more specific diagnosis. - | ErrorMalformedExp - { errorChecking :: Exp a n } - -- | Found a malformed type, -- and we don't have a more specific diagnosis. | ErrorMalformedType { errorChecking :: Exp a n , errorType :: Type n } - -- | Found a naked `XType` that wasn't the argument of an application. - | ErrorNakedType - { errorChecking :: Exp a n } - -- | Found a naked `XWitness` that wasn't the argument of an application. - | ErrorNakedWitness + -- Module ----------------------------------------- + -- | Exported value is undefined. + | ErrorExportUndefined + { errorName :: n } + + -- | Type signature of exported binding does not match the type at + -- the definition site. + | ErrorExportMismatch + { errorName :: n + , errorExportType :: Type n + , errorDefType :: Type n } + + + -- Exp -------------------------------------------- + -- | Found a malformed expression, + -- and we don't have a more specific diagnosis. + | ErrorMalformedExp { errorChecking :: Exp a n } + -- Var -------------------------------------------- - -- | A bound occurrence of a variable who's type annotation does not match + -- | An undefined type variable. + | ErrorUndefinedVar + { errorBound :: Bound n + , errorUniverse :: Universe } + + -- | A bound occurrence of a variable whose type annotation does not match -- the corresponding annotation in the environment. | ErrorVarAnnotMismatch { errorBound :: Bound n + , errorTypeAnnot :: Type n , errorTypeEnv :: Type n } + -- Con -------------------------------------------- -- | A data constructor that wasn't in the set of data definitions. | ErrorUndefinedCtor { errorChecking :: Exp a n } + -- Application ------------------------------------ -- | A function application where the parameter and argument don't match. | ErrorAppMismatch @@ -68,6 +86,7 @@ -- | A type or witness abstraction where the body has a visible side effect. | ErrorLamNotPure { errorChecking :: Exp a n + , errorSpecOrWit :: Bool , errorEffect :: Effect n } -- | A value function where the parameter does not have data kind. @@ -140,26 +159,32 @@ { errorChecking :: Exp a n , errorExp :: Exp a n } + -- | A recursive let-expression that has more than one binding + -- with the same name. + | ErrorLetrecRebound + { errorChecking :: Exp a n + , errorBind :: Bind n } + -- Letregion -------------------------------------- - -- | A letregion-expression where the bound variable does not have - -- region kind. - | ErrorLetRegionNotRegion + -- | A letregion-expression where the some of the bound variables do not + -- have region kind. + | ErrorLetRegionsNotRegion { errorChecking :: Exp a n - , errorBind :: Bind n - , errorKind :: Kind n } + , errorBinds :: [Bind n] + , errorKinds :: [Kind n] } - -- | A letregion-expression that tried to shadow a pre-existing named - -- region variable. - | ErrorLetRegionRebound + -- | A letregion-expression that tried to shadow some pre-existing named + -- region variables. + | ErrorLetRegionsRebound { errorChecking :: Exp a n - , errorBind :: Bind n } + , errorBinds :: [Bind n] } - -- | A letregion-expression where the bound region variable is free in - -- the type of the body. + -- | A letregion-expression where some of the the bound region variables + -- are free in the type of the body. | ErrorLetRegionFree { errorChecking :: Exp a n - , errorBind :: Bind n + , errorBinds :: [Bind n] , errorType :: Type n } -- | A letregion-expression that tried to create a witness with an @@ -176,18 +201,33 @@ -- | A letregion-expression where a bound witnesses was not for the -- the region variable being introduced. - | ErrorLetRegionWitnessOther + | ErrorLetRegionsWitnessOther { errorChecking :: Exp a n - , errorBoundRegion :: Bound n + , errorBoundRegions :: [Bound n] , errorBindWitness :: Bind n } + -- | A letregion-expression where the witness binding references some + -- free region variable that is not the one being introduced. + | ErrorLetRegionWitnessFree + { errorChecking :: Exp a n + , errorBindWitness :: Bind n } + + + -- Withregion ------------------------------------- -- | A withregion-expression where the handle does not have region kind. | ErrorWithRegionNotRegion { errorChecking :: Exp a n , errorBound :: Bound n , errorKind :: Kind n } + -- | A letregion-expression where some of the the bound region variables + -- are free in the type of the body. + | ErrorWithRegionFree + { errorChecking :: Exp a n + , errorBound :: Bound n + , errorType :: Type n } + -- Witnesses -------------------------------------- -- | A witness application where the argument type does not match -- the parameter type. @@ -224,16 +264,16 @@ -- Case Expressions ------------------------------- - -- | A case-expression where the discriminant type is not algebraic. - | ErrorCaseDiscrimNotAlgebraic + -- | A case-expression where the scrutinee type is not algebraic. + | ErrorCaseScrutineeNotAlgebraic { errorChecking :: Exp a n - , errorTypeDiscrim :: Type n } + , errorTypeScrutinee :: Type n } - -- | A case-expression where the discriminant type is not in our set + -- | A case-expression where the scrutinee type is not in our set -- of data type declarations. - | ErrorCaseDiscrimTypeUndeclared + | ErrorCaseScrutineeTypeUndeclared { errorChecking :: Exp a n - , errorTypeDiscrim :: Type n } + , errorTypeScrutinee :: Type n } -- | A case-expression with no alternatives. | ErrorCaseNoAlternatives @@ -258,22 +298,22 @@ -- | A case-expression where one of the patterns has too many binders. | ErrorCaseTooManyBinders { errorChecking :: Exp a n - , errorCtorBound :: Bound n + , errorCtorDaCon :: DaCon n , errorCtorFields :: Int , errorPatternFields :: Int } -- | A case-expression where the pattern types could not be instantiated - -- with the arguments of the discriminant type. + -- with the arguments of the scrutinee type. | ErrorCaseCannotInstantiate { errorChecking :: Exp a n - , errorTypeCtor :: Type n - , errorTypeDiscrim :: Type n } + , errorTypeScrutinee :: Type n + , errorTypeCtor :: Type n } - -- | A case-expression where the type of the discriminant does not match + -- | A case-expression where the type of the scrutinee does not match -- the type of the pattern. - | ErrorCaseDiscrimTypeMismatch + | ErrorCaseScrutineeTypeMismatch { errorChecking :: Exp a n - , errorTypeDiscrim :: Type n + , errorTypeScrutinee :: Type n , errorTypePattern :: Type n } -- | A case-expression where the annotation on a pattern variable binder @@ -292,22 +332,22 @@ -- Casts ------------------------------------------ - -- | A maxeff-cast where the type provided does not have effect kind. - | ErrorMaxeffNotEff + -- | A weakeff-cast where the type provided does not have effect kind. + | ErrorWeakEffNotEff { errorChecking :: Exp a n , errorEffect :: Effect n , errorKind :: Kind n } - -- | A maxclo-cast where the type provided does not have closure kind. - | ErrorMaxcloNotClo - { errorChecking :: Exp a n - , errorClosure :: Closure n - , errorKind :: Kind n } - -- | A maxclo-case where the closure provided is malformed. - -- It can only contain `Use` terms. - | ErrorMaxcloMalformed - { errorChecking :: Exp a n - , errorClosure :: Closure n } + -- Types ------------------------------------------ + -- | Found a naked `XType` that wasn't the argument of an application. + | ErrorNakedType + { errorChecking :: Exp a n } + + + -- Witnesses -------------------------------------- + -- | Found a naked `XWitness` that wasn't the argument of an application. + | ErrorNakedWitness + { errorChecking :: Exp a n } deriving (Show) diff --git a/DDC/Core/Check/ErrorMessage.hs b/DDC/Core/Check/ErrorMessage.hs --- a/DDC/Core/Check/ErrorMessage.hs +++ b/DDC/Core/Check/ErrorMessage.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} -- | Errors produced when checking core expressions. module DDC.Core.Check.ErrorMessage (Error(..)) @@ -6,9 +5,11 @@ import DDC.Core.Pretty import DDC.Core.Check.Error import DDC.Type.Compounds +import DDC.Type.Universe -instance (Pretty n, Eq n) => Pretty (Error a n) where +instance (Show n, Eq n, Pretty n) + => Pretty (Error a n) where ppr err = case err of ErrorType err' -> ppr err' @@ -21,22 +22,38 @@ , empty , text "with: " <> align (ppr xx) ] - ErrorNakedType xx - -> vcat [ text "Found naked type in core program." - , empty - , text "with: " <> align (ppr xx) ] + -- Modules --------------------------------------- + ErrorExportUndefined n + -> vcat [ text "Exported value '" <> ppr n <> text "' is undefined." ] - ErrorNakedWitness xx - -> vcat [ text "Found naked witness in core program." - , empty - , text "with: " <> align (ppr xx) ] + ErrorExportMismatch n tExport tDef + -> vcat [ text "Type of exported value does not match type of definition." + , text " with binding: " <> ppr n + , text " type of export: " <> ppr tExport + , text " type of definition: " <> ppr tDef ] + -- Variable --------------------------------------- - ErrorVarAnnotMismatch u t + ErrorUndefinedVar u universe + -> case universe of + UniverseSpec + -> vcat [ text "Undefined spec variable: " <> ppr u ] + + UniverseData + -> vcat [ text "Undefined value variable: " <> ppr u ] + + UniverseWitness + -> vcat [ text "Undefined witness variable: " <> ppr u ] + + -- Universes other than the above don't have variables, + -- but let's not worry about that here. + _ -> vcat [ text "Undefined variable: " <> ppr u ] + + ErrorVarAnnotMismatch u tEnv tAnnot -> vcat [ text "Type mismatch in annotation." , text " Variable: " <> ppr u - , text " has annotation: " <> (ppr $ typeOfBound u) - , text " which conflicts with: " <> ppr t + , text " has annotation: " <> ppr tAnnot + , text " which conflicts with: " <> ppr tEnv , text " from environment." ] @@ -68,11 +85,14 @@ , text " is already in the environment." , text "with: " <> align (ppr xx) ] - ErrorLamNotPure xx eff - -> vcat [ text "Impure type abstraction" - , text " has effect: " <> ppr eff - , empty - , text "with: " <> align (ppr xx) ] + ErrorLamNotPure xx spec eff + -> let universe' = if spec then text "spec" + else text "witness" + in vcat + [ text "Impure" <+> universe' <+> text "abstraction" + , text " has effect: " <> ppr eff + , empty + , text "with: " <> align (ppr xx) ] ErrorLamBindNotData xx t1 k1 @@ -158,29 +178,33 @@ , empty , text "with: " <> align (ppr xx) ] + ErrorLetrecRebound xx b + -> vcat [ text "Redefined binder '" <> ppr b <> text "' in letrec." + , empty + , text "with: " <> align (ppr xx) ] -- Letregion -------------------------------------- - ErrorLetRegionNotRegion xx b k - -> vcat [ text "Letregion binder does not have region kind." - , text " Region binder: " <> ppr b - , text " has kind: " <> ppr k - , text " but is must be: %" + ErrorLetRegionsNotRegion xx bs ks + -> vcat [ text "Letregion binders do not have region kind." + , text " Region binders: " <> (hcat $ map ppr bs) + , text " has kinds: " <> (hcat $ map ppr ks) + , text " but they must all be: %" , empty - , text "with: " <> align (ppr xx) ] + , text "with: " <> align (ppr xx) ] - ErrorLetRegionRebound xx b - -> vcat [ text "Region variable shadows existing one." - , text " Region variable: " <> ppr b - , text " is already in environment" + ErrorLetRegionsRebound xx bs + -> vcat [ text "Region variables shadow existing ones." + , text " Region variables: " <> (hcat $ map ppr bs) + , text " are already in environment" , empty - , text "with: " <> align (ppr xx) ] + , text "with: " <> align (ppr xx) ] - ErrorLetRegionFree xx b t - -> vcat [ text "Region variable escapes scope of letregion." - , text " The region variable: " <> ppr b - , text " is free in the body type: " <> ppr t + ErrorLetRegionFree xx bs t + -> vcat [ text "Region variables escape scope of letregion." + , text " The region variables: " <> (hcat $ map ppr bs) + , text " is free in the body type: " <> ppr t , empty - , text "with: " <> align (ppr xx) ] + , text "with: " <> align (ppr xx) ] ErrorLetRegionWitnessInvalid xx b -> vcat [ text "Invalid witness type with letregion." @@ -196,12 +220,27 @@ , empty , text "with: " <> align (ppr xx) ] - ErrorLetRegionWitnessOther xx b1 b2 - -> vcat [ text "Witness type is not for bound region." - , text " letregion binds: " <> ppr b1 + ErrorLetRegionsWitnessOther xx bs1 b2 + -> vcat [ text "Witness type is not for bound regions." + , text " letregion binds: " <> (hsep $ map ppr bs1) , text " but witness type is: " <> ppr b2 , empty , text "with: " <> align (ppr xx) ] + + ErrorLetRegionWitnessFree xx b + -> vcat [ text "Witness type references a free region variable." + , text " the binding: " <> ppr b + , text " contains free region variables." + , empty + , text "with: " <> align (ppr xx) ] + + -- Withregion ------------------------------------- + ErrorWithRegionFree xx u t + -> vcat [ text "Region handle escapes scope of withregion." + , text " The region handle: " <> ppr u + , text " is used in the body type: " <> ppr t + , empty + , text "with: " <> align (ppr xx) ] ErrorWithRegionNotRegion xx u k -> vcat [ text "Withregion handle does not have region kind." @@ -251,15 +290,15 @@ -- Case Expressions ------------------------------- - ErrorCaseDiscrimNotAlgebraic xx tDiscrim - -> vcat [ text "Discriminant of case expression is not algebraic data." - , text " Discriminant type: " <> ppr tDiscrim + ErrorCaseScrutineeNotAlgebraic xx tScrutinee + -> vcat [ text "Scrutinee of case expression is not algebraic data." + , text " Scrutinee type: " <> ppr tScrutinee , empty , text "with: " <> align (ppr xx) ] - ErrorCaseDiscrimTypeUndeclared xx tDiscrim - -> vcat [ text "Type of discriminant does not have a data declaration." - , text " Discriminant type: " <> ppr tDiscrim + ErrorCaseScrutineeTypeUndeclared xx tScrutinee + -> vcat [ text "Type of scrutinee does not have a data declaration." + , text " Scrutinee type: " <> ppr tScrutinee , empty , text "with: " <> align (ppr xx) ] @@ -295,18 +334,18 @@ , empty , text "with: " <> align (ppr xx) ] - ErrorCaseCannotInstantiate xx tCtor tDiscrim - -> vcat [ text "Cannot instantiate constructor type with discriminant type args." + ErrorCaseCannotInstantiate xx tScrutinee tCtor + -> vcat [ text "Cannot instantiate constructor type with scrutinee type args." , text " Either the constructor has an invalid type," - , text " or the type of the discriminant does not match the type of the pattern." + , 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 - , text " Discriminant type: " <> ppr tDiscrim , empty , text "with: " <> align (ppr xx) ] - ErrorCaseDiscrimTypeMismatch xx tDiscrim tPattern - -> vcat [ text "Discriminant type does not match result of pattern type." - , text " Discriminant type: " <> ppr tDiscrim + ErrorCaseScrutineeTypeMismatch xx tScrutinee tPattern + -> vcat [ text "Scrutinee type does not match result of pattern type." + , text " Scrutinee type: " <> ppr tScrutinee , text " Pattern type: " <> ppr tPattern , empty , text "with: " <> align (ppr xx) ] @@ -327,24 +366,23 @@ -- Casts ------------------------------------------ - ErrorMaxeffNotEff xx eff k - -> vcat [ text "Type provided for a 'maxeff' does not have effect kind." + ErrorWeakEffNotEff xx eff k + -> vcat [ text "Type provided for a 'weakeff' does not have effect kind." , text " Type: " <> ppr eff , text " has kind: " <> ppr k , empty , text "with: " <> align (ppr xx) ] - - ErrorMaxcloNotClo xx clo k - -> vcat [ text "Type provided for a 'maxclo' does not have closure kind." - , text " Type: " <> ppr clo - , text " has kind: " <> ppr k + + -- Type ------------------------------------------- + ErrorNakedType xx + -> vcat [ text "Found naked type in core program." , empty , text "with: " <> align (ppr xx) ] - ErrorMaxcloMalformed xx clo - -> vcat [ text "Type provided for a 'maxclo' is malformed." - , text " Closure: " <> ppr clo - , text " can only contain 'Use' terms." + -- Witness ---------------------------------------- + ErrorNakedWitness xx + -> vcat [ text "Found naked witness in core program." , empty , text "with: " <> align (ppr xx) ] - + + diff --git a/DDC/Core/Check/TaggedClosure.hs b/DDC/Core/Check/TaggedClosure.hs --- a/DDC/Core/Check/TaggedClosure.hs +++ b/DDC/Core/Check/TaggedClosure.hs @@ -11,7 +11,7 @@ , cutTaggedClosureXs , cutTaggedClosureT) where -import DDC.Type.Transform.LowerT +import DDC.Type.Transform.LiftT import DDC.Type.Transform.Trim import DDC.Type.Compounds import DDC.Type.Predicates @@ -20,6 +20,8 @@ import Control.Monad import Data.Maybe import Data.Set (Set) +import DDC.Type.Env (Env) +import qualified DDC.Type.Env as Env import qualified DDC.Type.Sum as Sum import qualified Data.Set as Set @@ -62,9 +64,9 @@ GBoundRgnCon u -> text "CLORGNCON" <+> ppr u -instance LowerT TaggedClosure where - lowerAtDepthT n d cc - = let down = lowerAtDepthT n d +instance Ord n => MapBoundT TaggedClosure n where + mapBoundAtDepthT f d cc + = let down = mapBoundAtDepthT f d in case cc of GBoundVal u ts -> GBoundVal (down u) (down ts) GBoundRgnVar u1 -> GBoundRgnVar (down u1) @@ -77,7 +79,7 @@ = case gg of GBoundVal _ clos -> TSum $ clos GBoundRgnVar u -> tUse (TVar u) - GBoundRgnCon u -> tUse (TCon (TyConBound u)) + GBoundRgnCon u -> tUse (TCon (TyConBound u kRegion)) -- | Convert a set of tagged closures to a regular closure by dropping the @@ -92,31 +94,35 @@ -- | Yield the tagged closure of a value variable. taggedClosureOfValBound :: (Ord n, Pretty n) - => Bound n -> TaggedClosure n + => Type n -> Bound n -> TaggedClosure n -taggedClosureOfValBound u +taggedClosureOfValBound t u = GBoundVal u $ Sum.singleton kClosure - $ (let clo = tDeepUse $ typeOfBound u + $ (let clo = tDeepUse t in fromMaybe clo (trimClosure clo)) --- | Yield the tagged closure of a type argument. +-- | Yield the tagged closure of a type argument, +-- or `Nothing` for out-of-scope type vars. taggedClosureOfTyArg :: (Ord n, Pretty n) - => Type n -> Set (TaggedClosure n) + => Env n -> Type n -> Maybe (Set (TaggedClosure n)) -taggedClosureOfTyArg tt +taggedClosureOfTyArg kenv tt = case tt of TVar u - | isRegionKind (typeOfBound u) - -> Set.singleton $ GBoundRgnVar u - - TCon (TyConBound u) - | isRegionKind (typeOfBound u) - -> Set.singleton $ GBoundRgnCon u + -> case Env.lookup u kenv of + Nothing -> Nothing + Just k + | isRegionKind k -> Just $ Set.singleton $ GBoundRgnVar u + | otherwise -> Just Set.empty + + TCon (TyConBound u k) + | isRegionKind k + -> Just $ Set.singleton $ GBoundRgnCon u - _ -> Set.empty + _ -> Just $ Set.empty -- | Convert the closure provided as a 'weakclo' to tagged form. @@ -136,8 +142,8 @@ Just (TyConSpec TcConUse, [TVar u]) -> Just $ GBoundRgnVar u - Just (TyConSpec TcConUse, [TCon (TyConBound u)]) - -> Just $ GBoundRgnVar u + Just (TyConSpec TcConUse, [TCon (TyConBound u _)]) + -> Just $ GBoundRgnCon u _ -> Nothing @@ -163,7 +169,7 @@ | otherwise -> Just gg GBoundRgnCon u - | Sum.elem (tUse (TCon (TyConBound u))) ts1 + | Sum.elem (tUse (TCon (TyConBound u kRegion))) ts1 -> Nothing | otherwise -> Just gg diff --git a/DDC/Core/Collect.hs b/DDC/Core/Collect.hs --- a/DDC/Core/Collect.hs +++ b/DDC/Core/Collect.hs @@ -1,253 +1,18 @@ -- | Collecting sets of variables and constructors. module DDC.Core.Collect - ( freeT + ( -- * Free Variables + freeT , freeX - , collectBound - , collectSpecBinds) -where -import DDC.Type.Compounds -import DDC.Core.Exp -import DDC.Type.Env (Env) -import qualified DDC.Type.Env as Env -import qualified DDC.Type.Sum as Sum -import qualified Data.Set as Set -import Data.Set (Set) - --- freeT ---------------------------------------------------------------------- --- | Collect the free Spec variables in a thing (level-1). -freeT :: (BindStruct c, Ord n) - => Env n -> c n -> Set (Bound n) -freeT tenv xx = Set.unions $ map (freeOfTreeT tenv) $ slurpBindTree xx - -freeOfTreeT :: Ord n => Env n -> BindTree n -> Set (Bound n) -freeOfTreeT kenv tt - = case tt of - BindDef way bs ts - | BoundSpec <- boundLevelOfBindWay way - , kenv' <- Env.extends bs kenv - -> Set.unions $ map (freeOfTreeT kenv') ts - - BindDef _ _ ts - -> Set.unions $ map (freeOfTreeT kenv) ts - - BindUse BoundSpec u - | Env.member u kenv -> Set.empty - | otherwise -> Set.singleton u - _ -> Set.empty - - --- freeX ---------------------------------------------------------------------- --- | Collect the free Data and Witness variables in a thing (level-0). -freeX :: (BindStruct c, Ord n) - => Env n -> c n -> Set (Bound n) -freeX tenv xx = Set.unions $ map (freeOfTreeX tenv) $ slurpBindTree xx - -freeOfTreeX :: Ord n => Env n -> BindTree n -> Set (Bound n) -freeOfTreeX tenv tt - = case tt of - BindDef way bs ts - | BoundExpWit <- boundLevelOfBindWay way - , tenv' <- Env.extends bs tenv - -> Set.unions $ map (freeOfTreeX tenv') ts - - BindDef _ _ ts - -> Set.unions $ map (freeOfTreeX tenv) ts - - BindUse BoundExpWit u - | Env.member u tenv -> Set.empty - | otherwise -> Set.singleton u - _ -> Set.empty - - --- collectBound --------------------------------------------------------------- --- | Collect all the bound variables in a thing, --- independent of whether they are free or not. -collectBound :: (BindStruct c, Ord n) => c n -> Set (Bound n) -collectBound - = Set.unions . map collectBoundOfTree . slurpBindTree - -collectBoundOfTree :: Ord n => BindTree n -> Set (Bound n) -collectBoundOfTree tt - = case tt of - BindDef _ _ ts -> Set.unions $ map collectBoundOfTree ts - BindUse _ u -> Set.singleton u - BindCon _ u -> Set.singleton u - - --- collectSpecBinds ----------------------------------------------------------- --- | Collect all the Spec binders in a thing. -collectSpecBinds :: (BindStruct c, Ord n) => c n -> [Bind n] -collectSpecBinds - = concatMap collectSpecBindsOfTree . slurpBindTree - - -collectSpecBindsOfTree :: Ord n => BindTree n -> [Bind n] -collectSpecBindsOfTree tt - = case tt of - BindDef way bs ts - | BoundSpec <- boundLevelOfBindWay way - -> concat ( bs - : map collectSpecBindsOfTree ts) - - | otherwise - -> concatMap collectSpecBindsOfTree ts - - _ -> [] - - -------------------------------------------------------------------------------- --- | A description of the binding structure of some type or expression. -data BindTree n - -- | An abstract binding expression. - = BindDef BindWay [Bind n] [BindTree n] - - -- | Use of a variable. - | BindUse BoundLevel (Bound n) - - -- | Use of a constructor. - | BindCon BoundLevel (Bound n) - deriving (Eq, Show) - - --- | Describes how a variable was bound. -data BindWay - = BindForall - | BindLAM - | BindLam - | BindLet - | BindLetRec - | BindLetRegion - | BindLetRegionWith - | BindCasePat - deriving (Eq, Show) - - --- | What level this binder is at. -data BoundLevel - = BoundSpec - | BoundExpWit - deriving (Eq, Show) - - --- | Get the `BoundLevel` corresponding to a `BindWay`. -boundLevelOfBindWay :: BindWay -> BoundLevel -boundLevelOfBindWay way - = case way of - BindForall -> BoundSpec - BindLAM -> BoundSpec - BindLam -> BoundExpWit - BindLet -> BoundExpWit - BindLetRec -> BoundExpWit - BindLetRegion -> BoundSpec - BindLetRegionWith -> BoundExpWit - BindCasePat -> BoundExpWit - - --- BindStruct ----------------------------------------------------------------- -class BindStruct (c :: * -> *) where - slurpBindTree :: c n -> [BindTree n] - - -instance BindStruct Type where - slurpBindTree tt - = case tt of - TVar u -> [BindUse BoundSpec u] - TCon tc -> slurpBindTree tc - TForall b t -> [bindDefT BindForall [b] [t]] - TApp t1 t2 -> slurpBindTree t1 ++ slurpBindTree t2 - TSum ts -> concatMap slurpBindTree $ Sum.toList ts - - -instance BindStruct TyCon where - slurpBindTree tc - = case tc of - TyConBound u -> [BindCon BoundSpec u] - _ -> [] - - -instance BindStruct (Exp a) where - slurpBindTree xx - = case xx of - XVar _ u -> [BindUse BoundExpWit u] - XCon _ u -> [BindCon BoundExpWit u] - XApp _ x1 x2 -> slurpBindTree x1 ++ slurpBindTree x2 - XLAM _ b x -> [bindDefT BindLAM [b] [x]] - XLam _ b x -> [bindDefX BindLam [b] [x]] - - XLet _ (LLet m b x1) x2 - -> slurpBindTree m - ++ slurpBindTree x1 - ++ [bindDefX BindLet [b] [x2]] - - XLet _ (LRec bxs) x2 - -> [bindDefX BindLetRec - (map fst bxs) - (map snd bxs ++ [x2])] - - XLet _ (LLetRegion b bs) x2 - -> [ BindDef BindLetRegion [b] - [bindDefX BindLetRegionWith bs [x2]]] - - XLet _ (LWithRegion u) x2 - -> BindUse BoundExpWit u : slurpBindTree x2 - - XCase _ x alts -> slurpBindTree x ++ concatMap slurpBindTree alts - XCast _ c x -> slurpBindTree c ++ slurpBindTree x - XType t -> slurpBindTree t - XWitness w -> slurpBindTree w - - -instance BindStruct LetMode where - slurpBindTree mm - = case mm of - LetLazy (Just w) -> slurpBindTree w - _ -> [] - - -instance BindStruct Cast where - slurpBindTree cc - = case cc of - CastWeakenEffect eff -> slurpBindTree eff - CastWeakenClosure clo -> slurpBindTree clo - CastPurify w -> slurpBindTree w - CastForget w -> slurpBindTree w - - -instance BindStruct (Alt a) where - slurpBindTree alt - = case alt of - AAlt PDefault x - -> slurpBindTree x - - AAlt (PData _ bs) x - -> [bindDefX BindCasePat bs [x]] - - -instance BindStruct Witness where - slurpBindTree ww - = case ww of - WVar u -> [BindUse BoundExpWit u] - WCon{} -> [] - WApp w1 w2 -> slurpBindTree w1 ++ slurpBindTree w2 - WJoin w1 w2 -> slurpBindTree w1 ++ slurpBindTree w2 - WType t -> slurpBindTree t - - --- | Helper for constructing the `BindTree` for an expression or witness binder. -bindDefX :: BindStruct c - => BindWay -> [Bind n] -> [c n] -> BindTree n -bindDefX way bs xs - = BindDef way bs - $ concatMap (slurpBindTree . typeOfBind) bs - ++ concatMap slurpBindTree xs - - --- | Helper for constructing the `BindTree` for a type binder. -bindDefT :: BindStruct c - => BindWay -> [Bind n] -> [c n] -> BindTree n -bindDefT way bs xs - = BindDef way bs $ concatMap slurpBindTree xs - + -- * Bounds and Binds + , collectBound + , collectBinds + -- * Support + , Support (..) + , SupportX (..)) +where +import DDC.Core.Collect.Free +import DDC.Core.Collect.Support +import DDC.Type.Collect diff --git a/DDC/Core/Collect/Free.hs b/DDC/Core/Collect/Free.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Collect/Free.hs @@ -0,0 +1,128 @@ +-- | Collecting sets of variables and constructors. +module DDC.Core.Collect.Free + (freeX) +where +import DDC.Type.Collect +import DDC.Type.Compounds +import DDC.Core.Module +import DDC.Core.Exp +import DDC.Type.Env (Env) +import qualified DDC.Type.Env as Env +import qualified Data.Set as Set +import Data.Set (Set) + + +-- freeX ---------------------------------------------------------------------- +-- | Collect the free Data and Witness variables in a thing (level-0). +freeX :: (BindStruct c, Ord n) + => Env n -> c n -> Set (Bound n) +freeX tenv xx = Set.unions $ map (freeOfTreeX tenv) $ slurpBindTree xx + +freeOfTreeX :: Ord n => Env n -> BindTree n -> Set (Bound n) +freeOfTreeX tenv tt + = {-# SCC freeOfTreeX #-} + case tt of + BindDef way bs ts + | isBoundExpWit $ boundLevelOfBindWay way + , tenv' <- Env.extends bs tenv + -> Set.unions $ map (freeOfTreeX tenv') ts + + BindDef _ _ ts + -> Set.unions $ map (freeOfTreeX tenv) ts + + BindUse bl u + | isBoundExpWit bl + , Env.member u tenv -> Set.empty + | isBoundExpWit bl -> Set.singleton u + _ -> Set.empty + + +-- Module --------------------------------------------------------------------- +instance BindStruct (Module a) where + slurpBindTree mm + = slurpBindTree $ moduleBody mm + + +-- Exp ------------------------------------------------------------------------ +instance BindStruct (Exp a) where + slurpBindTree xx + = case xx of + XVar _ u + -> [BindUse BoundExp u] + + XCon _ dc + -> case daConName dc of + DaConUnit -> [] + DaConNamed n -> [BindCon BoundExp (UName n) Nothing] + + XApp _ x1 x2 -> slurpBindTree x1 ++ slurpBindTree x2 + XLAM _ b x -> [bindDefT BindLAM [b] [x]] + XLam _ b x -> [bindDefX BindLam [b] [x]] + + XLet _ (LLet m b x1) x2 + -> slurpBindTree m + ++ slurpBindTree x1 + ++ [bindDefX BindLet [b] [x2]] + + XLet _ (LRec bxs) x2 + -> [bindDefX BindLetRec + (map fst bxs) + (map snd bxs ++ [x2])] + + XLet _ (LLetRegions b bs) x2 + -> [ BindDef BindLetRegions b + [bindDefX BindLetRegionWith bs [x2]]] + + XLet _ (LWithRegion u) x2 + -> BindUse BoundExp u : slurpBindTree x2 + + XCase _ x alts -> slurpBindTree x ++ concatMap slurpBindTree alts + XCast _ c x -> slurpBindTree c ++ slurpBindTree x + XType t -> slurpBindTree t + XWitness w -> slurpBindTree w + + +instance BindStruct LetMode where + slurpBindTree mode + = case mode of + LetStrict -> [] + LetLazy Nothing -> [] + LetLazy (Just ww) -> slurpBindTree ww + + +instance BindStruct (Cast a) where + slurpBindTree cc + = case cc of + CastWeakenEffect eff -> slurpBindTree eff + CastWeakenClosure xs -> concatMap slurpBindTree xs + CastPurify w -> slurpBindTree w + CastForget w -> slurpBindTree w + + +instance BindStruct (Alt a) where + slurpBindTree alt + = case alt of + AAlt PDefault x + -> slurpBindTree x + + AAlt (PData _ bs) x + -> [bindDefX BindCasePat bs [x]] + + +instance BindStruct Witness where + slurpBindTree ww + = case ww of + WVar u -> [BindUse BoundWit u] + WCon{} -> [] + WApp w1 w2 -> slurpBindTree w1 ++ slurpBindTree w2 + WJoin w1 w2 -> slurpBindTree w1 ++ slurpBindTree w2 + WType t -> slurpBindTree t + + +-- | Helper for constructing the `BindTree` for an expression or witness binder. +bindDefX :: BindStruct c + => BindWay -> [Bind n] -> [c n] -> BindTree n +bindDefX way bs xs + = BindDef way bs + $ concatMap (slurpBindTree . typeOfBind) bs + ++ concatMap slurpBindTree xs diff --git a/DDC/Core/Collect/Support.hs b/DDC/Core/Collect/Support.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Collect/Support.hs @@ -0,0 +1,208 @@ + +module DDC.Core.Collect.Support + ( Support (..) + , SupportX (..)) +where +import DDC.Core.Compounds +import DDC.Core.Exp +import DDC.Type.Collect.FreeT +import Data.Set (Set) +import DDC.Type.Env (KindEnv, TypeEnv) +import qualified DDC.Type.Env as Env +import qualified Data.Set as Set +import Data.Monoid + + +data Support n + = Support + { -- | Type constructors used in the expression. + supportTyCon :: Set (Bound n) + + -- | Type constructors used in the argument of a value-type application. + , supportTyConXArg :: Set (Bound n) + + -- | Free spec variables in an expression. + , supportSpVar :: Set (Bound n) + + -- | Type constructors used in the argument of a value-type application. + , supportSpVarXArg :: Set (Bound n) + + -- | Free witness variables in an expression. + -- (from the Witness universe) + , supportWiVar :: Set (Bound n) + + -- | Free value variables in an expression. + -- (from the Data universe) + , supportDaVar :: Set (Bound n) } + deriving Show + + +instance Ord n => Monoid (Support n) where + mempty = Support + { supportTyCon = Set.empty + , supportTyConXArg = Set.empty + , supportSpVar = Set.empty + , supportSpVarXArg = Set.empty + , supportWiVar = Set.empty + , supportDaVar = Set.empty } + + mappend sp1 sp2 + = Support + { supportTyCon = Set.unions [supportTyCon sp1, supportTyCon sp2] + , supportTyConXArg = Set.unions [supportTyConXArg sp1, supportTyConXArg sp2] + , supportSpVar = Set.unions [supportSpVar sp1, supportSpVar sp2] + , supportSpVarXArg = Set.unions [supportSpVarXArg sp1, supportSpVarXArg sp2] + , supportWiVar = Set.unions [supportWiVar sp1, supportWiVar sp2] + , supportDaVar = Set.unions [supportDaVar sp1, supportDaVar sp2] } + + +class SupportX (c :: * -> *) where + support + :: Ord n + => KindEnv n -> TypeEnv n + -> c n + -> Support n + + +instance SupportX Type where + support kenv _tenv t + = let (fvs1, tcs) = freeVarConT kenv t + in mempty { supportTyCon = tcs + , supportSpVar = fvs1 } + + +instance SupportX Bind where + support kenv tenv b + = support kenv tenv + $ typeOfBind b + + +instance SupportX (Exp a) where + support kenv tenv xx + = case xx of + XVar _ u + | Env.member u tenv -> mempty + | otherwise -> mempty { supportDaVar = Set.singleton u} + + XCon{} + -> mempty + + XLAM _ b x + -> support kenv tenv b + <> support (Env.extend b kenv) tenv x + + XLam _ b x + -> support kenv tenv b + <> support kenv (Env.extend b tenv) x + + XApp _ x1 x2 + -> let s1 = support kenv tenv x1 + s2 = support kenv tenv x2 + in mappend s1 s2 + + XLet _a lts x2 + -> let s1 = support kenv tenv lts + (bs1, bs0) = bindsOfLets lts + kenv' = Env.extends bs1 kenv + tenv' = Env.extends bs0 tenv + s2 = support kenv' tenv' x2 + in mappend s1 s2 + + XCase _ x1 alts + -> let s1 = support kenv tenv x1 + ss = mconcat $ map (support kenv tenv) alts + in mappend s1 ss + + XCast _ c1 x2 + -> let s1 = support kenv tenv c1 + s2 = support kenv tenv x2 + in mappend s1 s2 + + XType t + -> let sup = support kenv tenv t + in sup { supportTyConXArg = supportTyCon sup + , supportSpVarXArg = supportSpVar sup } + + XWitness w -> support kenv tenv w + + +instance SupportX (Alt a) where + support kenv tenv aa + = case aa of + AAlt PDefault x + -> support kenv tenv x + + AAlt (PData _dc bs0) x + -> let tenv' = Env.extends bs0 tenv + in support kenv tenv' x + + +instance SupportX Witness where + support kenv tenv ww + = case ww of + WVar u + | Env.member u tenv -> mempty + | otherwise -> mempty { supportWiVar = Set.singleton u } + + WCon{} + -> mempty + + WApp w1 w2 + -> support kenv tenv w1 + <> support kenv tenv w2 + + WJoin w1 w2 + -> support kenv tenv w1 + <> support kenv tenv w2 + + WType t + -> support kenv tenv t + + +instance SupportX (Cast a) where + support kenv tenv cc + = case cc of + CastWeakenEffect eff + -> support kenv tenv eff + + CastWeakenClosure xs + -> mconcat $ map (support kenv tenv) xs + + CastPurify w + -> support kenv tenv w + + CastForget w + -> support kenv tenv w + + +instance SupportX (Lets a) where + support kenv tenv lts + = case lts of + LLet m b x + -> support kenv tenv m + <> support kenv tenv b + <> support kenv (Env.extend b tenv) x + + LRec bxs + -> (mconcat $ map (support kenv tenv) $ map fst bxs) + <> (let tenv' = Env.extends (map fst bxs) tenv + in mconcat $ map (support kenv tenv') $ map snd bxs) + + LLetRegions bs ws + -> (mconcat $ map (support kenv tenv) bs) + <> (let kenv' = Env.extends bs kenv + in mconcat $ map (support kenv' tenv) ws) + + LWithRegion u + | Env.member u kenv -> mempty + | otherwise -> mempty { supportSpVar = Set.singleton u } + + +instance SupportX LetMode where + support kenv tenv mm + = case mm of + LetStrict -> mempty + LetLazy Nothing -> mempty + LetLazy (Just w) -> support kenv tenv w + + diff --git a/DDC/Core/Compounds.hs b/DDC/Core/Compounds.hs --- a/DDC/Core/Compounds.hs +++ b/DDC/Core/Compounds.hs @@ -1,79 +1,93 @@ -- | Utilities for constructing and destructing compound expressions. module DDC.Core.Compounds - ( -- * Lets - bindsOfLets - , specBindsOfLets - , valwitBindsOfLets + ( module DDC.Type.Compounds + , module DDC.Core.DaCon - -- * Patterns - , bindsOfPat + -- * Annotations + , takeAnnotOfExp -- * Lambdas - , makeXLAMs, takeXLAMs - , makeXLams, takeXLams - , takeXLamFlags + , xLAMs + , xLams , makeXLamFlags + , takeXLAMs + , takeXLams + , takeXLamFlags -- * Applications - , makeXApps + , xApps + , makeXAppsWithAnnots , takeXApps + , takeXApps1 + , takeXAppsAsList + , takeXAppsWithAnnots , takeXConApps , takeXPrimApps - -- * Alternatives - , takeCtorNameOfAlt) -where -import DDC.Type.Compounds -import DDC.Core.Exp - + -- * Lets + , xLets + , splitXLets + , bindsOfLets + , specBindsOfLets + , valwitBindsOfLets --- | Take the binds of a `Lets`. -bindsOfLets :: Lets a n -> [Bind n] -bindsOfLets ll - = case ll of - LLet _ b _ -> [b] - LRec bxs -> map fst bxs - LLetRegion b bs -> b : bs - LWithRegion{} -> [] + -- * Patterns + , bindsOfPat + -- * Alternatives + , takeCtorNameOfAlt --- | Like `bindsOfLets` but only take the type binders. -specBindsOfLets :: Lets a n -> [Bind n] -specBindsOfLets ll - = case ll of - LLet _ _ _ -> [] - LRec _ -> [] - LLetRegion b _ -> [b] - LWithRegion{} -> [] + -- * Witnesses + , wApp + , wApps + , takeXWitness + , takeWAppsAsList + , takePrimWiConApps + -- * Types + , takeXType --- | Like `bindsOfLets` but only take the value and witness binders. -valwitBindsOfLets :: Lets a n -> [Bind n] -valwitBindsOfLets ll - = case ll of - LLet _ b _ -> [b] - LRec bxs -> map fst bxs - LLetRegion _ bs -> bs - LWithRegion{} -> [] + -- * Units + , xUnit) +where +import DDC.Type.Compounds +import DDC.Core.Exp +import DDC.Core.DaCon --- | Take the binds of a `Pat`. -bindsOfPat :: Pat n -> [Bind n] -bindsOfPat pp - = case pp of - PDefault -> [] - PData _ bs -> bs +-- Annotations ---------------------------------------------------------------- +-- | Take the outermost annotation from an expression, +-- or Nothing if this is an `XType` or `XWitness` without an annotation. +takeAnnotOfExp :: Exp a n -> Maybe a +takeAnnotOfExp xx + = case xx of + XVar a _ -> Just a + XCon a _ -> Just a + XLAM a _ _ -> Just a + XLam a _ _ -> Just a + XApp a _ _ -> Just a + XLet a _ _ -> Just a + XCase a _ _ -> Just a + XCast a _ _ -> Just a + XType{} -> Nothing + XWitness{} -> Nothing -- Lambdas --------------------------------------------------------------------- --- | Make some nested type lambda abstractions. -makeXLAMs :: a -> [Bind n] -> Exp a n -> Exp a n -makeXLAMs a bs x +-- | Make some nested type lambdas. +xLAMs :: a -> [Bind n] -> Exp a n -> Exp a n +xLAMs a bs x = foldr (XLAM a) x (reverse bs) --- | Split nested value and witness lambdas from the front of an expression, +-- | Make some nested value or witness lambdas. +xLams :: a -> [Bind n] -> Exp a n -> Exp a n +xLams a bs x + = foldr (XLam a) x (reverse 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 @@ -84,12 +98,6 @@ (bs, body) -> Just (bs, body) --- | Make some nested value or witness lambda abstractions. -makeXLams :: a -> [Bind n] -> Exp a n -> Exp a n -makeXLams a bs x - = foldr (XLam a) x (reverse bs) - - -- | Split nested value or witness lambdas from the front of an expression, -- or `Nothing` if there aren't any. takeXLams :: Exp a n -> Maybe ([Bind n], Exp a n) @@ -101,6 +109,17 @@ (bs, body) -> Just (bs, body) +-- | Make some nested lambda abstractions, +-- using a flag to indicate whether the lambda is a +-- level-1 (True), or level-0 (False) binder. +makeXLamFlags :: a -> [(Bool, Bind n)] -> Exp a n -> Exp a n +makeXLamFlags a fbs x + = foldr (\(f, b) x' + -> if f then XLAM a b x' + else XLam a b x') + x fbs + + -- | Split nested lambdas from the front of an expression, -- with a flag indicating whether the lambda was a level-1 (True), -- or level-0 (False) binder. @@ -114,59 +133,200 @@ (bs, body) -> Just (bs, body) --- | Make some nested lambda abstractions, --- using a flag to indicate whether the lambda is a --- level-1 (True), or level-0 (False) binder. -makeXLamFlags :: a -> [(Bool, Bind n)] -> Exp a n -> Exp a n -makeXLamFlags a fbs x - = foldr (\(f, b) x' - -> if f then XLAM a b x' - else XLam a b x') - x fbs +-- Applications --------------------------------------------------------------- +-- | Build sequence of value applications. +xApps :: a -> Exp a n -> [Exp a n] -> Exp a n +xApps a t1 ts = foldl (XApp a) t1 ts --- Applications --------------------------------------------------------------- --- | Build sequence of type applications. -makeXApps :: a -> Exp a n -> [Exp a n] -> Exp a n -makeXApps a t1 ts = foldl (XApp a) t1 ts +-- | Build sequence of applications. +-- Similar to `xApps` but also takes list of annotations for +-- the `XApp` constructors. +makeXAppsWithAnnots :: Exp a n -> [(Exp a n, a)] -> Exp a n +makeXAppsWithAnnots f xas + = case xas of + [] -> f + (arg,a ) : as -> makeXAppsWithAnnots (XApp a f arg) as --- | Flatten an application into the function parts and arguments, if any. -takeXApps :: Exp a n -> [Exp a n] +-- | 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 -> takeXApps x1 ++ [x2] + XApp _ x1 x2 -> takeXAppsAsList x1 ++ [x2] _ -> [xx] +-- | Destruct sequence of applications. +-- Similar to `takeXAppsAsList` but also keeps annotations for later. +takeXAppsWithAnnots :: Exp a n -> (Exp a n, [(Exp a n, a)]) +takeXAppsWithAnnots xx + = case xx of + XApp a f arg + -> let (f', args') = takeXAppsWithAnnots f + in (f', args' ++ [(arg,a)]) + + _ -> (xx, []) + + -- | Flatten an application of a primop into the variable -- and its arguments. -- -- Returns `Nothing` if the expression isn't a primop application. takeXPrimApps :: Exp a n -> Maybe (n, [Exp a n]) takeXPrimApps xx - = case takeXApps xx of - XVar _ (UPrim p _) : xs -> Just (p, xs) - _ -> Nothing + = 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 (Bound n, [Exp a n]) +takeXConApps :: Exp a n -> Maybe (DaCon n, [Exp a n]) takeXConApps xx - = case takeXApps xx of - XCon _ u : xs -> Just (u, xs) + = case takeXAppsAsList xx of + XCon _ dc : xs -> Just (dc, xs) _ -> Nothing +-- Lets ----------------------------------------------------------------------- +-- | Wrap some let-bindings around an expression. +xLets :: a -> [Lets a n] -> Exp a n -> Exp a n +xLets a lts x + = foldr (XLet a) x lts + + +-- | Split let-bindings from the front of an expression, if any. +splitXLets :: Exp a n -> ([Lets a n], Exp a n) +splitXLets xx + = case xx of + XLet _ lts x + -> let (lts', x') = splitXLets x + in (lts : lts', x') + + _ -> ([], xx) + +-- | Take the binds of a `Lets`. +-- +-- The level-1 and level-0 binders are returned separately. +bindsOfLets :: Lets a n -> ([Bind n], [Bind n]) +bindsOfLets ll + = case ll of + LLet _ b _ -> ([], [b]) + LRec bxs -> ([], map fst bxs) + LLetRegions bs bbs -> (bs, bbs) + LWithRegion{} -> ([], []) + + +-- | Like `bindsOfLets` but only take the spec (level-1) binders. +specBindsOfLets :: Lets a n -> [Bind n] +specBindsOfLets ll + = case ll of + LLet _ _ _ -> [] + LRec _ -> [] + LLetRegions bs _ -> bs + LWithRegion{} -> [] + + +-- | Like `bindsOfLets` but only take the value and witness (level-0) binders. +valwitBindsOfLets :: Lets a n -> [Bind n] +valwitBindsOfLets ll + = case ll of + LLet _ b _ -> [b] + LRec bxs -> map fst bxs + LLetRegions _ bs -> bs + LWithRegion{} -> [] + + -- Alternatives --------------------------------------------------------------- -- | Take the constructor name of an alternative, if there is one. takeCtorNameOfAlt :: Alt a n -> Maybe n takeCtorNameOfAlt aa = case aa of - AAlt (PData u _) _ -> takeNameOfBound u + 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 n -> Witness n -> Witness n +wApp = WApp + + +-- | Construct a sequence of witness applications +wApps :: Witness n -> [Witness n] -> Witness n +wApps = foldl wApp + + +-- | Take the witness from an `XWitness` argument, if any. +takeXWitness :: Exp a n -> Maybe (Witness n) +takeXWitness xx + = case xx of + XWitness t -> Just t + _ -> Nothing + + +-- | Flatten an application into the function parts and arguments, if any. +takeWAppsAsList :: Witness n -> [Witness 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 n -> Maybe (n, [Witness n]) +takePrimWiConApps ww + = case takeWAppsAsList ww of + WCon wc : args | WiConBound (UPrim n _) _ <- wc + -> Just (n, args) + _ -> Nothing + + +-- Types ---------------------------------------------------------------------- +-- | Take the type from an `XType` argument, if any. +takeXType :: Exp a n -> Maybe (Type n) +takeXType xx + = case xx of + XType t -> Just t + _ -> Nothing + + +-- Units ----------------------------------------------------------------------- +-- | Construct a value of unit type. +xUnit :: a -> Exp a n +xUnit a = XCon a dcUnit diff --git a/DDC/Core/DaCon.hs b/DDC/Core/DaCon.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/DaCon.hs @@ -0,0 +1,100 @@ + +module DDC.Core.DaCon + ( DaCon (..) + , DaConName (..) + + , dcUnit + , mkDaConAlg + , mkDaConSolid + , takeNameOfDaCon + , typeOfDaCon) +where +import DDC.Type.Compounds +import DDC.Type.Exp +import Control.DeepSeq + + +------------------------------------------------------------------------------- +-- | Data constructor names. +data DaConName n + -- | The unit data constructor is builtin. + = DaConUnit + + -- | Data constructor name defined by the client. + | DaConNamed n + deriving (Eq, Show) + + +instance NFData n => NFData (DaConName n) where + rnf dcn + = case dcn of + DaConUnit -> () + DaConNamed n -> rnf n + + +------------------------------------------------------------------------------- +-- | Data constructors. +data DaCon n + = DaCon + { -- | Name of the data constructor. + daConName :: !(DaConName n) + + -- | Type of the data constructor. + -- The type must be closed. + , daConType :: !(Type n) + + -- | Algebraic constructors can be deconstructed with case-expressions, + -- and must have a data type declaration. + -- + -- Non-algebraic types like 'Float' can't be inspected with + -- case-expressions. + , daConIsAlgebraic :: !Bool } + deriving Show + + +instance NFData n => NFData (DaCon n) where + rnf !dc + = rnf (daConName dc) + `seq` rnf (daConType dc) + `seq` rnf (daConIsAlgebraic dc) + + +-- | Take the name of data constructor. +takeNameOfDaCon :: DaCon n -> Maybe n +takeNameOfDaCon dc + = case daConName dc of + DaConUnit -> Nothing + DaConNamed n -> Just n + + +-- | Take the type annotation of a data constructor. +typeOfDaCon :: DaCon n -> Type n +typeOfDaCon dc = daConType dc + + +-- | The unit data constructor. +dcUnit :: DaCon n +dcUnit = DaCon + { daConName = DaConUnit + , daConType = tUnit + , daConIsAlgebraic = True } + + +-- | Make an algebraic data constructor. +mkDaConAlg :: n -> Type n -> DaCon n +mkDaConAlg n t + = DaCon + { daConName = DaConNamed n + , daConType = t + , daConIsAlgebraic = True } + + +-- | Make a non-algebraic (solid) constructor. +-- These are used for location values in the interpreter, +-- and for floating point literals in the main compiler. +mkDaConSolid :: n -> Type n -> DaCon n +mkDaConSolid n t + = DaCon + { daConName = DaConNamed n + , daConType = t + , daConIsAlgebraic = False } diff --git a/DDC/Core/DataDef.hs b/DDC/Core/DataDef.hs deleted file mode 100644 --- a/DDC/Core/DataDef.hs +++ /dev/null @@ -1,135 +0,0 @@ - --- | Algebraic data type definitions. -module DDC.Core.DataDef - ( DataDef (..) - - -- * Data type definition table - , DataDefs (..) - , DataMode (..) - , DataType (..) - , DataCtor (..) - - , emptyDataDefs - , insertDataDef - , fromListDataDefs - , lookupModeOfDataType) -where -import DDC.Type.Exp -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe -import Control.Monad - - --- | The definition of a single data type. -data DataDef n - = DataDef - { -- | Name of the data type. - dataDefTypeName :: n - - -- | Kinds of type parameters. - , dataDefParamKinds :: [Kind n] - - -- | Constructors of the data type, or Nothing if there are - -- too many to list (like with `Int`). - , dataDefCtors :: Maybe [(n, [Type n])] } - - - --- DataDefs ------------------------------------------------------------------- --- | A table of data type definitions, --- unpacked into type and data constructors so we can find them easily. -data DataDefs n - = DataDefs - { dataDefsTypes :: Map n (DataType n) - , dataDefsCtors :: Map n (DataCtor n) } - - --- | The mode of a data type records how many data constructors there are. --- This can be set to 'Large' for large primitive types like Int and Float. --- In this case we don't ever expect them all to be enumerated --- as case alternatives. -data DataMode n - = DataModeSmall [n] - | DataModeLarge - - --- | Describes a data type constructor, used in the `DataDefs` table. -data DataType n - = DataType - { -- | Name of data type constructor. - dataTypeName :: n - - -- | Kinds of type parameters to constructor. - , dataTypeParamKinds :: [Kind n] - - -- | Names of data constructors of this data type, - -- or `Nothing` if it has infinitely many constructors. - , dataTypeMode :: DataMode n } - - --- | Describes a data constructor, used in the `DataDefs` table. -data DataCtor n - = DataCtor - { -- | Name of data constructor. - dataCtorName :: n - - -- | Field types of constructor. - , dataCtorFieldTypes :: [Type n] - - -- | Name of result type of constructor. - , dataCtorTypeName :: n } - - - --- | An empty table of data type definitions. -emptyDataDefs :: DataDefs n -emptyDataDefs - = DataDefs - { dataDefsTypes = Map.empty - , dataDefsCtors = Map.empty } - - --- | Insert a data type definition into some DataDefs. -insertDataDef :: Ord n => DataDef n -> DataDefs n -> DataDefs n -insertDataDef (DataDef nType ks mCtors) dataDefs - = let defType = DataType - { dataTypeName = nType - , dataTypeParamKinds = ks - , dataTypeMode = defMode } - - defMode = case mCtors of - Nothing -> DataModeLarge - Just ctors -> DataModeSmall (map fst ctors) - - makeDefCtor (nCtor, tsFields) - = DataCtor - { dataCtorName = nCtor - , dataCtorFieldTypes = tsFields - , dataCtorTypeName = nType } - - defCtors = case mCtors of - Nothing -> Nothing - Just cs -> Just $ map makeDefCtor cs - - in dataDefs - { dataDefsTypes = Map.insert nType defType (dataDefsTypes dataDefs) - , dataDefsCtors = Map.union (dataDefsCtors dataDefs) - $ Map.fromList [(n, def) | def@(DataCtor n _ _) - <- concat $ maybeToList defCtors] } - - --- | Build a `DataDefs` table from a list of `DataDef` -fromListDataDefs :: Ord n => [DataDef n] -> DataDefs n -fromListDataDefs defs - = foldr insertDataDef emptyDataDefs defs - - - --- | Yield the list of data constructor names for some data type, --- or `Nothing` for large types with too many constructors to list. -lookupModeOfDataType :: Ord n => n -> DataDefs n -> Maybe (DataMode n) -lookupModeOfDataType n defs - = liftM dataTypeMode $ Map.lookup n (dataDefsTypes defs) - - diff --git a/DDC/Core/Exp.hs b/DDC/Core/Exp.hs --- a/DDC/Core/Exp.hs +++ b/DDC/Core/Exp.hs @@ -5,6 +5,8 @@ -- * Computation expressions , Exp (..) + , DaCon (..) + , DaConName(..) , Cast (..) , Lets (..) , LetMode (..) @@ -16,183 +18,8 @@ , WiCon (..) , WbCon (..)) where +import DDC.Core.Exp.Base +import DDC.Core.Exp.NFData () +import DDC.Core.DaCon import DDC.Type.Exp -import DDC.Type.Sum () - - --- Values --------------------------------------------------------------------- --- | Well-typed expressions live in the Data universe, and their types always --- have kind '*'. --- --- Expressions do something useful at runtime, and might diverge or cause --- side effects. -data Exp a n - -- | Value variable or primitive operation. - = XVar a (Bound n) - - -- | Data constructor or literal. - | XCon a (Bound n) - - -- | Type abstraction (level-1). - | XLAM a (Bind n) (Exp a n) - - -- | Value and Witness abstraction (level-0). - | XLam a (Bind n) (Exp a n) - - -- | Application. - | XApp a (Exp a n) (Exp a n) - - -- | Possibly recursive bindings. - | XLet a (Lets a n) (Exp a n) - - -- | Case branching. - | XCase a (Exp a n) [Alt a n] - - -- | Type cast. - | XCast a (Cast n) (Exp a n) - - -- | Type can appear as the argument of an application. - | XType (Type n) - - -- | Witness can appear as the argument of an application. - | XWitness (Witness n) - deriving (Eq, Show) - - --- | Type casts. -data Cast n - -- | Weaken the effect of an expression. - = CastWeakenEffect (Effect n) - - -- | Weaken the closure of an expression. - | CastWeakenClosure (Closure n) - - -- | Purify the effect of an expression. - | CastPurify (Witness n) - - -- | Hide sharing of the closure of an expression. - | CastForget (Witness n) - deriving (Eq, Show) - - --- | Possibly recursive bindings. -data Lets a n - -- | Non-recursive expression binding. - = LLet (LetMode n) (Bind n) (Exp a n) - - -- | Recursive binding of lambda abstractions. - | LRec [(Bind n, Exp a n)] - - -- | Bind a local region variable, - -- and witnesses to its properties. - | LLetRegion (Bind n) [Bind n] - - -- | Holds a region handle during evaluation. - | LWithRegion (Bound n) - deriving (Eq, Show) - - --- | Describes how a let binding should be evaluated. -data LetMode n - -- | Evaluate binding before substituting the result. - = LetStrict - - -- | Use lazy evaluation. - -- The witness shows that the head region of the bound expression - -- can contain thunks (is lazy), or Nothing if there is no head region. - | LetLazy (Maybe (Witness n)) - deriving (Eq, Show) - - --- | Case alternatives. -data Alt a n - = AAlt (Pat n) (Exp a n) - deriving (Eq, Show) - - --- | Pattern matching. -data Pat n - -- | The default pattern always succeeds. - = PDefault - - -- | Match a data constructor and bind its arguments. - | PData (Bound n) [Bind n] - deriving (Eq, Show) - - --- Witness -------------------------------------------------------------------- --- | When a witness exists in the program it guarantees that a --- certain property of the program is true. -data Witness n - -- | Witness variable. - = WVar (Bound n) - - -- | Witness constructor. - | WCon (WiCon n) - - -- | Witness application. - | WApp (Witness n) (Witness n) - - -- | Joining of witnesses. - | WJoin (Witness n) (Witness n) - - -- | Type can appear as the argument of an application. - | WType (Type n) - deriving (Eq, Show) - - --- | Witness constructors. -data WiCon n - -- | Witness constructors baked into the language. - = WiConBuiltin WbCon - - -- | Witness constructors defined in the environment. - -- In the interpreter we use this to hold runtime capabilities. - | WiConBound (Bound n) - deriving (Eq, Show) - - --- | Built-in witness constructors. --- --- These are used to convert a runtime capability into a witness that --- the corresponding property is true. -data WbCon - -- | (axiom) The pure effect is pure. - -- - -- @pure :: Pure !0@ - = WbConPure - - -- | (axiom) The empty closure is empty. - -- - -- @empty :: Empty $0@ - | WbConEmpty - - -- | Convert a capability guaranteeing that a region is in the global - -- heap into a witness that a closure using this region is empty. - -- This lets us rely on the garbage collector to reclaim objects - -- in the region. It is needed when we suspend the evaluation of - -- expressions that have a region in their closure, because the - -- type of the returned thunk may not reveal that it references - -- objects in that region. - -- - -- @use :: [r: %]. Global r => Empty (Use r)@ - | WbConUse - - -- | Convert a capability guaranteeing the constancy of a region into - -- a witness that a read from that region is pure. - -- This lets us suspend applications that read constant objects, - -- because it doesn't matter if the read is delayed, we'll always - -- get the same result. - -- - -- @read :: [r: %]. Const r => Pure (Read r)@ - | WbConRead - - -- | Convert a capability guaranteeing the constancy of a region into - -- a witness that allocation into that region is pure. - -- This lets us increase the sharing of constant objects, - -- because we can't tell constant objects of the same value apart. - -- - -- @alloc :: [r: %]. Const r => Pure (Alloc r)@ - | WbConAlloc - deriving (Eq, Show) diff --git a/DDC/Core/Exp/Base.hs b/DDC/Core/Exp/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/Base.hs @@ -0,0 +1,186 @@ + +module DDC.Core.Exp.Base where +import DDC.Core.DaCon +import DDC.Type.Exp +import DDC.Type.Sum () + + +-- Values --------------------------------------------------------------------- +-- | Well-typed expressions produce `Data` values when evaluated, +-- and their types aways have kind '*' (Data) +data Exp a n + -- | Value variable or primitive operation. + = XVar !a !(Bound n) + + -- | Data constructor or literal. + | XCon !a !(DaCon n) + + -- | Type abstraction (level-1). + | XLAM !a !(Bind n) !(Exp a n) + + -- | Value and Witness abstraction (level-0). + | XLam !a !(Bind n) !(Exp a n) + + -- | Application. + | XApp !a !(Exp a n) !(Exp a n) + + -- | Possibly recursive bindings. + | XLet !a !(Lets a n) !(Exp a n) + + -- | Case branching. + | XCase !a !(Exp a n) ![Alt a n] + + -- | Type cast. + | XCast !a !(Cast a n) !(Exp a n) + + -- | Type can appear as the argument of an application. + | XType !(Type n) + + -- | Witness can appear as the argument of an application. + | XWitness !(Witness n) + deriving (Eq, Show) + +deriving instance Eq n => Eq (DaCon n) + + +-- | Type casts. +data Cast a n + -- | Weaken the effect of an expression. + -- The given effect is added to the effect + -- of the body. + = CastWeakenEffect !(Effect n) + + -- | Weaken the closure of an expression. + -- The closures of these expressions are added to the closure + -- of the body. + | CastWeakenClosure ![Exp a n] + + -- | Purify the effect (action) of an expression. + | CastPurify !(Witness n) + + -- | Forget about the closure (sharing) of an expression. + | CastForget !(Witness n) + deriving (Eq, Show) + + +-- | Possibly recursive bindings. +data Lets a n + -- | Non-recursive expression binding. + = LLet !(LetMode n) !(Bind n) !(Exp a n) + + -- | Recursive binding of lambda abstractions. + | LRec ![(Bind n, Exp a n)] + + -- | Bind a local region variable, + -- and witnesses to its properties. + | LLetRegions ![Bind n] ![Bind n] + + -- | Holds a region handle during evaluation. + | LWithRegion !(Bound n) + deriving (Eq, Show) + + +-- | Describes how a let binding should be evaluated. +data LetMode n + -- | Evaluate binding before substituting the result. + = LetStrict + + -- | Use lazy evaluation. + -- The witness shows that the head region of the bound expression + -- can contain thunks (is lazy), or Nothing if there is no head region. + | LetLazy !(Maybe (Witness n)) + deriving (Eq, Show) + + +-- | Case alternatives. +data Alt a n + = AAlt !(Pat n) !(Exp a n) + deriving (Eq, Show) + + +-- | Pattern matching. +data Pat n + -- | The default pattern always succeeds. + = PDefault + + -- | Match a data constructor and bind its arguments. + | PData !(DaCon n) ![Bind n] + deriving (Eq, Show) + + +-- Witness -------------------------------------------------------------------- +-- | When a witness exists in the program it guarantees that a +-- certain property of the program is true. +data Witness n + -- | Witness variable. + = WVar !(Bound n) + + -- | Witness constructor. + | WCon !(WiCon n) + + -- | Witness application. + | WApp !(Witness n) !(Witness n) + + -- | Joining of witnesses. + | WJoin !(Witness n) !(Witness n) + + -- | Type can appear as the argument of an application. + | WType !(Type n) + deriving (Eq, Show) + + +-- | Witness constructors. +data WiCon n + -- | Witness constructors baked into the language. + = WiConBuiltin !WbCon + + -- | Witness constructors defined in the environment. + -- In the interpreter we use this to hold runtime capabilities. + -- The attached type must be closed. + | WiConBound !(Bound n) !(Type n) + deriving (Eq, Show) + + +-- | Built-in witness constructors. +-- +-- These are used to convert a runtime capability into a witness that +-- the corresponding property is true. +data WbCon + -- | (axiom) The pure effect is pure. + -- + -- @pure :: Pure !0@ + = WbConPure + + -- | (axiom) The empty closure is empty. + -- + -- @empty :: Empty $0@ + | WbConEmpty + + -- | Convert a capability guaranteeing that a region is in the global + -- heap, into a witness that a closure using this region is empty. + -- This lets us rely on the garbage collector to reclaim objects + -- in the region. It is needed when we suspend the evaluation of + -- expressions that have a region in their closure, because the + -- type of the returned thunk may not reveal that it references + -- objects in that region. + -- + -- @use :: [r : %]. Global r => Empty (Use r)@ + | WbConUse + + -- | Convert a capability guaranteeing the constancy of a region, into + -- a witness that a read from that region is pure. + -- This lets us suspend applications that read constant objects, + -- because it doesn't matter if the read is delayed, we'll always + -- get the same result. + -- + -- @read :: [r : %]. Const r => Pure (Read r)@ + | WbConRead + + -- | Convert a capability guaranteeing the constancy of a region, into + -- a witness that allocation into that region is pure. + -- This lets us increase the sharing of constant objects, + -- because we can't tell constant objects of the same value apart. + -- + -- @alloc :: [r : %]. Const r => Pure (Alloc r)@ + | WbConAlloc + deriving (Eq, Show) diff --git a/DDC/Core/Exp/NFData.hs b/DDC/Core/Exp/NFData.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Exp/NFData.hs @@ -0,0 +1,82 @@ + +module DDC.Core.Exp.NFData where +import DDC.Core.Exp.Base +import Control.DeepSeq + + +instance (NFData a, NFData n) => NFData (Exp a n) where + rnf xx + = case xx of + XVar a u -> rnf a `seq` rnf u + XCon a dc -> rnf a `seq` rnf dc + XLAM a b x -> rnf a `seq` rnf b `seq` rnf x + XLam a b x -> rnf a `seq` rnf b `seq` rnf x + XApp a x1 x2 -> rnf a `seq` rnf x1 `seq` rnf x2 + XLet a lts x -> rnf a `seq` rnf lts `seq` rnf x + XCase a x alts -> rnf a `seq` rnf x `seq` rnf alts + XCast a c x -> rnf a `seq` rnf c `seq` rnf x + XType t -> rnf t + XWitness w -> rnf w + + +instance (NFData a, NFData n) => NFData (Cast a n) where + rnf cc + = case cc of + CastWeakenEffect e -> rnf e + CastWeakenClosure xs -> rnf xs + CastPurify w -> rnf w + CastForget w -> rnf w + + +instance (NFData a, NFData n) => NFData (Lets a n) where + rnf lts + = case lts of + LLet mode b x -> rnf mode `seq` rnf b `seq` rnf x + LRec bxs -> rnf bxs + LLetRegions bs1 bs2 -> rnf bs1 `seq` rnf bs2 + LWithRegion u -> rnf u + + +instance NFData n => NFData (LetMode n) where + rnf mode + = case mode of + LetStrict -> () + LetLazy mw -> rnf mw + + +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 n => NFData (Witness n) where + rnf ww + = case ww of + WVar u -> rnf u + WCon c -> rnf c + WApp w1 w2 -> rnf w1 `seq` rnf w2 + WJoin w1 w2 -> rnf w1 `seq` rnf w2 + WType tt -> rnf tt + + +instance NFData n => NFData (WiCon n) where + rnf wi + = case wi of + WiConBuiltin wb -> rnf wb + WiConBound u t -> rnf u `seq` rnf t + +instance NFData WbCon + + + + + + diff --git a/DDC/Core/Fragment.hs b/DDC/Core/Fragment.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Fragment.hs @@ -0,0 +1,65 @@ + +-- | The ambient Disciple Core language is specialised to concrete languages +-- by adding primitive operations and optionally restricting the set of +-- available language features. This specialisation results in user-facing +-- language fragments such as @Disciple Core Lite@ and @Disciple Core Salt@. +module DDC.Core.Fragment + ( -- * Langauge fragments + Fragment (..) + , Profile (..) + , zeroProfile + + -- * Fragment features + , Feature (..) + , Features (..) + , zeroFeatures + + -- * Compliance + , complies + , compliesWithEnvs + , Complies + , Error (..)) +where +import DDC.Core.Fragment.Feature +import DDC.Core.Fragment.Compliance +import DDC.Core.Fragment.Error +import DDC.Core.Fragment.Profile +import DDC.Core.Module +import DDC.Core.Exp +import DDC.Core.Lexer +import DDC.Data.Token + + +-- Fragment ------------------------------------------------------------------- +-- | Carries all the information we need to work on a particular +-- fragment of the Disciple Core language. +data Fragment n (err :: * -> *) + = Fragment + { -- | Language profile for this fragment. + fragmentProfile :: Profile n + + -- | File extension to use when dumping modules in this fragment. + , fragmentExtension :: String + + -- | Read a name. + , fragmentReadName :: String -> Maybe n + + -- | Lex module source into tokens, + -- given the source name and starting line number. + , fragmentLexModule :: String -> Int -> String -> [Token (Tok n)] + + -- | Lex expression source into tokens, + -- given the source name and starting line number. + , fragmentLexExp :: String -> Int -> String -> [Token (Tok n)] + + -- | Perform language fragment specific checks on a module. + , fragmentCheckModule :: forall a. Module a n -> Maybe (err a) + + -- | Perform language fragment specific checks on an expression. + , fragmentCheckExp :: forall a. Exp a n -> Maybe (err a) } + + +instance Show (Fragment n err) where + show frag + = profileName $ fragmentProfile frag + diff --git a/DDC/Core/Fragment/Compliance.hs b/DDC/Core/Fragment/Compliance.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Fragment/Compliance.hs @@ -0,0 +1,388 @@ + +module DDC.Core.Fragment.Compliance + ( complies + , compliesWithEnvs + , Complies) +where +import DDC.Core.Fragment.Feature +import DDC.Core.Fragment.Profile +import DDC.Core.Fragment.Error +import DDC.Core.Compounds +import DDC.Core.Predicates +import DDC.Core.Module +import DDC.Core.Exp +import Control.Monad +import Data.Maybe +import DDC.Type.Env (Env) +import Data.Set (Set) +import qualified DDC.Type.Env as Env +import qualified Data.Set as Set +import qualified Data.Map.Strict as Map + + +-- | Check whether a core thing complies with a language fragment profile. +complies + :: (Ord n, Show n, Complies c) + => Profile n -- ^ Fragment profile giving the supported + -- language features and primitive operators. + -> c a n -- ^ The thing to check. + -> Maybe (Error n) + +complies profile thing + = compliesWithEnvs profile + (profilePrimKinds profile) + (profilePrimTypes profile) + thing + + +-- | Like `complies` but with some starting environments. +compliesWithEnvs + :: (Ord n, Show n, Complies c) + => Profile n -- ^ Fragment profile giving the supported + -- language features and primitive operators. + -> Env.KindEnv n -- ^ Starting kind environment. + -> Env.TypeEnv n -- ^ Starting type environment. + -> c a n -- ^ The thing to check. + -> Maybe (Error n) + +compliesWithEnvs profile kenv tenv thing + = let merr = result + $ compliesX profile + kenv tenv + contextTop thing + in case merr of + Left err -> Just err + Right _ -> Nothing + + + +-- Complies ------------------------------------------------------------------- +-- | Class of things we can check language fragment compliance for. +class Complies (c :: * -> * -> *) where + -- Check compliance of a well typed term with a language profile. + -- If it is not well typed then this can return a bad result. + compliesX + :: (Ord n, Show n) + => Profile n -- ^ Fragment profile giving the supported + -- language features and primitive operators. + -> Env n -- ^ Starting Kind environment. + -> Env n -- ^ Starting Type environment. + -> Context + -> c a n + -> CheckM n + (Set n, Set n) -- Used type and value names. + + +instance Complies Module where + compliesX profile kenv tenv context mm + = do let bs = [ BName n t + | (n, (_, t)) <- Map.toList $ moduleImportTypes mm ] + let tenv' = Env.extends bs tenv + compliesX profile kenv tenv' context (moduleBody mm) + + +-- We'll mark type vars that only appear in types of binders as unused. +instance Complies Exp where + compliesX profile kenv tenv context xx + = let has f = f $ profileFeatures profile + ok = return (Set.empty, Set.empty) + in case xx of + + -- variables ---------------------------- + XVar _ u@(UName n) + | not $ Env.member u tenv + , not $ has featuresUnboundLevel0Vars + -> throw $ ErrorUndefinedVar n + + | args <- fromMaybe 0 $ contextFunArgs context + , Just t <- Env.lookup u tenv + , arity <- arityOfType t + , args < arity + , not $ has featuresPartialApplication + -> throw $ ErrorUnsupported PartialApplication + + | otherwise + -> return (Set.empty, Set.singleton n) + + XVar _ u@(UPrim n t) + | not $ Env.member u (profilePrimTypes profile) + -> throw $ ErrorUndefinedPrim n + + | args <- fromMaybe 0 $ contextFunArgs context + , arity <- arityOfType t + , args < arity + , not $ has featuresPartialPrims + -> throw $ ErrorUnsupported PartialPrims + + | otherwise + -> return (Set.empty, Set.empty) + + XVar{} -> ok + + -- constructors ------------------------- + XCon{} -> ok + + -- spec binders ------------------------- + XLAM _ b x + | contextAbsBody context + , not $ has featuresNestedFunctions + -> throw $ ErrorUnsupported NestedFunctions + + | otherwise + -> do + -- If the body isn't another lambda then remember + -- that we've entered into a function. + let context' + | isXLAM x || isXLam x = context + | otherwise = setBody context + + (tUsed, vUsed) <- compliesX profile + (Env.extend b kenv) tenv + context' x + + tUsed' <- checkBind profile kenv b tUsed + return (tUsed', vUsed) + + -- value and witness abstraction -------- + XLam _ b x + | contextAbsBody context + , not $ has featuresNestedFunctions + -> throw $ ErrorUnsupported NestedFunctions + + | otherwise + -> do + -- If the body isn't another lambda then remember + -- that we've entered into a function. + let context' + | isXLAM x || isXLam x = context + | otherwise = setBody context + + (tUsed, vUsed) <- compliesX profile + kenv (Env.extend b tenv) + context' x + + vUsed' <- checkBind profile tenv b vUsed + return (tUsed, vUsed') + + -- application -------------------------- + XApp _ x1 (XType t2) + | profileTypeIsUnboxed profile t2 + , Nothing <- takeXPrimApps xx + -> throw $ ErrorUnsupported UnboxedInstantiation + + | otherwise + -> do checkFunction profile x1 + compliesX profile kenv tenv (addArg context) x1 + + XApp _ x1 XWitness{} + -> do checkFunction profile x1 + compliesX profile kenv tenv (addArg context) x1 + + XApp _ x1 x2 + -> do checkFunction profile x1 + (tUsed1, vUsed1) <- compliesX profile kenv tenv (addArg context) x1 + (tUsed2, vUsed2) <- compliesX profile kenv tenv context x2 + return ( Set.union tUsed1 tUsed2 + , Set.union vUsed1 vUsed2) + + -- let ---------------------------------- + XLet _ (LLet mode b1 x1) x2 + -> do let tenv' = Env.extend b1 tenv + (tUsed1, vUsed1) <- compliesX profile kenv tenv (reset context) x1 + (tUsed2, vUsed2) <- compliesX profile kenv tenv' (reset context) x2 + vUsed2' <- checkBind profile tenv b1 vUsed2 + + -- Check for unsupported lazy bindings. + (case mode of + LetStrict -> return () + LetLazy _ + | has featuresLazyBindings -> return () + | otherwise + -> throw $ ErrorUnsupported LazyBindings) + + return ( Set.union tUsed1 tUsed2 + , Set.union vUsed1 vUsed2') + + XLet _ (LRec bxs) x2 + -> do let (bs, xs) = unzip bxs + let tenv' = Env.extends bs tenv + + (tUseds1, vUseds1) + <- liftM unzip + $ mapM (compliesX profile kenv tenv' (reset context)) + xs + + (tUsed2, vUsed2) <- compliesX profile kenv tenv' (reset context) x2 + let tUseds = Set.unions (tUsed2 : tUseds1) + let vUseds = Set.unions (vUsed2 : vUseds1) + + vUseds' <- checkBinds profile tenv bs vUseds + return (tUseds, vUseds') + + + XLet _ (LLetRegions rs bs) x2 + -> do (tUsed2, vUsed2) + <- compliesX profile (Env.extends rs kenv) + (Env.extends bs tenv) + (reset context) x2 + return (tUsed2, vUsed2) + + XLet _ (LWithRegion _) x2 + -> do (tUsed2, vUsed2) <- compliesX profile kenv tenv + (reset context) x2 + return (tUsed2, vUsed2) + + -- case --------------------------------- + XCase _ x1 alts + -> do (tUsed1, vUsed1) + <- compliesX profile kenv tenv (reset context) x1 + + (tUseds2, vUseds2) <- liftM unzip + $ mapM (compliesX profile kenv tenv (reset context)) alts + + return ( Set.unions $ tUsed1 : tUseds2 + , Set.unions $ vUsed1 : vUseds2) + + + -- cast --------------------------------- + XCast _ _ x -> compliesX profile kenv tenv (reset context) x + + -- type and witness --------------------- + XType t -> throw $ ErrorNakedType t + XWitness w -> throw $ ErrorNakedWitness w + + +instance Complies Alt where + compliesX profile kenv tenv context aa + = case aa of + AAlt PDefault x + -> do (tUsed1, vUsed1) <- compliesX profile kenv tenv + (reset context) x + return (tUsed1, vUsed1) + + AAlt (PData _ bs) x + -> do (tUsed1, vUsed1) <- compliesX profile kenv (Env.extends bs tenv) + (reset context) x + vUsed1' <- checkBinds profile tenv bs vUsed1 + return (tUsed1, vUsed1') + + +-- Bind ----------------------------------------------------------------------- +-- | Check for compliance violations at a binding site. +checkBind + :: Ord n + => Profile n -- ^ The current language profile. + -> Env n -- ^ The current environment + -> Bind n -- ^ The binder at this site. + -> Set n -- ^ Names used under the binder. + -> CheckM n (Set n) -- ^ Names used above the binder. + +checkBind profile env bb used + = let has f = f $ profileFeatures profile + in case bb of + BName n _ + | not $ Set.member n used + , not $ has featuresUnusedBindings + -> throw $ ErrorUnusedBind n + + | Env.memberBind bb env + , not $ has featuresNameShadowing + -> throw $ ErrorShadowedBind n + + | otherwise + -> return $ Set.delete n used + + BAnon{} + | not $ has featuresDebruijnBinders + -> throw $ ErrorUnsupported DebruijnBinders + + _ -> return used + + +-- | Check for compliance violations at a binding site. +-- The binders must all be at the same level. +checkBinds + :: Ord n + => Profile n + -> Env n -> [Bind n] -> Set n + -> CheckM n (Set n) + +checkBinds profile env bs used + = case bs of + [] -> return used + (b : bs') + -> do used' <- checkBinds profile env bs' used + checkBind profile env b used' + + +-- Function ------------------------------------------------------------------- +-- | Check the function part of an application. +checkFunction :: Profile n -> Exp a n -> CheckM n () +checkFunction profile xx + = let has f = f $ profileFeatures profile + ok = return () + in case xx of + XVar{} -> ok + XCon{} -> ok + XApp{} -> ok + XCast{} -> ok + _ + | has featuresGeneralApplication -> return () + | otherwise -> throw $ ErrorUnsupported GeneralApplication + + +-- Context -------------------------------------------------------------------- +data Context + = Context + { contextAbsBody :: Bool + , contextFunArgs :: Maybe Int } + deriving (Eq, Show) + + +-- | The top level context, used at the top-level scope of a module. +contextTop :: Context +contextTop + = Context + { contextAbsBody = False + , contextFunArgs = Nothing } + + +-- | Record that we've entered into an abstraction body. +setBody :: Context -> Context +setBody context = context { contextAbsBody = True } + + +-- | Record that the expression is being directly applied to an argument. +addArg :: Context -> Context +addArg context + = case contextFunArgs context of + Nothing -> context { contextFunArgs = Just 1 } + Just args -> context { contextFunArgs = Just (args + 1) } + + +-- | Reset the argument counter of a context. +reset :: Context -> Context +reset context = context { contextFunArgs = Nothing } + + +-- Monad ---------------------------------------------------------------------- +-- | Compliance checking monad. +data CheckM n x + = CheckM (Either (Error n) x) + +instance Monad (CheckM n) where + return x = CheckM (Right x) + (>>=) m f + = case m of + CheckM (Left err) -> CheckM (Left err) + CheckM (Right x) -> f x + + +-- | Throw an error in the monad. +throw :: Error n -> CheckM n x +throw e = CheckM $ Left e + + +-- | Take the result from a check monad. +result :: CheckM n x -> Either (Error n) x +result (CheckM r) = r diff --git a/DDC/Core/Fragment/Error.hs b/DDC/Core/Fragment/Error.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Fragment/Error.hs @@ -0,0 +1,59 @@ + +module DDC.Core.Fragment.Error + (Error(..)) +where +import DDC.Core.Fragment.Feature +import DDC.Core.Exp +import DDC.Core.Pretty + + +-- | Language fragment compliance violations. +data Error n + -- | Found an unsupported language feature. + = ErrorUnsupported !Feature + + -- | Found an undefined primitive operator. + | ErrorUndefinedPrim !n + + -- | Found an unbound variable. + | ErrorUndefinedVar !n + + -- | Found a variable binder that shadows another one at a higher scope, + -- but the profile doesn't permit this. + | ErrorShadowedBind !n + + -- | Found a bound variable with no uses, + -- but the profile doesn't permit this. + | ErrorUnusedBind !n + + -- | Found a naked type that isn't used as a function argument. + | ErrorNakedType !(Type n) + + -- | Found a naked witness that isn't used as a function argument. + | ErrorNakedWitness !(Witness n) + deriving (Eq, Show) + + +instance (Pretty n, Eq n) => Pretty (Error n) where + ppr err + = case err of + ErrorUnsupported feature + -> vcat [ text "Unsupported feature: " <> text (show feature) ] + + ErrorUndefinedPrim n + -> vcat [ text "Undefined primitive: " <> ppr n ] + + ErrorUndefinedVar n + -> vcat [ text "Undefined variable: " <> ppr n ] + + ErrorShadowedBind n + -> vcat [ text "Binding shadows existing name: " <> ppr n ] + + ErrorUnusedBind n + -> vcat [ text "Bound name is not used: " <> ppr n ] + + ErrorNakedType t + -> vcat [ text "Naked type is not a function argument: " <> ppr t] + + ErrorNakedWitness w + -> vcat [ text "Naked witness is not a function argument: " <> ppr w ] diff --git a/DDC/Core/Fragment/Feature.hs b/DDC/Core/Fragment/Feature.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Fragment/Feature.hs @@ -0,0 +1,63 @@ + +module DDC.Core.Fragment.Feature + (Feature(..)) +where + + +-- | Language feature supported by a fragment. +data Feature + -- Type system features --------------------------- + -- | Assume all functions perform global side effects, + -- and don't generate effect terms in types. + = UntrackedEffects + + -- | Assume all functions share data invisibly, + -- and don't generate closure terms in types. + | UntrackedClosures + + -- General features ------------------------------- + -- | Partially applied primitive operators. + | PartialPrims + + -- | Partially applied functions + | PartialApplication + + -- | Function application where the thing being applied + -- is not a variable. + -- Most backend languages (like LLVM) don't support this. + | GeneralApplication + + -- | Nested function bindings. + -- The output of the lambda-lifter should not contain these. + | NestedFunctions + + -- | Lazy let-bindings. + -- Turning this off means the runtime system won't need to build + -- suspensions. + | LazyBindings + + -- | Debruijn binders. + -- Most backends will want to use real names, instead of indexed + -- binders. + | DebruijnBinders + + -- | Allow data and witness vars without binding occurrences if + -- they are annotated directly with their types. This lets + -- us work with open terms. + | UnboundLevel0Vars + + -- | Allow non-primitive functions to be instantiated at unboxed types. + -- Our existing backends can't handle this, because boxed and unboxed + -- objects have different representations. + | UnboxedInstantiation + + -- Sanity ----------------------------------------- + -- | Allow name shadowing. + | NameShadowing + + -- | Allow unused named data and witness bindings. + | UnusedBindings + + -- | Allow unused named matches. + | UnusedMatches + deriving (Eq, Ord, Show) diff --git a/DDC/Core/Fragment/Profile.hs b/DDC/Core/Fragment/Profile.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Fragment/Profile.hs @@ -0,0 +1,111 @@ + +-- | A fragment profile determines what features a program can use. +module DDC.Core.Fragment.Profile + ( Profile (..) + , zeroProfile + + , Features(..) + , zeroFeatures + , setFeature) +where +import DDC.Core.Fragment.Feature +import DDC.Type.DataDef +import DDC.Type.Exp +import DDC.Type.Env (KindEnv, TypeEnv) +import qualified DDC.Type.Env as Env + + +-- | The fragment profile describes the language features and +-- primitive operators available in the language. +data Profile n + = Profile + { -- | The name of this profile. + profileName :: !String + + -- | Permitted language features. + , profileFeatures :: !Features + + -- | Primitive data type declarations. + , profilePrimDataDefs :: !(DataDefs n) + + -- | Kinds of primitive types. + , profilePrimKinds :: !(KindEnv n) + + -- | Types of primitive operators. + , profilePrimTypes :: !(TypeEnv n) + + -- | Check whether a type is an unboxed type. + -- Some fragments limit how these can be used. + , profileTypeIsUnboxed :: !(Type n -> Bool) } + + +-- | A language profile with no features or primitive operators. +-- +-- This provides a simple first-order language. +zeroProfile :: Profile n +zeroProfile + = Profile + { profileName = "Zero" + , profileFeatures = zeroFeatures + , profilePrimDataDefs = emptyDataDefs + , profilePrimKinds = Env.empty + , profilePrimTypes = Env.empty + , profileTypeIsUnboxed = const False } + + +-- | A flattened set of features, for easy lookup. +data Features + = Features + { featuresUntrackedEffects :: Bool + , featuresUntrackedClosures :: Bool + , featuresPartialPrims :: Bool + , featuresPartialApplication :: Bool + , featuresGeneralApplication :: Bool + , featuresNestedFunctions :: Bool + , featuresLazyBindings :: Bool + , featuresDebruijnBinders :: Bool + , featuresUnboundLevel0Vars :: Bool + , featuresUnboxedInstantiation :: Bool + , featuresNameShadowing :: Bool + , featuresUnusedBindings :: Bool + , featuresUnusedMatches :: Bool + } + + +-- | An emtpy feature set, with all flags set to `False`. +zeroFeatures :: Features +zeroFeatures + = Features + { featuresUntrackedEffects = False + , featuresUntrackedClosures = False + , featuresPartialPrims = False + , featuresPartialApplication = False + , featuresGeneralApplication = False + , featuresNestedFunctions = False + , featuresLazyBindings = False + , featuresDebruijnBinders = False + , featuresUnboundLevel0Vars = False + , featuresUnboxedInstantiation = False + , featuresNameShadowing = False + , featuresUnusedBindings = False + , featuresUnusedMatches = False } + + +-- | Set a language `Flag` in the `Profile`. +setFeature :: Feature -> Bool -> Features -> Features +setFeature feature val features + = case feature of + UntrackedEffects -> features { featuresUntrackedEffects = val } + UntrackedClosures -> features { featuresUntrackedClosures = val } + PartialPrims -> features { featuresPartialPrims = val } + PartialApplication -> features { featuresPartialApplication = val } + GeneralApplication -> features { featuresGeneralApplication = val } + NestedFunctions -> features { featuresNestedFunctions = val } + LazyBindings -> features { featuresLazyBindings = val } + DebruijnBinders -> features { featuresDebruijnBinders = val } + UnboundLevel0Vars -> features { featuresUnboundLevel0Vars = val } + UnboxedInstantiation -> features { featuresUnboxedInstantiation = val } + NameShadowing -> features { featuresNameShadowing = val } + UnusedBindings -> features { featuresUnusedBindings = val } + UnusedMatches -> features { featuresUnusedMatches = val } + diff --git a/DDC/Core/Lexer.hs b/DDC/Core/Lexer.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer.hs @@ -0,0 +1,215 @@ + +-- | Reference lexer for core langauge parser. Slow but Simple. +-- +-- The lexers here all use 'String' in place of a real name type. +-- After applying these functions to the program text, we need +-- to use `renameTok` tok convert the strings in `TokNamed` tokens +-- into the name type specific to the langauge fragment to be parsed. +-- +module DDC.Core.Lexer + ( module DDC.Core.Lexer.Tokens + , module DDC.Core.Lexer.Names + + -- * Lexer + , lexModuleWithOffside + , lexExp) +where +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 + + +-- Module --------------------------------------------------------------------- +-- | Lex a module and apply the offside rule. +-- +-- Automatically drop comments from the token stream along the way. +-- +lexModuleWithOffside + :: FilePath -- ^ Path to source file, for error messages. + -> Int -- ^ Starting line number. + -> String -- ^ String containing program text. + -> [Token (Tok String)] + +lexModuleWithOffside sourceName lineStart str + = {-# SCC lexWithOffside #-} + applyOffside [] + $ addStarts + $ dropComments + $ lexString sourceName lineStart str + + +-- Exp ------------------------------------------------------------------------ +-- | Lex a string into tokens. +-- +-- Automatically drop comments from the token stream along the way. +-- +lexExp :: FilePath -- ^ Path to source file, for error messages. + -> Int -- ^ Starting line number. + -> String -- ^ String containing program text. + -> [Token (Tok String)] + +lexExp sourceName lineStart str + = {-# SCC lexExp #-} + dropNewLines + $ dropComments + $ lexString sourceName lineStart str + + +-- Generic -------------------------------------------------------------------- +lexString :: String -> Int -> String -> [Token (Tok String)] +lexString sourceName lineStart str + = lexWord lineStart 1 str + where + lexWord :: Int -> Int -> String -> [Token (Tok String)] + lexWord line column w + = let tok t = Token t (SourcePos sourceName line column) + tokM = tok . KM + tokA = tok . KA + tokN = tok . KN + + lexMore n rest + = lexWord line (column + n) rest + + in case w of + [] -> [] + + -- Whitespace + ' ' : w' -> lexMore 1 w' + '\t' : w' -> lexMore 8 w' + + -- Literal values + -- This needs to come before the rule for '-' + c : cs + | isDigit c + , (body, rest) <- span isLitBody cs + -> tokN (KLit (c:body)) : lexMore (length (c:body)) rest + + '-' : c : cs + | isDigit c + , (body, rest) <- span isLitBody cs + -> tokN (KLit ('-':c:body)) : lexMore (length (c:body)) rest + + -- Meta tokens + '{' : '-' : w' -> tokM KCommentBlockStart : lexMore 2 w' + '-' : '}' : w' -> tokM KCommentBlockEnd : lexMore 2 w' + '-' : '-' : w' -> tokM KCommentLineStart : lexMore 2 w' + '\n' : w' -> tokM KNewLine : lexWord (line + 1) 1 w' + + + -- The unit data constructor + '(' : ')' : w' -> tokA KDaConUnit : lexMore 2 w' + + -- Compound Parens + '[' : ':' : w' -> tokA KSquareColonBra : lexMore 2 w' + ':' : ']' : w' -> tokA KSquareColonKet : lexMore 2 w' + '<' : ':' : w' -> tokA KAngleColonBra : lexMore 2 w' + ':' : '>' : w' -> tokA KAngleColonKet : lexMore 2 w' + + -- Function Constructors + '~' : '>' : w' -> tokA KArrowTilde : lexMore 2 w' + '-' : '>' : w' -> tokA KArrowDash : lexMore 2 w' + '<' : '-' : w' -> tokA KArrowDashLeft : lexMore 2 w' + '=' : '>' : w' -> tokA KArrowEquals : lexMore 2 w' + + -- Compound symbols + ':' : ':' : w' -> tokA KColonColon : lexMore 2 w' + '/' : '\\' : w' -> tokA KBigLambda : lexMore 2 w' + + -- Debruijn indices + '^' : cs + | (ds, rest) <- span isDigit cs + , length ds >= 1 + -> tokA (KIndex (read ds)) : lexMore (1 + length ds) rest + + -- Parens + '(' : w' -> tokA KRoundBra : lexMore 1 w' + ')' : w' -> tokA KRoundKet : lexMore 1 w' + '[' : w' -> tokA KSquareBra : lexMore 1 w' + ']' : w' -> tokA KSquareKet : lexMore 1 w' + '{' : w' -> tokA KBraceBra : lexMore 1 w' + '}' : w' -> tokA KBraceKet : lexMore 1 w' + '<' : w' -> tokA KAngleBra : lexMore 1 w' + '>' : w' -> tokA KAngleKet : lexMore 1 w' + + -- Punctuation + '.' : w' -> tokA KDot : lexMore 1 w' + '|' : w' -> tokA KBar : lexMore 1 w' + '^' : w' -> tokA KHat : lexMore 1 w' + '+' : w' -> tokA KPlus : lexMore 1 w' + ':' : w' -> tokA KColon : lexMore 1 w' + ',' : w' -> tokA KComma : lexMore 1 w' + '\\' : w' -> tokA KBackSlash : lexMore 1 w' + ';' : w' -> tokA KSemiColon : lexMore 1 w' + '_' : w' -> tokA KUnderscore : lexMore 1 w' + '=' : w' -> tokA KEquals : lexMore 1 w' + '&' : w' -> tokA KAmpersand : lexMore 1 w' + '-' : w' -> tokA KDash : lexMore 1 w' + + -- Bottoms + '!' : '0' : w' -> tokA KBotEffect : lexMore 2 w' + '$' : '0' : w' -> tokA KBotClosure : lexMore 2 w' + + -- Sort Constructors + '*' : '*' : w' -> tokA KSortComp : lexMore 2 w' + '@' : '@' : w' -> tokA KSortProp : lexMore 2 w' + + -- Kind Constructors + '*' : w' -> tokA KKindValue : lexMore 1 w' + '%' : w' -> tokA KKindRegion : lexMore 1 w' + '!' : w' -> tokA KKindEffect : lexMore 1 w' + '$' : w' -> tokA KKindClosure : lexMore 1 w' + '@' : w' -> tokA KKindWitness : lexMore 1 w' + + + -- Named Constructors + c : cs + | isConStart c + , (body, rest) <- span isConBody cs + , (body', rest') <- case rest of + '#' : rest' -> (body ++ "#", rest') + _ -> (body, rest) + -> let readNamedCon s + | Just twcon <- readTwConBuiltin s + = tokA (KTwConBuiltin twcon) : lexMore (length s) rest' + + | Just tccon <- readTcConBuiltin s + = tokA (KTcConBuiltin tccon) : lexMore (length s) rest' + + | Just con <- readCon s + = tokN (KCon con) : lexMore (length s) rest' + + | otherwise + = [tok (KJunk [c])] + + in readNamedCon (c : body') + + -- Keywords, Named Variables and Witness constructors + c : cs + | isVarStart c + , (body, rest) <- span isVarBody cs + , (body', rest') <- case rest of + '#' : rest' -> (body ++ "#", rest') + _ -> (body, rest) + -> let readNamedVar s + | Just t <- lookup s keywords + = tok t : lexMore (length s) rest' + + | Just wc <- readWbConBuiltin s + = tokA (KWbConBuiltin wc) : lexMore (length s) rest' + + | Just v <- readVar s + = tokN (KVar v) : lexMore (length s) rest' + + | otherwise + = [tok (KJunk [c])] + + in readNamedVar (c : body') + + -- Some unrecognised character. + -- We still need to keep lexing as this may be in a comment. + c : cs -> (tok $ KJunk [c]) : lexMore 1 cs + diff --git a/DDC/Core/Lexer/Comments.hs b/DDC/Core/Lexer/Comments.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Comments.hs @@ -0,0 +1,64 @@ + +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 new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Names.hs @@ -0,0 +1,226 @@ + +module DDC.Core.Lexer.Names + ( -- * Keywords + keywords + + -- * Builtin constructors + , readTwConBuiltin + , readTcConBuiltin + , readWbConBuiltin + + -- * Variable names + , isVarName + , isVarStart + , isVarBody + , readVar + + -- * Constructor names + , isConName + , isConStart + , isConBody + , readCon + + -- * Literal names + , isLitName + , isLitStart + , isLitBody) +where +import DDC.Core.Exp +import DDC.Core.Lexer.Tokens +import DDC.Data.ListUtils +import Data.Char +import Data.List + + +-- | Textual keywords in the core language. +keywords :: [(String, Tok n)] +keywords + = [ ("module", KA KModule) + , ("imports", KA KImports) + , ("exports", KA KExports) + , ("in", KA KIn) + , ("of", KA KOf) + , ("letrec", KA KLetRec) + , ("letregions", KA KLetRegions) + , ("letregion", KA KLetRegion) + , ("withregion", KA KWithRegion) + , ("let", KA KLet) + , ("lazy", KA KLazy) + , ("case", KA KCase) + , ("purify", KA KPurify) + , ("forget", KA KForget) + , ("type", KA KType) + , ("weakeff", KA KWeakEff) + , ("weakclo", KA KWeakClo) + , ("with", KA KWith) + , ("where", KA KWhere) + , ("do", KA KDo) + , ("match", KA KMatch) + , ("else", KA KElse) ] + + +-- | Read a named `TwCon`. +readTwConBuiltin :: String -> Maybe TwCon +readTwConBuiltin ss + = case ss of + "Global" -> Just TwConGlobal + "DeepGlobal" -> Just TwConDeepGlobal + "Const" -> Just TwConConst + "DeepConst" -> Just TwConDeepConst + "Mutable" -> Just TwConMutable + "DeepMutable" -> Just TwConDeepMutable + "Lazy" -> Just TwConLazy + "HeadLazy" -> Just TwConHeadLazy + "Manifest" -> Just TwConManifest + "Pure" -> Just TwConPure + "Empty" -> Just TwConEmpty + "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 `TcCon` with a non-symbolic name, +-- ie not '->'. +readTcConBuiltin :: String -> Maybe TcCon +readTcConBuiltin ss + = case ss of + "Unit" -> Just TcConUnit + "Read" -> Just TcConRead + "HeadRead" -> Just TcConHeadRead + "DeepRead" -> Just TcConDeepRead + "Write" -> Just TcConWrite + "DeepWrite" -> Just TcConDeepWrite + "Alloc" -> Just TcConAlloc + "DeepAlloc" -> Just TcConDeepAlloc + "Use" -> Just TcConUse + "DeepUse" -> Just TcConDeepUse + _ -> Nothing + + +-- | Read a `WbCon`. +readWbConBuiltin :: String -> Maybe WbCon +readWbConBuiltin ss + = case ss of + "pure" -> Just WbConPure + "empty" -> Just WbConEmpty + "use" -> Just WbConUse + "read" -> Just WbConRead + "alloc" -> Just WbConAlloc + _ -> Nothing + + +-- Variable names ------------------------------------------------------------- +-- | String is a variable name +isVarName :: String -> Bool +isVarName str + = case str of + [] -> False + c : cs + | isVarStart c + , and (map isVarBody cs) + -> True + + | _ : _ <- cs + , Just initCs <- takeInit cs + , isVarStart c + , and (map isVarBody initCs) + , last cs == '#' + -> True + + | otherwise + -> False + + +-- | Charater can start a variable name. +isVarStart :: Char -> Bool +isVarStart = isLower + + +-- | Character can be part of a variable body. +isVarBody :: Char -> Bool +isVarBody c + = isUpper c || isLower c || isDigit c || c == '_' || c == '\'' + + +-- | Read a named, user defined variable. +readVar :: String -> Maybe String +readVar ss + | isVarName ss = Just ss + | otherwise = Nothing + + +-- Constructor names ---------------------------------------------------------- +-- | String is a constructor name. +isConName :: String -> Bool +isConName str + = case str of + [] -> False + c : cs + | isConStart c + , and (map isConBody cs) + -> True + + | _ : _ <- cs + , Just initCs <- takeInit cs + , isConStart c + , and (map isConBody initCs) + , last cs == '#' + -> True + + | otherwise + -> False + +-- | Character can start a constructor name. +isConStart :: Char -> Bool +isConStart = isUpper + + +-- | Charater can be part of a constructor body. +isConBody :: Char -> Bool +isConBody c = isUpper c || isLower c || isDigit c || c == '_' + + + +-- | Read a named, user defined `TcCon`. +readCon :: String -> Maybe String +readCon ss + | isConName ss = Just ss + | otherwise = Nothing + + +-- Literal names -------------------------------------------------------------- +-- | String is the name of a literal. +isLitName :: String -> Bool +isLitName str + = case str of + [] -> False + c : cs + | isLitStart c + , and (map isLitBody cs) + -> True + + | otherwise + -> False + +-- | Character can start a literal. +isLitStart :: Char -> Bool +isLitStart c + = isDigit c + || c == '-' + +-- | Character can be part of a literal body. +isLitBody :: Char -> Bool +isLitBody c + = isDigit c + || c == 'b' || c == 'o' || c == 'x' + || c == 'w' || c == 'i' + || c == '#' + diff --git a/DDC/Core/Lexer/Offside.hs b/DDC/Core/Lexer/Offside.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Offside.hs @@ -0,0 +1,265 @@ + +-- | Apply the offside rule to a token stream to add braces. +module DDC.Core.Lexer.Offside + ( Lexeme (..) + , applyOffside + , addStarts) +where +import DDC.Core.Lexer.Tokens +import DDC.Data.SourcePos +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)) + | LexemeStartLine Int + + -- | Signal that we're starting a block in this column. + | LexemeStartBlock Int + deriving (Eq, Show) + +type Context + = Int + +-- | Apply the offside rule to this token stream. +-- It should have been processed with addStarts first to add the +-- LexemeStartLine/LexemeStartLine tokens. +-- +applyOffside + :: (Eq n, Show n) + => [Context] + -> [Lexeme n] + -> [Token (Tok n)] + +-- Wait for the module header before we start applying the real offside rule. +-- This allows us to write 'module Name with letrec' all on the same line. +applyOffside [] (LexemeToken t : ts) + | isToken t (KA KModule) + || isKNToken t + = t : applyOffside [] ts + +-- When we see the top-level letrec then enter into the outer-most context. +applyOffside [] (LexemeToken t1 : (LexemeStartBlock n) : ls) + | isToken t1 (KA KLetRec) + || isToken t1 (KA KExports) + || isToken t1 (KA KImports) + = t1 : newCBra ls : applyOffside [n] ls + +-- At top level without a context. +-- Skip over everything until we get the 'with' in 'module Name with ...'' +applyOffside [] (LexemeStartLine _ : ts) + = applyOffside [] ts + +applyOffside [] (LexemeStartBlock _ : ts) + = applyOffside [] ts + + +-- line start +applyOffside mm@(m : ms) (t@(LexemeStartLine n) : ts) + -- add semicolon to get to the next statement in this block + | m == n + = newSemiColon ts : applyOffside mm ts + + -- end a block + -- we keep the StartLine token in the recursion in case we're ending + -- multiple blocks difference from Haskell98: add a semicolon as well + | n < m + = newSemiColon ts : newCKet ts : applyOffside ms (t : ts) + + -- indented continuation of this statement + | otherwise + = applyOffside mm ts + + +-- block start +applyOffside mm@(m : ms) (LexemeStartBlock n : ts) + -- enter into a nested context + | n > m + = newCBra ts : applyOffside (n : m : ms) ts + + -- new context starts less than the current one. + -- This should never happen, + -- provided addStarts works. + | tNext : _ <- dropNewLinesLexeme ts + = error $ "DDC.Core.Lexer.Tokens.Offside: layout error on " ++ show tNext ++ "." + + -- new context cannot be less indented than outer one + -- This should never happen, + -- as there is no lexeme to start a new context at the end of the file + | [] <- dropNewLinesLexeme ts + = error "DDC.Core.Lexer.Tokens.Offside: tried to start new context at end of file." + + -- an empty block + | otherwise + = newCBra ts : newCKet ts : applyOffside mm (LexemeStartLine n : ts) + + +-- pop contexts from explicit close braces +applyOffside mm (LexemeToken t@Token { tokenTok = KA KBraceKet } : ts) + + -- make sure that explict open braces match explicit close braces + | 0 : ms <- mm + = t : applyOffside ms ts + + -- nup + | _tNext : _ <- dropNewLinesLexeme ts + = [newOffsideClosingBrace ts] + + +-- push contexts for explicit open braces +applyOffside ms (LexemeToken t@Token { tokenTok = KA KBraceBra } : ts) + = t : applyOffside (0 : ms) ts + +applyOffside ms (LexemeToken t : ts) + = t : applyOffside ms ts + +applyOffside [] [] = [] + +-- close off remaining contexts once we've reached the end of the stream. +applyOffside (_ : ms) [] = newCKet [] : applyOffside ms [] + + +-- addStarts ------------------------------------------------------------------ +-- | Add block and line start tokens to this stream. +-- This is lifted straight from the Haskell98 report. +addStarts :: Eq n => [Token (Tok n)] -> [Lexeme n] +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) + + | otherwise + -> addStarts' (t1 : tsRest) + + -- empty file + [] -> [] + + +addStarts' :: Eq n => [Token (Tok n)] -> [Lexeme n] +addStarts' [] = [] +addStarts' (t1 : ts) + + -- We're starting a block + | isBlockStart t1 + , [] <- dropNewLines ts + = LexemeToken t1 : [LexemeStartBlock 0] + + | isBlockStart t1 + , t2 : tsRest <- dropNewLines ts + , not $ isToken t2 (KA KBraceBra) + = LexemeToken t1 : LexemeStartBlock (tokenColumn t2) + : addStarts' (t2 : tsRest) + + -- check for start of list + | isToken t1 (KA KBraceBra) + = LexemeToken t1 : addStarts' ts + + -- check for end of list + | isToken t1 (KA KBraceKet) + = LexemeToken t1 : addStarts' ts + + -- check for start of new line + | isToken t1 (KM KNewLine) + , t2 : tsRest <- dropNewLines ts + , not $ isToken t2 (KA KBraceBra) + = LexemeStartLine (tokenColumn t2) + : addStarts' (t2 : tsRest) + + -- eat up trailine newlines + | isToken t1 (KM KNewLine) + = addStarts' ts + + -- a regular token + | otherwise + = LexemeToken t1 : addStarts' ts + + +-- | Drop newline tokens at the front fo this stream. +dropNewLines :: Eq n => [Token (Tok n)] -> [Token (Tok n)] +dropNewLines [] = [] +dropNewLines (t1:ts) + | isToken t1 (KM KNewLine) + = dropNewLines ts + + | otherwise + = t1 : ts + + +-- | Drop newline tokens at the front fo this stream. +dropNewLinesLexeme :: Eq n => [Lexeme n] -> [Lexeme n] +dropNewLinesLexeme ll + = case ll of + [] -> [] + LexemeToken t1 : ts + | isToken t1 (KM KNewLine) + -> dropNewLinesLexeme ts + + l : ls + -> l : dropNewLinesLexeme ls + + +-- | Check if a token is one that starts a block of statements. +isBlockStart :: Token (Tok n) -> Bool +isBlockStart Token { tokenTok = tok } + = case tok of + KA KDo -> True + KA KOf -> True + KA KLetRec -> True + KA KWhere -> True + KA KExports -> True + KA KImports -> True + _ -> False + + +-- Utils ---------------------------------------------------------------------- +-- | Test whether this wrapper token matches. +isToken :: Eq n => Token (Tok n) -> Tok n -> Bool +isToken (Token tok _) tok2 = tok == tok2 + + +-- | Test whether this wrapper token matches. +isKNToken :: Eq n => Token (Tok n) -> Bool +isKNToken (Token (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 ts + = (takeTok ts) { tokenTok = KA KBraceBra } + + +newCKet :: [Lexeme n] -> Token (Tok n) +newCKet ts + = (takeTok ts) { tokenTok = KA KBraceKet } + + +newSemiColon :: [Lexeme n] -> Token (Tok n) +newSemiColon ts + = (takeTok ts) { tokenTok = KA KSemiColon } + + +-- | 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 ts + = (takeTok ts) { tokenTok = KM KOffsideClosingBrace } + + +takeTok :: [Lexeme n] -> Token (Tok n) +takeTok [] + = Token (KJunk "") (SourcePos "" 0 0) + +takeTok (l : ls) + = case l of + LexemeToken (Token { tokenTok = KM KNewLine }) + -> takeTok ls + + LexemeToken t -> t + LexemeStartLine _ -> takeTok ls + LexemeStartBlock _ -> takeTok ls diff --git a/DDC/Core/Lexer/Tokens.hs b/DDC/Core/Lexer/Tokens.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lexer/Tokens.hs @@ -0,0 +1,347 @@ + +module DDC.Core.Lexer.Tokens + ( -- * Tokens + Tok (..) + , renameTok + , describeTok + + -- * Meta Tokens + , TokMeta (..) + , describeTokMeta + + -- * Atomic Tokens + , TokAtom (..) + , describeTokAtom + + -- * Named Tokens + , TokNamed (..) + , describeTokNamed) +where +import DDC.Core.Pretty +import DDC.Core.Exp +import Control.Monad + + +-- TokenFamily ---------------------------------------------------------------- +-- | The family of a token. +-- This is used to help generate parser error messages, +-- so we can say ''the constructor Cons'' +-- and ''the keyword case'' etc. +data TokenFamily + = Symbol + | Keyword + | Constructor + | Index + | Variable + + +-- | Describe a token family, for parser error messages. +describeTokenFamily :: TokenFamily -> String +describeTokenFamily tf + = case tf of + Symbol -> "symbol" + Keyword -> "keyword" + Constructor -> "constructor" + Index -> "index" + Variable -> "variable" + + +-- Tok ------------------------------------------------------------------------ +-- | Tokens accepted by the core language parser. +data Tok n + -- | Some junk symbol that isn't part of the language. + = KJunk String + + -- | Meta tokens contain out-of-band information that is eliminated + -- before parsing proper. + | KM !TokMeta + + -- | Atomic tokens are keywords, punctuation and baked-in + -- constructor names. + | KA !TokAtom + + -- | A named token that is specific to the language fragment + -- (maybe it's a primop), or a user defined name. + | KN !(TokNamed n) + deriving (Eq, Show) + + +-- | Apply a function to all the names in a `Tok`. +renameTok + :: Ord n2 + => (n1 -> Maybe n2) + -> Tok n1 + -> Maybe (Tok n2) + +renameTok f kk + = case kk of + KJunk s -> Just $ KJunk s + KM t -> Just $ KM t + KA t -> Just $ KA t + KN t -> liftM KN $ renameTokNamed f t + + +-- | Describe a token for parser error messages. +describeTok :: Pretty n => Tok n -> String +describeTok kk + = case kk of + KJunk c -> "character " ++ show c + KM tm -> describeTokMeta tm + KA ta -> describeTokAtom ta + KN tn -> describeTokNamed tn + + +-- TokMeta -------------------------------------------------------------------- +-- | Meta tokens contain out-of-band information that is +-- eliminated before parsing proper. +data TokMeta + = KNewLine + | KCommentLineStart + | KCommentBlockStart + | KCommentBlockEnd + + -- | This is injected by `dropCommentBlock` when it finds + -- an unterminated block comment. + | KCommentUnterminated + + -- | This is injected by `applyOffside` when it finds an explit close + -- brace in a position where it would close a synthetic one. + | KOffsideClosingBrace + deriving (Eq, Show) + + +-- | Describe a TokMeta, for lexer error messages. +describeTokMeta :: TokMeta -> String +describeTokMeta tm + = case tm of + KNewLine -> "new line" + KCommentLineStart -> "comment start" + KCommentBlockStart -> "block comment start" + KCommentBlockEnd -> "block comment end" + KCommentUnterminated -> "unterminated block comment" + KOffsideClosingBrace -> "closing brace" + + +-- TokAtom -------------------------------------------------------------------- +-- | Atomic tokens are keywords, punctuation and baked-in constructor names. +-- They don't contain user-defined names or primops specific to the +-- language fragment. +data TokAtom + -- parens + = KRoundBra + | KRoundKet + | KSquareBra + | KSquareKet + | KBraceBra + | KBraceKet + | KAngleBra + | KAngleKet + + -- compound parens + | KSquareColonBra + | KSquareColonKet + | KAngleColonBra + | KAngleColonKet + + -- punctuation + | KDot + | KBar + | KHat + | KPlus + | KColon + | KComma + | KBackSlash + | KSemiColon + | KUnderscore + | KEquals + | KAmpersand + | KDash + | KColonColon + | KBigLambda + + -- symbolic constructors + | KSortComp + | KSortProp + | KKindValue + | KKindRegion + | KKindEffect + | KKindClosure + | KKindWitness + | KArrowTilde + | KArrowDash + | KArrowDashLeft + | KArrowEquals + + -- bottoms + | KBotEffect + | KBotClosure + + -- core keywords + | KModule + | KImports + | KExports + | KWith + | KWhere + | KIn + | KLet + | KLazy + | KLetRec + | KLetRegions + | KLetRegion + | KWithRegion + | KCase + | KOf + | KType + | KWeakEff + | KWeakClo + | KPurify + | KForget + + -- sugar keywords + | KDo + | KMatch + | KElse + + -- debruijn indices + | KIndex Int + + -- builtin names ------------ + -- the unit data constructor. + | KDaConUnit + + -- witness type constructors. + | KTwConBuiltin TwCon + + -- witness constructors. + | KWbConBuiltin WbCon + + -- other builtin spec constructors. + | KTcConBuiltin TcCon + deriving (Eq, Show) + + +-- | Describe a `TokAtom`, for parser error messages. +describeTokAtom :: TokAtom -> String +describeTokAtom ta + = let (family, str) = describeTokAtom' ta + in describeTokenFamily family ++ " " ++ show str + +describeTokAtom' :: TokAtom -> (TokenFamily, String) +describeTokAtom' ta + = case ta of + -- parens + KRoundBra -> (Symbol, "(") + KRoundKet -> (Symbol, ")") + KSquareBra -> (Symbol, "[") + KSquareKet -> (Symbol, "]") + KBraceBra -> (Symbol, "{") + KBraceKet -> (Symbol, "}") + KAngleBra -> (Symbol, "<") + KAngleKet -> (Symbol, ">") + + -- compound parens + KSquareColonBra -> (Symbol, "[:") + KSquareColonKet -> (Symbol, ":]") + KAngleColonBra -> (Symbol, "<:") + KAngleColonKet -> (Symbol, ":>") + + -- punctuation + KDot -> (Symbol, ".") + KBar -> (Symbol, "|") + KHat -> (Symbol, "^") + KPlus -> (Symbol, "+") + KColon -> (Symbol, ":") + KComma -> (Symbol, ",") + KBackSlash -> (Symbol, "\\") + KSemiColon -> (Symbol, ";") + KUnderscore -> (Symbol, "_") + KEquals -> (Symbol, "=") + KAmpersand -> (Symbol, "&") + KDash -> (Symbol, "-") + KColonColon -> (Symbol, "::") + KBigLambda -> (Symbol, "/\\") + + -- symbolic constructors + KSortComp -> (Constructor, "**") + KSortProp -> (Constructor, "@@") + KKindValue -> (Constructor, "*") + KKindRegion -> (Constructor, "%") + KKindEffect -> (Constructor, "!") + KKindClosure -> (Constructor, "$") + KKindWitness -> (Constructor, "@") + KArrowTilde -> (Constructor, "~>") + KArrowDash -> (Constructor, "->") + KArrowDashLeft -> (Constructor, "<-") + KArrowEquals -> (Constructor, "=>") + + -- bottoms + KBotEffect -> (Constructor, "!0") + KBotClosure -> (Constructor, "!$") + + -- expression keywords + KModule -> (Keyword, "module") + KImports -> (Keyword, "imports") + KExports -> (Keyword, "exports") + KWith -> (Keyword, "with") + KWhere -> (Keyword, "where") + KIn -> (Keyword, "in") + KLet -> (Keyword, "let") + KLazy -> (Keyword, "lazy") + KLetRec -> (Keyword, "letrec") + KLetRegions -> (Keyword, "letregions") + KLetRegion -> (Keyword, "letregion") + KWithRegion -> (Keyword, "withregion") + KCase -> (Keyword, "case") + KOf -> (Keyword, "of") + KType -> (Keyword, "type") + KWeakEff -> (Keyword, "weakeff") + KWeakClo -> (Keyword, "weakclo") + KPurify -> (Keyword, "purify") + KForget -> (Keyword, "forget") + + -- sugar keywords + KDo -> (Keyword, "do") + KMatch -> (Keyword, "match") + KElse -> (Keyword, "else") + + -- debruijn indices + KIndex i -> (Index, "^" ++ show i) + + -- builtin names + KDaConUnit -> (Constructor, "()") + KTwConBuiltin tw -> (Constructor, renderPlain $ ppr tw) + KWbConBuiltin wi -> (Constructor, renderPlain $ ppr wi) + KTcConBuiltin tc -> (Constructor, renderPlain $ ppr tc) + + +-- TokNamed ------------------------------------------------------------------- +-- | A token with a user-defined name. +data TokNamed n + = KCon n + | KVar n + | KLit n + deriving (Eq, Show) + + +-- | Describe a `TokNamed`, for parser error messages. +describeTokNamed :: Pretty n => TokNamed n -> String +describeTokNamed tn + = case tn of + KCon n -> renderPlain $ text "constructor" <+> (dquotes $ ppr n) + KVar n -> renderPlain $ text "variable" <+> (dquotes $ ppr n) + KLit n -> renderPlain $ text "literal" <+> (dquotes $ ppr n) + + +-- | Apply a function to all the names in a `TokNamed`. +renameTokNamed + :: Ord n2 + => (n1 -> Maybe n2) + -> TokNamed n1 + -> Maybe (TokNamed n2) + +renameTokNamed 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 new file mode 100644 --- /dev/null +++ b/DDC/Core/Load.hs @@ -0,0 +1,240 @@ + +-- | \"Loading\" refers to the combination of parsing and type checking. +-- This is the easiest way to turn source tokens into a type-checked +-- abstract syntax tree. +module DDC.Core.Load + ( C.AnTEC (..) + , Error (..) + , loadModuleFromFile + , loadModuleFromString + , loadModuleFromTokens + , loadExp + , loadType + , loadWitness) +where +import DDC.Core.Transform.SpreadX +import DDC.Core.Fragment.Profile +import DDC.Core.Lexer.Tokens +import DDC.Core.Exp +import DDC.Type.Transform.SpreadT +import DDC.Core.Module +import DDC.Base.Pretty +import DDC.Data.Token +import qualified DDC.Core.Fragment as I +import qualified DDC.Core.Parser as C +import qualified DDC.Core.Check as C +import qualified DDC.Type.Check as T +import qualified DDC.Base.Parser as BP +import Data.Map.Strict (Map) +import System.Directory + + +-- | Things that can go wrong when loading a core thing. +data Error n + = ErrorRead !String + | ErrorParser !BP.ParseError + | ErrorCheckType !(T.Error n) + | ErrorCheckExp !(C.Error () n) + | ErrorCompliance !(I.Error n) + deriving Show + + +instance (Eq n, Show n, Pretty n) => Pretty (Error n) where + ppr err + = case err of + ErrorRead str + -> vcat [ text "While reading." + , indent 2 $ text str ] + + ErrorParser err' + -> vcat [ text "While parsing." + , indent 2 $ ppr err' ] + + ErrorCheckType err' + -> vcat [ text "When checking type." + , indent 2 $ ppr err' ] + + + ErrorCheckExp err' + -> vcat [ text "When checking expression." + , indent 2 $ ppr err' ] + + ErrorCompliance err' + -> vcat [ text "During fragment compliance check." + , indent 2 $ ppr err' ] + + +-- Module --------------------------------------------------------------------- +-- | Parse and type check a core module from a file. +loadModuleFromFile + :: (Eq n, Ord n, Show n, Pretty n) + => Profile n -- ^ Language fragment profile. + -> (String -> [Token (Tok n)]) -- ^ Function to lex the source file. + -> FilePath -- ^ File containing source code. + -> IO (Either (Error n) + (Module (C.AnTEC () n) n)) + +loadModuleFromFile profile lexSource filePath + = do + -- Check whether the file exists. + exists <- doesFileExist filePath + if not exists + then return $ Left $ ErrorRead "Cannot read file." + else do + -- Read the source file. + src <- readFile filePath + + -- Lex the source. + let toks = lexSource src + + return $ loadModuleFromTokens profile filePath toks + +-- | Parse and type check a core module from a string. +loadModuleFromString + :: (Eq n, Ord n, Show n, Pretty n) + => Profile n -- ^ Language fragment profile. + -> (String -> [Token (Tok n)]) -- ^ Function to lex the source file. + -> FilePath -- ^ Path to source file for error messages. + -> String -- ^ Program text. + -> Either (Error n) (Module (C.AnTEC () n) n) + +loadModuleFromString profile lexSource filePath src + = loadModuleFromTokens profile filePath (lexSource src) + + +-- | Parse and type check a core module. +loadModuleFromTokens + :: (Eq n, Ord n, Show n, Pretty n) + => Profile n -- ^ Language fragment profile. + -> FilePath -- ^ Path to source file for error messages. + -> [Token (Tok n)] -- ^ Source tokens. + -> Either (Error n) (Module (C.AnTEC () n) n) + +loadModuleFromTokens profile sourceName toks' + = goParse toks' + where + -- Type checker config kind and type environments. + config = C.configOfProfile profile + kenv = profilePrimKinds profile + tenv = profilePrimTypes profile + + -- Parse the tokens. + goParse toks + = case BP.runTokenParser describeTok sourceName C.pModule toks of + Left err -> Left (ErrorParser err) + Right mm -> goCheckType (spreadX kenv tenv mm) + + -- Check that the module is type sound. + goCheckType mm + = case C.checkModule config mm of + Left err -> Left (ErrorCheckExp err) + Right mm' -> goCheckCompliance mm' + + -- Check that the module compiles with the language fragment. + goCheckCompliance mm + = case I.complies profile mm of + Just err -> Left (ErrorCompliance err) + Nothing -> Right mm + + +-- Exp ------------------------------------------------------------------------ +-- | Parse and check an expression +-- returning it along with its spec, effect and closure +loadExp + :: (Eq n, Ord n, Show n, Pretty n) + => Profile n -- ^ Language fragment profile. + -> Map ModuleName (Module (C.AnTEC () n) n) + -- ^ Other modules currently in scope. + -- We add their exports to the environment. + -> FilePath -- ^ Path to source file for error messages. + -> [Token (Tok n)] -- ^ Source tokens. + -> Either (Error n) + (Exp (C.AnTEC () n) n) + +loadExp profile modules sourceName toks' + = goParse toks' + where + -- Type checker profile, kind and type environments. + config = C.configOfProfile profile + kenv = modulesExportKinds modules $ profilePrimKinds profile + tenv = modulesExportTypes modules $ profilePrimTypes profile + + -- Parse the tokens. + goParse toks + = case BP.runTokenParser describeTok sourceName C.pExp toks of + Left err -> Left (ErrorParser err) + Right t -> goCheckType (spreadX kenv tenv t) + + -- Check the kind of the type. + goCheckType x + = case C.checkExp config kenv tenv x of + Left err -> Left (ErrorCheckExp err) + Right (x', _, _, _) -> goCheckCompliance x' + + -- Check that the module compiles with the language fragment. + goCheckCompliance x + = case I.compliesWithEnvs profile kenv tenv x of + Just err -> Left (ErrorCompliance err) + Nothing -> Right x + + +-- Type ----------------------------------------------------------------------- +-- | Parse and check a type, +-- returning it along with its kind. +loadType + :: (Eq n, Ord n, Show n, Pretty n) + => Profile n -- ^ Language fragment profile. + -> FilePath -- ^ Path to source file for error messages. + -> [Token (Tok n)] -- ^ Source tokens. + -> Either (Error n) + (Type n, Kind n) + +loadType profile sourceName toks' + = goParse toks' + where defs = profilePrimDataDefs profile + kenv = profilePrimKinds profile + + -- Parse the tokens. + goParse toks + = case BP.runTokenParser describeTok sourceName C.pType toks of + Left err -> Left (ErrorParser err) + Right t -> goCheckType (spreadT kenv t) + + -- Check the kind of the type. + goCheckType t + = case T.checkType defs kenv t of + Left err -> Left (ErrorCheckType err) + Right k -> Right (t, k) + + + +-- Witness -------------------------------------------------------------------- +-- | Parse and check a witness, +-- returning it along with its type. +loadWitness + :: (Eq n, Ord n, Show n, Pretty n) + => Profile n -- ^ Language fragment profile. + -> FilePath -- ^ Path to source file for error messages. + -> [Token (Tok n)] -- ^ Source tokens. + -> Either (Error n) + (Witness n, Type n) + +loadWitness profile sourceName toks' + = goParse toks' + where -- Type checker config, kind and type environments. + config = C.configOfProfile profile + kenv = profilePrimKinds profile + tenv = profilePrimTypes profile + + -- Parse the tokens. + goParse toks + = case BP.runTokenParser describeTok sourceName C.pWitness toks of + Left err -> Left (ErrorParser err) + Right t -> goCheckType (spreadX kenv tenv t) + + -- Check the kind of the type. + goCheckType w + = case C.checkWitness config kenv tenv w of + Left err -> Left (ErrorCheckExp err) + Right k -> Right (w, k) + diff --git a/DDC/Core/Module.hs b/DDC/Core/Module.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Module.hs @@ -0,0 +1,147 @@ + +module DDC.Core.Module + ( -- * Modules + Module (..) + , isMainModule + , moduleKindEnv + , moduleTypeEnv + , modulesGetBinds + + -- * Module maps + , ModuleMap + , modulesExportKinds + , modulesExportTypes + + -- * Module Names. + , QualName (..) + , ModuleName (..) + , isMainModuleName) +where +import DDC.Core.Exp +import Data.Typeable +import Data.Map.Strict (Map) +import DDC.Type.Env as Env +import qualified Data.Map.Strict as Map +import Control.DeepSeq + + +-- Module --------------------------------------------------------------------- +-- | A module can be mutually recursive with other modules. +data Module a n + = ModuleCore + { -- | Name of this module. + moduleName :: !ModuleName + + -- Exports ------------------ + -- | Kinds of exported types. + , moduleExportKinds :: !(Map n (Kind n)) + + -- | Types of exported values. + , moduleExportTypes :: !(Map n (Type n)) + + -- Imports ------------------ + -- | Kinds of imported types, + -- along with the name of the module they are from. + , moduleImportKinds :: !(Map n (QualName n, Kind n)) + + -- | Types of imported values, + -- along with the name of the module they are from. + , moduleImportTypes :: !(Map n (QualName n, Type n)) + + -- Local -------------------- + -- | The module body consists of some let-bindings + -- wrapping a unit data constructor. + -- + -- We're only interested in the bindings, + -- with the unit being just a place-holder. + , moduleBody :: !(Exp a n) + } + deriving (Show, Typeable) + + +instance (NFData a, NFData n) => NFData (Module a n) where + rnf !mm + = rnf (moduleName mm) + `seq` rnf (moduleExportKinds mm) + `seq` rnf (moduleExportTypes mm) + `seq` rnf (moduleImportKinds mm) + `seq` rnf (moduleImportTypes mm) + `seq` rnf (moduleBody mm) + + +-- | Check if this is the `Main` module. +isMainModule :: Module a n -> Bool +isMainModule mm + = isMainModuleName + $ moduleName mm + + +-- | Get the top-level kind environment of a module, +-- from its imported types. +moduleKindEnv :: Ord n => Module a n -> KindEnv n +moduleKindEnv mm + = Env.fromList + $ [BName n k | (n, (_, k)) <- Map.toList $ moduleImportKinds mm] + + +-- | Get the top-level type environment of a module, +-- from its imported values. +moduleTypeEnv :: Ord n => Module a n -> TypeEnv n +moduleTypeEnv mm + = Env.fromList + $ [BName n k | (n, (_, k)) <- Map.toList $ moduleImportTypes mm] + + +-- ModuleMap ------------------------------------------------------------------ +-- | Map of module names to modules. +type ModuleMap a n + = Map ModuleName (Module a n) + +modulesGetBinds m + = Env.fromList $ map (uncurry BName) (Map.assocs m) + + +-- | Add the kind environment exported by all these modules to the given one. +modulesExportKinds :: Ord n => ModuleMap a n -> KindEnv n -> KindEnv n +modulesExportKinds mods base + = foldl Env.union base + $ map (modulesGetBinds.moduleExportKinds) (Map.elems mods) + + +-- | Add the type environment exported by all these modules to the given one. +modulesExportTypes :: Ord n => ModuleMap a n -> TypeEnv n -> TypeEnv n + +modulesExportTypes mods base + = foldl Env.union base + $ map (modulesGetBinds.moduleExportTypes) (Map.elems mods) + + +-- ModuleName ----------------------------------------------------------------- +-- | A hierarchical module name. +data ModuleName + = ModuleName [String] + deriving (Show, Eq, Ord, Typeable) + +instance NFData ModuleName where + rnf (ModuleName ss) + = rnf ss + + +-- | A fully qualified name, +-- including the name of the module it is from. +data QualName n + = QualName ModuleName n + deriving Show + +instance NFData n => NFData (QualName n) where + rnf (QualName mn n) + = rnf mn `seq` rnf n + + +-- | Check whether this is the name of the \"Main\" module. +isMainModuleName :: ModuleName -> Bool +isMainModuleName mn + = case mn of + ModuleName ["Main"] -> True + _ -> False + diff --git a/DDC/Core/Parser.hs b/DDC/Core/Parser.hs --- a/DDC/Core/Parser.hs +++ b/DDC/Core/Parser.hs @@ -1,631 +1,44 @@ -- | Core language parser. module DDC.Core.Parser - ( module DDC.Base.Parser - , Parser - , pExp - , pWitness) - -where -import DDC.Core.Exp -import DDC.Core.Parser.Tokens -import DDC.Base.Parser (()) -import DDC.Type.Parser (pTok) -import qualified DDC.Base.Parser as P -import qualified DDC.Type.Compounds as T -import qualified DDC.Type.Parser as T -import Control.Monad.Error - - --- | A parser of core language tokens. -type Parser n a - = P.Parser (Tok n) a - - --- Expressions ---------------------------------------------------------------- --- | Parse a core language expression. -pExp :: Ord n => Parser n (Exp () n) -pExp - = P.choice - -- Level-0 lambda abstractions - -- \(x1 x2 ... : TYPE) (y1 y2 ... : TYPE) ... . EXP - [ do pTok KBackSlash - - bs <- liftM concat - $ P.many1 - $ do pTok KRoundBra - bs' <- P.many1 T.pBinder - pTok KColon - t <- T.pType - pTok KRoundKet - return (map (\b -> T.makeBindFromBinder b t) bs') - - pTok KDot - xBody <- pExp - return $ foldr (XLam ()) xBody bs - - -- Level-1 lambda abstractions. - -- /\(x1 x2 ... : TYPE) (y1 y2 ... : TYPE) ... . EXP - , do pTok KBigLambda - - bs <- liftM concat - $ P.many1 - $ do pTok KRoundBra - bs' <- P.many1 T.pBinder - pTok KColon - t <- T.pType - pTok KRoundKet - return (map (\b -> T.makeBindFromBinder b t) bs') - - pTok KDot - xBody <- pExp - return $ foldr (XLAM ()) xBody bs - - - -- let expression - , do pTok KLet - (mode1, b1, x1) <- pLetBinding - pTok KIn - x2 <- pExp - return $ XLet () (LLet mode1 b1 x1) x2 - - - -- letrec expression - , do pTok KLetRec - - P.choice - -- Multiple bindings in braces - [ do pTok KBraceBra - lets <- P.sepEndBy1 pLetRecBinding (pTok KSemiColon) - pTok KBraceKet - pTok KIn - x <- pExp - return $ XLet () (LRec lets) x - - -- A single binding without braces. - , do ll <- pLetRecBinding - pTok KIn - x <- pExp - return $ XLet () (LRec [ll]) x - ] - - - -- Local region binding. - -- letregion BINDER with { BINDER : TYPE ... } in EXP - -- letregion BINDER in EXP - , do pTok KLetRegion - br <- T.pBinder - let b = T.makeBindFromBinder br T.kRegion - - P.choice - [ do pTok KWith - pTok KBraceBra - wits <- P.sepBy - (do w <- pVar - pTok KColon - t <- T.pTypeApp - return (BName w t)) - (pTok KSemiColon) - pTok KBraceKet - pTok KIn - x <- pExp - return $ XLet () (LLetRegion b wits) x - - , do pTok KIn - x <- pExp - return $ XLet () (LLetRegion b []) x ] - - - -- withregion CON in EXP - , do pTok KWithRegion - n <- pVar - pTok KIn - x <- pExp - let u = UName n (T.tBot T.kRegion) - return $ XLet () (LWithRegion u) x - - - -- case EXP of { ALTS } - , do pTok KCase - x <- pExp - pTok KOf - pTok KBraceBra - alts <- P.sepEndBy1 pAlt (pTok KSemiColon) - pTok KBraceKet - return $ XCase () x alts - - - -- weakeff [TYPE] in EXP - , do pTok KWeakEff - pTok KSquareBra - t <- T.pType - pTok KSquareKet - pTok KIn - x <- pExp - return $ XCast () (CastWeakenEffect t) x - - - -- weakclo [TYPE] in EXP - , do pTok KWeakClo - pTok KSquareBra - t <- T.pType - pTok KSquareKet - pTok KIn - x <- pExp - return $ XCast () (CastWeakenClosure t) x - - - -- purify in EXP - , do pTok KPurify - pTok KAngleBra - w <- pWitness - pTok KAngleKet - pTok KIn - x <- pExp - return $ XCast () (CastPurify w) x - - - -- forget in EXP - , do pTok KForget - pTok KAngleBra - w <- pWitness - pTok KAngleKet - pTok KIn - x <- pExp - return $ XCast () (CastForget w) x - - -- APP - , do pExpApp - ] - - "an expression" - - --- Applications. -pExpApp :: Ord n => Parser n (Exp () n) -pExpApp - = do x1 <- pExp0 - - P.choice - [ do xs <- liftM concat $ P.many1 pArgs - return $ foldl (XApp ()) x1 xs - - , return x1] - - "an expression or application" - - --- Comp, Witness or Spec arguments. -pArgs :: Ord n => Parser n [Exp () n] -pArgs - = P.choice - -- [TYPE] - [ do pTok KSquareBra - t <- T.pType - pTok KSquareKet - return [XType t] - - -- [: TYPE0 TYPE0 ... :] - , do pTok KSquareColonBra - ts <- P.many1 T.pTypeAtom - pTok KSquareColonKet - return $ map XType ts - - -- - , do pTok KAngleBra - w <- pWitness - pTok KAngleKet - return [XWitness w] - - -- <: WITNESS0 WITNESS0 ... :> - , do pTok KAngleColonBra - ws <- P.many1 pWitnessAtom - pTok KAngleColonKet - return $ map XWitness ws - - -- EXP0 - , do x <- pExp0 - return [x] - ] - "a type, witness or expression argument" - - --- Atomics -pExp0 :: Ord n => Parser n (Exp () n) -pExp0 - = P.choice - -- (EXP2) - [ do pTok KRoundBra - t <- pExp - pTok KRoundKet - return $ t - - -- Named constructors - , do con <- pCon - return $ XCon () (UName con (T.tBot T.kData)) - - -- Literals - , do lit <- pLit - return $ XCon () (UName lit (T.tBot T.kData)) - - -- Debruijn indices - , do i <- T.pIndex - return $ XVar () (UIx i (T.tBot T.kData)) - - -- Variables - , do var <- pVar - return $ XVar () (UName var (T.tBot T.kData)) - ] - - "a variable, constructor, or parenthesised type" - - --- Case alternatives. -pAlt :: Ord n => Parser n (Alt () n) -pAlt - = do p <- pPat - pTok KArrowDash - x <- pExp - return $ AAlt p x - - --- Patterns. -pPat :: Ord n => Parser n (Pat n) -pPat - = P.choice - [ -- Wildcard - do pTok KUnderscore - return $ PDefault - - -- LIT - , do nLit <- pLit - return $ PData (UName nLit (T.tBot T.kData)) [] - - -- CON BIND BIND ... - , do nCon <- pCon - bs <- P.many pBindPat - return $ PData (UName nCon (T.tBot T.kData)) bs] - - --- Binds in patterns can have no type annotation, --- or can have an annotation if the whole thing is in parens. -pBindPat :: Ord n => Parser n (Bind n) -pBindPat - = P.choice - -- Plain binder. - [ do b <- T.pBinder - return $ T.makeBindFromBinder b (T.tBot T.kData) - - -- Binder with type, wrapped in parens. - , do pTok KRoundBra - b <- T.pBinder - pTok KColon - t <- T.pType - pTok KRoundKet - return $ T.makeBindFromBinder b t - ] - - --- Bindings ------------------------------------------------------------------- --- | A binding for let expression. -pLetBinding :: Ord n => Parser n (LetMode n, Bind n, Exp () n) -pLetBinding - = do b <- T.pBinder - - P.choice - [ do -- Binding with full type signature. - -- BINDER : TYPE = EXP - pTok KColon - t <- T.pType - mode <- pLetMode - pTok KEquals - xBody <- pExp - - return $ (mode, T.makeBindFromBinder b t, xBody) - - - , do -- Non-function binding with no type signature. - -- This form can't be used with letrec as we can't use it - -- to build the full type sig for the let-bound variable. - -- BINDER = EXP - mode <- pLetMode - pTok KEquals - xBody <- pExp - let t = T.tBot T.kData - return $ (mode, T.makeBindFromBinder b t, xBody) - - - , do -- Binding using function syntax. - ps <- liftM concat - $ P.many pBindParamSpec - - P.choice - [ do -- Function syntax with a return type. - -- We can make the full type sig for the let-bound variable. - -- BINDER PARAM1 PARAM2 .. PARAMN : TYPE = EXP - pTok KColon - tBody <- T.pType - mode <- pLetMode - pTok KEquals - xBody <- pExp - - let x = expOfParams () ps xBody - let t = funTypeOfParams ps tBody - return (mode, T.makeBindFromBinder b t, x) - - -- Function syntax with no return type. - -- We can't make the type sig for the let-bound variable, - -- but we can create lambda abstractions with the given - -- parameter types. - -- BINDER PARAM1 PARAM2 .. PARAMN = EXP - , do mode <- pLetMode - pTok KEquals - xBody <- pExp - - let x = expOfParams () ps xBody - let t = T.tBot T.kData - return (mode, T.makeBindFromBinder b t, x) ] - ] - --- | Parse a let mode specifier. --- Only allow the lazy specifier with non-recursive bindings. --- We don't support value recursion, so the right of all recursive --- bindings must be explicit lambda abstractions anyway, so there's --- no point suspending them. -pLetMode :: Ord n => Parser n (LetMode n) -pLetMode - = do P.choice - -- lazy - [ do pTok KLazy - - P.choice - [ do pTok KAngleBra - w <- pWitness - pTok KAngleKet - return $ LetLazy (Just w) - - , do return $ LetLazy Nothing ] - - , do return $ LetStrict ] - - --- | Letrec bindings must have a full type signature, --- or use function syntax with a return type so that we can make one. -pLetRecBinding :: Ord n => Parser n (Bind n, Exp () n) -pLetRecBinding - = do b <- T.pBinder - - P.choice - [ do -- Binding with full type signature. - -- BINDER : TYPE = EXP - pTok KColon - t <- T.pType - pTok KEquals - xBody <- pExp - - return $ (T.makeBindFromBinder b t, xBody) - - - , do -- Binding using function syntax. - -- BINDER PARAM1 PARAM2 .. PARAMN : TYPE = EXP - ps <- liftM concat - $ P.many pBindParamSpec - - pTok KColon - tBody <- T.pType - let t = funTypeOfParams ps tBody - - pTok KEquals - xBody <- pExp - let x = expOfParams () ps xBody - - return (T.makeBindFromBinder b t, x) ] - - --- | Parse a parameter specification. --- --- [BIND1 BIND2 .. BINDN : TYPE] --- or (BIND : TYPE) --- or (BIND : TYPE) { EFFECT | CLOSURE } --- -pBindParamSpec :: Ord n => Parser n [ParamSpec n] -pBindParamSpec - = P.choice - -- Type parameter - -- [BIND1 BIND2 .. BINDN : TYPE] - [ do pTok KSquareBra - bs <- P.many1 T.pBinder - pTok KColon - t <- T.pType - pTok KSquareKet - return [ ParamType b - | b <- zipWith T.makeBindFromBinder bs (repeat t)] - - - -- Witness parameter - -- - , do pTok KAngleBra - b <- T.pBinder - pTok KColon - t <- T.pType - pTok KAngleKet - return [ ParamWitness $ T.makeBindFromBinder b t] - - -- Value parameter - -- (BIND : TYPE) - -- (BIND : TYPE) { TYPE | TYPE } - , do pTok KRoundBra - b <- T.pBinder - pTok KColon - t <- T.pType - pTok KRoundKet - - (eff, clo) - <- P.choice - [ do pTok KBraceBra - eff' <- T.pType - pTok KBar - clo' <- T.pType - pTok KBraceKet - return (eff', clo') - - , do return (T.tBot T.kEffect, T.tBot T.kClosure) ] - - - return $ [ParamValue (T.makeBindFromBinder b t) eff clo] - ] - - --- | Specification of a function parameter. --- We can determine the contribution to the type of the function, --- as well as its expression based on the parameter. -data ParamSpec n - = ParamType (Bind n) - | ParamWitness (Bind n) - | ParamValue (Bind n) (Type n) (Type n) - - --- | Build the type of a function from specifications of its parameters, --- and the type of the body. -funTypeOfParams - :: [ParamSpec n] -- ^ Spec of parameters. - -> Type n -- ^ Type of body. - -> Type n -- ^ Type of whole function. - -funTypeOfParams [] tBody = tBody -funTypeOfParams (p:ps) tBody - = case p of - ParamType b - -> TForall b - $ funTypeOfParams ps tBody - - ParamWitness b - -> T.tImpl (T.typeOfBind b) - $ funTypeOfParams ps tBody - - ParamValue b eff clo - -> T.tFun (T.typeOfBind b) eff clo - $ funTypeOfParams ps tBody - - --- | Build the expression of a function from specifications of its parameters, --- and the expression for the body. -expOfParams - :: a - -> [ParamSpec n] -- ^ Spec of parameters. - -> Exp a n -- ^ Body of function. - -> Exp a n -- ^ Expression of whole function. - -expOfParams _ [] xBody = xBody -expOfParams a (p:ps) xBody - = case p of - ParamType b - -> XLAM a b $ expOfParams a ps xBody - - ParamWitness b - -> XLam a b $ expOfParams a ps xBody - - ParamValue b _ _ - -> XLam a b $ expOfParams a ps xBody - - - --- Witnesses ------------------------------------------------------------------ --- | Parse a witness expression. -pWitness :: Ord n => Parser n (Witness n) -pWitness = pWitnessJoin - - --- Witness Joining -pWitnessJoin :: Ord n => Parser n (Witness n) -pWitnessJoin - -- WITNESS or WITNESS & WITNESS - = do w1 <- pWitnessApp - P.choice - [ do pTok KAmpersand - w2 <- pWitnessJoin - return (WJoin w1 w2) - - , do return w1 ] - - --- Applications -pWitnessApp :: Ord n => Parser n (Witness n) -pWitnessApp - = do (x:xs) <- P.many1 pWitnessArg - return $ foldl WApp x xs - - "a witness expression or application" - - --- Function argument -pWitnessArg :: Ord n => Parser n (Witness n) -pWitnessArg - = P.choice - [ -- [TYPE] - do pTok KSquareBra - t <- T.pType - pTok KSquareKet - return $ WType t - - -- WITNESS - , do pWitnessAtom ] - - --- Atomics -pWitnessAtom :: Ord n => Parser n (Witness n) -pWitnessAtom - = P.choice - -- (WITNESS) - [ do pTok KRoundBra - w <- pWitness - pTok KRoundKet - return $ w - - -- Named constructors - , do con <- pCon - return $ WCon (WiConBound $ UName con (T.tBot T.kWitness)) - - -- Baked-in witness constructors. - , do wb <- pWbCon - return $ WCon (WiConBuiltin wb) - - - -- Debruijn indices - , do i <- T.pIndex - return $ WVar (UIx i (T.tBot T.kWitness)) - - -- Variables - , do var <- pVar - return $ WVar (UName var (T.tBot T.kWitness)) ] + ( Parser - "a witness" + -- * Modules + , pModule + -- * Expressions + , pExp + , pExpApp + , pExpAtom -------------------------------------------------------------------------------- --- | Parse a builtin named `WiCon` -pWbCon :: Parser n WbCon -pWbCon = P.pTokMaybe f - where f (KA (KWbConBuiltin wb)) = Just wb - f _ = Nothing + -- * Types + , pType + , pTypeApp + , pTypeAtom + -- * Witnesses + , pWitness + , pWitnessApp + , pWitnessAtom --- | Parse a variable name -pVar :: Parser n n -pVar = P.pTokMaybe f - where f (KN (KVar n)) = Just n - f _ = Nothing + -- * Constructors + , pCon + , pLit + -- * Variables + , pBinder + , pIndex + , pVar + , pName --- | Parse a constructor name -pCon :: Parser n n -pCon = P.pTokMaybe f - where f (KN (KCon n)) = Just n - f _ = Nothing + -- * Raw Tokens + , pTok + , pTokAs) +where +import DDC.Core.Parser.Base +import DDC.Core.Parser.Witness +import DDC.Core.Parser.Type +import DDC.Core.Parser.Exp +import DDC.Core.Parser.Module --- | Parse a literal -pLit :: Parser n n -pLit = P.pTokMaybe f - where f (KN (KLit n)) = Just n - f _ = Nothing diff --git a/DDC/Core/Parser/Base.hs b/DDC/Core/Parser/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Parser/Base.hs @@ -0,0 +1,98 @@ + +module DDC.Core.Parser.Base + ( Parser + , pWbCon + , pModuleName + , pQualName + , pName + , pCon + , pLit + , pIndex + , pVar + , pTok + , pTokAs) +where +import DDC.Base.Pretty +import DDC.Core.Module +import DDC.Core.Exp +import DDC.Core.Lexer.Tokens +import DDC.Base.Parser (()) +import qualified DDC.Base.Parser as P + + +-- | A parser of core language tokens. +type Parser n a + = P.Parser (Tok n) a + + +-- | Parse a builtin named `WiCon` +pWbCon :: Parser n WbCon +pWbCon = P.pTokMaybe f + where f (KA (KWbConBuiltin wb)) = Just wb + f _ = Nothing + + +-- | Parse a module name. +-- +--- ISSUE #273: Handle hierarchical module names. +-- Accept hierachical names, and reject hashes at the end of a name. +-- Hashes can be at the end of constructor name, but not module names. +pModuleName :: Pretty n => Parser n ModuleName +pModuleName = P.pTokMaybe f + where f (KN (KCon n)) = Just $ ModuleName [renderPlain $ ppr n] + f _ = Nothing + + +-- | Parse a qualified variable or constructor name. +pQualName :: Pretty n => Parser n (QualName n) +pQualName + = do mn <- pModuleName + pTok KDot + n <- pName + return $ QualName mn n + + +-- | Parse a constructor or variable name. +pName :: Parser n n +pName = P.choice [pCon, pVar] + + +-- | Parse a constructor name. +pCon :: Parser n n +pCon = P.pTokMaybe f + where f (KN (KCon n)) = Just n + f _ = Nothing + + +-- | Parse a literal +pLit :: Parser n n +pLit = P.pTokMaybe f + where f (KN (KLit n)) = Just n + f _ = Nothing + + +-- | Parse a variable. +pVar :: Parser n n +pVar = P.pTokMaybe f + "a variable" + where f (KN (KVar n)) = Just n + f _ = Nothing + + +-- | Parse a deBruijn index +pIndex :: Parser n Int +pIndex = P.pTokMaybe f + "an index" + where f (KA (KIndex i)) = Just i + f _ = Nothing + + +-- | Parse an atomic token. +pTok :: TokAtom -> Parser n () +pTok k = P.pTok (KA k) + + +-- | Parse an atomic token and return some value. +pTokAs :: TokAtom -> a -> Parser n a +pTokAs k x = P.pTokAs (KA k) x + diff --git a/DDC/Core/Parser/Exp.hs b/DDC/Core/Parser/Exp.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Parser/Exp.hs @@ -0,0 +1,547 @@ + +-- | Core language parser. +module DDC.Core.Parser.Exp + ( pExp + , pExpApp + , pExpAtom + , pLets + , pType + , pTypeApp + , pTypeAtom) +where +import DDC.Core.Exp +import DDC.Core.Parser.Witness +import DDC.Core.Parser.Param +import DDC.Core.Parser.Type +import DDC.Core.Parser.Base +import DDC.Core.Lexer.Tokens +import DDC.Core.Compounds +import DDC.Base.Parser (()) +import qualified DDC.Base.Parser as P +import qualified DDC.Type.Compounds as T +import Control.Monad.Error + + +-- Expressions ---------------------------------------------------------------- +-- | Parse a core language expression. +pExp :: Ord n => Parser n (Exp () n) +pExp + = P.choice + -- Level-0 lambda abstractions + -- \(x1 x2 ... : TYPE) (y1 y2 ... : TYPE) ... . EXP + [ do pTok KBackSlash + + bs <- liftM concat + $ P.many1 + $ do pTok KRoundBra + bs' <- P.many1 pBinder + pTok KColon + t <- pType + pTok KRoundKet + return (map (\b -> T.makeBindFromBinder b t) bs') + + pTok KDot + xBody <- pExp + return $ foldr (XLam ()) xBody bs + + -- Level-1 lambda abstractions. + -- /\(x1 x2 ... : TYPE) (y1 y2 ... : TYPE) ... . EXP + , do pTok KBigLambda + + bs <- liftM concat + $ P.many1 + $ do pTok KRoundBra + bs' <- P.many1 pBinder + pTok KColon + t <- pType + pTok KRoundKet + return (map (\b -> T.makeBindFromBinder b t) bs') + + pTok KDot + xBody <- pExp + return $ foldr (XLAM ()) xBody bs + + + -- let expression + , do lts <- pLets + pTok KIn + x2 <- pExp + return $ XLet () lts x2 + + + -- do { STMTS } + -- Sugar for a let-expression. + , do pTok KDo + pTok KBraceBra + xx <- pStmts + pTok KBraceKet + return $ xx + + + -- withregion CON in EXP + , do pTok KWithRegion + u <- P.choice + [ do n <- pVar + return $ UName n + + , do n <- pCon + return $ UPrim n kRegion] + pTok KIn + x <- pExp + return $ XLet () (LWithRegion u) x + + + -- case EXP of { ALTS } + , do pTok KCase + x <- pExp + pTok KOf + pTok KBraceBra + alts <- P.sepEndBy1 pAlt (pTok KSemiColon) + pTok KBraceKet + return $ XCase () x alts + + + -- match PAT <- EXP else EXP in EXP + -- Sugar for a case-expression. + , do pTok KMatch + p <- pPat + pTok KArrowDashLeft + x1 <- pExp + pTok KElse + x2 <- pExp + pTok KIn + x3 <- pExp + return $ XCase () x1 [AAlt p x3, AAlt PDefault x2] + + + -- weakeff [TYPE] in EXP + , do pTok KWeakEff + pTok KSquareBra + t <- pType + pTok KSquareKet + pTok KIn + x <- pExp + return $ XCast () (CastWeakenEffect t) x + + + -- weakclo {EXP;+} in EXP + , do pTok KWeakClo + pTok KBraceBra + xs <- liftM concat $ P.sepEndBy1 pArgs (pTok KSemiColon) + pTok KBraceKet + pTok KIn + x <- pExp + return $ XCast () (CastWeakenClosure xs) x + + + -- purify in EXP + , do pTok KPurify + pTok KAngleBra + w <- pWitness + pTok KAngleKet + pTok KIn + x <- pExp + return $ XCast () (CastPurify w) x + + + -- forget in EXP + , do pTok KForget + pTok KAngleBra + w <- pWitness + pTok KAngleKet + pTok KIn + x <- pExp + return $ XCast () (CastForget w) x + + -- APP + , do pExpApp + ] + + "an expression" + + +-- Applications. +pExpApp :: Ord n => Parser n (Exp () n) +pExpApp + = do x1 <- pExpAtom + + P.choice + [ do xs <- liftM concat $ P.many1 pArgs + return $ foldl (XApp ()) x1 xs + + , return x1] + + "an expression or application" + + +-- Comp, Witness or Spec arguments. +pArgs :: Ord n => Parser n [Exp () n] +pArgs + = P.choice + -- [TYPE] + [ do pTok KSquareBra + t <- pType + pTok KSquareKet + return [XType t] + + -- [: TYPE0 TYPE0 ... :] + , do pTok KSquareColonBra + ts <- P.many1 pTypeAtom + pTok KSquareColonKet + return $ map XType ts + + -- + , do pTok KAngleBra + w <- pWitness + pTok KAngleKet + return [XWitness w] + + -- <: WITNESS0 WITNESS0 ... :> + , do pTok KAngleColonBra + ws <- P.many1 pWitnessAtom + pTok KAngleColonKet + return $ map XWitness ws + + -- EXP0 + , do x <- pExpAtom + return [x] + ] + "a type, witness or expression argument" + + +-- | Parse a variable, constructor or parenthesised expression. +pExpAtom :: Ord n => Parser n (Exp () n) +pExpAtom + = P.choice + -- (EXP2) + [ do pTok KRoundBra + t <- pExp + pTok KRoundKet + return $ t + + -- The unit data constructor. + , do pTok KDaConUnit + return $ XCon () dcUnit + + -- Named algebraic constructors. + -- We just fill-in the type with tBot for now, and leave it to + -- the spreader to attach the real type. + , do con <- pCon + return $ XCon () (mkDaConAlg con (T.tBot T.kData)) + + -- Literals. + -- We just fill-in the type with tBot for now, and leave it to + -- the spreader to attach the real type. + -- We also set the literal as being algebraic, which may not be + -- true (as for Floats). The spreader also needs to fix this. + , do lit <- pLit + return $ XCon () (mkDaConAlg lit (T.tBot T.kData)) + + -- Debruijn indices + , do i <- pIndex + return $ XVar () (UIx i) + + -- Variables + , do var <- pVar + return $ XVar () (UName var) + ] + + "a variable, constructor, or parenthesised type" + + +-- Alternatives --------------------------------------------------------------- +-- Case alternatives. +pAlt :: Ord n => Parser n (Alt () n) +pAlt + = do p <- pPat + pTok KArrowDash + x <- pExp + return $ AAlt p x + + +-- Patterns. +pPat :: Ord n => Parser n (Pat n) +pPat + = P.choice + [ -- Wildcard + do pTok KUnderscore + return $ PDefault + + -- LIT + , do nLit <- pLit + return $ PData (mkDaConAlg nLit (T.tBot T.kData)) [] + + -- Unit + , do pTok KDaConUnit + return $ PData dcUnit [] + + -- CON BIND BIND ... + , do nCon <- pCon + bs <- P.many pBindPat + return $ PData (mkDaConAlg nCon (T.tBot T.kData)) bs] + + +-- Binds in patterns can have no type annotation, +-- or can have an annotation if the whole thing is in parens. +pBindPat :: Ord n => Parser n (Bind n) +pBindPat + = P.choice + -- Plain binder. + [ do b <- pBinder + return $ T.makeBindFromBinder b (T.tBot T.kData) + + -- Binder with type, wrapped in parens. + , do pTok KRoundBra + b <- pBinder + pTok KColon + t <- pType + pTok KRoundKet + return $ T.makeBindFromBinder b t + ] + + +-- Bindings ------------------------------------------------------------------- +pLets :: Ord n => Parser n (Lets () n) +pLets + = P.choice + [ -- non-recursive let. + do pTok KLet + (mode1, b1, x1) <- pLetBinding + return $ LLet mode1 b1 x1 + + -- recursive let. + , do pTok KLetRec + P.choice + -- Multiple bindings in braces + [ do pTok KBraceBra + lets <- P.sepEndBy1 pLetRecBinding (pTok KSemiColon) + pTok KBraceKet + return $ LRec lets + + -- A single binding without braces. + , do ll <- pLetRecBinding + return $ LRec [ll] + ] + + -- Local region binding. + -- letregions [BINDER] with { BINDER : TYPE ... } in EXP + -- letregions [BINDER] in EXP + , do pTok KLetRegions + brs <- P.manyTill pBinder (P.try $ P.lookAhead $ P.choice [pTok KIn, pTok KWith]) + let bs = map (flip T.makeBindFromBinder T.kRegion) brs + pLetWits bs + + , do pTok KLetRegion + br <- pBinder + let b = T.makeBindFromBinder br T.kRegion + pLetWits [b] + + ] + + +pLetWits :: Ord n => [Bind n] -> Parser n (Lets () n) +pLetWits bs + = P.choice + [ do pTok KWith + pTok KBraceBra + wits <- P.sepBy + (do b <- pBinder + pTok KColon + t <- pTypeApp + return $ T.makeBindFromBinder b t) + (pTok KSemiColon) + pTok KBraceKet + return (LLetRegions bs wits) + + , do return (LLetRegions bs []) + ] + + +-- | A binding for let expression. +pLetBinding :: Ord n => Parser n (LetMode n, Bind n, Exp () n) +pLetBinding + = do b <- pBinder + + P.choice + [ do -- Binding with full type signature. + -- BINDER : TYPE = EXP + pTok KColon + t <- pType + mode <- pLetMode + pTok KEquals + xBody <- pExp + + return $ (mode, T.makeBindFromBinder b t, xBody) + + + , do -- Non-function binding with no type signature. + -- This form can't be used with letrec as we can't use it + -- to build the full type sig for the let-bound variable. + -- BINDER = EXP + mode <- pLetMode + pTok KEquals + xBody <- pExp + let t = T.tBot T.kData + return $ (mode, T.makeBindFromBinder b t, xBody) + + + , do -- Binding using function syntax. + ps <- liftM concat + $ P.many pBindParamSpec + + P.choice + [ do -- Function syntax with a return type. + -- We can make the full type sig for the let-bound variable. + -- BINDER PARAM1 PARAM2 .. PARAMN : TYPE = EXP + pTok KColon + tBody <- pType + mode <- pLetMode + pTok KEquals + xBody <- pExp + + let x = expOfParams () ps xBody + let t = funTypeOfParams ps tBody + return (mode, T.makeBindFromBinder b t, x) + + -- Function syntax with no return type. + -- We can't make the type sig for the let-bound variable, + -- but we can create lambda abstractions with the given + -- parameter types. + -- BINDER PARAM1 PARAM2 .. PARAMN = EXP + , do mode <- pLetMode + pTok KEquals + xBody <- pExp + + let x = expOfParams () ps xBody + let t = T.tBot T.kData + return (mode, T.makeBindFromBinder b t, x) ] + ] + +-- | Parse a let mode specifier. +-- Only allow the lazy specifier with non-recursive bindings. +-- We don't support value recursion, so the right of all recursive +-- bindings must be explicit lambda abstractions anyway, so there's +-- no point suspending them. +pLetMode :: Ord n => Parser n (LetMode n) +pLetMode + = do P.choice + -- lazy + [ do pTok KLazy + + P.choice + [ do pTok KAngleBra + w <- pWitness + pTok KAngleKet + return $ LetLazy (Just w) + + , do return $ LetLazy Nothing ] + + , do return $ LetStrict ] + + +-- | Letrec bindings must have a full type signature, +-- or use function syntax with a return type so that we can make one. +pLetRecBinding :: Ord n => Parser n (Bind n, Exp () n) +pLetRecBinding + = do b <- pBinder + + P.choice + [ do -- Binding with full type signature. + -- BINDER : TYPE = EXP + pTok KColon + t <- pType + pTok KEquals + xBody <- pExp + + return $ (T.makeBindFromBinder b t, xBody) + + + , do -- Binding using function syntax. + -- BINDER PARAM1 PARAM2 .. PARAMN : TYPE = EXP + ps <- liftM concat + $ P.many pBindParamSpec + + pTok KColon + tBody <- pType + let t = funTypeOfParams ps tBody + + pTok KEquals + xBody <- pExp + let x = expOfParams () ps xBody + + return (T.makeBindFromBinder b t, x) ] + + +-- Statements ----------------------------------------------------------------- +data Stmt n + = StmtBind (Bind n) (Exp () n) + | StmtMatch (Pat n) (Exp () n) (Exp () n) + | StmtNone (Exp () n) + + +-- | Parse a single statement. +pStmt :: Ord n => Parser n (Stmt n) +pStmt + = P.choice + [ -- BINDER = EXP ; + -- We need the 'try' because a VARIABLE binders can also be parsed + -- as a function name in a non-binding statement. + -- + P.try $ + do br <- pBinder + pTok KEquals + x1 <- pExp + let t = T.tBot T.kData + let b = T.makeBindFromBinder br t + return $ StmtBind b x1 + + -- PAT <- EXP else EXP; + -- Sugar for a case-expression. + -- We need the 'try' because the PAT can also be parsed + -- as a function name in a non-binding statement. + , P.try $ + do p <- pPat + pTok KArrowDashLeft + x1 <- pExp + pTok KElse + x2 <- pExp + return $ StmtMatch p x1 x2 + + -- EXP + , do x <- pExp + return $ StmtNone x + ] + + +-- | Parse some statements. +pStmts :: Ord n => Parser n (Exp () n) +pStmts + = do stmts <- P.sepEndBy1 pStmt (pTok KSemiColon) + case makeStmts stmts of + Nothing -> P.unexpected "do-block must end with a statement" + Just x -> return x + + +-- | Make an expression from some statements. +makeStmts :: [Stmt n] -> Maybe (Exp () n) +makeStmts ss + = case ss of + [StmtNone x] + -> Just x + + StmtNone x1 : rest + | Just x2 <- makeStmts rest + -> Just $ XLet () (LLet LetStrict (BNone (T.tBot T.kData)) x1) x2 + + StmtBind b x1 : rest + | Just x2 <- makeStmts rest + -> Just $ XLet () (LLet LetStrict b x1) x2 + + StmtMatch p x1 x2 : rest + | Just x3 <- makeStmts rest + -> Just $ XCase () x1 + [ AAlt p x3 + , AAlt PDefault x2] + + _ -> Nothing + diff --git a/DDC/Core/Parser/Lexer.hs b/DDC/Core/Parser/Lexer.hs deleted file mode 100644 --- a/DDC/Core/Parser/Lexer.hs +++ /dev/null @@ -1,293 +0,0 @@ - --- | Reference lexer for core langauge parser. Slow but Simple. -module DDC.Core.Parser.Lexer - ( -- * Constructors - isConName, isConStart, isConBody - , readTwConBuiltin - , readTcConBuiltin - , readWbConBuiltin - , readCon - - -- * Variables - , isVarName, isVarStart, isVarBody - , readVar - - -- * Lexer - , lexExp) -where -import DDC.Base.Lexer -import DDC.Core.Exp -import DDC.Core.Parser.Tokens -import Data.Char - - --- WbCon names ---------------------------------------------------------------- --- | Read a `WbCon`. -readWbConBuiltin :: String -> Maybe WbCon -readWbConBuiltin ss - = case ss of - "pure" -> Just WbConPure - "empty" -> Just WbConEmpty - "use" -> Just WbConUse - "read" -> Just WbConRead - "alloc" -> Just WbConAlloc - _ -> Nothing - - --- | Textual keywords in the core language. -keywords :: [(String, Tok n)] -keywords - = [ ("in", KA KIn) - , ("of", KA KOf) - , ("letrec", KA KLetRec) - , ("letregion", KA KLetRegion) - , ("withregion", KA KWithRegion) - , ("let", KA KLet) - , ("lazy", KA KLazy) - , ("case", KA KCase) - , ("purify", KA KPurify) - , ("forget", KA KForget) - , ("weakeff", KA KWeakEff) - , ("weakclo", KA KWeakClo) - , ("with", KA KWith) - , ("where", KA KWhere) ] - - -------------------------------------------------------------------------------- --- | Lex a string into tokens. --- -lexExp :: Int -> String -> [Token (Tok String)] -lexExp lineStart str - = lexWord lineStart 1 str - where - - lexWord :: Int -> Int -> String -> [Token (Tok String)] - lexWord line column w - = let tok t = Token t (SourcePos Nothing line column) - tokA = tok . KA - tokN = tok . KN - - lexMore n rest - = lexWord line (column + n) rest - - in case w of - [] -> [] - - ' ' : w' -> lexMore 1 w' - '\t' : w' -> lexMore 8 w' - '\n' : w' -> lexWord (line + 1) 1 w' - - - -- The unit data constructor - '(' : ')' : w' -> tokN (KCon "()") : lexMore 2 w' - - -- Compound Parens - '[' : ':' : w' -> tokA KSquareColonBra : lexMore 2 w' - ':' : ']' : w' -> tokA KSquareColonKet : lexMore 2 w' - '<' : ':' : w' -> tokA KAngleColonBra : lexMore 2 w' - ':' : '>' : w' -> tokA KAngleColonKet : lexMore 2 w' - - -- Function Constructors - '~' : '>' : w' -> tokA KArrowTilde : lexMore 2 w' - '-' : '>' : w' -> tokA KArrowDash : lexMore 2 w' - '=' : '>' : w' -> tokA KArrowEquals : lexMore 2 w' - - -- Compound symbols - ':' : ':' : w' -> tokA KColonColon : lexMore 2 w' - '/' : '\\' : w' -> tokA KBigLambda : lexMore 2 w' - - -- Debruijn indices - '^' : cs - | (ds, rest) <- span isDigit cs - , length ds >= 1 - -> tokA (KIndex (read ds)) : lexMore (1 + length ds) rest - - -- Parens - '(' : w' -> tokA KRoundBra : lexMore 1 w' - ')' : w' -> tokA KRoundKet : lexMore 1 w' - '[' : w' -> tokA KSquareBra : lexMore 1 w' - ']' : w' -> tokA KSquareKet : lexMore 1 w' - '{' : w' -> tokA KBraceBra : lexMore 1 w' - '}' : w' -> tokA KBraceKet : lexMore 1 w' - '<' : w' -> tokA KAngleBra : lexMore 1 w' - '>' : w' -> tokA KAngleKet : lexMore 1 w' - - -- Punctuation - '.' : w' -> tokA KDot : lexMore 1 w' - '|' : w' -> tokA KBar : lexMore 1 w' - '^' : w' -> tokA KHat : lexMore 1 w' - '+' : w' -> tokA KPlus : lexMore 1 w' - ':' : w' -> tokA KColon : lexMore 1 w' - ',' : w' -> tokA KComma : lexMore 1 w' - '\\' : w' -> tokA KBackSlash : lexMore 1 w' - ';' : w' -> tokA KSemiColon : lexMore 1 w' - '_' : w' -> tokA KUnderscore : lexMore 1 w' - '=' : w' -> tokA KEquals : lexMore 1 w' - '&' : w' -> tokA KAmpersand : lexMore 1 w' - '-' : w' -> tokA KDash : lexMore 1 w' - - -- Bottoms - '!' : '0' : w' -> tokA KBotEffect : lexMore 2 w' - '$' : '0' : w' -> tokA KBotClosure : lexMore 2 w' - - -- Sort Constructors - '*' : '*' : w' -> tokA KSortComp : lexMore 2 w' - '@' : '@' : w' -> tokA KSortProp : lexMore 2 w' - - -- Kind Constructors - '*' : w' -> tokA KKindValue : lexMore 1 w' - '%' : w' -> tokA KKindRegion : lexMore 1 w' - '!' : w' -> tokA KKindEffect : lexMore 1 w' - '$' : w' -> tokA KKindClosure : lexMore 1 w' - '@' : w' -> tokA KKindWitness : lexMore 1 w' - - -- Literal values - c : cs - | isDigit c - , (body, rest) <- span isDigit cs - -> tokN (KLit (c:body)) : lexMore (length (c:body)) rest - - -- Named Constructors - c : cs - | isConStart c - , (body, rest) <- span isConBody cs - , (body', rest') <- case rest of - '#' : rest' -> (body ++ "#", rest') - _ -> (body, rest) - -> let readNamedCon s - | Just twcon <- readTwConBuiltin s - = tokA (KTwConBuiltin twcon) : lexMore (length s) rest' - - | Just tccon <- readTcConBuiltin s - = tokA (KTcConBuiltin tccon) : lexMore (length s) rest' - - | Just con <- readCon s - = tokN (KCon con) : lexMore (length s) rest' - - | otherwise - = [tok (KJunk c)] - - in readNamedCon (c : body') - - -- Keywords, Named Variables and Witness constructors - c : cs - | isVarStart c - , (body, rest) <- span isVarBody cs - -> let readNamedVar s - | Just t <- lookup s keywords - = tok t : lexMore (length s) rest - - | Just wc <- readWbConBuiltin s - = tokA (KWbConBuiltin wc) : lexMore (length s) rest - - | Just v <- readVar s - = tokN (KVar v) : lexMore (length s) rest - - | otherwise - = [tok (KJunk c)] - - in readNamedVar (c : body) - - -- Error - c : _ -> [tok $ KJunk c] - - --- TyCon names ---------------------------------------------------------------- --- | String is a constructor name. -isConName :: String -> Bool -isConName str - = case str of - [] -> False - (c:cs) - | isConStart c - , and (map isConBody cs) - -> True - - | _ : _ <- cs - , isConStart c - , and (map isConBody (init cs)) - , last cs == '#' - -> True - - | otherwise - -> False - --- | Character can start a constructor name. -isConStart :: Char -> Bool -isConStart = isUpper - - --- | Charater can be part of a constructor body. -isConBody :: Char -> Bool -isConBody c = isUpper c || isLower c || isDigit c || c == '_' - - --- | Read a named `TwCon`. -readTwConBuiltin :: String -> Maybe TwCon -readTwConBuiltin ss - = case ss of - "Global" -> Just TwConGlobal - "DeepGlobal" -> Just TwConDeepGlobal - "Const" -> Just TwConConst - "DeepConst" -> Just TwConDeepConst - "Mutable" -> Just TwConMutable - "DeepMutable" -> Just TwConDeepMutable - "Lazy" -> Just TwConLazy - "HeadLazy" -> Just TwConHeadLazy - "Manifest" -> Just TwConManifest - "Pure" -> Just TwConPure - "Empty" -> Just TwConEmpty - _ -> Nothing - - --- | Read a builtin `TcCon` with a non-symbolic name, --- ie not '->'. -readTcConBuiltin :: String -> Maybe TcCon -readTcConBuiltin ss - = case ss of - "Read" -> Just TcConRead - "HeadRead" -> Just TcConHeadRead - "DeepRead" -> Just TcConDeepRead - "Write" -> Just TcConWrite - "DeepWrite" -> Just TcConDeepWrite - "Alloc" -> Just TcConAlloc - "DeepAlloc" -> Just TcConDeepAlloc - "Use" -> Just TcConUse - "DeepUse" -> Just TcConDeepUse - _ -> Nothing - - --- | Read a named, user defined `TcCon`. --- --- We won't know its kind, so fill this in with the Bottom element for --- computatation kinds (**0). -readCon :: String -> Maybe String -readCon ss - | isConName ss = Just ss - | otherwise = Nothing - - --- TyVar names ---------------------------------------------------------------- --- | String is a variable name. -isVarName :: String -> Bool -isVarName [] = False -isVarName (c:cs) = isVarStart c && (and $ map isVarBody cs) - - --- | Charater can start a variable name. -isVarStart :: Char -> Bool -isVarStart = isLower - - --- | Character can be part of a variable body. -isVarBody :: Char -> Bool -isVarBody c - = isUpper c || isLower c || isDigit c || c == '_' || c == '\'' - - --- | Read a named, user defined variable. -readVar :: String -> Maybe String -readVar ss - | isVarName ss = Just ss - | otherwise = Nothing - diff --git a/DDC/Core/Parser/Module.hs b/DDC/Core/Parser/Module.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Parser/Module.hs @@ -0,0 +1,125 @@ + +module DDC.Core.Parser.Module + (pModule) +where +import DDC.Core.Module +import DDC.Core.Exp +import DDC.Core.Parser.Type +import DDC.Core.Parser.Exp +import DDC.Core.Parser.Base +import DDC.Core.Lexer.Tokens +import DDC.Core.Compounds +import DDC.Base.Pretty +import qualified DDC.Base.Parser as P +import qualified Data.Map as Map + + +-- Module --------------------------------------------------------------------- +-- | Parse a core module. +pModule :: (Ord n, Pretty n) + => Parser n (Module () n) +pModule + = do pTok KModule + name <- pModuleName + + -- exports { SIG;+ } + tExports + <- P.choice + [do pTok KExports + pTok KBraceBra + sigs <- P.sepEndBy1 pTypeSig (pTok KSemiColon) + pTok KBraceKet + return sigs + + , return []] + + -- imports { SIG;+ } + tImportKindsTypes + <- P.choice + [do pTok KImports + pTok KBraceBra + importKinds <- P.sepEndBy pImportKindSpec (pTok KSemiColon) + importTypes <- P.sepEndBy pImportTypeSpec (pTok KSemiColon) + pTok KBraceKet + return (importKinds, importTypes) + + , return ([], [])] + + let (tImportKinds, tImportTypes) + = tImportKindsTypes + + pTok KWith + + -- LET;+ + lts <- P.sepBy1 pLets (pTok KIn) + + -- The body of the module consists of the top-level bindings wrapped + -- around a unit constructor place-holder. + let body = xLets () lts (xUnit ()) + + -- ISSUE #295: Check for duplicate exported names in module parser. + -- The names are added to a unique map, so later ones with the same + -- name will replace earlier ones. + return $ ModuleCore + { moduleName = name + , moduleExportKinds = Map.empty + , moduleExportTypes = Map.fromList tExports + , moduleImportKinds = Map.fromList tImportKinds + , moduleImportTypes = Map.fromList tImportTypes + , moduleBody = body } + + +-- | Parse a type signature. +pTypeSig :: Ord n => Parser n (n, Type n) +pTypeSig + = do var <- pVar + pTok KColonColon + t <- pType + return (var, t) + + +-- | Parse the type signature of an imported variable. +pImportKindSpec + :: (Ord n, Pretty n) + => Parser n (n, (QualName n, Kind n)) + +pImportKindSpec + = pTok KType + >> P.choice + [ -- Import with an explicit external name. + -- Module.varExternal with varLocal + do qn <- pQualName + pTok KWith + n <- pName + pTok KColonColon + k <- pType + return (n, (qn, k)) + + , do n <- pName + pTok KColonColon + k <- pType + return (n, (QualName (ModuleName []) n, k)) + ] + + +-- | Parse the type signature of an imported variable. +pImportTypeSpec + :: (Ord n, Pretty n) + => Parser n (n, (QualName n, Type n)) + +pImportTypeSpec + = P.choice + [ -- Import with an explicit external name. + -- Module.varExternal with varLocal + do qn <- pQualName + pTok KWith + n <- pName + pTok KColonColon + t <- pType + return (n, (qn, t)) + + , do n <- pName + pTok KColonColon + t <- pType + return (n, (QualName (ModuleName []) n, t)) + ] diff --git a/DDC/Core/Parser/Param.hs b/DDC/Core/Parser/Param.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Parser/Param.hs @@ -0,0 +1,122 @@ + +module DDC.Core.Parser.Param + ( ParamSpec (..) + , funTypeOfParams + , expOfParams + , pBindParamSpec) +where +import DDC.Core.Exp +import DDC.Core.Parser.Type +import DDC.Core.Parser.Base (Parser) +import DDC.Core.Lexer.Tokens +import qualified DDC.Base.Parser as P +import qualified DDC.Type.Compounds as T + + +-- | Specification of a function parameter. +-- We can determine the contribution to the type of the function, +-- as well as its expression based on the parameter. +data ParamSpec n + = ParamType (Bind n) + | ParamWitness (Bind n) + | ParamValue (Bind n) (Type n) (Type n) + + +-- | Build the type of a function from specifications of its parameters, +-- and the type of the body. +funTypeOfParams + :: [ParamSpec n] -- ^ Spec of parameters. + -> Type n -- ^ Type of body. + -> Type n -- ^ Type of whole function. + +funTypeOfParams [] tBody = tBody +funTypeOfParams (p:ps) tBody + = case p of + ParamType b + -> TForall b + $ funTypeOfParams ps tBody + + ParamWitness b + -> T.tImpl (T.typeOfBind b) + $ funTypeOfParams ps tBody + + ParamValue b eff clo + -> T.tFun (T.typeOfBind b) eff clo + $ funTypeOfParams ps tBody + + +-- | Build the expression of a function from specifications of its parameters, +-- and the expression for the body. +expOfParams + :: a + -> [ParamSpec n] -- ^ Spec of parameters. + -> Exp a n -- ^ Body of function. + -> Exp a n -- ^ Expression of whole function. + +expOfParams _ [] xBody = xBody +expOfParams a (p:ps) xBody + = case p of + ParamType b + -> XLAM a b $ expOfParams a ps xBody + + ParamWitness b + -> XLam a b $ expOfParams a ps xBody + + ParamValue b _ _ + -> XLam a b $ expOfParams a ps xBody + + +-- | Parse a parameter specification. +-- +-- [BIND1 BIND2 .. BINDN : TYPE] +-- or (BIND : TYPE) +-- or (BIND : TYPE) { EFFECT | CLOSURE } +-- +pBindParamSpec :: Ord n => Parser n [ParamSpec n] +pBindParamSpec + = P.choice + -- Type parameter + -- [BIND1 BIND2 .. BINDN : TYPE] + [ do pTok KSquareBra + bs <- P.many1 pBinder + pTok KColon + t <- pType + pTok KSquareKet + return [ ParamType b + | b <- zipWith T.makeBindFromBinder bs (repeat t)] + + + -- Witness parameter + -- + , do pTok KAngleBra + b <- pBinder + pTok KColon + t <- pType + pTok KAngleKet + return [ ParamWitness $ T.makeBindFromBinder b t] + + -- Value parameter + -- (BIND : TYPE) + -- (BIND : TYPE) { TYPE | TYPE } + , do pTok KRoundBra + b <- pBinder + pTok KColon + t <- pType + pTok KRoundKet + + (eff, clo) + <- P.choice + [ do pTok KBraceBra + eff' <- pType + pTok KBar + clo' <- pType + pTok KBraceKet + return (eff', clo') + + , do return (T.tBot T.kEffect, T.tBot T.kClosure) ] + + + return $ [ParamValue (T.makeBindFromBinder b t) eff clo] + ] + + diff --git a/DDC/Core/Parser/Tokens.hs b/DDC/Core/Parser/Tokens.hs deleted file mode 100644 --- a/DDC/Core/Parser/Tokens.hs +++ /dev/null @@ -1,263 +0,0 @@ - -module DDC.Core.Parser.Tokens - ( Tok (..) - , describeTok - , renameTok - - , TokAtom (..) - , describeTokAtom - - , TokNamed (..) - , describeTokNamed) -where -import DDC.Core.Pretty -import DDC.Core.Exp - - --- TokenFamily ---------------------------------------------------------------- --- | The family of a token. --- This is used to help generate parser error messages, --- so we can say ''the constructor Cons'' --- and ''the keyword case'' etc. -data TokenFamily - = Symbol - | Keyword - | Constructor - | Index - | Variable - - --- | Describe a token family, for parser error messages. -describeTokenFamily :: TokenFamily -> String -describeTokenFamily tf - = case tf of - Symbol -> "symbol" - Keyword -> "keyword" - Constructor -> "constructor" - Index -> "index" - Variable -> "variable" - - --- Tok ------------------------------------------------------------------------ --- | Tokens accepted by the core language parser. -data Tok n - -- Some junk symbol that isn't part of the language. - = KJunk Char - - -- An atomic token. - | KA !TokAtom - - -- A named token. - | KN !(TokNamed n) - deriving (Eq, Show) - - --- | Describe a token for parser error messages. -describeTok :: Pretty n => Tok n -> String -describeTok kk - = case kk of - KJunk c -> "character " ++ show c - KA ta -> describeTokAtom ta - KN tn -> describeTokNamed tn - - --- | Apply a function to all the names in a `Tok`. -renameTok - :: Ord n2 - => (n1 -> n2) -> Tok n1 -> Tok n2 - -renameTok f kk - = case kk of - KJunk s -> KJunk s - KA t -> KA t - KN t -> KN $ renameTokNamed f t - - --- TokAtom -------------------------------------------------------------------- --- | Atomic tokens, that don't contain user-defined names. -data TokAtom - -- parens - = KRoundBra - | KRoundKet - | KSquareBra - | KSquareKet - | KBraceBra - | KBraceKet - | KAngleBra - | KAngleKet - - -- compound parens - | KSquareColonBra - | KSquareColonKet - | KAngleColonBra - | KAngleColonKet - - -- punctuation - | KDot - | KBar - | KHat - | KPlus - | KColon - | KComma - | KBackSlash - | KSemiColon - | KUnderscore - | KEquals - | KAmpersand - | KDash - | KColonColon - | KBigLambda - - -- symbolic constructors - | KSortComp - | KSortProp - | KKindValue - | KKindRegion - | KKindEffect - | KKindClosure - | KKindWitness - | KArrowTilde - | KArrowDash - | KArrowEquals - - -- bottoms - | KBotEffect - | KBotClosure - - -- expression keywords - | KWith - | KWhere - | KIn - | KLet - | KLazy - | KLetRec - | KLetRegion - | KWithRegion - | KCase - | KOf - | KWeakEff - | KWeakClo - | KPurify - | KForget - - -- debruijn indices - | KIndex Int - - -- builtin names - | KTwConBuiltin TwCon - | KWbConBuiltin WbCon - | KTcConBuiltin TcCon - deriving (Eq, Show) - - --- | Describe a `TokAtom`, for parser error messages. -describeTokAtom :: TokAtom -> String -describeTokAtom ta - = let (family, str) = describeTokAtom' ta - in describeTokenFamily family ++ " " ++ show str - -describeTokAtom' :: TokAtom -> (TokenFamily, String) -describeTokAtom' ta - = case ta of - -- parens - KRoundBra -> (Symbol, "(") - KRoundKet -> (Symbol, ")") - KSquareBra -> (Symbol, "[") - KSquareKet -> (Symbol, "]") - KBraceBra -> (Symbol, "{") - KBraceKet -> (Symbol, "}") - KAngleBra -> (Symbol, "<") - KAngleKet -> (Symbol, ">") - - -- compound parens - KSquareColonBra -> (Symbol, "[:") - KSquareColonKet -> (Symbol, ":]") - KAngleColonBra -> (Symbol, "<:") - KAngleColonKet -> (Symbol, ":>") - - -- punctuation - KDot -> (Symbol, ".") - KBar -> (Symbol, "|") - KHat -> (Symbol, "^") - KPlus -> (Symbol, "+") - KColon -> (Symbol, ":") - KComma -> (Symbol, ",") - KBackSlash -> (Symbol, "\\") - KSemiColon -> (Symbol, ";") - KUnderscore -> (Symbol, "_") - KEquals -> (Symbol, "=") - KAmpersand -> (Symbol, "&") - KDash -> (Symbol, "-") - KColonColon -> (Symbol, "::") - KBigLambda -> (Symbol, "/\\") - - -- symbolic constructors - KSortComp -> (Constructor, "**") - KSortProp -> (Constructor, "@@") - KKindValue -> (Constructor, "*") - KKindRegion -> (Constructor, "%") - KKindEffect -> (Constructor, "!") - KKindClosure -> (Constructor, "$") - KKindWitness -> (Constructor, "@") - KArrowTilde -> (Constructor, "~>") - KArrowDash -> (Constructor, "->") - KArrowEquals -> (Constructor, "=>") - - -- bottoms - KBotEffect -> (Constructor, "!0") - KBotClosure -> (Constructor, "!$") - - -- expression keywords - KWith -> (Keyword, "with") - KWhere -> (Keyword, "where") - KIn -> (Keyword, "in") - KLet -> (Keyword, "let") - KLazy -> (Keyword, "lazy") - KLetRec -> (Keyword, "letrec") - KLetRegion -> (Keyword, "letregion") - KWithRegion -> (Keyword, "withregion") - KCase -> (Keyword, "case") - KOf -> (Keyword, "of") - KWeakEff -> (Keyword, "weakeff") - KWeakClo -> (Keyword, "weakclo") - KPurify -> (Keyword, "purify") - KForget -> (Keyword, "forget") - - -- debruijn indices - KIndex i -> (Index, "^" ++ show i) - - -- builtin names - KTwConBuiltin tw -> (Constructor, renderPlain $ ppr tw) - KWbConBuiltin wi -> (Constructor, renderPlain $ ppr wi) - KTcConBuiltin tc -> (Constructor, renderPlain $ ppr tc) - - --- TokNamed ------------------------------------------------------------------- --- | A token witn a user-defined name. -data TokNamed n - = KCon n - | KVar n - | KLit n - deriving (Eq, Show) - - --- | Describe a `TokNamed`, for parser error messages. -describeTokNamed :: Pretty n => TokNamed n -> String -describeTokNamed tn - = case tn of - KCon n -> renderPlain $ text "constructor" <+> (dquotes $ ppr n) - KVar n -> renderPlain $ text "variable" <+> (dquotes $ ppr n) - KLit n -> renderPlain $ text "literal" <+> (dquotes $ ppr n) - - --- | Apply a function to all the names in a `TokNamed`. -renameTokNamed - :: Ord n2 - => (n1 -> n2) -> TokNamed n1 -> TokNamed n2 - -renameTokNamed f kk - = case kk of - KCon c -> KCon $ f c - KVar c -> KVar $ f c - KLit c -> KLit $ f c - diff --git a/DDC/Core/Parser/Type.hs b/DDC/Core/Parser/Type.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Parser/Type.hs @@ -0,0 +1,209 @@ + +-- | Parser for type expressions. +module DDC.Core.Parser.Type + ( pType + , pTypeAtom + , pTypeApp + , pBinder + , pIndex + , pTok + , pTokAs) +where +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 qualified DDC.Type.Sum as TS + + +-- | Parse a type. +pType :: Ord n => Parser n (Type n) +pType = pTypeSum + "a type" + + +-- | Parse a type sum. +pTypeSum :: Ord n => Parser n (Type n) +pTypeSum + = do t1 <- pTypeForall + P.choice + [ -- Type sums. + -- T2 + T3 + do pTok KPlus + t2 <- pTypeSum + return $ TSum $ TS.fromList (tBot sComp) [t1, t2] + + , do return t1 ] + "a type" + + +-- | Parse a binder. +pBinder :: Ord n => Parser n (Binder n) +pBinder + = P.choice + -- Named binders. + [ do v <- pVar + return $ RName v + + -- Anonymous binders. + , do pTok KHat + return $ RAnon + + -- Vacant binders. + , do pTok KUnderscore + return $ RNone ] + "a binder" + +-- | Parse a quantified type. +pTypeForall :: Ord n => Parser n (Type n) +pTypeForall + = P.choice + [ -- Universal quantification. + -- [v1 v1 ... vn : T1]. T2 + do pTok KSquareBra + bs <- P.many1 pBinder + pTok KColon + k <- pTypeSum + pTok KSquareKet + pTok KDot + + body <- pTypeForall + + return $ foldr TForall body + $ map (\b -> makeBindFromBinder b k) bs + + -- Body type + , do pTypeFun] + "a type" + + +-- | Parse a function type. +pTypeFun :: Ord n => Parser n (Type n) +pTypeFun + = do t1 <- pTypeApp + P.choice + [ -- T1 ~> T2 + do pTok KArrowTilde + t2 <- pTypeFun + return $ TApp (TApp (TCon (TyConKind KiConFun)) t1) t2 + + -- T1 => T2 + , do pTok KArrowEquals + t2 <- pTypeFun + return $ TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2 + + -- T1 -> T2 + , do pTok KArrowDash + t2 <- pTypeFun + return $ t1 `tFunPE` t2 + + -- T1 -(TSUM | TSUM)> t2 + , do pTok KDash + pTok KRoundBra + eff <- pTypeSum + pTok KBar + clo <- pTypeSum + pTok KRoundKet + pTok KAngleKet + t2 <- pTypeFun + return $ tFun t1 eff clo t2 + + + -- Body type + , do return t1 ] + "an atomic type or type application" + + +-- | Parse a type application. +pTypeApp :: Ord n => Parser n (Type n) +pTypeApp + = do (t:ts) <- P.many1 pTypeAtom + return $ foldl TApp t ts + "an atomic type or type application" + + +-- | Parse a variable, constructor or parenthesised type. +pTypeAtom :: Ord n => Parser n (Type n) +pTypeAtom + = P.choice + -- (~>) and (=>) and (->) and (TYPE2) + [ do pTok KRoundBra + P.choice + [ do pTok KArrowTilde + pTok KRoundKet + return (TCon $ TyConKind KiConFun) + + , do pTok KArrowEquals + pTok KRoundKet + return (TCon $ TyConWitness TwConImpl) + + , do pTok KArrowDash + pTok KRoundKet + return (TCon $ TyConSpec TcConFun) + + , do t <- pTypeSum + pTok KRoundKet + return t + ] + + -- Named type constructors + , do tc <- pTcCon + return $ TCon (TyConSpec tc) + + , do tc <- pTwCon + return $ TCon (TyConWitness tc) + + , do tc <- pTyConNamed + return $ TCon tc + + -- Symbolic constructors. + , do pTokAs KSortComp (TCon $ TyConSort SoConComp) + , do pTokAs KSortProp (TCon $ TyConSort SoConProp) + , do pTokAs KKindValue (TCon $ TyConKind KiConData) + , do pTokAs KKindRegion (TCon $ TyConKind KiConRegion) + , do pTokAs KKindEffect (TCon $ TyConKind KiConEffect) + , do pTokAs KKindClosure (TCon $ TyConKind KiConClosure) + , do pTokAs KKindWitness (TCon $ TyConKind KiConWitness) + + -- Bottoms. + , do pTokAs KBotEffect (tBot kEffect) + , do pTokAs KBotClosure (tBot kClosure) + + -- Bound occurrence of a variable. + -- We don't know the kind of this variable yet, so fill in the + -- field with the bottom element of computation kinds. This isn't + -- really part of the language, but makes sense implentation-wise. + , do v <- pVar + return $ TVar (UName v) + + , do i <- pIndex + return $ TVar (UIx (fromIntegral i)) + ] + "an atomic type" + + +------------------------------------------------------------------------------- +-- | Parse a builtin `TcCon` +pTcCon :: Parser n TcCon +pTcCon = P.pTokMaybe f + "a type constructor" + where f (KA (KTcConBuiltin c)) = Just c + f _ = Nothing + +-- | Parse a builtin `TwCon` +pTwCon :: Parser n TwCon +pTwCon = P.pTokMaybe f + "a witness constructor" + where f (KA (KTwConBuiltin c)) = Just c + f _ = Nothing + +-- | Parse a user `TcCon` +pTyConNamed :: Parser n (TyCon n) +pTyConNamed + = P.pTokMaybe f + "a type constructor" + where f (KN (KCon n)) = Just (TyConBound (UName n) (tBot kData)) + f _ = Nothing + diff --git a/DDC/Core/Parser/Witness.hs b/DDC/Core/Parser/Witness.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Parser/Witness.hs @@ -0,0 +1,84 @@ + +module DDC.Core.Parser.Witness + ( pWitness + , pWitnessApp + , pWitnessAtom) +where +import DDC.Core.Parser.Type +import DDC.Core.Parser.Base +import DDC.Core.Lexer.Tokens +import DDC.Core.Exp +import DDC.Base.Parser (()) +import qualified DDC.Base.Parser as P +import qualified DDC.Type.Compounds as T + + +-- | Parse a witness expression. +pWitness :: Ord n => Parser n (Witness n) +pWitness = pWitnessJoin + + +-- | Parse a witness join. +pWitnessJoin :: Ord n => Parser n (Witness n) +pWitnessJoin + -- WITNESS or WITNESS & WITNESS + = do w1 <- pWitnessApp + P.choice + [ do pTok KAmpersand + w2 <- pWitnessJoin + return (WJoin w1 w2) + + , do return w1 ] + + +-- | Parse a witness application. +pWitnessApp :: Ord n => Parser n (Witness n) +pWitnessApp + = do (x:xs) <- P.many1 pWitnessArg + return $ foldl WApp x xs + + "a witness expression or application" + + +-- | Parse a witness argument. +pWitnessArg :: Ord n => Parser n (Witness n) +pWitnessArg + = P.choice + [ -- [TYPE] + do pTok KSquareBra + t <- pType + pTok KSquareKet + return $ WType t + + -- WITNESS + , do pWitnessAtom ] + + +-- | Parse a variable, constructor or parenthesised witness. +pWitnessAtom :: Ord n => Parser n (Witness n) +pWitnessAtom + = P.choice + -- (WITNESS) + [ do pTok KRoundBra + w <- pWitness + pTok KRoundKet + return $ w + + -- Named constructors + , do con <- pCon + return $ WCon (WiConBound (UName con) (T.tBot T.kWitness)) + + -- Baked-in witness constructors. + , do wb <- pWbCon + return $ WCon (WiConBuiltin wb) + + + -- Debruijn indices + , do i <- pIndex + return $ WVar (UIx i) + + -- Variables + , do var <- pVar + return $ WVar (UName var) ] + + "a witness" diff --git a/DDC/Core/Predicates.hs b/DDC/Core/Predicates.hs --- a/DDC/Core/Predicates.hs +++ b/DDC/Core/Predicates.hs @@ -1,10 +1,12 @@ -- | Simple predicates on core expressions. module DDC.Core.Predicates - ( -- * Atoms - isXVar, isXCon - , isAtomW, isAtomX + ( module DDC.Type.Predicates + -- * Atoms + , isXVar, isXCon + , isAtomX, isAtomW + -- * Lambdas , isXLAM, isXLam , isLambdaX @@ -12,6 +14,10 @@ -- * Applications , isXApp + -- * Types and Witnesses + , isXType + , isXWitness + -- * Patterns , isPDefault) where @@ -36,15 +42,6 @@ _ -> False --- | Check whether a witness is a `WVar` or `WCon`. -isAtomW :: Witness n -> Bool -isAtomW ww - = case ww of - WVar{} -> True - WCon{} -> True - _ -> False - - -- | Check whether an expression is a `XVar` or an `XCon`, -- or some type or witness atom. isAtomX :: Exp a n -> Bool @@ -57,6 +54,15 @@ _ -> False +-- | Check whether a witness is a `WVar` or `WCon`. +isAtomW :: Witness n -> Bool +isAtomW ww + = case ww of + WVar{} -> True + WCon{} -> True + _ -> False + + -- Lambdas -------------------------------------------------------------------- -- | Check whether an expression is a spec abstraction (level-1). isXLAM :: Exp a n -> Bool @@ -87,6 +93,23 @@ = case xx of XApp{} -> True _ -> False + + +-- Type and Witness ----------------------------------------------------------- +-- | Check whether an expression is an `XType` +isXType :: Exp a n -> Bool +isXType xx + = case xx of + XType{} -> True + _ -> False + + +-- | Check whether an expression is an `XWitness` +isXWitness :: Exp a n -> Bool +isXWitness xx + = case xx of + XWitness{} -> True + _ -> False -- Patterns ------------------------------------------------------------------- diff --git a/DDC/Core/Pretty.hs b/DDC/Core/Pretty.hs --- a/DDC/Core/Pretty.hs +++ b/DDC/Core/Pretty.hs @@ -1,43 +1,94 @@ --- | Pretty printing for core expressions. + +-- | Provides pretty printing for core modules and expressions. module DDC.Core.Pretty ( module DDC.Type.Pretty , module DDC.Base.Pretty) where -import DDC.Core.Exp import DDC.Core.Compounds import DDC.Core.Predicates +import DDC.Core.Module +import DDC.Core.Exp import DDC.Type.Pretty -import DDC.Type.Compounds -import DDC.Type.Predicates import DDC.Base.Pretty +import Data.List +import qualified Data.Map.Strict as Map --- Binder --------------------------------------------------------------------- --- | Pretty print a binder, adding spaces after names. --- The RAnon and None binders don't need spaces, as they're single symbols. -pprBinderSep :: Pretty n => Binder n -> Doc -pprBinderSep bb - = case bb of - RName v -> ppr v - RAnon -> text "^" - RNone -> text "_" +-- ModuleName ----------------------------------------------------------------- +instance Pretty ModuleName where + ppr (ModuleName parts) + = text $ intercalate "." parts --- | Print a group of binders with the same type. -pprBinderGroup - :: (Pretty n, Eq n) - => Doc -> ([Binder n], Type n) -> Doc +-- Module --------------------------------------------------------------------- +instance (Pretty n, Eq n) => Pretty (Module a n) where + ppr ModuleCore + { moduleName = name + , moduleExportKinds = exportKinds + , moduleExportTypes = exportTypes + , moduleImportKinds = importKinds + , moduleImportTypes = importTypes + , moduleBody = body } + = {-# SCC "ppr[Module]" #-} + let + (lts, _) = splitXLets body -pprBinderGroup lam (rs, t) - = lam <> parens ((cat $ map pprBinderSep rs) <+> text ":" <+> ppr t) <> dot + docsExportKinds + | Map.null exportKinds = empty + | otherwise + = nest 8 $ line + <> vcat [ text "type" <+> ppr n <+> text "::" <+> ppr t <> semi + | (n, t) <- Map.toList exportKinds ] + docsExportTypes + | Map.null exportTypes = empty + | otherwise + = nest 8 $ line + <> vcat [ ppr n <+> text "::" <+> ppr t <> semi + | (n, t) <- Map.toList exportTypes ] + docsImportKinds + | Map.null importKinds = empty + | otherwise + = nest 8 $ line + <> vcat [ text "type" <+> ppr n <+> text "::" <+> ppr t <> semi + | (n, (_, t)) <- Map.toList importKinds ] + + docsImportTypes + | Map.null importTypes = empty + | otherwise + = nest 8 $ line + <> vcat [ ppr n <+> text "::" <+> ppr t <> semi + | (n, (_, t)) <- Map.toList importTypes ] + + in text "module" <+> ppr name + <+> (if Map.null exportKinds && Map.null exportTypes + then empty + else line + <> text "exports" <+> lbrace + <> docsExportKinds + <> docsExportTypes + <> line + <> rbrace <> space) + + <> (if Map.null importKinds && Map.null importTypes + then empty + else line + <> text "imports" <+> lbrace + <> docsImportKinds + <> docsImportTypes + <> line + <> rbrace <> space) + <> text "with" <$$> (vcat $ map ppr lts) + + -- Exp ------------------------------------------------------------------------ instance (Pretty n, Eq n) => Pretty (Exp a n) where pprPrec d xx - = case xx of + = {-# SCC "ppr[Exp]" #-} + case xx of XVar _ u -> ppr u - XCon _ tc -> ppr tc + XCon _ dc -> ppr dc XLAM{} -> let Just (bs, xBody) = takeXLAMs xx @@ -107,15 +158,25 @@ = ppr p <+> nest 1 (line <> nest 3 (text "->" <+> ppr x)) +-- DaCon ---------------------------------------------------------------------- +instance (Pretty n, Eq n) => Pretty (DaCon n) where + ppr dc + = case daConName dc of + DaConUnit -> text "()" + DaConNamed n -> ppr n + + -- Cast ----------------------------------------------------------------------- -instance (Pretty n, Eq n) => Pretty (Cast n) where +instance (Pretty n, Eq n) => Pretty (Cast a n) where ppr cc = case cc of CastWeakenEffect eff -> text "weakeff" <+> brackets (ppr eff) - CastWeakenClosure clo - -> text "weakclo" <+> brackets (ppr clo) + CastWeakenClosure xs + -> text "weakclo" + <+> braces (hcat $ punctuate (semi <> space) + $ map ppr xs) CastPurify w -> text "purify" <+> angles (ppr w) @@ -152,17 +213,27 @@ $ map pprLetRecBind bxs))) <$> rbrace - - LLetRegion b [] + + LLetRegions [b] [] -> text "letregion" <+> ppr (binderOfBind b) - - LLetRegion b bs + + LLetRegions [b] bs -> text "letregion" <+> ppr (binderOfBind b) <+> text "with" <+> braces (cat $ punctuate (text "; ") $ map ppr bs) + LLetRegions b [] + -> text "letregions" + <+> (hcat $ punctuate space (map (ppr . binderOfBind) b)) + + LLetRegions b bs + -> text "letregions" + <+> (hcat $ punctuate space (map (ppr . binderOfBind) b)) + <+> text "with" + <+> braces (cat $ punctuate (text "; ") $ map ppr bs) + LWithRegion b -> text "withregion" <+> ppr b @@ -195,8 +266,8 @@ instance (Pretty n, Eq n) => Pretty (WiCon n) where ppr wc = case wc of - WiConBuiltin wb -> ppr wb - WiConBound u -> ppr u + WiConBuiltin wb -> ppr wb + WiConBound u _ -> ppr u instance Pretty WbCon where @@ -207,6 +278,24 @@ WbConUse -> text "use" WbConRead -> text "read" WbConAlloc -> text "alloc" + + +-- Binder --------------------------------------------------------------------- +pprBinder :: Pretty n => Binder n -> Doc +pprBinder bb + = case bb of + RName v -> ppr v + RAnon -> text "^" + RNone -> text "_" + + +-- | Print a group of binders with the same type. +pprBinderGroup + :: (Pretty n, Eq n) + => Doc -> ([Binder n], Type n) -> Doc + +pprBinderGroup lam (rs, t) + = lam <> parens ((hsep $ map pprBinder rs) <+> text ":" <+> ppr t) <> dot -- Utils ---------------------------------------------------------------------- diff --git a/DDC/Core/Transform/LiftT.hs b/DDC/Core/Transform/LiftT.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Transform/LiftT.hs @@ -0,0 +1,107 @@ + +module DDC.Core.Transform.LiftT + ( liftT, liftAtDepthT + , MapBoundT(..)) +where +import DDC.Core.Exp +import DDC.Type.Transform.LiftT + + +instance Ord n => MapBoundT (Exp a) n where + mapBoundAtDepthT f d xx + = let down = mapBoundAtDepthT f d + in case xx of + XVar a u -> XVar a u + XCon{} -> xx + XApp a x1 x2 -> XApp a (down x1) (down x2) + XLAM a b x -> XLAM a b (mapBoundAtDepthT f (d + countBAnons [b]) x) + XLam a b x -> XLam a (down b) (down x) + + XLet a lets x + -> let (lets', levels) = mapBoundAtDepthTLets f d lets + in XLet a lets' (mapBoundAtDepthT f (d + levels) x) + + XCase a x alts -> XCase a (down x) (map down alts) + XCast a cc x -> XCast a (down cc) (down x) + XType t -> XType (down t) + XWitness w -> XWitness (down w) + + +instance Ord n => MapBoundT LetMode n where + mapBoundAtDepthT f d m + = case m of + LetStrict -> m + LetLazy Nothing -> m + LetLazy (Just w) -> LetLazy (Just $ mapBoundAtDepthT f d w) + + +instance Ord n => MapBoundT Witness n where + mapBoundAtDepthT f d ww + = let down = mapBoundAtDepthT f d + in case ww of + WVar u -> WVar (down u) + WCon _ -> ww + WApp w1 w2 -> WApp (down w1) (down w2) + WJoin w1 w2 -> WJoin (down w1) (down w2) + WType t -> WType (down t) + + +instance Ord n => MapBoundT (Cast a) n where + mapBoundAtDepthT f d cc + = let down = mapBoundAtDepthT f d + in case cc of + CastWeakenEffect t + -> CastWeakenEffect (down t) + + CastWeakenClosure xs + -> CastWeakenClosure (map down xs) + + CastPurify w + -> CastPurify (down w) + + CastForget w + -> CastForget (down w) + + +instance Ord n => MapBoundT (Alt a) n where + mapBoundAtDepthT f d (AAlt p x) + = let down = mapBoundAtDepthT f d + in case p of + PDefault + -> AAlt PDefault (down x) + + PData dc bs + -> AAlt (PData dc (map down bs)) (down x) + + +mapBoundAtDepthTLets + :: Ord n + => (Int -> Bound n -> Bound n) -- ^ Number of levels to lift. + -> Int -- ^ Current binding depth. + -> Lets a n -- ^ Lift exp indices in this thing. + -> (Lets a n, Int) -- ^ Lifted, and how much to increase depth by + +mapBoundAtDepthTLets f d lts + = let down = mapBoundAtDepthT f d + in case lts of + LLet m b x + -> ( LLet (down m) (down b) (down x) + , 0) + + LRec bs + -> let bs' = [ (b, mapBoundAtDepthT f d x) | (b, x) <- bs ] + in (LRec bs', 0) + + LLetRegions bsT bsX + -> let inc = countBAnons bsT + bsX' = map (mapBoundAtDepthT f (d + inc)) bsX + in ( LLetRegions bsT bsX' + , inc) + + LWithRegion _ + -> (lts, 0) + + +countBAnons = length . filter isAnon + where isAnon (BAnon _) = True + isAnon _ = False diff --git a/DDC/Core/Transform/LiftW.hs b/DDC/Core/Transform/LiftW.hs deleted file mode 100644 --- a/DDC/Core/Transform/LiftW.hs +++ /dev/null @@ -1,116 +0,0 @@ - --- | Lift deBruijn indices in witnesses. -module DDC.Core.Transform.LiftW - (LiftW(..)) -where -import DDC.Core.Exp - - -class LiftW (c :: * -> *) where - -- | Lift indices that are at least a the given depth by some number - -- of levels - liftAtDepthW - :: forall n. Ord n - => Int -- ^ Number of levels to lift. - -> Int -- ^ Current binding depth. - -> c n -- ^ Lift witness variable indices in this thing. - -> c n - - -- | Wrapper for `liftAtDepthX` that starts at depth 0. - liftW :: forall n. Ord n - => Int -- ^ Number of levels to lift. - -> c n -- ^ Lift witness variable indices in this thing. - -> c n - - liftW n xx = liftAtDepthW n 0 xx - - -instance LiftW Bound where - liftAtDepthW n d uu - = case uu of - UName{} -> uu - UPrim{} -> uu - UIx i t - | d <= i -> UIx (i + n) t - | otherwise -> uu - - -instance LiftW (Exp a) where - liftAtDepthW n d xx - = let down = liftAtDepthW n d - in case xx of - XVar{} -> xx - XCon{} -> xx - XApp a x1 x2 -> XApp a (down x1) (down x2) - XLAM a b x -> XLAM a b (down x) - XLam a b x -> XLam a b (liftAtDepthW n (d + 1) x) - - XLet a lets x - -> let (lets', levels) = liftAtDepthXLets n d lets - in XLet a lets' (liftAtDepthW n (d + levels) x) - - XCase a x alts -> XCase a (down x) (map down alts) - XCast a cc x -> XCast a cc (down x) - XType{} -> xx - XWitness w -> XWitness (down w) - - -instance LiftW LetMode where - liftAtDepthW n d m - = case m of - LetStrict -> m - LetLazy Nothing -> m - LetLazy (Just w) -> LetLazy (Just $ liftAtDepthW n d w) - - -instance LiftW (Alt a) where - liftAtDepthW n d (AAlt p x) - = case p of - PDefault - -> AAlt PDefault (liftAtDepthW n d x) - - PData _ bs - -> let d' = d + countBAnons bs - in AAlt p (liftAtDepthW n d' x) - - -instance LiftW Witness where - liftAtDepthW n d ww - = let down = liftAtDepthW n d - in case ww of - WVar u -> WVar (down u) - WCon{} -> ww - WApp w1 w2 -> WApp (down w1) (down w2) - WJoin w1 w2 -> WJoin (down w1) (down w2) - WType{} -> ww - - -liftAtDepthXLets - :: forall a n. Ord n - => Int -- ^ Number of levels to lift. - -> Int -- ^ Current binding depth. - -> Lets a n -- ^ Lift exp indices in this thing. - -> (Lets a n, Int) -- ^ Lifted, and how much to increase depth by - -liftAtDepthXLets n d lts - = case lts of - LLet m b x - -> let m' = liftAtDepthW n d m - inc = countBAnons [b] - x' = liftAtDepthW n (d+inc) x - in (LLet m' b x', inc) - - LRec bs - -> let inc = countBAnons (map fst bs) - bs' = map (\(b,e) -> (b, liftAtDepthW n (d+inc) e)) bs - in (LRec bs', inc) - - LLetRegion _b bs -> (lts, countBAnons bs) - LWithRegion _ -> (lts, 0) - - -countBAnons = length . filter isAnon - where isAnon (BAnon _) = True - isAnon _ = False - - diff --git a/DDC/Core/Transform/LiftX.hs b/DDC/Core/Transform/LiftX.hs --- a/DDC/Core/Transform/LiftX.hs +++ b/DDC/Core/Transform/LiftX.hs @@ -1,92 +1,176 @@ --- | Lift deBruijn indices in expressions. +-- | Lifting and lowering level-0 deBruijn indices in core things. +-- +-- Level-0 indices are used for both value and witness variables. module DDC.Core.Transform.LiftX - (LiftX(..)) + ( liftX, liftAtDepthX + , lowerX, lowerAtDepthX + , MapBoundX(..)) where import DDC.Core.Exp -class LiftX (c :: * -> *) where - -- | Lift indices that are at least the given depth by some number - -- of levels. - liftAtDepthX - :: forall n. Ord n +-- Lift ----------------------------------------------------------------------- +-- | Lift debruijn indices less than or equal to the given depth. +liftAtDepthX + :: MapBoundX c n => Int -- ^ Number of levels to lift. -> Int -- ^ Current binding depth. -> c n -- ^ Lift expression indices in this thing. -> c n - - -- | Wrapper for `liftAtDepthX` that starts at depth 0. - liftX :: forall n. Ord n - => Int -- ^ Number of levels to lift. - -> c n -- ^ Lift expression indices in this thing. + +liftAtDepthX n d + = {-# SCC liftAtDepthX #-} + mapBoundAtDepthX liftU d + where + liftU d' u + = case u of + UName{} -> u + UPrim{} -> u + UIx i + | d' <= i -> UIx (i + n) + | otherwise -> u + + +-- | Wrapper for `liftAtDepthX` that starts at depth 0. +liftX :: MapBoundX c n => Int -> c n -> c n +liftX n xx = liftAtDepthX n 0 xx + + +-- Lower ---------------------------------------------------------------------- +-- | Lower debruijn indices less than or equal to the given depth. +lowerAtDepthX + :: MapBoundX c n + => Int -- ^ Number of levels to lower. + -> Int -- ^ Current binding depth. + -> c n -- ^ Lower expression indices in this thing. -> c n - - liftX n xx = liftAtDepthX n 0 xx - -instance LiftX Bound where - liftAtDepthX n d uu - = case uu of - UName{} -> uu - UPrim{} -> uu - UIx i t - | d <= i -> UIx (i + n) t - | otherwise -> uu +lowerAtDepthX n d + = {-# SCC lowerAtDepthX #-} + mapBoundAtDepthX liftU d + where + liftU d' u + = case u of + UName{} -> u + UPrim{} -> u + UIx i + | d' <= i -> UIx (i - n) + | otherwise -> u -instance LiftX (Exp a) where - liftAtDepthX n d xx - = let down = liftAtDepthX n d +-- | Wrapper for `lowerAtDepthX` that starts at depth 0. +lowerX :: MapBoundX c n => Int -> c n -> c n +lowerX n xx = lowerAtDepthX n 0 xx + + +-- MapBoundX ------------------------------------------------------------------ +class MapBoundX (c :: * -> *) n where + -- | Apply a function to all bound variables in the program. + -- The function is passed the current binding depth. + -- This is used to defined both `liftX` and `lowerX`. + mapBoundAtDepthX + :: (Int -> Bound n -> Bound n) -- ^ Function to apply to the bound occ. + -- It is passed the current binding depth. + -> Int -- ^ Current binding depth. + -> c n -- ^ Lift expression indices in this thing. + -> c n + + +instance MapBoundX Bound n where + mapBoundAtDepthX f d u + = f d u + + +instance MapBoundX (Exp a) n where + mapBoundAtDepthX f d xx + = let down = mapBoundAtDepthX f d in case xx of - XVar a u -> XVar a (down u) + XVar a u -> XVar a (f d u) XCon{} -> xx XApp a x1 x2 -> XApp a (down x1) (down x2) XLAM a b x -> XLAM a b (down x) - XLam a b x -> XLam a b (liftAtDepthX n (d + 1) x) + XLam a b x -> XLam a b (mapBoundAtDepthX f (d + countBAnons [b]) x) XLet a lets x - -> let (lets', levels) = liftAtDepthXLets n d lets - in XLet a lets' (liftAtDepthX n (d + levels) x) + -> let (lets', levels) = mapBoundAtDepthXLets f d lets + in XLet a lets' (mapBoundAtDepthX f (d + levels) x) - XCase a x alts -> XCase a (down x) (map down alts) - XCast a cc x -> XCast a cc (down x) + XCase a x alts -> XCase a (down x) (map down alts) + XCast a cc x -> XCast a (down cc) (down x) XType{} -> xx - XWitness{} -> xx + XWitness w -> XWitness (down w) + + +instance MapBoundX LetMode n where + mapBoundAtDepthX f d m + = case m of + LetStrict -> m + LetLazy Nothing -> m + LetLazy (Just w) -> LetLazy (Just $ mapBoundAtDepthX f d w) + +instance MapBoundX Witness n where + mapBoundAtDepthX f d ww + = let down = mapBoundAtDepthX f d + in case ww of + WVar u -> WVar (down u) + WCon _ -> ww + WApp w1 w2 -> WApp (down w1) (down w2) + WJoin w1 w2 -> WJoin (down w1) (down w2) + WType _ -> ww -instance LiftX (Alt a) where - liftAtDepthX n d (AAlt p x) + +instance MapBoundX (Cast a) n where + mapBoundAtDepthX f d cc + = case cc of + CastWeakenEffect{} + -> cc + + CastWeakenClosure xs + -> CastWeakenClosure (map (mapBoundAtDepthX f d) xs) + + CastPurify w + -> CastPurify w + + CastForget w + -> CastForget w + + +instance MapBoundX (Alt a) n where + mapBoundAtDepthX f d (AAlt p x) = case p of PDefault - -> AAlt PDefault (liftAtDepthX n d x) + -> AAlt PDefault (mapBoundAtDepthX f d x) PData _ bs -> let d' = d + countBAnons bs - in AAlt p (liftAtDepthX n d' x) + in AAlt p (mapBoundAtDepthX f d' x) -liftAtDepthXLets - :: forall a n. Ord n - => Int -- ^ Number of levels to lift. - -> Int -- ^ Current binding depth. - -> Lets a n -- ^ Lift exp indices in this thing. - -> (Lets a n, Int) -- ^ Lifted, and how much to increase depth by +mapBoundAtDepthXLets + :: (Int -> Bound n -> Bound n) -- ^ Number of levels to lift. + -> Int -- ^ Current binding depth. + -> Lets a n -- ^ Lift exp indices in this thing. + -> (Lets a n, Int) -- ^ Lifted, and how much to increase depth by -liftAtDepthXLets n d lts +mapBoundAtDepthXLets f d lts = case lts of LLet m b x -> let inc = countBAnons [b] - x' = liftAtDepthX n (d+inc) x - in (LLet m b x', inc) + m' = mapBoundAtDepthX f d m + -- non-recursive binding: do not increase x's depth + x' = mapBoundAtDepthX f d x + in (LLet m' b x', inc) + LRec bs -> let inc = countBAnons (map fst bs) - bs' = map (\(b,e) -> (b, liftAtDepthX n (d+inc) e)) bs + bs' = map (\(b,e) -> (b, mapBoundAtDepthX f (d+inc) e)) bs in (LRec bs', inc) - LLetRegion _b bs -> (lts, countBAnons bs) - LWithRegion _ -> (lts, 0) + LLetRegions _b bs -> (lts, countBAnons bs) + LWithRegion _ -> (lts, 0) countBAnons = length . filter isAnon diff --git a/DDC/Core/Transform/Reannotate.hs b/DDC/Core/Transform/Reannotate.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Transform/Reannotate.hs @@ -0,0 +1,68 @@ + +module DDC.Core.Transform.Reannotate + (Reannotate (..)) +where +import DDC.Core.Module +import DDC.Core.Exp + + +-- | Apply the given function to every annotation in a core thing. +class Reannotate c where + reannotate :: (a -> b) -> c a n -> c b n + + +instance Reannotate Module where + reannotate f + (ModuleCore name + exportKinds exportTypes + importKinds importTypes + body) + = ModuleCore name + exportKinds exportTypes + importKinds importTypes + (reannotate f body) + + +instance Reannotate Exp where + reannotate f xx + = {-# SCC reannotate #-} + let down x = reannotate f x + in case xx of + XVar a u -> XVar (f a) u + XCon a u -> XCon (f a) u + XLAM a b x -> XLAM (f a) b (down x) + XLam a b x -> XLam (f a) b (down x) + XApp a x1 x2 -> XApp (f a) (down x1) (down x2) + XLet a lts x -> XLet (f a) (down lts) (down x) + XCase a x alts -> XCase (f a) (down x) (map down alts) + XCast a c x -> XCast (f a) (down c) (down x) + XType t -> XType t + XWitness w -> XWitness w + + +instance Reannotate Lets where + reannotate f xx + = let down x = reannotate f x + in case xx of + LLet m b x -> LLet m b (down x) + LRec bxs -> LRec [(b, down x) | (b, x) <- bxs] + LLetRegions b bs -> LLetRegions b bs + LWithRegion b -> LWithRegion b + + +instance Reannotate Alt where + reannotate f aa + = case aa of + AAlt w x -> AAlt w (reannotate f x) + + +instance Reannotate Cast where + reannotate f cc + = let down x = reannotate f x + in case cc of + CastWeakenEffect eff -> CastWeakenEffect eff + CastWeakenClosure xs -> CastWeakenClosure (map down xs) + CastPurify w -> CastPurify w + CastForget w -> CastForget w + + diff --git a/DDC/Core/Transform/Rename.hs b/DDC/Core/Transform/Rename.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Transform/Rename.hs @@ -0,0 +1,41 @@ + +module DDC.Core.Transform.Rename + ( Rename(..) + + -- * Substitution states + , Sub(..) + + -- * Binding stacks + , BindStack(..) + , pushBind + , pushBinds + , substBound + + -- * Rewriting binding occurences + , bind1, bind1s, bind0, bind0s + + -- * Rewriting bound occurences + , use1, use0) +where +import DDC.Core.Exp +import DDC.Type.Transform.Rename + + +instance Rename LetMode where + renameWith sub lm + = case lm of + LetStrict -> lm + LetLazy (Just t) -> LetLazy (Just $ renameWith sub t) + LetLazy Nothing -> LetLazy Nothing + + +instance Rename Witness where + renameWith sub ww + = let down x = renameWith x + in case ww of + WVar u -> WVar (use0 sub u) + WCon{} -> ww + WApp w1 w2 -> WApp (down sub w1) (down sub w2) + WJoin w1 w2 -> WJoin (down sub w1) (down sub w2) + WType t -> WType (down sub t) + diff --git a/DDC/Core/Transform/SpreadX.hs b/DDC/Core/Transform/SpreadX.hs --- a/DDC/Core/Transform/SpreadX.hs +++ b/DDC/Core/Transform/SpreadX.hs @@ -1,15 +1,14 @@ --- | Spread type annotations from binders and the environment into bound --- occurrences of variables and constructors. module DDC.Core.Transform.SpreadX (SpreadX(..)) where +import DDC.Core.Module import DDC.Core.Exp import DDC.Core.Compounds import DDC.Type.Transform.SpreadT import DDC.Type.Env (Env) import qualified DDC.Type.Env as Env - +import qualified Data.Map as Map class SpreadX (c :: * -> *) where @@ -22,9 +21,24 @@ => Env n -> Env n -> c n -> c n +-- Module --------------------------------------------------------------------- +instance SpreadX (Module a) where + spreadX kenv tenv mm@ModuleCore{} + = mm + { moduleExportKinds = Map.map (spreadT kenv) (moduleExportKinds mm) + , moduleExportTypes = Map.map (spreadT kenv) (moduleExportTypes mm) + , moduleImportKinds = Map.map (liftSnd (spreadT kenv)) (moduleImportKinds mm) + , moduleImportTypes = Map.map (liftSnd (spreadT kenv)) (moduleImportTypes mm) + , moduleBody = spreadX kenv tenv (moduleBody mm) } + + where liftSnd f (x, y) = (x, f y) + + +------------------------------------------------------------------------------- instance SpreadX (Exp a) where spreadX kenv tenv xx - = let down = spreadX kenv tenv + = {-# SCC spreadX #-} + let down x = spreadX kenv tenv x in case xx of XVar a u -> XVar a (down u) XCon a u -> XCon a (down u) @@ -50,19 +64,37 @@ XWitness w -> XWitness (down w) -instance SpreadX Cast where +instance SpreadX DaCon where + spreadX _kenv tenv dc + = case daConName dc of + DaConUnit -> dc + + DaConNamed n + -> let u | Env.isPrim tenv n = UPrim n (daConType dc) + | otherwise = UName n + + in case Env.lookup u tenv of + Just t' -> dc { daConType = t' } + + -- Primitive constructors won't be in the type environment. + -- But we leave it to checkExp to worry about whether a constructor + -- is primitive or simply undefined. + Nothing -> dc + + +instance SpreadX (Cast a) where spreadX kenv tenv cc - = let down = spreadX kenv tenv + = let down x = spreadX kenv tenv x in case cc of - CastWeakenEffect eff -> CastWeakenEffect (spreadT kenv eff) - CastWeakenClosure clo -> CastWeakenClosure (spreadT kenv clo) - CastPurify w -> CastPurify (down w) - CastForget w -> CastForget (down w) + CastWeakenEffect eff -> CastWeakenEffect (spreadT kenv eff) + CastWeakenClosure xs -> CastWeakenClosure (map down xs) + CastPurify w -> CastPurify (down w) + CastForget w -> CastForget (down w) instance SpreadX Pat where spreadX kenv tenv pat - = let down = spreadX kenv tenv + = let down x = spreadX kenv tenv x in case pat of PDefault -> PDefault PData u bs -> PData (down u) (map down bs) @@ -79,7 +111,7 @@ instance SpreadX (Lets a) where spreadX kenv tenv lts - = let down = spreadX kenv tenv + = let down x = spreadX kenv tenv x in case lts of LLet m b x -> LLet (down m) (down b) (down x) @@ -90,11 +122,11 @@ xs' = map (spreadX kenv tenv') xs in LRec (zip bs' xs') - LLetRegion b bs - -> let b' = spreadT kenv b - kenv' = Env.extend b' kenv + LLetRegions b bs + -> let b' = map (spreadT kenv) b + kenv' = Env.extends b' kenv bs' = map (spreadX kenv' tenv) bs - in LLetRegion b' bs' + in LLetRegions b' bs' LWithRegion b -> LWithRegion (spreadX kenv tenv b) @@ -121,12 +153,17 @@ instance SpreadX WiCon where spreadX kenv tenv wc - = let down = spreadX kenv tenv - in case wc of - WiConBound u -> WiConBound (down u) - WiConBuiltin{} -> wc + = case wc of + WiConBound (UName n) _ + -> case Env.envPrimFun tenv n of + Nothing -> wc + Just t + -> let t' = spreadT kenv t + in WiConBound (UPrim n t') t' + _ -> wc + instance SpreadX Bind where spreadX kenv _tenv bb = case bb of @@ -139,13 +176,14 @@ spreadX kenv tenv uu | Just t' <- Env.lookup uu tenv = case uu of - UIx ix _ -> UIx ix t' - UPrim n _ -> UPrim n t' + UIx ix -> UIx ix - UName n _ + UName n -> if Env.isPrim tenv n then UPrim n (spreadT kenv t') - else UName n (spreadT kenv t') + else UName n + + UPrim n _ -> UPrim n t' | otherwise = uu diff --git a/DDC/Core/Transform/SubstituteTX.hs b/DDC/Core/Transform/SubstituteTX.hs --- a/DDC/Core/Transform/SubstituteTX.hs +++ b/DDC/Core/Transform/SubstituteTX.hs @@ -3,17 +3,18 @@ -- -- If a binder would capture a variable then it is anonymized -- to deBruijn form. +-- module DDC.Core.Transform.SubstituteTX - ( substituteTX + ( SubstituteTX(..) + , substituteTX , substituteTXs - , substituteBoundTX - , SubstituteTX(..)) + , substituteBoundTX) where import DDC.Core.Collect import DDC.Core.Exp import DDC.Type.Compounds import DDC.Type.Transform.SubstituteT -import DDC.Type.Rewrite +import DDC.Type.Transform.Rename import Data.Maybe import qualified Data.Set as Set import qualified DDC.Type.Env as Env @@ -64,9 +65,10 @@ instance SubstituteTX (Exp a) where substituteWithTX tArg sub xx - = let down = substituteWithTX tArg + = {-# SCC substituteWithTX #-} + let down x = substituteWithTX tArg x in case xx of - XVar a u -> XVar a (down sub u) + XVar a u -> XVar a u XCon{} -> xx XApp a x1 x2 -> XApp a (down sub x1) (down sub x2) @@ -94,11 +96,11 @@ x2' = down sub1 x2 in XLet a (LRec (zip bs' xs')) x2' - XLet a (LLetRegion b bs) x2 - -> let (sub1, b') = bind1 sub b + XLet a (LLetRegions b bs) x2 + -> let (sub1, b') = bind1s sub b (sub2, bs') = bind0s sub1 (map (down sub1) bs) x2' = down sub2 x2 - in XLet a (LLetRegion b' bs') x2' + in XLet a (LLetRegions b' bs') x2' XLet a (LWithRegion uR) x2 -> XLet a (LWithRegion uR) (down sub x2) @@ -111,7 +113,7 @@ instance SubstituteTX LetMode where substituteWithTX tArg sub lm - = let down = substituteWithTX tArg + = let down x = substituteWithTX tArg x in case lm of LetStrict -> lm LetLazy Nothing -> lm @@ -120,7 +122,7 @@ instance SubstituteTX (Alt a) where substituteWithTX tArg sub aa - = let down = substituteWithTX tArg + = let down x = substituteWithTX tArg x in case aa of AAlt PDefault xBody -> AAlt PDefault $ down sub xBody @@ -131,21 +133,21 @@ in AAlt (PData uCon bs') x' -instance SubstituteTX Cast where +instance SubstituteTX (Cast a) where substituteWithTX tArg sub cc - = let down = substituteWithTX tArg + = let down x = substituteWithTX tArg x in case cc of CastWeakenEffect eff -> CastWeakenEffect (down sub eff) - CastWeakenClosure clo -> CastWeakenClosure (down sub clo) + CastWeakenClosure clo -> CastWeakenClosure (map (down sub) clo) CastPurify w -> CastPurify (down sub w) CastForget w -> CastForget (down sub w) instance SubstituteTX Witness where substituteWithTX tArg sub ww - = let down = substituteWithTX tArg + = let down x = substituteWithTX tArg x in case ww of - WVar u -> WVar (down sub u) + WVar u -> WVar u WCon{} -> ww WApp w1 w2 -> WApp (down sub w1) (down sub w2) WJoin w1 w2 -> WJoin (down sub w1) (down sub w2) @@ -155,11 +157,6 @@ instance SubstituteTX Bind where substituteWithTX tArg sub bb = replaceTypeOfBind (substituteWithTX tArg sub (typeOfBind bb)) bb - - -instance SubstituteTX Bound where - substituteWithTX tArg sub uu - = replaceTypeOfBound (substituteWithTX tArg sub (typeOfBound uu)) uu instance SubstituteTX Type where diff --git a/DDC/Core/Transform/SubstituteWX.hs b/DDC/Core/Transform/SubstituteWX.hs --- a/DDC/Core/Transform/SubstituteWX.hs +++ b/DDC/Core/Transform/SubstituteWX.hs @@ -3,6 +3,7 @@ -- -- If a binder would capture a variable then it is anonymized -- to deBruijn form. +-- module DDC.Core.Transform.SubstituteWX ( SubstituteWX(..) , substituteWX @@ -10,15 +11,15 @@ where import DDC.Core.Exp import DDC.Core.Collect -import DDC.Core.Transform.LiftW +import DDC.Core.Transform.Rename +import DDC.Core.Transform.LiftX import DDC.Type.Compounds -import DDC.Type.Rewrite import Data.Maybe import qualified DDC.Type.Env as Env import qualified Data.Set as Set --- | Wrapper for `substituteWithW` that determines the set of free names in the +-- | Wrapper for `substituteWithWX` that determines the set of free names in the -- type being substituted, and starts with an empty binder stack. substituteWX :: (Ord n, SubstituteWX c) @@ -52,7 +53,7 @@ | otherwise = xx --- | Wrapper for `substituteW` to substitute multiple things. +-- | Wrapper for `substituteWithWX` to substitute multiple things. substituteWXs :: (Ord n, SubstituteWX c) => [(Bind n, Witness n)] -> c n -> c n @@ -60,12 +61,8 @@ = foldr (uncurry substituteWX) x bts +------------------------------------------------------------------------------- class SubstituteWX (c :: * -> *) where - - -- | Substitute a witness into some thing. - -- In the target, if we find a named binder that would capture a free variable - -- in the type to substitute, then we rewrite that binder to anonymous form, - -- avoiding the capture. substituteWithWX :: forall n. Ord n => Witness n -> Sub n -> c n -> c n @@ -73,10 +70,11 @@ instance SubstituteWX (Exp a) where substituteWithWX wArg sub xx - = let down = substituteWithWX wArg - into = rewriteWith + = {-# SCC substituteWithWX #-} + let down s x = substituteWithWX wArg s x + into s x = renameWith s x in case xx of - XVar a u -> XVar a (into sub u) + XVar a u -> XVar a u XCon{} -> xx XApp a x1 x2 -> XApp a (down sub x1) (down sub x2) @@ -104,11 +102,11 @@ x2' = down sub1 x2 in XLet a (LRec (zip bs' xs')) x2' - XLet a (LLetRegion b bs) x2 - -> let (sub1, b') = bind1 sub b + XLet a (LLetRegions b bs) x2 + -> let (sub1, b') = bind1s sub b (sub2, bs') = bind0s sub1 bs x2' = down sub2 x2 - in XLet a (LLetRegion b' bs') x2' + in XLet a (LLetRegions b' bs') x2' XLet a (LWithRegion uR) x2 -> XLet a (LWithRegion uR) (down sub x2) @@ -122,7 +120,7 @@ instance SubstituteWX LetMode where substituteWithWX wArg sub lm - = let down = substituteWithWX wArg + = let down s x = substituteWithWX wArg s x in case lm of LetStrict -> lm LetLazy Nothing -> LetLazy Nothing @@ -131,7 +129,7 @@ instance SubstituteWX (Alt a) where substituteWithWX wArg sub aa - = let down = substituteWithWX wArg + = let down s x = substituteWithWX wArg s x in case aa of AAlt PDefault xBody -> AAlt PDefault $ down sub xBody @@ -142,25 +140,25 @@ in AAlt (PData uCon bs') x' -instance SubstituteWX Cast where +instance SubstituteWX (Cast a) where substituteWithWX wArg sub cc - = let down = substituteWithWX wArg - into = rewriteWith + = let down s x = substituteWithWX wArg s x + into s x = renameWith s x in case cc of CastWeakenEffect eff -> CastWeakenEffect (into sub eff) - CastWeakenClosure clo -> CastWeakenClosure (into sub clo) + CastWeakenClosure xs -> CastWeakenClosure (map (down sub) xs) CastPurify w -> CastPurify (down sub w) CastForget w -> CastForget (down sub w) instance SubstituteWX Witness where substituteWithWX wArg sub ww - = let down = substituteWithWX wArg - into = rewriteWith + = let down s x = substituteWithWX wArg s x + into s x = renameWith s x in case ww of WVar u -> case substW wArg sub u of - Left u' -> WVar (into sub u') + Left u' -> WVar u' Right w -> w WCon{} -> ww @@ -175,8 +173,8 @@ substW wArg sub u = case substBound (subStack0 sub) (subBound sub) u of - Left u' -> Left (rewriteWith sub u') + Left u' -> Left u' Right n - | not $ subShadow0 sub -> Right (liftW n wArg) - | otherwise -> Left (rewriteWith sub u) + | not $ subShadow0 sub -> Right (liftX n wArg) + | otherwise -> Left u diff --git a/DDC/Core/Transform/SubstituteXX.hs b/DDC/Core/Transform/SubstituteXX.hs --- a/DDC/Core/Transform/SubstituteXX.hs +++ b/DDC/Core/Transform/SubstituteXX.hs @@ -3,6 +3,7 @@ -- -- If a binder would capture a variable then it is anonymized -- to deBruijn form. +-- module DDC.Core.Transform.SubstituteXX ( SubstituteXX(..) , substituteXX @@ -17,7 +18,7 @@ import DDC.Core.Transform.SubstituteWX import DDC.Core.Transform.SubstituteTX import DDC.Type.Transform.SubstituteT -import DDC.Type.Rewrite +import DDC.Type.Transform.Rename import Data.Maybe import qualified DDC.Type.Env as Env import qualified Data.Set as Set @@ -41,7 +42,7 @@ , subConflict1 = Set.fromList $ (mapMaybe takeNameOfBound $ Set.toList $ freeT Env.empty xArg) - ++ (mapMaybe takeNameOfBind $ collectSpecBinds xArg) + ++ (mapMaybe takeNameOfBind $ fst $ collectBinds xArg) -- Rewrite level-0 binders that have the same name as any -- of the free variables in the expression to substitute. @@ -99,12 +100,13 @@ instance SubstituteXX Exp where substituteWithXX xArg sub xx - = let down = substituteWithXX xArg - into = rewriteWith + = {-# SCC substituteWithXX #-} + let down s x = substituteWithXX xArg s x + into s x = renameWith s x in case xx of XVar a u -> case substX xArg sub u of - Left u' -> XVar a (into sub u') + Left u' -> XVar a u' Right x -> x XCon{} -> xx @@ -134,24 +136,24 @@ x2' = down sub1 x2 in XLet a (LRec (zip bs' xs')) x2' - XLet a (LLetRegion b bs) x2 - -> let (sub1, b') = bind1 sub b + XLet a (LLetRegions b bs) x2 + -> let (sub1, b') = bind1s sub b (sub2, bs') = bind0s sub1 bs x2' = down sub2 x2 - in XLet a (LLetRegion b' bs') x2' + in XLet a (LLetRegions b' bs') x2' XLet a (LWithRegion uR) x2 -> XLet a (LWithRegion uR) (down sub x2) XCase a x1 alts -> XCase a (down sub x1) (map (down sub) alts) - XCast a cc x1 -> XCast a (into sub cc) (down sub x1) + XCast a cc x1 -> XCast a (down sub cc) (down sub x1) XType t -> XType (into sub t) XWitness w -> XWitness (into sub w) instance SubstituteXX Alt where substituteWithXX xArg sub aa - = let down = substituteWithXX xArg + = let down s x = substituteWithXX xArg s x in case aa of AAlt PDefault xBody -> AAlt PDefault $ down sub xBody @@ -162,15 +164,26 @@ in AAlt (PData uCon bs') x' +instance SubstituteXX Cast where + substituteWithXX xArg sub cc + = let down s x = substituteWithXX xArg s x + into s x = renameWith s x + in case cc of + CastWeakenEffect eff -> CastWeakenEffect (into sub eff) + CastWeakenClosure xs -> CastWeakenClosure (map (down sub) xs) + CastPurify w -> CastPurify (into sub w) + CastForget w -> CastForget (into sub w) + + -- | Rewrite or substitute into an expression variable. substX :: Ord n => Exp a n -> Sub n -> Bound n -> Either (Bound n) (Exp a n) substX xArg sub u = case substBound (subStack0 sub) (subBound sub) u of - Left u' -> Left (rewriteWith sub u') + Left u' -> Left u' Right n | not $ subShadow0 sub -> Right (liftX n xArg) - | otherwise -> Left (rewriteWith sub u) + | otherwise -> Left u diff --git a/DDC/Core/Transform/Trim.hs b/DDC/Core/Transform/Trim.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Transform/Trim.hs @@ -0,0 +1,112 @@ + +-- | Trim the expressions passed to @weakclo@ casts to just those terms +-- that can affect the closure of the body. +-- +module DDC.Core.Transform.Trim + ( trimX, trimClosures ) +where +import DDC.Core.Collect() +import DDC.Type.Collect +import DDC.Core.Exp +import DDC.Type.Env +import DDC.Core.Transform.Reannotate +import Data.List (nubBy) + + +-- | Trim the expressions of a weaken closure @(XCast CastWeakenClosure)@ +-- into only the free variables. +-- +-- For example, +-- @trimClosures [build (\k z. something k), else] +-- = [build, something, else] +-- @ +trimClosures + :: (Ord n) + => a + -> [Exp a n] + -> [Exp a n] + +trimClosures a xs + = {-# SCC trimClosures #-} + nub' $ concatMap (freeExp a empty empty) xs + where nub' = nubBy (\x y -> reannotate (const ()) x == reannotate (const ()) y) + + +-- | Trim an expression if it is a @weakclo@ cast. +-- +-- Non-recursive version. If you want to recursively trim closures, +-- use @transformUpX' (const trimX)@. +trimX :: (Ord n) + => Exp a n + -> Exp a n +trimX (XCast a (CastWeakenClosure ws) in_) + = XCast a (CastWeakenClosure $ trimClosures a ws) in_ + +trimX x + = x + + +-- freeExp -------------------------------------------------------------------- +-- | Collect all the free variables, but return them all as expressions: +-- eg +-- @ +-- freeExp +-- (let i = 5 [R0#] () in +-- updateInt [:R0# R1#:] i ...) +-- +-- will return something like +-- [ XType (TCon R0#) +-- , XVar updateInt +-- , XType (TCon R0#) +-- , XType (TCon R1#) +-- , XWitness w ] +-- @ +freeExp :: (BindStruct c, Ord n) + => a + -> Env n + -> Env n + -> c n + -> [Exp a n] +freeExp a kenv tenv xx + = concatMap (freeOfTreeExp a kenv tenv) $ slurpBindTree xx + +freeOfTreeExp + :: Ord n + => a + -> Env n + -> Env n + -> BindTree n + -> [Exp a n] +freeOfTreeExp a kenv tenv tt + = case tt of + BindDef way bs ts + | isBoundExpWit $ boundLevelOfBindWay way + , tenv' <- extends bs tenv + -> concatMap (freeOfTreeExp a kenv tenv') ts + + BindDef way bs ts + | BoundSpec <- boundLevelOfBindWay way + , kenv' <- extends bs kenv + -> concatMap (freeOfTreeExp a kenv' tenv) ts + + BindDef _ _ ts + -> concatMap (freeOfTreeExp a kenv tenv) ts + + BindUse BoundExp u + | member u tenv -> [] + | otherwise -> [XVar a u] + + BindUse BoundWit u + | member u tenv -> [] + | otherwise -> [XWitness (WVar u)] + + BindUse BoundSpec u + | member u kenv -> [] + | otherwise -> [XType (TVar u)] + + BindCon BoundSpec u (Just k) + | member u kenv -> [] + | otherwise -> [XType (TCon (TyConBound u k))] + + _ -> [] + diff --git a/DDC/Type/Bind.hs b/DDC/Type/Bind.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Bind.hs @@ -0,0 +1,31 @@ + +module DDC.Type.Bind + (getBindType) +where +import DDC.Type.Exp + + +-- | Lookup the type of a bound thing from the binder stack. +-- The binder stack contains the binders of all the `TForall`s we've +-- entered under so far. +getBindType :: Eq n => [Bind n] -> Bound n -> Maybe (Int, Type n) +getBindType bs' u' + = go 0 u' bs' + where go n u (BName n1 t : bs) + | UName n2 <- u + , n1 == n2 = Just (n, t) + + | otherwise = go (n + 1) u bs + + go n (UIx i) (BAnon t : bs) + | i < 0 = Nothing + | i == 0 = Just (n, t) + | otherwise = go (n + 1) (UIx (i - 1)) bs + + go n u (BAnon _ : bs) + | otherwise = go (n + 1) u bs + + go n u (BNone _ : bs) + = go (n + 1) u bs + + go _ _ [] = Nothing diff --git a/DDC/Type/Check.hs b/DDC/Type/Check.hs --- a/DDC/Type/Check.hs +++ b/DDC/Type/Check.hs @@ -12,23 +12,23 @@ -- * Errors , Error(..)) where -import DDC.Type.Check.CheckError +import DDC.Type.DataDef +import DDC.Type.Check.Error +import DDC.Type.Check.ErrorMessage () import DDC.Type.Check.CheckCon import DDC.Type.Compounds import DDC.Type.Predicates -import DDC.Type.Transform.LiftT -import DDC.Core.DataDef import DDC.Type.Exp import DDC.Base.Pretty import Data.List import Control.Monad -import DDC.Type.Check.Monad (throw, result) -import DDC.Type.Pretty () -import DDC.Type.Env (Env) -import qualified DDC.Type.Sum as TS -import qualified DDC.Type.Env as Env -import qualified DDC.Type.Check.Monad as G -import qualified Data.Map as Map +import DDC.Type.Pretty () +import DDC.Type.Env (KindEnv) +import DDC.Control.Monad.Check (throw, result) +import qualified DDC.Control.Monad.Check as G +import qualified DDC.Type.Sum as TS +import qualified DDC.Type.Env as Env +import qualified Data.Map as Map -- | The type checker monad. @@ -37,9 +37,9 @@ -- Wrappers ------------------------------------------------------------------- -- | Check a type in the given environment, returning an error or its kind. -checkType :: (Ord n, Pretty n) +checkType :: (Ord n, Show n, Pretty n) => DataDefs n - -> Env n + -> KindEnv n -> Type n -> Either (Error n) (Kind n) @@ -48,7 +48,7 @@ -- | Check a type in an empty environment, returning an error or its kind. -kindOfType :: (Ord n, Pretty n) +kindOfType :: (Ord n, Show n, Pretty n) => DataDefs n -> Type n -> Either (Error n) (Kind n) @@ -65,55 +65,22 @@ -- that need to be compared up to alpha-equivalence, nor do they contain -- crushable components terms. checkTypeM - :: (Ord n, Pretty n) + :: (Ord n, Show n, Pretty n) => DataDefs n - -> Env n + -> KindEnv n -> Type n -> CheckM n (Kind n) checkTypeM defs env tt = -- trace (pretty $ text "checkTypeM:" <+> ppr tt) $ + {-# SCC checkTypeM #-} checkTypeM' defs env tt -- Variables ------------------ checkTypeM' _defs env (TVar u) - = do let tBound = typeOfBound u - let mtEnv = Env.lookup u env - - let mkResult - -- If the annot is Bot then just use the type - -- from the environment. - | Just tEnv <- mtEnv - , isBot tBound - = return tEnv - - -- The bound has an explicit type annotation, - -- which matches the one from the environment. - -- - -- When the bound is a deBruijn index we need to lift the - -- annotation on the original binder through any lambdas - -- between the binding occurrence and the use. - | Just tEnv <- mtEnv - , UIx i _ <- u - , tBound == liftT (i + 1) tEnv - = return tBound - - -- The bound has an explicit type annotation, - -- that matches the one from the environment. - | Just tEnv <- mtEnv - , tBound == tEnv - = return tBound - - -- The bound has an explicit type annotation, - -- that does not match the one from the environment. - | Just tEnv <- mtEnv - = throw $ ErrorVarAnnotMismatch u tEnv - - -- Type variables must be in the environment. - | _ <- mtEnv - = throw $ ErrorUndefined u - - mkResult + = case Env.lookup u env of + Just t -> return t + Nothing -> throw $ ErrorUndefined u -- Constructors --------------- checkTypeM' defs _env tt@(TCon tc) @@ -132,17 +99,17 @@ TyConSpec tcc -> return $ kindOfTcCon tcc -- User defined type constructors need to be in the set of data defs. - TyConBound u + TyConBound u k -> case u of - UName n _ + UName n | Just _ <- Map.lookup n (dataDefsTypes defs) - -> return $ typeOfBound u + -> return k | otherwise -> throw $ ErrorUndefinedCtor u - UPrim{} -> return $ typeOfBound u - UIx{} -> error "sorry" + UPrim{} -> return k + UIx{} -> throw $ ErrorUndefinedCtor u -- Quantifiers ---------------- diff --git a/DDC/Type/Check/CheckCon.hs b/DDC/Type/Check/CheckCon.hs --- a/DDC/Type/Check/CheckCon.hs +++ b/DDC/Type/Check/CheckCon.hs @@ -14,18 +14,18 @@ takeKindOfTyCon tt = case tt of -- Sorts don't have a higher classification. - TyConSort _ -> Nothing + TyConSort _ -> Nothing - TyConKind kc -> takeSortOfKiCon kc - TyConWitness tc -> Just $ kindOfTwCon tc - TyConSpec tc -> Just $ kindOfTcCon tc - TyConBound u -> Just $ typeOfBound u + TyConKind kc -> takeSortOfKiCon kc + TyConWitness tc -> Just $ kindOfTwCon tc + TyConSpec tc -> Just $ kindOfTcCon tc + TyConBound _u k -> Just k -- | Take the superkind of an atomic kind constructor. -- --- * Yields `Nothing` for the kind function (~>) as it doesn't have a sort --- without being fully applied. +-- 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 @@ -41,24 +41,27 @@ kindOfTwCon :: TwCon -> Kind n kindOfTwCon tc = case tc of - TwConImpl -> kWitness `kFun` (kWitness `kFun` kWitness) - TwConPure -> kEffect `kFun` kWitness - TwConEmpty -> kClosure `kFun` kWitness - TwConGlobal -> kRegion `kFun` kWitness - TwConDeepGlobal -> kData `kFun` kWitness - TwConConst -> kRegion `kFun` kWitness - TwConDeepConst -> kData `kFun` kWitness - TwConMutable -> kRegion `kFun` kWitness - TwConDeepMutable-> kData `kFun` kWitness - TwConLazy -> kRegion `kFun` kWitness - TwConHeadLazy -> kData `kFun` kWitness - TwConManifest -> kRegion `kFun` kWitness + TwConImpl -> kWitness `kFun` kWitness `kFun` kWitness + TwConPure -> kEffect `kFun` kWitness + TwConEmpty -> kClosure `kFun` kWitness + TwConGlobal -> kRegion `kFun` kWitness + TwConDeepGlobal -> kData `kFun` kWitness + TwConConst -> kRegion `kFun` kWitness + TwConDeepConst -> kData `kFun` kWitness + TwConMutable -> kRegion `kFun` kWitness + TwConDeepMutable-> kData `kFun` kWitness + TwConLazy -> kRegion `kFun` kWitness + TwConHeadLazy -> kData `kFun` kWitness + TwConManifest -> kRegion `kFun` kWitness + TwConDisjoint -> kEffect `kFun` kEffect `kFun` kWitness + TwConDistinct n -> (replicate n kRegion) `kFuns` kWitness -- | Take the kind of a computation type constructor. kindOfTcCon :: TcCon -> Kind n kindOfTcCon tc = case tc of + TcConUnit -> kData TcConFun -> [kData, kEffect, kClosure, kData] `kFuns` kData TcConRead -> kRegion `kFun` kEffect TcConHeadRead -> kData `kFun` kEffect diff --git a/DDC/Type/Check/CheckError.hs b/DDC/Type/Check/CheckError.hs deleted file mode 100644 --- a/DDC/Type/Check/CheckError.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} --- | Errors produced when checking types. -module DDC.Type.Check.CheckError - (Error(..)) -where -import DDC.Type.Exp -import DDC.Type.Compounds -import DDC.Type.Pretty - - --- Error ------------------------------------------------------------------------------------------ --- | Type errors. -data Error n - - -- | An undefined type variable. - = ErrorUndefined - { errorBound :: Bound n } - - -- | An undefined type constructor. - | ErrorUndefinedCtor - { errorBound :: Bound n } - - -- | The kind annotation on the variables does not match the one in the environment. - | ErrorVarAnnotMismatch - { errorBound :: Bound n - , errorTypeEnv :: Type n } - - -- | Found a naked sort constructor. - | ErrorNakedSort - { errorSort :: Sort n } - - -- | Found an unapplied kind function constructor. - | ErrorUnappliedKindFun - - -- | A type application where the parameter and argument kinds don't match. - | ErrorAppArgMismatch - { errorChecking :: Type n - , errorParamKind :: Kind n - , errorArgKind :: Kind n } - - -- | A type application where the thing being applied is not a function. - | ErrorAppNotFun - { errorChecking :: Type n - , errorFunType :: Type n - , errorFunTypeKind :: Kind n - , errorArgType :: Type n - , errorArgTypeKind :: Kind n } - - -- | A type sum where the components have differing kinds. - | ErrorSumKindMismatch - { errorKindExpected :: Kind n - , errorTypeSum :: TypeSum n - , errorKinds :: [Kind n] } - - -- | A type sum that does not have effect or closure kind. - | ErrorSumKindInvalid - { errorCheckingSum :: TypeSum n - , errorKind :: Kind n } - - -- | A forall where the body does not have data or witness kind. - | ErrorForallKindInvalid - { errorChecking :: Type n - , errorBody :: Type n - , errorKind :: Kind n } - - -- | A witness implication where the premise or conclusion has an invalid kind. - | ErrorWitnessImplInvalid - { errorChecking :: Type n - , errorLeftType :: Type n - , errorLeftKind :: Kind n - , errorRightType :: Type n - , errorRightKind :: Kind n } - deriving Show - - -instance (Eq n, Pretty n) => Pretty (Error n) where - ppr err - = case err of - ErrorUndefined u - -> text "Undefined type variable: " <> ppr u - - ErrorUndefinedCtor u - -> text "Undefined type constructor: " <> ppr u - - ErrorUnappliedKindFun - -> text "Can't take sort of unapplied kind function constructor." - - ErrorNakedSort s - -> text "Can't check a naked sort: " <> ppr s - - ErrorVarAnnotMismatch u t - -> vcat [ text "Type mismatch in annotation." - , text " Variable: " <> ppr u - , text " has annotation: " <> (ppr $ typeOfBound u) - , text " which conflicts with: " <> ppr t - , text " from environment." ] - - ErrorAppArgMismatch tt t1 t2 - -> vcat [ text "Core type mismatch in application." - , text " type: " <> ppr t1 - , text " does not match: " <> ppr t2 - , text " in application: " <> ppr tt ] - - ErrorAppNotFun tt t1 k1 t2 k2 - -> vcat [ text "Core type mismatch in application." - , text " cannot apply type: " <> ppr t2 - , text " of kind: " <> ppr k2 - , text " to non-function type: " <> ppr t1 - , text " of kind: " <> ppr k1 - , text " in appliction: " <> ppr tt] - - ErrorSumKindMismatch k ts ks - -> vcat - $ [ text "Core type mismatch in sum." - , text " found multiple types: " <> ppr ts - , text " with differing kinds: " <> ppr ks ] - ++ (if k /= tBot sComp - then [text " expected kind: " <> ppr k ] - else []) - - ErrorSumKindInvalid ts k - -> vcat [ text "Invalid kind for type sum." - , text " the type sum: " <> ppr ts - , text " has kind: " <> ppr k - , text " but it must be ! or $" ] - - ErrorForallKindInvalid tt t k - -> vcat [ text "Invalid kind for body of quantified type." - , text " the body type: " <> ppr t - , text " has kind: " <> ppr k - , text " but it must be * or @" - , text " when checking: " <> ppr tt ] - - ErrorWitnessImplInvalid tt t1 k1 t2 k2 - -> vcat [ text "Invalid args for witness implication." - , text " left type: " <> ppr t1 - , text " has kind: " <> ppr k1 - , text " right type: " <> ppr t2 - , text " has kind: " <> ppr k2 - , text " when checking: " <> ppr tt ] - diff --git a/DDC/Type/Check/Error.hs b/DDC/Type/Check/Error.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Check/Error.hs @@ -0,0 +1,71 @@ + +-- | Errors produced when checking types. +module DDC.Type.Check.Error + (Error(..)) +where +import DDC.Type.Exp + + +-- | Things that can go wrong when checking the kind of at type. +data Error n + + -- | An undefined type variable. + = ErrorUndefined + { errorBound :: Bound n } + + -- | An undefined type constructor. + | ErrorUndefinedCtor + { errorBound :: Bound n } + + -- | The kind annotation on the variables does not match the one in the environment. + | ErrorVarAnnotMismatch + { errorBound :: Bound n + , errorTypeEnv :: Type n } + + -- | Found a naked sort constructor. + | ErrorNakedSort + { errorSort :: Sort n } + + -- | Found an unapplied kind function constructor. + | ErrorUnappliedKindFun + + -- | A type application where the parameter and argument kinds don't match. + | ErrorAppArgMismatch + { errorChecking :: Type n + , errorParamKind :: Kind n + , errorArgKind :: Kind n } + + -- | A type application where the thing being applied is not a function. + | ErrorAppNotFun + { errorChecking :: Type n + , errorFunType :: Type n + , errorFunTypeKind :: Kind n + , errorArgType :: Type n + , errorArgTypeKind :: Kind n } + + -- | A type sum where the components have differing kinds. + | ErrorSumKindMismatch + { errorKindExpected :: Kind n + , errorTypeSum :: TypeSum n + , errorKinds :: [Kind n] } + + -- | A type sum that does not have effect or closure kind. + | ErrorSumKindInvalid + { errorCheckingSum :: TypeSum n + , errorKind :: Kind n } + + -- | A forall where the body does not have data or witness kind. + | ErrorForallKindInvalid + { errorChecking :: Type n + , errorBody :: Type n + , errorKind :: Kind n } + + -- | A witness implication where the premise or conclusion has an invalid kind. + | ErrorWitnessImplInvalid + { errorChecking :: Type n + , errorLeftType :: Type n + , errorLeftKind :: Kind n + , errorRightType :: Type n + , errorRightKind :: Kind n } + deriving Show + diff --git a/DDC/Type/Check/ErrorMessage.hs b/DDC/Type/Check/ErrorMessage.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Check/ErrorMessage.hs @@ -0,0 +1,75 @@ + +-- | Errors produced when checking types. +module DDC.Type.Check.ErrorMessage +where +import DDC.Type.Check.Error +import DDC.Type.Compounds +import DDC.Type.Pretty + + +instance (Eq n, Show n, Pretty n) => Pretty (Error n) where + ppr err + = case err of + ErrorUndefined u + -> text "Undefined type variable: " <> ppr u + + ErrorUndefinedCtor u + -> text "Undefined type constructor: " <> ppr u + + ErrorUnappliedKindFun + -> text "Can't take sort of unapplied kind function constructor." + + ErrorNakedSort s + -> text "Can't check a naked sort: " <> ppr s + + ErrorVarAnnotMismatch u t + -> vcat [ text "Type mismatch in annotation." + , text " Variable: " <> ppr u + , text " has annotation: " <> ppr u + , text " which conflicts with: " <> ppr t + , text " from environment." ] + + ErrorAppArgMismatch tt t1 t2 + -> vcat [ text "Core type mismatch in application." + , text " type: " <> ppr t1 + , text " does not match: " <> ppr t2 + , text " in application: " <> ppr tt ] + + ErrorAppNotFun tt t1 k1 t2 k2 + -> vcat [ text "Core type mismatch in application." + , text " cannot apply type: " <> ppr t2 + , text " of kind: " <> ppr k2 + , text " to non-function type: " <> ppr t1 + , text " of kind: " <> ppr k1 + , text " in appliction: " <> ppr tt] + + ErrorSumKindMismatch k ts ks + -> vcat + $ [ text "Core type mismatch in sum." + , text " found multiple types: " <> ppr ts + , text " with differing kinds: " <> ppr ks ] + ++ (if k /= tBot sComp + then [text " expected kind: " <> ppr k ] + else []) + + ErrorSumKindInvalid ts k + -> vcat [ text "Invalid kind for type sum." + , text " the type sum: " <> ppr ts + , text " has kind: " <> ppr k + , text " but it must be ! or $" ] + + ErrorForallKindInvalid tt t k + -> vcat [ text "Invalid kind for body of quantified type." + , text " the body type: " <> ppr t + , text " has kind: " <> ppr k + , text " but it must be * or @" + , text " when checking: " <> ppr tt ] + + ErrorWitnessImplInvalid tt t1 k1 t2 k2 + -> vcat [ text "Invalid args for witness implication." + , text " left type: " <> ppr t1 + , text " has kind: " <> ppr k1 + , text " right type: " <> ppr t2 + , text " has kind: " <> ppr k2 + , text " when checking: " <> ppr tt ] + diff --git a/DDC/Type/Check/Monad.hs b/DDC/Type/Check/Monad.hs deleted file mode 100644 --- a/DDC/Type/Check/Monad.hs +++ /dev/null @@ -1,28 +0,0 @@ - -module DDC.Type.Check.Monad - ( CheckM (..) - , throw - , result) -where - --- | Type checking monad. -data CheckM err a - = CheckM (Either err a) - -instance Monad (CheckM err) where - return x = CheckM (Right x) - (>>=) m f - = case m of - CheckM (Left err) -> CheckM (Left err) - CheckM (Right x) -> f x - - --- | Throw a type error in the monad. -throw :: err -> CheckM err a -throw e = CheckM $ Left e - - --- | Take the result from a check monad. -result :: CheckM err a -> Either err a -result (CheckM r) = r - diff --git a/DDC/Type/Collect.hs b/DDC/Type/Collect.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Collect.hs @@ -0,0 +1,185 @@ + +-- | Collecting sets of variables and constructors. +module DDC.Type.Collect + ( freeT + , collectBound + , collectBinds + , BindTree (..) + , BindWay (..) + , BindStruct (..) + + , BoundLevel (..) + , isBoundExpWit + , boundLevelOfBindWay + , bindDefT) +where +import DDC.Type.Exp +import DDC.Type.Env (Env) +import qualified DDC.Type.Env as Env +import qualified DDC.Type.Sum as Sum +import qualified Data.Set as Set +import Data.Set (Set) + + +-- freeT ---------------------------------------------------------------------- +-- | Collect the free Spec variables in a thing (level-1). +freeT :: (BindStruct c, Ord n) + => Env n -> c n -> Set (Bound n) +freeT tenv xx = Set.unions $ map (freeOfTreeT tenv) $ slurpBindTree xx + +freeOfTreeT :: Ord n => Env n -> BindTree n -> Set (Bound n) +freeOfTreeT kenv tt + = case tt of + BindDef way bs ts + | BoundSpec <- boundLevelOfBindWay way + , kenv' <- Env.extends bs kenv + -> Set.unions $ map (freeOfTreeT kenv') ts + + BindDef _ _ ts + -> Set.unions $ map (freeOfTreeT kenv) ts + + BindUse BoundSpec u + | Env.member u kenv -> Set.empty + | otherwise -> Set.singleton u + _ -> Set.empty + + +-- collectBound --------------------------------------------------------------- +-- | Collect all the bound variables in a thing, +-- independent of whether they are free or not. +collectBound :: (BindStruct c, Ord n) => c n -> Set (Bound n) +collectBound + = Set.unions . map collectBoundOfTree . slurpBindTree + +collectBoundOfTree :: Ord n => BindTree n -> Set (Bound n) +collectBoundOfTree tt + = case tt of + BindDef _ _ ts -> Set.unions $ map collectBoundOfTree ts + BindUse _ u -> Set.singleton u + BindCon _ u _ -> Set.singleton u + + +-- collectSpecBinds ----------------------------------------------------------- +-- | Collect all the spec and exp binders in a thing. +collectBinds + :: (BindStruct c, Ord n) + => c n + -> ([Bind n], [Bind n]) + +collectBinds thing + = let tree = slurpBindTree thing + in ( concatMap collectSpecBindsOfTree tree + , concatMap collectExpBindsOfTree tree) + + +collectSpecBindsOfTree :: Ord n => BindTree n -> [Bind n] +collectSpecBindsOfTree tt + = case tt of + BindDef way bs ts + | BoundSpec <- boundLevelOfBindWay way + -> concat ( bs + : map collectSpecBindsOfTree ts) + + | otherwise + -> concatMap collectSpecBindsOfTree ts + + _ -> [] + + +collectExpBindsOfTree :: Ord n => BindTree n -> [Bind n] +collectExpBindsOfTree tt + = case tt of + BindDef way bs ts + | BoundExp <- boundLevelOfBindWay way + -> concat ( bs + : map collectExpBindsOfTree ts) + + | otherwise + -> concatMap collectExpBindsOfTree ts + + _ -> [] + + +------------------------------------------------------------------------------- +-- | A description of the binding structure of some type or expression. +data BindTree n + -- | An abstract binding expression. + = BindDef BindWay [Bind n] [BindTree n] + + -- | Use of a variable. + | BindUse BoundLevel (Bound n) + + -- | Use of a constructor. + | BindCon BoundLevel (Bound n) (Maybe (Kind n)) + deriving (Eq, Show) + + +-- | Describes how a variable was bound. +data BindWay + = BindForall + | BindLAM + | BindLam + | BindLet + | BindLetRec + | BindLetRegions + | BindLetRegionWith + | BindCasePat + deriving (Eq, Show) + + +-- | What level this binder is at. +data BoundLevel + = BoundSpec + | BoundExp + | BoundWit + deriving (Eq, Show) + + +-- | Check if a boundlevel is expression or witness +isBoundExpWit :: BoundLevel -> Bool +isBoundExpWit BoundExp = True +isBoundExpWit BoundWit = True +isBoundExpWit _ = False + + +-- | Get the `BoundLevel` corresponding to a `BindWay`. +boundLevelOfBindWay :: BindWay -> BoundLevel +boundLevelOfBindWay way + = case way of + BindForall -> BoundSpec + BindLAM -> BoundSpec + BindLam -> BoundExp + BindLet -> BoundExp + BindLetRec -> BoundExp + BindLetRegions -> BoundSpec + BindLetRegionWith -> BoundExp + BindCasePat -> BoundExp + + +-- BindStruct ----------------------------------------------------------------- +class BindStruct (c :: * -> *) where + slurpBindTree :: c n -> [BindTree n] + + +instance BindStruct Type where + slurpBindTree tt + = case tt of + TVar u -> [BindUse BoundSpec u] + TCon tc -> slurpBindTree tc + TForall b t -> [bindDefT BindForall [b] [t]] + TApp t1 t2 -> slurpBindTree t1 ++ slurpBindTree t2 + TSum ts -> concatMap slurpBindTree $ Sum.toList ts + + +instance BindStruct TyCon where + slurpBindTree tc + = case tc of + TyConBound u k -> [BindCon BoundSpec u (Just k)] + _ -> [] + + +-- | Helper for constructing the `BindTree` for a type binder. +bindDefT :: BindStruct c + => BindWay -> [Bind n] -> [c n] -> BindTree n +bindDefT way bs xs + = BindDef way bs $ concatMap slurpBindTree xs diff --git a/DDC/Type/Collect/FreeT.hs b/DDC/Type/Collect/FreeT.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Collect/FreeT.hs @@ -0,0 +1,47 @@ + +module DDC.Type.Collect.FreeT + (FreeVarConT(..)) +where +import DDC.Type.Exp +import Data.Set (Set) +import DDC.Type.Env (KindEnv) +import qualified DDC.Type.Env as Env +import qualified DDC.Type.Sum as Sum +import qualified Data.Set as Set + + +class FreeVarConT (c :: * -> *) where + -- | Collect the free type variables and constructors used in a thing. + freeVarConT + :: Ord n + => KindEnv n -> c n + -> (Set (Bound n), Set (Bound n)) + + +instance FreeVarConT Type where + freeVarConT kenv tt + = case tt of + TVar u + -> if Env.member u kenv + then (Set.empty, Set.empty) + else (Set.singleton u, Set.empty) + + TCon tc + | TyConBound u _ <- tc -> (Set.empty, Set.singleton u) + | otherwise -> (Set.empty, Set.empty) + + TForall b t + -> freeVarConT (Env.extend b kenv) t + + TApp t1 t2 + -> let (vs1, cs1) = freeVarConT kenv t1 + (vs2, cs2) = freeVarConT kenv t2 + in ( Set.union vs1 vs2 + , Set.union cs1 cs2) + + TSum ts + -> let (vss, css) = unzip $ map (freeVarConT kenv) + $ Sum.toList ts + in (Set.unions vss, Set.unions css) + + diff --git a/DDC/Type/Compounds.hs b/DDC/Type/Compounds.hs --- a/DDC/Type/Compounds.hs +++ b/DDC/Type/Compounds.hs @@ -1,6 +1,6 @@ {-# OPTIONS -fno-warn-missing-signatures #-} module DDC.Type.Compounds - ( -- * Binds + ( -- * Binds takeNameOfBind , typeOfBind , replaceTypeOfBind @@ -11,31 +11,53 @@ , partitionBindsByType -- * Bounds - , typeOfBound , takeNameOfBound - , replaceTypeOfBound , boundMatchesBind , namedBoundMatchesBind , takeSubstBoundOfBind + , takeSubstBoundsOfBinds - -- * Type structure - , tIx - , tApp, ($:) - , tApps, takeTApps - , takeTyConApps, takeDataTyConApps + -- * Kinds + , kFun + , kFuns + , takeKFun + , takeKFuns + , takeKFuns' + , takeResultKind + + -- * Quantifiers , tForall - , tForalls, takeTForalls + , tForalls, takeTForalls, eraseTForalls + + -- * Sums , tBot , tSum - -- * Function type construction - , kFun - , kFuns, takeKFun - , takeKFuns, takeKFuns', takeResultKind - , tFun, takeTFun, takeTFunArgResult + -- * Applications + , tApp, ($:) + , tApps, takeTApps + , takeTyConApps + , takePrimTyConApps + , takeDataTyConApps + , takePrimeRegion + + -- * Functions + , tFun , tFunPE + , takeTFun + , takeTFunArgResult + , takeTFunWitArgResult + , arityOfType + + -- * Implications , tImpl + -- * Units + , tUnit + + -- * Variables + , tIx + -- * Sort construction , sComp, sProp @@ -47,15 +69,16 @@ , tWrite, tDeepWrite , tAlloc, tDeepAlloc - -- * Closure type constructors. + -- * Closure type constructors , tUse, tDeepUse - -- * Witness type constructors. + -- * Witness type constructors , tPure , tEmpty , tGlobal, tDeepGlobal , tConst, tDeepConst , tMutable, tDeepMutable + , tDistinct , tLazy, tHeadLazy , tManifest , tConData0, tConData1) @@ -123,32 +146,14 @@ -- Bounds --------------------------------------------------------------------- --- | Take the type of a bound variable. -typeOfBound :: Bound n -> Type n -typeOfBound uu - = case uu of - UName _ t -> t - UPrim _ t -> t - UIx _ t -> t - - -- | Take the name of bound variable. -- If this is a deBruijn index then there won't be a name. takeNameOfBound :: Bound n -> Maybe n takeNameOfBound uu = case uu of - UName n _ -> Just n + UName n -> Just n UPrim n _ -> Just n - UIx _ _ -> Nothing - - --- | Replace the type of a bound with a new one. -replaceTypeOfBound :: Type n -> Bound n -> Bound n -replaceTypeOfBound t uu - = case uu of - UName n _ -> UName n t - UPrim n _ -> UPrim n t - UIx i _ -> UIx i t + UIx{} -> Nothing -- | Check whether a bound maches a bind. @@ -158,9 +163,9 @@ 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 + (UName n1, BName n2 _) -> n1 == n2 + (UIx 0, BAnon _) -> True + _ -> False -- | Check whether a named bound matches a named bind. @@ -168,27 +173,36 @@ namedBoundMatchesBind :: Eq n => Bound n -> Bind n -> Bool namedBoundMatchesBind u b = case (u, b) of - (UName n1 _, BName n2 _) -> n1 == n2 - _ -> False - + (UName n1, BName n2 _) -> n1 == n2 + _ -> False --- | Convert a `Bound` to a `Bind`, ready for substitution. +-- | 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 t -> Just $ UName n t - BAnon t -> Just $ UIx 0 t + BName n _ -> Just $ UName n + BAnon _ -> Just $ UIx 0 BNone _ -> Nothing +-- | Convert some `Bind`s to `Bounds` +takeSubstBoundsOfBinds :: [Bind n] -> [Bound n] +takeSubstBoundsOfBinds bs + = go 0 bs + where go _level [] = [] + go level (BName n _ : bs') = UName n : go level bs' + go level (BAnon _ : bs') = UIx level : go (level + 1) bs' + go level (BNone _ : bs') = go level bs' + + -- Variables ------------------------------------------------------------------ -- | Construct a deBruijn index. tIx :: Kind n -> Int -> Type n -tIx k i = TVar (UIx i k) +tIx _ i = TVar (UIx i) -- Applications --------------------------------------------------------------- @@ -226,35 +240,58 @@ -- | 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 _ t) <- tc - , TCon (TyConKind KiConData) <- takeResultKind t + | TyConBound (UName _) k <- tc + , TCon (TyConKind KiConData) <- takeResultKind k -> Just (tc, args) - | TyConBound (UPrim _ t) <- tc - , TCon (TyConKind KiConData) <- takeResultKind t + | TyConBound UPrim{} k <- tc + , TCon (TyConKind KiConData) <- takeResultKind k -> Just (tc, args) _ -> Nothing +-- | Take the prime region variable of a data type. +-- This corresponds to the region the outermost constructor is allocated into. +takePrimeRegion :: Type n -> Maybe (Type n) +takePrimeRegion tt + = case takeTApps tt of + TCon _ : tR@(TVar _) : _ + -> Just tR + + _ -> Nothing + + -- Foralls -------------------------------------------------------------------- -- | Build an anonymous type abstraction, with a single parameter. tForall :: Kind n -> (Type n -> Type n) -> Type n tForall k f - = TForall (BAnon k) (f (TVar (UIx 0 k))) + = TForall (BAnon k) (f (TVar (UIx 0))) -- | Build an anonymous type abstraction, with several parameters. tForalls :: [Kind n] -> ([Type n] -> Type n) -> Type n tForalls ks f = let bs = [BAnon k | k <- ks] - us = reverse [TVar (UIx n k) | k <- ks | n <- [0..]] - in foldr TForall (f us) bs + us = map (\i -> TVar (UIx i)) [0.. (length ks - 1)] + in foldr TForall (f $ reverse us) bs -- | Split nested foralls from the front of a type, @@ -268,17 +305,33 @@ (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` @@ -330,7 +383,6 @@ tFun :: Type n -> Effect n -> Closure n -> Type n -> Type n tFun t1 eff clo t2 = (TCon $ TyConSpec TcConFun) `tApps` [t1, eff, clo, t2] - infixr `tFun` @@ -343,8 +395,8 @@ _ -> Nothing --- | Destruct the type of a value function, returning just the argument --- and result types. +-- | 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 @@ -354,17 +406,40 @@ _ -> ([], 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) + + +-- | Determine the arity of an expression by looking at its type. +-- Count all the function arrows, and foralls. +arityOfType :: Type n -> Int +arityOfType tt + = case tt of + TForall _ t -> 1 + arityOfType t + t -> length $ fst $ takeTFunArgResult t + + -- | Construct a pure and empty value type function. tFunPE :: Type n -> Type n -> Type n tFunPE t1 t2 = tFun t1 (tBot kEffect) (tBot kClosure) t2 +infixr `tFunPE` -- | Construct a witness implication type. tImpl :: Type n -> Type n -> Type n tImpl t1 t2 = ((TCon $ TyConWitness TwConImpl) `tApp` t1) `tApp` t2 - infixr `tImpl` @@ -405,6 +480,7 @@ tDeepConst = twCon1 TwConDeepConst tMutable = twCon1 TwConMutable tDeepMutable = twCon1 TwConDeepMutable +tDistinct n = twCon2 (TwConDistinct n) tLazy = twCon1 TwConLazy tHeadLazy = twCon1 TwConHeadLazy tManifest = twCon1 TwConManifest @@ -412,14 +488,16 @@ 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)) +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 +tConData1 n k t1 = TApp (TCon (TyConBound (UName n) k)) t1 diff --git a/DDC/Type/DataDef.hs b/DDC/Type/DataDef.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/DataDef.hs @@ -0,0 +1,142 @@ + +-- | Algebraic data type definitions. +module DDC.Type.DataDef + ( DataDef (..) + + -- * Data type definition table + , DataDefs (..) + , DataMode (..) + , DataType (..) + , DataCtor (..) + + , emptyDataDefs + , insertDataDef + , fromListDataDefs + , lookupModeOfDataType) +where +import DDC.Type.Exp +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import Control.Monad + + +-- | The definition of a single data type. +data DataDef n + = DataDef + { -- | Name of the data type. + dataDefTypeName :: !n + + -- | Kinds of type parameters. + , dataDefParamKinds :: ![Kind n] + + -- | Constructors of the data type, or Nothing if there are + -- too many to list (like with `Int`). + , dataDefCtors :: !(Maybe [(n, [Type n])]) } + deriving Show + + +-- DataDefs ------------------------------------------------------------------- +-- | A table of data type definitions, +-- unpacked into type and data constructors so we can find them easily. +data DataDefs n + = DataDefs + { dataDefsTypes :: !(Map n (DataType n)) + , dataDefsCtors :: !(Map n (DataCtor n)) } + deriving Show + + +-- | The mode of a data type records how many data constructors there are. +-- This can be set to 'Large' for large primitive types like Int and Float. +-- In this case we don't ever expect them all to be enumerated +-- as case alternatives. +data DataMode n + = DataModeSmall ![n] + | DataModeLarge + deriving Show + + +-- | Describes a data type constructor, used in the `DataDefs` table. +data DataType n + = DataType + { -- | Name of data type constructor. + dataTypeName :: !n + + -- | Kinds of type parameters to constructor. + , dataTypeParamKinds :: ![Kind n] + + -- | Names of data constructors of this data type, + -- or `Nothing` if it has infinitely many constructors. + , dataTypeMode :: !(DataMode n) } + deriving Show + + +-- | Describes a data constructor, used in the `DataDefs` table. +data DataCtor n + = DataCtor + { -- | Name of data constructor. + dataCtorName :: !n + + -- | Tag of constructor (order in data type declaration) + , dataCtorTag :: !Integer + + -- | Field types of constructor. + , dataCtorFieldTypes :: ![Type n] + + -- | Name of result type of constructor. + , dataCtorTypeName :: !n } + deriving Show + + +-- | An empty table of data type definitions. +emptyDataDefs :: DataDefs n +emptyDataDefs + = DataDefs + { dataDefsTypes = Map.empty + , dataDefsCtors = Map.empty } + + +-- | Insert a data type definition into some DataDefs. +insertDataDef :: Ord n => DataDef n -> DataDefs n -> DataDefs n +insertDataDef (DataDef nType ks mCtors) dataDefs + = let defType = DataType + { dataTypeName = nType + , dataTypeParamKinds = ks + , dataTypeMode = defMode } + + defMode = case mCtors of + Nothing -> DataModeLarge + Just ctors -> DataModeSmall (map fst ctors) + + makeDefCtor tag (nCtor, tsFields) + = DataCtor + { dataCtorName = nCtor + , dataCtorTag = tag + , dataCtorFieldTypes = tsFields + , dataCtorTypeName = nType } + + defCtors = case mCtors of + Nothing -> Nothing + Just cs -> Just $ zipWith makeDefCtor [0..] cs + + in dataDefs + { dataDefsTypes = Map.insert nType defType (dataDefsTypes dataDefs) + , dataDefsCtors = Map.union (dataDefsCtors dataDefs) + $ Map.fromList [(n, def) + | def@(DataCtor n _ _ _) <- concat $ maybeToList defCtors ]} + + +-- | Build a `DataDefs` table from a list of `DataDef` +fromListDataDefs :: Ord n => [DataDef n] -> DataDefs n +fromListDataDefs defs + = foldr insertDataDef emptyDataDefs defs + + + +-- | Yield the list of data constructor names for some data type, +-- or `Nothing` for large types with too many constructors to list. +lookupModeOfDataType :: Ord n => n -> DataDefs n -> Maybe (DataMode n) +lookupModeOfDataType n defs + = liftM dataTypeMode $ Map.lookup n (dataDefsTypes defs) + + diff --git a/DDC/Type/Env.hs b/DDC/Type/Env.hs --- a/DDC/Type/Env.hs +++ b/DDC/Type/Env.hs @@ -8,24 +8,43 @@ -- module DDC.Type.Env ( Env(..) + , KindEnv + , TypeEnv + + -- * Construction , empty - , extend, extends - , setPrimFun, isPrim - , fromList + , extend + , extends , union - , member, memberBind - , lookup, lookupName + + -- * Conversion + , fromList + , fromTypeMap + + -- * Projetions , depth - , lift - , wrapTForalls) + , member + , memberBind + , lookup + , lookupName + + -- * Primitives + , setPrimFun + , isPrim + + -- * Lifting + , wrapTForalls + + -- * Wrapping + , lift) where import DDC.Type.Exp import DDC.Type.Transform.LiftT import Data.Maybe -import Data.Map (Map) -import Prelude hiding (lookup) -import qualified Data.Map as Map -import qualified Prelude as P +import Data.Map (Map) +import Prelude hiding (lookup) +import qualified Data.Map.Strict as Map +import qualified Prelude as P import Control.Monad @@ -33,18 +52,26 @@ data Env n = Env { -- | Types of named binders. - envMap :: Map n (Type n) + envMap :: !(Map n (Type n)) -- | Types of anonymous deBruijn binders. - , envStack :: [Type n] + , envStack :: ![Type n] -- | The length of the above stack. - , envStackLength :: Int + , envStackLength :: !Int -- | Types of baked in, primitive names. - , envPrimFun :: n -> Maybe (Type n) } + , envPrimFun :: !(n -> Maybe (Type n)) } +-- | Type synonym to improve readability. +type KindEnv n = Env n + + +-- | Type synonym to improve readability. +type TypeEnv n = Env n + + -- | An empty environment. empty :: Env n empty = Env @@ -90,6 +117,12 @@ = foldr extend empty bs +-- | Convert a map of names to types to a environment. +fromTypeMap :: Map n (Type n) -> Env n +fromTypeMap m + = empty { envMap = m} + + -- | Combine two environments. -- If both environments have a binding with the same name, -- then the one in the second environment takes preference. @@ -121,15 +154,12 @@ lookup :: Ord n => Bound n -> Env n -> Maybe (Type n) lookup uu env = case uu of - UName n _ + UName n -> Map.lookup n (envMap env) `mplus` envPrimFun env n - UIx i _ - -> P.lookup i (zip [0..] (envStack env)) - - UPrim n _ - -> envPrimFun env n + UIx i -> P.lookup i (zip [0..] (envStack env)) + UPrim n _ -> envPrimFun env n -- | Lookup a bound name from an environment. @@ -144,8 +174,13 @@ -- | Lift all free deBruijn indices in the environment by the given number of steps. --- TODO: Delay this, only lift when we extract the final type. --- will also need to update the 'member' function. +--- +-- ISSUE #276: Delay lifting of indices in type environments. +-- The 'lift' function on type environments applies to every member of +-- the environment. We'd get better complexity by recording how many +-- levels all types should be lifted by, and only applying the real lift +-- function when the type is finally extracted. +-- lift :: Ord n => Int -> Env n -> Env n lift n env = Env diff --git a/DDC/Type/Equiv.hs b/DDC/Type/Equiv.hs --- a/DDC/Type/Equiv.hs +++ b/DDC/Type/Equiv.hs @@ -1,13 +1,12 @@ module DDC.Type.Equiv - (equivT) + ( equivT + , equivWithBindsT) where -import DDC.Type.Exp -import DDC.Type.Compounds import DDC.Type.Transform.Crush -import DDC.Type.Transform.Trim -import DDC.Base.Pretty -import Data.Maybe +import DDC.Type.Compounds +import DDC.Type.Bind +import DDC.Type.Exp import qualified DDC.Type.Sum as Sum @@ -22,33 +21,42 @@ -- bound variables match the binders. If this is not the case then you get -- an indeterminate result. -- -equivT :: (Ord n, Pretty n) => Type n -> Type n -> Bool +equivT :: Ord n => Type n -> Type n -> Bool equivT t1 t2 - = equivT' [] 0 [] 0 t1 t2 - + = equivWithBindsT [] [] t1 t2 -equivT' :: (Ord n, Pretty n) - => [Bind n] -> Int - -> [Bind n] -> Int - -> Type n -> Type n +-- | Like `equivT` but take the initial stacks of type binders. +equivWithBindsT + :: Ord n + => [Bind n] + -> [Bind n] + -> Type n + -> Type n -> Bool -equivT' stack1 depth1 stack2 depth2 t1 t2 +equivWithBindsT stack1 stack2 t1 t2 = let t1' = unpackSumT $ crushSomeT t1 t2' = unpackSumT $ crushSomeT t2 in case (t1', t2') of (TVar u1, TVar u2) - -- Bound variables are name-equivalent. - | u1 == u2 -> True + -- 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 - -- Variables aren't name equivalent, - -- but would be equivalent if we renamed them. - | depth1 == depth2 - , Just (ix1, t1a) <- getBindType stack1 u1 + -- 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 - -> equivT' stack1 depth1 stack2 depth2 t1a t2a + -> checkBounds u1 u2 + $ equivWithBindsT stack1 stack2 t1a t2a + | otherwise + -> checkBounds u1 u2 + $ False + -- Constructor names must be equal. (TCon tc1, TCon tc2) -> tc1 == tc2 @@ -56,31 +64,34 @@ -- Push binders on the stack as we enter foralls. (TForall b11 t12, TForall b21 t22) | equivT (typeOfBind b11) (typeOfBind b21) - -> equivT' (b11 : stack1) (depth1 + 1) - (b21 : stack2) (depth2 + 1) - t12 t22 + -> equivWithBindsT + (b11 : stack1) + (b21 : stack2) + t12 t22 -- Decend into applications. (TApp t11 t12, TApp t21 t22) - -> equivT' stack1 depth1 stack2 depth2 t11 t21 - && equivT' stack1 depth1 stack2 depth2 t12 t22 + -> 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 - equiv = equivT' stack1 depth1 stack2 depth2 -- If all the components of the sum were in the element -- arrays then they come out of Sum.toList sorted -- and we can compare corresponding pairs. - checkFast = and $ zipWith equiv ts1' ts2' + 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. - checkSlow = and [ or (map (equiv t1c) ts2') | t1c <- ts1' ] - && and [ or (map (equiv t2c) ts1') | t2c <- ts2' ] + -- 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) @@ -88,62 +99,30 @@ (_, _) -> False --- | Unpack single element sums into plain types. -unpackSumT :: Type n -> Type n -unpackSumT (TSum ts) - | [t] <- Sum.toList ts = t -unpackSumT tt = tt - - --- | Crush compound effects and closure terms. --- We check for a crushable term before calling crushT because that function --- will recursively crush the components. --- As equivT is already recursive, we don't want a doubly-recursive function --- that tries to re-crush the same non-crushable type over and over. --- -crushSomeT :: (Ord n, Pretty n) => Type n -> Type n -crushSomeT tt - = case tt of - (TApp (TCon tc) _) - -> case tc of - TyConSpec TcConDeepRead -> crushEffect tt - TyConSpec TcConDeepWrite -> crushEffect tt - TyConSpec TcConDeepAlloc -> crushEffect tt - - -- If a closure is miskinded then 'trimClosure' - -- can return Nothing, so we just leave the term untrimmed. - TyConSpec TcConDeepUse -> fromMaybe tt (trimClosure tt) - - TyConWitness TwConDeepGlobal -> crushEffect tt - _ -> tt - - _ -> tt - - --- | Lookup the type of a bound thing from the binder stack. --- The binder stack contains the binders of all the `TForall`s we've --- entered under so far. -getBindType :: Eq n => [Bind n] -> Bound n -> Maybe (Int, Type n) -getBindType bs' u - = go 0 bs' - where go n (BName n1 t : bs) - | UName n2 _ <- u - , n1 == n2 = Just (n, t) - | otherwise = go (n + 1) bs - - - go n (BAnon t : bs) - | UIx i _ <- u - , i == 0 = Just (n, t) +-- | 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 - | UIx i _ <- u - , i < 0 = Nothing + (UPrim n1 _, UName n2) + | n1 == n2 -> die - | otherwise = go (n + 1) bs + _ -> x + where + die = error $ unlines + [ "DDC.Type.Equiv" + , " Found a primitive and non-primitive bound variable with the same name."] - go n (BNone _ : bs) - = go (n + 1) bs +-- | Unpack single element sums into plain types. +unpackSumT :: Type n -> Type n +unpackSumT (TSum ts) + | [t] <- Sum.toList ts = t +unpackSumT tt = tt - go _ [] = Nothing diff --git a/DDC/Type/Exp.hs b/DDC/Type/Exp.hs --- a/DDC/Type/Exp.hs +++ b/DDC/Type/Exp.hs @@ -1,10 +1,7 @@ module DDC.Type.Exp ( -- * Types, Kinds, and Sorts - Binder (..) - , Bind (..) - , Bound (..) - , Type (..) + Type (..) , Kind, Sort , Region, Effect, Closure , TypeSum (..), TyConHash(..), TypeSumVarCon(..) @@ -12,260 +9,11 @@ , SoCon (..) , KiCon (..) , TwCon (..) - , TcCon (..)) + , TcCon (..) + , Binder (..) + , Bind (..) + , Bound (..)) where -import Data.Array -import Data.Map (Map) -import Data.Set (Set) - - --- Bind ----------------------------------------------------------------------- --- | A variable binder. -data Binder n - = RNone - | RAnon - | RName n - deriving Show - - --- | A variable binder with its type. -data Bind n - -- | A variable with no uses in the body doesn't need a name. - = BNone (Type n) - - -- | Nameless variable on the deBruijn stack. - | BAnon (Type n) - - -- | Named variable in the environment. - | BName n (Type n) - deriving Show - - - --- | A bound occurrence of a variable, with its type. --- --- If variable hasn't been annotated with its real type then this --- can be `tBot` (an empty sum). - -data Bound n - -- | Nameless variable that should be on the deBruijn stack. - = UIx Int (Type n) - - -- | Named variable that should be in the environment. - | UName n (Type n) - - -- | Named primitive that is not bound in the environment. - -- Prims aren't every counted as being free. - | UPrim n (Type n) - deriving Show - - --- Types ---------------------------------------------------------------------- --- | A value type, kind, or sort. --- --- We use the same data type to represent all three universes, as they have --- a similar algebraic structure. --- -data Type n - -- | Variable. - = TVar (Bound n) - - -- | Constructor. - | TCon (TyCon n) - - -- | Abstraction. - | TForall (Bind n) (Type n) - - -- | Application. - | TApp (Type n) (Type n) - - -- | Least upper bound. - | TSum (TypeSum n) - deriving Show - - -type Sort n = Type n -type Kind n = Type n -type Region n = Type n -type Effect n = Type n -type Closure n = Type n - - --- Type Sums ------------------------------------------------------------------ --- | A least upper bound of several types. --- --- We keep type sums in this normalised format instead of joining them --- together with a binary operator (like @(+)@). This makes sums easier to work --- with, as a given sum type often only has a single physical representation. -data TypeSum n - = TypeSum - { -- | The kind of the elements in this sum. - typeSumKind :: Kind n - - -- | Where we can see the outer constructor of a type, its argument - -- is inserted into this array. This handles common cases like - -- Read, Write, Alloc effects. - , typeSumElems :: Array TyConHash (Set (TypeSumVarCon n)) - - -- | A map for named type variables. - , typeSumBoundNamed :: Map n (Kind n) - - -- | A map for anonymous type variables. - , typeSumBoundAnon :: Map Int (Kind n) - - -- | Types that can't be placed in the other fields go here. - -- - -- INVARIANT: this list doesn't contain more `TSum`s. - , typeSumSpill :: [Type n] } - deriving (Show) - - --- | Hash value used to insert types into the `typeSumElems` array of a `TypeSum`. -data TyConHash - = TyConHash !Int - deriving (Eq, Show, Ord, Ix) - - --- | Wraps a variable or constructor that can be added the `typeSumElems` array. -data TypeSumVarCon n - = TypeSumVar (Bound n) - | TypeSumCon (Bound n) - deriving Show - - --- TyCon ---------------------------------------------------------------------- --- | Kind, type and witness constructors. --- --- These are grouped to make it easy to determine the universe that they --- belong to. --- -data TyCon n - -- | (level 3) Builtin Sort constructors. - = TyConSort SoCon - - -- | (level 2) Builtin Kind constructors. - | TyConKind KiCon - - -- | (level 1) Builtin Spec constructors for the types of witnesses. - | TyConWitness TwCon - - -- | (level 1) Builtin Spec constructors for types of other kinds. - | TyConSpec TcCon - - -- | User defined and primitive constructors. - | TyConBound (Bound n) - deriving Show - - --- | Sort constructor. -data SoCon - -- | Sort of witness kinds. - = SoConProp -- '@@' - - -- | Sort of computation kinds. - | SoConComp -- '**' - deriving (Eq, Show) - - --- | Kind constructor. -data KiCon - -- | Function kind constructor. - -- This is only well formed when it is fully applied. - = KiConFun -- (~>) - - -- Witness kinds ------------------------ - -- | Kind of witnesses. - | KiConWitness -- '@ :: @@' - - -- Computation kinds --------------------- - -- | Kind of data values. - | KiConData -- '* :: **' - - -- | Kind of regions. - | KiConRegion -- '% :: **' - - -- | Kind of effects. - | KiConEffect -- '! :: **' - - -- | Kind of closures. - | KiConClosure -- '$ :: **' - deriving (Eq, Show) - - --- | Witness type constructors. -data TwCon - -- Witness implication. - = TwConImpl -- :: '(=>) :: * ~> *' - - -- | Purity of some effect. - | TwConPure -- :: ! ~> @ - - -- | Emptiness of some closure. - | TwConEmpty -- :: $ ~> @ - - -- | Globalness of some region. - | TwConGlobal -- :: % ~> @ - - -- | Globalness of material regions in some type. - | TwConDeepGlobal -- :: * ~> @ - - -- | Constancy of some region. - | TwConConst -- :: % ~> @ - - -- | Constancy of material regions in some type - | TwConDeepConst -- :: * ~> @ - - -- | Mutability of some region. - | TwConMutable -- :: % ~> @ - - -- | Mutability of material regions in some type. - | TwConDeepMutable -- :: * ~> @ - - -- | Laziness of some region. - | TwConLazy -- :: % ~> @ - - -- | Laziness of the primary region in some type. - | TwConHeadLazy -- :: * ~> @ - - -- | Manifestness of some region (not lazy). - | TwConManifest -- :: % ~> @ - deriving (Eq, Show) - - --- | Other constructors at the spec level. -data TcCon - -- Data type constructors --------------- - -- | The function type constructor is baked in so we - -- represent it separately. - = TcConFun -- '(->) :: * ~> * ~> ! ~> $ ~> *' - - -- Effect type constructors ------------- - -- | Read of some region. - | TcConRead -- :: '% ~> !' - - -- | Read the head region in a data type. - | TcConHeadRead -- :: '* ~> !' - - -- | Read of all material regions in a data type. - | TcConDeepRead -- :: '* ~> !' - - -- | Write of some region. - | TcConWrite -- :: '% ~> !' - - -- | Write to all material regions in some data type. - | TcConDeepWrite -- :: '* ~> !' - - -- | Allocation into some region. - | TcConAlloc -- :: '% ~> !' - - -- | Allocation into all material regions in some data type. - | TcConDeepAlloc -- :: '* ~> !' - - -- Closure type constructors ------------ - -- | Region is captured in a closure. - | TcConUse -- :: '% ~> $' - - -- | All material regions in a data type are captured in a closure. - | TcConDeepUse -- :: '* ~> $' - deriving (Eq, Show) +import DDC.Type.Exp.Base +import DDC.Type.Exp.NFData () diff --git a/DDC/Type/Exp/Base.hs b/DDC/Type/Exp/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/Base.hs @@ -0,0 +1,267 @@ + +module DDC.Type.Exp.Base where +import Data.Array +import Data.Map.Strict (Map) +import Data.Set (Set) + + +-- Bind ----------------------------------------------------------------------- +-- | A variable binder. +data Binder n + = RNone + | RAnon + | RName !n + deriving Show + + +-- | A variable binder with its type. +data Bind n + -- | A variable with no uses in the body doesn't need a name. + = BNone !(Type n) + + -- | Nameless variable on the deBruijn stack. + | BAnon !(Type n) + + -- | Named variable in the environment. + | BName n !(Type n) + deriving Show + + + +-- | A bound occurrence of a variable, with its type. +-- +-- If variable hasn't been annotated with its real type then this +-- can be `tBot` (an empty sum). + +data Bound n + -- | Nameless variable that should be on the deBruijn stack. + = UIx !Int + + -- | Named variable that should be in the environment. + | UName !n + + -- | Named primitive that has its type attached to it. + -- The types of primitives must be closed. + | UPrim !n !(Type n) + deriving Show + + +-- Types ---------------------------------------------------------------------- +-- | A value type, kind, or sort. +-- +-- We use the same data type to represent all three universes, as they have +-- a similar algebraic structure. +-- +data Type n + -- | Variable. + = TVar !(Bound n) + + -- | Constructor. + | TCon !(TyCon n) + + -- | Abstraction. + | TForall !(Bind n) !(Type n) + + -- | Application. + | TApp !(Type n) !(Type n) + + -- | Least upper bound. + | TSum !(TypeSum n) + deriving Show + + +type Sort n = Type n +type Kind n = Type n +type Region n = Type n +type Effect n = Type n +type Closure n = Type n + + +-- Type Sums ------------------------------------------------------------------ +-- | A least upper bound of several types. +-- +-- We keep type sums in this normalised format instead of joining them +-- together with a binary operator (like @(+)@). This makes sums easier to work +-- with, as a given sum type often only has a single physical representation. +data TypeSum n + = TypeSumBot + { typeSumKind :: !(Kind n) } + + | TypeSumSet + { -- | The kind of the elements in this sum. + typeSumKind :: !(Kind n) + + -- | Where we can see the outer constructor of a type, its argument + -- is inserted into this array. This handles common cases like + -- Read, Write, Alloc effects. + , typeSumElems :: !(Array TyConHash (Set (TypeSumVarCon n))) + + -- | A map for named type variables. + , typeSumBoundNamed :: !(Map n (Kind n)) + + -- | A map for anonymous type variables. + , typeSumBoundAnon :: !(Map Int (Kind n)) + + -- | Types that can't be placed in the other fields go here. + -- + -- INVARIANT: this list doesn't contain more `TSum`s. + , typeSumSpill :: ![Type n] } + deriving (Show) + + +-- | Hash value used to insert types into the `typeSumElems` array of a `TypeSum`. +data TyConHash + = TyConHash !Int + deriving (Eq, Show, Ord, Ix) + + +-- | Wraps a variable or constructor that can be added the `typeSumElems` array. +data TypeSumVarCon n + = TypeSumVar !(Bound n) + | TypeSumCon !(Bound n) !(Type n) + deriving Show + + +-- TyCon ---------------------------------------------------------------------- +-- | Kind, type and witness constructors. +-- +-- These are grouped to make it easy to determine the universe that they +-- belong to. +-- +data TyCon n + -- | (level 3) Builtin Sort constructors. + = TyConSort !SoCon + + -- | (level 2) Builtin Kind constructors. + | TyConKind !KiCon + + -- | (level 1) Builtin Spec constructors for the types of witnesses. + | TyConWitness !TwCon + + -- | (level 1) Builtin Spec constructors for types of other kinds. + | TyConSpec !TcCon + + -- | User defined and primitive constructors. + | TyConBound !(Bound n) !(Kind n) + deriving Show + + +-- | Sort constructor. +data SoCon + -- | Sort of witness kinds. + = SoConProp -- '@@' + + -- | Sort of computation kinds. + | SoConComp -- '**' + deriving (Eq, Show) + + +-- | Kind constructor. +data KiCon + -- | Function kind constructor. + -- This is only well formed when it is fully applied. + = KiConFun -- (~>) + + -- Witness kinds ------------------------ + -- | Kind of witnesses. + | KiConWitness -- '@ :: @@' + + -- Computation kinds --------------------- + -- | Kind of data values. + | KiConData -- '* :: **' + + -- | Kind of regions. + | KiConRegion -- '% :: **' + + -- | Kind of effects. + | KiConEffect -- '! :: **' + + -- | Kind of closures. + | KiConClosure -- '$ :: **' + deriving (Eq, Show) + + +-- | Witness type constructors. +data TwCon + -- Witness implication. + = TwConImpl -- :: '(=>) :: @ ~> *' + + -- | Purity of some effect. + | TwConPure -- :: ! ~> @ + + -- | Emptiness of some closure. + | TwConEmpty -- :: $ ~> @ + + -- | Globalness of some region. + | TwConGlobal -- :: % ~> @ + + -- | Globalness of material regions in some type. + | TwConDeepGlobal -- :: * ~> @ + + -- | Constancy of some region. + | TwConConst -- :: % ~> @ + + -- | Constancy of material regions in some type + | TwConDeepConst -- :: * ~> @ + + -- | Mutability of some region. + | TwConMutable -- :: % ~> @ + + -- | Mutability of material regions in some type. + | TwConDeepMutable -- :: * ~> @ + + -- | Distinctness of some n regions + | TwConDistinct Int -- :: * ~> [%] ~> @ + + -- | Laziness of some region. + | TwConLazy -- :: % ~> @ + + -- | Laziness of the primary region in some type. + | TwConHeadLazy -- :: * ~> @ + + -- | Manifestness of some region (not lazy). + | TwConManifest -- :: % ~> @ + + -- | Non-interfering effects are disjoint. Used for rewrite rules. + | TwConDisjoint -- :: ! ~> ! ~> @ + deriving (Eq, Show) + + +-- | Other constructors at the spec level. +data TcCon + -- Data type constructors --------------- + -- | The unit data type constructor is baked in. + = TcConUnit -- 'Unit :: *' + + -- | The function type constructor is baked in. + | TcConFun -- '(->) :: * ~> * ~> ! ~> $ ~> *' + + -- Effect type constructors ------------- + -- | Read of some region. + | TcConRead -- :: '% ~> !' + + -- | Read the head region in a data type. + | TcConHeadRead -- :: '* ~> !' + + -- | Read of all material regions in a data type. + | TcConDeepRead -- :: '* ~> !' + + -- | Write of some region. + | TcConWrite -- :: '% ~> !' + + -- | Write to all material regions in some data type. + | TcConDeepWrite -- :: '* ~> !' + + -- | Allocation into some region. + | TcConAlloc -- :: '% ~> !' + + -- | Allocation into all material regions in some data type. + | TcConDeepAlloc -- :: '* ~> !' + + -- Closure type constructors ------------ + -- | Region is captured in a closure. + | TcConUse -- :: '% ~> $' + + -- | All material regions in a data type are captured in a closure. + | TcConDeepUse -- :: '* ~> $' + deriving (Eq, Show) diff --git a/DDC/Type/Exp/NFData.hs b/DDC/Type/Exp/NFData.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Exp/NFData.hs @@ -0,0 +1,81 @@ + +module DDC.Type.Exp.NFData where +import DDC.Type.Exp.Base +import Control.DeepSeq + + +instance NFData n => NFData (Binder n) where + rnf bb + = case bb of + RNone -> () + RAnon -> () + RName n -> rnf n + + +instance NFData n => NFData (Bind n) where + rnf bb + = case bb of + BNone t -> rnf t + BAnon t -> rnf t + BName n t -> rnf n `seq` rnf t + + +instance NFData n => NFData (Bound n) where + rnf uu + = case uu of + UIx i -> rnf i + UName n -> rnf n + UPrim u t -> rnf u `seq` rnf t + + +instance NFData n => NFData (Type n) where + rnf tt + = case tt of + TVar u -> rnf u + TCon tc -> rnf tc + TForall b t -> rnf b `seq` rnf t + TApp t1 t2 -> rnf t1 `seq` rnf t2 + TSum ts -> rnf ts + + +instance NFData n => NFData (TypeSum n) where + rnf !ts + = case ts of + TypeSumBot{} + -> rnf (typeSumKind ts) + + TypeSumSet{} + -> rnf (typeSumKind ts) + `seq` rnf (typeSumElems ts) + `seq` rnf (typeSumBoundNamed ts) + `seq` rnf (typeSumBoundAnon ts) + `seq` rnf (typeSumSpill ts) + + +instance NFData TyConHash where + rnf (TyConHash i) + = rnf i + + +instance NFData n => NFData (TypeSumVarCon n) where + rnf ts + = case ts of + TypeSumVar u -> rnf u + TypeSumCon u t -> rnf u `seq` rnf t + + +instance NFData n => NFData (TyCon n) where + rnf tc + = case tc of + TyConSort con -> rnf con + TyConKind con -> rnf con + TyConWitness con -> rnf con + TyConSpec con -> rnf con + TyConBound con k -> rnf con `seq` rnf k + + +instance NFData SoCon +instance NFData KiCon +instance NFData TwCon +instance NFData TcCon + diff --git a/DDC/Type/Parser.hs b/DDC/Type/Parser.hs deleted file mode 100644 --- a/DDC/Type/Parser.hs +++ /dev/null @@ -1,236 +0,0 @@ - --- | Parser for type expressions. -module DDC.Type.Parser - ( module DDC.Base.Parser - , Parser - , pType, pTypeAtom, pTypeApp - , pBinder - , pIndex - , pTok, pTokAs) -where -import DDC.Core.Parser.Tokens -import DDC.Type.Exp -import DDC.Type.Compounds -import DDC.Base.Parser (()) -import qualified DDC.Base.Parser as P -import qualified DDC.Type.Sum as TS - - --- | Parser of type tokens. -type Parser n a - = P.Parser (Tok n) a - - --- | Top level parser for types. -pType :: Ord n => Parser n (Type n) -pType = pTypeSum - "a type" - - --- | Parse a type sum. -pTypeSum :: Ord n => Parser n (Type n) -pTypeSum - = do t1 <- pTypeForall - P.choice - [ -- Type sums. - -- T2 + T3 - do pTok KPlus - t2 <- pTypeSum - return $ TSum $ TS.fromList (tBot sComp) [t1, t2] - - , do return t1 ] - "a type" - - --- | Parse a binder. -pBinder :: Ord n => Parser n (Binder n) -pBinder - = P.choice - -- Named binders. - [ do v <- pVar - return $ RName v - - -- Anonymous binders. - , do pTok KHat - return $ RAnon - - -- Vacant binders. - , do pTok KUnderscore - return $ RNone ] - "a binder" - - --- | Parse a quantified type. -pTypeForall :: Ord n => Parser n (Type n) -pTypeForall - = P.choice - [ -- Universal quantification. - -- [v1 v1 ... vn : T1]. T2 - do pTok KSquareBra - bs <- P.many1 pBinder - pTok KColon - k <- pTypeSum - pTok KSquareKet - pTok KDot - - body <- pTypeForall - - return $ foldr TForall body - $ map (\b -> makeBindFromBinder b k) bs - - -- Body type - , do pTypeFun] - "a type" - - --- | Parse a function type. -pTypeFun :: Ord n => Parser n (Type n) -pTypeFun - = do t1 <- pTypeApp - P.choice - [ -- T1 ~> T2 - do pTok KArrowTilde - t2 <- pTypeFun - return $ TApp (TApp (TCon (TyConKind KiConFun)) t1) t2 - - -- T1 => T2 - , do pTok KArrowEquals - t2 <- pTypeFun - return $ TApp (TApp (TCon (TyConWitness TwConImpl)) t1) t2 - - -- T1 -> T2 - , do pTok KArrowDash - t2 <- pTypeFun - return $ t1 `tFunPE` t2 - - -- T1 -(TSUM | TSUM)> t2 - , do pTok KDash - pTok KRoundBra - eff <- pTypeSum - pTok KBar - clo <- pTypeSum - pTok KRoundKet - pTok KAngleKet - t2 <- pTypeFun - return $ tFun t1 eff clo t2 - - - -- Body type - , do return t1 ] - "an atomic type or type application" - - --- | Parse a type application. -pTypeApp :: Ord n => Parser n (Type n) -pTypeApp - = do (t:ts) <- P.many1 pTypeAtom - return $ foldl TApp t ts - "an atomic type or type application" - - --- | Parse a variable, constructor or parenthesised type. -pTypeAtom :: Ord n => Parser n (Type n) -pTypeAtom - = P.choice - -- (~>) and (=>) and (->) and (TYPE2) - [ do pTok KRoundBra - P.choice - [ do pTok KArrowTilde - pTok KRoundKet - return (TCon $ TyConKind KiConFun) - - , do pTok KArrowEquals - pTok KRoundKet - return (TCon $ TyConWitness TwConImpl) - - , do pTok KArrowDash - pTok KRoundKet - return (TCon $ TyConSpec TcConFun) - - , do t <- pTypeSum - pTok KRoundKet - return t - ] - - -- Named type constructors - , do tc <- pTcCon - return $ TCon (TyConSpec tc) - - , do tc <- pTwCon - return $ TCon (TyConWitness tc) - - , do tc <- pTyConNamed - return $ TCon tc - - -- Symbolic constructors. - , do pTokAs KSortComp (TCon $ TyConSort SoConComp) - , do pTokAs KSortProp (TCon $ TyConSort SoConProp) - , do pTokAs KKindValue (TCon $ TyConKind KiConData) - , do pTokAs KKindRegion (TCon $ TyConKind KiConRegion) - , do pTokAs KKindEffect (TCon $ TyConKind KiConEffect) - , do pTokAs KKindClosure (TCon $ TyConKind KiConClosure) - , do pTokAs KKindWitness (TCon $ TyConKind KiConWitness) - - -- Bottoms. - , do pTokAs KBotEffect (tBot kEffect) - , do pTokAs KBotClosure (tBot kClosure) - - -- Bound occurrence of a variable. - -- We don't know the kind of this variable yet, so fill in the - -- field with the bottom element of computation kinds. This isn't - -- really part of the language, but makes sense implentation-wise. - , do v <- pVar - return $ TVar (UName v (tBot sComp)) - - , do i <- pIndex - return $ TVar (UIx (fromIntegral i) (tBot sComp)) - ] - "an atomic type" - - -------------------------------------------------------------------------------- --- | Parse a builtin `TcCon` -pTcCon :: Parser n TcCon -pTcCon = P.pTokMaybe f - "a type constructor" - where f (KA (KTcConBuiltin c)) = Just c - f _ = Nothing - --- | Parse a builtin `TwCon` -pTwCon :: Parser n TwCon -pTwCon = P.pTokMaybe f - "a witness constructor" - where f (KA (KTwConBuiltin c)) = Just c - f _ = Nothing - --- | Parse a user `TcCon` -pTyConNamed :: Parser n (TyCon n) -pTyConNamed - = P.pTokMaybe f - "a type constructor" - where f (KN (KCon n)) = Just (TyConBound (UName n (tBot kData))) - f _ = Nothing - --- | Parse a variable. -pVar :: Parser n n -pVar = P.pTokMaybe f - "a variable" - where f (KN (KVar n)) = Just n - f _ = Nothing - --- | Parse a deBruijn index -pIndex :: Parser n Int -pIndex = P.pTokMaybe f - "an index" - where f (KA (KIndex i)) = Just i - f _ = Nothing - --- | Parse an atomic token. -pTok :: TokAtom -> Parser n () -pTok k = P.pTok (KA k) - - --- | Parse an atomic token and return some value. -pTokAs :: TokAtom -> a -> Parser n a -pTokAs k x = P.pTokAs (KA k) x - diff --git a/DDC/Type/Predicates.hs b/DDC/Type/Predicates.hs --- a/DDC/Type/Predicates.hs +++ b/DDC/Type/Predicates.hs @@ -1,21 +1,71 @@ -- | Predicates on type expressions. module DDC.Type.Predicates - ( isBot + ( -- * Binders + isBNone + , isBAnon + , isBName + + -- * Atoms + , isTVar + , isBot , isAtomT + + -- * Kinds , isDataKind , isRegionKind , isEffectKind , isClosureKind , isWitnessKind - , isAlgDataType) + + -- * Data Types + , isAlgDataType + , isWitnessType + , isConstWitType + , isMutableWitType + , isDistinctWitType + + -- * Effect Types + , isReadEffect + , isWriteEffect + , isAllocEffect + , isSomeReadEffect + , isSomeWriteEffect + , isSomeAllocEffect) where import DDC.Type.Exp import DDC.Type.Compounds import qualified DDC.Type.Sum as T +-- Binders -------------------------------------------------------------------- +isBNone :: Bind n -> Bool +isBNone bb + = case bb of + BNone{} -> True + _ -> False + +isBAnon :: Bind n -> Bool +isBAnon bb + = case bb of + BAnon{} -> True + _ -> False + +isBName :: Bind n -> Bool +isBName bb + = case bb of + BName{} -> True + _ -> False + + -- Atoms ---------------------------------------------------------------------- +-- | Check whether a type is a `TVar` +isTVar :: Type n -> Bool +isTVar tt + = case tt of + TVar{} -> True + _ -> False + -- | Test if some type is an empty TSum isBot :: Type n -> Bool isBot tt @@ -82,17 +132,114 @@ -- It needs to have an explicit data constructor out the front, -- and not a type variable. The constructor must not be the function -- constructor, and must return a value of kind '*'. - --- Algebraic data types are all built from constructors --- that have '*' as their result kind. --- The function constructor (->) also has this result kind, --- but it is in `TyConComp`, so is easy to ignore. +--- +-- The function constructor (->) also has this result kind, +-- but it is in `TyConComp`, so is easy to ignore. isAlgDataType :: Eq n => Type n -> Bool isAlgDataType tt - | Just (tc, _) <- takeTyConApps tt - , TyConBound u <- tc - = takeResultKind (typeOfBound u) == kData + | 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 --- a/DDC/Type/Pretty.hs +++ b/DDC/Type/Pretty.hs @@ -49,13 +49,9 @@ instance (Pretty n, Eq n) => Pretty (Bound n) where ppr nn = case nn of --- UName n t -> parens (ppr n <> text ":" <> ppr t) - UName n _ -> ppr n - - - UPrim n _ -> ppr n --- UIx i t -> parens (text "^" <> ppr i <> text ":" <> ppr t) - UIx i _ -> text "^" <> ppr i + UName n -> ppr n + UPrim n _ -> ppr n + UIx i -> text "^" <> ppr i -- Type ----------------------------------------------------------------------- @@ -127,7 +123,7 @@ TyConKind kc -> ppr kc TyConWitness tc -> ppr tc TyConSpec tc -> ppr tc - TyConBound u -> ppr u + TyConBound u _ -> ppr u instance Pretty SoCon where @@ -160,14 +156,17 @@ TwConDeepConst -> text "DeepConst" TwConMutable -> text "Mutable" TwConDeepMutable-> text "DeepMutable" + TwConDistinct n -> text "Distinct" <> ppr n TwConLazy -> text "Lazy" TwConHeadLazy -> text "HeadLazy" TwConManifest -> text "Manifest" + TwConDisjoint -> text "Disjoint" instance Pretty TcCon where ppr tc = case tc of + TcConUnit -> text "Unit" TcConFun -> text "(->)" TcConRead -> text "Read" TcConHeadRead -> text "HeadRead" diff --git a/DDC/Type/Rewrite.hs b/DDC/Type/Rewrite.hs deleted file mode 100644 --- a/DDC/Type/Rewrite.hs +++ /dev/null @@ -1,264 +0,0 @@ - --- | Rewriting of variable binders to anonymous form to avoid capture. -module DDC.Type.Rewrite - ( Rewrite(..) - , Sub(..) - , BindStack(..) - , pushBind - , pushBinds - , substBound - - , bind1, bind0, bind0s - , use1, use0) -where -import DDC.Core.Exp -import DDC.Type.Compounds -import Data.List -import Data.Set (Set) -import qualified DDC.Type.Sum as Sum -import qualified Data.Set as Set - - --- | Substitution state. --- Keeps track of the binders in the environment that have been rewrittten --- to avoid variable capture or spec binder shadowing. -data Sub n - = Sub - { -- | Bound variable that we're substituting for. - subBound :: Bound n - - -- | We've decended past a binder that shadows the one that we're - -- substituting for. We're no longer substituting, but still may - -- need to anonymise variables in types. - -- This can only happen for level-0 named binders. - , subShadow0 :: Bool - - -- | Level-1 names that need to be rewritten to avoid capture. - , subConflict1 :: Set n - - -- | Level-0 names that need to be rewritten to avoid capture. - , subConflict0 :: Set n - - -- | Rewriting stack for level-1 names. - , subStack1 :: BindStack n - - -- | Rewriting stack for level-0 names. - , subStack0 :: BindStack n } - - --- | Stack of anonymous binders that we've entered under during substitution. -data BindStack n - = BindStack - { -- | Holds anonymous binders that were already in the program, - -- as well as named binders that are being rewritten to anonymous ones. - -- In the resulting expression all these binders will be anonymous. - stackBinds :: [Bind n] - - -- | Holds all binders, independent of whether they are being rewritten or not. - , stackAll :: [Bind n] - - -- | Number of `BAnon` in `stackBinds`. - , stackAnons :: Int - - -- | Number of `BName` in `stackBinds`. - , stackNamed :: Int } - - --- | Push several binds onto the bind stack, --- anonymyzing them if need be to avoid variable capture. -pushBinds :: Ord n => Set n -> BindStack n -> [Bind n] -> (BindStack n, [Bind n]) -pushBinds fns stack bs - = mapAccumL (pushBind fns) stack bs - - --- | Push a bind onto a bind stack, --- anonymizing it if need be to avoid variable capture. -pushBind - :: Ord n - => Set n -- ^ Names that need to be rewritten. - -> BindStack n -- ^ Current bind stack. - -> Bind n -- ^ Bind to push. - -> (BindStack n, Bind n) -- ^ New stack and possibly anonymised bind. - -pushBind fns bs@(BindStack stack env dAnon dName) bb - = case bb of - -- Push already anonymous bind on stack. - BAnon t - -> ( BindStack (BAnon t : stack) (BAnon t : env) (dAnon + 1) dName - , BAnon t) - - -- If the binder needs to be rewritten then push the original name on the - -- 'stackBinds' to remember this. - BName n t - | Set.member n fns - -> ( BindStack (BName n t : stack) (BAnon t : env) dAnon (dName + 1) - , BAnon t) - - | otherwise - -> ( BindStack stack (BName n t : env) dAnon dName - , bb) - - -- Binder was a wildcard. - _ -> (bs, bb) - - - --- | Compare a `Bound` against the one we're substituting for. -substBound - :: Ord n - => BindStack n -- ^ Current Bind stack during substitution. - -> Bound n -- ^ Bound we're substituting for. - -> Bound n -- ^ Bound we're looking at now. - -> Either - (Bound n) -- Bound doesn't match, but replace with this one. - Int -- Bound matches, drop the thing being substituted and - -- and lift indices this many steps. - -substBound (BindStack binds _ dAnon dName) u u' - -- Bound name matches the one that we're substituting for. - | UName n1 _ <- u - , UName n2 _ <- u' - , n1 == n2 - = Right (dAnon + dName) - - -- Bound index matches the one that we're substituting for. - | UIx i1 _ <- u - , UIx i2 _ <- u' - , i1 + dAnon == i2 - = Right (dAnon + dName) - - -- The Bind for this name was rewritten to avoid variable capture, - -- so we also have to update the bound occurrence. - | UName _ t <- u' - , Just ix <- findIndex (boundMatchesBind u') binds - = Left $ UIx ix t - - -- Bound index doesn't match, but lower this index by one to account - -- for the removal of the outer binder. - | UIx i2 t <- u' - , i2 > dAnon - , cutOffset <- case u of - UIx{} -> 1 - _ -> 0 - = Left $ UIx (i2 + dName - cutOffset) t - - -- Some name that didn't match. - | otherwise - = Left u' - - -------------------------------------------------------------------------------- --- | Push a level-1 binder on the rewrite stack. -bind1 :: Ord n => Sub n -> Bind n -> (Sub n, Bind n) -bind1 sub b - = let (stackT', b') = pushBind (subConflict1 sub) (subStack1 sub) b - in (sub { subStack1 = stackT' }, b') - - --- | Push a level-0 binder on the rewrite stack. -bind0 :: Ord n => Sub n -> Bind n -> (Sub n, Bind n) -bind0 sub b - = let b1 = rewriteWith sub b - (stackX', b2) = pushBind (subConflict0 sub) (subStack0 sub) b1 - in ( sub { subStack0 = stackX' - , subShadow0 = subShadow0 sub - || namedBoundMatchesBind (subBound sub) b2 } - , b2) - - --- | Push some level-0 binders on the rewrite stack. -bind0s :: Ord n => Sub n -> [Bind n] -> (Sub n, [Bind n]) -bind0s = mapAccumL bind0 - - --- | Rewrite a use of a level-1 binder if need be. -use1 :: Ord n => Sub n -> Bound n -> Bound n -use1 sub u - | UName _ t <- u - , BindStack binds _ _ _ <- subStack1 sub - , Just ix <- findIndex (boundMatchesBind u) binds - = UIx ix t - - | otherwise - = u - - --- | Rewrite the use of a level-0 binder if need be. -use0 :: Ord n => Sub n -> Bound n -> Bound n -use0 sub u - | UName _ t <- u - , BindStack binds _ _ _ <- subStack0 sub - , Just ix <- findIndex (boundMatchesBind u) binds - = UIx ix (rewriteWith sub t) - - | otherwise - = rewriteWith sub u - - -------------------------------------------------------------------------------- -class Rewrite (c :: * -> *) where - -- | Rewrite names in some thing to anonymous form if they conflict with --- any names in the `Sub` state. - rewriteWith :: Ord n => Sub n -> c n -> c n - - -instance Rewrite Bind where - rewriteWith sub bb - = replaceTypeOfBind (rewriteWith sub (typeOfBind bb)) bb - - -instance Rewrite Bound where - rewriteWith sub uu - = replaceTypeOfBound (rewriteWith sub (typeOfBound uu)) uu - - -instance Rewrite LetMode where - rewriteWith sub lm - = case lm of - LetStrict -> lm - LetLazy (Just t) -> LetLazy (Just $ rewriteWith sub t) - LetLazy Nothing -> LetLazy Nothing - - -instance Rewrite Cast where - rewriteWith sub cc - = let down = rewriteWith sub - in case cc of - CastWeakenEffect eff -> CastWeakenEffect (down eff) - CastWeakenClosure clo -> CastWeakenClosure (down clo) - CastPurify w -> CastPurify (down w) - CastForget w -> CastForget (down w) - - -instance Rewrite Type where - rewriteWith sub tt - = let down = rewriteWith - in case tt of - TVar u -> TVar (use1 sub u) - TCon{} -> tt - - TForall b t - -> let (sub1, b') = bind1 sub b - t' = down sub1 t - in TForall b' t' - - TApp t1 t2 -> TApp (down sub t1) (down sub t2) - TSum ts -> TSum (down sub ts) - - -instance Rewrite TypeSum where - rewriteWith sub ts - = Sum.fromList (Sum.kindOfSum ts) - $ map (rewriteWith sub) - $ Sum.toList ts - - -instance Rewrite Witness where - rewriteWith sub ww - = let down = rewriteWith - in case ww of - WVar u -> WVar (use0 sub u) - WCon{} -> ww - WApp w1 w2 -> WApp (down sub w1) (down sub w2) - WJoin w1 w2 -> WJoin (down sub w1) (down sub w2) - WType t -> WType (down sub t) diff --git a/DDC/Type/Sum.hs b/DDC/Type/Sum.hs --- a/DDC/Type/Sum.hs +++ b/DDC/Type/Sum.hs @@ -2,32 +2,48 @@ -- | Utilities for working with `TypeSum`s. -- module DDC.Type.Sum - ( empty + ( -- * Constructors + empty , singleton - , elem - , insert - , delete , union , unions - , difference + , insert + + -- * Conversion + , toList + , fromList + + -- * Projection , kindOfSum - , toList, fromList - , hashTyCon, hashTyConRange - , unhashTyCon - , takeSumArrayElem - , makeSumArrayElem) + , elem + + -- * Deletion + , delete + , difference + + -- * Hashing + , hashTyCon + , hashTyConRange + , unhashTyCon) where import DDC.Type.Exp import Data.Array -import qualified Data.List as L -import qualified Data.Map as Map -import qualified Data.Set as Set -import Prelude hiding (elem) +import qualified Data.List as L +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Prelude hiding (elem) -- | Construct an empty type sum of the given kind. empty :: Kind n -> TypeSum n -empty k = TypeSum +empty k = TypeSumBot k + + +-- | Construct an empty type sum of the given kind, but in `TypeSumSet` form. +-- This isn't exported. +emptySet :: Kind n -> TypeSum n +emptySet k + = TypeSumSet { typeSumKind = k , typeSumElems = listArray hashTyConRange (repeat Set.empty) , typeSumBoundNamed = Map.empty @@ -50,11 +66,12 @@ -- * May return False if the first argument is miskinded but still -- alpha-equivalent to some component of the sum. elem :: (Eq n, Ord n) => Type n -> TypeSum n -> Bool -elem t ts +elem _ TypeSumBot{} = False +elem t ts@TypeSumSet{} = case t of - TVar (UName n _) -> Map.member n (typeSumBoundNamed ts) + TVar (UName n) -> Map.member n (typeSumBoundNamed ts) + TVar (UIx i) -> Map.member i (typeSumBoundAnon ts) TVar (UPrim n _) -> Map.member n (typeSumBoundNamed ts) - TVar (UIx i _) -> Map.member i (typeSumBoundAnon ts) TCon{} -> L.elem t (typeSumSpill ts) -- Foralls can't be a part of well-kinded sums. @@ -86,17 +103,19 @@ -- | Insert a new element into a sum. insert :: Ord n => Type n -> TypeSum n -> TypeSum n -insert t ts - = case t of - TVar (UName n k) -> ts { typeSumBoundNamed = Map.insert n k (typeSumBoundNamed ts) } - TVar (UPrim n k) -> ts { typeSumBoundNamed = Map.insert n k (typeSumBoundNamed ts) } - TVar (UIx i k) -> ts { typeSumBoundAnon = Map.insert i k (typeSumBoundAnon ts) } - TCon{} -> ts { typeSumSpill = t : typeSumSpill ts } +insert t (TypeSumBot k) = insert t (emptySet k) +insert t ts@TypeSumSet{} + = let k = typeSumKind ts + in case t of + TVar (UName n) -> ts { typeSumBoundNamed = Map.insert n k (typeSumBoundNamed ts) } + TVar (UIx i) -> ts { typeSumBoundAnon = Map.insert i k (typeSumBoundAnon ts) } + TVar (UPrim n _)-> ts { typeSumBoundNamed = Map.insert n k (typeSumBoundNamed ts) } + 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 = t : typeSumSpill ts } + TForall{} -> ts { typeSumSpill = L.nub $ t : typeSumSpill ts } TApp (TCon _) _ | Just (h, vc) <- takeSumArrayElem t @@ -105,20 +124,21 @@ then ts else ts { typeSumElems = (typeSumElems ts) // [(h, Set.insert vc tsThere)] } - TApp{} -> ts { typeSumSpill = t : typeSumSpill ts } + TApp{} -> ts { typeSumSpill = L.nub $ t : typeSumSpill ts } TSum ts' -> foldr insert ts (toList ts') -- | Delete an element from a sum. delete :: Ord n => Type n -> TypeSum n -> TypeSum n -delete t ts +delete _ ts@TypeSumBot{} = ts +delete t ts@TypeSumSet{} = case t of - TVar (UName n _) -> ts { typeSumBoundNamed = Map.delete n (typeSumBoundNamed ts) } - TVar (UPrim n _) -> ts { typeSumBoundNamed = Map.delete n (typeSumBoundNamed ts) } - TVar (UIx i _) -> ts { typeSumBoundAnon = Map.delete i (typeSumBoundAnon ts) } - TCon{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } - TForall{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } + TVar (UName n) -> ts { typeSumBoundNamed = Map.delete n (typeSumBoundNamed ts) } + TVar (UIx i) -> ts { typeSumBoundAnon = Map.delete i (typeSumBoundAnon ts) } + TVar (UPrim n _)-> ts { typeSumBoundNamed = Map.delete n (typeSumBoundNamed ts) } + TCon{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } + TForall{} -> ts { typeSumSpill = L.delete t (typeSumSpill ts) } TApp (TCon _) _ | Just (h, vc) <- takeSumArrayElem t @@ -157,7 +177,10 @@ -- | Flatten out a sum, yielding a list of individual terms. toList :: TypeSum n -> [Type n] -toList TypeSum +toList TypeSumBot{} + = [] + +toList TypeSumSet { typeSumKind = _kind , typeSumElems = sumElems , typeSumBoundNamed = named @@ -166,8 +189,8 @@ = [ makeSumArrayElem h vc | (h, ts) <- assocs sumElems, vc <- Set.toList ts] - ++ [TVar $ UName n k | (n, k) <- Map.toList named] - ++ [TVar $ UIx i k | (i, k) <- Map.toList anon] + ++ [TVar $ UName n | (n, _) <- Map.toList named] + ++ [TVar $ UIx i | (i, _) <- Map.toList anon] ++ spill @@ -231,7 +254,7 @@ | Just h <- hashTyCon tc = case t2 of TVar u -> Just (h, TypeSumVar u) - TCon (TyConBound u) -> Just (h, TypeSumCon u) + TCon (TyConBound u k) -> Just (h, TypeSumCon u k) _ -> Nothing takeSumArrayElem _ = Nothing @@ -243,7 +266,7 @@ = let tc = unhashTyCon h in case vc of TypeSumVar u -> TApp (TCon tc) (TVar u) - TypeSumCon u -> TApp (TCon tc) (TCon (TyConBound u)) + TypeSumCon u k -> TApp (TCon tc) (TCon (TyConBound u k)) -- Type Equality -------------------------------------------------------------- @@ -268,6 +291,7 @@ -- Unwrap single element sums into plain types. where normalise (TSum ts) | [t'] <- toList ts = t' + | [] <- toList ts = TSum $ empty (typeSumKind ts) normalise t' = t' @@ -280,25 +304,47 @@ , [] <- toList ts2 = typeSumKind ts1 == typeSumKind ts2 - -- If the sum has elements, then compare them directly and ignore the + | TypeSumBot{} <- normalise ts1 + , TypeSumBot{} <- normalise ts2 + = typeSumKind ts1 == typeSumKind ts2 + + -- If both sums have elements, then compare them directly and ignore the -- kind. This allows us to use (tBot sComp) as the typeSumKind field -- when we want to compute the real kind based on the elements. - | otherwise + | TypeSumSet{} <- ts1 + , TypeSumSet{} <- ts2 = typeSumElems ts1 == typeSumElems ts2 && typeSumBoundNamed ts1 == typeSumBoundNamed ts2 && typeSumBoundAnon ts1 == typeSumBoundAnon ts2 && typeSumSpill ts1 == typeSumSpill ts2 + -- One is a set and one is bottom, so they are not equal. + | otherwise + = False + where normalise ts + | [] <- toList ts = empty (typeSumKind ts) + normalise ts = ts + + instance Ord n => Ord (Bound n) where - compare (UName n1 _) (UName n2 _) = compare n1 n2 - compare (UIx i1 _) (UIx i2 _) = compare i1 i2 - compare (UPrim n1 _) (UPrim n2 _) = compare n1 n2 - compare (UIx _ _) _ = LT - compare (UName _ _) (UIx _ _) = GT - compare (UName _ _) (UPrim _ _) = LT - compare (UPrim _ _) _ = GT + compare (UName n1) (UName n2) = compare n1 n2 + compare (UIx i1) (UIx i2) = compare i1 i2 + compare (UPrim n1 _) (UPrim n2 _) = compare n1 n2 + compare UIx{} _ = LT + compare UName{} UIx{} = GT + compare UName{} UPrim{} = LT + compare UPrim{} _ = GT -deriving instance Eq n => Eq (TypeSumVarCon n) -deriving instance Ord n => Ord (TypeSumVarCon n) + +instance Eq n => Eq (TypeSumVarCon n) where + (==) (TypeSumVar u1) (TypeSumVar u2) = u1 == u2 + (==) (TypeSumCon u1 _) (TypeSumCon u2 _) = u1 == u2 + (==) _ _ = False + +instance Ord n => Ord (TypeSumVarCon n) where + compare (TypeSumVar u1) (TypeSumVar u2) = compare u1 u2 + compare (TypeSumCon u1 _) (TypeSumCon u2 _) = compare u1 u2 + compare (TypeSumVar _) _ = LT + compare (TypeSumCon _ _) _ = GT diff --git a/DDC/Type/Transform/Crush.hs b/DDC/Type/Transform/Crush.hs --- a/DDC/Type/Transform/Crush.hs +++ b/DDC/Type/Transform/Crush.hs @@ -1,12 +1,41 @@ module DDC.Type.Transform.Crush - (crushEffect) + ( crushSomeT + , crushEffect ) where import DDC.Type.Predicates import DDC.Type.Compounds +import DDC.Type.Transform.Trim import DDC.Type.Exp import qualified DDC.Type.Sum as Sum +import Data.Maybe +-- | Crush compound effects and closure terms. +-- We check for a crushable term before calling crushT because that function +-- will recursively crush the components. +-- As equivT is already recursive, we don't want a doubly-recursive function +-- that tries to re-crush the same non-crushable type over and over. +-- +crushSomeT :: Ord n => Type n -> Type n +crushSomeT tt + = {-# SCC crushSomeT #-} + case tt of + (TApp (TCon tc) _) + -> case tc of + TyConSpec TcConDeepRead -> crushEffect tt + TyConSpec TcConDeepWrite -> crushEffect tt + TyConSpec TcConDeepAlloc -> crushEffect tt + + -- If a closure is miskinded then 'trimClosure' + -- can return Nothing, so we just leave the term untrimmed. + TyConSpec TcConDeepUse -> fromMaybe tt (trimClosure tt) + + TyConWitness TwConDeepGlobal -> crushEffect tt + _ -> tt + + _ -> tt + + -- | Crush compound effect terms into their components. -- -- This is like `trimClosure` but for effects instead of closures. @@ -15,7 +44,8 @@ -- crushEffect :: Ord n => Effect n -> Effect n crushEffect tt - = case tt of + = {-# SCC crushEffect #-} + case tt of TVar{} -> tt TCon{} -> tt TForall b t @@ -33,14 +63,15 @@ -> case takeTyConApps t of -- Type has a head region. - Just (TyConBound u, (tR : _)) - | (k1 : _, _) <- takeKFuns (typeOfBound u) + Just (TyConBound _ k, (tR : _)) + | (k1 : _, _) <- takeKFuns k , isRegionKind k1 -> tRead tR -- Type has no head region. -- This happens with case () of { ... } - Just (TyConBound _, []) -> tBot kEffect + Just (TyConSpec TcConUnit, []) -> tBot kEffect + Just (TyConBound _ _, []) -> tBot kEffect _ -> tt @@ -48,8 +79,8 @@ -- See Note: Crushing with higher kinded type vars. | Just (TyConSpec TcConDeepRead, [t]) <- takeTyConApps tt -> case takeTyConApps t of - Just (TyConBound u, ts) - | (ks, _) <- takeKFuns (typeOfBound u) + Just (TyConBound _ k, ts) + | (ks, _) <- takeKFuns k , length ks == length ts , Just effs <- sequence $ zipWith makeDeepRead ks ts -> crushEffect $ TSum $ Sum.fromList kEffect effs @@ -60,8 +91,8 @@ -- See Note: Crushing with higher kinded type vars. | Just (TyConSpec TcConDeepWrite, [t]) <- takeTyConApps tt -> case takeTyConApps t of - Just (TyConBound u, ts) - | (ks, _) <- takeKFuns (typeOfBound u) + Just (TyConBound _ k, ts) + | (ks, _) <- takeKFuns k , length ks == length ts , Just effs <- sequence $ zipWith makeDeepWrite ks ts -> crushEffect $ TSum $ Sum.fromList kEffect effs @@ -72,22 +103,24 @@ -- See Note: Crushing with higher kinded type vars. | Just (TyConSpec TcConDeepAlloc, [t]) <- takeTyConApps tt -> case takeTyConApps t of - Just (TyConBound u, ts) - | (ks, _) <- takeKFuns (typeOfBound u) + Just (TyConBound _ k, ts) + | (ks, _) <- takeKFuns k , length ks == length ts , Just effs <- sequence $ zipWith makeDeepAlloc ks ts -> crushEffect $ TSum $ Sum.fromList kEffect effs _ -> tt - -- TODO: we're hijacking crushEffect to work on witnesses as well. - -- we should split this into another function. -- Deep Global -- See Note: Crushing with higher kinded type vars. + -- + -- NOTE: We're hijacking crushEffect to work on witnesses as well. + -- It would be better to split this into another function. + -- | Just (TyConWitness TwConDeepGlobal, [t]) <- takeTyConApps tt -> case takeTyConApps t of - Just (TyConBound u, ts) - | (ks, _) <- takeKFuns (typeOfBound u) + Just (TyConBound _ k, ts) + | (ks, _) <- takeKFuns k , length ks == length ts , Just props <- sequence $ zipWith makeDeepGlobal ks ts -> crushEffect $ TSum $ Sum.fromList kWitness props diff --git a/DDC/Type/Transform/Instantiate.hs b/DDC/Type/Transform/Instantiate.hs --- a/DDC/Type/Transform/Instantiate.hs +++ b/DDC/Type/Transform/Instantiate.hs @@ -10,7 +10,12 @@ -- | Instantiate a type with an argument. -- The type to be instantiated must have an outer forall, else `Nothing`. -instantiateT :: (Ord n, Pretty n) => Type n -> Type n -> Maybe (Type n) +instantiateT + :: (Ord n, Pretty n) + => Type n -- ^ Type to instantiate. + -> Type n -- ^ Argument type. + -> Maybe (Type n) + instantiateT (TForall b tBody) t2 = Just $ substituteT b t2 tBody instantiateT _ _ = Nothing @@ -18,7 +23,12 @@ -- | Instantiate a type with several arguments. -- The type to be instantiated must have at least as many outer foralls -- as provided type arguments, else `Nothing`. -instantiateTs :: (Ord n, Pretty n) => Type n -> [Type n] -> Maybe (Type n) +instantiateTs + :: (Ord n, Pretty n) + => Type n -- ^ Type to instantiate. + -> [Type n] -- ^ Argument types. + -> Maybe (Type n) + instantiateTs t [] = Just t instantiateTs t (tArg:tsArgs) = case instantiateT t tArg of diff --git a/DDC/Type/Transform/LiftT.hs b/DDC/Type/Transform/LiftT.hs --- a/DDC/Type/Transform/LiftT.hs +++ b/DDC/Type/Transform/LiftT.hs @@ -1,63 +1,109 @@ -- | Lifting of deBruijn indices in a type. ---- --- TODO: merge this code with LowerT module DDC.Type.Transform.LiftT - (LiftT(..)) + ( liftT, liftAtDepthT + , lowerT, lowerAtDepthT + , MapBoundT(..)) where import DDC.Type.Exp import DDC.Type.Compounds import qualified DDC.Type.Sum as Sum -class LiftT (c :: * -> *) where - - -- | Lift type indices that are at least a certain depth by the given number of levels. - liftAtDepthT - :: forall n. Ord n +-- Lift ----------------------------------------------------------------------- +-- | Lift debruijn indices less than or equal to the given depth. +liftAtDepthT + :: MapBoundT c n => Int -- ^ Number of levels to lift. -> Int -- ^ Current binding depth. - -> c n -- ^ Lift type indices in this thing. + -> c n -- ^ Lift expression indices in this thing. -> c n - - -- | Wrapper for `liftAtDepthT` that starts at depth 0. - liftT :: forall n. Ord n - => Int -- ^ Number of levels to lift - -> c n -- ^ Lift type indices in this thing. + +liftAtDepthT n d + = mapBoundAtDepthT liftU d + where + liftU d' u + = case u of + UName{} -> u + UPrim{} -> u + UIx i + | d' <= i -> UIx (i + n) + | otherwise -> u + + +-- | Wrapper for `liftAtDepthX` that starts at depth 0. +liftT :: MapBoundT c n => Int -> c n -> c n +liftT n xx = liftAtDepthT n 0 xx + + +-- Lower ---------------------------------------------------------------------- +-- | Lower debruijn indices less than or equal to the given depth. +lowerAtDepthT + :: MapBoundT c n + => Int -- ^ Number of levels to lower. + -> Int -- ^ Current binding depth. + -> c n -- ^ Lower expression indices in this thing. -> c n - - liftT n xx = liftAtDepthT n 0 xx - -instance LiftT Bind where - liftAtDepthT n d bb - = replaceTypeOfBind (liftAtDepthT n d $ typeOfBind bb) bb - +lowerAtDepthT n d + = mapBoundAtDepthT lowerU d + where + lowerU d' u + = case u of + UName{} -> u + UPrim{} -> u + UIx i + | d' <= i -> UIx (i - n) + | otherwise -> u -instance LiftT Bound where - liftAtDepthT n d uu - = case uu of - UName{} -> uu - UPrim{} -> uu - UIx i t - | d <= i -> UIx (i + n) t - | otherwise -> uu - -instance LiftT Type where - liftAtDepthT n d tt - = let down = liftAtDepthT n +-- | Wrapper for `lowerAtDepthX` that starts at depth 0. +lowerT :: MapBoundT c n => Int -> c n -> c n +lowerT n xx = lowerAtDepthT n 0 xx + + +-- MapBoundT ------------------------------------------------------------------ +class MapBoundT (c :: * -> *) n where + -- | Apply a function to all bound variables in the program. + -- The function is passed the current binding depth. + -- This is used to defined both `liftT` and `lowerT`. + mapBoundAtDepthT + :: (Int -> Bound n -> Bound n) + -- ^ Function to apply to the bound occ. + -- It is passed the current binding depth. + -> Int -- ^ Current binding depth. + -> c n -- ^ Lift expression indices in this thing. + -> c n + + +instance Ord n => MapBoundT Bind n where + mapBoundAtDepthT f d bb + = replaceTypeOfBind (mapBoundAtDepthT f d $ typeOfBind bb) bb + + +instance MapBoundT Bound n where + mapBoundAtDepthT f d u + = f d u + + +instance Ord n => MapBoundT Type n where + mapBoundAtDepthT f d tt + = let down = mapBoundAtDepthT f d in case tt of - TVar u -> TVar (down d u) + TVar u -> TVar (f d u) TCon{} -> tt - TForall b t -> TForall (down d b) (down (d + 1) t) - TApp t1 t2 -> TApp (down d t1) (down d t2) - TSum ss -> TSum (down d ss) + TForall b t -> TForall b (mapBoundAtDepthT f (d + countBAnons [b]) t) + TApp t1 t2 -> TApp (down t1) (down t2) + TSum ss -> TSum (down ss) -instance LiftT TypeSum where - liftAtDepthT n d ss - = Sum.fromList (liftAtDepthT n d $ Sum.kindOfSum ss) - $ map (liftAtDepthT n d) +instance Ord n => MapBoundT TypeSum n where + mapBoundAtDepthT f d ss + = Sum.fromList (Sum.kindOfSum ss) + $ map (mapBoundAtDepthT f d) $ Sum.toList ss + +countBAnons = length . filter isAnon + where isAnon (BAnon _) = True + isAnon _ = False diff --git a/DDC/Type/Transform/LowerT.hs b/DDC/Type/Transform/LowerT.hs deleted file mode 100644 --- a/DDC/Type/Transform/LowerT.hs +++ /dev/null @@ -1,63 +0,0 @@ - --- | Lowering of deBruijn indices in a type. ---- --- TODO: merge this code with LiftT. -module DDC.Type.Transform.LowerT - (LowerT(..)) -where -import DDC.Type.Exp -import DDC.Type.Compounds -import qualified DDC.Type.Sum as Sum - - -class LowerT (c :: * -> *) where - - -- | Lower type indices that are at least a certain depth by the given number of levels. - lowerAtDepthT - :: forall n. Ord n - => Int -- ^ Number of levels to lower. - -> Int -- ^ Current binding depth. - -> c n -- ^ Lower type indices in this thing. - -> c n - - -- | Wrapper for `lowerAtDepthT` that starts at depth 0. - lowerT :: forall n. Ord n - => Int -- ^ Number of levels to lower. - -> c n -- ^ Lower type indices in this thing. - -> c n - - lowerT n xx = lowerAtDepthT n 0 xx - - -instance LowerT Bind where - lowerAtDepthT n d bb - = replaceTypeOfBind (lowerAtDepthT n d $ typeOfBind bb) bb - - -instance LowerT Bound where - lowerAtDepthT n d uu - = case uu of - UName{} -> uu - UPrim{} -> uu - UIx i t - | d <= i -> UIx (i - n) t - | otherwise -> uu - - -instance LowerT Type where - lowerAtDepthT n d tt - = let down = lowerAtDepthT n - in case tt of - TVar uu -> TVar (down d uu) - TCon{} -> tt - TForall b t -> TForall (down d b) (down (d + 1) t) - TApp t1 t2 -> TApp (down d t1) (down d t2) - TSum ss -> TSum (down d ss) - - -instance LowerT TypeSum where - lowerAtDepthT n d ss - = Sum.fromList (lowerAtDepthT n d $ Sum.kindOfSum ss) - $ map (lowerAtDepthT n d) - $ Sum.toList ss - diff --git a/DDC/Type/Transform/Rename.hs b/DDC/Type/Transform/Rename.hs new file mode 100644 --- /dev/null +++ b/DDC/Type/Transform/Rename.hs @@ -0,0 +1,246 @@ + +-- | Renaming of variable binders to anonymous form to avoid capture. +module DDC.Type.Transform.Rename + ( Rename(..) + + -- * Substitution states + , Sub(..) + + -- * Binding stacks + , BindStack(..) + , pushBind + , pushBinds + , substBound + + -- * Rewriting binding occurences + , bind1, bind1s, bind0, bind0s + + -- * Rewriting bound occurences + , use1, use0) +where +import DDC.Type.Compounds +import DDC.Type.Exp +import Data.List +import Data.Set (Set) +import qualified DDC.Type.Sum as Sum +import qualified Data.Set as Set + + +------------------------------------------------------------------------------- +class Rename (c :: * -> *) where + -- | Rewrite names in some thing to anonymous form if they conflict with +-- any names in the `Sub` state. We use this to avoid variable capture +-- during substitution. + renameWith :: Ord n => Sub n -> c n -> c n + + +instance Rename Type where + renameWith sub tt + = {-# SCC renameWith #-} + let down = renameWith + in case tt of + TVar u -> TVar (use1 sub u) + TCon{} -> tt + + TForall b t + -> let (sub1, b') = bind1 sub b + t' = down sub1 t + in TForall b' t' + + TApp t1 t2 -> TApp (down sub t1) (down sub t2) + TSum ts -> TSum (down sub ts) + + +instance Rename TypeSum where + renameWith sub ts + = Sum.fromList (Sum.kindOfSum ts) + $ map (renameWith sub) + $ Sum.toList ts + + +instance Rename Bind where + renameWith sub bb + = replaceTypeOfBind (renameWith sub (typeOfBind bb)) bb + + +------------------------------------------------------------------------------- +-- | Substitution state. +-- Keeps track of the binders in the environment that have been rewrittten +-- to avoid variable capture or spec binder shadowing. +data Sub n + = Sub + { -- | Bound variable that we're substituting for. + subBound :: !(Bound n) + + -- | We've decended past a binder that shadows the one that we're + -- substituting for. We're no longer substituting, but still may + -- need to anonymise variables in types. + -- This can only happen for level-0 named binders. + , subShadow0 :: !Bool + + -- | Level-1 names that need to be rewritten to avoid capture. + , subConflict1 :: !(Set n) + + -- | Level-0 names that need to be rewritten to avoid capture. + , subConflict0 :: !(Set n) + + -- | Rewriting stack for level-1 names. + , subStack1 :: !(BindStack n) + + -- | Rewriting stack for level-0 names. + , subStack0 :: !(BindStack n) } + + +-- | Stack of anonymous binders that we've entered under during substitution. +data BindStack n + = BindStack + { -- | Holds anonymous binders that were already in the program, + -- as well as named binders that are being rewritten to anonymous ones. + -- In the resulting expression all these binders will be anonymous. + stackBinds :: ![Bind n] + + -- | Holds all binders, independent of whether they are being rewritten or not. + , stackAll :: ![Bind n] + + -- | Number of `BAnon` in `stackBinds`. + , stackAnons :: !Int + + -- | Number of `BName` in `stackBinds`. + , stackNamed :: !Int } + + +-- | Push several binds onto the bind stack, +-- anonymyzing them if need be to avoid variable capture. +pushBinds :: Ord n => Set n -> BindStack n -> [Bind n] -> (BindStack n, [Bind n]) +pushBinds fns stack bs + = mapAccumL (pushBind fns) stack bs + + +-- | Push a bind onto a bind stack, +-- anonymizing it if need be to avoid variable capture. +pushBind + :: Ord n + => Set n -- ^ Names that need to be rewritten. + -> BindStack n -- ^ Current bind stack. + -> Bind n -- ^ Bind to push. + -> (BindStack n, Bind n) -- ^ New stack and possibly anonymised bind. + +pushBind fns bs@(BindStack stack env dAnon dName) bb + = case bb of + -- Push already anonymous bind on stack. + BAnon t + -> ( BindStack (BAnon t : stack) (BAnon t : env) (dAnon + 1) dName + , BAnon t) + + -- If the binder needs to be rewritten then push the original name on the + -- 'stackBinds' to remember this. + BName n t + | Set.member n fns + -> ( BindStack (BName n t : stack) (BAnon t : env) dAnon (dName + 1) + , BAnon t) + + | otherwise + -> ( BindStack stack (BName n t : env) dAnon dName + , bb) + + -- Binder was a wildcard. + _ -> (bs, bb) + + + +-- | Compare a `Bound` against the one we're substituting for. +substBound + :: Ord n + => BindStack n -- ^ Current Bind stack during substitution. + -> Bound n -- ^ Bound we're substituting for. + -> Bound n -- ^ Bound we're looking at now. + -> Either + (Bound n) -- Bound doesn't match, but replace with this one. + Int -- Bound matches, drop the thing being substituted and + -- and lift indices this many steps. + +substBound (BindStack binds _ dAnon dName) u u' + -- Bound name matches the one that we're substituting for. + | UName n1 <- u + , UName n2 <- u' + , n1 == n2 + = Right (dAnon + dName) + + -- Bound index matches the one that we're substituting for. + | UIx i1 <- u + , UIx i2 <- u' + , i1 + dAnon == i2 + = Right (dAnon + dName) + + -- The Bind for this name was rewritten to avoid variable capture, + -- so we also have to update the bound occurrence. + | UName _ <- u' + , Just ix <- findIndex (boundMatchesBind u') binds + = Left $ UIx ix + + -- Bound index doesn't match, but lower this index by one to account + -- for the removal of the outer binder. + | UIx i2 <- u' + , i2 > dAnon + , cutOffset <- case u of + UIx{} -> 1 + _ -> 0 + = Left $ UIx (i2 + dName - cutOffset) + + -- Some name that didn't match. + | otherwise + = Left u' + + +------------------------------------------------------------------------------- +-- | Push a level-1 binder on the rewrite stack. +bind1 :: Ord n => Sub n -> Bind n -> (Sub n, Bind n) +bind1 sub b + = let (stackT', b') = pushBind (subConflict1 sub) (subStack1 sub) b + in (sub { subStack1 = stackT' }, b') + + +-- | Push some level-1 binders on the rewrite stack. +bind1s :: Ord n => Sub n -> [Bind n] -> (Sub n, [Bind n]) +bind1s = mapAccumL bind1 + + +-- | Push a level-0 binder on the rewrite stack. +bind0 :: Ord n => Sub n -> Bind n -> (Sub n, Bind n) +bind0 sub b + = let b1 = renameWith sub b + (stackX', b2) = pushBind (subConflict0 sub) (subStack0 sub) b1 + in ( sub { subStack0 = stackX' + , subShadow0 = subShadow0 sub + || namedBoundMatchesBind (subBound sub) b2 } + , b2) + + +-- | Push some level-0 binders on the rewrite stack. +bind0s :: Ord n => Sub n -> [Bind n] -> (Sub n, [Bind n]) +bind0s = mapAccumL bind0 + + +-- | Rewrite the use of a level-1 binder if need be. +use1 :: Ord n => Sub n -> Bound n -> Bound n +use1 sub u + | UName _ <- u + , BindStack binds _ _ _ <- subStack1 sub + , Just ix <- findIndex (boundMatchesBind u) binds + = UIx ix + + | otherwise + = u + + +-- | Rewrite the use of a level-0 binder if need be. +use0 :: Ord n => Sub n -> Bound n -> Bound n +use0 sub u + | UName _ <- u + , BindStack binds _ _ _ <- subStack0 sub + , Just ix <- findIndex (boundMatchesBind u) binds + = UIx ix + + | otherwise + = u + diff --git a/DDC/Type/Transform/SpreadT.hs b/DDC/Type/Transform/SpreadT.hs --- a/DDC/Type/Transform/SpreadT.hs +++ b/DDC/Type/Transform/SpreadT.hs @@ -3,17 +3,19 @@ (SpreadT(..)) where import DDC.Type.Exp -import DDC.Type.Env (Env) +import DDC.Type.Env (TypeEnv) import qualified DDC.Type.Env as Env import qualified DDC.Type.Sum as T class SpreadT (c :: * -> *) where - -- | Spread type annotations from variable binders in to the bound - -- occurrences. + -- | Rewrite `UName` bounds to `UPrim` bounds and attach their types. + -- Primitives have their types attached because they are so common in the + -- language, their types are closed, and we don't want to keep having to + -- look them up from the environment. spreadT :: forall n. Ord n - => Env n -> c n -> c n + => TypeEnv n -> c n -> c n instance SpreadT Type where @@ -47,21 +49,23 @@ instance SpreadT Bound where spreadT kenv uu - | Just t' <- Env.lookup uu kenv = case uu of - UIx ix _ -> UIx ix t' - UPrim n _ -> UPrim n t' - UName n _ - -> if Env.isPrim kenv n - then UPrim n t' - else UName n t' - - | otherwise = uu + UIx{} -> uu + UPrim{} -> uu + UName n + -> case Env.envPrimFun kenv n of + Nothing -> UName n + Just t -> UPrim n t + instance SpreadT TyCon where spreadT kenv tc = case tc of - TyConBound u -> TyConBound (spreadT kenv u) + TyConBound (UName n) _ + -> case Env.envPrimFun kenv n of + Nothing -> tc + Just t -> TyConBound (UPrim n t) t + _ -> tc diff --git a/DDC/Type/Transform/SubstituteT.hs b/DDC/Type/Transform/SubstituteT.hs --- a/DDC/Type/Transform/SubstituteT.hs +++ b/DDC/Type/Transform/SubstituteT.hs @@ -1,23 +1,23 @@ -- | Capture avoiding substitution of types in types. module DDC.Type.Transform.SubstituteT - ( SubstituteT(..) - , substituteT + ( substituteT , substituteTs , substituteBoundT + , SubstituteT(..) , BindStack(..) , pushBind , pushBinds , substBound) where -import DDC.Type.Exp +import DDC.Type.Collect import DDC.Type.Compounds -import DDC.Core.Collect import DDC.Type.Transform.LiftT import DDC.Type.Transform.Crush import DDC.Type.Transform.Trim -import DDC.Type.Rewrite +import DDC.Type.Transform.Rename +import DDC.Type.Exp import Data.Maybe import qualified DDC.Type.Sum as Sum import qualified DDC.Type.Env as Env diff --git a/DDC/Type/Transform/Trim.hs b/DDC/Type/Transform/Trim.hs --- a/DDC/Type/Transform/Trim.hs +++ b/DDC/Type/Transform/Trim.hs @@ -2,7 +2,7 @@ module DDC.Type.Transform.Trim (trimClosure) where -import DDC.Core.Collect +import DDC.Type.Collect import DDC.Type.Check.CheckCon import DDC.Type.Exp import DDC.Type.Compounds @@ -18,19 +18,22 @@ -- -- This is like `crushEffect`, but for closures instead of effects. -- --- For example, trimming @Int r2 -(Read r1 | Use r1)> Int r2@ yields just @Use r1@. +-- For example, trimming @DeepUse (Int r2 -(Read r1 | Use r1)> Int r2)@ yields +-- just @Use r1@. -- Only @r1@ might contain an actual store object that is reachable from a function -- closure with such a type. -- -- This function assumes the closure is well-kinded, and may return `Nothing` if -- this is not the case. +-- trimClosure :: Ord n => Closure n -> Maybe (Closure n) trimClosure cc - = liftM TSum $ trimToSumC cc + = {-# SCC trimClosure #-} + liftM TSum $ trimToSumC cc -- | Trim a closure down to a closure sum. diff --git a/DDC/Type/Universe.hs b/DDC/Type/Universe.hs --- a/DDC/Type/Universe.hs +++ b/DDC/Type/Universe.hs @@ -1,5 +1,4 @@ --- | Universes of the Disciple Core language. module DDC.Type.Universe ( Universe(..) , universeFromType3 @@ -8,7 +7,8 @@ , universeOfType) where import DDC.Type.Exp -import DDC.Type.Compounds +import DDC.Base.Pretty +import DDC.Type.Env as Env import qualified DDC.Type.Sum as T @@ -45,6 +45,16 @@ deriving (Show, Eq) +instance Pretty Universe where + ppr u + = case u of + UniverseSort -> text "Sort" + UniverseKind -> text "Kind" + UniverseSpec -> text "Spec" + UniverseWitness -> text "Witness" + UniverseData -> text "Data" + + -- | 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 @@ -69,9 +79,9 @@ KiConData -> Just UniverseData _ -> Nothing - TCon (TyConWitness _) -> Nothing - TCon (TyConSpec _) -> Nothing - TCon (TyConBound _) -> Nothing + TCon TyConWitness{} -> Nothing + TCon TyConSpec{} -> Nothing + TCon TyConBound{} -> Nothing TForall _ _ -> Nothing TApp _ t2 -> universeFromType2 t2 TSum _ -> Nothing @@ -79,38 +89,47 @@ -- | Given the type of some thing (up one level), -- yield the universe of the original thing, or `Nothing` if it was badly formed. -universeFromType1 :: Type n -> Maybe Universe -universeFromType1 tt +universeFromType1 :: Ord n => Env n -> Type n -> Maybe Universe +universeFromType1 kenv tt = case tt of - TVar u -> universeFromType2 (typeOfBound u) - TCon (TyConSort _) -> Just UniverseKind - TCon (TyConKind _) -> Just UniverseSpec - TCon (TyConWitness _) -> Just UniverseWitness - TCon (TyConSpec TcConFun) -> Just UniverseData - TCon (TyConSpec _) -> Nothing - TCon (TyConBound u) -> universeFromType2 (typeOfBound u) - TForall _ t2 -> universeFromType1 t2 - TApp _ t2 -> universeFromType1 t2 - TSum _ -> Nothing + TVar n + -> case Env.lookup n kenv of + Nothing -> Nothing + Just k -> universeFromType2 k + TCon (TyConSort _) -> Just UniverseKind + TCon (TyConKind _) -> Just UniverseSpec + TCon (TyConWitness _) -> Just UniverseWitness + TCon (TyConSpec TcConFun) -> Just UniverseData + TCon (TyConSpec TcConUnit) -> Just UniverseData + TCon (TyConSpec _) -> Nothing + TCon (TyConBound _ k) -> universeFromType2 k + TForall b t2 -> universeFromType1 (Env.extend b kenv) t2 + TApp t1 _ -> universeFromType1 kenv t1 + TSum _ -> Nothing + -- | Yield the universe of some type. -- -- @ universeOfType (tBot kEffect) = UniverseSpec -- universeOfType kRegion = UniverseKind -- @ -- -universeOfType :: Type n -> Maybe Universe -universeOfType tt +universeOfType :: Ord n => Env n -> Type n -> Maybe Universe +universeOfType kenv tt = case tt of - TVar u -> universeFromType1 (typeOfBound u) + TVar n + -> case Env.lookup n kenv of + Nothing -> Nothing + Just k -> universeFromType1 kenv k + TCon (TyConSort _) -> Just UniverseSort TCon (TyConKind _) -> Just UniverseKind TCon (TyConWitness _) -> Just UniverseSpec TCon (TyConSpec _) -> Just UniverseSpec - TCon (TyConBound u) -> universeFromType1 (typeOfBound u) - TForall _ t2 -> universeOfType t2 - TApp _ t2 -> universeOfType t2 - TSum ss -> universeFromType1 (T.kindOfSum ss) + TCon (TyConBound _ k) -> universeFromType1 kenv k + TForall b t2 -> universeOfType (Env.extend b kenv) t2 + TApp _ t2 -> universeOfType kenv t2 + TSum ss -> universeFromType1 kenv (T.kindOfSum ss) diff --git a/ddc-core.cabal b/ddc-core.cabal --- a/ddc-core.cabal +++ b/ddc-core.cabal @@ -1,5 +1,5 @@ Name: ddc-core -Version: 0.2.1.2 +Version: 0.3.1.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -10,73 +10,116 @@ Category: Compilers/Interpreters Homepage: http://disciple.ouroborus.net Bug-reports: disciple@ouroborus.net -Synopsis: Disciple Core language and type checker. +Synopsis: Disciplined Disciple Compiler core language and type checker. Description: Disciple Core is an explicitly typed language based on System-F2, intended - as an intermediate representation for a compiler. In addition to the features of + as an intermediate representation for a compiler. In addition to the polymorphism of System-F2 it supports region, effect and closure typing. Evaluation order is left-to-right call-by-value by default, but explicit lazy evaluation is also supported. - There is also a capability system to track whether objects are mutable or constant, + There is a capability system to track whether objects are mutable or constant, and to ensure that computations that perform visible side effects are not suspended with lazy evaluation. - See the @ddci-core@ package for a user-facing interpreter. + See the @ddc-tools@ package for a user-facing interpreter and compiler. Library Build-Depends: base == 4.6.*, + deepseq == 1.3.*, containers == 0.5.*, array == 0.4.*, + directory == 1.2.*, transformers == 0.3.*, mtl == 2.1.*, - ddc-base == 0.2.1.* + ddc-base == 0.3.1.* Exposed-modules: - DDC.Core.Check.CheckExp - DDC.Core.Check.CheckWitness - DDC.Core.Check.Error - DDC.Core.Check.TaggedClosure - DDC.Core.Parser.Lexer - DDC.Core.Parser.Tokens - DDC.Core.Transform.LiftW + DDC.Core.Lexer.Names + DDC.Core.Lexer.Tokens + + DDC.Core.Transform.LiftT DDC.Core.Transform.LiftX + DDC.Core.Transform.Reannotate + DDC.Core.Transform.Rename DDC.Core.Transform.SpreadX DDC.Core.Transform.SubstituteTX DDC.Core.Transform.SubstituteWX DDC.Core.Transform.SubstituteXX + DDC.Core.Transform.Trim + DDC.Core.Check DDC.Core.Collect DDC.Core.Compounds - DDC.Core.DataDef + DDC.Core.DaCon DDC.Core.Exp - DDC.Core.Pretty - DDC.Core.Predicates + DDC.Core.Fragment + DDC.Core.Lexer + DDC.Core.Load + DDC.Core.Module DDC.Core.Parser - DDC.Type.Check.Monad + DDC.Core.Predicates + DDC.Core.Pretty + DDC.Type.Transform.Crush DDC.Type.Transform.Instantiate DDC.Type.Transform.LiftT - DDC.Type.Transform.LowerT + DDC.Type.Transform.Rename DDC.Type.Transform.SpreadT DDC.Type.Transform.SubstituteT DDC.Type.Transform.Trim + DDC.Type.Bind DDC.Type.Check + DDC.Type.Collect DDC.Type.Compounds + DDC.Type.DataDef DDC.Type.Env DDC.Type.Equiv DDC.Type.Exp - DDC.Type.Parser DDC.Type.Predicates - DDC.Type.Rewrite + DDC.Type.Pretty DDC.Type.Subsumes DDC.Type.Sum DDC.Type.Universe Other-modules: + DDC.Core.Check.CheckDaCon + DDC.Core.Check.CheckExp + DDC.Core.Check.CheckModule + DDC.Core.Check.CheckWitness DDC.Core.Check.ErrorMessage + DDC.Core.Check.Error + DDC.Core.Check.TaggedClosure + + DDC.Core.Collect.Support + DDC.Core.Collect.Free + + DDC.Core.Exp.Base + DDC.Core.Exp.NFData + + DDC.Core.Fragment.Compliance + DDC.Core.Fragment.Error + DDC.Core.Fragment.Feature + DDC.Core.Fragment.Profile + + DDC.Core.Lexer.Comments + DDC.Core.Lexer.Offside + + DDC.Core.Parser.Base + DDC.Core.Parser.Exp + DDC.Core.Parser.Module + DDC.Core.Parser.Param + DDC.Core.Parser.Type + DDC.Core.Parser.Witness + DDC.Type.Check.CheckCon - DDC.Type.Check.CheckError - DDC.Type.Pretty + DDC.Type.Check.Error + DDC.Type.Check.ErrorMessage + + DDC.Type.Collect.FreeT + + DDC.Type.Exp.Base + DDC.Type.Exp.NFData + GHC-options: -Wall @@ -85,6 +128,7 @@ -fno-warn-unused-do-bind Extensions: + BangPatterns ParallelListComp PatternGuards RankNTypes @@ -97,4 +141,6 @@ ScopedTypeVariables StandaloneDeriving DoAndIfThenElse - + DeriveDataTypeable + ViewPatterns +