270 lines
9.1 KiB
Plaintext
270 lines
9.1 KiB
Plaintext
{
|
|
{-|
|
|
Module : Core.Parse
|
|
Description : Parser for the Core language
|
|
-}
|
|
{-# LANGUAGE OverloadedStrings, ViewPatterns #-}
|
|
module Core.Parse
|
|
( parseCoreExpr
|
|
, parseCoreExprR
|
|
, parseCoreProg
|
|
, parseCoreProgR
|
|
, module Core.Lex -- temp convenience
|
|
, SrcError
|
|
)
|
|
where
|
|
|
|
import Control.Monad ((>=>))
|
|
import Control.Monad.Utils (generalise)
|
|
import Data.Foldable (foldl')
|
|
import Data.Functor.Identity
|
|
import Core.Syntax
|
|
import Core.Lex
|
|
import Compiler.RLPC
|
|
import Control.Monad
|
|
import Control.Lens hiding (snoc)
|
|
import Data.Default.Class (def)
|
|
import Data.Hashable (Hashable)
|
|
import Data.List.Extra
|
|
import Data.Text.IO qualified as TIO
|
|
import Data.Text (Text)
|
|
import Data.Text qualified as T
|
|
import Data.HashMap.Strict qualified as H
|
|
|
|
import Core.Parse.Types
|
|
}
|
|
|
|
%name parseCoreExpr StandaloneExpr
|
|
%name parseCoreProg StandaloneProgram
|
|
%tokentype { Located CoreToken }
|
|
%error { parseError }
|
|
%monad { P }
|
|
|
|
%token
|
|
let { Located _ TokenLet }
|
|
letrec { Located _ TokenLetrec }
|
|
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 $$) }
|
|
alttag { Located _ (TokenAltTag $$) }
|
|
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 }
|
|
|
|
%right '->'
|
|
|
|
%%
|
|
|
|
Eof :: { () }
|
|
Eof : eof { () }
|
|
| error { () }
|
|
|
|
StandaloneProgram :: { Program Var }
|
|
StandaloneProgram : Program eof { $1 }
|
|
|
|
Program :: { Program Var }
|
|
: TypedScDef ';' Program { $3 & insTypeSig (fst $1)
|
|
& insScDef (snd $1) }
|
|
| TypedScDef OptSemi { mempty & insTypeSig (fst $1)
|
|
& insScDef (snd $1) }
|
|
| TLPragma Program {% doTLPragma $1 $2 }
|
|
| TLPragma {% doTLPragma $1 mempty }
|
|
|
|
TLPragma :: { Pragma }
|
|
: '{-#' Words '#-}' { Pragma $2 }
|
|
|
|
Words :: { [Text] }
|
|
: Words word { $1 `snoc` $2 }
|
|
| word { [$1] }
|
|
|
|
OptSemi :: { () }
|
|
OptSemi : ';' { () }
|
|
| {- epsilon -} { () }
|
|
|
|
ScTypeSig :: { (Name, Type) }
|
|
ScTypeSig : Id ':' Type { ($1, $3) }
|
|
|
|
TypedScDef :: { (Var, ScDef Var) }
|
|
: Id ':' Type ';' Id ParList '=' Expr
|
|
{ (MkVar $1 $3, mkTypedScDef $1 $3 $5 $6 $8) }
|
|
|
|
-- ScDefs :: { [ScDef PsName] }
|
|
-- ScDefs : ScDef ';' ScDefs { $1 : $3 }
|
|
-- | ScDef ';' { [$1] }
|
|
-- | ScDef { [$1] }
|
|
--
|
|
-- ScDef :: { ScDef PsName }
|
|
-- ScDef : Id ParList '=' Expr { ScDef (Left $1) $2
|
|
-- ($4 & binders %~ Right) }
|
|
|
|
Type :: { Type }
|
|
: TypeApp '->' TypeApp { $1 :-> $3 }
|
|
| TypeApp { $1 }
|
|
|
|
TypeApp :: { Type }
|
|
: TypeApp Type1 { TyApp $1 $2 }
|
|
| Type1 { $1 }
|
|
|
|
-- do we want to allow symbolic names for tyvars and tycons?
|
|
|
|
Type1 :: { Type }
|
|
Type1 : '(' Type ')' { $2 }
|
|
| varname { TyVar $1 }
|
|
| conname { if $1 == "Type"
|
|
then TyKindType else TyCon $1 }
|
|
|
|
ParList :: { [Name] }
|
|
ParList : varname ParList { $1 : $2 }
|
|
| {- epsilon -} { [] }
|
|
|
|
StandaloneExpr :: { Expr Var }
|
|
StandaloneExpr : Expr eof { $1 }
|
|
|
|
Expr :: { Expr Var }
|
|
Expr : LetExpr { $1 }
|
|
| 'λ' Binders '->' Expr { Lam $2 $4 }
|
|
| Application { $1 }
|
|
| CaseExpr { $1 }
|
|
| Expr1 { $1 }
|
|
|
|
LetExpr :: { Expr Var }
|
|
LetExpr : let '{' Bindings '}' in Expr { Let NonRec $3 $6 }
|
|
| letrec '{' Bindings '}' in Expr { Let Rec $3 $6 }
|
|
|
|
Binders :: { [Var] }
|
|
Binders : Var Binders { $1 : $2 }
|
|
| Var { [$1] }
|
|
|
|
Application :: { Expr Var }
|
|
Application : Application AppArg { App $1 $2 }
|
|
| Expr1 AppArg { App $1 $2 }
|
|
|
|
AppArg :: { Expr Var }
|
|
: '@' Type1 { Type $2 }
|
|
| Expr1 { $1 }
|
|
|
|
CaseExpr :: { Expr Var }
|
|
CaseExpr : case Expr of '{' Alters '}' { Case $2 $5 }
|
|
|
|
Alters :: { [Alter Var] }
|
|
Alters : Alter ';' Alters { $1 : $3 }
|
|
| Alter ';' { [$1] }
|
|
| Alter { [$1] }
|
|
|
|
Alter :: { Alter Var }
|
|
Alter : alttag AltParList '->' Expr { Alter (AltTag $1) $2 $4 }
|
|
| conname AltParList '->' Expr { Alter (AltData $1) $2 $4 }
|
|
|
|
AltParList :: { [Var] }
|
|
: Var AltParList { $1 : $2 }
|
|
| {- epsilon -} { [] }
|
|
|
|
Expr1 :: { Expr Var }
|
|
Expr1 : litint { Lit $ IntL $1 }
|
|
| Id { Var $1 }
|
|
| PackCon { $1 }
|
|
| '(' Expr ')' { $2 }
|
|
|
|
PackCon :: { Expr Var }
|
|
PackCon : pack '{' litint litint '}' { Con $3 $4 }
|
|
|
|
Bindings :: { [Binding Var] }
|
|
Bindings : Binding ';' Bindings { $1 : $3 }
|
|
| Binding ';' { [$1] }
|
|
| Binding { [$1] }
|
|
|
|
Binding :: { Binding Var }
|
|
Binding : Var '=' Expr { $1 := $3 }
|
|
|
|
Id :: { Name }
|
|
: varname { $1 }
|
|
| conname { $1 }
|
|
|
|
Var :: { Var }
|
|
Var : '(' varname ':' Type ')' { MkVar $2 $4 }
|
|
|
|
{
|
|
|
|
parseError :: [Located CoreToken] -> P a
|
|
parseError (Located _ t : _) =
|
|
error $ "<line>" <> ":" <> "<col>"
|
|
<> ": parse error at token `" <> show t <> "'"
|
|
|
|
exprPragma :: [String] -> RLPC (Expr Var)
|
|
exprPragma ("AST" : e) = undefined
|
|
exprPragma _ = undefined
|
|
|
|
astPragma :: [String] -> RLPC (Expr Var)
|
|
astPragma _ = undefined
|
|
|
|
-- insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b
|
|
-- insTypeSig ts = programTypeSigs %~ uncurry H.insert ts
|
|
|
|
insTypeSig :: Var -> Program Var -> Program Var
|
|
insTypeSig w@(MkVar _ t) = programTypeSigs %~ H.insert w t
|
|
|
|
-- 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
|
|
|
|
parseCoreExprR :: (Monad m) => [Located CoreToken] -> RLPCT m (Expr Var)
|
|
parseCoreExprR = liftMaybe . snd . flip runP def . parseCoreExpr
|
|
|
|
parseCoreProgR :: forall m. (Monad m)
|
|
=> [Located CoreToken] -> RLPCT m (Program Var)
|
|
parseCoreProgR s = do
|
|
let p = runP (parseCoreProg s) def
|
|
case p of
|
|
(st, Just a) -> do
|
|
ddumpast a
|
|
pure a
|
|
where
|
|
ddumpast :: Show a => Program a -> RLPCT m (Program a)
|
|
ddumpast p = do
|
|
addDebugMsg "dump-parsed-core" . show $ p
|
|
pure p
|
|
|
|
happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b
|
|
happyBind m k = m >>= k
|
|
|
|
happyPure :: a -> RLPC a
|
|
happyPure a = pure a
|
|
|
|
doTLPragma :: Pragma -> Program Var -> P (Program Var)
|
|
-- TODO: warn unrecognised pragma
|
|
doTLPragma (Pragma []) p = pure p
|
|
|
|
doTLPragma (Pragma pr) p = case pr of
|
|
-- TODO: warn on overwrite
|
|
["PackData", n, readt -> t, readt -> a] ->
|
|
pure $ p & programDataTags . at n ?~ (t,a)
|
|
|
|
readt :: (Read a) => Text -> a
|
|
readt = read . T.unpack
|
|
|
|
}
|
|
|