335 lines
11 KiB
Plaintext
335 lines
11 KiB
Plaintext
{
|
||
{-# LANGUAGE LambdaCase, ViewPatterns #-}
|
||
module Rlp.Parse
|
||
( parseRlpProg
|
||
, parseRlpProgR
|
||
, parseRlpExpr
|
||
, parseRlpExprR
|
||
, runP'
|
||
)
|
||
where
|
||
import Compiler.RlpcError
|
||
import Compiler.RLPC
|
||
import Control.Comonad.Cofree
|
||
import Rlp.Lex
|
||
import Rlp.Syntax
|
||
import Rlp.Parse.Types
|
||
import Rlp.Parse.Associate
|
||
import Control.Lens hiding (snoc, (.>), (<.), (<<~), (:<))
|
||
import Data.List.Extra
|
||
import Data.Fix
|
||
import Data.Functor.Const
|
||
import Data.Functor.Apply
|
||
import Data.Functor.Bind
|
||
import Control.Comonad
|
||
import Data.Functor
|
||
import Data.Semigroup.Traversable
|
||
import Data.Text (Text)
|
||
import Data.Text qualified as T
|
||
import Data.Void
|
||
import Compiler.Types
|
||
}
|
||
|
||
%name parseRlpProg StandaloneProgram
|
||
%name parseRlpExpr StandaloneExpr
|
||
|
||
%monad { P }
|
||
%lexer { lexCont } { Located _ TokenEOF }
|
||
%error { parseError }
|
||
%errorhandlertype explist
|
||
%tokentype { Located RlpToken }
|
||
|
||
%token
|
||
varname { Located _ (TokenVarName _) }
|
||
conname { Located _ (TokenConName _) }
|
||
consym { Located _ (TokenConSym _) }
|
||
varsym { Located _ (TokenVarSym _) }
|
||
data { Located _ TokenData }
|
||
case { Located _ TokenCase }
|
||
of { Located _ TokenOf }
|
||
litint { Located _ (TokenLitInt _) }
|
||
'=' { Located _ TokenEquals }
|
||
'|' { Located _ TokenPipe }
|
||
'::' { Located _ TokenHasType }
|
||
';' { Located _ TokenSemicolon }
|
||
'(' { Located _ TokenLParen }
|
||
')' { Located _ TokenRParen }
|
||
'->' { Located _ TokenArrow }
|
||
vsemi { Located _ TokenSemicolonV }
|
||
'{' { Located _ TokenLBrace }
|
||
'}' { Located _ TokenRBrace }
|
||
vlbrace { Located _ TokenLBraceV }
|
||
vrbrace { Located _ TokenRBraceV }
|
||
infixl { Located _ TokenInfixL }
|
||
infixr { Located _ TokenInfixR }
|
||
infix { Located _ TokenInfix }
|
||
let { Located _ TokenLet }
|
||
letrec { Located _ TokenLetrec }
|
||
in { Located _ TokenIn }
|
||
|
||
%nonassoc '='
|
||
%right '->'
|
||
%right in
|
||
|
||
%%
|
||
|
||
StandaloneProgram :: { Program RlpcPs SrcSpan }
|
||
StandaloneProgram : layout0(Decl) {% mkProgram $1 }
|
||
|
||
StandaloneExpr :: { Expr' RlpcPs SrcSpan }
|
||
: VL Expr VR { $2 }
|
||
|
||
VL :: { () }
|
||
VL : vlbrace { () }
|
||
|
||
VR :: { () }
|
||
VR : vrbrace { () }
|
||
| error {% void popLayout }
|
||
|
||
VS :: { () }
|
||
VS : ';' { () }
|
||
| vsemi { () }
|
||
|
||
Decl :: { Decl RlpcPs SrcSpan }
|
||
: FunDecl { $1 }
|
||
| TySigDecl { $1 }
|
||
| DataDecl { $1 }
|
||
| InfixDecl { $1 }
|
||
|
||
TySigDecl :: { Decl RlpcPs SrcSpan }
|
||
: Var '::' Type { TySigD [$1] $3 }
|
||
|
||
InfixDecl :: { Decl RlpcPs SrcSpan }
|
||
: InfixWord litint InfixOp {% mkInfixD $1 ($2 ^. _litint) $3 }
|
||
|
||
InfixWord :: { Assoc }
|
||
: infixl { InfixL }
|
||
| infixr { InfixR }
|
||
| infix { Infix }
|
||
|
||
DataDecl :: { Decl RlpcPs SrcSpan }
|
||
: data Con TyParams '=' DataCons { DataD $2 $3 $5 }
|
||
|
||
TyParams :: { [PsName] }
|
||
: {- epsilon -} { [] }
|
||
| TyParams varname { $1 `snoc` extractName $2 }
|
||
|
||
DataCons :: { [ConAlt RlpcPs] }
|
||
: DataCons '|' DataCon { $1 `snoc` $3 }
|
||
| DataCon { [$1] }
|
||
|
||
DataCon :: { ConAlt RlpcPs }
|
||
: Con Type1s { ConAlt $1 $2 }
|
||
|
||
Type1s :: { [Ty RlpcPs] }
|
||
: {- epsilon -} { [] }
|
||
| Type1s Type1 { $1 `snoc` $2 }
|
||
|
||
Type1 :: { Ty RlpcPs }
|
||
: '(' Type ')' { $2 }
|
||
| conname { ConT (extractName $1) }
|
||
| varname { VarT (extractName $1) }
|
||
|
||
Type :: { Ty RlpcPs }
|
||
: Type '->' Type { FunT $1 $3 }
|
||
| TypeApp { $1 }
|
||
|
||
TypeApp :: { Ty RlpcPs }
|
||
: Type1 { $1 }
|
||
| TypeApp Type1 { AppT $1 $2 }
|
||
|
||
FunDecl :: { Decl RlpcPs SrcSpan }
|
||
FunDecl : Var Params '=' Expr { FunD $1 $2 $4 Nothing }
|
||
|
||
Params :: { [Pat RlpcPs] }
|
||
Params : {- epsilon -} { [] }
|
||
| Params Pat1 { $1 `snoc` $2 }
|
||
|
||
Pat :: { Pat RlpcPs }
|
||
: Con Pat1s { ConP $1 $2 }
|
||
| Pat1 { $1 }
|
||
|
||
Pat1s :: { [Pat RlpcPs] }
|
||
: Pat1s Pat1 { $1 `snoc` $2 }
|
||
| Pat1 { [$1] }
|
||
|
||
Pat1 :: { Pat RlpcPs }
|
||
: Con { ConP $1 [] }
|
||
| Var { VarP $1 }
|
||
| Lit { LitP $1 }
|
||
| '(' Pat ')' { $2 }
|
||
|
||
Expr :: { Expr' RlpcPs SrcSpan }
|
||
-- infixities delayed till next release :(
|
||
-- : Expr1 InfixOp Expr { undefined }
|
||
: AppExpr { $1 }
|
||
| TempInfixExpr { $1 }
|
||
| LetExpr { $1 }
|
||
| CaseExpr { $1 }
|
||
|
||
TempInfixExpr :: { Expr' RlpcPs SrcSpan }
|
||
TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 }
|
||
| Expr1 InfixOp Expr1 { nolo' $ InfixEF $2 $1 $3 }
|
||
|
||
AppExpr :: { Expr' RlpcPs SrcSpan }
|
||
: Expr1 { $1 }
|
||
| AppExpr Expr1 { comb2 AppEF $1 $2 }
|
||
|
||
LetExpr :: { Expr' RlpcPs SrcSpan }
|
||
: let layout1(Binding) in Expr { nolo' $ LetEF NonRec $2 $4 }
|
||
| letrec layout1(Binding) in Expr { nolo' $ LetEF Rec $2 $4 }
|
||
|
||
CaseExpr :: { Expr' RlpcPs SrcSpan }
|
||
: case Expr of layout0(Alt) { nolo' $ CaseEF $2 $4 }
|
||
|
||
-- TODO: where-binds
|
||
Alt :: { Alt' RlpcPs SrcSpan }
|
||
: Pat '->' Expr { AltA $1 (view _unwrap $3) Nothing }
|
||
|
||
-- layout0(p : β) :: [β]
|
||
layout0(p) : '{' layout_list0(';',p) '}' { $2 }
|
||
| VL layout_list0(VS,p) VR { $2 }
|
||
|
||
-- layout_list0(sep : α, p : β) :: [β]
|
||
layout_list0(sep,p) : p { [$1] }
|
||
| layout_list1(sep,p) sep p { $1 `snoc` $3 }
|
||
| {- epsilon -} { [] }
|
||
|
||
-- layout1(p : β) :: [β]
|
||
layout1(p) : '{' layout_list1(';',p) '}' { $2 }
|
||
| VL layout_list1(VS,p) VR { $2 }
|
||
|
||
-- layout_list1(sep : α, p : β) :: [β]
|
||
layout_list1(sep,p) : p { [$1] }
|
||
| layout_list1(sep,p) sep p { $1 `snoc` $3 }
|
||
|
||
Binding :: { Binding' RlpcPs SrcSpan }
|
||
: Pat '=' Expr { PatB $1 (view _unwrap $3) }
|
||
|
||
Expr1 :: { Expr' RlpcPs SrcSpan }
|
||
: '(' Expr ')' { $2 }
|
||
| Lit { nolo' $ LitEF $1 }
|
||
| Var { case $1 of Located ss _ -> ss :< VarEF $1 }
|
||
| Con { case $1 of Located ss _ -> ss :< VarEF $1 }
|
||
|
||
InfixOp :: { PsName }
|
||
: consym { extractName $1 }
|
||
| varsym { extractName $1 }
|
||
|
||
-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
|
||
Lit :: { Lit RlpcPs }
|
||
: litint { $1 ^. to extract
|
||
. singular _TokenLitInt
|
||
. to IntL }
|
||
|
||
Var :: { PsName }
|
||
Var : varname { $1 <&> view (singular _TokenVarName) }
|
||
| varsym { $1 <&> view (singular _TokenVarSym) }
|
||
|
||
Con :: { PsName }
|
||
: conname { $1 <&> view (singular _TokenConName) }
|
||
|
||
{
|
||
|
||
parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program RlpcPs SrcSpan)
|
||
parseRlpProgR s = do
|
||
a <- liftErrorful $ pToErrorful parseRlpProg st
|
||
addDebugMsg @_ @String "dump-parsed" $ show a
|
||
pure a
|
||
where
|
||
st = programInitState s
|
||
|
||
parseRlpExprR :: (Monad m) => Text -> RLPCT m (Expr' RlpcPs SrcSpan)
|
||
parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
|
||
where
|
||
st = programInitState s
|
||
|
||
mkInfixD :: Assoc -> Int -> PsName -> P (Decl RlpcPs SrcSpan)
|
||
mkInfixD a p ln@(Located ss n) = do
|
||
let opl :: Lens' ParseState (Maybe OpInfo)
|
||
opl = psOpTable . at n
|
||
opl <~ (use opl >>= \case
|
||
Just o -> addWoundHere l e >> pure (Just o) where
|
||
e = RlpParErrDuplicateInfixD n
|
||
l = T.length n
|
||
Nothing -> pure (Just (a,p))
|
||
)
|
||
pos <- use (psInput . aiPos)
|
||
pure $ InfixD a p ln
|
||
|
||
{--
|
||
|
||
parseRlpExprR :: (Monad m) => Text -> RLPCT m (Expr RlpcPs)
|
||
parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
|
||
where
|
||
st = programInitState s
|
||
|
||
parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program RlpcPs)
|
||
parseRlpProgR s = do
|
||
a <- liftErrorful $ pToErrorful parseRlpProg st
|
||
addDebugMsg @_ @String "dump-parsed" $ show a
|
||
pure a
|
||
where
|
||
st = programInitState s
|
||
|
||
mkPsName :: Located RlpToken -> Located PsName
|
||
mkPsName = fmap extractName
|
||
|
||
extractName :: RlpToken -> PsName
|
||
extractName = \case
|
||
TokenVarName n -> n
|
||
TokenConName n -> n
|
||
TokenConSym n -> n
|
||
TokenVarSym n -> n
|
||
_ -> error "mkPsName: not an identifier"
|
||
|
||
extractInt :: RlpToken -> Int
|
||
extractInt (TokenLitInt n) = n
|
||
extractInt _ = error "extractInt: ugh"
|
||
|
||
mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan)
|
||
mkProgram ds = do
|
||
pt <- use psOpTable
|
||
pure $ Program (associate pt <$> ds)
|
||
|
||
intOfToken :: Located RlpToken -> Int
|
||
intOfToken (Located _ (TokenLitInt n)) = n
|
||
|
||
tempInfixExprErr :: Expr RlpcPs -> Expr RlpcPs -> P a
|
||
tempInfixExprErr (Located a _) (Located b _) =
|
||
addFatal $ errorMsg (a <> b) $ RlpParErrOther
|
||
[ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
|
||
, "In the mean time, don't mix any infix operators."
|
||
]
|
||
|
||
--}
|
||
|
||
_litint :: Getter (Located RlpToken) Int
|
||
_litint = to extract
|
||
. singular _TokenLitInt
|
||
|
||
tempInfixExprErr :: Expr' RlpcPs SrcSpan -> Expr' RlpcPs SrcSpan -> P a
|
||
tempInfixExprErr (a :< _) (b :< _) =
|
||
addFatal $ errorMsg (a <> b) $ RlpParErrOther
|
||
[ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
|
||
, "In the mean time, don't mix any infix operators."
|
||
]
|
||
|
||
mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan)
|
||
mkProgram ds = do
|
||
pt <- use psOpTable
|
||
pure $ Program (associate pt <$> ds)
|
||
|
||
extractName :: Located RlpToken -> PsName
|
||
extractName (Located ss (TokenVarSym n)) = Located ss n
|
||
extractName (Located ss (TokenVarName n)) = Located ss n
|
||
extractName (Located ss (TokenConName n)) = Located ss n
|
||
extractName (Located ss (TokenConSym n)) = Located ss n
|
||
|
||
parseError :: (Located RlpToken, [String]) -> P a
|
||
parseError ((Located ss t), exp) = addFatal $
|
||
errorMsg ss (RlpParErrUnexpectedToken t exp)
|
||
|
||
}
|
||
|