diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs new file mode 100644 index 0000000..08d991e --- /dev/null +++ b/src/Compiler/RLPC.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +module Compiler.RLPC + ( RLPC(..) + ) + where + +-- TODO: fancy errors +newtype RLPC a = RLPC { runRLPC :: Either String a } + deriving (Functor, Applicative, Monad) + diff --git a/src/Core/Lex.x b/src/Core/Lex.x index 090dd95..fa40921 100644 --- a/src/Core/Lex.x +++ b/src/Core/Lex.x @@ -4,6 +4,7 @@ module Core.Lex ( lexCore , lexCore' , CoreToken(..) + , lexTmp ) where import Data.Char (chr) @@ -81,7 +82,7 @@ $white_no_nl+ { skip } "of" { constTok TokenOf `andBegin` layout_keyword } "case" { constTok TokenCase } "module" { constTok TokenModule } - "in" { constTok TokenIn } + "in" { letin } "where" { constTok TokenWhere } } @@ -136,10 +137,8 @@ data CoreToken = TokenLet | TokenLitInt Int | TokenVarName Name | TokenConName Name - | TokenName Name -- temp | TokenVarSym Name | TokenConSym Name - | TokenSym Name -- temp | TokenEquals | TokenLParen | TokenRParen @@ -265,17 +264,21 @@ getOffside = do doBol :: Lexer doBol (p,c,_,s) l = do off <- getOffside - -- traceM $ show (p, c, s) col <- getSrcCol - traceM $ show (s, p, col, off) case off of LT -> insRBrace p EQ -> insSemi p _ -> lexToken -testTmp :: IO (Either String [CoreToken]) -testTmp = do - s <- readFile "/tmp/t.hs" - pure $ lexCore' s +letin :: Lexer +letin (p,_,_,_) l = do + popContext + pure $ Located p TokenIn +lexTmp :: IO [CoreToken] +lexTmp = do + s <- readFile "/tmp/t.hs" + case lexCore' s of + Left e -> error e + Right a -> pure a } diff --git a/src/Core/Parse.y b/src/Core/Parse.y index 4077528..342acf4 100644 --- a/src/Core/Parse.y +++ b/src/Core/Parse.y @@ -1,20 +1,24 @@ +-- TODO: resolve shift/reduce conflicts { module Core.Parse ( parseCore - -- , parseCoreExpr + , parseCoreExpr , module Core.Lex -- temp convenience + , parseTmp ) where import Data.Foldable (foldl') import Core.Syntax import Core.Lex +import Compiler.RLPC } -%name parseCore +%name parseCore Module %name parseCoreExpr Expr %tokentype { CoreToken } %error { parseError } +%monad { RLPC } %token let { TokenLet } @@ -24,8 +28,10 @@ import Core.Lex ',' { TokenComma } in { TokenIn } litint { TokenLitInt $$ } - name { TokenName $$ } - sym { TokenSym $$ } + varname { TokenVarName $$ } + varsym { TokenVarSym $$ } + conname { TokenConName $$ } + consym { TokenConSym $$ } 'λ' { TokenLambda } '->' { TokenArrow } '=' { TokenEquals } @@ -34,23 +40,43 @@ import Core.Lex '{' { TokenLBrace } '}' { TokenRBrace } ';' { TokenSemicolon } + eof { TokenEOF } %% -ExportList :: { [Name] } -ExportList : '(' Exports ')' { $2 } +Module :: { Module } +Module : module conname where Program Eof { Module (Just ($2, [])) $4 } + | Program Eof { Module Nothing $1 } -Exports :: { [Name] } -Exports : Var ',' Exports { $1 : $3 } - | Var { [$1] } +Eof :: { () } +Eof : eof { () } + | error { () } + +Program :: { Program } +Program : '{' ScDefs Close { Program $2 } + +ScDefs :: { [ScDef] } +ScDefs : ScDef ';' ScDefs { $1 : $3 } + | {- epsilon -} { [] } + +ScDef :: { ScDef } +ScDef : Var ParList '=' Expr { ScDef $1 $2 $4 } + +ParList :: { [Name] } +ParList : Var ParList { $1 : $2 } + | {- epsilon -} { [] } Expr :: { Expr } -Expr : let Bindings in Expr { Let NonRec $2 $4 } - | letrec Bindings in Expr { Let Rec $2 $4 } +Expr : let '{' Bindings Close in Expr { Let NonRec $3 $6 } + | letrec '{' Bindings Close in Expr { Let Rec $3 $6 } | 'λ' Binders '->' Expr { Lam $2 $4 } | Application { $1 } | Expr1 { $1 } +Close :: { () } +Close : '}' { () } + | error { () } + Binders :: { [Name] } Binders : Var Binders { $1 : $2 } | Var { [$1] } @@ -65,18 +91,38 @@ AppArgs : Expr1 AppArgs { $1 : $2 } Expr1 :: { Expr } Expr1 : litint { IntE $1 } - | Var { Var $1 } + | Id { Var $1 } | '(' Expr ')' { $2 } -Var :: { Name } -Var : '(' sym ')' { $2 } - | name { $1 } - Bindings :: { [Binding] } -Bindings : Var '=' Expr { [$1 := $3] } +Bindings : Binding ';' Bindings { $1 : $3 } + | Binding ';' { [$1] } + | Binding { [$1] } + +Binding :: { Binding } +Binding : Var '=' Expr { $1 := $3 } + +Id :: { Name } +Id : Var { $1 } + | Con { $1 } + +Var :: { Name } +Var : '(' varsym ')' { $2 } + | varname { $1 } + +Con :: { Name } +Con : '(' consym ')' { $2 } + | conname { $1 } { parseError :: [CoreToken] -> a -parseError _ = error "fuuckk!" +parseError ts = error $ "parse error at token: " <> show (head ts) + +parseTmp :: IO (Module) +parseTmp = do + s <- readFile "/tmp/t.hs" + case lexCore' s >>= runRLPC . parseCore of + Left e -> error e + Right a -> pure a }