From 0b72bc8f11463cf1ffebd44a9634091b23d1eb7e Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Fri, 24 Nov 2023 14:13:20 -0700 Subject: [PATCH] temporarily remove layout support the core language doesn't need it. let's just keep the core simple for now while i focus on more important things --- rlp.cabal | 1 + src/Core/Examples.hs | 35 +++-- src/Core/Lex.x | 197 +++------------------------ src/Core/Lex.x.old | 315 +++++++++++++++++++++++++++++++++++++++++++ src/Core/Parse.y | 16 +-- src/Core/Parse.y.old | 159 ++++++++++++++++++++++ 6 files changed, 521 insertions(+), 202 deletions(-) create mode 100644 src/Core/Lex.x.old create mode 100644 src/Core/Parse.y.old diff --git a/rlp.cabal b/rlp.cabal index 0637aca..58e71de 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -43,6 +43,7 @@ library -- required for happy , array , data-default-class + hs-source-dirs: src default-language: GHC2021 diff --git a/src/Core/Examples.hs b/src/Core/Examples.hs index 153db5c..0911567 100644 --- a/src/Core/Examples.hs +++ b/src/Core/Examples.hs @@ -10,15 +10,16 @@ import Core.TH letrecExample :: Program letrecExample = [coreProg| - pair x y f = f x y + pair x y f = f x y; - fst' p = p k - snd' p = p k1 + fst' p = p k; + snd' p = p k1; f x y = - letrec a = pair x b - b = pair y a - in fst' (snd' (snd' (snd' a))); + letrec + { a = pair x b + ; b = pair y a + } in fst' (snd' (snd' (snd' a))); main = f 3 4; |] @@ -37,9 +38,10 @@ indExample2 = [coreProg| |] indExample3 = [coreProg| - main = letrec x = 2 - y = f x x - in g y y; + main = letrec + { x = 2 + ; y = f x x + } in g y y; f a b = b; g a b = a; @@ -74,7 +76,7 @@ ifExample2 = [coreProg| |] facExample = [coreProg| - fac n = if# ((==#) n 0) 1 ((*#) n (fac ((-#) n 1))) + fac n = if# ((==#) n 0) 1 ((*#) n (fac ((-#) n 1))); main = fac 3; |] @@ -91,12 +93,19 @@ listExample1 = [coreProg| |] listExample2 = [coreProg| - cc f x xs = Cons (f x) (map f xs) - map f l = caseList# l Nil (cc f) - list = Cons 1 (Cons 2 (Cons 3 Nil)) + cc f x xs = Cons (f x) (map f xs); + map f l = caseList# l Nil (cc f); + list = Cons 1 (Cons 2 (Cons 3 Nil)); main = map negate# list; |] +listExample3 = [coreProg| + cc f z x xs = f x (foldr f z xs); + foldr f z l = caseList# l z (cc f z); + list = Cons 1 (Cons 2 (Cons 3 Nil)); + main = foldr (+#) 0 list; +|] + corePrelude :: Module corePrelude = Module (Just ("Prelude", [])) $ Program [ ScDef "id" ["x"] $ "x" diff --git a/src/Core/Lex.x b/src/Core/Lex.x index 0aebd64..08d5c0d 100644 --- a/src/Core/Lex.x +++ b/src/Core/Lex.x @@ -1,6 +1,4 @@ { --- TODO: layout semicolons are not inserted at EOf. -{-# LANGUAGE TemplateHaskell #-} module Core.Lex ( lexCore , lexCore' @@ -18,7 +16,7 @@ import Lens.Micro import Lens.Micro.TH } -%wrapper "monadUserState" +%wrapper "monad" $whitechar = [ \t\n\r\f\v] $special = [\(\)\,\;\[\]\{\}] @@ -57,81 +55,37 @@ $white_no_nl = $white # $nl rlp :- --- everywhere: skip whitespace -$white_no_nl+ { skip } - --- TODO: `--` could begin an operator -"--"[^$nl]* { skip } -"--"\-*[^$symbol].* { skip } - -"{-" { nestedComment } - --- syntactic symbols <0> { "(" { constTok TokenLParen } ")" { constTok TokenRParen } - "{" { lbrace } - "}" { rbrace } + "{" { constTok TokenLBrace } + "}" { constTok TokenRBrace } ";" { constTok TokenSemicolon } "," { constTok TokenComma } -} --- keywords --- see commentary on the layout system -<0> -{ - "let" { constTok TokenLet `andBegin` layout } - "letrec" { constTok TokenLetrec `andBegin` layout } - "of" { constTok TokenOf `andBegin` layout } + "let" { constTok TokenLet } + "letrec" { constTok TokenLetrec } + "of" { constTok TokenOf } "case" { constTok TokenCase } "module" { constTok TokenModule } - "in" { letin } - "where" { constTok TokenWhere `andBegin` layout } -} + "in" { constTok TokenIn } + "where" { constTok TokenWhere } --- reserved symbols -<0> -{ + "\\" { constTok TokenLambda } + "λ" { constTok TokenLambda } "=" { constTok TokenEquals } "->" { constTok TokenArrow } -} --- identifiers -<0> -{ - -- TODO: qualified names @varname { lexWith TokenVarName } @conname { lexWith TokenConName } @varsym { lexWith TokenVarSym } -} + @consym { lexWith TokenConSym } --- literals -<0> -{ @decimal { lexWith (TokenLitInt . read @Int) } -} -<0> \n { begin bol } - - -{ $white { skip } \n { skip } - () { topLevelOff `andBegin` 0 } -} - - -{ - \n { skip } - () { doBol `andBegin` 0 } -} - - -{ - $white { skip } - \{ { lbrace `andBegin` 0 } - () { noBrace `andBegin` 0 } } { @@ -161,57 +115,14 @@ data CoreToken = TokenLet | TokenRParen | TokenLBrace | TokenRBrace - | TokenLBraceV -- virtual brace inserted by layout - | TokenRBraceV -- virtual brace inserted by layout - | TokenIndent Int - | TokenDedent Int | TokenSemicolon | TokenEOF deriving Show -data LayoutContext = Layout Int - | NoLayout - deriving Show - -data AlexUserState = AlexUserState - { _ausContext :: [LayoutContext] - } - -ausContext :: Lens' AlexUserState [LayoutContext] -ausContext f (AlexUserState ctx) - = fmap - (\a -> AlexUserState a) (f ctx) -{-# INLINE ausContext #-} - -pushContext :: LayoutContext -> Alex () -pushContext c = do - st <- alexGetUserState - alexSetUserState $ st { _ausContext = c : _ausContext st } - -popContext :: Alex () -popContext = do - st <- alexGetUserState - alexSetUserState $ st { _ausContext = drop 1 (_ausContext st) } - -getContext :: Alex [LayoutContext] -getContext = do - st <- alexGetUserState - pure $ _ausContext st - type Lexer = AlexInput -> Int -> Alex (Located CoreToken) -alexInitUserState :: AlexUserState -alexInitUserState = AlexUserState [] - -nestedComment :: Lexer -nestedComment _ _ = undefined - -lexStream :: Alex [Located CoreToken] -lexStream = do - l <- alexMonadScan - case l of - Located _ _ _ TokenEOF -> pure [l] - _ -> (l:) <$> lexStream +lexWith :: (String -> CoreToken) -> Lexer +lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ take l s) -- | The main lexer driver. lexCore :: String -> RLPC ParseError [Located CoreToken] @@ -224,7 +135,7 @@ lexCore s = case m of } Right ts -> pure ts where - m = runAlex s (alexSetStartCode initial *> lexStream) + m = runAlex s lexStream -- | @lexCore@, but the tokens are stripped of location info. Useful for -- debugging @@ -232,84 +143,20 @@ lexCore' :: String -> RLPC ParseError [CoreToken] lexCore' s = fmap f <$> lexCore s where f (Located _ _ _ t) = t +lexStream :: Alex [Located CoreToken] +lexStream = do + l <- alexMonadScan + case l of + Located _ _ _ TokenEOF -> pure [l] + _ -> (l:) <$> lexStream + data ParseError = ParErrLexical String | ParErrParse deriving Show -lexWith :: (String -> CoreToken) -> Lexer -lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ take l s) - -lexToken :: Alex (Located CoreToken) -lexToken = alexMonadScan - -getSrcCol :: Alex Int -getSrcCol = Alex $ \ st -> - let AlexPn _ _ col = alex_pos st - in Right (st, col) - -lbrace :: Lexer -lbrace (AlexPn _ y x,_,_,_) l = do - pushContext NoLayout - pure $ Located y x l TokenLBrace - -rbrace :: Lexer -rbrace (AlexPn _ y x,_,_,_) l = do - popContext - pure $ Located y x l TokenRBrace - -insRBraceV :: AlexPosn -> Alex (Located CoreToken) -insRBraceV (AlexPn _ y x) = do - popContext - pure $ Located y x 0 TokenRBraceV - -insSemi :: AlexPosn -> Alex (Located CoreToken) -insSemi (AlexPn _ y x) = do - pure $ Located y x 0 TokenSemicolon - -modifyUst :: (AlexUserState -> AlexUserState) -> Alex () -modifyUst f = do - st <- alexGetUserState - alexSetUserState $ f st - -getUst :: Alex AlexUserState -getUst = alexGetUserState - -newLayoutContext :: Lexer -newLayoutContext (p,_,_,_) _ = do - undefined - -noBrace :: Lexer -noBrace (AlexPn _ y x,_,_,_) l = do - col <- getSrcCol - pushContext (Layout col) - pure $ Located y x l TokenLBraceV - -getOffside :: Alex Ordering -getOffside = do - ctx <- getContext - m <- getSrcCol - case ctx of - Layout n : _ -> pure $ m `compare` n - _ -> pure GT - -doBol :: Lexer -doBol (p,c,_,s) _ = do - off <- getOffside - case off of - LT -> insRBraceV p - EQ -> insSemi p - _ -> lexToken - -letin :: Lexer -letin (AlexPn _ y x,_,_,_) l = do - popContext - pure $ Located y x l TokenIn - -topLevelOff :: Lexer -topLevelOff = noBrace - alexEOF :: Alex (Located CoreToken) alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) -> Right (st, Located y x 0 TokenEOF) } + diff --git a/src/Core/Lex.x.old b/src/Core/Lex.x.old new file mode 100644 index 0000000..0aebd64 --- /dev/null +++ b/src/Core/Lex.x.old @@ -0,0 +1,315 @@ +{ +-- TODO: layout semicolons are not inserted at EOf. +{-# LANGUAGE TemplateHaskell #-} +module Core.Lex + ( lexCore + , lexCore' + , CoreToken(..) + , ParseError(..) + , Located(..) + , AlexPosn(..) + ) + where +import Data.Char (chr) +import Debug.Trace +import Core.Syntax +import Compiler.RLPC +import Lens.Micro +import Lens.Micro.TH +} + +%wrapper "monadUserState" + +$whitechar = [ \t\n\r\f\v] +$special = [\(\)\,\;\[\]\{\}] + +$digit = 0-9 + +$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~] +$unisymbol = [] -- TODO +$symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\'] + +$large = [A-Z \xc0-\xd6 \xd8-\xde] +$small = [a-z \xdf-\xf6 \xf8-\xff \_] +$alpha = [$small $large] + +$graphic = [$small $large $symbol $digit $special \:\"\'] + +$octit = 0-7 +$hexit = [0-9 A-F a-f] +$namechar = [$alpha $digit \' \#] +$symchar = [$symbol \:] +$nl = [\n\r] +$white_no_nl = $white # $nl + +@reservedid = + case|data|do|import|in|let|letrec|module|of|where + +@reservedop = + "=" | \\ | "->" + +@varname = $small $namechar* +@conname = $large $namechar* +@varsym = $symbol $symchar* +@consym = \: $symchar* + +@decimal = $digit+ + +rlp :- + +-- everywhere: skip whitespace +$white_no_nl+ { skip } + +-- TODO: `--` could begin an operator +"--"[^$nl]* { skip } +"--"\-*[^$symbol].* { skip } + +"{-" { nestedComment } + +-- syntactic symbols +<0> +{ + "(" { constTok TokenLParen } + ")" { constTok TokenRParen } + "{" { lbrace } + "}" { rbrace } + ";" { constTok TokenSemicolon } + "," { constTok TokenComma } +} + +-- keywords +-- see commentary on the layout system +<0> +{ + "let" { constTok TokenLet `andBegin` layout } + "letrec" { constTok TokenLetrec `andBegin` layout } + "of" { constTok TokenOf `andBegin` layout } + "case" { constTok TokenCase } + "module" { constTok TokenModule } + "in" { letin } + "where" { constTok TokenWhere `andBegin` layout } +} + +-- reserved symbols +<0> +{ + "=" { constTok TokenEquals } + "->" { constTok TokenArrow } +} + +-- identifiers +<0> +{ + -- TODO: qualified names + @varname { lexWith TokenVarName } + @conname { lexWith TokenConName } + @varsym { lexWith TokenVarSym } +} + +-- literals +<0> +{ + @decimal { lexWith (TokenLitInt . read @Int) } +} + +<0> \n { begin bol } + + +{ + $white { skip } + \n { skip } + () { topLevelOff `andBegin` 0 } +} + + +{ + \n { skip } + () { doBol `andBegin` 0 } +} + + +{ + $white { skip } + \{ { lbrace `andBegin` 0 } + () { noBrace `andBegin` 0 } +} + +{ +data Located a = Located Int Int Int a + deriving Show + +constTok :: t -> AlexInput -> Int -> Alex (Located t) +constTok t (AlexPn _ y x,_,_,_) l = pure $ Located y x l t + +data CoreToken = TokenLet + | TokenLetrec + | TokenIn + | TokenModule + | TokenWhere + | TokenComma + | TokenCase + | TokenOf + | TokenLambda + | TokenArrow + | TokenLitInt Int + | TokenVarName Name + | TokenConName Name + | TokenVarSym Name + | TokenConSym Name + | TokenEquals + | TokenLParen + | TokenRParen + | TokenLBrace + | TokenRBrace + | TokenLBraceV -- virtual brace inserted by layout + | TokenRBraceV -- virtual brace inserted by layout + | TokenIndent Int + | TokenDedent Int + | TokenSemicolon + | TokenEOF + deriving Show + +data LayoutContext = Layout Int + | NoLayout + deriving Show + +data AlexUserState = AlexUserState + { _ausContext :: [LayoutContext] + } + +ausContext :: Lens' AlexUserState [LayoutContext] +ausContext f (AlexUserState ctx) + = fmap + (\a -> AlexUserState a) (f ctx) +{-# INLINE ausContext #-} + +pushContext :: LayoutContext -> Alex () +pushContext c = do + st <- alexGetUserState + alexSetUserState $ st { _ausContext = c : _ausContext st } + +popContext :: Alex () +popContext = do + st <- alexGetUserState + alexSetUserState $ st { _ausContext = drop 1 (_ausContext st) } + +getContext :: Alex [LayoutContext] +getContext = do + st <- alexGetUserState + pure $ _ausContext st + +type Lexer = AlexInput -> Int -> Alex (Located CoreToken) + +alexInitUserState :: AlexUserState +alexInitUserState = AlexUserState [] + +nestedComment :: Lexer +nestedComment _ _ = undefined + +lexStream :: Alex [Located CoreToken] +lexStream = do + l <- alexMonadScan + case l of + Located _ _ _ TokenEOF -> pure [l] + _ -> (l:) <$> lexStream + +-- | The main lexer driver. +lexCore :: String -> RLPC ParseError [Located CoreToken] +lexCore s = case m of + Left e -> addFatal err + where err = SrcError + { _errSpan = (0,0,0) -- TODO: location + , _errSeverity = Error + , _errDiagnostic = ParErrLexical e + } + Right ts -> pure ts + where + m = runAlex s (alexSetStartCode initial *> lexStream) + +-- | @lexCore@, but the tokens are stripped of location info. Useful for +-- debugging +lexCore' :: String -> RLPC ParseError [CoreToken] +lexCore' s = fmap f <$> lexCore s + where f (Located _ _ _ t) = t + +data ParseError = ParErrLexical String + | ParErrParse + deriving Show + +lexWith :: (String -> CoreToken) -> Lexer +lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ take l s) + +lexToken :: Alex (Located CoreToken) +lexToken = alexMonadScan + +getSrcCol :: Alex Int +getSrcCol = Alex $ \ st -> + let AlexPn _ _ col = alex_pos st + in Right (st, col) + +lbrace :: Lexer +lbrace (AlexPn _ y x,_,_,_) l = do + pushContext NoLayout + pure $ Located y x l TokenLBrace + +rbrace :: Lexer +rbrace (AlexPn _ y x,_,_,_) l = do + popContext + pure $ Located y x l TokenRBrace + +insRBraceV :: AlexPosn -> Alex (Located CoreToken) +insRBraceV (AlexPn _ y x) = do + popContext + pure $ Located y x 0 TokenRBraceV + +insSemi :: AlexPosn -> Alex (Located CoreToken) +insSemi (AlexPn _ y x) = do + pure $ Located y x 0 TokenSemicolon + +modifyUst :: (AlexUserState -> AlexUserState) -> Alex () +modifyUst f = do + st <- alexGetUserState + alexSetUserState $ f st + +getUst :: Alex AlexUserState +getUst = alexGetUserState + +newLayoutContext :: Lexer +newLayoutContext (p,_,_,_) _ = do + undefined + +noBrace :: Lexer +noBrace (AlexPn _ y x,_,_,_) l = do + col <- getSrcCol + pushContext (Layout col) + pure $ Located y x l TokenLBraceV + +getOffside :: Alex Ordering +getOffside = do + ctx <- getContext + m <- getSrcCol + case ctx of + Layout n : _ -> pure $ m `compare` n + _ -> pure GT + +doBol :: Lexer +doBol (p,c,_,s) _ = do + off <- getOffside + case off of + LT -> insRBraceV p + EQ -> insSemi p + _ -> lexToken + +letin :: Lexer +letin (AlexPn _ y x,_,_,_) l = do + popContext + pure $ Located y x l TokenIn + +topLevelOff :: Lexer +topLevelOff = noBrace + +alexEOF :: Alex (Located CoreToken) +alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) -> + Right (st, Located y x 0 TokenEOF) + +} diff --git a/src/Core/Parse.y b/src/Core/Parse.y index bacd40e..e0e8527 100644 --- a/src/Core/Parse.y +++ b/src/Core/Parse.y @@ -45,8 +45,6 @@ import Data.Default.Class (def) ')' { Located _ _ _ TokenRParen } '{' { Located _ _ _ TokenLBrace } '}' { Located _ _ _ TokenRBrace } - vl { Located _ _ _ TokenLBraceV } - vr { Located _ _ _ TokenRBraceV } ';' { Located _ _ _ TokenSemicolon } eof { Located _ _ _ TokenEOF } @@ -64,15 +62,7 @@ StandaloneProgram :: { Program } StandaloneProgram : Program eof { $1 } Program :: { Program } -Program : VOpen ScDefs VClose { Program $2 } - | '{' ScDefs '}' { Program $2 } - -VOpen :: { () } -VOpen : vl { () } - -VClose :: { () } -VClose : vr { () } - | error { () } +Program : ScDefs { Program $1 } ScDefs :: { [ScDef] } ScDefs : ScDef ';' ScDefs { $1 : $3 } @@ -95,9 +85,7 @@ Expr : LetExpr { $1 } | Expr1 { $1 } LetExpr :: { Expr } -LetExpr : let VOpen Bindings VClose in Expr { Let NonRec $3 $6 } - | letrec VOpen Bindings VClose in Expr { Let Rec $3 $6 } - | let '{' Bindings '}' in Expr { Let NonRec $3 $6 } +LetExpr : let '{' Bindings '}' in Expr { Let NonRec $3 $6 } | letrec '{' Bindings '}' in Expr { Let Rec $3 $6 } Binders :: { [Name] } diff --git a/src/Core/Parse.y.old b/src/Core/Parse.y.old new file mode 100644 index 0000000..bacd40e --- /dev/null +++ b/src/Core/Parse.y.old @@ -0,0 +1,159 @@ +{ +module Core.Parse + ( parseCore + , parseCoreExpr + , parseCoreProg + , module Core.Lex -- temp convenience + , parseTmp + , SrcError + , ParseError + , Module + ) + where + +import Control.Monad ((>=>)) +import Data.Foldable (foldl') +import Core.Syntax +import Core.Lex +import Compiler.RLPC +import Data.Default.Class (def) +} + +%name parseCore Module +%name parseCoreExpr StandaloneExpr +%name parseCoreProg StandaloneProgram +%tokentype { Located CoreToken } +%error { parseError } +%monad { RLPC ParseError } + +%token + let { Located _ _ _ TokenLet } + letrec { Located _ _ _ TokenLetrec } + module { Located _ _ _ TokenModule } + where { Located _ _ _ TokenWhere } + ',' { Located _ _ _ TokenComma } + in { Located _ _ _ TokenIn } + litint { Located _ _ _ (TokenLitInt $$) } + varname { Located _ _ _ (TokenVarName $$) } + varsym { Located _ _ _ (TokenVarSym $$) } + conname { Located _ _ _ (TokenConName $$) } + consym { Located _ _ _ (TokenConSym $$) } + 'λ' { Located _ _ _ TokenLambda } + '->' { Located _ _ _ TokenArrow } + '=' { Located _ _ _ TokenEquals } + '(' { Located _ _ _ TokenLParen } + ')' { Located _ _ _ TokenRParen } + '{' { Located _ _ _ TokenLBrace } + '}' { Located _ _ _ TokenRBrace } + vl { Located _ _ _ TokenLBraceV } + vr { Located _ _ _ TokenRBraceV } + ';' { Located _ _ _ TokenSemicolon } + eof { Located _ _ _ TokenEOF } + +%% + +Module :: { Module } +Module : module conname where Program Eof { Module (Just ($2, [])) $4 } + | Program Eof { Module Nothing $1 } + +Eof :: { () } +Eof : eof { () } + | error { () } + +StandaloneProgram :: { Program } +StandaloneProgram : Program eof { $1 } + +Program :: { Program } +Program : VOpen ScDefs VClose { Program $2 } + | '{' ScDefs '}' { Program $2 } + +VOpen :: { () } +VOpen : vl { () } + +VClose :: { () } +VClose : vr { () } + | error { () } + +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 -} { [] } + +StandaloneExpr :: { Expr } +StandaloneExpr : Expr eof { $1 } + +Expr :: { Expr } +Expr : LetExpr { $1 } + | 'λ' Binders '->' Expr { Lam $2 $4 } + | Application { $1 } + | Expr1 { $1 } + +LetExpr :: { Expr } +LetExpr : let VOpen Bindings VClose in Expr { Let NonRec $3 $6 } + | letrec VOpen Bindings VClose in Expr { Let Rec $3 $6 } + | let '{' Bindings '}' in Expr { Let NonRec $3 $6 } + | letrec '{' Bindings '}' in Expr { Let Rec $3 $6 } + +Binders :: { [Name] } +Binders : Var Binders { $1 : $2 } + | Var { [$1] } + +Application :: { Expr } +Application : Expr1 AppArgs { foldl' App $1 $2 } + +-- TODO: Application can probably be written as a single rule, without AppArgs +AppArgs :: { [Expr] } +AppArgs : Expr1 AppArgs { $1 : $2 } + | Expr1 { [$1] } + +Expr1 :: { Expr } +Expr1 : litint { IntE $1 } + | Id { Var $1 } + | '(' Expr ')' { $2 } + +Bindings :: { [Binding] } +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 :: [Located CoreToken] -> RLPC ParseError a +parseError (Located y x l _ : _) = addFatal err + where err = SrcError + { _errSpan = (y,x,l) + , _errSeverity = Error + , _errDiagnostic = ParErrParse + } + +parseTmp :: IO Module +parseTmp = do + s <- readFile "/tmp/t.hs" + case parse s of + Left e -> error (show e) + Right (ts,_) -> pure ts + where + parse = evalRLPC def . (lexCore >=> parseCore) + +} +