caseE

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

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
+

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