diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index c48ff38..51eaf4c 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -143,7 +143,11 @@ Type1 :: { RlpType' RlpcPs } Type :: { RlpType' RlpcPs } : Type '->' Type { FunT <<~ $1 <~> $3 } - | Type1 { $1 } + | TypeApp { $1 } + +TypeApp :: { RlpType' RlpcPs } + : Type1 { $1 } + | TypeApp Type1 { AppT <<~ $1 <~> $2 } FunDecl :: { Decl' RlpcPs } FunDecl : Var Params '=' Expr { $4 =>> \e -> @@ -173,7 +177,11 @@ Expr :: { RlpExpr' RlpcPs } OAppE (extract o) $1 $3 } | LetExpr { $1 } | CaseExpr { $1 } - | Expr1 { $1 } + | ExprApp { $1 } + +ExprApp :: { RlpExpr' RlpcPs } + : Expr1 { $1 } + | ExprApp Expr1 { AppE <<~ $1 <~> $2 } LetExpr :: { RlpExpr' RlpcPs } : let layout1(Binding) in Expr { $1 \$> LetE $2 $4 } diff --git a/src/Rlp2Core.hs b/src/Rlp2Core.hs index 4e4d279..017c2d6 100644 --- a/src/Rlp2Core.hs +++ b/src/Rlp2Core.hs @@ -1,7 +1,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveTraversable #-} module Rlp2Core - ( rlpProgToCore + ( desugarRlpProg + , desugarRlpExpr ) where -------------------------------------------------------------------------------- @@ -23,6 +24,7 @@ import Data.Foldable import Data.Fix import Data.Maybe (fromJust, fromMaybe) import Data.Functor.Bind +import Data.Function (on) import Debug.Trace import Effectful.State.Static.Local import Effectful.Labeled @@ -51,6 +53,14 @@ type Rose = Fix Branch deriveShow1 ''Branch +-------------------------------------------------------------------------------- + +desugarRlpProg :: RlpProgram RlpcPs -> Program' +desugarRlpProg = rlpProgToCore + +desugarRlpExpr :: RlpExpr RlpcPs -> Expr' +desugarRlpExpr = runPureEff . runNameSupply "anon" . exprToCore + -- the rl' program is desugared by desugaring each declaration as a separate -- program, and taking the monoidal product of the lot :3 @@ -95,6 +105,8 @@ exprToCore :: (NameSupply :> es) => RlpExpr RlpcPs -> Eff es Expr' exprToCore (VarE n) = pure $ Var (dsNameToName n) +exprToCore (AppE a b) = (liftA2 App `on` exprToCore . unXRec) a b + exprToCore (CaseE (unXRec -> e) as) = do e' <- exprToCore e Case e' <$> caseAltToCore `traverse` as