diff --git a/DDC/Source/Tetra/Collect/FreeVars.hs b/DDC/Source/Tetra/Collect/FreeVars.hs new file mode 100644 --- /dev/null +++ b/DDC/Source/Tetra/Collect/FreeVars.hs @@ -0,0 +1,44 @@ + +module DDC.Source.Tetra.Collect.FreeVars where +import DDC.Source.Tetra.Exp +import DDC.Source.Tetra.Env (Env, Presence(..)) +import Data.Set (Set) +import qualified DDC.Source.Tetra.Env as Env +import qualified Data.Set as Set + + +-- | Collect the variables a type that do not appear in the given environment. +freeVarsT :: Env -> Type -> Set Bound +freeVarsT env tt + = case tt of + TAnnot _ t + -> freeVarsT env t + + TCon{} + -> Set.empty + + TVar u@(UName _) + -> case Env.lookupTyVar env u of + Present _ -> Set.empty + Unknown -> Set.empty + Absent -> Set.singleton u + + TVar u@(UIx i) + -> case Env.lookupTyVar env u of + Present _ -> Set.empty + Unknown -> Set.empty + Absent -> Set.singleton (UIx (i - Env.tyStackDepth env)) + + TVar UHole + -> Set.empty + + TAbs{} + | Just (k, b, t) <- takeTForall tt + -> freeVarsT (Env.extendTyVar b k env) t + + | otherwise + -> Set.empty + + TApp t1 t2 + -> Set.union (freeVarsT env t1) (freeVarsT env t2) + diff --git a/DDC/Source/Tetra/Compounds.hs b/DDC/Source/Tetra/Compounds.hs deleted file mode 100644 --- a/DDC/Source/Tetra/Compounds.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - --- | Utilities for constructing and destructing Source Tetra expressions. -module DDC.Source.Tetra.Compounds - ( module DDC.Type.Compounds - , takeAnnotOfExp - - -- * Lambdas - , xLAMs - , xLams - , makeXLamFlags - , takeXLAMs - , takeXLams - , takeXLamFlags - - -- * Applications - , xApps - , makeXAppsWithAnnots - , takeXApps - , takeXApps1 - , takeXAppsAsList - , takeXAppsWithAnnots - , takeXConApps - , takeXPrimApps - - -- * Casts - , xBox - , xRun - - -- * Data Constructors - , dcUnit - , takeNameOfDaCon - , takeTypeOfDaCon - - -- * Patterns - , bindsOfPat - , pTrue - , pFalse - - -- * Witnesses - , wApp - , wApps - , takeXWitness - , takeWAppsAsList - , takePrimWiConApps - - -- * Primitives - , xErrorDefault) -where -import DDC.Source.Tetra.Exp -import DDC.Source.Tetra.Prim -import DDC.Type.Compounds -import Data.Text (Text) -import DDC.Core.Exp.Annot.Compounds - ( dcUnit - , takeNameOfDaCon - , takeTypeOfDaCon - - , bindsOfPat - - , wApp - , wApps - , takeXWitness - , takeWAppsAsList - , takePrimWiConApps) - - --- Annotations ---------------------------------------------------------------- --- | Take the outermost annotation from an expression, --- or Nothing if this is an `XType` or `XWitness` without an annotation. -takeAnnotOfExp :: GExp l -> Maybe (GAnnot l) -takeAnnotOfExp xx - = case xx of - XVar a _ -> Just a - XPrim 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 - XDefix a _ -> Just a - XInfixOp a _ -> Just a - XInfixVar a _ -> Just a - - --- Lambdas --------------------------------------------------------------------- --- | Make some nested type lambdas. -xLAMs :: GAnnot l -> [GBind l] -> GExp l -> GExp l -xLAMs a bs x - = foldr (XLAM a) x bs - - --- | Make some nested value or witness lambdas. -xLams :: GAnnot l -> [GBind l] -> GExp l -> GExp l -xLams a bs x - = foldr (XLam a) x bs - - --- | Split type lambdas from the front of an expression, --- or `Nothing` if there aren't any. -takeXLAMs :: GExp l -> Maybe ([GBind l], GExp l) -takeXLAMs xx - = let go bs (XLAM _ b x) = go (b:bs) x - go bs x = (reverse bs, x) - in case go [] xx of - ([], _) -> Nothing - (bs, body) -> Just (bs, body) - - --- | Split nested value or witness lambdas from the front of an expression, --- or `Nothing` if there aren't any. -takeXLams :: GExp l -> Maybe ([GBind l], GExp l) -takeXLams xx - = let go bs (XLam _ b x) = go (b:bs) x - go bs x = (reverse bs, x) - in case go [] xx of - ([], _) -> Nothing - (bs, body) -> Just (bs, body) - - --- | Make some nested lambda abstractions, --- using a flag to indicate whether the lambda is a --- level-1 (True), or level-0 (False) binder. -makeXLamFlags :: GAnnot l -> [(Bool, GBind l)] -> GExp l -> GExp l -makeXLamFlags a fbs x - = foldr (\(f, b) x' - -> if f then XLAM a b x' - else XLam a b x') - x fbs - - --- | Split nested lambdas from the front of an expression, --- with a flag indicating whether the lambda was a level-1 (True), --- or level-0 (False) binder. -takeXLamFlags :: GExp l -> Maybe ([(Bool, GBind l)], GExp l) -takeXLamFlags xx - = let go bs (XLAM _ b x) = go ((True, b):bs) x - go bs (XLam _ b x) = go ((False, b):bs) x - go bs x = (reverse bs, x) - in case go [] xx of - ([], _) -> Nothing - (bs, body) -> Just (bs, body) - - --- Applications --------------------------------------------------------------- --- | Build sequence of value applications. -xApps :: GAnnot l -> GExp l -> [GExp l] -> GExp l -xApps a t1 ts = foldl (XApp a) t1 ts - - --- | Build sequence of applications. --- Similar to `xApps` but also takes list of annotations for --- the `XApp` constructors. -makeXAppsWithAnnots :: GExp l -> [(GExp l, GAnnot l)] -> GExp l -makeXAppsWithAnnots f xas - = case xas of - [] -> f - (arg,a ) : as -> makeXAppsWithAnnots (XApp a f arg) as - - --- | Flatten an application into the function part and its arguments. --- --- Returns `Nothing` if there is no outer application. -takeXApps :: GExp l -> Maybe (GExp l, [GExp l]) -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 :: GExp l -> GExp l -> (GExp l, [GExp l]) -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 :: GExp l -> [GExp l] -takeXAppsAsList xx - = case xx of - XApp _ x1 x2 -> takeXAppsAsList x1 ++ [x2] - _ -> [xx] - - --- | Destruct sequence of applications. --- Similar to `takeXAppsAsList` but also keeps annotations for later. -takeXAppsWithAnnots :: GExp l -> (GExp l, [(GExp l, GAnnot l)]) -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 :: GExp l -> Maybe (GPrim l, [GExp l]) -takeXPrimApps xx - = case takeXAppsAsList xx of - XPrim _ 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 :: GExp l -> Maybe (DaCon (GName l), [GExp l]) -takeXConApps xx - = case takeXAppsAsList xx of - XCon _ dc : xs -> Just (dc, xs) - _ -> Nothing - - --- Casts ---------------------------------------------------------------------- -xBox a x = XCast a CastBox x -xRun a x = XCast a CastRun x - - --- Primitives ----------------------------------------------------------------- -xErrorDefault :: (GPrim l ~ PrimVal, GName l ~ Name) - => GAnnot l -> Text -> Integer -> GExp l -xErrorDefault a name n - = xApps a - (XPrim a (PrimValError OpErrorDefault)) - [ XCon a (DaConPrim (NameLitTextLit name) (tBot kData)) - , XCon a (DaConPrim (NameLitNat n) (tBot kData))] - --- Patterns ------------------------------------------------------------------- -pTrue = PData (DaConPrim (NameLitBool True) tBool) [] -pFalse = PData (DaConPrim (NameLitBool False) tBool) [] - - diff --git a/DDC/Source/Tetra/Convert.hs b/DDC/Source/Tetra/Convert.hs --- a/DDC/Source/Tetra/Convert.hs +++ b/DDC/Source/Tetra/Convert.hs @@ -8,41 +8,32 @@ , runConvertM) where import DDC.Source.Tetra.Convert.Error -import DDC.Data.SourcePos +import DDC.Source.Tetra.Convert.Witness +import DDC.Source.Tetra.Convert.Clause +import DDC.Source.Tetra.Convert.Type +import DDC.Source.Tetra.Convert.Prim +import DDC.Source.Tetra.Convert.Base -import qualified DDC.Source.Tetra.Transform.Guards as S import qualified DDC.Source.Tetra.Module as S import qualified DDC.Source.Tetra.DataDef as S -import qualified DDC.Source.Tetra.Env as S -import qualified DDC.Source.Tetra.Compounds as S -import qualified DDC.Source.Tetra.Exp.Annot as S -import qualified DDC.Source.Tetra.Prim as S +import qualified DDC.Source.Tetra.Exp as S +import qualified DDC.Source.Tetra.Env as Env +import qualified DDC.Core.Tetra.Compounds as C import qualified DDC.Core.Tetra.Prim as C import qualified DDC.Core.Module as C -import qualified DDC.Core.Exp.Annot as C import qualified DDC.Type.DataDef as C - -import qualified DDC.Type.Exp as T -import qualified DDC.Type.Sum as Sum import qualified Data.Text as Text +import qualified Text.Show.Pretty as Text import Data.Maybe - import DDC.Core.Module ( ExportSource (..) , ImportType (..) , ImportCap (..) , ImportValue (..)) - --------------------------------------------------------------------------------------------------- -type ConvertM a x - = Either (ErrorConvert a) x - -type SP = SourcePos - - -- | Run a conversion computation. runConvertM :: ConvertM a x -> Either (ErrorConvert a) x runConvertM cc = cc @@ -50,8 +41,8 @@ -- | Convert a Source Tetra module to Core Tetra. coreOfSourceModule :: SP - -> S.Module (S.Annot SP) - -> Either (ErrorConvert SP) (C.Module SP C.Name) + -> S.Module S.Source + -> Either (ErrorConvert S.Source) (C.Module SP C.Name) coreOfSourceModule a mm = runConvertM @@ -69,46 +60,54 @@ -- coreOfSourceModuleM :: SP - -> S.Module (S.Annot SP) - -> ConvertM SP (C.Module SP C.Name) + -> S.Module S.Source + -> ConvertM S.Source (C.Module SP C.Name) coreOfSourceModuleM a mm = do -- Exported types and values. - exportTypes' <- sequence - $ fmap (\n - -> (,) <$> (pure $ toCoreN n) - <*> (pure $ ExportSourceLocalNoType (toCoreN n))) - $ S.moduleExportTypes mm + exportTypes' + <- sequence + $ fmap (\n -> (,) <$> toCoreTUCN n + <*> (fmap ExportSourceLocalNoType $ toCoreTUCN n)) + $ S.moduleExportTypes mm - exportValues' <- sequence - $ fmap (\n - -> (,) <$> (pure $ toCoreN n) - <*> (pure $ ExportSourceLocalNoType (toCoreN n))) - $ S.moduleExportValues mm + exportValues' + <- sequence + $ fmap (\n -> (,) <$> toCoreXUVN n + <*> (fmap ExportSourceLocalNoType (toCoreXUVN n))) + $ S.moduleExportValues mm - -- Imported types and values. - importTypes' <- sequence - $ fmap (\(n, it) - -> (,) <$> (pure $ toCoreN n) <*> (toCoreImportType it)) - $ S.moduleImportTypes mm - importCaps' <- sequence - $ fmap (\(n, iv) - -> (,) <$> (pure $ toCoreN n) <*> (toCoreImportCap iv)) - $ S.moduleImportCaps mm + -- Imported types, capabilities and values. + importTypes' + <- sequence + $ fmap (\(n, it) -> (,) <$> toCoreTBCN n <*> (toCoreImportType it)) + $ S.moduleImportTypes mm - importValues' <- sequence - $ fmap (\(n, iv) - -> (,) <$> (pure $ toCoreN n) <*> (toCoreImportValue iv)) - $ S.moduleImportValues mm + importCaps' + <- sequence + $ fmap (\(n, iv) -> (,) <$> toCoreXBVN n <*> toCoreImportCap iv) + $ S.moduleImportCaps mm + importValues' + <- sequence + $ fmap (\(n, iv) -> (,) <$> toCoreXBVN n <*> toCoreImportValue iv) + $ S.moduleImportValues mm + -- Data type definitions. - dataDefsLocal <- sequence $ fmap toCoreDataDef - $ [ def | S.TopData _ def <- S.moduleTops mm ] + dataDefsLocal + <- sequence $ fmap toCoreDataDef + $ [ def | S.TopData _ def <- S.moduleTops mm ] + -- Type equations. + typeDefsLocal + <- sequence $ fmap toCoreTypeDef + $ [ (b, t) | S.TopType _ b t <- S.moduleTops mm ] + -- Top level bindings. - ltsTops <- letsOfTops $ S.moduleTops mm + ltsTops + <- letsOfTops $ S.moduleTops mm return $ C.ModuleCore @@ -120,131 +119,100 @@ , C.moduleExportValues = exportValues' ++ (if C.isMainModuleName (S.moduleName mm) - && (not $ elem (S.NameVar "main") $ S.moduleExportValues mm) + && (not $ elem (S.UName (Text.pack "main")) + $ S.moduleExportValues mm) + then [ ( C.NameVar "main" , ExportSourceLocalNoType (C.NameVar "main"))] + else []) , C.moduleImportTypes = importTypes' , C.moduleImportCaps = importCaps' , C.moduleImportValues = importValues' , C.moduleImportDataDefs = [] + , C.moduleImportTypeDefs = [] , C.moduleDataDefsLocal = dataDefsLocal + , C.moduleTypeDefsLocal = typeDefsLocal , C.moduleBody = C.XLet a ltsTops (C.xUnit a) } -- | Extract the top-level bindings from some source definitions. -letsOfTops :: [S.Top (S.Annot SP)] - -> ConvertM SP (C.Lets SP C.Name) +letsOfTops :: [S.Top S.Source] + -> ConvertM S.Source (C.Lets SP C.Name) letsOfTops tops - = C.LRec <$> (sequence $ mapMaybe bindOfTop tops) - - --- | Try to convert a `TopBind` to a top-level binding, --- or `Nothing` if it isn't one. -bindOfTop - :: S.Top (S.Annot SP) - -> Maybe (ConvertM SP (T.Bind C.Name, C.Exp SP C.Name)) + = do + -- Collect up the type signatures defined at top level. + let cls = [cl | S.TopClause _ cl <- tops] + let sigs = collectSigsFromClauses cls + let vals = collectBoundVarsFromClauses cls -bindOfTop (S.TopClause _ (S.SLet _ b [] [S.GExp x])) - = Just ((,) <$> toCoreB b <*> toCoreX x) + bxps <- fmap catMaybes + $ mapM (makeBindingFromClause sigs vals) cls -bindOfTop _ - = Nothing + let (bms, xps) = unzip bxps + bs' <- mapM (toCoreBM UniverseSpec) bms + xs' <- mapM (\(sp, x) -> toCoreX sp x) xps + return $ C.LRec $ zip bs' xs' -- ImportType ------------------------------------------------------------------------------------- -toCoreImportType :: ImportType S.Name -> ConvertM a (ImportType C.Name) +toCoreImportType + :: ImportType n S.Type + -> ConvertM a (ImportType C.Name (C.Type C.Name)) + toCoreImportType src = case src of ImportTypeAbstract t - -> ImportTypeAbstract <$> toCoreT t + -> ImportTypeAbstract <$> toCoreT UniverseKind t ImportTypeBoxed t - -> ImportTypeBoxed <$> toCoreT t + -> ImportTypeBoxed <$> toCoreT UniverseKind t -- ImportCap -------------------------------------------------------------------------------------- -toCoreImportCap :: ImportCap S.Name -> ConvertM a (ImportCap C.Name) +toCoreImportCap + :: ImportCap S.Bind S.Type + -> ConvertM a (ImportCap C.Name (C.Type C.Name)) + toCoreImportCap src = case src of ImportCapAbstract t - -> ImportCapAbstract <$> toCoreT t + -> ImportCapAbstract <$> toCoreT UniverseSpec t -- ImportValue ------------------------------------------------------------------------------------ -toCoreImportValue :: ImportValue S.Name -> ConvertM a (ImportValue C.Name) +toCoreImportValue + :: ImportValue S.Bind S.Type + -> ConvertM a (ImportValue C.Name (C.Type C.Name)) + toCoreImportValue src = case src of ImportValueModule mn n t mA -> ImportValueModule - <$> (pure mn) <*> (pure $ toCoreN n) <*> toCoreT t <*> pure mA + <$> pure mn <*> toCoreXBVN n + <*> toCoreT UniverseSpec t + <*> pure mA ImportValueSea v t -> ImportValueSea - <$> pure v <*> toCoreT t - - --- Type ------------------------------------------------------------------------------------------- -toCoreT :: T.Type S.Name -> ConvertM a (T.Type C.Name) -toCoreT tt - = case tt of - T.TVar u - -> T.TVar <$> toCoreU u - - T.TCon tc - -> T.TCon <$> toCoreTC tc - - T.TForall b t - -> T.TForall <$> toCoreB b <*> toCoreT t - - T.TApp t1 t2 - -> T.TApp <$> toCoreT t1 <*> toCoreT t2 - - T.TSum ts - -> do k' <- toCoreT $ Sum.kindOfSum ts - - tss' <- fmap (Sum.fromList k') - $ sequence $ fmap toCoreT $ Sum.toList ts - - return $ T.TSum tss' - - --- TyCon ------------------------------------------------------------------------------------------ -toCoreTC :: T.TyCon S.Name -> ConvertM a (T.TyCon C.Name) -toCoreTC tc - = case tc of - T.TyConSort sc - -> pure $ T.TyConSort sc - - T.TyConKind kc - -> pure $ T.TyConKind kc - - T.TyConWitness wc - -> pure $ T.TyConWitness wc - - T.TyConSpec sc - -> pure $ T.TyConSpec sc - - T.TyConBound u k - -> T.TyConBound <$> toCoreU u <*> toCoreT k - - T.TyConExists n k - -> T.TyConExists <$> pure n <*> toCoreT k + <$> pure v <*> toCoreT UniverseSpec t -- DataDef ---------------------------------------------------------------------------------------- -toCoreDataDef :: S.DataDef S.Name -> ConvertM a (C.DataDef C.Name) +toCoreDataDef :: S.DataDef S.Source -> ConvertM a (C.DataDef C.Name) toCoreDataDef def = do - defParams <- sequence $ fmap toCoreB $ S.dataDefParams def + defParams <- sequence $ fmap toCoreTBK $ S.dataDefParams def defCtors <- sequence $ fmap (\(ctor, tag) -> toCoreDataCtor def tag ctor) $ [(ctor, tag) | ctor <- S.dataDefCtors def | tag <- [0..]] + let (S.TyConBindName txTyConName) = S.dataDefTypeName def + return $ C.DataDef - { C.dataDefTypeName = toCoreN $ S.dataDefTypeName def + { C.dataDefTypeName = C.NameCon (Text.unpack txTyConName) , C.dataDefParams = defParams , C.dataDefCtors = Just $ defCtors , C.dataDefIsAlgebraic = True } @@ -252,119 +220,142 @@ -- DataCtor --------------------------------------------------------------------------------------- toCoreDataCtor - :: S.DataDef S.Name + :: S.DataDef S.Source -> Integer - -> S.DataCtor S.Name + -> S.DataCtor S.Source -> ConvertM a (C.DataCtor C.Name) toCoreDataCtor dataDef tag ctor - = do typeParams <- sequence $ fmap toCoreB $ S.dataDefParams dataDef - fieldTypes <- sequence $ fmap toCoreT $ S.dataCtorFieldTypes ctor - resultType <- toCoreT (S.dataCtorResultType ctor) + = do typeParams <- sequence $ fmap toCoreTBK $ S.dataDefParams dataDef + fieldTypes <- sequence $ fmap (toCoreT UniverseSpec) $ S.dataCtorFieldTypes ctor + resultType <- toCoreT UniverseSpec (S.dataCtorResultType ctor) + let (S.TyConBindName txTyConName) = S.dataDefTypeName dataDef return $ C.DataCtor - { C.dataCtorName = toCoreN (S.dataCtorName ctor) + { C.dataCtorName = toCoreDaConBind (S.dataCtorName ctor) , C.dataCtorTag = tag , C.dataCtorFieldTypes = fieldTypes , C.dataCtorResultType = resultType - , C.dataCtorTypeName = toCoreN (S.dataDefTypeName dataDef) + , C.dataCtorTypeName = C.NameCon (Text.unpack txTyConName) , C.dataCtorTypeParams = typeParams } -- Exp -------------------------------------------------------------------------------------------- -toCoreX :: S.Exp SP -> ConvertM SP (C.Exp SP C.Name) -toCoreX xx +toCoreX :: SP -> S.Exp -> ConvertM S.Source (C.Exp SP C.Name) +toCoreX a xx = case xx of - S.XVar a u - -> C.XVar <$> pure a <*> toCoreU u + S.XAnnot a' x + -> toCoreX a' x + S.XVar u + -> C.XVar <$> pure a <*> toCoreU u + -- Wrap text literals into Text during conversion to Core. -- The 'textLit' variable refers to whatever is in scope. - S.XCon a dc@(C.DaConPrim (S.NameLitTextLit{}) _) - -> C.XApp <$> pure a - <*> (C.XVar <$> pure a <*> (pure $ C.UName (C.NameVar "textLit"))) - <*> (C.XCon <$> pure a <*> (toCoreDC dc)) + S.XCon dc@(C.DaConPrim (S.DaConBoundLit (S.PrimLitTextLit{})) _) + -> C.XApp <$> pure a + <*> (C.XVar <$> pure a <*> (pure $ C.UName (C.NameVar "textLit"))) + <*> (C.XCon <$> pure a <*> (toCoreDC dc)) - S.XPrim a p - -> C.XVar <$> pure a <*> toCoreU (C.UPrim (S.NameVal p) (S.typeOfPrimVal p)) + S.XPrim p + -> do let p' = toCorePrimVal p + t' <- toCoreT UniverseSpec $ Env.typeOfPrimVal p + return $ C.XVar a (C.UPrim p' t') - S.XCon a dc - -> C.XCon <$> pure a <*> toCoreDC dc + S.XCon dc + -> C.XCon <$> pure a <*> toCoreDC dc - S.XLAM a b x - -> C.XLAM <$> pure a <*> toCoreB b <*> toCoreX x + S.XLAM bm x + -> C.XLAM <$> pure a <*> toCoreBM UniverseKind bm <*> toCoreX a x - S.XLam a b x - -> C.XLam <$> pure a <*> toCoreB b <*> toCoreX x + S.XLam bm x + -> C.XLam <$> pure a <*> toCoreBM UniverseSpec bm <*> toCoreX a x -- We don't want to wrap the source file path passed to the default# prim -- in a Text constructor, so detect this case separately. - S.XApp a0 _ _ + S.XApp _ _ | Just ( p@(S.PrimValError S.OpErrorDefault) - , [S.XCon a1 dc1, S.XCon a2 dc2]) + , [S.XCon dc1, S.XCon dc2]) <- S.takeXPrimApps xx - -> do xPrim' <- toCoreX (S.XPrim a0 p) + -> do xPrim' <- toCoreX a (S.XPrim p) dc1' <- toCoreDC dc1 dc2' <- toCoreDC dc2 - return $ C.xApps a0 xPrim' [C.XCon a1 dc1', C.XCon a2 dc2'] + return $ C.xApps a xPrim' [C.XCon a dc1', C.XCon a dc2'] - S.XApp a x1 x2 - -> C.XApp <$> pure a <*> toCoreX x1 <*> toCoreX x2 + S.XApp x1 x2 + -> C.XApp <$> pure a <*> toCoreX a x1 <*> toCoreX a x2 - S.XLet a lts x - -> C.XLet <$> pure a <*> toCoreLts lts <*> toCoreX x + S.XLet lts x + -> C.XLet <$> pure a <*> toCoreLts a lts <*> toCoreX a x - S.XCase a x alts - -> C.XCase <$> pure a <*> toCoreX x <*> (sequence $ map (toCoreA a) alts) + S.XCase x alts + -> C.XCase <$> pure a <*> toCoreX a x + <*> (sequence $ map (toCoreA a) alts) - S.XCast a c x - -> C.XCast <$> pure a <*> toCoreC c <*> toCoreX x + S.XCast c x + -> C.XCast <$> pure a <*> toCoreC a c <*> toCoreX a x - S.XType a t - -> C.XType <$> pure a <*> toCoreT t + S.XType t + -> C.XType <$> pure a <*> toCoreT UniverseSpec t - S.XWitness a w - -> C.XWitness <$> pure a <*> toCoreW w + S.XWitness w + -> C.XWitness <$> pure a <*> toCoreW a w -- These shouldn't exist in the desugared source tetra code. - S.XDefix{} -> Left $ ErrorConvertCannotConvertSugarExp xx - S.XInfixOp{} -> Left $ ErrorConvertCannotConvertSugarExp xx - S.XInfixVar{} -> Left $ ErrorConvertCannotConvertSugarExp xx + S.XDefix{} -> Left $ ErrorConvertSugaredExp xx + S.XInfixOp{} -> Left $ ErrorConvertSugaredExp xx + S.XInfixVar{} -> Left $ ErrorConvertSugaredExp xx + S.XMatch{} -> Left $ ErrorConvertSugaredExp xx + S.XWhere{} -> Left $ ErrorConvertSugaredExp xx + S.XLamPat{} -> Left $ ErrorConvertSugaredExp xx + S.XLamCase{} -> Left $ ErrorConvertSugaredExp xx -- Lets ------------------------------------------------------------------------------------------- -toCoreLts :: S.Lets SP -> ConvertM SP (C.Lets SP C.Name) -toCoreLts lts +toCoreLts :: SP -> S.Lets -> ConvertM S.Source (C.Lets SP C.Name) +toCoreLts a lts = case lts of S.LLet b x - -> C.LLet <$> toCoreB b <*> toCoreX x + -> C.LLet <$> toCoreBM UniverseSpec b <*> toCoreX a x S.LRec bxs - -> C.LRec <$> (sequence $ map (\(b, x) -> (,) <$> toCoreB b <*> toCoreX x) bxs) + -> C.LRec <$> (sequence + $ map (\(b, x) -> (,) <$> toCoreBM UniverseSpec b <*> toCoreX a x) bxs) - S.LPrivate bks Nothing bts - -> C.LPrivate <$> (sequence $ fmap toCoreB bks) - <*> pure Nothing - <*> (sequence $ fmap toCoreB bts) + S.LPrivate bs Nothing bts + -> C.LPrivate + <$> (sequence $ fmap (toCoreBM UniverseKind) + $ [S.XBindVarMT b (Just S.KRegion) | b <- bs]) + <*> pure Nothing + <*> (sequence $ fmap toCoreTBK bts) - S.LPrivate bks (Just tParent) bts - -> C.LPrivate <$> (sequence $ fmap toCoreB bks) - <*> (fmap Just $ toCoreT tParent) - <*> (sequence $ fmap toCoreB bts) + S.LPrivate bs (Just tParent) bts + -> C.LPrivate + <$> (sequence $ fmap (toCoreBM UniverseKind) + $ [S.XBindVarMT b (Just S.KRegion) | b <- bs]) + <*> (fmap Just $ toCoreT UniverseKind tParent) + <*> (sequence $ fmap toCoreTBK bts) - S.LGroup{} - -> Left $ ErrorConvertCannotConvertSugarLets lts + S.LGroup cls + -> do let sigs = collectSigsFromClauses cls + let vals = collectBoundVarsFromClauses cls + bxs <- fmap catMaybes + $ mapM (makeBindingFromClause sigs vals) cls + let bxs' = [(b, x) | (b, (_, x)) <- bxs] + toCoreLts a (S.LRec bxs') + + -- Cast ------------------------------------------------------------------------------------------- -toCoreC :: S.Cast a -> ConvertM a (C.Cast a C.Name) -toCoreC cc +toCoreC :: SP -> S.Cast -> ConvertM S.Source (C.Cast SP C.Name) +toCoreC a cc = case cc of S.CastWeakenEffect eff - -> C.CastWeakenEffect <$> toCoreT eff + -> C.CastWeakenEffect <$> toCoreT UniverseSpec eff S.CastPurify w - -> C.CastPurify <$> toCoreW w + -> C.CastPurify <$> toCoreW a w S.CastBox -> pure C.CastBox @@ -374,142 +365,73 @@ -- Alt -------------------------------------------------------------------------------------------- -toCoreA :: SP -> S.Alt SP -> ConvertM SP (C.Alt SP C.Name) -toCoreA sp (S.AAlt w gxs) - = C.AAlt <$> toCoreP w - <*> (toCoreX $ S.desugarGuards sp gxs - $ S.xErrorDefault sp - (Text.pack $ sourcePosSource sp) - (fromIntegral $ sourcePosLine sp)) +toCoreA :: SP -> S.AltCase -> ConvertM S.Source (C.Alt SP C.Name) +toCoreA sp alt + = case alt of + S.AAltCase w [S.GExp x] + -> C.AAlt <$> toCoreP alt w <*> toCoreX sp x + _ -> error $ unlines + [ "ddc-source-tetra: cannot convert sugared alt" + , Text.ppShow alt] + -- Pat -------------------------------------------------------------------------------------------- -toCoreP :: S.Pat a -> ConvertM a (C.Pat C.Name) -toCoreP pp +toCoreP :: S.AltCase -> S.Pat -> ConvertM a (C.Pat C.Name) +toCoreP aa pp = case pp of - S.PDefault + S.PDefault -> pure C.PDefault - S.PData dc bs - -> C.PData <$> toCoreDC dc <*> (sequence $ fmap toCoreB bs) - - --- DaCon ------------------------------------------------------------------------------------------ -toCoreDC :: S.DaCon S.Name -> ConvertM a (C.DaCon C.Name) -toCoreDC dc - = case dc of - S.DaConUnit - -> pure $ C.DaConUnit - - S.DaConPrim n t - -> C.DaConPrim <$> (pure $ toCoreN n) <*> toCoreT t - - S.DaConBound n - -> C.DaConBound <$> (pure $ toCoreN n) - - --- Witness ---------------------------------------------------------------------------------------- -toCoreW :: S.Witness a -> ConvertM a (C.Witness a C.Name) -toCoreW ww - = case ww of - S.WVar a u - -> C.WVar <$> pure a <*> toCoreU u - - S.WCon a wc - -> C.WCon <$> pure a <*> toCoreWC wc - - S.WApp a w1 w2 - -> C.WApp <$> pure a <*> toCoreW w1 <*> toCoreW w2 - - S.WType a t - -> C.WType <$> pure a <*> toCoreT t + S.PAt{} + -> error $ unlines + [ "ddc-source-tetra: cannot convert PAt pattern" + , Text.ppShow pp] + S.PVar{} + -> error $ unlines + [ "ddc-source-tetra: cannot convert PVar pattern" + , Text.ppShow aa] --- WiCon ------------------------------------------------------------------------------------------ -toCoreWC :: S.WiCon a -> ConvertM a (C.WiCon C.Name) -toCoreWC wc - = case wc of - S.WiConBound u t - -> C.WiConBound <$> toCoreU u <*> toCoreT t + S.PData dc bs + -> C.PData <$> toCoreDC dc <*> (sequence $ fmap toCorePasB bs) --- Bind ------------------------------------------------------------------------------------------- -toCoreB :: S.Bind -> ConvertM a (C.Bind C.Name) -toCoreB bb - = case bb of - T.BName n t - -> T.BName <$> (pure $ toCoreN n) <*> toCoreT t - - T.BAnon t - -> T.BAnon <$> toCoreT t - - T.BNone t - -> T.BNone <$> toCoreT t - +-- | Convert a pattern to a core binder. +-- Only default and var patterns are supported, +-- nested patterns need to have been eliminated by the desugarer. +toCorePasB :: S.Pat -> ConvertM a (C.Bind C.Name) +toCorePasB pp + = let hole = C.TVar (C.UName C.NameHole) + in case pp of + S.PDefault + -> pure $ C.BAnon hole --- Bound ------------------------------------------------------------------------------------------ -toCoreU :: S.Bound -> ConvertM a (C.Bound C.Name) -toCoreU uu - = case uu of - T.UName n - -> T.UName <$> (pure $ toCoreN n) + S.PAt{} + -> error $ "ddc-source-tetra: cannot convert at pattern " ++ Text.ppShow pp - T.UIx i - -> T.UIx <$> (pure i) + S.PVar b + -> do b' <- toCoreB b + return b' - T.UPrim n t - -> T.UPrim <$> (pure $ toCoreN n) <*> toCoreT t + S.PData{} + -> error $ "ddc-source-tetra: cannot convert nested pattern " ++ Text.ppShow pp --- Name ------------------------------------------------------------------------------------------- -toCoreN :: S.Name -> C.Name -toCoreN nn - = case nn of - S.NameVar str - -> C.NameVar str - - S.NameCon str - -> C.NameCon str - - S.NamePrim (S.PrimNameType (S.PrimTypeTyConTetra tc)) - -> C.NameTyConTetra (toCoreTyConTetra tc) - - S.NamePrim (S.PrimNameType (S.PrimTypeTyCon p)) - -> C.NamePrimTyCon p - - S.NamePrim (S.PrimNameVal (S.PrimValLit lit)) - -> case lit of - S.PrimLitBool x -> C.NameLitBool x - S.PrimLitNat x -> C.NameLitNat x - S.PrimLitInt x -> C.NameLitInt x - S.PrimLitSize x -> C.NameLitSize x - S.PrimLitWord x s -> C.NameLitWord x s - S.PrimLitFloat x s -> C.NameLitFloat x s - S.PrimLitTextLit x -> C.NameLitTextLit x - - S.NamePrim (S.PrimNameVal (S.PrimValArith p)) - -> C.NamePrimArith p False - - S.NamePrim (S.PrimNameVal (S.PrimValVector p)) - -> C.NameOpVector p False +-- DaCon ------------------------------------------------------------------------------------------ +toCoreDC :: S.DaCon S.DaConBound S.Type + -> ConvertM a (C.DaCon C.Name (C.Type (C.Name))) - S.NamePrim (S.PrimNameVal (S.PrimValFun p)) - -> C.NameOpFun p +toCoreDC dc + = case dc of + S.DaConUnit + -> pure $ C.DaConUnit - S.NamePrim (S.PrimNameVal (S.PrimValError p)) - -> C.NameOpError p False + S.DaConPrim n t + -> C.DaConPrim <$> (pure $ toCoreDaConBound n) <*> toCoreT UniverseSpec t - S.NameHole - -> C.NameHole + S.DaConBound n + -> C.DaConBound <$> (pure $ toCoreDaConBound n) --- | Convert a Tetra specific type constructor to core. -toCoreTyConTetra :: S.PrimTyConTetra -> C.TyConTetra -toCoreTyConTetra tc - = case tc of - S.PrimTyConTetraTuple n -> C.TyConTetraTuple n - S.PrimTyConTetraVector -> C.TyConTetraVector - S.PrimTyConTetraF -> C.TyConTetraF - S.PrimTyConTetraC -> C.TyConTetraC - S.PrimTyConTetraU -> C.TyConTetraU diff --git a/DDC/Source/Tetra/Convert/Base.hs b/DDC/Source/Tetra/Convert/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Source/Tetra/Convert/Base.hs @@ -0,0 +1,21 @@ + +module DDC.Source.Tetra.Convert.Base + ( ConvertM + , SP + + , module DDC.Type.Universe + , module DDC.Source.Tetra.Convert.Error + , module DDC.Data.SourcePos) +where +import DDC.Type.Universe +import DDC.Source.Tetra.Convert.Error +import DDC.Data.SourcePos + + +type ConvertM a x + = Either (ErrorConvert a) x + + +type SP = SourcePos + + diff --git a/DDC/Source/Tetra/Convert/Clause.hs b/DDC/Source/Tetra/Convert/Clause.hs new file mode 100644 --- /dev/null +++ b/DDC/Source/Tetra/Convert/Clause.hs @@ -0,0 +1,99 @@ + +module DDC.Source.Tetra.Convert.Clause + ( collectSigsFromClauses + , collectBoundVarsFromClauses + , makeBindingFromClause) +where +import DDC.Source.Tetra.Convert.Error +import DDC.Source.Tetra.Convert.Base +import qualified DDC.Source.Tetra.Exp as S + + +-- | Collect type signatures defined in a clause group. +collectSigsFromClauses :: [S.Clause] -> [(S.BindVar, S.Type)] +collectSigsFromClauses cls + = go cls + where go (S.SSig _ b t : cls') + = (b, t) : go cls' + go (_ : cls') = go cls' + go [] = [] + + +-- | Collect binders for values defined in a clause group. +collectBoundVarsFromClauses :: [S.Clause] -> [S.BindVar] +collectBoundVarsFromClauses cls + = go cls + where go (S.SLet _ (S.XBindVarMT b _) _ _ : cls') + = b : go cls' + go (_ : cls') = go cls' + go [] = [] + + +-- | Strip a let-binding from a clause. +makeBindingFromClause + :: [(S.BindVar, S.Type)] -- ^ Type signatures in the same group. + -> [ S.BindVar ] -- ^ Bound values defined in the same group. + -> S.Clause -- ^ Clause to consider. + -> ConvertM S.Source + (Maybe (S.BindVarMT, (SP, S.Exp))) + -- ^ Let-bindings with attached signatures. +makeBindingFromClause sigs vals cc + = case cc of + S.SLet sp bm@(S.XBindVarMT b mtHas) ps [S.GExp x] + -- See if there was a type signature specified in the same group. + | Just tSig <- lookup b sigs + -> case mtHas of + -- If the binder was already directly annotated with a signature + -- then throw an error, as it might conflict with the separate + -- signature provided in the same group. + Just _ -> Left $ ErrorMultipleSignatures sp b + + -- The binder was not directly annotated, + -- so attach the provided signature. + Nothing + -> case wrapParams ps x of + Nothing -> Left $ ErrorConvertSugaredClause cc + Just x' -> return $ Just $ ( S.XBindVarMT b (Just tSig), (sp, x')) + + -- We don't have a separate signature for this binding. + | otherwise + -> case wrapParams ps x of + Nothing -> Left $ ErrorConvertSugaredClause cc + Just x' -> return $ Just $ (bm, (sp, x')) + + -- Some let binding with an expression that should have + -- been desugared earlier. + S.SLet{} -> Left $ ErrorConvertSugaredClause cc + + -- Check that signatures in the clause group have associated bindings. + -- If we find a signature without a binding then one or + -- the other is probably mis-spelled. + S.SSig sp b _ + | elem b vals -> return Nothing + | otherwise -> Left $ ErrorTypeSignatureLacksBinding sp b + + +-- | Wrap an expression with lambda abstractions for each +-- of the given parameters. +wrapParams :: [S.Param] -> S.Exp -> Maybe S.Exp +wrapParams [] x + = pure x + +wrapParams (p:ps) x + = case p of + S.MType b mt + -> S.XLAM (S.XBindVarMT b mt) <$> wrapParams ps x + + S.MWitness b mt + -> S.XLam (S.XBindVarMT b mt) <$> wrapParams ps x + + S.MValue S.PDefault mt + -> S.XLam (S.XBindVarMT S.BNone mt) <$> wrapParams ps x + + S.MValue (S.PVar b) mt + -> S.XLam (S.XBindVarMT b mt) <$> wrapParams ps x + + -- Some pattern that should have been desugared earlier. + S.MValue _ _ + -> Nothing + diff --git a/DDC/Source/Tetra/Convert/Error.hs b/DDC/Source/Tetra/Convert/Error.hs --- a/DDC/Source/Tetra/Convert/Error.hs +++ b/DDC/Source/Tetra/Convert/Error.hs @@ -1,27 +1,53 @@ - +{-# LANGUAGE UndecidableInstances #-} module DDC.Source.Tetra.Convert.Error (ErrorConvert (..)) where +import DDC.Data.SourcePos import DDC.Source.Tetra.Pretty -import qualified DDC.Source.Tetra.Exp.Annot as S +import DDC.Source.Tetra.Exp.Generic -data ErrorConvert a - -- | Cannot convert sugar expression to core. - = ErrorConvertCannotConvertSugarExp (S.Exp a) +-- | Things that can go wrong when converting source to core. +data ErrorConvert l + -- | Cannot convert sugared expression to core. + -- This should have been desugared in a prior pass. + = ErrorConvertSugaredExp (GExp l) - -- | Cannot convert sugar let bindings to core. - | ErrorConvertCannotConvertSugarLets (S.Lets a) + -- | Cannot convert sugared let bindings to core. + -- This should have been desugared in a prior pass. + | ErrorConvertSugaredLets (GLets l) + -- | Cannot convert sugared clause to core. + -- This should have been desugared in a prior pass. + | ErrorConvertSugaredClause (GClause l) -instance Pretty a => Pretty (ErrorConvert a) where - ppr err - = case err of - ErrorConvertCannotConvertSugarExp xx - -> vcat [ text "Cannot desugar expression" - , indent 2 $ ppr xx ] + -- | Found multiple type signatures for the same binder. + -- This should have been desugared in a prior pass. + | ErrorMultipleSignatures SourcePos (GXBindVar l) - ErrorConvertCannotConvertSugarLets xx - -> vcat [ text "Cannot desugar let-bindings" - , indent 2 $ ppr xx ] + -- | Type signature lacks associated value-level binding. + | ErrorTypeSignatureLacksBinding SourcePos (GXBindVar l) + +instance (PrettyLanguage l) => Pretty (ErrorConvert l) where + ppr = pprError + +pprError (ErrorConvertSugaredExp xx) + = vcat [ text "Cannot convert sugared expression" + , indent 2 $ ppr xx ] + +pprError (ErrorConvertSugaredLets xx) + = vcat [ text "Cannot convert sugared let-bindings" + , indent 2 $ ppr xx ] + +pprError (ErrorConvertSugaredClause l) + = vcat [ text "Cannot convert sugared let-bindings" + , indent 2 $ ppr l ] + +pprError (ErrorMultipleSignatures sp b) + = vcat [ ppr sp + , text "Multiple type signatures specified for " <> ppr b ] + +pprError (ErrorTypeSignatureLacksBinding sp b) + = vcat [ ppr sp + , text "Type signature lacks associated binding " <> ppr b] diff --git a/DDC/Source/Tetra/Convert/Prim.hs b/DDC/Source/Tetra/Convert/Prim.hs new file mode 100644 --- /dev/null +++ b/DDC/Source/Tetra/Convert/Prim.hs @@ -0,0 +1,45 @@ + +module DDC.Source.Tetra.Convert.Prim + ( toCoreTyConTetra + , toCorePrimVal + , toCorePrimLit) +where +import qualified DDC.Core.Tetra.Prim as C +import qualified DDC.Source.Tetra.Prim as S + + +-- | Convert a Tetra specific type constructor to core. +toCoreTyConTetra :: S.PrimTyConTetra -> C.TyConTetra +toCoreTyConTetra tc + = case tc of + S.PrimTyConTetraTuple n -> C.TyConTetraTuple n + S.PrimTyConTetraVector -> C.TyConTetraVector + S.PrimTyConTetraF -> C.TyConTetraF + S.PrimTyConTetraC -> C.TyConTetraC + S.PrimTyConTetraU -> C.TyConTetraU + + +-- | Convert a value primtivie to a core name. +toCorePrimVal :: S.PrimVal -> C.Name +toCorePrimVal pv + = case pv of + S.PrimValArith p -> C.NamePrimArith p False + S.PrimValCast p -> C.NamePrimCast p False + S.PrimValError p -> C.NameOpError p False + S.PrimValVector p -> C.NameOpVector p False + S.PrimValFun p -> C.NameOpFun p + S.PrimValLit p -> toCorePrimLit p + + +-- | Convert a primitive literal to a core name. +toCorePrimLit :: S.PrimLit -> C.Name +toCorePrimLit pl + = case pl of + S.PrimLitBool x -> C.NameLitBool x + S.PrimLitNat x -> C.NameLitNat x + S.PrimLitInt x -> C.NameLitInt x + S.PrimLitSize x -> C.NameLitSize x + S.PrimLitWord x s -> C.NameLitWord x s + S.PrimLitFloat x s -> C.NameLitFloat x s + S.PrimLitChar x -> C.NameLitChar x + S.PrimLitTextLit x -> C.NameLitTextLit x diff --git a/DDC/Source/Tetra/Convert/Type.hs b/DDC/Source/Tetra/Convert/Type.hs new file mode 100644 --- /dev/null +++ b/DDC/Source/Tetra/Convert/Type.hs @@ -0,0 +1,241 @@ + +module DDC.Source.Tetra.Convert.Type + ( toCoreTypeDef + + , toCoreT + , toCoreTC + + , toCoreTBCN, toCoreTUCN + , toCoreXUVN, toCoreXBVN + + , toCoreTBK + + , toCoreB, toCoreBM + , toCoreU + , toCoreDaConBind + , toCoreDaConBound) +where +import DDC.Source.Tetra.Convert.Prim +import DDC.Source.Tetra.Convert.Base +import DDC.Type.Universe (Universe (..), universeUp) + +import qualified DDC.Source.Tetra.Exp as S +import qualified DDC.Source.Tetra.Prim as S + +import qualified DDC.Core.Tetra.Compounds as C +import qualified DDC.Core.Tetra.Prim as C +import qualified DDC.Type.Sum as CSum +import qualified Data.Text as Text + + +-- TypeDef ---------------------------------------------------------------------------------------- +toCoreTypeDef + :: (S.TyConBind, S.Type) + -> ConvertM a (C.Name, (C.Kind C.Name, C.Type C.Name)) + +toCoreTypeDef (b, t) + = do n <- toCoreTBCN b + t' <- toCoreT UniverseSpec t + let hole = C.TVar (C.UName C.NameHole) + return (n, (hole, t')) + + +-- Type ------------------------------------------------------------------------------------------- +toCoreT :: Universe -> S.Type -> ConvertM a (C.Type C.Name) +toCoreT uu tt + = case tt of + S.TAnnot _ t + -> toCoreT uu t + + S.TCon (S.TyConBot k) + -> do k' <- toCoreT uu k + return $ C.tBot k' + + S.TCon (S.TyConVoid) + -> do return $ C.tVoid + + S.TCon tc + -> do mtc' <- toCoreTC uu tc + case mtc' of + Nothing -> error $ "ddc-soure-tetra.toCoreT: " ++ show tt + Just tc' -> return $ C.TCon tc' + + S.TVar u + -> C.TVar <$> toCoreU u + + S.TAbs b k t + -> do b' <- toCoreTBK (b, k) + t' <- toCoreT uu t + return $ C.TAbs b' t' + + S.TApp (S.TCon (S.TyConForall _)) (S.TAbs b k t) + -> let uu' = universeUp uu + in C.TForall <$> toCoreBM uu' (S.XBindVarMT b (Just k)) <*> toCoreT uu t + + S.TApp{} + | Just (k, ts) <- S.takeTUnions tt + -> do let uu' = universeUp uu + k' <- toCoreT uu' k + ts' <- sequence $ fmap (toCoreT uu) ts + return $ C.TSum (CSum.fromList k' ts') + + S.TApp t1 t2 + -> C.TApp <$> toCoreT uu t1 <*> toCoreT uu t2 + + + +-- TyCon ------------------------------------------------------------------------------------------ +-- | Convert a Source TyCon to Core, or Nothing if it cannot be converted in isolation. +toCoreTC :: Universe -> S.TyCon -> ConvertM a (Maybe (C.TyCon C.Name)) +toCoreTC uu tc + = case tc of + S.TyConVoid -> return Nothing + S.TyConUnit -> return $ Just $ C.TyConSpec C.TcConUnit + + S.TyConFun + -> case uu of + UniverseSpec -> return $ Just $ C.TyConSpec C.TcConFun + UniverseKind -> return $ Just $ C.TyConKind C.KiConFun + _ -> return Nothing + + + S.TyConUnion _ -> return Nothing + + S.TyConBot _k -> return Nothing + S.TyConForall _k -> return Nothing + S.TyConExists _k -> return Nothing + + -- Primitive type constructors. + S.TyConPrim pt + -> case pt of + -- Ambient TyCons + S.PrimTypeSoCon sc -> return $ Just $ C.TyConSort sc + S.PrimTypeKiCon kc -> return $ Just $ C.TyConKind kc + S.PrimTypeTwCon tw -> return $ Just $ C.TyConWitness tw + S.PrimTypeTcCon ts -> return $ Just $ C.TyConSpec ts + + -- Primitive TyCons + S.PrimTypeTyCon tcy + -> do k <- toCoreT UniverseKind $ S.kindPrimTyCon tcy + return $ Just $ C.TyConBound (C.UPrim (C.NamePrimTyCon tcy) k) k + + S.PrimTypeTyConTetra tct + -> do k <- toCoreT UniverseKind $ S.kindPrimTyConTetra tct + let tct' = toCoreTyConTetra tct + return $ Just $ C.TyConBound (C.UPrim (C.NameTyConTetra tct') k) k + + -- Bound type constructors. + -- The embedded kind is set to Bot. We rely on the spreader + -- to fill in the real kind before type checking. + S.TyConBound (S.TyConBoundName tx) + -> return $ Just + $ C.TyConBound (C.UName (C.NameCon (Text.unpack tx))) + (C.TVar (C.UName C.NameHole)) + + +-- Bind ------------------------------------------------------------------------------------------- +-- | Convert a type constructor binding occurrence to a core name. +toCoreTBCN :: S.GTBindCon S.Source -> ConvertM a C.Name +toCoreTBCN (S.TyConBindName n) + = return $ C.NameCon (Text.unpack n) + + +-- | Convert a type constructor bound occurrence to a core name. +toCoreTUCN :: S.GTBoundCon S.Source -> ConvertM a C.Name +toCoreTUCN (S.TyConBoundName n) + = return $ C.NameCon (Text.unpack n) + + +-- | Convert a term variable bound occurrence to a core name. +toCoreXUVN :: S.Bound -> ConvertM a C.Name +toCoreXUVN uu + = case uu of + S.UName n -> return $ C.NameVar (Text.unpack n) + S.UIx _i -> error "ddc-source-tetra.toCoreXBVN: anon bound" + S.UHole -> return $ C.NameHole + + +toCoreXBVN :: S.GTBindVar S.Source -> ConvertM a C.Name +toCoreXBVN bb + = case bb of + S.BNone -> error "ddc-source-tetra.toCoreXBVN: none bound" + S.BAnon -> error "ddc-source-tetra.toCoreXBVN: anon bound" + S.BName n -> return $ C.NameVar (Text.unpack n) + + +-- | Convert a type binder and kind to core. +toCoreTBK :: (S.GTBindVar S.Source, S.GType S.Source) + -> ConvertM a (C.Bind C.Name) +toCoreTBK (bb, k) + = case bb of + S.BNone -> C.BNone <$> (toCoreT UniverseKind k) + S.BAnon -> C.BAnon <$> (toCoreT UniverseKind k) + S.BName n -> C.BName <$> (return $ C.NameVar (Text.unpack n)) + <*> (toCoreT UniverseKind k) + + +-- | Convert an unannoted binder to core. +toCoreB :: S.Bind -> ConvertM a (C.Bind C.Name) +toCoreB bb + = let hole = C.TVar (C.UName C.NameHole) + in case bb of + S.BNone -> return $ C.BNone hole + S.BAnon -> return $ C.BAnon hole + S.BName n -> return $ C.BName (C.NameVar (Text.unpack n)) hole + + +-- | Convert a possibly annoted binding occurrence of a variable to core. +toCoreBM :: Universe -> S.GXBindVarMT S.Source -> ConvertM a (C.Bind C.Name) +toCoreBM uu bb + = case bb of + S.XBindVarMT S.BNone (Just t) + -> C.BNone <$> toCoreT uu t + + S.XBindVarMT S.BNone Nothing + -> C.BNone <$> (return $ C.TVar (C.UName C.NameHole)) + + + S.XBindVarMT S.BAnon (Just t) + -> C.BAnon <$> toCoreT uu t + + S.XBindVarMT S.BAnon Nothing + -> C.BAnon <$> (return $ C.TVar (C.UName C.NameHole)) + + + S.XBindVarMT (S.BName n) (Just t) + -> C.BName <$> (return $ C.NameVar (Text.unpack n)) + <*> toCoreT uu t + + S.XBindVarMT (S.BName n) Nothing + -> C.BName <$> (return $ C.NameVar (Text.unpack n)) + <*> (return $ C.TVar (C.UName C.NameHole)) + + +-- Bound ------------------------------------------------------------------------------------------ +toCoreU :: S.Bound -> ConvertM a (C.Bound C.Name) +toCoreU uu + = case uu of + S.UName n -> C.UName <$> pure (C.NameVar (Text.unpack n)) + S.UIx i -> C.UIx <$> (pure i) + S.UHole -> C.UName <$> pure (C.NameHole) + + +-- Name ------------------------------------------------------------------------------------------- +-- | Convert a binding occurrences of a data constructor to a core name. +toCoreDaConBind :: S.DaConBind -> C.Name +toCoreDaConBind (S.DaConBindName tx) + = C.NameCon (Text.unpack tx) + + +-- | Convert a bound occurrence of a data constructor to a core name. +toCoreDaConBound :: S.DaConBound -> C.Name +toCoreDaConBound dcb + = case dcb of + S.DaConBoundName tx + -> C.NameCon (Text.unpack tx) + + S.DaConBoundLit pl + -> toCorePrimLit pl + + + diff --git a/DDC/Source/Tetra/Convert/Witness.hs b/DDC/Source/Tetra/Convert/Witness.hs new file mode 100644 --- /dev/null +++ b/DDC/Source/Tetra/Convert/Witness.hs @@ -0,0 +1,41 @@ + +module DDC.Source.Tetra.Convert.Witness + ( toCoreW + , toCoreWC) +where +import DDC.Source.Tetra.Convert.Type +import DDC.Source.Tetra.Convert.Base + +import qualified DDC.Source.Tetra.Exp as S + +import qualified DDC.Core.Tetra.Prim as C +import qualified DDC.Core.Exp.Annot as C + + + +toCoreW :: SP -> S.Witness -> ConvertM a (C.Witness SP C.Name) +toCoreW a ww + = case ww of + S.WAnnot a' w + -> toCoreW a' w + + S.WVar u + -> C.WVar <$> pure a <*> toCoreU u + + S.WCon wc + -> C.WCon <$> pure a <*> toCoreWC wc + + S.WApp w1 w2 + -> C.WApp <$> pure a <*> toCoreW a w1 <*> toCoreW a w2 + + S.WType t + -> C.WType <$> pure a <*> toCoreT UniverseSpec t + + +toCoreWC :: S.WiCon -> ConvertM a (C.WiCon C.Name) +toCoreWC wc + = case wc of + S.WiConBound u t + -> C.WiConBound <$> toCoreU u + <*> toCoreT UniverseSpec t + diff --git a/DDC/Source/Tetra/DataDef.hs b/DDC/Source/Tetra/DataDef.hs --- a/DDC/Source/Tetra/DataDef.hs +++ b/DDC/Source/Tetra/DataDef.hs @@ -1,72 +1,82 @@ +{-# LANGUAGE TypeFamilies, UndecidableInstances #-} -- | Source Tetra data type definitions. module DDC.Source.Tetra.DataDef ( -- * Data Type Definition. DataDef (..) - , typeEnvOfDataDef + , envOfDataDef -- * Data Constructor Definition. , DataCtor (..) , typeOfDataCtor) where -import DDC.Type.Compounds -import DDC.Type.Exp -import DDC.Type.Env (TypeEnv) -import qualified DDC.Type.Env as Env +import DDC.Source.Tetra.Exp.Generic +import DDC.Source.Tetra.Exp.Source +import DDC.Source.Tetra.Env (Env) +import qualified DDC.Source.Tetra.Env as Env import Control.DeepSeq -- DataDef -------------------------------------------------------------------- -- | Data type definitions. -data DataDef n +data DataDef l = DataDef { -- | Data type name. - dataDefTypeName :: !n + dataDefTypeName :: !(GTBindCon l) - -- | Type parameters. - , dataDefParams :: [Bind n] + -- | Type parameters and their kinds. + , dataDefParams :: [(GTBindVar l, GType l)] -- | Parameters and return type of each constructor. - , dataDefCtors :: [DataCtor n] } - deriving Show + , dataDefCtors :: [DataCtor l] } +deriving instance (ShowLanguage l, Show (DataCtor l)) + => Show (DataDef l) instance NFData (DataDef n) where rnf !_ = () -- | Take the types of data constructors from a data type definition. -typeEnvOfDataDef :: Ord n => DataDef n -> TypeEnv n -typeEnvOfDataDef def - = Env.fromList - [BName (dataCtorName ctor) - (typeOfDataCtor def ctor) - | ctor <- dataDefCtors def ] - +envOfDataDef + :: DataDef Source -> Env +envOfDataDef def + = Env.unions + $ [Env.singletonDaCon (dataCtorName ctor) (typeOfDataCtor def ctor) + | ctor <- dataDefCtors def] + + -- DataCtor ------------------------------------------------------------------- -- | A data type constructor definition. -data DataCtor n +data DataCtor l = DataCtor { -- | Name of the data constructor. - dataCtorName :: !n + dataCtorName :: !(GXBindCon l) -- | Types of each of the fields of the constructor. - , dataCtorFieldTypes :: ![Type n] + , dataCtorFieldTypes :: ![GType l] -- | Result type of the constructor. - , dataCtorResultType :: !(Type n) } - deriving Show + , dataCtorResultType :: !(GType l) } +deriving instance (ShowLanguage l) + => Show (DataCtor l) + + instance NFData (DataCtor n) where rnf !_ = () -- | Get the type of a data constructor. -typeOfDataCtor :: DataDef n -> DataCtor n -> Type n +typeOfDataCtor :: DataDef l -> DataCtor l -> GType l typeOfDataCtor def ctor - = foldr TForall - (foldr tFun (dataCtorResultType ctor) + = foldr (\(b, k) t -> TApp (TCon (TyConForall k)) (TAbs b k t)) + (foldr TFun (dataCtorResultType ctor) (dataCtorFieldTypes ctor)) (dataDefParams def) + + + + diff --git a/DDC/Source/Tetra/Env.hs b/DDC/Source/Tetra/Env.hs --- a/DDC/Source/Tetra/Env.hs +++ b/DDC/Source/Tetra/Env.hs @@ -1,86 +1,326 @@ -- | Source Tetra primitive type and kind environments. module DDC.Source.Tetra.Env - ( -- * Primitive kind environment. - primKindEnv - , kindOfPrimName + ( Env (..) - -- * Primitive type environment. - , primTypeEnv - , typeOfPrimName - , typeOfPrimVal - , typeOfPrimLit + , Presence (..) + , takePresent - , dataDefBool) + , empty + , union, unions + + -- ** Type Variables + , singletonTyVar, singletonTyVar' + , extendTyVar + , extendTyVar', extendsTyVar' + , lookupTyVar + , tyStackDepth + + -- ** Data Constructors + , singletonDaCon + , extendDaCon + , lookupDaCon + + -- ** Term Variables + , singletonDaVar + , singletonDaVar' + , extendDaVar, extendsDaVar + , extendDaVar' + , extendDaVarMT, extendsDaVarMT + , lookupDaVar + , daStackDepth + + -- * Primitive Kinds and Types. + , kindOfPrimType + , typeOfPrimVal + , typeOfPrimLit) where import DDC.Source.Tetra.Prim -import DDC.Source.Tetra.Exp -import DDC.Type.DataDef -import DDC.Type.Env (Env) -import qualified DDC.Type.Env as Env +import DDC.Source.Tetra.Exp.Source +import Data.Map (Map) +import Data.Sequence (Seq) +import Data.Text (Text) +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import qualified Data.Sequence as Seq --- Kinds ---------------------------------------------------------------------- --- | Kind environment containing kinds of primitive data types. -primKindEnv :: Env Name -primKindEnv = Env.setPrimFun kindOfPrimName Env.empty +--------------------------------------------------------------------------------------------------- +data Env + = Env + { -- | Map names of type constructors to their kinds. + envTyCon :: Map Text Type + -- | Map names of variables to their kinds. + , envTyVar :: Map Text (Maybe Type) --- | Take the kind of a primitive name. --- --- Returns `Nothing` if the name isn't primitive. --- -kindOfPrimName :: Name -> Maybe (Kind Name) -kindOfPrimName nn - = case nn of - NameTyCon tc -> Just $ kindPrimTyCon tc - _ -> Nothing + -- | Stack of kinds of deBruijn indexed type variables. + , envTyStack :: Seq (Maybe Type) + + -- | Map names of data constructors to their types. + , envDaCon :: Map Text Type + -- | Map names of term variables to their types. + , envDaVar :: Map Text (Maybe Type) --- Types ---------------------------------------------------------------------- --- | Type environment containing types of primitive operators. -primTypeEnv :: Env Name -primTypeEnv = Env.setPrimFun typeOfPrimName Env.empty + -- | Stack of types of deBruijn indexed term variables. + , envDaStack :: Seq (Maybe Type) } --- | Take the type of a name, --- or `Nothing` if this is not a value name. -typeOfPrimName :: Name -> Maybe (Type Name) -typeOfPrimName nn - = case nn of - NameVal n -> Just $ typeOfPrimVal n - _ -> Nothing +-- | Presence of a variable in the environment. +data Presence a + -- | Variable is not present in environment. + = Absent + -- | Variable is present but we don't have a type for it. + | Unknown + -- | Variable is present in the environment with this information. + | Present a + deriving Show + + +-- | Yield `Just` for a `Present` and `Nothing` for the others. +takePresent :: Presence a -> Maybe a +takePresent pp + = case pp of + Absent -> Nothing + Unknown -> Nothing + Present x -> Just x + + +-- | An empty environment. +empty :: Env +empty + = Env + { envTyCon = Map.empty + , envTyVar = Map.empty + , envTyStack = Seq.empty + , envDaCon = Map.empty + , envDaVar = Map.empty + , envDaStack = Seq.empty } + + +-- | Take the right biased union of two environments. +union :: Env -> Env -> Env +union env1 env2 + = Env + { envTyCon = Map.union (envTyCon env1) (envTyCon env2) + , envTyVar = Map.union (envTyVar env1) (envTyVar env2) + , envTyStack = envTyStack env1 Seq.>< envTyStack env2 + + , envDaCon = Map.union (envDaCon env1) (envDaCon env2) + , envDaVar = Map.union (envDaVar env1) (envDaVar env2) + , envDaStack = envDaStack env1 Seq.>< envDaStack env2 } + + +-- | Take the right biased union of a list of type environments. +unions :: [Env] -> Env +unions envs + = List.foldl' union empty envs + + +--------------------------------------------------------------------------------------------------- +-- | Extend the environment with the kind for a type variable. +extendTyVar :: Bind -> Type -> Env -> Env +extendTyVar b k env + = case b of + BNone -> env + BAnon -> env { envTyStack = (envTyStack env) Seq.|> (Just k) } + BName n -> env { envTyVar = Map.insert n (Just k) (envTyVar env) } + + +-- | Extend the environment with a type variable where we don't know its kind. +extendTyVar' :: Bind -> Env -> Env +extendTyVar' b env + = case b of + BNone -> env + BAnon -> env { envTyStack = (envTyStack env) Seq.|> Nothing } + BName n -> env { envTyVar = Map.insert n Nothing (envTyVar env) } + + +-- | Extend the environment with some type variables where we don't know their kinds. +extendsTyVar' :: [Bind] -> Env -> Env +extendsTyVar' bs env + = List.foldl' (flip extendTyVar') env bs + + +-- | Yield an environment containing a single type variable. +singletonTyVar' :: Bind -> Env +singletonTyVar' b + = extendTyVar' b empty + +-- | Yield an environment containing the kind for a single type variable. +singletonTyVar :: Bind -> Type -> Env +singletonTyVar b t + = extendTyVar b t empty + + + +-- | Lookup the kind of the given type variable. +lookupTyVar :: Env -> Bound -> Presence Type +lookupTyVar env u + = case u of + UName tx + -> case Map.lookup tx (envTyVar env) of + Nothing -> Absent + Just Nothing -> Unknown + Just (Just t) -> Present t + + UIx i + | i >= Seq.length (envTyStack env) + -> Absent + + | otherwise + -> case Seq.index (envTyStack env) i of + Nothing -> Unknown + Just t -> Present t + + UHole + -> Unknown + + +-- | Get the depth of the type stack. +tyStackDepth :: Env -> Int +tyStackDepth env = Seq.length (envTyStack env) + + +--------------------------------------------------------------------------------------------------- +-- | Extend the environment with the type of a data constructor. +extendDaCon :: DaConBind -> Type -> Env -> Env +extendDaCon (DaConBindName tx) t env + = env { envDaCon = Map.insert tx t (envDaCon env) } + + +-- | Yield an environment containing the type of a single data constructor. +singletonDaCon :: DaConBind -> Type -> Env +singletonDaCon dc t + = extendDaCon dc t empty + + +-- | Lookup the type of a data constructor. +lookupDaCon :: DaConBound -> Env -> Maybe Type +lookupDaCon dc env + = case dc of + DaConBoundName tx -> Map.lookup tx (envDaCon env) + DaConBoundLit lit -> Just (typeOfPrimLit lit) + + +--------------------------------------------------------------------------------------------------- +-- | Extend the environment with the type of a term variable. +extendDaVar :: Bind -> Type -> Env -> Env +extendDaVar b t env + = case b of + BNone -> env + BAnon -> env { envDaStack = (envDaStack env) Seq.|> (Just t) } + BName n -> env { envDaVar = Map.insert n (Just t) (envDaVar env) } + + +-- | Extend the environment with the types of some term variables. +extendsDaVar :: [(Bind, Type)] -> Env -> Env +extendsDaVar bxs env + = List.foldl' (\env' (b, t) -> extendDaVar b t env') env bxs + + +-- | Extend the environment with a term variable where we don't know it's type. +extendDaVar' :: Bind -> Env -> Env +extendDaVar' b env + = case b of + BNone -> env + BAnon -> env { envDaStack = (envDaStack env) Seq.|> Nothing } + BName n -> env { envDaVar = Map.insert n Nothing (envDaVar env) } + + +-- | Like `extendDaVar` but take a `BindVarMT` +extendDaVarMT :: BindVarMT -> Env -> Env +extendDaVarMT xb env + = case xb of + XBindVarMT b Nothing -> extendDaVar' b env + XBindVarMT b (Just t) -> extendDaVar b t env + + +-- | Like `extendDaVarMT` but take a list of `BindVarMT` +extendsDaVarMT :: [BindVarMT] -> Env -> Env +extendsDaVarMT bs env + = List.foldl' (flip extendDaVarMT) env bs + + +-- | Yield an environment containing the type for a single term variable. +singletonDaVar :: Bind -> Type -> Env +singletonDaVar b t + = extendDaVar b t empty + + +-- | Yield an environment containing a single term variable where we don't know its type. +singletonDaVar' :: Bind -> Env +singletonDaVar' b + = extendDaVar' b empty + + +-- | Lookup the kind of the given type variable. +lookupDaVar :: Env -> Bound -> Presence Type +lookupDaVar env u + = case u of + UName tx + -> case Map.lookup tx (envDaVar env) of + Nothing -> Absent + Just Nothing -> Unknown + Just (Just t) -> Present t + + UIx i + | i >= Seq.length (envDaStack env) + -> Absent + + | otherwise + -> case Seq.index (envDaStack env) i of + Nothing -> Unknown + Just t -> Present t + + UHole + -> Unknown + + +-- | Get the depth of the type stack. +daStackDepth :: Env -> Int +daStackDepth env = Seq.length (envDaStack env) + + +--------------------------------------------------------------------------------------------------- +-- | Take the kind of a primitive type. +kindOfPrimType :: PrimType -> Maybe Type +kindOfPrimType tt + = case tt of + PrimTypeSoCon _ -> Nothing + PrimTypeKiCon _ -> Nothing + PrimTypeTwCon _ -> Nothing + PrimTypeTcCon _ -> Nothing + PrimTypeTyCon tc -> Just (kindPrimTyCon tc) + PrimTypeTyConTetra tc -> Just (kindPrimTyConTetra tc) + + -- | Take the type of a primitive name. -typeOfPrimVal :: PrimVal -> Type Name +typeOfPrimVal :: PrimVal -> Type typeOfPrimVal dc = case dc of - PrimValLit l -> typeOfPrimLit l - PrimValArith p -> typePrimArith p - PrimValError p -> typeOpError p - PrimValVector p -> typeOpVector p - PrimValFun p -> typeOpFun p + PrimValLit l -> typeOfPrimLit l + PrimValArith p -> typePrimArith Source p + PrimValCast p -> typePrimCast Source p + PrimValError p -> typeOpError Source p + PrimValVector p -> typeOpVector Source p + PrimValFun p -> typeOpFun Source p -- | Take the type of a primitive literal. -typeOfPrimLit :: PrimLit -> Type Name +typeOfPrimLit :: PrimLit -> Type typeOfPrimLit pl = case pl of - PrimLitBool _ -> tBool - PrimLitNat _ -> tNat - PrimLitInt _ -> tInt - PrimLitSize _ -> tSize - PrimLitFloat _ bits -> tFloat bits - PrimLitWord _ bits -> tWord bits - PrimLitTextLit _ -> tTextLit - + PrimLitBool _ -> TBool + PrimLitNat _ -> TNat + PrimLitInt _ -> TInt + PrimLitSize _ -> TSize + PrimLitFloat _ bits -> TFloat bits + PrimLitWord _ bits -> TWord bits + PrimLitChar _ -> TWord 32 + PrimLitTextLit _ -> TTextLit --- | Data type definition for `Bool`. -dataDefBool :: DataDef Name -dataDefBool - = makeDataDefAlg (NameTyCon PrimTyConBool) - [] - (Just [ (NameLitBool True, []) - , (NameLitBool False, []) ]) diff --git a/DDC/Source/Tetra/Exp.hs b/DDC/Source/Tetra/Exp.hs --- a/DDC/Source/Tetra/Exp.hs +++ b/DDC/Source/Tetra/Exp.hs @@ -1,31 +1,246 @@ --- | Definition of Source Tetra Expressions. +-- | Definition of Source Tetra Abstract Syntax, +-- and utilities for working with it. module DDC.Source.Tetra.Exp - ( module DDC.Type.Exp + ( -- * Binding + Name + , Bind (..) + , Bound (..) + , takeBoundOfBind - -- * Expressions - , GName - , GAnnot - , GBind - , GBound - , GPrim - , GExp (..) - , GLets (..) - , GAlt (..) - , GPat (..) - , GClause (..) - , GGuardedExp (..) - , GGuard (..) - , GCast (..) - , DaCon (..) + ------------------------------------------------- + -- * Types - -- * Witnesses - , GWitness (..) - , GWiCon (..) + ----------------------------- + -- ** Syntax + -- *** Expressions + , Type, GType (..) + -- *** TyCons + , TyCon, GTyCon (..) + , TyConBind (..) + , TyConBound (..) + + ----------------------------- + -- ** Type Generics + , Source (..) + , GTAnnot + , GTBindVar, GTBoundVar + , GTBindCon, GTBoundCon + , GTPrim + + ----------------------------- + -- ** Type Constructors + , SoCon (..) + , KiCon (..) + , TwCon (..) + , TcCon (..) + + ----------------------------- + -- ** Type Primitives + , PrimType (..) + , PrimTyCon (..) + , PrimTyConTetra (..) + + ----------------------------- + -- ** Pattern Synonyms + , pattern TApp2, pattern TApp3 + , pattern TApp4, pattern TApp5 + + , pattern TVoid, pattern TUnit + , pattern TFun + , pattern TBot, pattern TUnion + , pattern TPrim + + , pattern KData, pattern KRegion, pattern KEffect + , pattern TImpl + , pattern TSusp + , pattern TRead, pattern TWrite, pattern TAlloc + + , pattern TBool + , pattern TNat, pattern TInt + , pattern TSize, pattern TWord + , pattern TFloat + , pattern TTextLit + + ----------------------------- + -- ** Predicates + , isAtomT + + ----------------------------- + -- ** Compounds + , -- *** Destructors + takeTCon + , takeTVar + , takeTAbs + , takeTApp + + -- *** Type Applications + , makeTApps, takeTApps + + -- *** Function Types + , makeTFun, makeTFuns, makeTFuns', (~>) + , takeTFun, takeTFuns, takeTFuns' + + -- *** Forall Types + , makeTForall, makeTForalls + , takeTForall + + -- *** Exists Types + , makeTExists, takeTExists + + -- *** Union types + , takeTUnion + , makeTUnions, takeTUnions + , splitTUnionsOfKind + , makeTBot + + ------------------------------------------------- + -- * Terms + -- ** Syntax + , Annot, GXAnnot + , BindVar, GXBindVar + , BindVarMT, GXBindVarMT (..) + , BoundVar, GXBoundVar + , BindCon, GXBindCon + , BoundCon, GXBoundCon + , Prim, GXPrim + + -- *** Expressions + , Exp, GExp (..) + + -- *** Let-binding + , Lets, GLets (..) + + -- *** Clauses + , Clause, GClause (..) + + -- *** Parameters + , Param, GParam (..) + + -- *** Patterns + , Pat, GPat (..) + + -- *** Guards + , Guard, GGuard (..) + + -- *** Guarded Expressions + , GuardedExp, GGuardedExp (..) + + -- *** Case Alternatives + , AltCase, GAltCase (..) + , AltMatch, GAltMatch (..) + + -- *** Casts + , Cast, GCast (..) + + -- *** Witnesses + , Witness, GWitness (..) + + -- *** Witness Constructors + , WiCon, GWiCon (..) + + -- *** Data Constructors + , DaCon (..) + , DaConBind (..) + , DaConBound (..) + + ----------------------------- + -- ** Term Primitives + , PrimVal (..) + , PrimArith (..) + , OpVector (..) + , OpFun (..) + , OpError (..) + , PrimLit (..) + + ----------------------------- + -- ** Pattern Synonyms + , pattern PTrue + , pattern PFalse + + ----------------------------- + -- ** Predicates + -- *** Atoms + , isXVar, isXCon + , isAtomX, isAtomW + + -- *** Lambdas + , isXLAM, isXLam + , isLambdaX + + -- *** Applications + , isXApp + + -- *** Let bindings + , isXLet + + -- *** Types and Witnesses + , isXType + , isXWitness + + -- *** Patterns + , isPDefault + + ----------------------------- + -- ** Compounds + , takeAnnotOfExp + + -- *** Binds + , bindOfBindMT + , takeTypeOfBindMT + + -- *** Lambdas + , makeXLAMs + , makeXLams + , makeXLamFlags + , takeXLAMs + , takeXLams + , takeXLamFlags + + -- *** Applications + , makeXApps + , makeXAppsWithAnnots + , takeXApps + , takeXApps1 + , takeXAppsAsList + , takeXAppsWithAnnots + , takeXConApps + , takeXPrimApps + + -- *** Clauses + , bindOfClause + + -- *** Casts + , pattern XRun + , pattern XBox + + -- *** Data Constructors + , dcUnit + , takeNameOfDaCon + , takeTypeOfDaCon + + -- *** Patterns + , bindsOfPat + + -- *** Witnesses + , wApp + , wApps + , takeXWitness + , takeWAppsAsList + , takePrimWiConApps + + ------------------------------------------------- -- * Dictionaries , ShowLanguage + , PrettyLanguage , NFDataLanguage) where -import DDC.Type.Exp -import DDC.Source.Tetra.Exp.Generic +import DDC.Source.Tetra.Exp.Bind +import DDC.Source.Tetra.Exp.Source +import DDC.Source.Tetra.Exp.Predicates +import DDC.Source.Tetra.Exp.Compounds +import DDC.Source.Tetra.Exp.NFData +import DDC.Source.Tetra.Pretty +import DDC.Type.Exp.Generic.Compounds + diff --git a/DDC/Source/Tetra/Exp/Annot.hs b/DDC/Source/Tetra/Exp/Annot.hs deleted file mode 100644 --- a/DDC/Source/Tetra/Exp/Annot.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module DDC.Source.Tetra.Exp.Annot - ( module DDC.Source.Tetra.Exp.Generic - , Annot - , HasAnonBind (..) - - -- * Expressions - , Name - , Bound - , Bind - , Exp - , Lets - , Alt - , Pat - , Clause - , GuardedExp - , Guard - , Cast - , DaCon (..) - - -- * Witnesses - , Witness - , WiCon) -where -import DDC.Source.Tetra.Exp.Generic -import DDC.Source.Tetra.Prim -import qualified DDC.Type.Exp as T - - --- | Type index for annotated expression type. -data Annot a - -instance HasAnonBind (Annot a) where - isAnon _ (T.BAnon _) = True - isAnon _ _ = False - -type instance GName (Annot a) = Name -type instance GAnnot (Annot a) = a -type instance GBind (Annot a) = T.Bind Name -type instance GBound (Annot a) = T.Bound Name -type instance GPrim (Annot a) = PrimVal - -type Bound = T.Bound Name -type Bind = T.Bind Name -type Exp a = GExp (Annot a) -type Lets a = GLets (Annot a) -type Alt a = GAlt (Annot a) -type Pat a = GPat (Annot a) -type Clause a = GClause (Annot a) -type GuardedExp a = GGuardedExp (Annot a) -type Guard a = GGuard (Annot a) -type Cast a = GCast (Annot a) -type Witness a = GWitness (Annot a) -type WiCon a = GWiCon (Annot a) diff --git a/DDC/Source/Tetra/Exp/Bind.hs b/DDC/Source/Tetra/Exp/Bind.hs new file mode 100644 --- /dev/null +++ b/DDC/Source/Tetra/Exp/Bind.hs @@ -0,0 +1,71 @@ + +module DDC.Source.Tetra.Exp.Bind + ( Name + , Bind (..) + , Bound (..) + , takeBoundOfBind + + , DaConBind (..) + , DaConBound (..) + , TyConBind (..) + , TyConBound (..)) +where +import DDC.Source.Tetra.Prim.Base +import Data.Text (Text) + +type Name = Text + +-- | Binding occurrence of a variable. +data Bind + = BNone + | BAnon + | BName !Text + deriving (Eq, Ord, Show) + + +-- | Bound occurrence of a variable. +data Bound + -- A named variable. + = UName !Text + + -- A deBruijn idex. + | UIx !Int + + -- A hole that we want the type checker to fill in. + | UHole + deriving (Eq, Ord, Show) + + +-- | Take the corresponding `Bound` of a `Bind`, if there is one. +takeBoundOfBind :: Bind -> Maybe Bound +takeBoundOfBind bb + = case bb of + BNone -> Nothing + BAnon -> Just $ UIx 0 + BName tx -> Just $ UName tx + + +-- | Binding occurrence of a data constructor. +data DaConBind + = DaConBindName Text + deriving (Eq, Ord, Show) + + +-- | Bound occurrences of a data constructor. +data DaConBound + = DaConBoundName Text + | DaConBoundLit PrimLit + deriving (Eq, Ord, Show) + + +-- | Binding occurrence of a type constructor. +data TyConBind + = TyConBindName Text + deriving (Eq, Ord, Show) + + +-- | Bound occurrence of a type constructor. +data TyConBound + = TyConBoundName Text + deriving (Eq, Ord, Show) + diff --git a/DDC/Source/Tetra/Exp/Compounds.hs b/DDC/Source/Tetra/Exp/Compounds.hs new file mode 100644 --- /dev/null +++ b/DDC/Source/Tetra/Exp/Compounds.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | Utilities for constructing and destructing Source Tetra expressions. +module DDC.Source.Tetra.Exp.Compounds + ( takeAnnotOfExp + + -- * Binds + , bindOfBindMT + , takeTypeOfBindMT + + -- * Types + -- ** Type Applications + , T.makeTApps, T.takeTApps + + -- ** Sum Types + , makeTBot + + -- ** Function Types + , T.makeTFun, T.makeTFuns, T.makeTFuns', (T.~>) + , T.takeTFun, T.takeTFuns, T.takeTFuns' + + -- ** Forall Types + , T.makeTForall, T.makeTForalls + , T.takeTForall + + -- ** Exists Types + , T.makeTExists, T.takeTExists + + -- ** Union types + , T.takeTUnion + , T.makeTUnions, T.takeTUnions + , T.splitTUnionsOfKind + + -- * Terms + -- ** Lambdas + , makeXLAMs + , makeXLams + , makeXLamFlags + , takeXLAMs + , takeXLams + , takeXLamFlags + + -- ** Applications + , makeXApps + , makeXAppsWithAnnots + , takeXApps + , takeXApps1 + , takeXAppsAsList + , takeXAppsWithAnnots + , takeXConApps + , takeXPrimApps + + -- ** Clauses + , bindOfClause + + -- ** Casts + , pattern XRun + , pattern XBox + + -- ** Data Constructors + , dcUnit + , takeNameOfDaCon + , takeTypeOfDaCon + + -- ** Patterns + , bindsOfPat + + -- * Witnesses + , wApp + , wApps + , takeXWitness + , takeWAppsAsList + , takePrimWiConApps) +where +import DDC.Source.Tetra.Exp.Generic +import Data.Maybe +import qualified DDC.Type.Exp.Generic.Compounds as T + +import DDC.Core.Exp.Annot + ( dcUnit + , takeNameOfDaCon + , takeTypeOfDaCon + + , bindsOfPat + + , wApp + , wApps + , takeXWitness + , takeWAppsAsList + , takePrimWiConApps) + + +-- Binds ---------------------------------------------------------------------- +-- | Take the `GBind` of a `GBindMT` +bindOfBindMT :: GXBindVarMT l -> GXBindVar l +bindOfBindMT (XBindVarMT g _mt) = g + + +-- | Take the type of a `GBindMT`. +takeTypeOfBindMT :: GXBindVarMT l -> Maybe (GType l) +takeTypeOfBindMT (XBindVarMT _g mt) = mt + + +-- Types ---------------------------------------------------------------------- +-- | Make an empty union type of the given kind. +makeTBot :: GType l -> GType l +makeTBot k = TCon (TyConUnion k) + + + +-- Annotations ---------------------------------------------------------------- +-- | Take the outermost annotation from an expression, +-- or Nothing if this is an `XType` or `XWitness` without an annotation. +takeAnnotOfExp :: GExp l -> Maybe (GXAnnot l) +takeAnnotOfExp xx + = case xx of + XAnnot a _ -> Just a + XVar{} -> Nothing + XPrim{} -> Nothing + XCon{} -> Nothing + XLAM _ x -> takeAnnotOfExp x + XLam _ x -> takeAnnotOfExp x + XApp x1 x2 -> firstJust $ map takeAnnotOfExp [x1, x2] + XLet _ x -> takeAnnotOfExp x + XCase x _ -> takeAnnotOfExp x + XCast _ x -> takeAnnotOfExp x + XType{} -> Nothing + XWitness{} -> Nothing + XDefix a _ -> Just a + XInfixOp a _ -> Just a + XInfixVar a _ -> Just a + XMatch a _ _ -> Just a + XWhere a _ _ -> Just a + XLamPat a _ _ _ -> Just a + XLamCase a _ -> Just a + + +firstJust = listToMaybe . catMaybes + +-- Lambdas --------------------------------------------------------------------- +-- | Make some nested type lambdas. +makeXLAMs :: [GXBindVarMT l] -> GExp l -> GExp l +makeXLAMs bs x = foldr XLAM x bs + + +-- | Make some nested value or witness lambdas. +makeXLams :: [GXBindVarMT l] -> GExp l -> GExp l +makeXLams bs x = foldr XLam x bs + + +-- | Split type lambdas from the front of an expression, +-- or `Nothing` if there aren't any. +takeXLAMs :: GExp l -> Maybe ([GXBindVarMT l], GExp l) +takeXLAMs xx + = let go bs (XAnnot _ x) = go bs x + go bs (XLAM b x) = go (b:bs) x + go bs x = (reverse bs, x) + + in case go [] xx of + ([], _) -> Nothing + (bs, body) -> Just (bs, body) + + +-- | Split nested value or witness lambdas from the front of an expression, +-- or `Nothing` if there aren't any. +takeXLams :: GExp l -> Maybe ([GXBindVarMT l], GExp l) +takeXLams xx + = let go bs (XAnnot _ x) = go bs x + go bs (XLam b x) = go (b:bs) x + go bs x = (reverse bs, x) + in case go [] xx of + ([], _) -> Nothing + (bs, body) -> Just (bs, body) + + +-- | Make some nested lambda abstractions, +-- using a flag to indicate whether the lambda is a +-- level-1 (True), or level-0 (False) binder. +makeXLamFlags :: [(Bool, GXBindVarMT l)] -> GExp l -> GExp l +makeXLamFlags fbs x + = foldr (\(f, b) x' + -> if f then XLAM b x' + else XLam b x') + x fbs + + +-- | Split nested lambdas from the front of an expression, +-- with a flag indicating whether the lambda was a level-1 (True), +-- or level-0 (False) binder. +takeXLamFlags + :: GExp l + -> Maybe ([(Bool, GXBindVarMT l)], GExp l) + +takeXLamFlags xx + = let go bs (XAnnot _ x) = go bs x + go bs (XLAM b x) = go ((True, b):bs) x + go bs (XLam b x) = go ((False, b):bs) x + go bs x = (reverse bs, x) + + in case go [] xx of + ([], _) -> Nothing + (bs, body) -> Just (bs, body) + + +-- Applications --------------------------------------------------------------- +-- | Build sequence of value applications. +makeXApps :: GExp l -> [GExp l] -> GExp l +makeXApps t1 ts = foldl XApp t1 ts + + +-- | Build sequence of applications. +-- Similar to `xApps` but also takes list of annotations for +-- the `XApp` constructors. +makeXAppsWithAnnots :: GExp l -> [(GExp l, Maybe (GXAnnot l))] -> GExp l +makeXAppsWithAnnots f xas + = case xas of + [] -> f + (arg, Nothing) : as -> makeXAppsWithAnnots (XApp f arg) as + (arg, Just a) : as -> makeXAppsWithAnnots (XAnnot a $ XApp f arg) as + + +-- | Flatten an application into the function part and its arguments. +-- +-- Returns `Nothing` if there is no outer application. +takeXApps :: GExp l -> Maybe (GExp l, [GExp l]) +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 :: GExp l -> GExp l -> (GExp l, [GExp l]) +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 :: GExp l -> [GExp l] +takeXAppsAsList xx + = case xx of + XAnnot _ x -> takeXAppsAsList x + XApp x1 x2 -> takeXAppsAsList x1 ++ [x2] + _ -> [xx] + + +-- | Destruct sequence of applications. +-- Similar to `takeXAppsAsList` but also keeps annotations for later. +takeXAppsWithAnnots :: GExp l -> (GExp l, [(GExp l, Maybe (GXAnnot l))]) +takeXAppsWithAnnots xx + = case xx of + XAnnot a (XApp f arg) + -> let (f', args') = takeXAppsWithAnnots f + in (f', args' ++ [(arg, Just a)]) + + XApp f arg + -> let (f', args') = takeXAppsWithAnnots f + in (f', args' ++ [(arg, Nothing)]) + + _ -> (xx, []) + + +-- | Flatten an application of a primop into the variable +-- and its arguments. +-- +-- Returns `Nothing` if the expression isn't a primop application. +takeXPrimApps :: GExp l -> Maybe (GXPrim l, [GExp l]) +takeXPrimApps xx + = case takeXAppsAsList xx of + XPrim 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 :: GExp l -> Maybe (DaCon (GXBoundCon l) (GType l), [GExp l]) +takeXConApps xx + = case takeXAppsAsList xx of + XCon dc : xs -> Just (dc, xs) + _ -> Nothing + + +-- Clauses -------------------------------------------------------------------- +-- | Take the binding variable of a clause. +bindOfClause :: GClause l -> GXBindVar l +bindOfClause cc + = case cc of + SSig _ b _ -> b + SLet _ (XBindVarMT b _) _ _ -> b + + +-- Casts ---------------------------------------------------------------------- +pattern XBox x = XCast CastBox x +pattern XRun x = XCast CastRun x + diff --git a/DDC/Source/Tetra/Exp/Generic.hs b/DDC/Source/Tetra/Exp/Generic.hs --- a/DDC/Source/Tetra/Exp/Generic.hs +++ b/DDC/Source/Tetra/Exp/Generic.hs @@ -4,52 +4,93 @@ module DDC.Source.Tetra.Exp.Generic ( -- * Classes HasAnonBind (..) + , Anon (..) - -- * Expressions - , GName - , GAnnot - , GBind - , GBound - , GPrim + -- * Types + -- ** Type Functions + , GTAnnot + , GTBindVar, GTBoundVar + , GTBindCon, GTBoundCon + , GTPrim + + -- ** Syntax + , GType (..) + , GTyCon (..) + + , pattern TApp2, pattern TApp3 + , pattern TApp4, pattern TApp5 + + , pattern TVoid, pattern TUnit + , pattern TFun + , pattern TBot, pattern TUnion + , pattern TPrim + + -- ** Dictionaries + , ShowGType + + -- * Terms + -- ** Type Functions + , GXAnnot + , GXBindVar, GXBoundVar + , GXBindCon, GXBoundCon + , GXPrim + + -- ** Syntax + , GXBindVarMT (..) , GExp (..) , GLets (..) - , GAlt (..) , GPat (..) , GClause (..) - , GGuardedExp (..) + , GParam (..) , GGuard (..) + , GGuardedExp (..) + , GAltMatch (..) + , GAltCase (..) , GCast (..) - , DaCon (..) - - -- * Witnesses , GWitness (..) , GWiCon (..) + , DaCon (..) -- * Dictionaries - , ShowLanguage - , NFDataLanguage) + , ShowLanguage) where -import DDC.Type.Exp -import qualified DDC.Type.Exp as T -import DDC.Type.Sum () -import Control.DeepSeq -import DDC.Core.Exp - ( DaCon (..)) +import DDC.Type.Exp.Generic.Binding +import DDC.Type.Exp.Generic.Exp +import DDC.Core.Exp (DaCon (..)) ---------------------------------------------------------------------------------------------------- --- | Type functions associated with the language AST. -type family GName l -type family GAnnot l -type family GBind l -type family GBound l -type family GPrim l +------------------------------------------------------------------------------- +-- Type functions associated with the language AST. +-- | Yield the type of annotations. +type family GXAnnot l + +-- | Yield the type of binding occurrences of variables. +type family GXBindVar l + +-- | Yield the type of bound occurrences of variables. +type family GXBoundVar l + +-- | Yield the type of binding occurrences of constructors. +type family GXBindCon l + +-- | Yield the type of bound occurrences of constructors. +type family GXBoundCon l + +-- | Yield the type of primitive operator names. +type family GXPrim l + + class HasAnonBind l where - isAnon :: l -> GBind l -> Bool + isAnon :: l -> GXBindVar l -> Bool ---------------------------------------------------------------------------------------------------- +-- | A possibly typed binding. +data GXBindVarMT l + = XBindVarMT (GXBindVar l) (Maybe (GType l)) + + +------------------------------------------------------------------------------- -- | Well-typed expressions have types of kind `Data`. data GExp l --------------------------------------------------- @@ -57,57 +98,78 @@ -- These are also in the core language, and after desugaring only -- these constructs are used. -- + = XAnnot !(GXAnnot l) !(GExp l) + -- | Value variable or primitive operation. - = XVar !(GAnnot l) !(GBound l) + | XVar !(GXBoundVar l) -- | Primitive values. - | XPrim !(GAnnot l) !(GPrim l) + | XPrim !(GXPrim l) -- | Data constructor or literal. - | XCon !(GAnnot l) !(DaCon (GName l)) + | XCon !(DaCon (GXBoundCon l) (GType l)) -- | Type abstraction (level-1). - | XLAM !(GAnnot l) !(GBind l) !(GExp l) + | XLAM !(GXBindVarMT l) !(GExp l) -- | Value and Witness abstraction (level-0). - | XLam !(GAnnot l) !(GBind l) !(GExp l) + | XLam !(GXBindVarMT l) !(GExp l) -- | Application. - | XApp !(GAnnot l) !(GExp l) !(GExp l) + | XApp !(GExp l) !(GExp l) -- | A non-recursive let-binding. - | XLet !(GAnnot l) !(GLets l) !(GExp l) + | XLet !(GLets l) !(GExp l) -- | Case branching. - | XCase !(GAnnot l) !(GExp l) ![GAlt l] + | XCase !(GExp l) ![GAltCase l] -- | Type cast. - | XCast !(GAnnot l) !(GCast l) !(GExp l) + | XCast !(GCast l) !(GExp l) -- | Type can appear as the argument of an application. - | XType !(GAnnot l) !(Type (GName l)) + | XType !(GType l) -- | Witness can appear as the argument of an application. - | XWitness !(GAnnot l) !(GWitness l) + | XWitness !(GWitness l) --------------------------------------------------- -- Sugar Constructs. -- These constructs are eliminated by the desugarer. -- - -- | Some expressions and infix operators that need to be resolved into - -- proper function applications. - | XDefix !(GAnnot l) [GExp l] + -- | Some expressions and infix operators that need to be resolved + -- into proper function applications. + | XDefix !(GXAnnot l) [GExp l] -- | Use of a naked infix operator, like in 1 + 2. -- INVARIANT: only appears in the list of an XDefix node. - | XInfixOp !(GAnnot l) String + | XInfixOp !(GXAnnot l) String -- | Use of an infix operator as a plain variable, like in (+) 1 2. -- INVARIANT: only appears in the list of an XDefix node. - | XInfixVar !(GAnnot l) String + | XInfixVar !(GXAnnot l) String + -- | Match expression with default. + -- Similar to a case expression, except that if an alternative + -- fails then we try the next one instead of failing. + -- If none of the alternatives succeeds then the overall value + -- is the value of the default expression. + | XMatch !(GXAnnot l) ![GAltMatch l] !(GExp l) + -- | Where expression defines a group of recursive clauses, + -- and is desugared to a letrec. + | XWhere !(GXAnnot l) !(GExp l) ![GClause l] + + -- | Lambda abstraction which matches its argument against + -- a single pattern. + | XLamPat !(GXAnnot l) !(GPat l) !(Maybe (GType l)) !(GExp l) + + -- | Lambda abstraction that matches its argument against + -- the given alternatives. + | XLamCase !(GXAnnot l) ![GAltCase l] + + -- | Possibly recursive bindings. -- Whether these are taken as recursive depends on whether they appear -- in an XLet or XLetrec group. @@ -115,14 +177,14 @@ --------------------------------------------------- -- Core Language Constructs -- | Non-recursive expression binding. - = LLet !(GBind l) !(GExp l) + = LLet !(GXBindVarMT l) !(GExp l) -- | Recursive binding of lambda abstractions. - | LRec ![(GBind l, GExp l)] + | LRec ![(GXBindVarMT l, GExp l)] -- | Bind a local region variable, -- and witnesses to its properties. - | LPrivate ![GBind l] !(Maybe (Type (GName l))) ![GBind l] + | LPrivate ![GXBindVar l] !(Maybe (GType l)) ![(GXBindVar l, GType l)] --------------------------------------------------- -- Sugar Constructs @@ -135,24 +197,38 @@ -- | Binding clause data GClause l -- | A separate type signature. - = SSig !(GAnnot l) !(GBind l) !(Type (GName l)) + = SSig !(GXAnnot l) !(GXBindVar l) !(GType l) -- | A function binding using pattern matching and guards. - | SLet !(GAnnot l) !(GBind l) ![GPat l] ![GGuardedExp l] + | SLet !(GXAnnot l) !(GXBindVarMT l) ![GParam l] ![GGuardedExp l] --- | Case alternatives. -data GAlt l - = AAlt !(GPat l) ![GGuardedExp l] +-- | Parameter for a binding. +data GParam l + -- | Type parameter with optional kind. + = MType !(GXBindVar l) (Maybe (GType l)) + -- | Witness parameter with optional type. + | MWitness !(GXBindVar l) (Maybe (GType l)) + -- | Value paatter with optional type. + | MValue !(GPat l) (Maybe (GType l)) + + -- | Patterns. data GPat l -- | The default pattern always succeeds. = PDefault + -- | Give a name to the value matched by a pattern. + | PAt !(GXBindVar l) !(GPat l) + + -- | The variable pattern always succeeds and binds the value + -- to the new variable. + | PVar !(GXBindVar l) + -- | Match a data constructor and bind its arguments. - | PData !(DaCon (GName l)) ![GBind l] + | PData !(DaCon (GXBoundCon l) (GType l)) ![GPat l] -- | An expression with some guards. @@ -163,17 +239,31 @@ -- | Expression guards. data GGuard l - = GPat !(GPat l) !(GExp l) - | GPred !(GExp l) + = GPat !(GPat l) !(GExp l) + | GPred !(GExp l) | GDefault +-- | Case alternative. +-- If the pattern matches then bind the variables then enter +-- the guarded expression. +data GAltCase l + = AAltCase !(GPat l) ![GGuardedExp l] + + +-- | Match alternative. +-- This is like a case alternative except that the match expression +-- does not give us a head pattern. +data GAltMatch l + = AAltMatch !(GGuardedExp l) + + -- | Type casts. data GCast l -- | Weaken the effect of an expression. -- The given effect is added to the effect -- of the body. - = CastWeakenEffect !(Effect (GName l)) + = CastWeakenEffect !(GType l) -- | Purify the effect (action) of an expression. | CastPurify !(GWitness l) @@ -189,17 +279,20 @@ -- | Witnesses. data GWitness l + -- | Witness annotation + = WAnnot !(GXAnnot l) !(GWitness l) + -- | Witness variable. - = WVar !(GAnnot l) !(GBound l) + | WVar !(GXBoundVar l) -- | Witness constructor. - | WCon !(GAnnot l) !(GWiCon l) + | WCon !(GWiCon l) -- | Witness application. - | WApp !(GAnnot l) !(GWitness l) !(GWitness l) + | WApp !(GWitness l) !(GWitness l) -- | Type can appear as an argument of a witness application. - | WType !(GAnnot l) !(T.Type (GName l)) + | WType !(GType l) -- | Witness constructors. @@ -207,116 +300,29 @@ -- | Witness constructors defined in the environment. -- In the interpreter we use this to hold runtime capabilities. -- The attached type must be closed. - = WiConBound !(GBound l) !(T.Type (GName l)) + = WiConBound !(GXBoundVar l) !(GType l) ---------------------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- type ShowLanguage l = ( Show l - , Show (GName l), Show (GAnnot l) - , Show (GBind l), Show (GBound l), Show (GPrim l)) - -deriving instance ShowLanguage l => Show (GExp l) -deriving instance ShowLanguage l => Show (GLets l) -deriving instance ShowLanguage l => Show (GClause l) -deriving instance ShowLanguage l => Show (GAlt l) -deriving instance ShowLanguage l => Show (GGuardedExp l) -deriving instance ShowLanguage l => Show (GGuard l) -deriving instance ShowLanguage l => Show (GPat l) -deriving instance ShowLanguage l => Show (GCast l) -deriving instance ShowLanguage l => Show (GWitness l) -deriving instance ShowLanguage l => Show (GWiCon l) - - ---------------------------------------------------------------------------------------------------- -type NFDataLanguage l - = ( NFData l - , NFData (GAnnot l), NFData (GName l) - , NFData (GBind l), NFData (GBound l), NFData (GPrim l)) - -instance NFDataLanguage l => NFData (GExp l) where - rnf xx - = case xx of - XVar a u -> rnf a `seq` rnf u - XPrim a p -> rnf a `seq` rnf p - XCon a dc -> rnf a `seq` rnf dc - XLAM a b x -> rnf a `seq` rnf b `seq` rnf x - XLam a b x -> rnf a `seq` rnf b `seq` rnf x - XApp a x1 x2 -> rnf a `seq` rnf x1 `seq` rnf x2 - XLet a lts x -> rnf a `seq` rnf lts `seq` rnf x - XCase a x alts -> rnf a `seq` rnf x `seq` rnf alts - XCast a c x -> rnf a `seq` rnf c `seq` rnf x - XType a t -> rnf a `seq` rnf t - XWitness a w -> rnf a `seq` rnf w - XDefix a xs -> rnf a `seq` rnf xs - XInfixOp a s -> rnf a `seq` rnf s - XInfixVar a s -> rnf a `seq` rnf s - - -instance NFDataLanguage l => NFData (GClause l) where - rnf cc - = case cc of - SSig a b t -> rnf a `seq` rnf b `seq` rnf t - SLet a b ps gxs -> rnf a `seq` rnf b `seq` rnf ps `seq` rnf gxs - - -instance NFDataLanguage l => NFData (GLets l) where - rnf lts - = case lts of - LLet b x -> rnf b `seq` rnf x - LRec bxs -> rnf bxs - LPrivate bs1 mR bs2 -> rnf bs1 `seq` rnf mR `seq` rnf bs2 - LGroup cs -> rnf cs - - -instance NFDataLanguage l => NFData (GAlt l) where - rnf aa - = case aa of - AAlt w gxs -> rnf w `seq` rnf gxs - - -instance NFDataLanguage l => NFData (GPat l) where - rnf pp - = case pp of - PDefault -> () - PData dc bs -> rnf dc `seq` rnf bs - - -instance NFDataLanguage l => NFData (GGuardedExp l) where - rnf gx - = case gx of - GGuard g gx' -> rnf g `seq` rnf gx' - GExp x -> rnf x - - -instance NFDataLanguage l => NFData (GGuard l) where - rnf gg - = case gg of - GPred x -> rnf x - GPat p x -> rnf p `seq` rnf x - GDefault -> () - - -instance NFDataLanguage l => NFData (GCast l) where - rnf cc - = case cc of - CastWeakenEffect e -> rnf e - CastPurify w -> rnf w - CastBox -> () - CastRun -> () - - -instance NFDataLanguage l => NFData (GWitness l) where - rnf ww - = case ww of - WVar a u -> rnf a `seq` rnf u - WCon a c -> rnf a `seq` rnf c - WApp a w1 w2 -> rnf a `seq` rnf w1 `seq` rnf w2 - WType a t -> rnf a `seq` rnf t - + , ShowGType l + , Show (GXAnnot l) + , Show (GXBindVar l), Show (GXBoundVar l) + , Show (GXBindCon l), Show (GXBoundCon l) + , Show (GXPrim l)) -instance NFDataLanguage l => NFData (GWiCon l) where - rnf wc - = case wc of - WiConBound u t -> rnf u `seq` rnf t +deriving instance ShowLanguage l => Show (GExp l) +deriving instance ShowLanguage l => Show (GLets l) +deriving instance ShowLanguage l => Show (GClause l) +deriving instance ShowLanguage l => Show (GParam l) +deriving instance ShowLanguage l => Show (GAltCase l) +deriving instance ShowLanguage l => Show (GAltMatch l) +deriving instance ShowLanguage l => Show (GGuardedExp l) +deriving instance ShowLanguage l => Show (GGuard l) +deriving instance ShowLanguage l => Show (GPat l) +deriving instance ShowLanguage l => Show (GCast l) +deriving instance ShowLanguage l => Show (GWitness l) +deriving instance ShowLanguage l => Show (GWiCon l) +deriving instance ShowLanguage l => Show (GXBindVarMT l) diff --git a/DDC/Source/Tetra/Exp/NFData.hs b/DDC/Source/Tetra/Exp/NFData.hs new file mode 100644 --- /dev/null +++ b/DDC/Source/Tetra/Exp/NFData.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE UndecidableInstances #-} +module DDC.Source.Tetra.Exp.NFData where +import DDC.Source.Tetra.Exp.Generic +import qualified DDC.Type.Exp.Generic.NFData as T +import Control.DeepSeq + +--------------------------------------------------------------------------------------------------- +type NFDataLanguage l + = ( NFData l, T.NFDataLanguage l + , NFData (GXAnnot l) + , NFData (GXBindVar l), NFData (GXBoundVar l) + , NFData (GXBindCon l), NFData (GXBoundCon l) + , NFData (GXPrim l)) + +instance NFDataLanguage l => NFData (GExp l) where + rnf xx + = case xx of + XAnnot a x -> rnf a `seq` rnf x + XVar u -> rnf u + XPrim p -> rnf p + XCon dc -> rnf dc + XLAM b x -> rnf b `seq` rnf x + XLam b x -> rnf b `seq` rnf x + XApp x1 x2 -> rnf x1 `seq` rnf x2 + XLet lts x -> rnf lts `seq` rnf x + XCase x alts -> rnf x `seq` rnf alts + XCast c x -> rnf c `seq` rnf x + XType t -> rnf t + XWitness w -> rnf w + XDefix a xs -> rnf a `seq` rnf xs + XInfixOp a s -> rnf a `seq` rnf s + XInfixVar a s -> rnf a `seq` rnf s + XMatch a as x -> rnf a `seq` rnf as `seq` rnf x + XWhere a cl x -> rnf a `seq` rnf cl `seq` rnf x + XLamPat a w mt x -> rnf a `seq` rnf w `seq` rnf mt `seq` rnf x + XLamCase a as -> rnf a `seq` rnf as + + +instance NFDataLanguage l => NFData (GXBindVarMT l) where + rnf (XBindVarMT b mt) + = rnf b `seq` rnf mt + + +instance NFDataLanguage l => NFData (GClause l) where + rnf cc + = case cc of + SSig a b t -> rnf a `seq` rnf b `seq` rnf t + SLet a b ps gxs -> rnf a `seq` rnf b `seq` rnf ps `seq` rnf gxs + + +instance NFDataLanguage l => NFData (GParam l) where + rnf pp + = case pp of + MType b mt -> rnf b `seq` rnf mt + MWitness b mt -> rnf b `seq` rnf mt + MValue p mt -> rnf p `seq` rnf mt + + +instance NFDataLanguage l => NFData (GLets l) where + rnf lts + = case lts of + LLet b x -> rnf b `seq` rnf x + LRec bxs -> rnf bxs + LPrivate bs1 mR bs2 -> rnf bs1 `seq` rnf mR `seq` rnf bs2 + LGroup cs -> rnf cs + + +instance NFDataLanguage l => NFData (GAltCase l) where + rnf aa + = case aa of + AAltCase w gxs -> rnf w `seq` rnf gxs + + +instance NFDataLanguage l => NFData (GAltMatch l) where + rnf aa + = case aa of + AAltMatch gs -> rnf gs + + +instance NFDataLanguage l => NFData (GPat l) where + rnf pp + = case pp of + PDefault -> () + PAt b p -> rnf b `seq` rnf p + PVar b -> rnf b + PData dc bs -> rnf dc `seq` rnf bs + + +instance NFDataLanguage l => NFData (GGuardedExp l) where + rnf gx + = case gx of + GGuard g gx' -> rnf g `seq` rnf gx' + GExp x -> rnf x + + +instance NFDataLanguage l => NFData (GGuard l) where + rnf gg + = case gg of + GPred x -> rnf x + GPat p x -> rnf p `seq` rnf x + GDefault -> () + + +instance NFDataLanguage l => NFData (GCast l) where + rnf cc + = case cc of + CastWeakenEffect e -> rnf e + CastPurify w -> rnf w + CastBox -> () + CastRun -> () + + +instance NFDataLanguage l => NFData (GWitness l) where + rnf ww + = case ww of + WAnnot a w -> rnf a `seq` rnf w + WVar u -> rnf u + WCon c -> rnf c + WApp w1 w2 -> rnf w1 `seq` rnf w2 + WType t -> rnf t + + +instance NFDataLanguage l => NFData (GWiCon l) where + rnf wc + = case wc of + WiConBound u t -> rnf u `seq` rnf t + diff --git a/DDC/Source/Tetra/Exp/Predicates.hs b/DDC/Source/Tetra/Exp/Predicates.hs new file mode 100644 --- /dev/null +++ b/DDC/Source/Tetra/Exp/Predicates.hs @@ -0,0 +1,139 @@ + +-- | Simple predicates on Source Tetra things. +module DDC.Source.Tetra.Exp.Predicates + ( module DDC.Type.Exp.Generic.Predicates + + -- * Atoms + , isXVar, isXCon + , isAtomX, isAtomW + + -- * Lambdas + , isXLAM, isXLam + , isLambdaX + + -- * Applications + , isXApp + + -- * Let bindings + , isXLet + + -- * Types and Witnesses + , isXType + , isXWitness + + -- * Patterns + , isPDefault + , isPVar) +where +import DDC.Source.Tetra.Exp.Generic +import DDC.Type.Exp.Generic.Predicates + + +-- Atoms ---------------------------------------------------------------------- +-- | Check whether an expression is a variable. +isXVar :: GExp l -> Bool +isXVar xx + = case xx of + XVar{} -> True + _ -> False + + +-- | Check whether an expression is a constructor. +isXCon :: GExp l -> Bool +isXCon xx + = case xx of + XCon{} -> True + _ -> False + + +-- | Check whether an expression is a `XVar` or an `XCon`, +-- or some type or witness atom. +isAtomX :: GExp l -> Bool +isAtomX xx + = case xx of + XVar{} -> True + XCon{} -> True + XType t -> isAtomT t + XWitness w -> isAtomW w + _ -> False + + +-- | Check whether a witness is a `WVar` or `WCon`. +isAtomW :: GWitness l -> Bool +isAtomW ww + = case ww of + WVar{} -> True + WCon{} -> True + _ -> False + + +-- Lambdas -------------------------------------------------------------------- +-- | Check whether an expression is a spec abstraction (level-1). +isXLAM :: GExp l -> Bool +isXLAM xx + = case xx of + XLAM{} -> True + _ -> False + + +-- | Check whether an expression is a value or witness abstraction (level-0). +isXLam :: GExp l -> Bool +isXLam xx + = case xx of + XLam{} -> True + _ -> False + + +-- | Check whether an expression is a spec, value, or witness abstraction. +isLambdaX :: GExp l -> Bool +isLambdaX xx + = isXLAM xx || isXLam xx + + +-- Applications --------------------------------------------------------------- +-- | Check whether an expression is an `XApp`. +isXApp :: GExp l -> Bool +isXApp xx + = case xx of + XApp{} -> True + _ -> False + + +-- Let Bindings --------------------------------------------------------------- +-- | Check whether an expression is a `XLet`. +isXLet :: GExp l -> Bool +isXLet xx + = case xx of + XLet{} -> True + _ -> False + + +-- Type and Witness ----------------------------------------------------------- +-- | Check whether an expression is an `XType` +isXType :: GExp l -> Bool +isXType xx + = case xx of + XType{} -> True + _ -> False + + +-- | Check whether an expression is an `XWitness` +isXWitness :: GExp l -> Bool +isXWitness xx + = case xx of + XWitness{} -> True + _ -> False + + +-- Patterns ------------------------------------------------------------------- +-- | Check whether a pattern is a `PDefault`. +isPDefault :: GPat l -> Bool +isPDefault PDefault = True +isPDefault _ = False + + +-- | Check whether a pattern is a `PVar`. +isPVar :: GPat l -> Bool +isPVar (PVar _) = True +isPVar _ = False + diff --git a/DDC/Source/Tetra/Exp/Source.hs b/DDC/Source/Tetra/Exp/Source.hs new file mode 100644 --- /dev/null +++ b/DDC/Source/Tetra/Exp/Source.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE TypeFamilies #-} +module DDC.Source.Tetra.Exp.Source + ( -- * Language + Source (..) + + -- * Binding + , Name + , Bind (..) + , Bound (..) + + -- * Types + -- ** Syntax + , GTAnnot + , GTBindVar, GTBoundVar + , GTBindCon, GTBoundCon + , GTPrim + + , Type, GType (..) + , TyCon, GTyCon (..) + + , SoCon (..) + , KiCon (..) + , TwCon (..) + , TcCon (..) + + , TyConBind (..) + , TyConBound (..) + + , pattern TApp2, pattern TApp3 + , pattern TApp4, pattern TApp5 + + , pattern TVoid, pattern TUnit + , pattern TFun + , pattern TBot, pattern TUnion + , pattern TPrim + + -- ** Primitives + , PrimType (..) + , PrimTyCon (..) + , PrimTyConTetra (..) + + , pattern KData, pattern KRegion, pattern KEffect + , pattern TImpl + , pattern TSusp + , pattern TRead, pattern TWrite, pattern TAlloc + + , pattern TBool + , pattern TNat, pattern TInt + , pattern TSize, pattern TWord + , pattern TFloat + , pattern TTextLit + + -- * Terms + -- ** Syntax + , Annot, GXAnnot + , BindVarMT, GXBindVarMT (..) + , BindVar, GXBindVar + , BoundVar, GXBoundVar + , BindCon, GXBindCon + , BoundCon, GXBoundCon + , Prim, GXPrim + , Exp, GExp (..) + , Lets, GLets (..) + , Clause, GClause (..) + , Param, GParam (..) + , Pat, GPat (..) + , Guard, GGuard (..) + , GuardedExp, GGuardedExp (..) + , AltMatch, GAltMatch (..) + , AltCase, GAltCase (..) + , Cast, GCast (..) + , Witness, GWitness (..) + , WiCon, GWiCon (..) + , DaCon (..) + + , DaConBind (..) + , DaConBound (..) + + -- ** Primitives + , PrimVal (..) + , PrimArith (..) + , OpVector (..) + , OpFun (..) + , OpError (..) + , PrimLit (..) + + , pattern PTrue + , pattern PFalse + + -- ** Dictionaries + , ShowLanguage) +where +import DDC.Source.Tetra.Exp.Generic +import DDC.Source.Tetra.Exp.Bind +import DDC.Source.Tetra.Prim +import DDC.Type.Exp.TyCon as T +import DDC.Data.SourcePos +import DDC.Data.Pretty + + +-- Language ------------------------------------------------------------------- +-- | Type index for Source Tetra Language. +data Source + = Source + deriving Show + +instance Pretty Source where + ppr ss = text (show ss) + + +instance HasAnonBind Source where + isAnon _ BAnon = True + isAnon _ _ = False + + +instance Anon Source where + withBindings Source n f + = let bs = replicate n BAnon + us = reverse [UIx i | i <- [0..(n - 1)]] + in f bs us + + +-- Type AST ------------------------------------------------------------------- +type Type = GType Source +type TyCon = GTyCon Source + +type instance GTAnnot Source = SourcePos +type instance GTBindVar Source = Bind +type instance GTBoundVar Source = Bound +type instance GTBindCon Source = TyConBind +type instance GTBoundCon Source = TyConBound +type instance GTPrim Source = PrimType + + +-- Term AST ------------------------------------------------------------------- +type Annot = GXAnnot Source +type BindVar = GXBindVar Source +type BindVarMT = GXBindVarMT Source +type BoundVar = GXBoundVar Source +type BindCon = GXBoundCon Source +type BoundCon = GXBoundCon Source +type Prim = GXPrim Source +type Exp = GExp Source +type Lets = GLets Source +type Clause = GClause Source +type Param = GParam Source +type Pat = GPat Source +type Guard = GGuard Source +type GuardedExp = GGuardedExp Source +type AltCase = GAltCase Source +type AltMatch = GAltMatch Source +type Cast = GCast Source +type Witness = GWitness Source +type WiCon = GWiCon Source + +type instance GXAnnot Source = SourcePos +type instance GXBindVar Source = Bind +type instance GXBoundVar Source = Bound +type instance GXBindCon Source = DaConBind +type instance GXBoundCon Source = DaConBound +type instance GXPrim Source = PrimVal + diff --git a/DDC/Source/Tetra/Lexer.hs b/DDC/Source/Tetra/Lexer.hs --- a/DDC/Source/Tetra/Lexer.hs +++ b/DDC/Source/Tetra/Lexer.hs @@ -1,13 +1,87 @@ -- | Lexer for Source Tetra tokens. module DDC.Source.Tetra.Lexer - (lexModuleString) + ( Name (..) + , lexModuleString) where import DDC.Source.Tetra.Prim import DDC.Core.Lexer -import DDC.Data.Token +import DDC.Data.Pretty +import Control.DeepSeq +import Data.Char +import Data.Text (Text) +import qualified Data.Text as Text +--------------------------------------------------------------------------------------------------- +-- | Union of all names that we detect during lexing. +data Name + -- | A user defined variable. + = NameVar !Text + + -- | A user defined constructor. + | NameCon !Text + + -- | Primitive type names. + | NamePrimType !PrimType + + -- | Primitive literal values. + | NamePrimValLit !PrimLit + + -- | Primitive operator values. + | NamePrimValOp !PrimVal + deriving (Eq, Ord, Show) + + +--------------------------------------------------------------------------------------------------- +instance Pretty Name where + ppr nn + = case nn of + NameVar v -> text (Text.unpack v) + NameCon c -> text (Text.unpack c) + NamePrimType p -> ppr p + NamePrimValLit p -> ppr p + NamePrimValOp p -> ppr p + + +instance NFData Name where + rnf nn + = case nn of + NameVar s -> rnf s + NameCon s -> rnf s + NamePrimType p -> rnf p + NamePrimValLit p -> rnf p + NamePrimValOp p -> rnf p + + +-- | Read the name of a variable, constructor or literal. +readName :: String -> Maybe Name +readName str + -- Primitive names. + | Just n <- readPrimType str + = Just $ NamePrimType n + + | Just n <- readPrimLit str + = Just $ NamePrimValLit n + + | Just n <- readPrimVal str + = Just $ NamePrimValOp n + + -- Constructors. + | c : _ <- str + , isUpper c + = Just $ NameCon (Text.pack str) + + -- Variables. + | c : _ <- str + , isVarStart c + = Just $ NameVar (Text.pack str) + + | otherwise + = Nothing + + +--------------------------------------------------------------------------------------------------- -- | Lex a string to tokens, using primitive names. -- -- The first argument gives the starting source line number. @@ -17,10 +91,13 @@ -- There are a few tokens accepted by one language but not the other, -- but it'll do for now. -- -lexModuleString :: String -> Int -> String -> [Token (Tok Name)] +lexModuleString :: String -> Int -> String -> [Located (Token Name)] lexModuleString sourceName lineStart str = map rn $ lexModuleWithOffside sourceName lineStart str - where rn (Token strTok sp) - = case renameTok readName strTok of - Just t' -> Token t' sp - Nothing -> Token (KErrorJunk "lexical error") sp + where + rn (Located sp strTok) + = case renameToken readName strTok of + Just t' -> Located sp t' + Nothing -> Located sp (KErrorJunk "lexical error") + + diff --git a/DDC/Source/Tetra/Module.hs b/DDC/Source/Tetra/Module.hs --- a/DDC/Source/Tetra/Module.hs +++ b/DDC/Source/Tetra/Module.hs @@ -21,8 +21,9 @@ -- * Data type definitions , DataDef (..)) where -import DDC.Source.Tetra.Exp import DDC.Source.Tetra.DataDef +import DDC.Source.Tetra.Exp.Source +import DDC.Source.Tetra.Exp.NFData import Control.DeepSeq import DDC.Core.Module @@ -35,7 +36,7 @@ , ImportValue (..)) --- Module --------------------------------------------------------------------- +-- Module ----------------------------------------------------------------------------------------- data Module l = Module { -- | Name of this module @@ -43,28 +44,29 @@ -- Exports ---------------------------- -- | Names of exported types (level-1). - , moduleExportTypes :: [GName l] + , moduleExportTypes :: [GTBoundCon l] -- | Names of exported values (level-0). - , moduleExportValues :: [GName l] + , moduleExportValues :: [GXBoundVar l] -- Imports ---------------------------- -- | Imported modules. , moduleImportModules :: [ModuleName] -- | Kinds of imported foreign types. - , moduleImportTypes :: [(GName l, ImportType (GName l))] + , moduleImportTypes :: [(GTBindCon l, ImportType (GTBindCon l) (GType l))] -- | Types of imported capabilities. - , moduleImportCaps :: [(GName l, ImportCap (GName l))] + , moduleImportCaps :: [(GXBindVar l, ImportCap (GXBindVar l) (GType l))] -- | Types of imported foreign values. - , moduleImportValues :: [(GName l, ImportValue (GName l))] + , moduleImportValues :: [(GXBindVar l, ImportValue (GXBindVar l) (GType l))] -- Local ------------------------------ -- | Top-level things , moduleTops :: [Top l] } + deriving instance ShowLanguage l => Show (Module l) @@ -86,18 +88,25 @@ = isMainModuleName $ moduleName mm --- Top Level Thing ------------------------------------------------------------ +-- Top Level Thing -------------------------------------------------------------------------------- data Top l -- | Some top-level, possibly recursive clauses. = TopClause - { topAnnot :: GAnnot l + { topAnnot :: GXAnnot l , topClause :: GClause l } -- | Data type definition. | TopData - { topAnnot :: GAnnot l - , topDataDef :: DataDef (GName l) } + { topAnnot :: GXAnnot l + , topDataDef :: DataDef l } + -- | Type binding. + | TopType + { topAnnot :: GXAnnot l + , topTypeBind :: GTBindCon l + , topTypeExp :: GType l } + + deriving instance ShowLanguage l => Show (Top l) instance NFDataLanguage l => NFData (Top l) where @@ -105,4 +114,5 @@ = case top of TopClause a c -> rnf a `seq` rnf c TopData a def -> rnf a `seq` rnf def + TopType a b t -> rnf a `seq` rnf b `seq` rnf t diff --git a/DDC/Source/Tetra/Parser.hs b/DDC/Source/Tetra/Parser.hs --- a/DDC/Source/Tetra/Parser.hs +++ b/DDC/Source/Tetra/Parser.hs @@ -2,55 +2,42 @@ -- | Parser for the Source Tetra language. module DDC.Source.Tetra.Parser ( Parser - , Context (..) - , context -- * Modules , pModule -- * Expressions , pExp - , pExpApp - , pExpAtom + , pExpAppSP -- * Types , pType , pTypeApp - , pTypeAtom + , pTypeAtomSP -- * Witnesses , pWitness , pWitnessApp , pWitnessAtom - -- * Constructors - , pCon - , pLit - -- * Variables - , pBinder - , pIndex - , pVar - , pName + , pBindNameSP + , pBoundNameSP, pBoundName + , pBoundIxSP + , pBoundNameOpSP + , pBoundNameOpVarSP + -- * Constructors + , pDaConBindName + , pDaConBoundName, pDaConBoundNameSP + , pDaConBoundLit, pDaConBoundLitSP + , pPrimValSP + -- * Raw Tokens - , pTok - , pTokAs) + , pTok) where -import DDC.Source.Tetra.Parser.Exp import DDC.Source.Tetra.Parser.Module +import DDC.Source.Tetra.Parser.Witness +import DDC.Source.Tetra.Parser.Exp +import DDC.Source.Tetra.Parser.Base -import DDC.Core.Parser - ( Parser - , Context (..) - , pWitness - , pWitnessApp - , pWitnessAtom - , pVar - , pCon - , pName - , pBinder - , pIndex - , pLit - , pTok, pTokAs) - diff --git a/DDC/Source/Tetra/Parser/Atom.hs b/DDC/Source/Tetra/Parser/Atom.hs deleted file mode 100644 --- a/DDC/Source/Tetra/Parser/Atom.hs +++ /dev/null @@ -1,28 +0,0 @@ - -module DDC.Source.Tetra.Parser.Atom - ( pPrimValSP - , pVarStringSP) -where -import DDC.Source.Tetra.Prim -import DDC.Core.Lexer.Tokens -import DDC.Base.Parser ((), SourcePos) -import qualified DDC.Base.Parser as P - -import DDC.Core.Parser - (Parser) - - --- | Parse a variable, with source position. -pPrimValSP :: Parser Name (PrimVal, SourcePos) -pPrimValSP = P.pTokMaybeSP f - "a variable" - where f (KN (KVar (NameVal p))) = Just p - f _ = Nothing - - --- | Parse a variable, with source position. -pVarStringSP :: Parser Name (String, SourcePos) -pVarStringSP = P.pTokMaybeSP f - "a variable" - where f (KN (KVar (NameVar s))) = Just s - f _ = Nothing diff --git a/DDC/Source/Tetra/Parser/Base.hs b/DDC/Source/Tetra/Parser/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Source/Tetra/Parser/Base.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE ExplicitNamespaces #-} +module DDC.Source.Tetra.Parser.Base + ( type Parser + , (), SourcePos(..) + + -- * Generic Token parsers + , pSym, pKey + , pTok, pTokSP + + -- * Term Variables + , pBindNameSP + , pBoundName, pBoundNameSP + , pBoundIxSP + , pBoundNameOpVarSP + , pBoundNameOpSP + + -- * TyCons + , pTyConBindName, pTyConBindNameSP + + -- * DaCons + , pDaConBindName + , pDaConBoundName, pDaConBoundNameSP + , pDaConBoundLit, pDaConBoundLitSP + + -- * Primitive Operators + , pPrimValSP) +where +import DDC.Source.Tetra.Exp.Bind hiding (Name) +import DDC.Source.Tetra.Prim +import DDC.Source.Tetra.Lexer +import DDC.Core.Lexer.Tokens +import DDC.Control.Parser (()) +import DDC.Control.Parser (SourcePos(..)) +import qualified DDC.Control.Parser as P +import qualified Data.Text as Text + + +import DDC.Core.Parser + ( pSym, pKey + , pTok, pTokSP + , pIndexSP) + +type Parser a + = P.Parser (Token Name) a + + +-- Type and Term Variables ---------------------------------------------------- +-- | Parse a binding occurrence of a named variable. +pBindNameSP :: Parser (Bind, SourcePos) +pBindNameSP = P.pTokMaybeSP f "a variable" + where f (KN (KVar (NameVar s))) = Just (BName s) + f _ = Nothing + + +-- | Parse a named term variable. +pBoundName :: Parser Bound +pBoundName = P.pTokMaybe f "a variable" + where f (KN (KVar (NameVar s))) = Just (UName s) + f _ = Nothing + + +-- | Parse a named term variable. +pBoundNameSP :: Parser (Bound, SourcePos) +pBoundNameSP = P.pTokMaybeSP f "a variable" + where f (KN (KVar (NameVar s))) = Just (UName s) + f _ = Nothing + + +-- | Parse an indexed term variable. +pBoundIxSP :: Parser (Bound, SourcePos) +pBoundIxSP + = do (i, sp) <- pIndexSP + return $ (UIx i, sp) + + +-- | Parse an infix operator used as a variable. +pBoundNameOpSP :: Parser (Bound, SourcePos) +pBoundNameOpSP = P.pTokMaybeSP f + where f (KA (KOp s)) = Just (UName (Text.pack s)) + f _ = Nothing + + +-- | Parse an infix operator used as a variable. +pBoundNameOpVarSP :: Parser (Bound, SourcePos) +pBoundNameOpVarSP = P.pTokMaybeSP f + where f (KA (KOpVar s)) = Just (UName (Text.pack s)) + f _ = Nothing + + +-- TyCons --------------------------------------------------------------------- +-- | Parse a binding occurrences of a type constructor name. +pTyConBindName :: Parser TyConBind +pTyConBindName = P.pTokMaybe f + where f (KN (KCon (NameCon n))) = Just (TyConBindName n) + f _ = Nothing + + +-- | Parse a binding occurrences of a type constructor name. +pTyConBindNameSP :: Parser (TyConBind, SourcePos) +pTyConBindNameSP = P.pTokMaybeSP f + where f (KN (KCon (NameCon n))) = Just (TyConBindName n) + f _ = Nothing + + + +-- DaCons --------------------------------------------------------------------- +-- | Parse a binding occurrence of a data constructor name. +pDaConBindName :: Parser DaConBind +pDaConBindName = P.pTokMaybe f + where f (KN (KCon (NameCon n))) = Just (DaConBindName n) + f _ = Nothing + + +-- | Parse a bound occurrence of a data constructor name. +pDaConBoundName :: Parser DaConBound +pDaConBoundName = P.pTokMaybe f + where f (KN (KCon (NameCon n))) = Just (DaConBoundName n) + f _ = Nothing + + +-- | Parse a constructor name. +pDaConBoundNameSP :: Parser (DaConBound, SourcePos) +pDaConBoundNameSP = P.pTokMaybeSP f + where f (KN (KCon (NameCon n))) = Just (DaConBoundName n) + f _ = Nothing + + +-- | Parse a literal. +-- These are numeric literals, string literals, +-- and special constructors like 'True' and 'False'. +pDaConBoundLit :: Parser DaConBound +pDaConBoundLit = P.pTokMaybe f + where f (KA (KLiteral lit False)) = Just (DaConBoundLit (primLitOfLiteral lit)) + f (KN (KCon (NamePrimValLit n))) = Just (DaConBoundLit n) + f _ = Nothing + + +-- | Parse a literal, with source position. +-- These are numeric literals, string literals, +-- and special constructors like 'True' and 'False'. +pDaConBoundLitSP :: Parser (DaConBound, SourcePos) +pDaConBoundLitSP = P.pTokMaybeSP f + where f (KA (KLiteral lit False)) = Just (DaConBoundLit (primLitOfLiteral lit)) + f (KN (KCon (NamePrimValLit n))) = Just (DaConBoundLit n) + f _ = Nothing + + +-- Primitive Values ----------------------------------------------------------- +pPrimValSP :: Parser (PrimVal, SourcePos) +pPrimValSP = P.pTokMaybeSP f "a primitive operator" + where f (KN (KVar (NamePrimValOp p))) = Just p + f _ = Nothing + + diff --git a/DDC/Source/Tetra/Parser/Exp.hs b/DDC/Source/Tetra/Parser/Exp.hs --- a/DDC/Source/Tetra/Parser/Exp.hs +++ b/DDC/Source/Tetra/Parser/Exp.hs @@ -1,644 +1,778 @@ - --- | Parser for Source Tetra expressions. -module DDC.Source.Tetra.Parser.Exp - ( context - , pExp - , pExpApp - , pExpAtom, pExpAtomSP - , pLetsSP, pClauseSP - , pType - , pTypeApp - , pTypeAtom) -where -import DDC.Source.Tetra.Transform.Guards -import DDC.Source.Tetra.Parser.Witness -import DDC.Source.Tetra.Parser.Param -import DDC.Source.Tetra.Parser.Atom -import DDC.Source.Tetra.Compounds -import DDC.Source.Tetra.Prim -import DDC.Source.Tetra.Exp.Annot -import DDC.Core.Lexer.Tokens -import Control.Monad.Except -import DDC.Base.Parser ((), SourcePos(..)) -import qualified DDC.Base.Parser as P -import qualified DDC.Type.Exp as T -import qualified DDC.Type.Compounds as T -import qualified Data.Text as Text - -import DDC.Core.Parser - ( Parser - , Context (..) - , pBinder - , pType - , pTypeAtom - , pTypeApp - , pCon, pConSP - , pLit, pLitSP - , pStringSP - , pIndexSP - , pOpSP, pOpVarSP - , pTok - , pTokSP) - - -type SP = SourcePos - --- | Starting context for the parser. --- Holds flags about what language features we should accept. -context :: Context Name -context = Context - { contextTrackedEffects = True - , contextTrackedClosures = True - , contextFunctionalEffects = False - , contextFunctionalClosures = False - , contextMakeStringName = Just (\_ tx -> NameLitTextLit tx) } - - --- Exp -------------------------------------------------------------------------------------------- --- | Parse a Tetra Source language expression. -pExp :: Context Name -> Parser Name (Exp SP) -pExp c - = P.choice - - -- Level-0 lambda abstractions - -- \(x1 x2 ... : Type) (y1 y2 ... : Type) ... . Exp - -- \x1 x2 : Type. Exp - [ do sp <- P.choice [ pTokSP KLambda, pTokSP KBackSlash ] - - bs <- P.choice - [ fmap concat $ P.many1 - $ do pTok KRoundBra - bs' <- P.many1 pBinder - pTok (KOp ":") - t <- pType c - pTok KRoundKet - return (map (\b -> T.makeBindFromBinder b t) bs') - - , do bs' <- P.many1 pBinder - pTok (KOp ":") - t <- pType c - return (map (\b -> T.makeBindFromBinder b t) bs') - ] - - pTok KDot - xBody <- pExp c - return $ foldr (XLam sp) xBody bs - - -- Level-1 lambda abstractions. - -- /\(x1 x2 ... : Type) (y1 y2 ... : Type) ... . Exp - , do sp <- P.choice [ pTokSP KBigLambda, pTokSP KBigLambdaSlash ] - - bs <- P.choice - [ fmap concat $ P.many1 - $ do pTok KRoundBra - bs' <- P.many1 pBinder - pTok (KOp ":") - t <- pType c - pTok KRoundKet - return (map (\b -> T.makeBindFromBinder b t) bs') - - , do bs' <- P.many1 pBinder - pTok (KOp ":") - t <- pType c - return (map (\b -> T.makeBindFromBinder b t) bs') - ] - - pTok KDot - xBody <- pExp c - return $ foldr (XLAM sp) xBody bs - - -- let expression - , do (lts, sp) <- pLetsSP c - pTok KIn - x2 <- pExp c - return $ XLet sp lts x2 - - -- Sugar for a let-expression. - -- do { Stmt;+ } - , do pTok KDo - pTok KBraceBra - xx <- pStmts c - pTok KBraceKet - return $ xx - - -- case Exp of { Alt;+ } - , do sp <- pTokSP KCase - x <- pExp c - pTok KOf - pTok KBraceBra - alts <- P.sepEndBy1 (pAlt c) (pTok KSemiColon) - pTok KBraceKet - return $ XCase sp x alts - - -- match { | EXP = EXP | EXP = EXP ... } - -- Sugar for cascaded case expressions case-expression. - , do sp <- pTokSP KMatch - pTok KBraceBra - x <- pMatchGuardsAsCase sp c - pTok KBraceKet - return x - - , do -- if-then-else - -- Sugar for a case-expression. - sp <- pTokSP KIf - x1 <- pExp c - pTok KThen - x2 <- pExp c - pTok KElse - x3 <- pExp c - return $ XCase sp x1 - [ AAlt pTrue [GExp x2] - , AAlt PDefault [GExp x3]] - - -- weakeff [Type] in Exp - , do sp <- pTokSP KWeakEff - pTok KSquareBra - t <- pType c - pTok KSquareKet - pTok KIn - x <- pExp c - return $ XCast sp (CastWeakenEffect t) x - - -- purify Witness in Exp - , do sp <- pTokSP KPurify - w <- pWitness c - pTok KIn - x <- pExp c - return $ XCast sp (CastPurify w) x - - -- box Exp - , do sp <- pTokSP KBox - x <- pExp c - return $ XCast sp CastBox x - - -- run Exp - , do sp <- pTokSP KRun - x <- pExp c - return $ XCast sp CastRun x - - -- APP - , do pExpApp c - ] - - "an expression" - - --- Applications. -pExpApp :: Context Name -> Parser Name (Exp SP) -pExpApp c - = do xps <- liftM concat $ P.many1 (pArgSPs c) - let (xs, sps) = unzip xps - let sp1 : _ = sps - - case xs of - [x] -> return x - _ -> return $ XDefix sp1 xs - - "an expression or application" - - --- Comp, Witness or Spec arguments. -pArgSPs :: Context Name -> Parser Name [(Exp SP, SP)] -pArgSPs c - = P.choice - -- [Type] - [ do sp <- pTokSP KSquareBra - t <- pType c - pTok KSquareKet - return [(XType sp t, sp)] - - -- [: Type0 Type0 ... :] - , do sp <- pTokSP KSquareColonBra - ts <- P.many1 (pTypeAtom c) - pTok KSquareColonKet - return [(XType sp t, sp) | t <- ts] - - -- { Witness } - , do sp <- pTokSP KBraceBra - w <- pWitness c - pTok KBraceKet - return [(XWitness sp w, sp)] - - -- {: Witness0 Witness0 ... :} - , do sp <- pTokSP KBraceColonBra - ws <- P.many1 (pWitnessAtom c) - pTok KBraceColonKet - return [(XWitness sp w, sp) | w <- ws] - - -- Exp0 - , do (x, sp) <- pExpAtomSP c - return [(x, sp)] - ] - "a type, witness or expression argument" - - --- | Parse a variable, constructor or parenthesised expression. -pExpAtom :: Context Name -> Parser Name (Exp SP) -pExpAtom c - = do (x, _) <- pExpAtomSP c - return x - - --- | Parse a variable, constructor or parenthesised expression, --- also returning source position. -pExpAtomSP :: Context Name -> Parser Name (Exp SP, SP) -pExpAtomSP c - = P.choice - [ -- ( Exp2 ) - do sp <- pTokSP KRoundBra - t <- pExp c - pTok KRoundKet - return (t, sp) - - -- Infix operator used as a variable. - , do (str, sp) <- pOpVarSP - return (XInfixVar sp str, sp) - - -- Infix operator used nekkid. - , do (str, sp) <- pOpSP - return (XInfixOp sp str, sp) - - -- The unit data constructor. - , do sp <- pTokSP KDaConUnit - return (XCon sp dcUnit, sp) - - -- Named algebraic constructors. - , do (con, sp) <- pConSP - return (XCon sp (DaConBound con), sp) - - -- Literals. - -- We just fill-in the type with tBot for now, and leave it to - -- the spreader to attach the real type. - -- We also set the literal as being algebraic, which may not be - -- true (as for Floats). The spreader also needs to fix this. - , do (lit, sp) <- pLitSP - return (XCon sp (DaConPrim lit (T.tBot T.kData)), sp) - - , do (tx, sp) <- pStringSP - let Just mkString = contextMakeStringName c - let lit = mkString sp tx - return (XCon sp (DaConPrim lit (T.tBot T.kData)), sp) - - -- Primitive names. - , do (nPrim, sp) <- pPrimValSP - return (XPrim sp nPrim, sp) - - -- Named variables. - , do (sVar, sp) <- pVarStringSP - return (XVar sp (T.UName (NameVar sVar)), sp) - - -- Debruijn indices - , do (i, sp) <- pIndexSP - return (XVar sp (T.UIx i), sp) - - ] - - "a variable, constructor, or parenthesised type" - - --- Alternatives ----------------------------------------------------------------------------------- --- Case alternatives. -pAlt :: Context Name -> Parser Name (Alt SP) -pAlt c - = do p <- pPat c - P.choice - [ do -- Desugar case guards while we're here. - spgxs <- P.many1 (pGuardedExpSP c (pTokSP KArrowDash)) - let gxs = map snd spgxs - return $ AAlt p gxs - - , do pTok KArrowDash - x <- pExp c - return $ AAlt p [GExp x] ] - - --- Patterns. -pPat :: Context Name -> Parser Name (Pat SP) -pPat c - = P.choice - [ -- Wildcard - do pTok KUnderscore - return $ PDefault - - -- Lit - , do nLit <- pLit - return $ PData (DaConPrim nLit (T.tBot T.kData)) [] - - -- 'Unit' - , do pTok KDaConUnit - return $ PData dcUnit [] - - -- Con Bind Bind ... - , do nCon <- pCon - bs <- P.many (pBindPat c) - return $ PData (DaConBound nCon) bs] - - --- Binds in patterns can have no type annotation, --- or can have an annotation if the whole thing is in parens. -pBindPat :: Context Name -> Parser Name Bind -pBindPat c - = 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 (KOp ":") - t <- pType c - pTok KRoundKet - return $ T.makeBindFromBinder b t - ] - - --- Guards ----------------------------------------------------------------------------------------- --- | Parse some guards and auto-desugar them to a case-expression. -pBindGuardsAsCaseSP - :: Context Name - -> Parser Name (SP, Exp SP) - -pBindGuardsAsCaseSP c - = do - (sp, g) : spgs - <- P.many1 (pGuardedExpSP c (pTokSP KEquals)) - - -- Desugar guards. - -- If none match then raise a runtime error. - let xx' = desugarGuards sp (g : map snd spgs) - $ xErrorDefault sp - (Text.pack $ sourcePosSource sp) - (fromIntegral $ sourcePosLine sp) - - return (sp, xx') - - -pMatchGuardsAsCase - :: SP -> Context Name - -> Parser Name (Exp SP) - -pMatchGuardsAsCase sp c - = do gg <- liftM (map snd) - $ P.sepEndBy1 (pGuardedExpSP c (pTokSP KEquals)) - (pTok KSemiColon) - - -- Desugar guards. - -- If none match then raise a runtime error. - let xx' = desugarGuards sp gg - $ xErrorDefault sp - (Text.pack $ sourcePosSource sp) - (fromIntegral $ sourcePosLine sp) - - return xx' - - --- | An guarded expression, --- like | EXP1 = EXP2. -pGuardedExpSP - :: Context Name -- ^ Parser context. - -> Parser Name SP -- ^ Parser for char between and of guards and exp. - -- usually -> or = - -> Parser Name (SP, GuardedExp SP) - -pGuardedExpSP c pTermSP - = pGuardExp (pTokSP KBar) - - where pGuardExp pSepSP - = P.choice - [ do sp <- pSepSP - g <- pGuard - gx <- liftM snd $ pGuardExp (pTokSP KComma) - return (sp, GGuard g gx) - - , do sp <- pTermSP - x <- pExp c - return (sp, GExp x) ] - - pGuard - = P.choice - [ P.try $ - do p <- pPat c - pTok KArrowDashLeft - x <- pExp c - return $ GPat p x - - , do g <- pExp c - return $ GPred g - - - , do pTok KOtherwise - return GDefault ] - - --- Bindings --------------------------------------------------------------------------------------- -pLetsSP :: Context Name -> Parser Name (Lets SP, SP) -pLetsSP c - = P.choice - [ -- non-recursive let - do sp <- pTokSP KLet - l <- liftM fst $ pClauseSP c - return (LGroup [l], sp) - - -- recursive let - , do sp <- pTokSP KLetRec - pTok KBraceBra - ls <- liftM (map fst) - $ P.sepEndBy1 (pClauseSP c) (pTok KSemiColon) - pTok KBraceKet - return (LGroup ls, sp) - - -- Private region binding. - -- private Binder+ (with { Binder : Type ... })? in Exp - , do sp <- pTokSP KPrivate - - -- new private region names. - brs <- P.manyTill pBinder - $ P.try $ P.lookAhead $ P.choice [pTok KIn, pTok KWith] - - let bs = map (flip T.makeBindFromBinder T.kRegion) brs - - -- Witness types. - r <- pLetWits c bs Nothing - return (r, sp) - - -- Extend an existing region. - -- extend Binder+ using Type (with { Binder : Type ...})? in Exp - , do sp <- pTokSP KExtend - - -- parent region - t <- pType c - pTok KUsing - - -- new private region names. - brs <- P.manyTill pBinder - $ P.try $ P.lookAhead - $ P.choice [pTok KUsing, pTok KWith, pTok KIn] - - let bs = map (flip T.makeBindFromBinder T.kRegion) brs - - -- witness types - r <- pLetWits c bs (Just t) - return (r, sp) - ] - - -pLetWits :: Context Name - -> [Bind] -> Maybe (T.Type Name) - -> Parser Name (Lets SP) - -pLetWits c bs mParent - = P.choice - [ do pTok KWith - pTok KBraceBra - wits <- P.sepBy (P.choice - [ -- Named witness binder. - do b <- pBinder - pTok (KOp ":") - t <- pTypeApp c - return $ T.makeBindFromBinder b t - - -- Ambient witness binding, used for capabilities. - , do t <- pTypeApp c - return $ T.BNone t - ]) - (pTok KSemiColon) - pTok KBraceKet - return (LPrivate bs mParent wits) - - , do return (LPrivate bs mParent []) - ] - - --- | A binding for let expression. -pClauseSP :: Context Name - -> Parser Name (Clause SP, SP) - -pClauseSP c - = do b <- pBinder - - P.choice - [ do -- Binding with full type signature. - sp <- pTokSP (KOp ":") - t <- pType c - (_, xBody) <- pBindGuardsAsCaseSP c - return ( SLet sp (T.makeBindFromBinder b t) [] [GExp xBody] - , sp) - - , do -- Non-function binding with no type signature. - sp <- pTokSP KEquals - xBody <- pExp c - let t = T.tBot T.kData - return ( SLet sp (T.makeBindFromBinder b t) [] [GExp xBody] - , sp) - - , do -- Binding using function syntax. - ps <- liftM concat - $ P.many (pBindParamSpec c) - - P.choice - [ do -- Function syntax with a return type. - -- We can make the full type sig for the let-bound variable. - -- Binder Param1 Param2 .. ParamN : Type = Exp - pTok (KOp ":") - tBody <- pType c - (sp, xBody) <- pBindGuardsAsCaseSP c - - let x = expOfParams sp ps xBody - let t = funTypeOfParams c ps tBody - return ( SLet sp (T.makeBindFromBinder b t) [] [GExp x] - , sp) - - -- Function syntax with no return type. - -- We can't make the type sig for the let-bound variable, - -- but we can create lambda abstractions with the given - -- parameter types. - -- Binder Param1 Param2 .. ParamN = Exp - , do (sp, xBody) <- pBindGuardsAsCaseSP c - - let x = expOfParams sp ps xBody - let t = T.tBot T.kData - return ( SLet sp (T.makeBindFromBinder b t) [] [GExp x] - , sp) - ] - ] - - --- Statements ------------------------------------------------------------------------------------- -data Stmt n - = StmtBind SP Bind (Exp SP) - | StmtMatch SP (Pat SP) (Exp SP) (Exp SP) - | StmtNone SP (Exp SP) - - --- | Parse a single statement. -pStmt :: Context Name -> Parser Name (Stmt Name) -pStmt c - = P.choice - [ -- Binder = Exp ; - -- We need the 'try' because a VARIABLE binders can also be parsed - -- as a function name in a non-binding statement. - -- - P.try $ - do br <- pBinder - sp <- pTokSP KEquals - x1 <- pExp c - let t = T.tBot T.kData - let b = T.makeBindFromBinder br t - return $ StmtBind sp b x1 - - -- Pat <- Exp else Exp ; - -- Sugar for a case-expression. - -- We need the 'try' because the PAT can also be parsed - -- as a function name in a non-binding statement. - , P.try $ - do p <- pPat c - sp <- pTokSP KArrowDashLeft - x1 <- pExp c - pTok KElse - x2 <- pExp c - return $ StmtMatch sp p x1 x2 - - -- Exp - , do x <- pExp c - - -- This should always succeed because pExp doesn't - -- parse plain types or witnesses - let Just sp = takeAnnotOfExp x - - return $ StmtNone sp x - ] - - --- | Parse some statements. -pStmts :: Context Name -> Parser Name (Exp SP) -pStmts c - = do stmts <- P.sepEndBy1 (pStmt c) (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 Name] -> Maybe (Exp SP) -makeStmts ss - = case ss of - [StmtNone _ x] - -> Just x - - StmtNone sp x1 : rest - | Just x2 <- makeStmts rest - -> Just $ XLet sp (LLet (T.BNone (T.tBot T.kData)) x1) x2 - - StmtBind sp b x1 : rest - | Just x2 <- makeStmts rest - -> Just $ XLet sp (LLet b x1) x2 - - StmtMatch sp p x1 x2 : rest - | Just x3 <- makeStmts rest - -> Just $ XCase sp x1 - [ AAlt p [GExp x3] - , AAlt PDefault [GExp x2] ] - - _ -> Nothing +{-# LANGUAGE TypeFamilies #-} + +-- | Parser for Source Tetra expressions. +module DDC.Source.Tetra.Parser.Exp + ( pExp + , pExpAppSP + , pExpAtomSP + , pLetsSP, pClauseSP + , pType + , pTypeApp + , pTypeAtomSP) +where +import DDC.Source.Tetra.Parser.Type +import DDC.Source.Tetra.Parser.Witness +import DDC.Source.Tetra.Parser.Base +import DDC.Source.Tetra.Exp +import DDC.Source.Tetra.Prim as S +import DDC.Core.Lexer.Tokens +import Control.Monad.Except +import Data.Maybe +import qualified DDC.Control.Parser as P +import qualified Data.Text as Text + + +type SP = SourcePos + + +-- Exp -------------------------------------------------------------------------------------------- +pExp :: Parser Exp +pExp = fmap snd pExpWhereSP + + +-- An expression that may have a trailing where clause. +pExpWhereSP :: Parser (SP, Exp) +pExpWhereSP + = do (sp1, xx) <- pExpAppSP + + P.choice + [ do -- x where GROUP + sp <- pKey EWhere + pSym SBraceBra + cls <- liftM (map snd) + $ P.sepEndBy1 pClauseSP (pSym SSemiColon) + pSym SBraceKet + return (sp1, XWhere sp xx cls) + + , do return (sp1, xx) ] + + +-- An application of a function to its arguments, +-- or a plain expression with no arguments. +pExpAppSP :: Parser (SP, Exp) +pExpAppSP + = do (spF, (xF, xsArg)) <- pExpAppsSP + case xsArg of + [] -> return (spF, xF) + _ -> return (spF, XDefix spF (xF : xsArg)) + + "an expression or application" + + +-- An application of a function to its arguments, +-- or a plan expression with no arguments. +pExpAppsSP :: Parser (SP, (Exp, [Exp])) +pExpAppsSP + = do (spF, xFun) <- pExpFrontSP + xsArg <- pExpArgsSP pExpAtomSP + return (spF, (xFun, xsArg)) + + +-- A list of arguments. +pExpArgsSP :: Parser (SP, Exp) -> Parser [Exp] +pExpArgsSP pX + = P.choice + [ do -- After an infix operator we allow the next expression + -- to be a compound expression rather than an atom. + -- This allows code like (f x $ λy. g x y) as in Haskell. + (UName txOp, sp) <- pBoundNameOpSP + xsMore <- pExpArgsSP pExpFrontSP + return (XInfixOp sp (Text.unpack txOp) : xsMore) + + -- Some arguments. + , do (_, xsArg) <- pExpArgsSpecSP pX + xsMore <- pExpArgsSP pExpAtomSP + return (xsArg ++ xsMore) + + -- No more arguments. + , do return [] + ] + + +-- Comp, Witness or Spec arguments. +pExpArgsSpecSP :: Parser (SP, Exp) -> Parser (SP, [Exp]) +pExpArgsSpecSP pX + = P.choice + -- [Type] + [ do sp <- pSym SSquareBra + t <- pType + pSym SSquareKet + return (sp, [XType t]) + + -- [: Type0 Type0 ... :] + , do sp <- pSym SSquareColonBra + ts <- fmap (fst . unzip) $ P.many1 pTypeAtomSP + pSym SSquareColonKet + return (sp, [XType t | t <- ts]) + + -- { Witness } + , do sp <- pSym SBraceBra + w <- pWitness + pSym SBraceKet + return (sp, [XWitness w]) + + -- {: Witness0 Witness0 ... :} + , do sp <- pSym SBraceColonBra + ws <- P.many1 pWitnessAtom + pSym SBraceColonKet + return (sp, [XWitness w | w <- ws]) + + -- Exp0 + , do (sp, x) <- pX + return (sp, [x]) + ] + "a type, witness or expression argument" + + +-- | Parse a compound Source Tetra expression. +-- The first token determines the form of the expression. +pExpFrontSP :: Parser (SP, Exp) +pExpFrontSP + = P.choice + + -- Level-0 lambda abstractions + -- \(x1 x2 ... : Type) (y1 y2 ... : Type) ... . Exp + -- \x1 x2 : Type. Exp + -- \x1 x2. Exp + [ do sp <- P.choice + [ pSym SLambda + , pSym SBackSlash ] + + pts <- P.choice + [ P.try + $ fmap concat $ P.many1 + $ do pSym SRoundBra + ps <- P.many1 pPat + pTok (KOp ":") + t <- pType + pSym SRoundKet + return [(p, Just t) | p <- ps] + + , do ps <- P.many1 pPatAtom + return [(p, Nothing) | p <- ps] + ] + + pSym SArrowDashRight + xBody <- pExp + return (sp, XAnnot sp $ foldr (\(p, mt) -> XLamPat sp p mt) xBody pts) + + + -- Level-1 lambda abstractions. + -- /\(x1 x2 ... : Type) (y1 y2 ... : Type) ... . Exp + , do sp <- P.choice + [ pSym SBigLambda + , pSym SBigLambdaSlash ] + + bs <- P.choice + [ fmap concat $ P.many1 + $ do pSym SRoundBra + bs' <- P.many1 pBind + pTok (KOp ":") + t <- pType + pSym SRoundKet + return $ map (\b -> XBindVarMT b (Just t)) bs' + + , do bs' <- P.many1 pBind + return $ map (\b -> XBindVarMT b Nothing) bs' + ] + + pSym SArrowDashRight + xBody <- pExp + return (sp, XAnnot sp $ foldr XLAM xBody bs) + + + -- let expression + , do (lts, sp) <- pLetsSP + pTok (KKeyword EIn) + x2 <- pExp + return (sp, XAnnot sp $ XLet lts x2) + + + -- Sugar for a let-expression. + -- do { Stmt;+ } + , do sp <- pKey EDo + pSym SBraceBra + xx <- pStmts + pSym SBraceKet + return (sp, xx) + + + -- case Exp of { Alt;+ } + , do sp <- pKey ECase + x <- pExp + pKey EOf + pSym SBraceBra + alts <- P.sepEndBy1 pAltCase (pSym SSemiColon) + pSym SBraceKet + return (sp, XAnnot sp $ XCase x alts) + + + -- match { | EXP = EXP | EXP = EXP ... } + -- Sugar for cascaded case expressions case-expression. + , do sp <- pKey EMatch + pSym SBraceBra + + gxs <- liftM (map (AAltMatch . snd)) + $ P.sepEndBy1 (pGuardedExpSP (pSym SEquals)) + (pSym SSemiColon) + + let xError + = makeXErrorDefault + (Text.pack $ sourcePosSource sp) + (fromIntegral $ sourcePosLine sp) + + pSym SBraceKet + return (sp, XAnnot sp $ XMatch sp gxs xError) + + + , do -- if-then-else + -- Sugar for a case-expression. + sp <- pTokSP (KKeyword EIf) + x1 <- pExp + pTok (KKeyword EThen) + x2 <- pExp + pTok (KKeyword EElse) + x3 <- pExp + return (sp, XAnnot sp $ XCase x1 + [ AAltCase PTrue [GExp x2] + , AAltCase PDefault [GExp x3]]) + + + -- weakeff [Type] in Exp + , do sp <- pTokSP (KKeyword EWeakEff) + pSym SSquareBra + t <- pType + pSym SSquareKet + pKey EIn + x <- pExp + return (sp, XAnnot sp $ XCast (CastWeakenEffect t) x) + + + -- purify Witness in Exp + , do sp <- pKey EPurify + w <- pWitness + pTok (KKeyword EIn) + x <- pExp + return (sp, XAnnot sp $ XCast (CastPurify w) x) + + + -- box Exp + , do sp <- pKey EBox + x <- pExp + return (sp, XAnnot sp $ XCast CastBox x) + + + -- run Exp + , do sp <- pKey ERun + x <- pExp + return (sp, XAnnot sp $ XCast CastRun x) + + -- ATOM + , do pExpAtomSP + ] + "an expression" + + +-- | Parse a variable, constructor or parenthesised expression, +-- also returning source position. +pExpAtomSP :: Parser (SP, Exp) +pExpAtomSP + = P.choice + [ + -- ( Exp2 ) + do pSym SRoundBra + (sp, t) <- pExpWhereSP + pSym SRoundKet + return (sp, t) + + -- Infix operator used as a variable. + , do (UName tx, sp) <- pBoundNameOpVarSP + return (sp, XInfixVar sp (Text.unpack tx)) + + -- Infix operator used nekkid. + , do (UName tx, sp) <- pBoundNameOpSP + return (sp, XInfixOp sp (Text.unpack tx)) + + -- The unit data constructor. + , do sp <- pTokSP (KBuiltin BDaConUnit) + return (sp, XCon dcUnit) + + -- Named algebraic constructors. + , do (con, sp) <- pDaConBoundNameSP + return (sp, XCon (DaConBound con)) + + -- Literals. + -- We just fill-in the type with a hole for now, and leave it to + -- We also set the literal as being algebraic, which may not be + -- true (as for Floats). The spreader also needs to fix this. + , do (lit, sp) <- pDaConBoundLitSP + return (sp, XCon (DaConPrim lit (TVar UHole))) + + -- Primitive names. + , do (nPrim, sp) <- pPrimValSP + return (sp, XPrim nPrim) + + -- Named variables. + , do (u, sp) <- pBoundNameSP + return (sp, XVar u) + + -- Debruijn indices + , do (u, sp) <- pBoundIxSP + return (sp, XVar u) + + ] + "a variable, constructor, or parenthesised type" + + +-- Alternatives ----------------------------------------------------------------------------------- +-- Case alternatives. +pAltCase :: Parser AltCase +pAltCase + = do p <- pPat + P.choice + [ do -- Desugar case guards while we're here. + spgxs <- P.many1 (pGuardedExpSP (pSym SArrowDashRight)) + let gxs = map snd spgxs + return $ AAltCase p gxs + + , do pSym SArrowDashRight + x <- pExp + return $ AAltCase p [GExp x] ] + + +-- Patterns. +pPat :: Parser Pat +pPat + = P.choice + [ -- Con Bind Bind ... + do nCon <- pDaConBoundName + ps <- P.many pPatAtom + return $ PData (DaConBound nCon) ps + + -- Atom + , do p <- pPatAtom + return p + ] + "a pattern" + + +pPatAtom :: Parser Pat +pPatAtom + = P.choice + [ do -- ( PAT ) + pSym SRoundBra + p <- pPat + pSym SRoundKet + return $ p + + -- Wildcard + -- Try this case before the following one for binders + -- so that '_' is parsed as the default pattern, + -- rather than a wildcard binder. + , do pSym SUnderscore + return $ PDefault + + -- Var + , do b <- pBind + P.choice + [ do _ <- pSym SAt + p <- pPatAtom + return $ PAt b p + + , do return $ PVar b + ] + + -- Lit + , do nLit <- pDaConBoundLit + return $ PData (DaConPrim nLit (TBot S.KData)) [] + + -- Named algebraic constructors. + , do nCon <- pDaConBoundName + return $ PData (DaConBound nCon) [] + + -- 'Unit' + , do pTok (KBuiltin BDaConUnit) + return $ PData dcUnit [] + ] + "a pattern" + + +-- Bindings --------------------------------------------------------------------------------------- +pLetsSP :: Parser (Lets, SP) +pLetsSP + = P.choice + [ -- non-recursive let + do sp <- pKey ELet + l <- liftM snd $ pClauseSP + return (LGroup [l], sp) + + -- recursive let + , do sp <- pKey ELetRec + pSym SBraceBra + ls <- liftM (map snd) + $ P.sepEndBy1 pClauseSP (pSym SSemiColon) + pSym SBraceKet + return (LGroup ls, sp) + + -- Private region binding. + -- private Binder+ (with { Binder : Type ... })? in Exp + , do sp <- pKey EPrivate + + -- new private region names. + bs <- P.manyTill pBind + $ P.try + $ P.lookAhead + $ P.choice [pKey EIn, pKey EWith] + + -- Witness types. + r <- pLetWits bs Nothing + return (r, sp) + + -- Extend an existing region. + -- extend Binder+ using Type (with { Binder : Type ...})? in Exp + , do sp <- pTokSP (KKeyword EExtend) + + -- parent region + t <- pType + pTok (KKeyword EUsing) + + -- new private region names. + bs <- P.manyTill pBind + $ P.try $ P.lookAhead + $ P.choice + [ pTok (KKeyword EUsing) + , pTok (KKeyword EWith) + , pTok (KKeyword EIn) ] + + -- witness types + r <- pLetWits bs (Just t) + return (r, sp) + ] + + +pLetWits :: [Bind] -> Maybe Type -> Parser Lets +pLetWits bs mParent + = P.choice + [ do pKey EWith + pSym SBraceBra + wits <- P.sepBy (P.choice + [ -- Named witness binder. + do b <- pBind + pTok (KOp ":") + t <- pTypeApp + return (b, t) + + -- Ambient witness binding, used for capabilities. + , do t <- pTypeApp + return (BNone, t) + ]) + (pSym SSemiColon) + pSym SBraceKet + return (LPrivate bs mParent wits) + + , do return (LPrivate bs mParent []) + ] + + +-- | A binding for let expression. +pClauseSP :: Parser (SP, Clause) +pClauseSP + = do -- Name of the binding. + (b, sp0) <- pBindNameSP + + P.choice + [ do -- Either + -- 1) a definition with a signature and some clauses. + -- foo : Nat -> Nat = ... + -- 2) foo : Nat -> Nat + -- + _ <- pTokSP (KOp ":") + t <- pType + P.choice + [ do + gxs <- pTermGuardedExps (pSym SEquals) + return (sp0, SLet sp0 (XBindVarMT b (Just t)) [] gxs) + + , do return (sp0, SSig sp0 b t) + ] + + , do -- Non-function binding with no type signature. + gxs <- pTermGuardedExps (pSym SEquals) + return (sp0, SLet sp0 (XBindVarMT b Nothing) [] gxs) + + , do -- Binding using function syntax. + ps <- fmap concat $ P.many pParamsSP + + 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 + sp <- pTokSP (KOp ":") + tBody <- pType + gxs <- pTermGuardedExps (pSym SEquals) + + let t = funTypeOfParams ps tBody + return (sp, SLet sp (XBindVarMT b (Just t)) ps gxs) + + -- Function syntax with no return type. + -- We can't make the type sig for the let-bound variable. + , do gxs <- pTermGuardedExps (pSym SEquals) + return (sp0, SLet sp0 (XBindVarMT b Nothing) ps gxs) + ] + ] + + +-- Function parameters. +pParamsSP :: Parser [Param] +pParamsSP + = P.choice + -- Type parameter + -- [BIND1 BIND2 .. BINDN : TYPE] + [ do pSym SSquareBra + bs <- P.many1 pBind + pTok (KOp ":") + t <- pType + pSym SSquareKet + return [ MType b (Just t) | b <- bs] + + -- Witness parameter + -- {BIND : TYPE} + , do pSym SBraceBra + b <- pBind + pTok (KOp ":") + t <- pType + pSym SBraceKet + return [ MWitness b (Just t) ] + + -- Value pattern with type annotations. + -- (BIND1 BIND2 .. BINDN : TYPE) + , do pSym SRoundBra + ps <- P.choice + [ P.try $ do + ps <- P.many1 pPatAtom + pTok (KOp ":") + t <- pType + return [ MValue p (Just t) | p <- ps ] + + , do p <- pPat + return [ MValue p Nothing ] + ] + + pSym SRoundKet + return ps + + + , do -- Value parameter without a type annotation. + p <- pPatAtom + return [MValue p Nothing] + ] + "a function parameter" + + +-- and the type of the body. +funTypeOfParams + :: [Param] -- ^ Spec of parameters. + -> Type -- ^ Type of body. + -> Type -- ^ Type of whole function. + +funTypeOfParams [] tBody + = tBody + +funTypeOfParams (p:ps) tBody + = case p of + MType b mt + -> let k = fromMaybe (TBot S.KData) mt + in TApp (TCon (TyConForall k)) (TAbs b k $ funTypeOfParams ps tBody) + + MWitness _ mt + -> let k = fromMaybe (TBot S.KData) mt + in TImpl k $ funTypeOfParams ps tBody + + MValue _ mt + -> let k = fromMaybe (TBot S.KData) mt + in TFun k $ funTypeOfParams ps tBody + + + +-- Guards ----------------------------------------------------------------------------------------- +-- | Parse either the terminating char and a single expression, +-- or some guarded expressions. +pTermGuardedExps + :: Parser SP -- ^ Parser for char between guards and exp + -> Parser [GuardedExp] + +pTermGuardedExps pTerm + = P.choice + [ do _ <- pTerm + xBody <- pExp + return [GExp xBody] + + , do fmap (map snd) + $ P.many1 $ pGuardedExpSP pTerm + ] + + +-- | An guarded expression, +-- like | EXP1 = EXP2. +pGuardedExpSP + :: Parser SP -- ^ Parser for char between and of guards and exp. + -- usually -> or = + -> Parser (SP, GuardedExp) + +pGuardedExpSP pTermSP + = pGuardExp (pSym SBar) + + where pGuardExp pSepSP + = P.choice + [ do sp <- pSepSP + g <- pGuard + gx <- liftM snd $ pGuardExp (pSym SComma) + return (sp, GGuard g gx) + + , do sp <- pTermSP + x <- pExp + return (sp, GExp x) ] + + pGuard + = P.choice + [ P.try $ + do p <- pPat + pSym SArrowDashLeft + x <- pExp + return $ GPat p x + + , do g <- pExp + return $ GPred g + + , do pKey EOtherwise + return GDefault ] + + +-- Statements ------------------------------------------------------------------------------------- +-- These are statements inside a do expression. +-- +-- A 'do' block behaves much the same way as a 'let' expression, +-- except we can write effectful statements without binding the +-- result to anything. +-- +-- We currently desugar do expressions to let-expressions in the parser. +-- + +-- | Represent a statement inside a do block. +data Stmt + -- | Let-binding or type signature. + = StmtClause SP Clause + + -- | Case match. + | StmtMatch SP Pat Exp Exp + + -- | Plain statement without binding the result. + | StmtNone SP Exp + + +-- | Parse a single statement. +pStmt :: Parser Stmt +pStmt + = P.choice + [ -- Clause; + -- We need the 'try' because the function and argument names at the front + -- of a clause can also be parsed as a function application in a statement. + P.try $ + do (sp, c) <- pClauseSP + return $ StmtClause sp c + + -- 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 + sp <- pSym SArrowDashLeft + x1 <- pExp + pTok (KKeyword EElse) + x2 <- pExp + return $ StmtMatch sp p x1 x2 + + -- Exp + , do (sp, x) <- pExpWhereSP + return $ StmtNone sp x + ] + + +-- | Parse some statements. +pStmts :: Parser Exp +pStmts + = do -- Parse statements in the block. + stmts <- P.sepEndBy1 pStmt (pSym SSemiColon) + + -- As in Haskell, we require do blocks to end with a statement + -- that gives the overall value. + case makeStmts [] stmts of + Nothing -> P.unexpected "do-block must end with a statement" + Just x -> return x + + +-- | Make an expression from some statements. +-- We collect consecutive clauses into the same clause group, +-- so that we can define functions with multiple clauses at the top +-- level of a 'do' expression. +makeStmts :: [Clause] -> [Stmt] -> Maybe Exp +makeStmts clsAcc ss + = let + -- Wrap the clauses we're carrying around the given + -- body expression. + dropClauses xBody + = case clsAcc of + [] -> xBody + [SLet sp bmt [] [GExp x]] + -> XAnnot sp $ XLet (LLet bmt x) xBody + _ -> XLet (LGroup clsAcc) xBody + in + case ss of + [StmtNone _ x] + -> Just $ dropClauses + $ x + + StmtNone sp x1 : rest + | Just x2 <- makeStmts [] rest + -> Just $ XAnnot sp + $ dropClauses + $ XLet (LLet (XBindVarMT BNone Nothing) x1) x2 + + StmtClause _ cl : rest + -> case clsAcc of + -- Start accumulating successive clauses. + [] -> makeStmts (clsAcc ++ [cl]) rest + + (cl1 : _) + -- If this clause is for the same function as + -- the previous one then we'll collect it into + -- at letrec at this point. + | bindOfClause cl1 == bindOfClause cl + -> makeStmts (clsAcc ++ [cl]) rest + + -- Otherwise make a standard let-expression. + _ | Just x3 <- makeStmts [] rest + -> case cl of + (SLet sp bmt [] [GExp x]) + -> Just $ XAnnot sp + $ dropClauses + $ XLet (LLet bmt x) x3 + + _ -> Nothing + + | otherwise + -> Nothing + + + StmtMatch sp p x1 x2 : rest + | Just x3 <- makeStmts [] rest + -> Just $ XAnnot sp + $ dropClauses + $ XCase x1 + [ AAltCase p [GExp x3] + , AAltCase PDefault [GExp x2] ] + + _ -> Nothing + diff --git a/DDC/Source/Tetra/Parser/Module.hs b/DDC/Source/Tetra/Parser/Module.hs --- a/DDC/Source/Tetra/Parser/Module.hs +++ b/DDC/Source/Tetra/Parser/Module.hs @@ -8,66 +8,58 @@ -- * Top-level things , pTop) where -import DDC.Source.Tetra.Parser.Exp -import DDC.Source.Tetra.Compounds -import DDC.Source.Tetra.DataDef -import DDC.Source.Tetra.Module -import DDC.Source.Tetra.Prim -import DDC.Source.Tetra.Exp.Annot -import DDC.Core.Lexer.Tokens -import DDC.Base.Pretty +import DDC.Source.Tetra.Parser.Exp as S +import DDC.Source.Tetra.Parser.Base as S +import DDC.Source.Tetra.Module as S +import DDC.Source.Tetra.DataDef as S +import DDC.Source.Tetra.Exp as S +import DDC.Core.Lexer.Tokens as K +import DDC.Data.Pretty import Control.Monad -import qualified DDC.Type.Exp as T -import qualified DDC.Base.Parser as P -import DDC.Base.Parser (()) +import qualified DDC.Control.Parser as P +import qualified Data.Text as Text import DDC.Core.Parser - ( Parser - , Context (..) - , pModuleName - , pName - , pVar - , pTok, pTokSP) - -type SP = P.SourcePos + ( pModuleName + , pName) -- Module ----------------------------------------------------------------------------------------- -- | Parse a source tetra module. -pModule :: Context Name -> Parser Name (Module (Annot SP)) -pModule c +pModule :: Parser (Module Source) +pModule = do - _sp <- pTokSP KModule + _sp <- pTokSP (KKeyword EModule) name <- pModuleName "a module name" -- export { VAR;+ } tExports <- P.choice - [do pTok KExport - pTok KBraceBra - vars <- P.sepEndBy1 pVar (pTok KSemiColon) - pTok KBraceKet - return vars + [ do pKey EExport + pSym SBraceBra + vars <- P.sepEndBy1 pBoundName (pSym SSemiColon) + pSym SBraceKet + return vars - , return []] + , return []] -- import { SIG;+ } tImports - <- liftM concat $ P.many (pImportSpecs c) + <- liftM concat $ P.many pImportSpecs -- top-level declarations. tops <- P.choice - [do pTok KWhere - pTok KBraceBra + [ do pKey EWhere + pSym SBraceBra - -- TOP;+ - tops <- P.sepEndBy (pTop c) (pTok KSemiColon) + -- TOP;+ + tops <- P.sepEndBy pTop (pSym SSemiColon) - pTok KBraceKet - return tops + pSym SBraceKet + return tops - ,do return [] ] + , do return [] ] -- ISSUE #295: Check for duplicate exported names in module parser. @@ -85,174 +77,186 @@ -- | Parse a type signature. -pTypeSig :: Context Name -> Parser Name (Name, T.Type Name) -pTypeSig c - = do var <- pVar +pTypeSig :: Parser (Bind, Type) +pTypeSig + = do (b, _) <- pBindNameSP pTokSP (KOp ":") - t <- pType c - return (var, t) + t <- pType + return (b, t) --------------------------------------------------------------------------------------------------- -- | An imported foreign type or foreign value. -data ImportSpec n +data ImportSpec = ImportModule ModuleName - | ImportType n (ImportType n) - | ImportCap n (ImportCap n) - | ImportValue n (ImportValue n) + | ImportType TyConBind (ImportType TyConBind Type) + | ImportCap Bind (ImportCap Bind Type) + | ImportValue Bind (ImportValue Bind Type) deriving Show -- | Parse some import specs. -pImportSpecs :: Context Name -> Parser Name [ImportSpec Name] -pImportSpecs c - = do pTok KImport +pImportSpecs :: Parser [ImportSpec] +pImportSpecs + = do pTok (KKeyword EImport) P.choice -- import foreign ... - [ do pTok KForeign + [ do pTok (KKeyword EForeign) src <- liftM (renderIndent . ppr) pName P.choice [ -- import foreign X type (NAME :: TYPE)+ - do pTok KType - pTok KBraceBra - - sigs <- P.sepEndBy1 (pImportType c src) (pTok KSemiColon) - pTok KBraceKet + do pKey EType + pSym SBraceBra + sigs <- P.sepEndBy1 (pImportType src) (pSym SSemiColon) + pSym SBraceKet return sigs -- import foreign X capability (NAME :: TYPE)+ - , do pTok KCapability - pTok KBraceBra - - sigs <- P.sepEndBy1 (pImportCapability c src) (pTok KSemiColon) - pTok KBraceKet + , do pKey ECapability + pSym SBraceBra + sigs <- P.sepEndBy1 (pImportCapability src) (pSym SSemiColon) + pSym SBraceKet return sigs -- import foreign X value (NAME :: TYPE)+ - , do pTok KValue - pTok KBraceBra - - sigs <- P.sepEndBy1 (pImportValue c src) (pTok KSemiColon) - pTok KBraceKet + , do pKey EValue + pSym SBraceBra + sigs <- P.sepEndBy1 (pImportValue src) (pSym SSemiColon) + pSym SBraceKet return sigs ] - , do pTok KBraceBra - names <- P.sepEndBy1 pModuleName (pTok KSemiColon) - "module names" - pTok KBraceKet + , do pSym SBraceBra + names <- P.sepEndBy1 pModuleName (pSym SSemiColon) + "module names" + pSym SBraceKet return [ImportModule n | n <- names] ] -- | Parse a type import spec. -pImportType :: Context Name -> String -> Parser Name (ImportSpec Name) -pImportType c src +pImportType :: String -> Parser ImportSpec +pImportType src | "abstract" <- src - = do n <- pName + = do b <- pTyConBindName pTokSP (KOp ":") - k <- pType c - return (ImportType n (ImportTypeAbstract k)) + k <- pType + return (ImportType b (ImportTypeAbstract k)) - | "boxed" <- src - = do n <- pName + | "boxed" <- src + = do b <- pTyConBindName pTokSP (KOp ":") - k <- pType c - return (ImportType n (ImportTypeBoxed k)) + k <- pType + return (ImportType b (ImportTypeBoxed k)) | otherwise = P.unexpected "import mode for foreign type" -- | Parse a capability import. -pImportCapability :: Context Name -> String -> Parser Name (ImportSpec Name) -pImportCapability c src +pImportCapability :: String -> Parser ImportSpec +pImportCapability src | "abstract" <- src - = do n <- pName + = do (b, _) <- pBindNameSP pTokSP (KOp ":") - t <- pType c - return (ImportCap n (ImportCapAbstract t)) + t <- pType + return (ImportCap b (ImportCapAbstract t)) | otherwise = P.unexpected "import mode for foreign capability" -- | Parse a value import spec. -pImportValue :: Context Name -> String -> Parser Name (ImportSpec Name) -pImportValue c src +pImportValue :: String -> Parser ImportSpec +pImportValue src | "c" <- src - = do n <- pName + = do (b@(BName n), _) <- pBindNameSP pTokSP (KOp ":") - k <- pType c + k <- pType -- ISSUE #327: Allow external symbol to be specified -- with foreign C imports and exports. - let symbol = renderIndent (ppr n) + let symbol = renderIndent (text $ Text.unpack n) - return (ImportValue n (ImportValueSea symbol k)) + return (ImportValue b (ImportValueSea symbol k)) | otherwise = P.unexpected "import mode for foreign value" -- Top Level -------------------------------------------------------------------------------------- -pTop :: Context Name -> Parser Name (Top (Annot SP)) -pTop c +pTop :: Parser (Top Source) +pTop = P.choice [ do -- A top-level, possibly recursive binding. - (l, sp) <- pClauseSP c + (sp, l) <- pClauseSP return $ TopClause sp l -- A data type declaration - , do pData c + , do pDataDef + + -- A type binding + , do pTypeDef ] -- Data ------------------------------------------------------------------------------------------- -- | Parse a data type declaration. -pData :: Context Name -> Parser Name (Top (Annot SP)) -pData c - = do sp <- pTokSP KData - n <- pName - ps <- liftM concat $ P.many (pDataParam c) +pDataDef :: Parser (Top Source) +pDataDef + = do sp <- pTokSP (KKeyword EData) + b <- pTyConBindName + ps <- liftM concat $ P.many pTypeParam P.choice [ -- Data declaration with constructors that have explicit types. - do pTok KWhere - pTok KBraceBra - ctors <- P.sepEndBy1 (pDataCtor c) (pTok KSemiColon) - pTok KBraceKet - return $ TopData sp (DataDef n ps ctors) + do pKey EWhere + pSym SBraceBra + ctors <- P.sepEndBy1 pDataCtor (pSym SSemiColon) + pSym SBraceKet + return $ TopData sp (DataDef b ps ctors) -- Data declaration with no data constructors. - , do return $ TopData sp (DataDef n ps []) + , do return $ TopData sp (DataDef b ps []) ] - --- | Parse a type parameter to a data type. -pDataParam :: Context Name -> Parser Name [Bind] -pDataParam c - = do pTok KRoundBra - ns <- P.many1 pName - pTokSP (KOp ":") - k <- pType c - pTok KRoundKet - return [T.BName n k | n <- ns] - - -- | Parse a data constructor declaration. -pDataCtor :: Context Name -> Parser Name (DataCtor Name) -pDataCtor c - = do n <- pName +pDataCtor :: Parser (DataCtor Source) +pDataCtor + = do n <- pDaConBindName pTokSP (KOp ":") - t <- pType c - let (tsArg, tResult) - = takeTFunArgResult t + t <- pType + let (tsArg, tResult) = takeTFuns t return $ DataCtor { dataCtorName = n , dataCtorFieldTypes = tsArg , dataCtorResultType = tResult } + + +-- Type ------------------------------------------------------------------------------------------- +pTypeDef :: Parser (Top Source) +pTypeDef + = do sp <- pKey EType + bType <- pTyConBindName + bsParam <- liftM concat $ P.many pTypeParam + _ <- pSym SEquals + tBody <- pType + + return $ TopType sp bType + $ foldr (\(b, k) t -> TAbs b k t) tBody bsParam + + +-- | Parse a type parameter to a data type or type function. +pTypeParam :: Parser [(Bind, Type)] +pTypeParam + = do pSym SRoundBra + bs <- fmap (fst . unzip) $ P.many1 pBindNameSP + pTokSP (KOp ":") + k <- pType + pSym SRoundKet + return [(b, k) | b <- bs] + diff --git a/DDC/Source/Tetra/Parser/Param.hs b/DDC/Source/Tetra/Parser/Param.hs --- a/DDC/Source/Tetra/Parser/Param.hs +++ b/DDC/Source/Tetra/Parser/Param.hs @@ -2,33 +2,125 @@ -- | Desugaring of function parameter syntax in Source Tetra. module DDC.Source.Tetra.Parser.Param ( ParamSpec (..) + , expOfParams , funTypeOfParams , pBindParamSpec - , expOfParams) + , pBindParamSpecAnnot) where -import DDC.Source.Tetra.Exp.Annot -import DDC.Core.Parser - ( ParamSpec(..) - , funTypeOfParams - , pBindParamSpec) +import DDC.Source.Tetra.Parser.Base +import DDC.Source.Tetra.Parser.Type +import DDC.Source.Tetra.Exp.Source +import Data.Maybe +import DDC.Core.Lexer.Tokens as K +import qualified DDC.Control.Parser as P +-- | Specification of a function parameter. +-- We can determine the contribution to the type of the function, +-- as well as its expression based on the parameter. +data ParamSpec + = ParamType Bind (Maybe Type) + | ParamWitness Bind (Maybe Type) + | ParamValue Bind (Maybe Type) + + -- | Build the expression of a function from specifications of its parameters, -- and the expression for the body. expOfParams - :: a - -> [ParamSpec Name] -- ^ Spec of parameters. - -> Exp a -- ^ Body of function. - -> Exp a -- ^ Expression of whole function. + :: [ParamSpec] -- ^ Spec of parameters. + -> Exp -- ^ Body of function. + -> Exp -- ^ Expression of whole function. -expOfParams _ [] xBody = xBody -expOfParams a (p:ps) xBody +expOfParams [] xBody = xBody +expOfParams (p:ps) xBody = case p of - ParamType b - -> XLAM a b $ expOfParams a ps xBody + ParamType b mt + -> XLAM (XBindVarMT b mt) $ expOfParams ps xBody - ParamWitness b - -> XLam a b $ expOfParams a ps xBody + ParamWitness b mt + -> XLam (XBindVarMT b mt) $ expOfParams ps xBody - ParamValue b _ _ - -> XLam a b $ expOfParams a ps xBody + ParamValue b mt + -> XLam (XBindVarMT b mt) $ expOfParams ps xBody + + +-- | Build the type of a function from specifications of its parameters, +-- and the type of the body. +funTypeOfParams + :: [ParamSpec] -- ^ Spec of parameters. + -> Type -- ^ Type of body. + -> Type -- ^ Type of whole function. + +funTypeOfParams [] tBody + = tBody + +funTypeOfParams (p:ps) tBody + = case p of + ParamType b mt + -> let k = fromMaybe (TBot KData) mt + in TApp (TCon (TyConForall k)) (TAbs b k $ funTypeOfParams ps tBody) + + ParamWitness _ mt + -> TImpl (fromMaybe (TBot KData) mt) + $ funTypeOfParams ps tBody + + ParamValue _ mt + -> TFun (fromMaybe (TBot KData) mt) + $ funTypeOfParams ps tBody + + +-- | Parse a function parameter specification, +-- with an optional type (or kind) annotation. +pBindParamSpec :: Parser [ParamSpec] +pBindParamSpec + = P.choice + [ -- Value (or type) binder with a type (or kind) annotation. + pBindParamSpecAnnot + + -- Value binder without type annotations. + , do b <- pBind + return $ [ ParamValue b Nothing ] + ] + + +-- | Parse a function parameter specification, +-- requiring a full type (or kind) annotation. +--- +-- [BIND1 BIND2 .. BINDN : TYPE] +-- or (BIND : TYPE) +-- or (BIND : TYPE) { EFFECT | CLOSURE } +-- +pBindParamSpecAnnot :: Parser [ParamSpec] +pBindParamSpecAnnot + = P.choice + -- Type parameter + -- [BIND1 BIND2 .. BINDN : TYPE] + [ do pSym SSquareBra + bs <- P.many1 pBind + pTok (K.KOp ":") + t <- pType + pSym SSquareKet + return [ ParamType b (Just t) | b <- bs] + + -- Witness parameter + -- {BIND : TYPE} + , do pSym SBraceBra + b <- pBind + pTok (K.KOp ":") + t <- pType + pSym SBraceKet + return [ ParamWitness b (Just t) ] + + -- Value parameter with type annotations. + -- (BIND1 BIND2 .. BINDN : TYPE) + -- (BIND1 BIND2 .. BINDN : TYPE) { TYPE | TYPE } + , do pSym SRoundBra + bs <- P.many1 pBind + pTok (K.KOp ":") + t <- pType + pSym SRoundKet + + return $ [ ParamValue b (Just t) | b <- bs ] + ] + + diff --git a/DDC/Source/Tetra/Parser/Type.hs b/DDC/Source/Tetra/Parser/Type.hs new file mode 100644 --- /dev/null +++ b/DDC/Source/Tetra/Parser/Type.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE TypeFamilies #-} +module DDC.Source.Tetra.Parser.Type + ( pBind + , pType + , pTypeUnion + , pTypeApp + , pTypeAtomSP + , pTyConSP + , pTyConBound) +where +import DDC.Source.Tetra.Parser.Base as S +import DDC.Source.Tetra.Exp.Source as S +import DDC.Source.Tetra.Prim.TyConTetra as S +import DDC.Core.Lexer.Tokens as K +import qualified DDC.Source.Tetra.Lexer as SL + +import qualified DDC.Core.Tetra as C +import qualified DDC.Control.Parser as P +import qualified Data.Text as T + + +-- | Parse a binder. +pBind :: Parser Bind +pBind + = P.choice + -- Named binders. + [ do (b, _) <- pBindNameSP + return $ b + + -- Anonymous binders. + , do pSym SHat + return $ BAnon + + -- Vacant binders. + , do pSym SUnderscore + return $ BNone ] + "a binder" + + +-- | Parse a type. +pType :: Parser Type +pType = pTypeUnion + + +-- | Parse a type union. +pTypeUnion :: Parser Type +pTypeUnion + = do t1 <- pTypeForall + P.choice + [ -- Type sums. + -- T2 + T3 + do sp <- pTokSP (KOp "+") + t2 <- pTypeUnion + return $ TAnnot sp $ TUnion KEffect t1 t2 + + , do return t1 ] + "a type" + + +-- | Parse a quantified type. +pTypeForall :: Parser Type +pTypeForall + = P.choice + [ -- Universal quantification. + -- [v1 v1 ... vn : T1]. T2 + do pSym SSquareBra + bs <- P.many1 pBind + sp <- pTokSP (KOp ":") + kBind <- pTypeUnion + pSym SSquareKet + pSym SDot + + tBody <- pTypeForall + return $ foldr (\b t -> TAnnot sp + $ TApp (TCon (TyConForall kBind)) + (TAbs b kBind t)) + tBody bs + + -- Body type + , do pTypeFun + ] + "a type" + + +-- | Parse a function type. +pTypeFun :: Parser Type +pTypeFun + = do t1 <- pTypeApp + P.choice + [ -- T1 ~> T2 + do sp <- pSym SArrowTilde + t2 <- pTypeForall + return $ TAnnot sp $ TFun t1 t2 + + -- T1 => T2 + , do sp <- pSym SArrowEquals + t2 <- pTypeForall + return $ TAnnot sp $ TImpl t1 t2 + + -- T1 -> T2 + , do sp <- pSym SArrowDashRight + t2 <- pTypeForall + return $ TAnnot sp $ TFun t1 t2 + + -- Body type + , do return t1 + ] + "an atomic type or type application" + + +-- | Parse a type application. +pTypeApp :: Parser Type +pTypeApp + = do ((t, _):ts) <- P.many1 pTypeAtomSP + return $ foldl (\t1 (t2, sp) -> TAnnot sp (TApp t1 t2)) t ts + "an atomic type or type application" + + +-- | Parse a variable, constructor or parenthesised type. +pTypeAtomSP :: Parser (Type, SourcePos) +pTypeAtomSP + = P.choice + -- (~>) and (=>) and (->) and (TYPE2) + [ -- (~>) + do sp <- pTokSP $ KOpVar "~>" + return (TAnnot sp $ TCon TyConFun, sp) + + -- (=>) + , do sp <- pTokSP $ KOpVar "=>" + return (TAnnot sp $ TCon (TyConPrim (PrimTypeTwCon TwConImpl)), sp) + + -- (->) + , do sp <- pTokSP $ KOpVar "->" + return (TAnnot sp $ TCon TyConFun, sp) + + -- (TYPE2) + , do sp <- pSym SRoundBra + t <- pTypeUnion + pSym SRoundKet + return (t, sp) + + -- Named type constructors + , do (tc, sp) <- pTyConSP + return (TAnnot sp $ TCon tc, sp) + + -- Bottoms. + , do sp <- pTokSP (KBuiltin BPure) + return (TAnnot sp $ TBot KEffect, sp) + + -- 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 (u, sp) <- pBoundNameSP + return (TAnnot sp $ TVar u, sp) + + , do (u, sp) <- pBoundIxSP + return (TAnnot sp $ TVar u, sp) + ] + "an atomic type" + + +-- | Parse a type constructor. +pTyConSP :: Parser (TyCon, SourcePos) +pTyConSP = P.pTokMaybeSP f "a type constructor" + where f kk + = case kk of + -- Primitive Ambient TyCons. + KA (KBuiltin (BSoCon c)) + -> Just $ TyConPrim $ PrimTypeSoCon c + + KA (KBuiltin (BKiCon c)) + -> Just $ TyConPrim $ PrimTypeKiCon c + + KA (KBuiltin (BTwCon c)) + -> Just $ TyConPrim $ PrimTypeTwCon c + + KA (KBuiltin (BTcCon c)) + -> Just $ TyConPrim $ PrimTypeTcCon c + + -- Primitive TyCons. + KN (KCon (SL.NamePrimType tc)) + -> Just $ TyConPrim tc + + -- User Bound TyCons. + KN (KCon (SL.NameCon tx)) + -> Just (TyConBound (TyConBoundName tx)) + + _ -> Nothing + + +-- | Parse a bound type constructor. +-- Known primitive type constructors do not match. +pTyConBound :: Parser TyCon +pTyConBound + = P.pTokMaybe f "a bound type constructor" + where + f :: Token SL.Name -> Maybe TyCon + f (KN (KCon (SL.NameCon tx))) + | Nothing <- C.readPrimTyCon (T.unpack tx) + , Nothing <- S.readPrimTyConTetra (T.unpack tx) + = Just (TyConBound (TyConBoundName tx)) + + f _ = Nothing + diff --git a/DDC/Source/Tetra/Parser/Witness.hs b/DDC/Source/Tetra/Parser/Witness.hs --- a/DDC/Source/Tetra/Parser/Witness.hs +++ b/DDC/Source/Tetra/Parser/Witness.hs @@ -4,97 +4,86 @@ , pWitnessApp , pWitnessAtom) where -import DDC.Source.Tetra.Prim -import DDC.Source.Tetra.Exp.Annot -import DDC.Core.Parser - ( Parser - , Context (..) - , pType - , pConSP - , pIndexSP - , pVarSP - , pTok - , pTokSP) - -import DDC.Core.Lexer.Tokens -import DDC.Base.Parser ((), SourcePos) -import qualified DDC.Base.Parser as P -import qualified DDC.Type.Exp as T -import qualified DDC.Type.Compounds as T +import DDC.Source.Tetra.Parser.Type +import DDC.Source.Tetra.Parser.Base +import DDC.Source.Tetra.Exp.Source import Control.Monad.Except +import DDC.Core.Lexer.Tokens as K +import qualified DDC.Control.Parser as P type SP = SourcePos -- | Parse a witness expression. -pWitness :: Context Name -> Parser Name (Witness SP) -pWitness c = pWitnessJoin c +pWitness :: Parser Witness +pWitness = pWitnessJoin -- | Parse a witness join. -pWitnessJoin :: Context Name -> Parser Name (Witness SP) -pWitnessJoin c +pWitnessJoin :: Parser Witness +pWitnessJoin -- WITNESS or WITNESS & WITNESS - = do w1 <- pWitnessApp c + = do w1 <- pWitnessApp P.choice [ do return w1 ] -- | Parse a witness application. -pWitnessApp :: Context Name -> Parser Name (Witness SP) -pWitnessApp c - = do (x:xs) <- P.many1 (pWitnessArgSP c) +pWitnessApp :: Parser Witness +pWitnessApp + = do (x:xs) <- P.many1 pWitnessArgSP let x' = fst x let sp = snd x let xs' = map fst xs - return $ foldl (WApp sp) x' xs' + return $ foldl (\w1 w2 -> WAnnot sp $ WApp w1 w2) x' xs' "a witness expression or application" -- | Parse a witness argument. -pWitnessArgSP :: Context Name -> Parser Name (Witness SP, SP) -pWitnessArgSP c +pWitnessArgSP :: Parser (Witness, SP) +pWitnessArgSP = P.choice [ -- [TYPE] - do sp <- pTokSP KSquareBra - t <- pType c - pTok KSquareKet - return (WType sp t, sp) + do sp <- pSym SSquareBra + t <- pType + pSym SSquareKet + return (WAnnot sp $ WType t, sp) -- WITNESS - , do pWitnessAtomSP c ] + , do pWitnessAtomSP ] -- | Parse a variable, constructor or parenthesised witness. -pWitnessAtom :: Context Name -> Parser Name (Witness SP) -pWitnessAtom c - = liftM fst (pWitnessAtomSP c) +pWitnessAtom :: Parser Witness +pWitnessAtom = liftM fst pWitnessAtomSP -- | Parse a variable, constructor or parenthesised witness, -- also returning source position. -pWitnessAtomSP :: Context Name -> Parser Name (Witness SP, SP) -pWitnessAtomSP c +pWitnessAtomSP :: Parser (Witness, SP) +pWitnessAtomSP = P.choice -- (WITNESS) - [ do sp <- pTokSP KRoundBra - w <- pWitness c - pTok KRoundKet + [ do sp <- pSym SRoundBra + w <- pWitness + pSym SRoundKet return (w, sp) -- Named constructors - , do (con, sp) <- pConSP - return (WCon sp (WiConBound (T.UName con) (T.tBot T.kWitness)), sp) + , do (DaConBoundName n, sp) <- pDaConBoundNameSP + return ( WAnnot sp $ WCon (WiConBound (UName n) (TBot KData)) + , sp) -- Debruijn indices - , do (i, sp) <- pIndexSP - return (WVar sp (T.UIx i), sp) + , do (u, sp) <- pBoundIxSP + return ( WAnnot sp $ WVar u, sp) -- Variables - , do (var, sp) <- pVarSP - return (WVar sp (T.UName var), sp) ] + , do (u, sp) <- pBoundNameSP + return ( WAnnot sp $ WVar u, sp) + ] "a witness" diff --git a/DDC/Source/Tetra/Predicates.hs b/DDC/Source/Tetra/Predicates.hs deleted file mode 100644 --- a/DDC/Source/Tetra/Predicates.hs +++ /dev/null @@ -1,132 +0,0 @@ - --- | Simple predicates on Source Tetra things. -module DDC.Source.Tetra.Predicates - ( module DDC.Type.Predicates - - -- * Atoms - , isXVar, isXCon - , isAtomX, isAtomW - - -- * Lambdas - , isXLAM, isXLam - , isLambdaX - - -- * Applications - , isXApp - - -- * Let bindings - , isXLet - - -- * Types and Witnesses - , isXType - , isXWitness - - -- * Patterns - , isPDefault) -where -import DDC.Source.Tetra.Exp.Generic -import DDC.Type.Predicates - - --- Atoms ---------------------------------------------------------------------- --- | Check whether an expression is a variable. -isXVar :: GExp l -> Bool -isXVar xx - = case xx of - XVar{} -> True - _ -> False - - --- | Check whether an expression is a constructor. -isXCon :: GExp l -> Bool -isXCon xx - = case xx of - XCon{} -> True - _ -> False - - --- | Check whether an expression is a `XVar` or an `XCon`, --- or some type or witness atom. -isAtomX :: GExp l -> Bool -isAtomX xx - = case xx of - XVar{} -> True - XCon{} -> True - XType _ t -> isAtomT t - XWitness _ w -> isAtomW w - _ -> False - - --- | Check whether a witness is a `WVar` or `WCon`. -isAtomW :: GWitness l -> Bool -isAtomW ww - = case ww of - WVar{} -> True - WCon{} -> True - _ -> False - - --- Lambdas -------------------------------------------------------------------- --- | Check whether an expression is a spec abstraction (level-1). -isXLAM :: GExp l -> Bool -isXLAM xx - = case xx of - XLAM{} -> True - _ -> False - - --- | Check whether an expression is a value or witness abstraction (level-0). -isXLam :: GExp l -> Bool -isXLam xx - = case xx of - XLam{} -> True - _ -> False - - --- | Check whether an expression is a spec, value, or witness abstraction. -isLambdaX :: GExp l -> Bool -isLambdaX xx - = isXLAM xx || isXLam xx - - --- Applications --------------------------------------------------------------- --- | Check whether an expression is an `XApp`. -isXApp :: GExp l -> Bool -isXApp xx - = case xx of - XApp{} -> True - _ -> False - - --- Let Bindings --------------------------------------------------------------- --- | Check whether an expression is a `XLet`. -isXLet :: GExp l -> Bool -isXLet xx - = case xx of - XLet{} -> True - _ -> False - - --- Type and Witness ----------------------------------------------------------- --- | Check whether an expression is an `XType` -isXType :: GExp l -> Bool -isXType xx - = case xx of - XType{} -> True - _ -> False - - --- | Check whether an expression is an `XWitness` -isXWitness :: GExp l -> Bool -isXWitness xx - = case xx of - XWitness{} -> True - _ -> False - - --- Patterns ------------------------------------------------------------------- --- | Check whether an alternative is a `PDefault`. -isPDefault :: GPat l -> Bool -isPDefault PDefault = True -isPDefault _ = False - diff --git a/DDC/Source/Tetra/Pretty.hs b/DDC/Source/Tetra/Pretty.hs --- a/DDC/Source/Tetra/Pretty.hs +++ b/DDC/Source/Tetra/Pretty.hs @@ -3,24 +3,103 @@ -- | Pretty printing for Tetra modules and expressions. module DDC.Source.Tetra.Pretty ( module DDC.Core.Pretty - , module DDC.Base.Pretty + , module DDC.Data.Pretty , PrettyLanguage) where -import DDC.Source.Tetra.Predicates +import DDC.Source.Tetra.Exp.Predicates import DDC.Source.Tetra.DataDef import DDC.Source.Tetra.Module -import DDC.Source.Tetra.Exp +import DDC.Source.Tetra.Exp.Source +import DDC.Type.Exp.Generic.Pretty import DDC.Core.Pretty -import DDC.Base.Pretty -import Prelude hiding ((<$>)) +import DDC.Data.Pretty +import Prelude hiding ((<$>)) +import qualified Data.Text as Text type PrettyLanguage l - = ( Eq (GName l) - , Pretty (GAnnot l), Pretty (GName l) - , Pretty (GBound l), Pretty (GBind l), Pretty (GPrim l)) + = ( Pretty l + , Pretty (GTAnnot l) + , Pretty (GTBindVar l), Pretty (GTBoundVar l) + , Pretty (GTBindCon l), Pretty (GTBoundCon l) + , Pretty (GTPrim l) + , Pretty (GXAnnot l) + , Pretty (GXBindVar l), Pretty (GXBoundVar l) + , Pretty (GXBindCon l), Pretty (GXBoundCon l) + , Pretty (GXPrim l) + , Pretty (DaCon (GXBoundCon l) (GType l))) + +instance Pretty Bind where + ppr bb + = case bb of + BNone -> text "_" + BAnon -> text "^" + BName t -> text (Text.unpack t) + + +instance Pretty Bound where + ppr uu + = case uu of + UIx i -> int i + UName t -> text (Text.unpack t) + UHole -> text "?" + + +instance Pretty DaConBind where + ppr (DaConBindName tt) = text (Text.unpack tt) + + +instance Pretty DaConBound where + ppr uu + = case uu of + DaConBoundName tt -> text (Text.unpack tt) + DaConBoundLit pl -> ppr pl + + +instance Pretty TyConBind where + ppr (TyConBindName tx) = text (Text.unpack tx) + + +instance Pretty TyConBound where + ppr (TyConBoundName tx) = text (Text.unpack tx) + + +-- Bind ------------------------------------------------------------------------------------------- +instance PrettyLanguage l => Pretty (GXBindVarMT l) where + ppr (XBindVarMT b mt) + = case mt of + Nothing -> ppr b + Just _t -> ppr b + + +-- Type ------------------------------------------------------------------------------------------- +instance PrettyLanguage l => Pretty (GType l) where + pprPrec d tt + = case tt of + TAnnot _ t -> pprPrec d t + TCon tc -> ppr tc + TVar bv -> ppr bv + + TAbs bv k t + -> text "λ" <> ppr bv <> text ":" <+> ppr k <> text "." <+> ppr t + + TApp (TApp (TCon TyConFun) t1) t2 + -> pprParen' (d > 5) + $ pprPrec 6 t1 <+> text "->" <+> pprPrec 5 t2 + + TApp t1 t2 + -> pprParen' (d > 10) + $ pprPrec 10 t1 <+> pprPrec 11 t2 + + + +instance PrettyLanguage l => Pretty (GTyCon l) where + ppr tc + = pprRawC tc + + -- Module ----------------------------------------------------------------------------------------- instance PrettyLanguage l => Pretty (Module l) where ppr Module @@ -56,12 +135,14 @@ -- Top -------------------------------------------------------------------------------------------- instance PrettyLanguage l => Pretty (Top l) where - ppr (TopClause _ c) = ppr c + ppr (TopClause _ c) + = ppr c + <> semi <> line ppr (TopData _ (DataDef name params ctors)) = (text "data" <+> hsep ( ppr name - : map (parens . ppr) params) + : map pprParam params) <+> text "where" <+> lbrace) <$> indent 8 @@ -72,20 +153,30 @@ ++ [ ppr (dataCtorResultType ctor)])) <> semi | ctor <- ctors ]) + <> line <> rbrace <> semi <> line - <> rbrace + ppr (TopType _ b t) + = text "type" <+> ppr b <+> text "=" <+> ppr t + <> semi + <> line +pprParam (b, t) + = parens $ ppr b <> text ":" <+> ppr t + + -- Exp -------------------------------------------------------------------------------------------- instance PrettyLanguage l => Pretty (GExp l) where pprPrec d xx = {-# SCC "ppr[Exp]" #-} case xx of - XVar _ u -> ppr u - XCon _ dc -> ppr dc - XPrim _ u -> ppr u + XAnnot _ x -> pprPrec d x + + XVar u -> ppr u + XCon dc -> ppr dc + XPrim u -> ppr u - XLAM _ b xBody + XLAM b xBody -> pprParen' (d > 1) $ text "/\\" <> ppr b <> text "." <> (if isXLAM xBody then empty @@ -94,56 +185,91 @@ else line) <> ppr xBody - XLam _ b xBody + XLam b xBody -> pprParen' (d > 1) $ text "\\" <> ppr b <> text "." <> breakWhen (not $ isSimpleX xBody) <> ppr xBody - XApp _ x1 x2 + XApp x1 x2 -> pprParen' (d > 10) $ pprPrec 10 x1 <> nest 4 (breakWhen (not $ isSimpleX x2) <> pprPrec 11 x2) - XLet _ lts x + XLet lts x -> pprParen' (d > 2) $ ppr lts <+> text "in" <$> ppr x - XCase _ x alts + XCase x alts -> pprParen' (d > 2) $ (nest 2 $ text "case" <+> ppr x <+> text "of" <+> lbrace <> line <> (vcat $ punctuate semi $ map ppr alts)) <> line <> rbrace - XCast _ CastBox x + XCast CastBox x -> pprParen' (d > 2) $ text "box" <$> ppr x - XCast _ CastRun x + XCast CastRun x -> pprParen' (d > 2) $ text "run" <+> ppr x - XCast _ cc x + XCast cc x -> pprParen' (d > 2) $ ppr cc <+> text "in" <$> ppr x - XType _ t -> text "[" <> ppr t <> text "]" - XWitness _ w -> text "<" <> ppr w <> text ">" + XType t -> text "[" <> ppr t <> text "]" + XWitness w -> text "<" <> ppr w <> text ">" - XDefix _ xs + XDefix _ xs -> text "[" <> text "DEFIX|" <+> hsep (map (pprPrec 11) xs) <+> text "]" - XInfixOp _ str + XInfixOp _ str -> parens $ text "INFIXOP" <+> text "\"" <> text str <> text "\"" XInfixVar _ str -> parens $ text "INFIXVAR" <+> text "\"" <> text str <> text "\"" + XMatch _ alts xDefault + -> pprParen' (d > 2) + $ (nest 2 $ text "match" <+> lbrace <> line + <> (vcat $ punctuate (semi <> line) $ map ppr alts)) + <> line + <> rbrace + <+> text "else" <+> pprPrec 10 xDefault + XWhere _ x cls + -> pprParen' (d > 2) + $ ppr x + <+> line + <> (text "where" + <+> text "{" <> line + <> (nest 4 $ vcat $ map ppr cls) + <> line + <> text "}") + + XLamPat _ p mt xBody + -> pprParen' (d > 1) + $ text "\\" + <> pprPrec 2 p + <> (case mt of + Just t -> text ": " <> ppr t + Nothing -> empty) + <> text "." + <> breakWhen (not $ isSimpleX xBody) + <> ppr xBody + + XLamCase _ alts + -> pprParen' (d > 1) + $ text "λcase." <> lbrace <> line + <> (vcat $ punctuate semi $ map ppr alts) + <> line <> rbrace + + -- Lets ------------------------------------------------------------------------------------------- instance PrettyLanguage l => Pretty (GLets l) where ppr lts @@ -191,7 +317,11 @@ <+> braces (cat $ punctuate (text "; ") $ map ppr bsWit) LGroup cs - -> vcat $ map ppr cs + -> text "letgroup" + <+> nest 2 (lbrace + <> line + <> (vcat $ map ppr cs) + <> line <> rbrace) -- Clause ----------------------------------------------------------------------------------------- @@ -200,29 +330,51 @@ = ppr b <+> text ":" <+> ppr t ppr (SLet _ b ps [GExp x]) - = ppr b <+> hsep (map ppr ps) + = ppr b <+> hsep (map (pprPrec 10) ps) <> nest 2 ( breakWhen (not $ isSimpleX x) <> text "=" <+> align (ppr x)) ppr (SLet _ b ps gxs) - = ppr b <+> hsep (map ppr ps) + = ppr b <+> hsep (map (pprPrec 10) ps) <> nest 2 (line <> vcat (map (pprGuardedExp "=") gxs)) --- Alt -------------------------------------------------------------------------------------------- -instance PrettyLanguage l => Pretty (GAlt l) where - ppr (AAlt p gxs) - = ppr p <> nest 2 (line <> vcat (map (pprGuardedExp "->") gxs)) +-- Param ------------------------------------------------------------------------------------------ +instance PrettyLanguage l => Pretty (GParam l) where + pprPrec _d (MType b Nothing) + = text "[" <> ppr b <> text "]" + pprPrec _d (MType b (Just t)) + = text "[" <> ppr b <> text ":" <+> ppr t <> text "]" + pprPrec _d (MWitness b Nothing) + = text "<" <> ppr b <> text ">" + + pprPrec _d (MWitness b (Just t)) + = text "<" <> ppr b <> text ":" <+> ppr t <> text ">" + + pprPrec d (MValue p Nothing) + = pprPrec d p + + pprPrec _ (MValue p (Just t)) + = parens $ pprPrec 0 p <> text ":" <+> ppr t + + -- Pat -------------------------------------------------------------------------------------------- instance PrettyLanguage l => Pretty (GPat l) where - ppr pp + pprPrec d pp = case pp of PDefault -> text "_" - PData u bs -> ppr u <+> sep (map ppr bs) + PAt b p -> ppr b <> text "@" <> ppr p + PVar b -> ppr b + PData u [] -> ppr u + PData u ps + -> pprParen' (d > 1) + $ ppr u <+> sep (map (pprPrec 2) ps) + + -- GuardedExp ------------------------------------------------------------------------------------- pprGuardedExp :: PrettyLanguage l => String -> GGuardedExp l -> Doc pprGuardedExp sTerm gx @@ -246,8 +398,30 @@ -- Guard ------------------------------------------------------------------------------------------ instance PrettyLanguage l => Pretty (GGuard l) where + ppr gg + = case gg of + GPat p w + -> ppr p <+> text "<-" <+> ppr w + GPred p + -> ppr p + GDefault + -> text "otherwise" + + +-- AltCase ---------------------------------------------------------------------------------------- +instance PrettyLanguage l => Pretty (GAltCase l) where + ppr (AAltCase p gxs) + = ppr p <> nest 2 (line <> vcat (map (pprGuardedExp "->") gxs)) + + +-- AltMatch --------------------------------------------------------------------------------------- +instance PrettyLanguage l => Pretty (GAltMatch l) where + ppr (AAltMatch gs) + = pprGuardedExp "=" gs + + -- Cast ------------------------------------------------------------------------------------------- instance PrettyLanguage l => Pretty (GCast l) where ppr cc @@ -262,10 +436,11 @@ instance PrettyLanguage l => Pretty (GWitness l) where pprPrec d ww = case ww of - WVar _ n -> ppr n - WCon _ wc -> ppr wc - WApp _ w1 w2 -> pprParen (d > 10) (ppr w1 <+> pprPrec 11 w2) - WType _ t -> text "[" <> ppr t <> text "]" + WAnnot _ w -> ppr w + WVar n -> ppr n + WCon wc -> ppr wc + WApp w1 w2 -> pprParen (d > 10) (ppr w1 <+> pprPrec 11 w2) + WType t -> text "[" <> ppr t <> text "]" instance PrettyLanguage l => Pretty (GWiCon l) where @@ -274,6 +449,14 @@ WiConBound u _ -> ppr u +instance Pretty n => Pretty (DaCon n t) where + ppr dc + = case dc of + DaConUnit -> text "()" + DaConPrim n _ -> ppr n + DaConBound n -> ppr n + + -- Utils ------------------------------------------------------------------------------------------ breakWhen :: Bool -> Doc breakWhen True = line @@ -283,11 +466,12 @@ isSimpleX :: GExp l -> Bool isSimpleX xx = case xx of + XAnnot _ x -> isSimpleX x XVar{} -> True XCon{} -> True XType{} -> True XWitness{} -> True - XApp _ x1 x2 -> isSimpleX x1 && isAtomX x2 + XApp x1 x2 -> isSimpleX x1 && isAtomX x2 _ -> False @@ -300,3 +484,4 @@ pprParen' b c = if b then parens' c else c + diff --git a/DDC/Source/Tetra/Prim.hs b/DDC/Source/Tetra/Prim.hs --- a/DDC/Source/Tetra/Prim.hs +++ b/DDC/Source/Tetra/Prim.hs @@ -1,51 +1,48 @@ -- | Definitions of Source Tetra primitive names and operators. module DDC.Source.Tetra.Prim - ( -- * Names - Name (..) - - -- * Primitive Names - , PrimName (..) - , pattern NameType - , pattern NameVal - , readName - - -- * Primitive Types - , PrimType (..) - , pattern NameTyCon - , pattern NameTyConTetra + ( -- * Primitive Types + PrimType (..) + , readPrimType -- ** Primitive machine type constructors. , PrimTyCon (..) , kindPrimTyCon - , tBool - , tNat - , tInt - , tSize - , tWord - , tFloat - , tTextLit + , pattern KData + , pattern KRegion + , pattern KEffect + + , pattern TImpl + , pattern TSusp + , pattern TRead + , pattern TWrite + , pattern TAlloc + + , pattern TBool + , pattern TNat + , pattern TInt + , pattern TSize + , pattern TWord + , pattern TFloat + , pattern TTextLit + -- ** Primitive tetra type constructors. , PrimTyConTetra(..) - , pattern NameTyConTetraTuple - , pattern NameTyConTetraF - , pattern NameTyConTetraC - , pattern NameTyConTetraU , kindPrimTyConTetra -- * Primitive values , PrimVal (..) - , pattern NameLit - , pattern NameArith - , pattern NameVector - , pattern NameFun - , pattern NameError + , readPrimVal -- ** Primitive arithmetic operators. , PrimArith (..) , typePrimArith + -- ** Primitive casting operators. + , PrimCast (..) + , typePrimCast + -- ** Primitive vector operators. , OpVector (..) , typeOpVector @@ -57,33 +54,33 @@ -- ** Primitive error handling , OpError (..) , typeOpError + , makeXErrorDefault -- ** Primitive literals , PrimLit (..) - , pattern NameLitBool - , pattern NameLitNat - , pattern NameLitInt - , pattern NameLitSize - , pattern NameLitWord - , pattern NameLitFloat - , pattern NameLitTextLit) + , readPrimLit + , primLitOfLiteral + + , pattern PTrue + , pattern PFalse) where import DDC.Source.Tetra.Prim.Base +import DDC.Source.Tetra.Prim.TyCon import DDC.Source.Tetra.Prim.TyConPrim import DDC.Source.Tetra.Prim.TyConTetra import DDC.Source.Tetra.Prim.OpArith +import DDC.Source.Tetra.Prim.OpCast import DDC.Source.Tetra.Prim.OpFun import DDC.Source.Tetra.Prim.OpVector import DDC.Source.Tetra.Prim.OpError -import DDC.Core.Lexer.Names (isVarStart) -import DDC.Base.Pretty +import DDC.Data.Pretty import Control.DeepSeq -import Data.Char import qualified Data.Text as T import DDC.Core.Tetra ( readPrimTyCon , readPrimArithFlag + , readPrimCastFlag , readOpFun , readOpErrorFlag , readOpVectorFlag) @@ -97,85 +94,26 @@ --------------------------------------------------------------------------------------------------- -instance Pretty Name where - ppr nn - = case nn of - NameVar v -> text v - NameCon c -> text c - NamePrim p -> ppr p - NameHole -> text "?" - - -instance NFData Name where - rnf nn - = case nn of - NameVar s -> rnf s - NameCon s -> rnf s - NamePrim p -> rnf p - NameHole -> () - - --- | Read the name of a variable, constructor or literal. -readName :: String -> Maybe Name -readName str - -- Primitive names. - | Just n <- readPrimName str - = Just $ NamePrim n - - -- Constructors. - | c : _ <- str - , isUpper c - = Just $ NameCon str - - -- Variables. - | c : _ <- str - , isVarStart c - = Just $ NameVar str - - | otherwise - = Nothing - - ---------------------------------------------------------------------------------------------------- -instance Pretty PrimName where - ppr nn - = case nn of - PrimNameType p -> ppr p - PrimNameVal p -> ppr p - - -instance NFData PrimName where - rnf nn - = case nn of - PrimNameType p -> rnf p - PrimNameVal p -> rnf p - - -readPrimName :: String -> Maybe PrimName -readPrimName str - | Just t <- readPrimType str - = Just $ PrimNameType t - - | Just v <- readPrimVal str - = Just $ PrimNameVal v - - | otherwise - = Nothing - - ---------------------------------------------------------------------------------------------------- instance Pretty PrimType where ppr t = case t of - PrimTypeTyConTetra p -> ppr p - PrimTypeTyCon p -> ppr p + PrimTypeSoCon c -> ppr c + PrimTypeKiCon c -> ppr c + PrimTypeTwCon c -> ppr c + PrimTypeTcCon c -> ppr c + PrimTypeTyCon c -> ppr c + PrimTypeTyConTetra c -> ppr c instance NFData PrimType where rnf t = case t of - PrimTypeTyConTetra p -> rnf p - PrimTypeTyCon p -> rnf p + PrimTypeSoCon _ -> () + PrimTypeKiCon _ -> () + PrimTypeTwCon _ -> () + PrimTypeTcCon _ -> () + PrimTypeTyCon c -> rnf c + PrimTypeTyConTetra c -> rnf c -- | Read the name of a primitive type. @@ -195,21 +133,23 @@ instance Pretty PrimVal where ppr val = case val of - PrimValError p -> ppr p - PrimValLit lit -> ppr lit - PrimValArith p -> ppr p - PrimValVector p -> ppr p - PrimValFun p -> ppr p + PrimValError p -> ppr p + PrimValLit lit -> ppr lit + PrimValArith p -> ppr p + PrimValCast p -> ppr p + PrimValVector p -> ppr p + PrimValFun p -> ppr p instance NFData PrimVal where rnf val = case val of - PrimValError p -> rnf p - PrimValLit lit -> rnf lit - PrimValArith p -> rnf p - PrimValVector p -> rnf p - PrimValFun p -> rnf p + PrimValError p -> rnf p + PrimValLit lit -> rnf lit + PrimValArith p -> rnf p + PrimValCast p -> rnf p + PrimValVector p -> rnf p + PrimValFun p -> rnf p -- | Read the name of a primtive value. @@ -224,7 +164,10 @@ | Just (p, False) <- readPrimArithFlag str = Just $ PrimValArith p - | Just (p, False) <- readOpVectorFlag str + | Just (p, False) <- readPrimCastFlag str + = Just $ PrimValCast p + + | Just (p, False) <- readOpVectorFlag str = Just $ PrimValVector p | Just p <- readOpFun str @@ -238,26 +181,28 @@ instance Pretty PrimLit where ppr lit = case lit of - PrimLitBool True -> text "True" - PrimLitBool False -> text "False" - PrimLitNat i -> integer i - PrimLitInt i -> integer i <> text "i" - PrimLitSize s -> integer s <> text "s" - PrimLitWord i bits -> integer i <> text "w" <> int bits - PrimLitFloat f bits -> double f <> text "f" <> int bits - PrimLitTextLit tx -> text (show $ T.unpack tx) + PrimLitBool True -> text "True" + PrimLitBool False -> text "False" + PrimLitNat i -> integer i + PrimLitInt i -> integer i <> text "i" + PrimLitSize s -> integer s <> text "s" + PrimLitWord i bits -> integer i <> text "w" <> int bits + PrimLitFloat f bits -> double f <> text "f" <> int bits + PrimLitChar c -> text (show c) + PrimLitTextLit tx -> text (show $ T.unpack tx) instance NFData PrimLit where rnf lit = case lit of - PrimLitBool b -> rnf b - PrimLitNat n -> rnf n - PrimLitInt i -> rnf i - PrimLitSize s -> rnf s - PrimLitWord i bits -> rnf i `seq` rnf bits - PrimLitFloat d bits -> rnf d `seq` rnf bits - PrimLitTextLit bs -> rnf bs + PrimLitBool b -> rnf b + PrimLitNat n -> rnf n + PrimLitInt i -> rnf i + PrimLitSize s -> rnf s + PrimLitWord i bits -> rnf i `seq` rnf bits + PrimLitFloat d bits -> rnf d `seq` rnf bits + PrimLitChar c -> rnf c + PrimLitTextLit bs -> rnf bs -- | Read the name of a primitive literal. @@ -291,4 +236,5 @@ | otherwise = Nothing + diff --git a/DDC/Source/Tetra/Prim/Base.hs b/DDC/Source/Tetra/Prim/Base.hs --- a/DDC/Source/Tetra/Prim/Base.hs +++ b/DDC/Source/Tetra/Prim/Base.hs @@ -1,41 +1,24 @@ -- | Definition of names used in Source Tetra language. module DDC.Source.Tetra.Prim.Base - ( -- * Names - Name (..) - - -- * Primitive Names - , PrimName (..) - , pattern NameType - , pattern NameVal - - -- * Primitive Types - , PrimType (..) - , pattern NameTyCon - , pattern NameTyConTetra + ( -- * Primitive Types + PrimType (..) -- ** Primitive machine type constructors. , PrimTyCon (..) -- ** Primitive Tetra specific type constructors. , PrimTyConTetra(..) - , pattern NameTyConTetraTuple - , pattern NameTyConTetraVector - , pattern NameTyConTetraF - , pattern NameTyConTetraC - , pattern NameTyConTetraU -- * Primitive Values , PrimVal (..) - , pattern NameLit - , pattern NameArith - , pattern NameVector - , pattern NameFun - , pattern NameError -- ** Primitive arithmetic operators. , PrimArith (..) + -- ** Primitive casting operators. + , PrimCast (..) + -- ** Primitive vector operators. , OpVector (..) @@ -47,67 +30,44 @@ -- ** Primitive literals. , PrimLit (..) - , pattern NameLitBool - , pattern NameLitNat - , pattern NameLitInt - , pattern NameLitSize - , pattern NameLitWord - , pattern NameLitFloat - , pattern NameLitTextLit) + , primLitOfLiteral) where +import DDC.Type.Exp.TyCon +import DDC.Core.Exp.Literal import DDC.Core.Tetra ( OpFun (..) , OpVector (..) , OpError (..) , PrimTyCon (..) - , PrimArith (..)) + , PrimArith (..) + , PrimCast (..)) import Data.Text (Text) --------------------------------------------------------------------------------------------------- --- | Names of things used in Disciple Source Tetra. -data Name - -- | A user defined variable. - = NameVar !String - - -- | A user defined constructor. - | NameCon !String - - -- | Primitive names. - | NamePrim !PrimName - - -- Inference ---------------------------- - -- | A hole used during type inference. - | NameHole - deriving (Eq, Ord, Show) - +-- | Primitive types. +data PrimType + -- | Primitive sort constructors. + = PrimTypeSoCon !SoCon ---------------------------------------------------------------------------------------------------- --- | Primitive names. -data PrimName - = PrimNameType !PrimType - | PrimNameVal !PrimVal - deriving (Eq, Ord, Show) + -- | Primitive kind constructors. + | PrimTypeKiCon !KiCon -pattern NameType p = NamePrim (PrimNameType p) -pattern NameVal p = NamePrim (PrimNameVal p) + -- | Primitive witness type constructors. + | PrimTypeTwCon !TwCon + -- | Other type constructors at the spec level. + | PrimTypeTcCon !TcCon ---------------------------------------------------------------------------------------------------- --- | Primitive types. -data PrimType -- | Primitive machine type constructors. - = PrimTypeTyCon !PrimTyCon + | PrimTypeTyCon !PrimTyCon -- | Primtiive type constructors specific to the Tetra fragment. | PrimTypeTyConTetra !PrimTyConTetra deriving (Eq, Ord, Show) -pattern NameTyCon tc = NamePrim (PrimNameType (PrimTypeTyCon tc)) -pattern NameTyConTetra tc = NamePrim (PrimNameType (PrimTypeTyConTetra tc)) - --------------------------------------------------------------------------------------------------- -- | Primitive type constructors specific to the Tetra language fragment. data PrimTyConTetra @@ -127,13 +87,7 @@ | PrimTyConTetraU deriving (Eq, Ord, Show) -pattern NameTyConTetraTuple i = NameTyConTetra (PrimTyConTetraTuple i) -pattern NameTyConTetraVector = NameTyConTetra PrimTyConTetraVector -pattern NameTyConTetraF = NameTyConTetra PrimTyConTetraF -pattern NameTyConTetraC = NameTyConTetra PrimTyConTetraC -pattern NameTyConTetraU = NameTyConTetra PrimTyConTetraU - --------------------------------------------------------------------------------------------------- -- | Primitive values. data PrimVal @@ -143,6 +97,9 @@ -- | Primitive arithmetic operators. | PrimValArith !PrimArith + -- | Primitive numeric casting operators. + | PrimValCast !PrimCast + -- | Primitive error handling. | PrimValError !OpError @@ -153,13 +110,7 @@ | PrimValFun !OpFun deriving (Eq, Ord, Show) -pattern NameLit p = NamePrim (PrimNameVal (PrimValLit p)) -pattern NameArith p = NamePrim (PrimNameVal (PrimValArith p)) -pattern NameError p = NamePrim (PrimNameVal (PrimValError p)) -pattern NameVector p = NamePrim (PrimNameVal (PrimValVector p)) -pattern NameFun p = NamePrim (PrimNameVal (PrimValFun p)) - --------------------------------------------------------------------------------------------------- data PrimLit -- | A boolean literal. @@ -185,15 +136,23 @@ -- with the given number of bits precision. | PrimLitFloat !Double !Int + -- | A character literal. + | PrimLitChar !Char + -- | Text literals (UTF-8 encoded) | PrimLitTextLit !Text deriving (Eq, Ord, Show) -pattern NameLitBool x = NameLit (PrimLitBool x) -pattern NameLitNat x = NameLit (PrimLitNat x) -pattern NameLitInt x = NameLit (PrimLitInt x) -pattern NameLitSize x = NameLit (PrimLitSize x) -pattern NameLitWord x s = NameLit (PrimLitWord x s) -pattern NameLitFloat x s = NameLit (PrimLitFloat x s) -pattern NameLitTextLit x = NameLit (PrimLitTextLit x) + +-- | Convert a literal to a Tetra name. +primLitOfLiteral :: Literal -> PrimLit +primLitOfLiteral lit + = case lit of + LNat n -> PrimLitNat n + LInt i -> PrimLitInt i + LSize s -> PrimLitSize s + LWord i b -> PrimLitWord i b + LFloat f b -> PrimLitFloat f b + LChar c -> PrimLitChar c + LString tx -> PrimLitTextLit tx diff --git a/DDC/Source/Tetra/Prim/OpArith.hs b/DDC/Source/Tetra/Prim/OpArith.hs --- a/DDC/Source/Tetra/Prim/OpArith.hs +++ b/DDC/Source/Tetra/Prim/OpArith.hs @@ -1,42 +1,47 @@ +{-# LANGUAGE TypeFamilies #-} -- | Types of primitive Source Tetra arithmetic operators. module DDC.Source.Tetra.Prim.OpArith (typePrimArith) where +import DDC.Source.Tetra.Prim.TyCon import DDC.Source.Tetra.Prim.TyConPrim import DDC.Source.Tetra.Prim.Base -import DDC.Type.Compounds -import DDC.Type.Exp +import DDC.Source.Tetra.Exp.Generic +import DDC.Source.Tetra.Exp.Compounds -- | Take the type of a primitive arithmetic operator. -typePrimArith :: PrimArith -> Type Name -typePrimArith op +typePrimArith + :: (Anon l, GTPrim l ~ PrimType) + => l -> PrimArith -> GType l +typePrimArith l op = case op of -- Numeric - PrimArithNeg -> tForall kData $ \t -> t `tFun` t - PrimArithAdd -> tForall kData $ \t -> t `tFun` t `tFun` t - PrimArithSub -> tForall kData $ \t -> t `tFun` t `tFun` t - PrimArithMul -> tForall kData $ \t -> t `tFun` t `tFun` t - PrimArithDiv -> tForall kData $ \t -> t `tFun` t `tFun` t - PrimArithMod -> tForall kData $ \t -> t `tFun` t `tFun` t - PrimArithRem -> tForall kData $ \t -> t `tFun` t `tFun` t + PrimArithNeg -> makeTForall l KData $ \t -> t ~> t + PrimArithAdd -> makeTForall l KData $ \t -> t ~> t ~> t + PrimArithSub -> makeTForall l KData $ \t -> t ~> t ~> t + PrimArithMul -> makeTForall l KData $ \t -> t ~> t ~> t + PrimArithDiv -> makeTForall l KData $ \t -> t ~> t ~> t + PrimArithMod -> makeTForall l KData $ \t -> t ~> t ~> t + PrimArithRem -> makeTForall l KData $ \t -> t ~> t ~> t -- Comparison - PrimArithEq -> tForall kData $ \t -> t `tFun` t `tFun` tBool - PrimArithNeq -> tForall kData $ \t -> t `tFun` t `tFun` tBool - PrimArithGt -> tForall kData $ \t -> t `tFun` t `tFun` tBool - PrimArithLt -> tForall kData $ \t -> t `tFun` t `tFun` tBool - PrimArithLe -> tForall kData $ \t -> t `tFun` t `tFun` tBool - PrimArithGe -> tForall kData $ \t -> t `tFun` t `tFun` tBool + PrimArithEq -> makeTForall l KData $ \t -> t ~> t ~> TBool + PrimArithNeq -> makeTForall l KData $ \t -> t ~> t ~> TBool + PrimArithGt -> makeTForall l KData $ \t -> t ~> t ~> TBool + PrimArithLt -> makeTForall l KData $ \t -> t ~> t ~> TBool + PrimArithLe -> makeTForall l KData $ \t -> t ~> t ~> TBool + PrimArithGe -> makeTForall l KData $ \t -> t ~> t ~> TBool -- Boolean - PrimArithAnd -> tBool `tFun` tBool `tFun` tBool - PrimArithOr -> tBool `tFun` tBool `tFun` tBool + PrimArithAnd -> TBool ~> TBool ~> TBool + PrimArithOr -> TBool ~> TBool ~> TBool -- Bitwise - PrimArithShl -> tForall kData $ \t -> t `tFun` t `tFun` t - PrimArithShr -> tForall kData $ \t -> t `tFun` t `tFun` t - PrimArithBAnd -> tForall kData $ \t -> t `tFun` t `tFun` t - PrimArithBOr -> tForall kData $ \t -> t `tFun` t `tFun` t - PrimArithBXOr -> tForall kData $ \t -> t `tFun` t `tFun` t + PrimArithShl -> makeTForall l KData $ \t -> t ~> t ~> t + PrimArithShr -> makeTForall l KData $ \t -> t ~> t ~> t + PrimArithBAnd -> makeTForall l KData $ \t -> t ~> t ~> t + PrimArithBOr -> makeTForall l KData $ \t -> t ~> t ~> t + PrimArithBXOr -> makeTForall l KData $ \t -> t ~> t ~> t + diff --git a/DDC/Source/Tetra/Prim/OpCast.hs b/DDC/Source/Tetra/Prim/OpCast.hs new file mode 100644 --- /dev/null +++ b/DDC/Source/Tetra/Prim/OpCast.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | Types of primitive Source Tetra arithmetic operators. +module DDC.Source.Tetra.Prim.OpCast + (typePrimCast) +where +import DDC.Source.Tetra.Prim.TyCon +import DDC.Source.Tetra.Prim.Base +import DDC.Source.Tetra.Exp.Generic +import DDC.Source.Tetra.Exp.Compounds + + +-- | Take the type of a primitive arithmetic operator. +typePrimCast + :: (Anon l, GTPrim l ~ PrimType) + => l -> PrimCast -> GType l +typePrimCast l op + = case op of + PrimCastConvert + -> makeTForalls l [KData, KData] + $ \[t1, t2] -> t1 ~> t2 + + PrimCastPromote + -> makeTForalls l [KData, KData] + $ \[t1, t2] -> t1 ~> t2 + + PrimCastTruncate + -> makeTForalls l [KData, KData] + $ \[t1, t2] -> t1 ~> t2 diff --git a/DDC/Source/Tetra/Prim/OpError.hs b/DDC/Source/Tetra/Prim/OpError.hs --- a/DDC/Source/Tetra/Prim/OpError.hs +++ b/DDC/Source/Tetra/Prim/OpError.hs @@ -1,19 +1,16 @@ - +{-# LANGUAGE TypeFamilies #-} module DDC.Source.Tetra.Prim.OpError ( typeOpError) where import DDC.Source.Tetra.Prim.TyConPrim import DDC.Source.Tetra.Prim.Base -import DDC.Type.Compounds -import DDC.Type.Exp - +import DDC.Source.Tetra.Prim.TyCon +import DDC.Source.Tetra.Exp.Compounds -- | Take the type of a primitive error function. -typeOpError :: OpError -> Type Name -typeOpError err +typeOpError l err = case err of OpErrorDefault - -> tForall kData $ \t -> tTextLit `tFun` tNat `tFun` t - + -> makeTForall l KData $ \t -> TTextLit ~> TNat ~> t diff --git a/DDC/Source/Tetra/Prim/OpFun.hs b/DDC/Source/Tetra/Prim/OpFun.hs --- a/DDC/Source/Tetra/Prim/OpFun.hs +++ b/DDC/Source/Tetra/Prim/OpFun.hs @@ -1,69 +1,55 @@ +{-# LANGUAGE TypeFamilies #-} -- | Types of primitive Source Tetra function operators. module DDC.Source.Tetra.Prim.OpFun (typeOpFun) where +import DDC.Source.Tetra.Prim.TyCon import DDC.Source.Tetra.Prim.TyConTetra import DDC.Source.Tetra.Prim.Base -import DDC.Type.Compounds -import DDC.Type.Exp +import DDC.Source.Tetra.Exp.Generic +import DDC.Source.Tetra.Exp.Compounds -- | Take the type of a primitive function operator. -typeOpFun :: OpFun -> Type Name -typeOpFun op +typeOpFun :: (Anon l, GTPrim l ~ PrimType) + => l -> OpFun -> GType l +typeOpFun l op = case op of OpFunCurry n - -> tForalls (replicate (n + 1) kData) - $ \ts -> - let Just tF = tFunOfList ts - Just result = tFunOfList (tF : ts) - in result + -> makeTForalls l (replicate (n + 1) KData) $ \ts + -> let Just tF = makeTFuns' ts + Just result = makeTFuns' (tF : ts) + in result OpFunApply n - -> tForalls (replicate (n + 1) kData) - $ \ts -> - let Just tF = tFunOfList ts - Just result = tFunOfList (tF : ts) - in result + -> makeTForalls l (replicate (n + 1) KData) $ \ts + -> let Just tF = makeTFuns' ts + Just result = makeTFuns' (tF : ts) + in result OpFunCReify - -> tForalls [kData, kData] - $ \[tA, tB] -> (tA `tFun` tB) `tFun` tFunValue (tA `tFun` tB) + -> makeTForalls l [KData, KData] $ \[tA, tB] + -> (tA ~> tB) ~> TFunValue (tA ~> tB) OpFunCCurry n - -> tForalls (replicate (n + 1) kData) - $ \ts -> - let tLast : tsFront' = reverse ts - tsFront = reverse tsFront' - Just tF = tFunOfList ts - Just result - = tFunOfList - ( tFunValue tF - : tsFront ++ [tCloValue tLast]) - in result + -> makeTForalls l (replicate (n + 1) KData) $ \ts + -> let tLast : tsFront' = reverse ts + tsFront = reverse tsFront' + Just tF = makeTFuns' ts + in makeTFuns (TFunValue tF : tsFront) (TCloValue tLast) OpFunCExtend n - -> tForalls (replicate (n + 1) kData) - $ \ts -> - let tLast : tsFront' = reverse ts - tsFront = reverse tsFront' - Just tF = tFunOfList ts - Just result - = tFunOfList - ( tCloValue tF - : tsFront ++ [tCloValue tLast]) - in result + -> makeTForalls l (replicate (n + 1) KData) $ \ts + -> let tLast : tsFront' = reverse ts + tsFront = reverse tsFront' + Just tF = makeTFuns' ts + in makeTFuns (TCloValue tF : tsFront) (TCloValue tLast) OpFunCApply n - -> tForalls (replicate (n + 1) kData) - $ \ts -> - let tLast : tsFront' = reverse ts - tsFront = reverse tsFront' - Just tF = tFunOfList ts - Just result - = tFunOfList - ( tCloValue tF - : tsFront ++ [tLast]) - in result + -> makeTForalls l (replicate (n + 1) KData) $ \ts + -> let tLast : tsFront' = reverse ts + tsFront = reverse tsFront' + Just tF = makeTFuns' ts + in makeTFuns (TCloValue tF : tsFront) tLast diff --git a/DDC/Source/Tetra/Prim/OpVector.hs b/DDC/Source/Tetra/Prim/OpVector.hs --- a/DDC/Source/Tetra/Prim/OpVector.hs +++ b/DDC/Source/Tetra/Prim/OpVector.hs @@ -1,32 +1,33 @@ - +{-# LANGUAGE TypeFamilies #-} -- Types of primitive Source Tetra vector operators. module DDC.Source.Tetra.Prim.OpVector (typeOpVector) where +import DDC.Source.Tetra.Prim.TyCon import DDC.Source.Tetra.Prim.TyConPrim import DDC.Source.Tetra.Prim.TyConTetra import DDC.Source.Tetra.Prim.Base -import DDC.Type.Compounds -import DDC.Type.Exp +import DDC.Source.Tetra.Exp.Generic +import DDC.Source.Tetra.Exp.Compounds -- | Take the type of a primitive vector operator. -typeOpVector :: OpVector -> Type Name -typeOpVector op +typeOpVector :: forall l. (Anon l, GTPrim l ~ PrimType) => l -> OpVector -> GType l +typeOpVector l op = case op of OpVectorAlloc - -> tForalls [kRegion, kData] - $ \[tR, tA] -> tNat `tFun` tSusp (tAlloc tR) (tVector tR tA) + -> makeTForalls l [KRegion, KData] $ \[tR, tA] + -> TSusp (TAlloc tR) (TVector tR tA) OpVectorLength - -> tForalls [kRegion, kData] - $ \[tR, tA] -> tVector tR tA `tFun` tNat + -> makeTForalls l [KRegion, KData] $ \[tR, tA] + -> TVector tR tA ~> TNat OpVectorRead - -> tForalls [kRegion, kData] - $ \[tR, tA] -> tVector tR tA `tFun` tNat `tFun` tSusp (tRead tR) tA + -> makeTForalls l [KRegion, KData] $ \[tR, tA] + -> TVector tR tA ~> TNat ~> TSusp (TRead tR) tA OpVectorWrite - -> tForalls [kRegion, kData] - $ \[tR, tA] -> tVector tR tA `tFun` tNat `tFun` tA `tFun` tSusp (tWrite tR) tVoid + -> makeTForalls l [KRegion, KData] $ \[tR, tA] + -> TVector tR tA ~> TNat ~> tA ~> TSusp (TWrite tR) TVoid diff --git a/DDC/Source/Tetra/Prim/TyCon.hs b/DDC/Source/Tetra/Prim/TyCon.hs new file mode 100644 --- /dev/null +++ b/DDC/Source/Tetra/Prim/TyCon.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TypeFamilies #-} +module DDC.Source.Tetra.Prim.TyCon + ( pattern KData + , pattern KRegion + , pattern KEffect + + , pattern TImpl + , pattern TSusp + , pattern TRead + , pattern TWrite + , pattern TAlloc) +where +import DDC.Source.Tetra.Prim.Base +import DDC.Type.Exp.Generic.Exp +import DDC.Type.Exp.TyCon + + +-- | Representation of the Data kind. +pattern KData = TCon (TyConPrim (PrimTypeKiCon KiConData)) + +-- | Representation of the Region kind. +pattern KRegion = TCon (TyConPrim (PrimTypeKiCon KiConRegion)) + +-- | Representation of the Effect kind. +pattern KEffect = TCon (TyConPrim (PrimTypeKiCon KiConEffect)) + +-- | Representation of an implication type. +pattern TImpl t1 t2 = TApp (TApp (TCon (TyConPrim (PrimTypeTwCon TwConImpl))) t1) t2 + +-- | Representation of a suspension type. +pattern TSusp tE tA = TApp (TApp (TCon (TyConPrim (PrimTypeTcCon TcConSusp))) tE) tA + +-- | Representation of a read effect. +pattern TRead tR = TApp (TCon (TyConPrim (PrimTypeTcCon TcConRead))) tR + +-- | Representation of a write effect. +pattern TWrite tR = TApp (TCon (TyConPrim (PrimTypeTcCon TcConWrite))) tR + +-- | Representation of a alloc effect. +pattern TAlloc tR = TApp (TCon (TyConPrim (PrimTypeTcCon TcConAlloc))) tR + diff --git a/DDC/Source/Tetra/Prim/TyConPrim.hs b/DDC/Source/Tetra/Prim/TyConPrim.hs --- a/DDC/Source/Tetra/Prim/TyConPrim.hs +++ b/DDC/Source/Tetra/Prim/TyConPrim.hs @@ -1,72 +1,87 @@ - +{-# LANGUAGE TypeFamilies #-} -- | Definitions of primitive types for Source Tetra language. module DDC.Source.Tetra.Prim.TyConPrim ( kindPrimTyCon - , tVoid, tBool, tNat, tInt, tSize, tWord, tFloat - , tTextLit) + , pattern TVoid + , pattern TBool + , pattern TNat + , pattern TInt + , pattern TSize + , pattern TWord + , pattern TFloat + , pattern TTextLit + + , pattern PTrue + , pattern PFalse + + , makeXErrorDefault) where import DDC.Source.Tetra.Prim.Base -import DDC.Type.Compounds -import DDC.Type.Exp +import DDC.Source.Tetra.Prim.TyCon +import DDC.Source.Tetra.Exp.Generic +import DDC.Source.Tetra.Exp.Bind +import DDC.Source.Tetra.Exp.Compounds +import Data.Text (Text) -- | Yield the kind of a type constructor. -kindPrimTyCon :: PrimTyCon -> Kind Name +kindPrimTyCon + :: (PrimType ~ GTPrim l) + => PrimTyCon -> GType l + kindPrimTyCon tc = case tc of - PrimTyConVoid -> kData - PrimTyConBool -> kData - PrimTyConNat -> kData - PrimTyConInt -> kData - PrimTyConSize -> kData - PrimTyConWord _ -> kData - PrimTyConFloat _ -> kData - PrimTyConVec _ -> kData `kFun` kData - PrimTyConAddr -> kData - PrimTyConPtr -> kRegion `kFun` kData `kFun` kData - PrimTyConTextLit -> kData - PrimTyConTag -> kData - - --- Compounds ------------------------------------------------------------------ --- | Primitive `Void` type. -tVoid :: Type Name -tVoid = TCon (TyConBound (UPrim (NameTyCon PrimTyConVoid) kData) kData) + PrimTyConVoid -> KData + PrimTyConBool -> KData + PrimTyConNat -> KData + PrimTyConInt -> KData + PrimTyConSize -> KData + PrimTyConWord _ -> KData + PrimTyConFloat _ -> KData + PrimTyConVec _ -> KData ~> KData + PrimTyConAddr -> KData + PrimTyConPtr -> KRegion ~> KData ~> KData + PrimTyConTextLit -> KData + PrimTyConTag -> KData +-- Compounds -------------------------------------------------------------------------------------- -- | Primitive `Bool` type. -tBool :: Type Name -tBool = TCon (TyConBound (UPrim (NameTyCon PrimTyConBool) kData) kData) - +pattern TBool = TCon (TyConPrim (PrimTypeTyCon PrimTyConBool)) -- | Primitive `Nat` type. -tNat :: Type Name -tNat = TCon (TyConBound (UPrim (NameTyCon PrimTyConNat) kData) kData) - +pattern TNat = TCon (TyConPrim (PrimTypeTyCon PrimTyConNat)) -- | Primitive `Int` type. -tInt :: Type Name -tInt = TCon (TyConBound (UPrim (NameTyCon PrimTyConInt) kData) kData) - +pattern TInt = TCon (TyConPrim (PrimTypeTyCon PrimTyConInt)) -- | Primitive `Size` type. -tSize :: Type Name -tSize = TCon (TyConBound (UPrim (NameTyCon PrimTyConSize) kData) kData) - +pattern TSize = TCon (TyConPrim (PrimTypeTyCon PrimTyConSize) ) -- | Primitive `WordN` type of the given width. -tWord :: Int -> Type Name -tWord bits - = TCon (TyConBound (UPrim (NameTyCon (PrimTyConWord bits)) kData) kData) - +pattern TWord bits = TCon (TyConPrim (PrimTypeTyCon (PrimTyConWord bits))) -- | Primitive `FloatN` type of the given width. -tFloat :: Int -> Type Name -tFloat bits - = TCon (TyConBound (UPrim (NameTyCon (PrimTyConFloat bits)) kData) kData) - +pattern TFloat bits = TCon (TyConPrim (PrimTypeTyCon (PrimTyConFloat bits))) -- | Primitive `TextLit` type. -tTextLit :: Type Name -tTextLit - = TCon (TyConBound (UPrim (NameTyCon PrimTyConTextLit) kData) kData) +pattern TTextLit = TCon (TyConPrim (PrimTypeTyCon PrimTyConTextLit)) + + +-- Patterns --------------------------------------------------------------------------------------- +pattern PTrue = PData (DaConPrim (DaConBoundLit (PrimLitBool True)) TBool) [] +pattern PFalse = PData (DaConPrim (DaConBoundLit (PrimLitBool False)) TBool) [] + + +-- Primitives ------------------------------------------------------------------------------------- +makeXErrorDefault + :: ( GXBoundCon l ~ DaConBound + , GXPrim l ~ PrimVal + , GTPrim l ~ PrimType) + => Text -> Integer -> GExp l +makeXErrorDefault name n + = makeXApps + (XPrim (PrimValError OpErrorDefault)) + [ XCon (DaConPrim (DaConBoundLit (PrimLitTextLit name)) (TBot KData)) + , XCon (DaConPrim (DaConBoundLit (PrimLitNat n)) (TBot KData))] + diff --git a/DDC/Source/Tetra/Prim/TyConTetra.hs b/DDC/Source/Tetra/Prim/TyConTetra.hs --- a/DDC/Source/Tetra/Prim/TyConTetra.hs +++ b/DDC/Source/Tetra/Prim/TyConTetra.hs @@ -1,21 +1,24 @@ - +{-# LANGUAGE TypeFamilies #-} -- | Definitions of primitive type constructors for Source Tetra language. module DDC.Source.Tetra.Prim.TyConTetra ( kindPrimTyConTetra , readPrimTyConTetra - , tVector - , tFunValue - , tCloValue) + , pattern TVector + , pattern TFunValue + , pattern TCloValue) where +import DDC.Source.Tetra.Prim.TyCon import DDC.Source.Tetra.Prim.Base -import DDC.Type.Compounds -import DDC.Type.Exp -import DDC.Base.Pretty +import DDC.Source.Tetra.Exp.Generic +import DDC.Source.Tetra.Exp.Compounds + +import DDC.Data.Pretty import Data.Char import Data.List import Control.DeepSeq +--------------------------------------------------------------------------------------------------- instance NFData PrimTyConTetra where rnf !_ = () @@ -30,6 +33,7 @@ PrimTyConTetraU -> text "U#" +--------------------------------------------------------------------------------------------------- -- | Read the name of a baked-in type constructor. readPrimTyConTetra :: String -> Maybe PrimTyConTetra readPrimTyConTetra str @@ -49,33 +53,17 @@ -- | Take the kind of a baked-in data constructor. -kindPrimTyConTetra :: PrimTyConTetra -> Type Name kindPrimTyConTetra tc = case tc of - PrimTyConTetraTuple n -> foldr kFun kData (replicate n kData) - PrimTyConTetraVector -> kRegion `kFun` kData `kFun` kData - PrimTyConTetraF -> kData `kFun` kData - PrimTyConTetraC -> kData `kFun` kData - PrimTyConTetraU -> kData `kFun` kData - - --- Compounds ------------------------------------------------------------------ --- | Primitive `Vector` type. -tVector :: Region Name -> Type Name -> Type Name -tVector tR tA - = tApps (TCon (TyConBound (UPrim (NameTyConTetra PrimTyConTetraVector) k) k)) - [tR, tA] - where k = kRegion `kFun` kData `kFun` kData - - -tFunValue :: Type Name -> Type Name -tFunValue tA - = tApps (TCon (TyConBound (UPrim (NameTyConTetra PrimTyConTetraF) k) k)) [tA] - where k = kData `kFun` kData + PrimTyConTetraTuple n -> foldr (~>) KData (replicate n KData) + PrimTyConTetraVector -> KRegion ~> KData ~> KData + PrimTyConTetraF -> KData ~> KData + PrimTyConTetraC -> KData ~> KData + PrimTyConTetraU -> KData ~> KData -tCloValue :: Type Name -> Type Name -tCloValue tA - = tApps (TCon (TyConBound (UPrim (NameTyConTetra PrimTyConTetraC) k) k)) [tA] - where k = kData `kFun` kData +--------------------------------------------------------------------------------------------------- +pattern TVector tR tA = TApp2 (TCon (TyConPrim (PrimTypeTyConTetra PrimTyConTetraVector))) tR tA +pattern TFunValue tA = TApp (TCon (TyConPrim (PrimTypeTyConTetra PrimTyConTetraF))) tA +pattern TCloValue tA = TApp (TCon (TyConPrim (PrimTypeTyConTetra PrimTyConTetraC))) tA diff --git a/DDC/Source/Tetra/Transform/BoundX.hs b/DDC/Source/Tetra/Transform/BoundX.hs --- a/DDC/Source/Tetra/Transform/BoundX.hs +++ b/DDC/Source/Tetra/Transform/BoundX.hs @@ -1,31 +1,30 @@ {-# LANGUAGE TypeFamilies #-} --- | Lifting and lowering level-0 deBruijn indices in source expressions. +-- | Lifting level-0 deBruijn indices in source expressions. -- -- Level-0 indices are used for both value and witness variables. -- module DDC.Source.Tetra.Transform.BoundX ( liftX, liftAtDepthX --- , lowerX, lowerAtDepthX , MapBoundX (..) , HasAnonBind (..)) where import DDC.Source.Tetra.Exp.Generic -import DDC.Type.Exp +import DDC.Source.Tetra.Exp.Bind --------------------------------------------------------------------------------------------------- class HasAnonBind l => MapBoundX (c :: * -> *) l where mapBoundAtDepthX - :: l -- Proxy for language index, not inspected. - -> (Int -> GBound l -> GBound l) -- Function to apply to current bound occ. - -> Int -- Current binding depth. - -> c l -- Map across bounds in this thing. - -> c l -- Result thing. + :: l -- Proxy for language index, not inspected. + -> (Int -> GXBoundVar l -> GXBoundVar l) -- Function to apply to current bound occ. + -> Int -- Current binding depth. + -> c l -- Map across bounds in this thing. + -> c l -- Result thing. -- Lift ------------------------------------------------------------------------------------------- -- | Lift debruijn indices less than or equal to the given depth. liftAtDepthX - :: (MapBoundX c l, GBound l ~ Bound n) + :: (MapBoundX c l, GXBoundVar l ~ Bound) => l -> Int -- ^ Number of levels to lift. -> Int -- ^ Current binding depth. @@ -38,14 +37,14 @@ liftU d' u = case u of UName{} -> u - UPrim{} -> u UIx i | d' <= i -> UIx (i + n) | otherwise -> u + UHole{} -> u -- | Wrapper for `liftAtDepthX` that starts at depth 0. -liftX :: (MapBoundX c l, GBound l ~ Bound n) +liftX :: (MapBoundX c l, GXBoundVar l ~ Bound) => Int -> c l -> c l liftX n xx @@ -60,30 +59,40 @@ downX l f d xx = case xx of - XVar a u -> XVar a (f d u) - XCon{} -> xx - XPrim{} -> xx - XApp a x1 x2 -> XApp a (downX l f d x1) (downX l f d x2) - XLAM a b x -> XLAM a b (downX l f d x) + XAnnot a x -> XAnnot a (downX l f d x) + XVar u -> XVar (f d u) + XCon c -> XCon c + XPrim p -> XPrim p + XApp x1 x2 -> XApp (downX l f d x1) (downX l f d x2) + XLAM b x -> XLAM b (downX l f d x) - XLam a b x - -> let d' = d + countBAnons l [b] - in XLam a b (mapBoundAtDepthX l f d' x) + XLam b x + -> let d' = d + countBAnonsBM l [b] + in XLam b (mapBoundAtDepthX l f d' x) - XLet a lets x + XLet lets x -> let (lets', levels) = mapBoundAtDepthXLets l f d lets - in XLet a lets' (mapBoundAtDepthX l f (d + levels) x) + in XLet lets' (mapBoundAtDepthX l f (d + levels) x) - XCase a x alts -> XCase a (downX l f d x) (map (downA l f d) alts) - XCast a cc x -> XCast a (downC l f d cc) (downX l f d x) - XType{} -> xx - XWitness a w -> XWitness a (downW l f d w) + XCase x alts -> XCase (downX l f d x) (map (downA l f d) alts) + XCast cc x -> XCast (downC l f d cc) (downX l f d x) + XType t -> XType t + XWitness w -> XWitness (downW l f d w) - XDefix a xs -> XDefix a (map (downX l f d) xs) - XInfixOp{} -> xx - XInfixVar{} -> xx + XDefix a xs -> XDefix a (map (downX l f d) xs) + XInfixOp a x -> XInfixOp a x + XInfixVar a x -> XInfixVar a x + XMatch a gs x -> XMatch a (map (downMA l f d) gs) (downX l f d x) + XWhere a x cls -> XWhere a (downX l f d x) (map (downCL l f d) cls) + XLamPat a p mt x + -> let d' = d + countBAnonsP l p + in XLamPat a p mt (downX l f d' x) + XLamCase a alts + -> XLamCase a (map (downA l f d) alts) + + --------------------------------------------------------------------------------------------------- instance HasAnonBind l => MapBoundX GClause l where mapBoundAtDepthX = downCL @@ -95,20 +104,37 @@ --------------------------------------------------------------------------------------------------- -instance HasAnonBind l => MapBoundX GAlt l where +instance HasAnonBind l => MapBoundX GAltCase l where mapBoundAtDepthX = downA -downA l f d (AAlt p gxs) +downA l f d (AAltCase p gxs) = case p of PDefault - -> AAlt PDefault (map (downGX l f d) gxs) + -> AAltCase PDefault (map (downGX l f d) gxs) - PData _ bs - -> let d' = d + countBAnons l bs - in AAlt p (map (downGX l f d') gxs) + PAt b p' + -> let d' = d + countBAnonsB l [b] + AAltCase p'' gxs' = downA l f d' (AAltCase p' gxs) + in AAltCase (PAt b p'') gxs' + PVar b + -> let d' = d + countBAnonsB l [b] + in AAltCase p (map (downGX l f d') gxs) + PData _ ps + -> let d' = d + (sum $ map (countBAnonsP l) ps) + in AAltCase p (map (downGX l f d') gxs) + + --------------------------------------------------------------------------------------------------- +instance HasAnonBind l => MapBoundX GAltMatch l where + mapBoundAtDepthX = downMA + +downMA l f d (AAltMatch gx) + = AAltMatch (downGX l f d gx) + + +--------------------------------------------------------------------------------------------------- instance HasAnonBind l => MapBoundX GGuardedExp l where mapBoundAtDepthX = downGX @@ -121,7 +147,6 @@ GExp x -> GExp (downX l f d x) - --------------------------------------------------------------------------------------------------- instance HasAnonBind l => MapBoundX GGuard l where mapBoundAtDepthX = downG @@ -150,10 +175,11 @@ downW l f d ww = case ww of - WVar a u -> WVar a (f d u) - WCon{} -> ww - WApp a w1 w2 -> WApp a (downW l f d w1) (downW l f d w2) - WType{} -> ww + WAnnot a w -> WAnnot a (downW l f d w) + WVar u -> WVar (f d u) + WCon c -> WCon c + WApp w1 w2 -> WApp (downW l f d w1) (downW l f d w2) + WType t -> WType t --------------------------------------------------------------------------------------------------- @@ -161,7 +187,7 @@ :: forall l . HasAnonBind l => l - -> (Int -> GBound l -> GBound l) + -> (Int -> GXBoundVar l -> GXBoundVar l) -- ^ Function given number of levels to lift. -> Int -- ^ Current binding depth. -> GLets l -- ^ Lift exp indices in this thing. @@ -170,17 +196,17 @@ mapBoundAtDepthXLets l f d lts = case lts of LLet b x - -> let inc = countBAnons l [b] + -> let inc = countBAnonsBM l [b] x' = mapBoundAtDepthX l f d x in (LLet b x', inc) LRec bs - -> let inc = countBAnons l (map fst bs) + -> let inc = countBAnonsBM l (map fst bs) bs' = map (\(b,e) -> (b, mapBoundAtDepthX l f (d + inc) e)) bs in (LRec bs', inc) - LPrivate _b _ bs - -> (lts, countBAnons l bs) + LPrivate _b _ bts + -> (lts, countBAnonsB l $ map fst bts) LGroup cs -> let inc = sum (map (countBAnonsC l) cs) @@ -189,15 +215,21 @@ --------------------------------------------------------------------------------------------------- -countBAnons :: HasAnonBind l => l -> [GBind l] -> Int -countBAnons l = length . filter (isAnon l) +countBAnonsB :: HasAnonBind l => l -> [GXBindVar l] -> Int +countBAnonsB l = length . filter (isAnon l) +countBAnonsBM :: HasAnonBind l => l -> [GXBindVarMT l] -> Int +countBAnonsBM l bmts + = length + $ filter (isAnon l) + $ [b | XBindVarMT b _ <- bmts] + countBAnonsC :: HasAnonBind l => l -> GClause l -> Int countBAnonsC l c = case c of - SSig _ b _ -> countBAnons l [b] - SLet _ b _ _ -> countBAnons l [b] + SSig _ b _ -> countBAnonsB l [b] + SLet _ bm _ _ -> countBAnonsBM l [bm] countBAnonsG :: HasAnonBind l => l -> GGuard l -> Int @@ -210,6 +242,9 @@ countBAnonsP :: HasAnonBind l => l -> GPat l -> Int countBAnonsP l p = case p of - PData _ bs -> countBAnons l bs + PData _ ps -> sum $ map (countBAnonsP l) ps + PAt b p' -> countBAnonsB l [b] + countBAnonsP l p' + PVar b -> countBAnonsB l [b] PDefault -> 0 + diff --git a/DDC/Source/Tetra/Transform/Defix.hs b/DDC/Source/Tetra/Transform/Defix.hs --- a/DDC/Source/Tetra/Transform/Defix.hs +++ b/DDC/Source/Tetra/Transform/Defix.hs @@ -26,7 +26,6 @@ where import DDC.Source.Tetra.Transform.Defix.FixTable import DDC.Source.Tetra.Transform.Defix.Error -import DDC.Source.Tetra.Compounds import DDC.Source.Tetra.Module import DDC.Source.Tetra.Exp import DDC.Data.ListUtils @@ -60,15 +59,16 @@ defix table xx = let down = defix table in case xx of + XAnnot a x -> liftM (XAnnot a) (defix table x) XVar{} -> return xx XCon{} -> return xx XPrim{} -> return xx - XLAM a b x -> liftM (XLAM a b) (down x) - XLam a b x -> liftM (XLam a b) (down x) - XApp a x1 x2 -> liftM2 (XApp a) (down x1) (down x2) - XLet a lts x -> liftM2 (XLet a) (down lts) (down x) - XCase a x alts -> liftM2 (XCase a) (down x) (mapM down alts) - XCast a c x -> liftM (XCast a c) (down x) + XLAM b x -> liftM (XLAM b) (down x) + XLam b x -> liftM (XLam b) (down x) + XApp x1 x2 -> liftM2 XApp (down x1) (down x2) + XLet lts x -> liftM2 XLet (down lts) (down x) + XCase x alts -> liftM2 XCase (down x) (mapM down alts) + XCast c x -> liftM (XCast c) (down x) XType{} -> return xx XWitness{} -> return xx @@ -84,7 +84,13 @@ Just def -> return (fixDefExp def a) Nothing -> Left $ ErrorNoInfixDef a str + XMatch a gs x -> liftM2 (XMatch a) (mapM down gs) (down x) + XWhere a x cls -> liftM2 (XWhere a) (down x) (mapM down cls) + XLamPat a p mt x -> liftM (XLamPat a p mt) (down x) + XLamCase a alts -> liftM (XLamCase a) (mapM down alts) + + instance Defix GLets l where defix table lts = let down = defix table @@ -109,13 +115,20 @@ SLet a b ps gs -> liftM (SLet a b ps) (mapM down gs) -instance Defix GAlt l where +instance Defix GAltCase l where defix table aa = let down = defix table in case aa of - AAlt p x -> liftM (AAlt p) (mapM down x) + AAltCase p x -> liftM (AAltCase p) (mapM down x) +instance Defix GAltMatch l where + defix table aa + = let down = defix table + in case aa of + AAltMatch gx -> liftM AAltMatch (down gx) + + instance Defix GGuardedExp l where defix table gg = let down = defix table @@ -140,7 +153,7 @@ -- and produces (f a) + (g b) with three nodes in the XDefix list. -- defixApps - :: GAnnot l + :: GXAnnot l -> FixTable l -> [GExp l] -> Either (Error l) [GExp l] @@ -184,7 +197,7 @@ -- Add another argument to the application. munch acc (x1 : xs) - = munch (XApp a acc x1) xs + = munch (XApp acc x1) xs ------------------------------------------------------------------------------- @@ -193,7 +206,7 @@ -- The input needs to have already been preprocessed by defixApps above. -- defixExps - :: GAnnot l -- ^ Annotation from original XDefix node. + :: GXAnnot l -- ^ Annotation from original XDefix node. -> FixTable l -- ^ Table of infix defs. -> [GExp l] -- ^ Body of the XDefix node. -> Either (Error l) (GExp l) @@ -215,7 +228,7 @@ -- Defixer didn't find any infix ops, so whatever is leftover -- is a standard prefix application. - Right Nothing -> Right $ xApps a x xs + Right Nothing -> Right $ XAnnot a $ makeXApps x xs -- Defixer made progress, so keep calling it. Right (Just xs') -> defixExps a table xs' @@ -223,7 +236,7 @@ -- | Try to defix a sequence of expressions and XInfixOp nodes. defixInfix - :: GAnnot l -- ^ Annotation from original XDefix node. + :: GXAnnot l -- ^ Annotation from original XDefix node. -> FixTable l -- ^ Table of infix defs. -> [GExp l] -- ^ Body of the XDefix node. -> Either (Error l) (Maybe [GExp l]) @@ -280,13 +293,13 @@ -- | Defix some left associative ops. defixInfixLeft - :: GAnnot l -> FixTable l -> Int + :: GXAnnot l -> FixTable l -> Int -> [GExp l] -> Either (Error l) [GExp l] defixInfixLeft sp table precHigh (x1 : XInfixOp spo op : x2 : xs) | Just def <- lookupDefInfixOfSymbol table op , fixDefPrec def == precHigh - = Right (XApp sp (XApp sp (fixDefExp def spo) x1) x2 : xs) + = Right (XApp (XApp (fixDefExp def spo) x1) x2 : xs) | otherwise = do xs' <- defixInfixLeft sp table precHigh (x2 : xs) @@ -300,13 +313,13 @@ -- The input expression list is reversed, so we can eat the operators left -- to right. However, be careful to build the App node the right way around. defixInfixRight - :: GAnnot l -> FixTable l -> Int + :: GXAnnot l -> FixTable l -> Int -> [GExp l] -> Either (Error l) [GExp l] defixInfixRight sp table precHigh (x2 : XInfixOp spo op : x1 : xs) | Just def <- lookupDefInfixOfSymbol table op , fixDefPrec def == precHigh - = Right (XApp sp (XApp sp (fixDefExp def spo) x1) x2 : xs) + = Right (XApp (XApp (fixDefExp def spo) x1) x2 : xs) | otherwise = do xs' <- defixInfixRight sp table precHigh (x1 : xs) @@ -318,7 +331,7 @@ -- | Defix non-associative ops. defixInfixNone - :: GAnnot l -> FixTable l -> Int + :: GXAnnot l -> FixTable l -> Int -> [GExp l] -> Either (Error l) [GExp l] defixInfixNone sp table precHigh xx @@ -334,7 +347,7 @@ | x1 : XInfixOp sp2 op2 : x3 : xs <- xx , Just def2 <- lookupDefInfixOfSymbol table op2 , fixDefPrec def2 == precHigh - = Right $ (XApp sp (XApp sp (fixDefExp def2 sp2) x1) x3) : xs + = Right $ (XApp (XApp (fixDefExp def2 sp2) x1) x3) : xs -- Some other operator. | x1 : x2@(XInfixOp{}) : x3 : xs <- xx diff --git a/DDC/Source/Tetra/Transform/Defix/Error.hs b/DDC/Source/Tetra/Transform/Defix/Error.hs --- a/DDC/Source/Tetra/Transform/Defix/Error.hs +++ b/DDC/Source/Tetra/Transform/Defix/Error.hs @@ -12,25 +12,25 @@ data Error l -- | Infix operator symbol has no infix definition. = ErrorNoInfixDef - { errorAnnot :: GAnnot l + { errorAnnot :: GXAnnot l , errorSymbol :: String } -- | Two non-associative operators with the same precedence. | ErrorDefixNonAssoc { errorOp1 :: String - , errorAnnot1 :: GAnnot l + , errorAnnot1 :: GXAnnot l , errorOp2 :: String - , errorAnnot2 :: GAnnot l } + , errorAnnot2 :: GXAnnot l } -- | Two operators of different associativies with same precedence. | ErrorDefixMixedAssoc - { errorAnnot :: GAnnot l + { errorAnnot :: GXAnnot l , errorOps :: [String] } -- | Infix expression is malformed. -- Eg "+ 3" or "2 + + 2" | ErrorMalformed - { errorAnnot :: GAnnot l + { errorAnnot :: GXAnnot l , errorExp :: GExp l } deriving instance ShowLanguage l => Show (Error l) diff --git a/DDC/Source/Tetra/Transform/Defix/FixTable.hs b/DDC/Source/Tetra/Transform/Defix/FixTable.hs --- a/DDC/Source/Tetra/Transform/Defix/FixTable.hs +++ b/DDC/Source/Tetra/Transform/Defix/FixTable.hs @@ -13,10 +13,9 @@ , defaultFixTable) where import DDC.Source.Tetra.Transform.Defix.Error -import DDC.Source.Tetra.Exp.Generic -import DDC.Source.Tetra.Prim +import DDC.Source.Tetra.Exp.Source import Data.List -import qualified DDC.Type.Exp as T +import qualified Data.Text as Text -- | Table of infix operator definitions. @@ -33,7 +32,7 @@ -- Expression to rewrite the operator to, -- given the annotation of the original symbol. - , fixDefExp :: GAnnot l -> GExp l } + , fixDefExp :: GXAnnot l -> GExp l } -- An infix operator. | FixDefInfix @@ -42,7 +41,7 @@ -- Expression to rewrite the operator to, -- given the annotation of the original symbol. - , fixDefExp :: GAnnot l -> GExp l + , fixDefExp :: GXAnnot l -> GExp l -- Associativity of infix operator. , fixDefAssoc :: InfixAssoc @@ -90,7 +89,7 @@ -- | Get the precedence of an infix symbol, else Error. getInfixDefOfSymbol - :: GAnnot l + :: GXAnnot l -> FixTable l -> String -> Either (Error l) (FixDef l) @@ -102,7 +101,7 @@ -- | Default fixity table for infix operators. -defaultFixTable :: GBound l ~ T.Bound Name => FixTable l +defaultFixTable :: GXBoundVar l ~ Bound => FixTable l defaultFixTable = FixTable [ FixDefPrefix "-" (xvar "neg") @@ -143,5 +142,5 @@ ] where xvar str sp - = XVar sp (T.UName (NameVar str)) + = XAnnot sp $ XVar (UName $ Text.pack str) diff --git a/DDC/Source/Tetra/Transform/Expand.hs b/DDC/Source/Tetra/Transform/Expand.hs --- a/DDC/Source/Tetra/Transform/Expand.hs +++ b/DDC/Source/Tetra/Transform/Expand.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TypeFamilies, UndecidableInstances #-} -- | Look at type signatures and add quantifiers to bind any free type --- variables. Also add holes for missing type arguments. +-- variables. -- -- Given -- @@ -18,62 +18,44 @@ -- mapS [a e b : ?] (f : a -> S e b) (xx : List a) : S e (List b) -- = /\(a e b : ?). box case xx of -- Nil -> Nil --- Cons x xs -> Cons (run f x) (run mapS [?] [?] [?] f xs) +-- Cons x xs -> Cons (run f x) (run mapS f xs) -- @ -- module DDC.Source.Tetra.Transform.Expand - ( Config (..) - , configDefault + ( expandModule , Expand (..)) where -import DDC.Source.Tetra.Compounds -import DDC.Source.Tetra.Predicates +import DDC.Source.Tetra.Collect.FreeVars +import DDC.Source.Tetra.Exp import DDC.Source.Tetra.DataDef import DDC.Source.Tetra.Module -import DDC.Source.Tetra.Prim -import DDC.Source.Tetra.Exp -import DDC.Type.Collect -import DDC.Type.Env (KindEnv, TypeEnv) -import qualified DDC.Type.Env as Env +import DDC.Data.SourcePos +import Data.Function +import DDC.Source.Tetra.Env (Env) +import Data.Maybe +import qualified DDC.Source.Tetra.Env as Env import qualified Data.Set as Set - - ---------------------------------------------------------------------------------------------------- --- | Expander configuration. -data Config l - = Config - { -- | Make a type hole of the given kind. - configMakeTypeHole :: Kind (GName l) -> Type (GName l) } +import qualified Data.List as List --- | Default expander configuration. -configDefault :: GName l ~ Name => Config l -configDefault - = Config - { configMakeTypeHole = \k -> TVar (UPrim NameHole k)} +-- | Run the expander on the given module. +expandModule :: SourcePos -> Module Source -> Module Source +expandModule sp mm + = expand sp Env.empty mm --------------------------------------------------------------------------------------------------- -type ExpandLanguage l - = ( Ord (GName l) - , GBind l ~ Bind (GName l) - , GBound l ~ Bound (GName l)) - -class ExpandLanguage l => Expand (c :: * -> *) l where +class Expand c where -- | Add quantifiers to the types of binders. Also add holes for missing -- type arguments. - expand - :: Ord (GName l) - => Config l - -> KindEnv (GName l) -> TypeEnv (GName l) - -> c l -> c l + expand :: SourcePos -> Env -> c -> c --------------------------------------------------------------------------------------------------- -instance ExpandLanguage l => Expand Module l where +instance Expand (Module Source) where expand = expandM -expandM config kenv tenv mm +expandM a env mm = let -- Add quantifiers to the types of bindings, and also slurp -- out the contribution to the top-level environment from each binding. @@ -81,176 +63,174 @@ -- thing is in-scope of all the others. preTop p = case p of - TopClause a (SLet _ b [] [GExp x]) - -> let (b', x') = expandQuant a config kenv (b, x) - in ( TopClause a (SLet a b' [] [GExp x']) - , Env.singleton b') - - TopData _ def - -> (p, typeEnvOfDataDef def) + TopClause aT (SLet aL bm ps gxs) + -> let (bm', ps') = expandQuantParams env bm ps + in ( TopClause aT (SLet aL bm' ps' gxs) + , Env.extendDaVarMT bm' Env.empty) -- Clauses should have already desugared. - _ -> error "source-tetra.expand: can't expand sugared TopClause." + TopClause _ SSig{} -> (p, Env.empty) + TopData _ def -> (p, envOfDataDef def) + TopType{} -> (p, Env.empty) - (tops_quant, tenvs) + (tops_quant, envs) = unzip $ map preTop $ moduleTops mm -- Build the compound top-level environment. - tenv' = Env.unions $ tenv : tenvs + env' = Env.unions $ env : envs -- Expand all the top-level definitions. - tops' = map (expand config kenv tenv') - $ tops_quant + tops' = map (expand a env') + $ tops_quant in mm { moduleTops = tops' } --------------------------------------------------------------------------------------------------- -instance ExpandLanguage l => Expand Top l where +instance Expand (Top Source) where expand = expandT -expandT config kenv tenv top - = case top of - TopClause a1 (SLet a2 b [] [GExp x]) - -> let tenv' = Env.extend b tenv - x' = expand config kenv tenv' x - in TopClause a1 (SLet a2 b [] [GExp x']) +expandT _a env top + = case top of + TopClause a1 (SLet a2 bm ps gxs) + -> let env' = Env.extendDaVarMT bm env + env'' = List.foldl' (flip extendParam) env' ps + gxs' = map (expand a2 env'') gxs + in TopClause a1 (SLet a2 bm ps gxs') - TopData{} -> top + TopClause _ (SSig{}) -> top - -- Clauses should have already been desugared. - _ -> error "source-tetra.expand: can't expand sugared TopClause." + TopData{} -> top + TopType{} -> top --------------------------------------------------------------------------------------------------- -instance ExpandLanguage l => Expand GExp l where +instance Expand Exp where expand = downX -downX config kenv tenv xx +downX a env xx = case xx of + XAnnot a' x + -> downX a' env x -- Invoke the expander -------- - XVar{} - -> expandApp config kenv tenv xx [] - - XCon{} - -> expandApp config kenv tenv xx [] - - XPrim{} - -> expandApp config kenv tenv xx [] + XVar{} -> xx + XCon{} -> xx + XPrim{} -> xx XApp{} | (x1, xas) <- takeXAppsWithAnnots xx - -> if isXVar x1 || isXCon x1 - -- If the function is a variable or constructor then try to expand - -- extra arguments in the application. - then let xas' = [ (expand config kenv tenv x, a) | (x, a) <- xas ] - in expandApp config kenv tenv x1 xas' + -> let x1' = expand a env x1 + xas' = [ (expand (fromMaybe a a') env x, a') + | (x, a') <- xas ] + in makeXAppsWithAnnots x1' xas' - -- Otherwise just apply the original arguments. - else let x1' = expand config kenv tenv x1 - xas' = [ (expand config kenv tenv x, a) | (x, a) <- xas ] - in makeXAppsWithAnnots x1' xas' + XLet (LLet b x1) x2 + -> let x1' = expand a env x1 - XLet a (LLet b x1) x2 - -> let - -- Add missing quantifiers to the types of let-bindings. - (b_quant, x1_quant) - = expandQuant a config kenv (b, x1) + env' = Env.extendDaVarMT b env + x2' = expand a env' x2 + in XLet (LLet b x1') x2' - tenv' = Env.extend b_quant tenv - x1' = expand config kenv tenv' x1_quant - x2' = expand config kenv tenv' x2 - in XLet a (LLet b x1') x2' + XLet (LRec bxs) x2 + -> let (bs, xs) = unzip bxs + env' = Env.extendsDaVarMT bs env - XLet a (LRec bxs) x2 - -> let - (bs_quant, xs_quant) - = unzip - $ [expandQuant a config kenv (b, x) | (b, x) <- bxs] + xs' = map (expand a env') xs + bxs' = zip bs xs' - tenv' = Env.extends bs_quant tenv - xs' = map (expand config kenv tenv') xs_quant - x2' = expand config kenv tenv' x2 - in XLet a (LRec (zip bs_quant xs')) x2' + x2' = expand a env' x2 + in XLet (LRec bxs') x2' - -- LGroups need to be desugared first because any quantifiers - -- we add to the front of a function binding need to scope over - -- all the clauses related to that binding. - XLet a (LGroup [SLet _ b [] [GExp x1]]) x2 - -> expand config kenv tenv (XLet a (LLet b x1) x2) - -- This should have already been desugared. - XLet _ (LGroup{}) _ - -> error $ "ddc-source-tetra.expand: can't expand sugared LGroup." + XLet (LGroup cs) x2 + -> let cs' = map (downCX a env) cs + bs = [b | SLet _ b _ _ <- cs'] + env' = Env.extendsDaVarMT bs env + x2' = downX a env' x2 + in XLet (LGroup cs') x2' -- Boilerplate ---------------- - XLAM a b x - -> let kenv' = Env.extend b kenv - x' = expand config kenv' tenv x - in XLAM a b x' + XLAM bm@(XBindVarMT b _) x + -> let env' = env & Env.extendTyVar' b + x' = expand a env' x + in XLAM bm x' - XLam a b x - -> let tenv' = Env.extend b tenv - x' = expand config kenv tenv' x - in XLam a b x' + XLam bm@(XBindVarMT b _) x + -> let env' = env & Env.extendDaVar' b + x' = expand a env' x + in XLam bm x' - XLet a (LPrivate bts mR bxs) x2 - -> let tenv' = Env.extends bts kenv - kenv' = Env.extends bxs tenv - x2' = expand config kenv' tenv' x2 - in XLet a (LPrivate bts mR bxs) x2' + XLet (LPrivate bts mR bxs) x2 + -> let env' = env & Env.extendsTyVar' bts + & Env.extendsDaVar bxs + x2' = expand a env' x2 + in XLet (LPrivate bts mR bxs) x2' - XCase a x alts -> XCase a (downX config kenv tenv x) - (map (downA config kenv tenv) alts) - XCast a c x -> XCast a c (downX config kenv tenv x) + XCase x alts -> XCase (downX a env x) + (map (downA a env) alts) + + XCast c x -> XCast c (downX a env x) XType{} -> xx XWitness{} -> xx - XDefix a xs -> XDefix a (map (downX config kenv tenv) xs) + + XDefix a' xs -> XDefix a' (map (downX a' env) xs) XInfixOp{} -> xx XInfixVar{} -> xx + XMatch a' as x -> XMatch a' (map (downMA a' env) as) (downX a' env x) + XWhere a' x cls -> XWhere a' (downX a' env x) (map (downCX a env) cls) + XLamPat a' p mt x + -> let env' = extendPat p env + in XLamPat a' p mt (downX a' env' x) + + XLamCase a' alts -> XLamCase a (map (downA a' env) alts) + + --------------------------------------------------------------------------------------------------- -instance ExpandLanguage l => Expand GAlt l where - expand = downA +instance Expand Clause where + expand a env cl + = downCX a env cl -downA config kenv tenv alt - = case alt of - AAlt p gsx - -> let tenv' = extendPat p tenv - gsx' = map (expand config kenv tenv') gsx - in AAlt p gsx' +downCX _a env cl + = case expandQuantClause env cl of + (_, SSig{}) + -> cl + (env', SLet a mt ps gxs) + -> let gxs' = map (downGX a env') gxs + in SLet a mt ps gxs' + --------------------------------------------------------------------------------------------------- -instance ExpandLanguage l => Expand GGuardedExp l where +instance Expand GuardedExp where expand = downGX -downGX config kenv tenv (GGuard g x) - = let g' = expand config kenv tenv g - tenv' = extendGuard g' tenv - in GGuard g' (expand config kenv tenv' x) +downGX a env (GGuard g x) + = let g' = expand a env g + env' = extendGuard g' env + in GGuard g' (expand a env' x) -downGX config kenv tenv (GExp x) - = let x' = expand config kenv tenv x +downGX a env (GExp x) + = let x' = expand a env x in GExp x' --------------------------------------------------------------------------------------------------- -instance ExpandLanguage l => Expand GGuard l where +instance Expand Guard where expand = downG -downG config kenv tenv gg +downG a env gg = case gg of GPat p x - -> let tenv' = extendPat p tenv - x' = expand config kenv tenv' x + -> let env' = extendPat p env + x' = expand a env' x in GPat p x' GPred x - -> let x' = expand config kenv tenv x + -> let x' = expand a env x in GPred x' GDefault @@ -258,20 +238,47 @@ --------------------------------------------------------------------------------------------------- +instance Expand AltCase where + expand = downA + +downA a env alt + = case alt of + AAltCase p gsx + -> let env' = extendPat p env + gsx' = map (expand a env') gsx + in AAltCase p gsx' + + +--------------------------------------------------------------------------------------------------- +instance Expand AltMatch where + expand = downMA + +downMA a env alt + = case alt of + AAltMatch gx -> AAltMatch (downGX a env gx) + + +--------------------------------------------------------------------------------------------------- -- | Extend a type environment with the variables bound by the given pattern. -extendPat - :: ExpandLanguage l - => GPat l -> TypeEnv (GName l) -> TypeEnv (GName l) -extendPat ww tenv +extendPat :: Pat -> Env -> Env +extendPat ww env = case ww of - PDefault -> tenv - PData _ bs -> Env.extends bs tenv + PDefault -> env + PAt b p -> extendPat p $ Env.union env (Env.singletonDaVar' b) + PVar b -> Env.union env (Env.singletonDaVar' b) + PData{} -> env +extendParam :: Param -> Env -> Env +extendParam pp env + = case pp of + MType b _ -> Env.union env (Env.singletonTyVar' b) + MWitness b _ -> Env.union env (Env.singletonDaVar' b) + MValue p _ -> extendPat p env + + -- | Extend a type environment with the variables bound by the given guard. -extendGuard - :: ExpandLanguage l - => GGuard l -> TypeEnv (GName l) -> TypeEnv (GName l) +extendGuard :: Guard -> Env -> Env extendGuard gg tenv = case gg of GPat w _ -> extendPat w tenv @@ -279,103 +286,59 @@ --------------------------------------------------------------------------------------------------- +expandQuantClause :: Env -> Clause -> (Env, Clause) +expandQuantClause env cc + = case cc of + SSig{} + -> (env, cc) + + SLet a mt ps gxs + -> let (mt', ps') = expandQuantParams env mt ps + in (env, SLet a mt' ps' gxs) + + -- | Expand missing quantifiers in types of bindings. -- -- If a binding mentions type variables that are not in scope then add new -- quantifiers to its type, as well as matching type lambdas. -- -expandQuant - :: ExpandLanguage l - => GAnnot l -- ^ Annotation to use on new type lambdas. - -> Config l -- ^ Expander configuration. - -> KindEnv (GName l) -- ^ Current kind environment. - -> (GBind l, GExp l) -- ^ Binder and expression of binding. - -> (GBind l, GExp l) +expandQuantParams + :: Env -- ^ Current environment. + -> BindVarMT -- ^ Type of binding. + -> [Param] -- ^ Parameters of binding. + -> (BindVarMT, [Param]) -- ^ Expanded type and body of binding. -expandQuant a config kenv (b, x) - | fvs <- freeVarsT kenv (typeOfBind b) +expandQuantParams env bmBind ps + | XBindVarMT bBind (Just tBind) <- bmBind + , fvs <- freeVarsT env tBind , not $ Set.null fvs = let - -- Make binders for each of the free type variables. - -- We set these to holes so the Core type inferencer will determine - -- their kinds for us. - kHole = configMakeTypeHole config sComp + -- Make new binders for each of the free type variables. + -- We shouldn't have any holes or indices in the incoming type, + -- but don't have a way to specify this in the type of the AST. makeBind u = case u of - UName n -> Just $ BName n kHole - UIx{} -> Just $ BAnon kHole - _ -> Nothing + UName n -> Just $ BName n + UHole -> error "ddc-source-tetra.expandQuant: not expanding hole in type" + UIx{} -> error "ddc-source-tetra.expandQuant: not expanding deBruijn type var" Just bsNew = sequence $ map makeBind $ Set.toList fvs - -- Attach quantifiers to the front of the old type. - t' = foldr TForall (typeOfBind b) bsNew - b' = replaceTypeOfBind t' b - - -- Attach type lambdas to the front of the expression. - x' = foldr (XLAM a) x bsNew - - in (b', x') - - | otherwise - = (b, x) - - ---------------------------------------------------------------------------------------------------- --- | Expand missing type arguments in applications. --- --- The thing being applied needs to be a variable or data constructor --- so we can look up its type in the environment. Given the type, look --- at the quantifiers out the front and insert new type applications if --- the expression is missing them. --- -expandApp - :: ExpandLanguage l - => Config l -- ^ Expander configuration. - -> KindEnv (GName l) -- ^ Current kind environment. - -> TypeEnv (GName l) -- ^ Current type environment. - -> GExp l -- ^ Functional expression being applied. - -> [(GExp l, GAnnot l)] -- ^ Function arguments. - -> GExp l - -expandApp config _kenv tenv x0 xas0 - | Just (a, u) <- slurpVarConBound x0 - , Just tt <- Env.lookup u tenv - , not $ isBot tt - = let - go t xas - = case (t, xas) of - (TForall _b t2, (x1@(XType _ _t1'), a1) : xas') - -> (x1, a1) : go t2 xas' - - (TForall b t2, xas') - -> let k = typeOfBind b - Just a0 = takeAnnotOfExp x0 - xh = XType a0 (configMakeTypeHole config k) - in (xh, a) : go t2 xas' - - _ -> xas + -- Attach quantifiers to the front of the old type, + -- using a hole bound to indicate we want the type inferencer, + -- to infer a kind or this. + k = TVar UHole + tBind' = foldr (\b t -> TApp (TCon (TyConForall k)) (TAbs b k t)) tBind bsNew - xas_expanded - = go tt xas0 + -- Attach type lambdas to the front of the term + -- using a matching hole bound on the type abstraction. + -- We could instead just not include a kind, but use + -- a hole so the form of the term matches the form + -- of its type. + ps' = [MType b Nothing | b <- bsNew] ++ ps - in makeXAppsWithAnnots x0 xas_expanded + in (XBindVarMT bBind (Just tBind'), ps') | otherwise - = makeXAppsWithAnnots x0 xas0 - - --- | Slurp a `Bound` from and `XVar` or `XCon`. --- Named data constructors are converted to `UName`s. -slurpVarConBound - :: GBound l ~ Bound (GName l) - => GExp l - -> Maybe (GAnnot l, GBound l) -slurpVarConBound xx - = case xx of - XVar a u -> Just (a, u) - XCon a dc - | DaConBound n <- dc -> Just (a, UName n) - | DaConPrim n t <- dc -> Just (a, UPrim n t) - _ -> Nothing + = (bmBind, ps) diff --git a/DDC/Source/Tetra/Transform/Freshen.hs b/DDC/Source/Tetra/Transform/Freshen.hs new file mode 100644 --- /dev/null +++ b/DDC/Source/Tetra/Transform/Freshen.hs @@ -0,0 +1,483 @@ +{-# LANGUAGE TypeFamilies, OverloadedStrings #-} +-- | Freshen shadowed names in the source file, +-- and rewrite anonymous binders to their named forms. +module DDC.Source.Tetra.Transform.Freshen + ( type S, evalState, newName + , freshenModule) +where +import DDC.Source.Tetra.Transform.Freshen.State +import DDC.Source.Tetra.Module +import DDC.Source.Tetra.Exp +import qualified Control.Monad.State as S +import qualified Data.Set as Set +import qualified Data.Map.Strict as Map +import qualified Data.List as List + + +------------------------------------------------------------------------------- +-- | Freshen the given module. +freshenModule :: Module Source -> S (Module Source) +freshenModule mm + = do tops' <- freshenTops $ moduleTops mm + return $ mm { moduleTops = tops' } + + +------------------------------------------------------------------------------- +-- | Freshen a top level thing. +freshenTops :: [Top Source] -> S [Top Source] +freshenTops tops + = do + let (topCls, topRest) = List.partition isTopClause tops + let (sps, cls) = unzip $ [(sp, cl) | TopClause sp cl <- topCls] + cls' <- freshenClauseGroup cls + let topCls' = zipWith TopClause sps cls' + return $ topRest ++ topCls' + + +-- | Check if this top level thing is a clause. +isTopClause :: Top Source -> Bool +isTopClause tt + = case tt of + TopClause{} -> True + _ -> False + + +------------------------------------------------------------------------------- +-- | Freshen a clause group. +freshenClauseGroup :: [Clause] -> S [Clause] +freshenClauseGroup cls + = freshenClauseGroupBinds cls $ \cls' + -> mapM freshenClauseBody cls' + + +-- | Freshen the binders in a group of clauses. +-- +-- In the group, we may have several clauses that define the same function. +-- If we freshen the name of one of those clauses, we need to use the same +-- name for the other associated ones. +-- +-- All the new names for the clauses are in scope in the continuation, +-- which can then be used to freshen the bodies. +-- +freshenClauseGroupBinds + :: [Clause] -> ([Clause] -> S a) -> S a + +freshenClauseGroupBinds cls0 cont + = do envTopX <- S.gets stateEnvX + go envTopX [] cls0 + where + go _envTopX clsAcc [] + = cont (reverse clsAcc) + + -- Signatures. + go envTopX clsAcc ((SSig a b t) : clsRest) + = do -- Freshen the signature type. + t' <- freshenType t + + -- Check if we've already renamed this variable in the + -- current clause group. + envX <- S.gets stateEnvX + case b of + BName name + -- We've already renamed one of the clauses in the same + -- group to a new name, so use that for matching ones. + | Just name' <- Map.lookup name (envRename envX) + -> do let b' = BName name' + let cls' = SSig a b' t' + go envTopX (cls' : clsAcc) clsRest + + -- Bind the variable into the current environment, + -- renaming it if it was already visible in the context + -- of the current clause group. + _ + -> bindCtxBX envTopX b $ \b' + -> do let cls' = SSig a b' t' + go envTopX (cls' : clsAcc) clsRest + + + -- Binding Clauses. + go envTopX clsAcc ((SLet a (XBindVarMT b mt) ps gxs) : clsRest) + = do -- Freshen the type on the binder. + mt' <- traverse freshenType mt + + -- Check if we've already renamed this variable in the + -- current clause group. + envX <- S.gets stateEnvX + case b of + BName name + -- We've already renamed one of the clauses in the same + -- group to a new name, so use that for matching ones. + | Just name' <- Map.lookup name (envRename envX) + -> do let b' = BName name' + let cls' = SLet a (XBindVarMT b' mt') ps gxs + go envTopX (cls' : clsAcc) clsRest + + -- Bind the variable into the current environment, + -- renaming it if it was already visible in the context + -- of the current clause group. + _ + -> bindCtxBX envTopX b $ \b' + -> do let cls' = SLet a (XBindVarMT b' mt') ps gxs + go envTopX (cls' : clsAcc) clsRest + + +-- | Freshen a clause. +freshenClauseBody :: Clause -> S Clause +freshenClauseBody cl + = case cl of + SSig{} + -> return cl + + SLet a b ps gxs + -> mapFreshBinds bindParam ps $ \ps' + -> SLet a b ps' <$> mapM freshenGuardedExp gxs + + +------------------------------------------------------------------------------- +-- | Freshen and bind a function parameter. +bindParam :: Param -> (Param -> S a) -> S a +bindParam pp cont + = case pp of + MType b mt + -> bindBT b $ \b' + -> do mt' <- traverse freshenType mt + cont $ MType b' mt' + + MWitness b mt + -> bindBX b $ \b' + -> do mt' <- traverse freshenType mt + cont $ MWitness b' mt' + + MValue p mt + -> bindPat p $ \p' + -> do mt' <- traverse freshenType mt + cont $ MValue p' mt' + + +------------------------------------------------------------------------------- +-- | Freshen a guarded expression. +freshenGuardedExp :: GuardedExp -> S GuardedExp +freshenGuardedExp gx + = case gx of + GGuard g gx' + -> bindGuard g $ \g' + -> GGuard g' <$> freshenGuardedExp gx' + + GExp x + -> do x' <- freshenExp x + return $ GExp x' + + +------------------------------------------------------------------------------- +-- | Freshen an expression. +freshenExp :: Exp -> S Exp +freshenExp xx + = case xx of + XAnnot a x -> XAnnot a <$> freshenExp x + XVar u -> XVar <$> boundUX u + XPrim{} -> return xx + XCon{} -> return xx + + XLAM (XBindVarMT b mt) x + -> do mt' <- traverse freshenType mt + bindBT b $ \b' + -> XLAM (XBindVarMT b' mt') <$> freshenExp x + + XLam (XBindVarMT b mt) x + -> do mt' <- traverse freshenType mt + bindBX b $ \b' + -> XLam (XBindVarMT b' mt') <$> freshenExp x + + XApp x1 x2 -> XApp <$> freshenExp x1 <*> freshenExp x2 + + XLet lts x + -> bindLets lts $ \lts' + -> XLet lts' <$> freshenExp x + + XCase x alts -> XCase <$> freshenExp x + <*> mapM freshenAltCase alts + + XCast c x -> XCast <$> freshenCast c <*> freshenExp x + + XType t -> XType <$> freshenType t + + XWitness w -> XWitness <$> freshenWitness w + + XDefix a xs -> XDefix a <$> mapM freshenExp xs + + XInfixOp{} -> return xx + + XInfixVar{} -> return xx + + XMatch a as x -> XMatch a <$> mapM freshenAltMatch as + <*> freshenExp x + + XWhere a x cl -> XWhere a <$> freshenExp x <*> freshenClauseGroup cl + + XLamPat a p mt x + -> do mt' <- traverse freshenType mt + bindPat p $ \p' + -> XLamPat a p' mt' <$> freshenExp x + + XLamCase a as + -> XLamCase a <$> mapM freshenAltCase as + + +------------------------------------------------------------------------------- +-- | Freshen and bind guards. +bindGuard :: Guard -> (Guard -> S a) -> S a +bindGuard gg cont + = case gg of + GPat p x + -> bindPat p $ \p' + -> cont =<< (GPat p' <$> freshenExp x) + + GPred x + -> cont =<< (GPred <$> freshenExp x) + + GDefault + -> cont GDefault + + +------------------------------------------------------------------------------- +-- | Freshen and bind let expressions. +bindLets :: Lets -> (Lets -> S a) -> S a +bindLets lts cont + = case lts of + LLet (XBindVarMT b mt) x + -> do mt' <- traverse freshenType mt + bindBX b $ \b' + -> cont =<< (LLet (XBindVarMT b' mt') <$> freshenExp x) + + LRec bxs + -> do let (bs, xs) = unzip bxs + mapFreshBinds bindBVX bs $ \bs' + -> do xs' <- mapM freshenExp xs + cont (LRec $ zip bs' xs') + + LPrivate brs mt bwts + -> do mt' <- traverse freshenType mt + mapFreshBinds bindBT brs $ \brs' + -> do let (bws, ts) = unzip bwts + ts' <- mapM freshenType ts + mapFreshBinds bindBX bws $ \bws' + -> cont (LPrivate brs' mt' $ zip bws' ts') + + LGroup cls + -> cont =<< (LGroup <$> freshenClauseGroup cls) + + +------------------------------------------------------------------------------- +-- | Freshen a case alternative. +freshenAltCase :: AltCase -> S AltCase +freshenAltCase (AAltCase p gxs) + = bindPat p $ \p' + -> AAltCase p' <$> mapM freshenGuardedExp gxs + + +-- | Freshen a match alternative +freshenAltMatch :: AltMatch -> S AltMatch +freshenAltMatch (AAltMatch gx) + = AAltMatch <$> freshenGuardedExp gx + + +------------------------------------------------------------------------------- +-- | Freshen a cast. +freshenCast :: Cast -> S Cast +freshenCast cc + = case cc of + CastWeakenEffect t -> CastWeakenEffect <$> freshenType t + CastPurify w -> CastPurify <$> freshenWitness w + CastBox -> return CastBox + CastRun -> return CastRun + + +------------------------------------------------------------------------------- +-- | Freshen a witness. +freshenWitness :: Witness -> S Witness +freshenWitness ww + = case ww of + WAnnot a w -> WAnnot a <$> freshenWitness w + WVar u -> WVar <$> boundUX u + WCon {} -> return ww + WApp w1 w2 -> WApp <$> freshenWitness w1 <*> freshenWitness w2 + WType t -> WType <$> freshenType t + + +------------------------------------------------------------------------------- +-- | Freshen a type. +freshenType :: Type -> S Type +freshenType tt + = case tt of + TAnnot a t -> TAnnot a <$> freshenType t + + TCon{} -> return tt + + TVar u -> TVar <$> boundUT u + + TAbs b t1 t2 + -> do t1' <- freshenType t1 + bindBT b $ \b' + -> TAbs b' t1' <$> freshenType t2 + + TApp t1 t2 -> TApp <$> freshenType t1 <*> freshenType t2 + + +------------------------------------------------------------------------------- +-- | Bind a pattern. +bindPat :: Pat -> (Pat -> S a) -> S a +bindPat pp cont + = case pp of + PDefault + -> cont pp + + PAt b p + -> bindBX b $ \b' + -> bindPat p $ \p' + -> cont (PAt b' p') + + PVar b + -> bindBX b $ \b' + -> cont (PVar b') + + PData dc ps + -> mapFreshBinds bindPat ps $ \ps' + -> cont (PData dc ps') + + +------------------------------------------------------------------------------- +-- | Bind a new type variable. +bindBT :: Bind -> (Bind -> S a) -> S a +bindBT b@BNone cont + = cont b + +bindBT BAnon cont + = do -- Create a new name for anonymous binders. + name <- newName "t" + + withModifiedEnvT + (\envT -> envT { envStack = name : envStack envT + , envStackLen = 1 + envStackLen envT }) + $ cont (BName name) + +bindBT (BName n) cont + = S.get >>= \state0 + -> case Set.member n (envNames $ stateEnvT state0) of + -- If the binder does not shadow an existing one + -- then don't bother rewriting it. + False + -> withModifiedEnvT + (\envT -> envT { envNames = Set.insert n (envNames envT) }) + $ cont (BName n) + + -- The binder shadows an existing one, so rewrite it. + True + -> do name <- newName "t" + + -- Run the continuation in the extended environment. + withModifiedEnvT + (\envT -> envT { envNames = Set.insert name (envNames envT) + , envRename = Map.insert n name (envRename envT)}) + $ cont (BName name) + + +------------------------------------------------------------------------------- +-- | Bind a term variable with its attached type. +bindBVX :: BindVarMT -> (BindVarMT -> S a) -> S a +bindBVX (XBindVarMT b mt) cont + = do mt' <- traverse freshenType mt + bindBX b $ \b' + -> cont (XBindVarMT b' mt') + + +-- | Bind a new term variable, +-- renaming it if it is already in the current environment. +bindBX :: Bind -> (Bind -> S a) -> S a +bindBX b cont + = do envX <- S.gets stateEnvX + bindCtxBX envX b cont + + +-- | Bind a new term variable, +-- renaming it if it is already in the given environment. +bindCtxBX :: Env -> Bind -> (Bind -> S a) -> S a + +bindCtxBX _envCtx b@BNone cont + = cont b + +bindCtxBX _envCtx BAnon cont + = do -- Create a new name for anonymous binders. + name <- newName "x" + + withModifiedEnvX + (\envX -> envX { envStack = name : envStack envX + , envStackLen = 1 + envStackLen envX }) + $ cont (BName name) + +bindCtxBX envCtx (BName name) cont + = case Set.member name (envNames envCtx) of + -- If the binder does not shadow an existing one + -- then don't bother rewriting it. + False + -> do withModifiedEnvX + (\envX -> envX + { envNames = Set.insert name (envNames envX)}) + $ cont (BName name) + + -- The binder shadows an existing one, so rewrite it. + True + -> do name' <- newName name + + -- Run the continuation in the environment extended with the + -- new name. + withModifiedEnvX + (\envX -> envX + { envNames = Set.insert name' (envNames envX) + , envRename = Map.insert name name' (envRename envX)}) + $ cont (BName name') + + +------------------------------------------------------------------------------- +-- | Rewrite bound type variable if needed. +boundUT :: Bound -> S Bound +boundUT uu + = case uu of + UName n + -> do envT <- S.gets (envRename . stateEnvT) + case Map.lookup n envT of + Just n' -> return $ UName n' + _ -> return uu + + UIx i + -> do stack <- S.gets (envStack . stateEnvT) + len <- S.gets (envStackLen . stateEnvT) + if (i < len) + then return $ UName (stack !! i) + else return uu + + UHole{} + -> return uu + + +------------------------------------------------------------------------------- +-- | Rewrite bound term variable if needed. +boundUX :: Bound -> S Bound +boundUX uu + = case uu of + UName n + -> do envX <- S.gets (envRename . stateEnvX) + case Map.lookup n envX of + Just n' -> return $ UName n' + _ -> return uu + + UIx i + -> do stack <- S.gets (envStack . stateEnvX) + len <- S.gets (envStackLen . stateEnvX) + if (i < len) + then return $ UName (stack !! i) + else return uu + + UHole{} + -> return uu + + diff --git a/DDC/Source/Tetra/Transform/Freshen/State.hs b/DDC/Source/Tetra/Transform/Freshen/State.hs new file mode 100644 --- /dev/null +++ b/DDC/Source/Tetra/Transform/Freshen/State.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE TypeFamilies, OverloadedStrings #-} +module DDC.Source.Tetra.Transform.Freshen.State + ( type S + , State (..), stateZero + , Env (..), envZero + , evalState + , newName + , withModifiedEnvT + , withModifiedEnvX + , mapFreshBinds) +where +import DDC.Source.Tetra.Exp +import Data.Monoid +import Data.Set (Set) +import Data.Map.Strict (Map) +import Data.Text (Text) +import qualified Control.Monad.State as S +import qualified Data.Text as Text +import qualified Data.Set as Set +import qualified Data.Map.Strict as Map + + +------------------------------------------------------------------------------- +-- | State holding a variable name prefix and counter to +-- create fresh variable names. +type S = S.State State + +data State + = State + { -- | Prefix for creating fresh variables. + stateVarPrefix :: Text + + -- | Current counter for creating fresh variables. + , stateVarCount :: Int + + -- | Environment for type level names. + , stateEnvT :: Env + + -- | Environment for value level names. + , stateEnvX :: Env + } + + +-- | Information about a current environemnt. +data Env + = Env + { -- | Stack of names of anonymous binders. + envStack :: [Name] + + -- | Length of the above sack. + , envStackLen :: Int + + -- | Names currently in scope. + , envNames :: Set Name + + -- | Names currently being rewritten. + , envRename :: Map Name Name } + + +-- | The empty environmenet. +envZero :: Env +envZero + = Env + { envStack = [] + , envStackLen = 0 + , envNames = Set.empty + , envRename = Map.empty } + + +-- | The starting state. +stateZero :: Text -> State +stateZero prefix + = State + { stateVarPrefix = prefix + , stateVarCount = 0 + , stateEnvT = envZero + , stateEnvX = envZero } + + +-- | Evaluate a desguaring computation, +-- using the given prefix for freshly introduced variables. +evalState :: Text -> S a -> a +evalState prefix c + = S.evalState c (stateZero prefix) + + +-- | Allocate a new name. +newName :: Text -> S Name +newName pre + = do prefix <- S.gets stateVarPrefix + count <- S.gets stateVarCount + let name = pre <> "$" <> prefix <> Text.pack (show count) + S.modify $ \s -> s { stateVarCount = count + 1 } + return name + + +-- | Run a computation in a modified EnvT, +-- restoring the original environment after it's done. +withModifiedEnvT :: (Env -> Env) -> S a -> S a +withModifiedEnvT modEnvT cont + = do + state <- S.get + let envT = stateEnvT state + let envT' = modEnvT envT + S.put state { stateEnvT = envT' } + + result <- cont + + state' <- S.get + S.put state' { stateEnvT = envT } + return result + + +-- | Run a computation in a modified EnvX, +-- restoring the original environment after it's done. +withModifiedEnvX :: (Env -> Env) -> S a -> S a +withModifiedEnvX modEnvX cont + = do + state <- S.get + let envX = stateEnvX state + let envX' = modEnvX envX + S.put state { stateEnvX = envX' } + + result <- cont + + state' <- S.get + S.put state' { stateEnvX = envX } + return result + + +-- | Given a function that binds and freshens a single thing, +-- binds and freshens a list of things in sequence. +mapFreshBinds + :: (a -> ( a -> S b) -> S b) + -> [a] -> ([a] -> S b) -> S b + +mapFreshBinds freshBind as0 cont + = go [] as0 + where + go asAcc [] + = cont (reverse asAcc) + + go asAcc (a : as) + = freshBind a $ \a' -> go (a' : asAcc) as + diff --git a/DDC/Source/Tetra/Transform/Guards.hs b/DDC/Source/Tetra/Transform/Guards.hs --- a/DDC/Source/Tetra/Transform/Guards.hs +++ b/DDC/Source/Tetra/Transform/Guards.hs @@ -1,68 +1,395 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies, OverloadedStrings #-} --- | Desugaring Source Tetra guards to simple case-expressions. +-- | Desugar guards and nested patterns to match expressions. module DDC.Source.Tetra.Transform.Guards - ( desugarGuards ) + ( type S, evalState, newVar + , desugarModule) where -import DDC.Source.Tetra.Transform.BoundX -import DDC.Source.Tetra.Compounds -import DDC.Source.Tetra.Exp.Annot -import DDC.Type.Exp +import DDC.Source.Tetra.Module +import DDC.Source.Tetra.Prim +import DDC.Source.Tetra.Exp +import Data.Monoid +import Data.Text (Text) +import Control.Monad +import qualified DDC.Data.SourcePos as SP +import qualified Control.Monad.State as S +import qualified Data.Text as Text --- | Desugar some guards to a case-expression. --- At runtime, if none of the guards match then run the provided fail action. -desugarGuards - :: forall a - . GAnnot (Annot a) -- ^ Annotation. - -> [GGuardedExp (Annot a)] -- ^ Guarded expressions to desugar. - -> GExp (Annot a) -- ^ Failure action. - -> GExp (Annot a) +------------------------------------------------------------------------------- +-- | Desugar guards and nested patterns to match expressions. +desugarModule :: Module Source -> S (Module Source) +desugarModule mm + = do ts' <- mapM desugarTop $ moduleTops mm + return $ mm { moduleTops = ts' } -desugarGuards a gs0 fail0 - = go gs0 fail0 - where - -- Desugar list of guarded expressions. - go [] cont - = cont - go [g] cont - = go1 g cont +------------------------------------------------------------------------------- +-- | Desugar a top-level thing. +desugarTop :: Top Source -> S (Top Source) +desugarTop tt + = case tt of + TopClause sp c -> TopClause sp <$> desugarCl sp c + TopData{} -> return tt + TopType{} -> return tt - go (g : gs) cont - = go1 g (go gs cont) - -- Desugar single guarded expression. - go1 (GExp x1) _ - = x1 +------------------------------------------------------------------------------- +-- | Desugar a clause. +desugarCl :: SP -> Clause -> S Clause +desugarCl _sp cc + = case cc of + SSig{} + -> return cc - go1 (GGuard GDefault gs) cont - = go1 gs cont + SLet sp mt ps gxs + -> do (ps', gsParam) <- stripParamsToGuards ps + gxs' <- mapM (desugarGX sp >=> (return . cleanGX)) + $ map (wrapGuards gsParam) gxs - -- Simple cases where we can avoid introducing the continuation. - go1 (GGuard (GPred g1) (GExp x1)) cont - = XCase a g1 - [ AAlt pTrue [GExp x1] - , AAlt PDefault [GExp cont] ] + return $ SLet sp mt ps' gxs' - go1 (GGuard (GPat p1 g1) (GExp x1)) cont - = XCase a g1 - [ AAlt p1 [GExp x1] - , AAlt PDefault [GExp cont]] - -- Cases that use a continuation function as a join point. - -- We need this when desugaring general pattern alternatives, - -- as each group of guards can be reached from multiple places. - go1 (GGuard (GPred x1) gs) cont - = XLet a (LLet (BAnon (tBot kData)) (xBox a cont)) - $ XCase a (liftX 1 x1) - [ AAlt pTrue [GExp (go1 (liftX 1 gs) (xRun a (XVar a (UIx 0))))] - , AAlt PDefault [GExp (xRun a (XVar a (UIx 0))) ]] +------------------------------------------------------------------------------- +-- | Desugar an expression. +desugarX :: SP -> Exp -> S Exp +desugarX sp xx + = case xx of + -- Boilerplate. + XAnnot sp' x -> XAnnot sp' <$> desugarX sp' x + XVar{} -> pure xx + XPrim{} -> pure xx + XCon{} -> pure xx + XLam b x -> XLam b <$> pure x + XLAM b x -> XLAM b <$> pure x + XApp x1 x2 -> XApp <$> desugarX sp x1 <*> desugarX sp x2 + XLet lts x -> XLet <$> desugarLts sp lts <*> desugarX sp x + XCast c x -> XCast c <$> desugarX sp x + XType{} -> pure xx + XWitness{} -> pure xx + XDefix a xs -> XDefix a <$> mapM (desugarX sp) xs + XInfixOp{} -> pure xx + XInfixVar{} -> pure xx + XWhere a x cls -> XWhere a <$> desugarX sp x + <*> mapM (desugarCl sp) cls - go1 (GGuard (GPat p1 x1) gs) cont - = XLet a (LLet (BAnon (tBot kData)) (xBox a cont)) - $ XCase a (liftX 1 x1) - [ AAlt p1 [GExp (go1 (liftX 1 gs) (xRun a (XVar a (UIx 0))))] - , AAlt PDefault [GExp (xRun a (XVar a (UIx 0))) ]] - + -- Desugar a case expression. + XCase xScrut alts + -- Simple alternatives are ones where we can determine whether they + -- match just based on the head pattern. If all the alternatives + -- in a case-expression are simple then we can convert directly + -- to core-level case expressions. + | all isSimpleAltCase alts + -> do xScrut' <- desugarX sp xScrut + alts' <- mapM (desugarAltCase sp) alts + return $ XCase xScrut' alts' + + -- Complex alternatives are ones that have include a guard or some + -- other pattern that may fail, and require us to skip to the next + -- alternatives. These are compiled as per match expressions. + | otherwise + -> do -- Desugar the scrutinee. + xScrut' <- desugarX sp xScrut + + -- We bind the scrutinee to a new variable so we can + -- defer to it multiple times in the body of the match. + (b, u) <- newVar "xScrut" + + -- At the start of each guarded expression we match against + -- the pattern from the original case alternative. + gxsAlt' <- mapM (desugarGX sp >=> (return . cleanGX)) + $ concat [ map (GGuard (GPat p (XVar u))) gxs + | AAltCase p gxs <- alts] + + -- Desugar the body of each alternative. + alts' <- mapM (desugarAltMatch sp) + $ [AAltMatch gx | gx <- gxsAlt'] + + -- Result contains a let-binding to bind the scrutinee, + -- then a match expression that implements the complex + -- case alternatives. + pure $ XLet (LLet (XBindVarMT b Nothing) xScrut') + $ XMatch sp alts' + $ makeXErrorDefault + (Text.pack $ SP.sourcePosSource sp) + (fromIntegral $ SP.sourcePosLine sp) + + -- Desugar a match expression from the source code. + XMatch sp' alts xFail + -> do alts' <- mapM (desugarAltMatch sp') alts + xFail' <- desugarX sp' xFail + pure $ XMatch sp' alts' xFail' + + + -- Desugar lambda with a pattern for the parameter. + XLamPat _a PDefault mt x + -> XLam (XBindVarMT BNone mt) <$> desugarX sp x + + XLamPat _a (PVar b) mt x + -> XLam (XBindVarMT b mt) <$> desugarX sp x + + XLamPat _a p mt x + -> do (b, u) <- newVar "x" + x' <- desugarX sp x + return $ XLam (XBindVarMT b mt) + $ XCase (XVar u) [ AAltCase p [GExp x'] ] + + + -- Desugar lambda case by inserting the intermediate variable. + XLamCase _a alts + -> do (b, u) <- newVar "x" + alts' <- mapM (desugarAltCase sp) alts + return $ XLam (XBindVarMT b Nothing) + $ XCase (XVar u) alts' + + +-- | Check if this is simple Case alternative, which means if the pattern +-- matches then we can run the expression on the right instead of needing +-- to skip to another alternative. +isSimpleAltCase :: AltCase -> Bool +isSimpleAltCase aa + = case aa of + AAltCase p [GExp _] -> isSimplePat p + _ -> False + + +-- | Simple patterns can be converted directly to core. +isSimplePat :: Pat -> Bool +isSimplePat pp + = case pp of + PDefault -> True + PAt{} -> False + PVar{} -> True + PData _ ps -> all isTrivialPat ps + + +-- | Trival patterns are the default one and variables, +-- and don't require an actual pattern to be matched. +isTrivialPat :: Pat -> Bool +isTrivialPat pp + = case pp of + PDefault -> True + PVar{} -> True + _ -> False + + +------------------------------------------------------------------------------- +-- | Desugar some let bindings. +desugarLts :: SP -> Lets -> S Lets +desugarLts sp lts + = case lts of + LLet bm x -> LLet bm <$> desugarX sp x + + LRec bxs + -> do let (bs, xs) = unzip bxs + xs' <- mapM (desugarX sp) xs + let bxs' = zip bs xs' + return $ LRec bxs' + + LPrivate{} -> pure lts + + LGroup cs -> LGroup <$> mapM (desugarCl sp) cs + + +------------------------------------------------------------------------------- +-- | Desugar a guarded expression. +desugarGX :: SP -> GuardedExp -> S GuardedExp +desugarGX sp gx + = case gx of + GGuard (GPat p x) gxInner + -> do x' <- desugarX sp x + (g', gs') <- stripGuardToGuards (GPat p x') + gxInner' <- desugarGX sp gxInner + return $ GGuard g' + $ wrapGuards gs' gxInner' + + GGuard g gx' + -> GGuard <$> desugarG sp g <*> desugarGX sp gx' + + GExp x + -> GExp <$> desugarX sp x + + +-- | Desugar a guard. +desugarG :: SP -> Guard -> S Guard +desugarG sp g + = case g of + GPat p x -> GPat p <$> desugarX sp x + GPred x -> GPred <$> desugarX sp x + GDefault -> pure GDefault + + +------------------------------------------------------------------------------- +-- | Desugar a case alternative. +desugarAltCase :: SP -> AltCase -> S AltCase +desugarAltCase sp (AAltCase p gxs) + = do gxs' <- mapM (desugarGX sp >=> (return . cleanGX)) gxs + pure $ AAltCase p gxs' + + +-- | Desugar a match alternative. +desugarAltMatch :: SP -> AltMatch -> S AltMatch +desugarAltMatch sp (AAltMatch gx) + = do gx' <- (desugarGX sp >=> (return . cleanGX)) gx + pure $ AAltMatch gx' + + +------------------------------------------------------------------------------- +-- | Strip out patterns in the given parameter list, +-- yielding a list of guards that implement the patterns. +stripParamsToGuards :: [Param] -> S ([Param], [Guard]) +stripParamsToGuards [] + = return ([], []) + +stripParamsToGuards (p:ps) + = case p of + MType{} + -> do (ps', gs) <- stripParamsToGuards ps + return (p : ps', gs) + + MWitness{} + -> do (ps', gs) <- stripParamsToGuards ps + return (p : ps', gs) + + MValue PDefault _mt + -> do (ps', gs) <- stripParamsToGuards ps + return (p : ps', gs) + + MValue (PVar _b) _mt + -> do (ps', gs) <- stripParamsToGuards ps + return (p : ps', gs) + + MValue (PAt b p1) _mt + -> do (psParam', gsRest) <- stripParamsToGuards ps + ([p1'], gsData) <- stripPatsToGuards [p1] + let Just u = takeBoundOfBind b + return ( MValue (PVar b) _mt : psParam' + , GPat p1' (XVar u) + : (gsData ++ gsRest)) + + MValue (PData dc psData) mt + -> do (psParam', gsRest) <- stripParamsToGuards ps + (psData', gsData) <- stripPatsToGuards psData + (b, u) <- newVar "p" + return ( MValue (PVar b) mt : psParam' + , GPat (PData dc psData') (XVar u) + : (gsData ++ gsRest)) + + +-- | Strip out nested patterns from the given pattern list, +-- yielding a list of guards that implement the patterns. +stripPatsToGuards :: [Pat] -> S ([Pat], [Guard]) +stripPatsToGuards [] + = return ([], []) + +stripPatsToGuards (p:ps) + = case p of + -- Match against defaults directly. + PDefault + -> do (ps', gs) <- stripPatsToGuards ps + return (p : ps', gs) + + -- Match against vars directly. + PVar _b + -> do (ps', gs) <- stripPatsToGuards ps + return (p : ps', gs) + + -- Strip at patterns. + PAt b p1 + -> do -- Strip the rest of the patterns. + (psRest', gsRest) <- stripPatsToGuards ps + + -- Strip nested patterns from the argument. + ([p1'], gsData) <- stripPatsToGuards [p1] + let Just u = takeBoundOfBind b + + return ( PVar b : psRest' + , GPat p1' (XVar u) + : (gsData ++ gsRest)) + + -- Strip out nested patterns in the arguments of a data constructor. + PData dc psData + -> do -- Strip the rest of the patterns. + (psRest', gsRest) <- stripPatsToGuards ps + + -- Strip nested patterns out of the arguments. + (psData', gsData) <- stripPatsToGuards psData + + -- Make a new name to bind the value we are matching against. + (b, u) <- newVar "p" + return ( PVar b : psRest' + , GPat (PData dc psData') (XVar u) + : (gsData ++ gsRest) ) + + +-- | Like `stripPatsToGuards` but we take the whole enclosing guards. +-- This gives us access to the expression being scrutinised, +-- which we can match against directly without introducing a new variable. +stripGuardToGuards :: Guard -> S (Guard, [Guard]) +stripGuardToGuards g + = case g of + -- Match against defaults and vars directly. + GPat PDefault _ -> return (g, []) + GPat PVar{} _ -> return (g, []) + + -- As we alerady have the expression being matched we don't + -- need to introduce a new variable to name it. + GPat (PAt b p) x + -> do ([p'], gsData) <- stripPatsToGuards [p] + let Just u = takeBoundOfBind b + return ( GPat (PVar b) x + , GPat p' (XVar u) : gsData) + + GPat (PData dc psData) x + -> do (psData', gsData) <- stripPatsToGuards psData + return ( GPat (PData dc psData') x + , gsData) + + GPred{} -> return (g, []) + GDefault{} -> return (g, []) + + +-- | Wrap more guards around the outside of a guarded expression. +wrapGuards :: [Guard] -> GuardedExp -> GuardedExp +wrapGuards [] gx = gx +wrapGuards (g : gs) gx = GGuard g (wrapGuards gs gx) + + +-- | Clean out default patterns from a guarded expression. +-- +-- We end up with default patterns in guards when desugaring default +-- alternatives, but they serve no purpose in the desugared code. +cleanGX :: GuardedExp -> GuardedExp +cleanGX gx + = case gx of + GGuard GDefault gx' -> cleanGX gx' + GGuard g gx' -> GGuard g $ cleanGX gx' + GExp x -> GExp x + + +------------------------------------------------------------------------------- +-- | Source position. +type SP = SP.SourcePos + + +-- | State holding a variable name prefix and counter to +-- create fresh variable names. +type S = S.State (Text, Int) + + +-- | Evaluate a desguaring computation, +-- using the given prefix for freshly introduced variables. +evalState :: Text -> S a -> a +evalState n c + = S.evalState c (n, 0) + + +-- | Allocate a new named variable, yielding its associated bind and bound. +newVar :: Text -> S (Bind, Bound) +newVar pre + = do (n, i) <- S.get + let name = pre <> "$" <> n <> Text.pack (show i) + S.put (n, i + 1) + return (BName name, UName name) + diff --git a/DDC/Source/Tetra/Transform/Matches.hs b/DDC/Source/Tetra/Transform/Matches.hs new file mode 100644 --- /dev/null +++ b/DDC/Source/Tetra/Transform/Matches.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE TypeFamilies, OverloadedStrings #-} +-- | Desugar match expressions to case expressions. +-- +-- In a match expression if matching fails in one block of guards then +-- we skip to the next block. This introduces join point at the start +-- of every block of guards execpt the first one, which we need to flatten +-- out when converting to plain case expressions. +-- +-- We also merge multiple clauses for the same function into a single one +-- while we're here. +-- +module DDC.Source.Tetra.Transform.Matches + ( type S, evalState, newVar + , desugarModule) +where +import DDC.Source.Tetra.Module +import DDC.Source.Tetra.Prim +import DDC.Source.Tetra.Exp +import Data.Monoid +import Data.Text (Text) +import qualified DDC.Data.SourcePos as SP +import qualified Control.Monad.State as S +import qualified Data.Text as Text + + +------------------------------------------------------------------------------- +-- | Desugar match expressions to case expressions in a module. +desugarModule :: Module Source -> S (Module Source) +desugarModule mm + = do ts' <- desugarTops $ moduleTops mm + return $ mm { moduleTops = ts' } + + +------------------------------------------------------------------------------- +-- | Desugar top-level definitions. +desugarTops :: [Top Source] -> S [Top Source] +desugarTops ts + = do let tsType = [t | t@TopType{} <- ts] + let tsData = [t | t@TopData{} <- ts] + let spCls = [(sp, cl) | TopClause sp cl <- ts] + + -- We may have multiple clauses for the same function in a single + -- group, so we need to pass them all to the clause group + -- desugarer at once. + spCls' <- desugarClGroup spCls + + return $ tsType + ++ tsData + ++ [TopClause sp cl | (sp, cl) <- spCls'] + + +------------------------------------------------------------------------------- +-- | Desugar a clause group. +desugarClGroup :: [(SP, Clause)] -> S [(SP, Clause)] +desugarClGroup spcls0 + = loop spcls0 + where + + -- We've reached the end of the list of clauses. + loop [] + = return [] + + -- Signatures do not need desugaring. + loop ((sp, cl@SSig{}) : cls) + = do cls' <- loop cls + return $ (sp, cl) : cls' + + -- We have a let-clause. + loop ( (sp, SLet sp1 (XBindVarMT b1 mt1) ps1 gxs1) : cls) + = loop cls >>= \cls' + -> case cls' of + + -- Consecutive clauses are for the same function. + (_, SLet _sp2 (XBindVarMT b2 _mt2) ps2 [GExp xNext]) : clsRest + | b1 == b2 + -> do + -- Flatten out guards, wrapping the next expression + -- with case expressions to implement them. + xBody_inner <- flattenGXs gxs1 xNext + + -- Recursively desugar the flattened expression + xBody_rec <- desugarX sp xBody_inner + + -- Intoduce new let-bindings to handle the case + -- where different clauses name their parameters + -- differently. + (ps1', _ps2', xBody_join) + <- joinParams ps1 ps2 xBody_rec + + return $ (sp, SLet sp1 (XBindVarMT b1 mt1) ps1' + [GExp xBody_join]) + : clsRest + + -- Consecutive clauses are not for the same function. + _ -> do let xError = makeXErrorDefault + (Text.pack $ SP.sourcePosSource sp1) + (fromIntegral $ SP.sourcePosLine sp1) + + -- Flatten out guards, wrapping the error expression + -- with case expressions to implement them. + xBody_inner <- flattenGXs gxs1 xError + + -- Recursively desugar the flattened expression. + xBody' <- desugarX sp xBody_inner + + return $ (sp, SLet sp1 (XBindVarMT b1 mt1) ps1 + [GExp xBody']) + : cls' + + +-- | Given corresponding parameters for earlier and later clauses, +-- introduce let bindings to handle differences in parameter naming. +joinParams :: [Param] -> [Param] -> Exp + -> S ([Param], [Param], Exp) + +joinParams [] ps2 xx + = return ([], ps2, xx) + +joinParams ps1 [] xx + = return (ps1, [], xx) + +joinParams (p1:ps1) (p2:ps2) xx + = do + (p1', p2', mLets) <- joinParam p1 p2 + (ps1', ps2', xx') <- joinParams ps1 ps2 xx + + case mLets of + Nothing + -> return (p1' : ps1', p2' : ps2', xx') + + Just lts + -> return (p1' : ps1', p2' : ps2', XLet lts xx') + + +-- | Given corresponding parameters for earlier and later clauses, +-- introduce let bindings to handle differences in parameter naming. +joinParam :: Param -> Param + -> S (Param, Param, Maybe Lets) + +joinParam p1 p2 + = case (p1, p2) of + -- When an earlier pattern does not bind the argument to a variable + -- then we need to introduce a new variable so we can pass the + -- same argument to successive clauses. + ( MValue pat1 mt1 + , MValue (PVar (BName n2)) mt2) + | isAnonPat pat1 + -> do (b, u) <- newVar "m" + let lts = LLet (XBindVarMT (BName n2) mt2) (XVar u) + return (MValue (PVar b) mt1, p2, Just lts) + + -- When earlier clauses bind the argument using a different variable + -- than later ones then we need to add a synonym. + ( MValue (PVar (BName n1)) _mt1 + , MValue (PVar (BName n2)) mt2) + | n1 /= n2 + -> do let lts = LLet (XBindVarMT (BName n2) mt2) (XVar (UName n1)) + return (p1, p2, Just lts) + + _ -> return (p1, p2, Nothing) + + +-- | Check if this pattern does not bind a variable. +isAnonPat :: Pat -> Bool +isAnonPat pp + = case pp of + PDefault -> True + PVar BAnon -> True + _ -> False + + +------------------------------------------------------------------------------- +-- | Desugar an expression. +desugarX :: SP -> Exp -> S Exp +desugarX sp xx + = case xx of + -- Boilerplate. + XAnnot sp' x -> XAnnot sp' <$> desugarX sp' x + XVar{} -> pure xx + XPrim{} -> pure xx + XCon{} -> pure xx + XLam b x -> XLam b <$> desugarX sp x + XLAM b x -> XLAM b <$> desugarX sp x + XApp x1 x2 -> XApp <$> desugarX sp x1 <*> desugarX sp x2 + XLet lts x -> XLet <$> desugarLts sp lts <*> desugarX sp x + XCast c x -> XCast c <$> desugarX sp x + XType{} -> pure xx + XWitness{} -> pure xx + XDefix a xs -> XDefix a <$> mapM (desugarX sp) xs + XInfixOp{} -> pure xx + XInfixVar{} -> pure xx + + -- Desugar case expressions. + XCase x alts + -> XCase <$> desugarX sp x + <*> mapM (desugarAC sp) alts + + -- Desugar match expressions into case expressions. + XMatch _ alts xFail + -> do let gxs = [gx | AAltMatch gx <- alts] + xFlat <- flattenGXs gxs xFail + xFlat' <- desugarX sp xFlat + return xFlat' + + XWhere sp' x cls + -> do x' <- desugarX sp' x + let spcls = [(sp', cl) | cl <- cls] + spcls' <- desugarClGroup spcls + return $ XWhere sp' x' (map snd spcls') + + XLamPat sp' w mt x + -> XLamPat sp' w mt <$> desugarX sp x + + XLamCase sp' alts + -> XLamCase sp' <$> mapM (desugarAC sp) alts + + +------------------------------------------------------------------------------- +-- | Desugar some let bindings. +desugarLts :: SP -> Lets -> S Lets +desugarLts sp lts + = case lts of + LLet mb x -> LLet mb <$> desugarX sp x + + LRec bxs + -> do let (bs, xs) = unzip bxs + xs' <- mapM (desugarX sp) xs + return $ LRec $ zip bs xs' + + LPrivate{} -> return lts + + LGroup cls + -> do let spcls = zip (repeat sp) cls + spcls' <- desugarClGroup spcls + return $ LGroup $ map snd spcls' + + +------------------------------------------------------------------------------- +-- | Desugar a guarded expression. +desugarGX :: SP -> GuardedExp -> S GuardedExp +desugarGX sp gx + = case gx of + GGuard g gx' -> GGuard <$> desugarG sp g <*> desugarGX sp gx' + GExp x -> GExp <$> desugarX sp x + + +------------------------------------------------------------------------------- +-- | Desugar a guard. +desugarG :: SP -> Guard -> S Guard +desugarG sp g + = case g of + GPat p x -> GPat p <$> desugarX sp x + GPred x -> GPred <$> desugarX sp x + GDefault -> pure GDefault + + +------------------------------------------------------------------------------- +-- | Desugar a case alternative. +desugarAC :: SP -> AltCase -> S AltCase +desugarAC sp (AAltCase p gxs) + = do gxs' <- mapM (desugarGX sp) gxs + return $ AAltCase p gxs' + + +------------------------------------------------------------------------------- +-- | Desugar some guards to a case-expression. +-- At runtime, if none of the guards match then run the provided +-- fall-though computation. +flattenGXs :: [GuardedExp] -> Exp -> S Exp +flattenGXs gs0 fail0 + = go gs0 fail0 + where + -- Desugar list of guarded expressions. + go [] cont + = return cont + + go [g] cont + = go1 g cont + + go (g : gs) cont + = do gs' <- go gs cont + go1 g gs' + + -- Desugar single guarded expression. + go1 (GExp x1) _ + = return x1 + + go1 (GGuard GDefault gs) cont + = go1 gs cont + + -- Simple cases where we can avoid introducing the continuation. + go1 (GGuard (GPred g1) (GExp x1)) cont + = return + $ XCase g1 [ AAltCase PTrue [GExp x1] + , AAltCase PDefault [GExp cont] ] + + go1 (GGuard (GPat p1 g1) (GExp x1)) cont + = return + $ XCase g1 [ AAltCase p1 [GExp x1] + , AAltCase PDefault [GExp cont]] + + -- Cases that use a continuation function as a join point. + -- We need this when desugaring general pattern alternatives, + -- as each group of guards can be reached from multiple places. + go1 (GGuard (GPred x1) gs) cont + = do (b, u) <- newVar "m" + x' <- go1 gs (XRun (XVar u)) + return + $ XLet (LLet (XBindVarMT b Nothing) (XBox cont)) + $ XCase x1 [ AAltCase PTrue [GExp x'] + , AAltCase PDefault [GExp (XRun (XVar u)) ]] + + go1 (GGuard (GPat p1 x1) gs) cont + = do (b, u) <- newVar "m" + x' <- go1 gs (XRun (XVar u)) + return + $ XLet (LLet (XBindVarMT b Nothing) (XBox cont)) + $ XCase x1 [ AAltCase p1 [GExp x'] + , AAltCase PDefault [GExp (XRun (XVar u)) ]] + + +------------------------------------------------------------------------------- +-- | Source position. +type SP = SP.SourcePos + + +-- | State holding a variable name prefix and counter to +-- create fresh variable names. +type S = S.State (Text, Int) + + +-- | Evaluate a desguaring computation, +-- using the given prefix for freshly introduced variables. +evalState :: Text -> S a -> a +evalState n c + = S.evalState c (n, 0) + + +-- | Allocate a new named variable, yielding its associated bind and bound. +newVar :: Text -> S (Bind, Bound) +newVar pre + = do (n, i) <- S.get + let name = pre <> "$" <> n <> Text.pack (show i) + S.put (n, i + 1) + return (BName name, UName name) + diff --git a/DDC/Source/Tetra/Transform/Prep.hs b/DDC/Source/Tetra/Transform/Prep.hs new file mode 100644 --- /dev/null +++ b/DDC/Source/Tetra/Transform/Prep.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE TypeFamilies, OverloadedStrings #-} +-- | A light simplification pass before conversion of desugared code to Core. +module DDC.Source.Tetra.Transform.Prep + ( type S, evalState, newVar + , desugarModule) +where +import DDC.Source.Tetra.Module +import DDC.Source.Tetra.Exp +import Data.Monoid +import Data.Text (Text) +import Data.Map (Map) +import qualified Control.Monad.State.Strict as S +import qualified Data.Text as Text +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + + +--------------------------------------------------------------------------------------------------- +-- | State holding a variable name prefix and counter to +-- create fresh variable names. +type S = S.State (Bool, Text, Int) + + +-- | Evaluate a desguaring computation, +-- using the given prefix for freshly introduced variables. +evalState :: Text -> S a -> a +evalState n c + = S.evalState c (False, n, 0) + + +-- | Allocate a new named variable, yielding its associated bind and bound. +newVar :: Text -> S (Bind, Bound) +newVar pre + = do (p, n, i) <- S.get + let name = pre <> "$" <> n <> Text.pack (show i) + S.put (p, n, i + 1) + return (BName name, UName name) + + +-- | Set the progress flag in the state. +progress :: S () +progress + = do (_, n, i) <- S.get + S.put (True, n, i) + + +--------------------------------------------------------------------------------------------------- +-- | Desguar a module. +-- +-- We keep applying the prep transforms we have until they +-- stop making progress. +-- +desugarModule :: Module Source -> S (Module Source) +desugarModule mm + = do (_, n, i) <- S.get + S.put (False, n, i) + + mm' <- desugarModule1 mm + (p', _, _) <- S.get + + if p' then desugarModule mm' + else return mm' + + +-- | Prepare a source module for conversion to core. +desugarModule1 :: Module Source -> S (Module Source) +desugarModule1 mm + = do ts' <- mapM desugarTop $ moduleTops mm + return $ mm { moduleTops = ts' } + + +--------------------------------------------------------------------------------------------------- +-- | Desugar a top-level definition. +desugarTop :: Top Source -> S (Top Source) +desugarTop tt + = case tt of + TopType{} -> return tt + TopData{} -> return tt + TopClause sp cl -> TopClause sp <$> desugarCl Map.empty cl + + +--------------------------------------------------------------------------------------------------- +-- | Desugar a clause. +desugarCl + :: Map Name Name + -> Clause -> S Clause + +desugarCl rns cl + = case cl of + SSig{} + -> return cl + + SLet a b ps gxs + -> do ps' <- mapM desugarP ps + gxs' <- mapM (desugarGX rns) gxs + return $ SLet a b ps' gxs' + + +desugarP :: Param -> S Param +desugarP pp + = case pp of + MType{} -> return pp + MWitness{} -> return pp + MValue w mt -> MValue <$> desugarW w <*> return mt + + +--------------------------------------------------------------------------------------------------- +-- | Desugar a guarded expression. +desugarGX + :: Map Name Name + -> GuardedExp -> S GuardedExp + +desugarGX rns gx + = case gx of + GGuard g gx' -> GGuard <$> desugarG rns g <*> desugarGX rns gx' + GExp x -> GExp <$> desugarX rns x + + +--------------------------------------------------------------------------------------------------- +-- | Desugar a guard. +desugarG :: Map Name Name + -> Guard -> S Guard + +desugarG rns gg + = case gg of + GPat p x -> GPat <$> desugarW p <*> desugarX rns x + GPred x -> GPred <$> desugarX rns x + GDefault -> return GDefault + + +--------------------------------------------------------------------------------------------------- +-- | Desugar an expression. +desugarX :: Map Name Name -- ^ Renamed bound variables. + -> Exp -> S Exp + +desugarX rns xx + = case xx of + -- Lift out nested box casts. + -- This speculatively allocates the inner box, + -- but means it's easier to find (run (box x)) pairs + -- + -- let b1 = box (let b2 = box x3 + -- in x2) + -- in x1 + -- + -- => let b2 = box x3 in + -- let b1 = box x2 in + -- x1 + -- + -- This transform makes b2 scope over x1 where it didn't before, + -- so we rename it along the way to avoid variable clashes. + -- + XLet (LLet b1 + (XCast CastBox + (XLet (LLet (XBindVarMT (BName n2) mt2) + (XCast CastBox x3)) + x2))) + x1 + -> do + progress + + -- Make a new name for b2 and desugar x2 to force the rename. + (b2', (UName n2')) <- newVar "x" + x2' <- desugarX (Map.insert n2 n2' rns) x2 + + desugarX rns + $ XLet (LLet (XBindVarMT b2' mt2) (XCast CastBox x3)) + $ XLet (LLet b1 (XCast CastBox x2')) + $ x1 + + + -- Eliminate trivial v1 = v2 bindings. + XLet (LLet (XBindVarMT (BName n1) _) (XVar (UName n2))) x1 + -> do let rns' = Map.insert n1 n2 rns + progress + desugarX rns' x1 + + + -- The match desugarer introduces case alternatives where the pattern + -- is just a variable, which we can convert to a let-expression. + XCase x0 ( AAltCase (PVar b) [GExp x1] : _) + -> do progress + desugarX rns + $ XLet (LLet (XBindVarMT b Nothing) x0) + $ x1 + + -- If the first pattern is a default and none of the other alternatives + -- constrain the type of the scrutinee then the core type inferencer + -- won't be able to determine the match type. + XCase _x0 alts@(AAltCase PDefault [GExp x1] : _) + | null [ p | AAltCase p@(PData _ _) _ <- alts] + -> do progress + desugarX rns x1 + + -- Translate out varible patterns. + -- The core language does not include them, so we bind the + -- scrutinee with a new name and substitute that for the + -- name bound by the variable patterns. + XCase x0 alts + -- Only do the rewrite if at least one expression has + -- such a variable pattern. + | ns <- [n | AAltCase (PVar n) _ <- alts] + , not $ null ns + -> do + progress + + -- Desugar the scrutinee. + x0' <- desugarX rns x0 + + -- New variable to bind the scrutinee. + (b, u@(UName nScrut)) <- newVar "xScrut" + + -- For each alternative, if it has a variable pattern + -- then substitute the new name for it in the alternative. + let desugarAlt (AAltCase (PVar (BName n1)) gxs) + = do let rns' = Map.insert n1 nScrut rns + gxs' <- mapM (desugarGX rns') gxs + return $ AAltCase PDefault gxs' + + desugarAlt (AAltCase p gxs) + = do gxs' <- mapM (desugarGX rns) gxs + return $ AAltCase p gxs' + + alts' <- mapM desugarAlt alts + + -- The final expression. + return + $ XLet (LLet (XBindVarMT b Nothing) x0') + $ XCase (XVar u) alts' + + + -- Eliminate (run (box x)) pairs. + XCast CastBox (XCast CastRun x) + -> do progress + desugarX rns x + + + -- Lookup renames from the variable rename map. + XVar (UName n0) + -> let sink entered n + = case Map.lookup n rns of + Just n' + | Set.member n' entered + -> n' + + | otherwise + -> sink (Set.insert n' entered) n' + + Nothing -> n + + in do + let n0' = sink Set.empty n0 + if n0 /= n0' + then do + progress + return $ XVar (UName n0') + + else return xx + + + -- Convert XWhere to let expressions. + XWhere _sp x cls + -> do x' <- desugarX rns x + cls' <- mapM (desugarCl rns) cls + return $ XLet (LGroup cls') x' + + + -- Boilerplate. + XAnnot a x -> XAnnot a <$> desugarX rns x + XVar{} -> return xx + XPrim{} -> return xx + XCon{} -> return xx + XLAM mb x -> XLAM mb <$> desugarX rns x + XLam mb x -> XLam mb <$> desugarX rns x + XApp x1 x2 -> XApp <$> desugarX rns x1 <*> desugarX rns x2 + XLet lts x -> XLet <$> desugarLts rns lts <*> desugarX rns x + XCase x as -> XCase <$> desugarX rns x <*> mapM (desugarAC rns) as + XCast c x -> XCast c <$> desugarX rns x + XType{} -> return xx + XWitness{} -> return xx + XDefix sp xs -> XDefix sp <$> mapM (desugarX rns) xs + XInfixOp{} -> return xx + XInfixVar{} -> return xx + XMatch sp as x -> XMatch sp <$> mapM (desugarAM rns) as <*> desugarX rns x + XLamPat sp p mt x -> XLamPat sp p mt <$> desugarX rns x + XLamCase sp alts -> XLamCase sp <$> mapM (desugarAC rns) alts + + +--------------------------------------------------------------------------------------------------- +-- | Desugar a case alternative. +desugarAC + :: Map Name Name + -> AltCase -> S AltCase + +desugarAC rns aa + = case aa of + AAltCase p gxs + -> AAltCase <$> desugarW p <*> mapM (desugarGX rns) gxs + + +-- | Desugar a match alternative. +desugarAM + :: Map Name Name + -> AltMatch -> S AltMatch + +desugarAM rns (AAltMatch gx) + = AAltMatch <$> desugarGX rns gx + + +-- | Desugar a pattern. +desugarW :: Pat -> S Pat +desugarW pp + = case pp of + -- Convert var binders where the variable is a wild card to + -- the default pattern. We can't convert plain variable patterns + -- to core. + PVar BNone + -> do progress + return PDefault + + PDefault -> return PDefault + PAt b p -> PAt b <$> desugarW p + PVar b -> return $ PVar b + PData dc ps -> PData dc <$> mapM desugarW ps + + +--------------------------------------------------------------------------------------------------- +-- | Desugar some let-bindings. +desugarLts + :: Map Name Name + -> Lets -> S Lets + +desugarLts rns lts + = case lts of + LLet mb x -> LLet mb <$> desugarX rns x + LPrivate{} -> return lts + LGroup cls -> LGroup <$> mapM (desugarCl rns) cls + LRec bxs + -> do let (bs, xs) = unzip bxs + xs' <- mapM (desugarX rns) xs + return $ LRec $ zip bs xs' + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2014 The Disciplined Disciple Compiler Strike Force +Copyrite (K) 2007-2016 The Disciplined Disciple Compiler Strike Force All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy diff --git a/ddc-source-tetra.cabal b/ddc-source-tetra.cabal --- a/ddc-source-tetra.cabal +++ b/ddc-source-tetra.cabal @@ -1,5 +1,5 @@ Name: ddc-source-tetra -Version: 0.4.2.1 +Version: 0.4.3.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -17,28 +17,34 @@ Library Build-Depends: - base >= 4.6 && < 4.9, + base >= 4.6 && < 4.10, array >= 0.4 && < 0.6, deepseq >= 1.3 && < 1.5, - containers == 0.5.*, text >= 1.0 && < 1.3, - transformers == 0.4.*, + containers == 0.5.*, + transformers == 0.5.*, + pretty-show >= 1.6.10 && < 1.7, mtl == 2.2.1.*, - ddc-base == 0.4.2.*, - ddc-core == 0.4.2.*, - ddc-core-salt == 0.4.2.*, - ddc-core-tetra == 0.4.2.* + ddc-core == 0.4.3.*, + ddc-core-salt == 0.4.3.*, + ddc-core-tetra == 0.4.3.* Exposed-modules: - DDC.Source.Tetra.Exp.Annot + DDC.Source.Tetra.Exp.Bind + DDC.Source.Tetra.Exp.Compounds DDC.Source.Tetra.Exp.Generic + DDC.Source.Tetra.Exp.NFData + DDC.Source.Tetra.Exp.Predicates + DDC.Source.Tetra.Exp.Source DDC.Source.Tetra.Transform.BoundX DDC.Source.Tetra.Transform.Defix DDC.Source.Tetra.Transform.Expand + DDC.Source.Tetra.Transform.Freshen DDC.Source.Tetra.Transform.Guards + DDC.Source.Tetra.Transform.Matches + DDC.Source.Tetra.Transform.Prep - DDC.Source.Tetra.Compounds DDC.Source.Tetra.Convert DDC.Source.Tetra.DataDef DDC.Source.Tetra.Env @@ -46,35 +52,49 @@ DDC.Source.Tetra.Lexer DDC.Source.Tetra.Module DDC.Source.Tetra.Parser - DDC.Source.Tetra.Predicates DDC.Source.Tetra.Pretty DDC.Source.Tetra.Prim Other-modules: + DDC.Source.Tetra.Collect.FreeVars + + DDC.Source.Tetra.Convert.Base + DDC.Source.Tetra.Convert.Clause DDC.Source.Tetra.Convert.Error + DDC.Source.Tetra.Convert.Prim + DDC.Source.Tetra.Convert.Type + DDC.Source.Tetra.Convert.Witness - DDC.Source.Tetra.Parser.Atom + DDC.Source.Tetra.Parser.Base DDC.Source.Tetra.Parser.Exp DDC.Source.Tetra.Parser.Module DDC.Source.Tetra.Parser.Param + DDC.Source.Tetra.Parser.Type DDC.Source.Tetra.Parser.Witness DDC.Source.Tetra.Prim.Base DDC.Source.Tetra.Prim.OpArith + DDC.Source.Tetra.Prim.OpCast DDC.Source.Tetra.Prim.OpError DDC.Source.Tetra.Prim.OpFun DDC.Source.Tetra.Prim.OpVector + DDC.Source.Tetra.Prim.TyCon DDC.Source.Tetra.Prim.TyConPrim DDC.Source.Tetra.Prim.TyConTetra DDC.Source.Tetra.Transform.Defix.Error DDC.Source.Tetra.Transform.Defix.FixTable + DDC.Source.Tetra.Transform.Freshen.State + + + GHC-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures -fno-warn-missing-methods + -fno-warn-missing-pattern-synonym-signatures -fno-warn-unused-do-bind Extensions: