diff --git a/src/Rlp/AltParse.y b/src/Rlp/AltParse.y index 1cbf7f1..073e0e2 100644 --- a/src/Rlp/AltParse.y +++ b/src/Rlp/AltParse.y @@ -120,6 +120,16 @@ FunD :: { Decl PsName (RlpExpr PsName) } Expr :: { RlpExpr PsName } : AppE { $1 } | LetE { $1 } + | CaseE { $1 } + +CaseE :: { RlpExpr PsName } + : case Expr of CaseAlts { Finr $ CaseEF $2 $4 } + +CaseAlts :: { [Alter PsName (RlpExpr PsName)] } + : layout1(CaseAlt) { $1 } + +CaseAlt :: { Alter PsName (RlpExpr PsName) } + : Pat '->' Expr { Alter $1 $3 } LetE :: { RlpExpr PsName } : let layout1(Binding) in Expr @@ -140,9 +150,15 @@ Pat1s :: { [Pat PsName] } Pat1 :: { Pat PsName } : Var { VarP $1 } + | Con { ConP $1 } + | '(' Pat ')' { $2 } Pat :: { Pat PsName } + : AppP { $1 } + +AppP :: { Pat PsName } : Pat1 { $1 } + | AppP Pat1 { $1 `AppP` $2 } Con :: { PsName } : conname { $1 ^. to extract diff --git a/src/Rlp/AltSyntax.hs b/src/Rlp/AltSyntax.hs index bc625bd..16ddd42 100644 --- a/src/Rlp/AltSyntax.hs +++ b/src/Rlp/AltSyntax.hs @@ -3,11 +3,15 @@ module Rlp.AltSyntax ( -- * AST Program(..), Decl(..), ExprF(..), Pat(..) - , RlpExprF, RlpExpr, Binding(..) + , RlpExprF, RlpExpr, Binding(..), Alter(..) , DataCon(..), Type(..) , Core.Name, PsName + -- * Optics + , programDecls + , _VarP, _FunB, _VarB + -- * Functor-related tools , Fix(..), Cofree(..), Sum(..), pattern Finl, pattern Finr ) @@ -17,6 +21,7 @@ import Data.Functor.Sum import Control.Comonad.Cofree import Data.Fix import Data.Function (fix) +import Control.Lens import Text.Show.Deriving import Data.Text qualified as T @@ -31,6 +36,9 @@ type PsName = T.Text newtype Program b a = Program [Decl b a] deriving Show +programDecls :: Lens' (Program b a) [Decl b a] +programDecls = lens (\ (Program ds) -> ds) (const Program) + data Decl b a = FunD b [Pat b] a | DataD b [b] [DataCon b] deriving Show @@ -46,10 +54,15 @@ data Type b = VarT b data ExprF b a = InfixEF b a a | LetEF Core.Rec [Binding b a] a + | CaseEF a [Alter b a] + deriving (Functor, Foldable, Traversable) + +data Alter b a = Alter (Pat b) a + deriving (Show, Functor, Foldable, Traversable) data Binding b a = FunB b [Pat b] a | VarB (Pat b) a - deriving Show + deriving (Show, Functor, Foldable, Traversable) -- type Expr b = Cofree (ExprF b) @@ -58,8 +71,11 @@ type RlpExprF b = Sum (Core.ExprF b) (ExprF b) type RlpExpr b = Fix (RlpExprF b) data Pat b = VarP b - deriving Show + | ConP b + | AppP (Pat b) (Pat b) + deriving Show +deriveShow1 ''Alter deriveShow1 ''Binding deriveShow1 ''ExprF deriving instance (Show b, Show a) => Show (ExprF b a) @@ -75,9 +91,19 @@ pattern Finr ga = Fix (InR ga) instance (Pretty b, Pretty a) => Pretty (ExprF b a) where prettyPrec = prettyPrec1 +instance (Pretty b, Pretty a) => Pretty (Alter b a) where + prettyPrec = prettyPrec1 + +instance (Pretty b) => Pretty1 (Alter b) where + liftPrettyPrec pr _ (Alter p e) = + hsep [ pretty p, "->", pr 0 e] + instance Pretty b => Pretty1 (ExprF b) where liftPrettyPrec pr p (InfixEF o a b) = maybeParens (p>0) $ pr 1 a <+> pretty o <+> pr 1 b + liftPrettyPrec pr p (CaseEF e as) = maybeParens (p>0) $ + hsep [ "case", pr 0 e, "of" ] + $+$ nest 2 (vcat $ liftPrettyPrec pr 0 <$> as) instance (Pretty b, Pretty a) => Pretty (Decl b a) where prettyPrec = prettyPrec1 @@ -107,6 +133,9 @@ instance (Pretty b) => Pretty (Type b) where instance (Pretty b) => Pretty (Pat b) where prettyPrec p (VarP b) = prettyPrec p b + prettyPrec p (ConP b) = prettyPrec p b + prettyPrec p (AppP c x) = maybeParens (p>appPrec) $ + prettyPrec appPrec c <+> prettyPrec appPrec1 x instance (Pretty a, Pretty b) => Pretty (Program b a) where prettyPrec = prettyPrec1 @@ -114,3 +143,6 @@ instance (Pretty a, Pretty b) => Pretty (Program b a) where instance (Pretty b) => Pretty1 (Program b) where liftPrettyPrec pr p (Program ds) = vsep $ liftPrettyPrec pr p <$> ds +makePrisms ''Pat +makePrisms ''Binding + diff --git a/src/Rlp2Core.hs b/src/Rlp2Core.hs index e65607c..e0b1bcd 100644 --- a/src/Rlp2Core.hs +++ b/src/Rlp2Core.hs @@ -36,10 +36,9 @@ import Effectful import Text.Show.Deriving import Core.Syntax as Core -import Rlp.Syntax as Rlp +import Rlp.AltSyntax as Rlp import Compiler.Types import Data.Pretty (render, pretty) -import Rlp.Parse.Types (RlpcPs, PsName) -------------------------------------------------------------------------------- type Tree a = Either Name (Name, Branch a) @@ -60,19 +59,17 @@ deriveShow1 ''Branch -------------------------------------------------------------------------------- -desugarRlpProgR :: forall m. (Monad m) - => Rlp.Program RlpcPs SrcSpan +desugarRlpProgR :: forall m a. (Monad m) + => Rlp.Program PsName a -> RLPCT m Core.Program' desugarRlpProgR p = do let p' = desugarRlpProg p addDebugMsg "dump-desugared" $ render (pretty p') pure p' -desugarRlpProg :: Rlp.Program RlpcPs SrcSpan -> Core.Program' -desugarRlpProg = rlpProgToCore +desugarRlpProg = undefined -desugarRlpExpr :: Rlp.Expr' RlpcPs SrcSpan -> Core.Expr' -desugarRlpExpr = runPureEff . runNameSupply "anon" . undefined +desugarRlpExpr = undefined runNameSupply :: Text -> Eff (NameSupply ': es) a -> Eff es a runNameSupply pre = undefined -- evalState [ pre <> "_" <> tshow name | name <- [0..] ] @@ -80,15 +77,31 @@ runNameSupply pre = undefined -- evalState [ pre <> "_" <> tshow name | name <- -- the rl' program is desugared by desugaring each declaration as a separate -- program, and taking the monoidal product of the lot :3 -rlpProgToCore :: Rlp.Program RlpcPs SrcSpan -> Program' +rlpProgToCore :: Rlp.Program PsName (RlpExpr PsName) -> Program' rlpProgToCore = foldMapOf (programDecls . each) declToCore -declToCore :: Rlp.Decl RlpcPs SrcSpan -> Program' -declToCore = undefined +declToCore :: Rlp.Decl PsName (RlpExpr PsName) -> Program' + +-- assume all arguments are VarP's for now +declToCore (FunD b as e) = mempty & programScDefs .~ [ScDef b as' e'] + where + as' = as ^.. each . singular _VarP + e' = runPureEff . runNameSupply b . exprToCore $ e type NameSupply = State [Name] exprToCore :: (NameSupply :> es) - => Rlp.ExprF RlpcPs a -> Eff es Core.Expr' -exprToCore = undefined + => RlpExpr PsName -> Eff es Core.Expr' +exprToCore = foldFixM \case + InL e -> pure $ Fix e + InR e -> rlpExprToCore e + +rlpExprToCore :: (NameSupply :> es) + => Rlp.ExprF PsName Core.Expr' -> Eff es Core.Expr' + +-- assume all binders are simple variable patterns for now +rlpExprToCore (LetEF r bs e) = pure $ Let r bs' e + where + bs' = b2b <$> bs + b2b (VarB (VarP k) v) = Binding k v