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)
+

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])
+letin :: Lexer
-testTmp = do
+letin (p,_,_,_) l = do
-    s <- readFile "/tmp/t.hs"
+    popContext
-    pure $ lexCore' s
+    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
 }

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 $$ }
+      varname         { TokenVarName $$ }
-      sym             { TokenSym $$ }
+      varsym          { TokenVarSym $$ }
+      conname         { TokenConName $$ }
+      consym          { TokenConSym $$ }
       'λ'             { TokenLambda }
       '->'            { TokenArrow }
       '='             { TokenEquals }
@@ -34,23 +40,43 @@ import Core.Lex
       '{'             { TokenLBrace }
       '}'             { TokenRBrace }
       ';'             { TokenSemicolon }
+      eof             { TokenEOF }
 
 %%
 
-ExportList      :: { [Name] }
+Module          :: { Module }
-ExportList      : '(' Exports ')'               { $2 }
+Module          : module conname where Program Eof { Module (Just ($2, [])) $4 }
+                | Program Eof                      { Module Nothing $1 }
 
-Exports         :: { [Name] }
+Eof             :: { () }
-Exports         : Var ',' Exports               { $1 : $3 }
+Eof             : eof           { () }
-                | Var                           { [$1] }
+                | 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 }
+Expr            : let '{' Bindings Close in Expr  { Let NonRec $3 $6 }
-                | letrec Bindings in Expr       { Let Rec $2 $4 }
+                | 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
 }