diff --git a/src/Rlp/Lex.x b/src/Rlp/Lex.x index 9229b8b..72f2cf0 100644 --- a/src/Rlp/Lex.x +++ b/src/Rlp/Lex.x @@ -10,6 +10,7 @@ module Rlp.Lex , lexStream , lexDebug , lexCont + , popLexState ) where import Codec.Binary.UTF8.String (encodeChar) @@ -73,6 +74,17 @@ $white_no_nl+ ; -- for the definition of `doBol` <0> \n { beginPush bol } + +{ + +} + +-- layout keywords +<0> +{ + "let" { constToken TokenLet `thenBeginPush` layout_let } +} + -- scan various identifiers and reserved words. order is important here! <0> { @@ -110,6 +122,14 @@ $white_no_nl+ ; () { doBol } } + +{ + \n { beginPush bol } + "{" { explicitLBrace } + "in" { constToken TokenIn `thenDo` (popLexState *> popLayout) } + () { doLayout } +} + { \n ; @@ -144,6 +164,12 @@ thenBegin act c inp l = do psLexState . _head .= c pure a +thenBeginPush :: LexerAction a -> Int -> LexerAction a +thenBeginPush act c inp l = do + a <- act inp l + pushLexState c + pure a + andBegin :: LexerAction a -> Int -> LexerAction a andBegin act c inp l = do psLexState . _head .= c @@ -342,6 +368,7 @@ explicitRBrace inp l = do doLayout :: LexerAction (Located RlpToken) doLayout _ _ = do i <- indentLevel + traceM $ "doLayout: i: " <> show i pushLayout (Implicit i) popLexState insertLBrace diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index 67e1b5d..ae467e8 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase, ViewPatterns #-} module Rlp.Parse ( parseRlpProg + , parseRlpExpr ) where import Compiler.RlpcError @@ -23,6 +24,7 @@ import Data.Void } %name parseRlpProg StandaloneProgram +%name parseRlpExpr StandaloneExpr %monad { P } %lexer { lexCont } { Located _ TokenEOF } @@ -51,8 +53,12 @@ import Data.Void infixl { Located _ TokenInfixL } infixr { Located _ TokenInfixR } infix { Located _ TokenInfix } + let { Located _ TokenLet } + in { Located _ TokenIn } +%nonassoc '=' %right '->' +%right in %% @@ -60,6 +66,9 @@ StandaloneProgram :: { RlpProgram RlpcPs } StandaloneProgram : '{' Decls '}' {% mkProgram $2 } | VL DeclsV VR {% mkProgram $2 } +StandaloneExpr :: { RlpExpr RlpcPs } + : VL Expr VR { extract $2 } + VL :: { () } VL : vlbrace { () } @@ -143,6 +152,20 @@ Expr :: { RlpExpr' RlpcPs } : Expr1 InfixOp Expr { $2 =>> \o -> OAppE (extract o) $1 $3 } | Expr1 { $1 } + | LetExpr { $1 } + +LetExpr :: { RlpExpr' RlpcPs } + : let layout1(Binding) in Expr { $1 \$> LetE $2 $4 } + +layout1(p) : '{' layout_list1(';',p) '}' { $2 } + | VL layout_list1(VS,p) VR { $2 } + +layout_list1(sep,p) : p sep { [$1] } + | p { [$1] } + | layout_list1(sep,p) sep p { $1 `snoc` $3 } + +Binding :: { Binding' RlpcPs } + : Pat1 '=' Expr { PatB <<~ $1 <~> $3 } Expr1 :: { RlpExpr' RlpcPs } : '(' Expr ')' { $1 .> $2 <. $3 } diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs index 25b20e8..b2eee70 100644 --- a/src/Rlp/Syntax.hs +++ b/src/Rlp/Syntax.hs @@ -14,6 +14,7 @@ module Rlp.Syntax , Lit(..), Lit' , RlpType(..), RlpType' , ConAlt(..) + , Binding(..), Binding' -- * Trees That Grow extensions , UnXRec(..), MapXRec(..), XRec, IdP @@ -28,7 +29,7 @@ import Data.Functor.Classes import Data.Kind (Type) import Lens.Micro import Lens.Micro.TH -import Core.Syntax hiding (Lit, Type, Binding) +import Core.Syntax hiding (Lit, Type, Binding, Binding') import Core (HasRHS(..), HasLHS(..)) ---------------------------------------------------------------------------------- @@ -42,6 +43,7 @@ type PhaseShow p = ( Show (XRec p Pat), Show (XRec p RlpExpr) , Show (XRec p Lit), Show (IdP p) , Show (XRec p RlpType) + , Show (XRec p Binding) ) newtype RlpProgram p = RlpProgram [Decl' p] @@ -77,7 +79,7 @@ data ConAlt p = ConAlt (IdP p) [RlpType' p] deriving instance (Show (IdP p), Show (XRec p RlpType)) => Show (ConAlt p) -data RlpExpr p = LetE [Binding p] (RlpExpr' p) +data RlpExpr p = LetE [Binding' p] (RlpExpr' p) | VarE (IdP p) | LamE [Pat p] (RlpExpr' p) | CaseE (RlpExpr' p) [(Alt p, Where p)] @@ -111,6 +113,8 @@ deriving instance (PhaseShow p) => Show (Alt p) data Binding p = PatB (Pat' p) (RlpExpr' p) | FunB (IdP p) [Pat' p] (RlpExpr' p) +type Binding' p = XRec p Binding + deriving instance (Show (XRec p Pat), Show (XRec p RlpExpr), Show (IdP p) ) => Show (Binding p)