234 lines
8.0 KiB
Plaintext
234 lines
8.0 KiB
Plaintext
{
|
|
{-|
|
|
Module : Core.Parse
|
|
Description : Parser for the Core language
|
|
-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module Core.Parse
|
|
( parseCore
|
|
, parseCoreExpr
|
|
, parseCoreProg
|
|
, parseCoreProgR
|
|
, module Core.Lex -- temp convenience
|
|
, SrcError
|
|
, Module
|
|
)
|
|
where
|
|
|
|
import Control.Monad ((>=>))
|
|
import Data.Foldable (foldl')
|
|
import Core.Syntax
|
|
import Core.Lex
|
|
import Compiler.RLPC
|
|
import Lens.Micro
|
|
import Data.Default.Class (def)
|
|
import Data.Hashable (Hashable)
|
|
import Data.Text.IO qualified as TIO
|
|
import Data.Text qualified as T
|
|
import Data.HashMap.Strict qualified as H
|
|
}
|
|
|
|
%name parseCore Module
|
|
%name parseCoreExpr StandaloneExpr
|
|
%name parseCoreProg StandaloneProgram
|
|
%tokentype { Located CoreToken }
|
|
%error { parseError }
|
|
%monad { RLPC } { happyBind } { happyPure }
|
|
|
|
%token
|
|
let { Located _ _ _ TokenLet }
|
|
letrec { Located _ _ _ TokenLetrec }
|
|
module { Located _ _ _ TokenModule }
|
|
where { Located _ _ _ TokenWhere }
|
|
case { Located _ _ _ TokenCase }
|
|
of { Located _ _ _ TokenOf }
|
|
pack { Located _ _ _ TokenPack } -- temp
|
|
in { Located _ _ _ TokenIn }
|
|
litint { Located _ _ _ (TokenLitInt $$) }
|
|
varname { Located _ _ _ (TokenVarName $$) }
|
|
varsym { Located _ _ _ (TokenVarSym $$) }
|
|
conname { Located _ _ _ (TokenConName $$) }
|
|
consym { Located _ _ _ (TokenConSym $$) }
|
|
word { Located _ _ _ (TokenWord $$) }
|
|
'λ' { Located _ _ _ TokenLambda }
|
|
'->' { Located _ _ _ TokenArrow }
|
|
'=' { Located _ _ _ TokenEquals }
|
|
'@' { Located _ _ _ TokenTypeApp }
|
|
'(' { Located _ _ _ TokenLParen }
|
|
')' { Located _ _ _ TokenRParen }
|
|
'{' { Located _ _ _ TokenLBrace }
|
|
'}' { Located _ _ _ TokenRBrace }
|
|
'{-#' { Located _ _ _ TokenLPragma }
|
|
'#-}' { Located _ _ _ TokenRPragma }
|
|
';' { Located _ _ _ TokenSemicolon }
|
|
'::' { Located _ _ _ TokenHasType }
|
|
eof { Located _ _ _ TokenEOF }
|
|
|
|
%%
|
|
|
|
Module :: { Module Name }
|
|
Module : module conname where Program Eof { Module (Just ($2, [])) $4 }
|
|
| Program Eof { Module Nothing $1 }
|
|
|
|
Eof :: { () }
|
|
Eof : eof { () }
|
|
| error { () }
|
|
|
|
StandaloneProgram :: { Program Name }
|
|
StandaloneProgram : Program eof { $1 }
|
|
|
|
Program :: { Program Name }
|
|
Program : ScTypeSig ';' Program { insTypeSig $1 $3 }
|
|
| ScTypeSig OptSemi { singletonTypeSig $1 }
|
|
| ScDef ';' Program { insScDef $1 $3 }
|
|
| ScDef OptSemi { singletonScDef $1 }
|
|
|
|
OptSemi :: { () }
|
|
OptSemi : ';' { () }
|
|
| {- epsilon -} { () }
|
|
|
|
ScTypeSig :: { (Name, Type) }
|
|
ScTypeSig : Var '::' Type { ($1,$3) }
|
|
|
|
ScDefs :: { [ScDef Name] }
|
|
ScDefs : ScDef ';' ScDefs { $1 : $3 }
|
|
| ScDef ';' { [$1] }
|
|
| ScDef { [$1] }
|
|
| {- epsilon -} { [] }
|
|
|
|
ScDef :: { ScDef Name }
|
|
ScDef : Var ParList '=' Expr { ScDef $1 $2 $4 }
|
|
-- hack to allow constructors to be compiled into scs
|
|
| Con ParList '=' Expr { ScDef $1 $2 $4 }
|
|
|
|
Type :: { Type }
|
|
Type : Type1 { $1 }
|
|
|
|
Type1 :: { Type }
|
|
Type1 : '(' Type ')' { $2 }
|
|
| Type1 '->' Type { $1 :-> $3 }
|
|
-- do we want to allow symbolic names for tyvars and tycons?
|
|
| varname { TyVar $1 }
|
|
| conname { TyCon $1 }
|
|
|
|
ParList :: { [Name] }
|
|
ParList : Var ParList { $1 : $2 }
|
|
| {- epsilon -} { [] }
|
|
|
|
StandaloneExpr :: { Expr Name }
|
|
StandaloneExpr : Expr eof { $1 }
|
|
|
|
Expr :: { Expr Name }
|
|
Expr : LetExpr { $1 }
|
|
| 'λ' Binders '->' Expr { Lam $2 $4 }
|
|
| Application { $1 }
|
|
| CaseExpr { $1 }
|
|
| Expr1 { $1 }
|
|
|
|
LetExpr :: { Expr Name }
|
|
LetExpr : 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 Name }
|
|
Application : Expr1 AppArgs { foldl' App $1 $2 }
|
|
|
|
AppArgs :: { [Expr Name] }
|
|
AppArgs : Expr1 AppArgs { $1 : $2 }
|
|
| Expr1 { [$1] }
|
|
|
|
CaseExpr :: { Expr Name }
|
|
CaseExpr : case Expr of '{' Alters '}' { Case $2 $5 }
|
|
|
|
Alters :: { [Alter Name] }
|
|
Alters : Alter ';' Alters { $1 : $3 }
|
|
| Alter ';' { [$1] }
|
|
| Alter { [$1] }
|
|
|
|
Alter :: { Alter Name }
|
|
Alter : litint ParList '->' Expr { Alter (AltData $1) $2 $4 }
|
|
|
|
Expr1 :: { Expr Name }
|
|
Expr1 : litint { Lit $ IntL $1 }
|
|
| Id { Var $1 }
|
|
| PackCon { $1 }
|
|
| ExprPragma { $1 }
|
|
| '(' Expr ')' { $2 }
|
|
|
|
ExprPragma :: { Expr Name }
|
|
ExprPragma : '{-#' Words '#-}' {% exprPragma $2 }
|
|
|
|
Words :: { [String] }
|
|
Words : word Words { T.unpack $1 : $2 }
|
|
| word { [T.unpack $1] }
|
|
|
|
PackCon :: { Expr Name }
|
|
PackCon : pack '{' litint litint '}' { Con $3 $4 }
|
|
|
|
Bindings :: { [Binding Name] }
|
|
Bindings : Binding ';' Bindings { $1 : $3 }
|
|
| Binding ';' { [$1] }
|
|
| Binding { [$1] }
|
|
|
|
Binding :: { Binding Name }
|
|
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 a
|
|
parseError (Located y x l t : _) =
|
|
error $ show y <> ":" <> show x
|
|
<> ": parse error at token `" <> show t <> "'"
|
|
|
|
{-# WARNING parseError "unimpl" #-}
|
|
|
|
exprPragma :: [String] -> RLPC (Expr Name)
|
|
exprPragma ("AST" : e) = undefined
|
|
exprPragma _ = undefined
|
|
|
|
{-# WARNING exprPragma "unimpl" #-}
|
|
|
|
astPragma :: [String] -> RLPC (Expr Name)
|
|
astPragma _ = undefined
|
|
|
|
{-# WARNING astPragma "unimpl" #-}
|
|
|
|
insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b
|
|
insTypeSig ts = programTypeSigs %~ uncurry H.insert ts
|
|
|
|
singletonTypeSig :: (Hashable b) => (b, Type) -> Program b
|
|
singletonTypeSig ts = insTypeSig ts mempty
|
|
|
|
insScDef :: (Hashable b) => ScDef b -> Program b -> Program b
|
|
insScDef sc = programScDefs %~ (sc:)
|
|
|
|
singletonScDef :: (Hashable b) => ScDef b -> Program b
|
|
singletonScDef sc = insScDef sc mempty
|
|
|
|
parseCoreProgR :: [Located CoreToken] -> RLPC Program'
|
|
parseCoreProgR = parseCoreProg
|
|
|
|
happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b
|
|
happyBind m k = m >>= k
|
|
|
|
happyPure :: a -> RLPC a
|
|
happyPure a = pure a
|
|
|
|
}
|
|
|