|
{
|
|
{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
|
|
module Presyntax.Parser where
|
|
|
|
import qualified Data.Text as T
|
|
import Data.Text (Text)
|
|
|
|
import Presyntax.Presyntax
|
|
import Presyntax.Tokens
|
|
import Presyntax.Lexer
|
|
|
|
import Prelude hiding (span)
|
|
|
|
}
|
|
|
|
%name parseExp Exp
|
|
%name parseStmt Statement
|
|
%name parseProg Program
|
|
%name parseRepl ReplStatement
|
|
|
|
%tokentype { Token }
|
|
|
|
%monad { Alex }
|
|
%lexer { lexer } { Token TokEof _ _ }
|
|
|
|
%errorhandlertype explist
|
|
%error { parseError }
|
|
|
|
%token
|
|
var { Token (TokVar _) _ _ }
|
|
'eof' { Token TokEof _ _ }
|
|
|
|
'(' { Token TokOParen _ _ }
|
|
')' { Token TokCParen _ _ }
|
|
|
|
'{' { Token TokOBrace _ _ }
|
|
'}' { Token TokCBrace _ _ }
|
|
|
|
'[' { Token TokOSquare _ _ }
|
|
']' { Token TokCSquare _ _ }
|
|
|
|
'{-#' { Token TokOPragma _ _ }
|
|
'#-}' { Token TokCPragma _ _ }
|
|
|
|
'\\' { Token TokLambda _ _ }
|
|
|
|
'->' { Token TokArrow _ _ }
|
|
':' { Token TokColon _ _ }
|
|
';' { Token TokSemi _ _ }
|
|
'=' { Token TokEqual _ _ }
|
|
',' { Token TokComma _ _ }
|
|
'*' { Token TokStar _ _ }
|
|
'as' { Token TokAs _ _ }
|
|
|
|
'&&' { Token TokAnd _ _ }
|
|
'||' { Token TokOr _ _ }
|
|
|
|
'.1' { Token TokPi1 _ _ }
|
|
'.2' { Token TokPi2 _ _ }
|
|
|
|
'PRIMITIVE' { Token TokPrim _ _ }
|
|
|
|
':let' { Token TokReplLet _ _ }
|
|
':t' { Token (TokReplT _) _ _ }
|
|
|
|
%%
|
|
|
|
Exp :: { Expr }
|
|
Exp
|
|
: '\\' LambdaList '->' Exp { span $1 $4 $ makeLams $2 $4 }
|
|
| '\\' MaybeLambdaList '[' System ']' { span $1 $5 $ makeLams $2 $ LamSystem $4 }
|
|
| '(' var ':' Exp ')' ProdTail { span $1 $6 $ Pi Ex (getVar $2) $4 $6 }
|
|
| '{' var ':' Exp '}' ProdTail { span $1 $6 $ Pi Im (getVar $2) $4 $6 }
|
|
| ExpApp '->' Exp { span $1 $3 $ Pi Ex (T.singleton '_') $1 $3 }
|
|
|
|
| '(' var ':' Exp ')' '*' Exp { span $1 $7 $ Sigma (getVar $2) $4 $7 }
|
|
| ExpApp '*' Exp { span $1 $3 $ Sigma (T.singleton '_') $1 $3 }
|
|
|
|
| ExpApp { $1 }
|
|
|
|
ExpApp :: { Expr }
|
|
: ExpApp ExpProj { span $1 $2 $ App Ex $1 $2 }
|
|
| ExpApp '{' Exp '}' { span $1 $4 $ App Im $1 $3 }
|
|
| ExpProj { $1 }
|
|
|
|
ExpProj :: { Expr }
|
|
: ExpProj '.1' { span $1 $2 $ Proj1 $1 }
|
|
| ExpProj '.2' { span $1 $2 $ Proj2 $1 }
|
|
| Atom { $1 }
|
|
|
|
Tuple :: { Expr }
|
|
: Exp { $1 }
|
|
| Exp ',' Tuple { span $1 $3 $ Pair $1 $3 }
|
|
|
|
Atom :: { Expr }
|
|
: var { span $1 $1 $ Var (getVar $1) }
|
|
| '(' Tuple ')' { span $1 $3 $ $2 }
|
|
|
|
ProdTail :: { Expr }
|
|
: '(' VarList ':' Exp ')' ProdTail { span $1 $6 $ makePis Ex (thd $2) $4 $6 }
|
|
| '{' VarList ':' Exp '}' ProdTail { span $1 $6 $ makePis Im (thd $2) $4 $6 }
|
|
| '->' Exp { span $2 $2 $ $2 }
|
|
|
|
MaybeLambdaList :: { [(Plicity, Text)] }
|
|
: {- empty -} { [] }
|
|
| LambdaList { $1 }
|
|
|
|
LambdaList :: { [(Plicity, Text)] }
|
|
: var { [(Ex, getVar $1)] }
|
|
| var LambdaList { (Ex, getVar $1):$2 }
|
|
|
|
| '{'var'}' { [(Im, getVar $2)] }
|
|
| '{'var'}' LambdaList { (Im, getVar $2):$4 }
|
|
|
|
LhsList :: { [(Plicity, Text)] }
|
|
: { [] }
|
|
| LambdaList { $1 }
|
|
|
|
VarList :: { (Posn, Posn, [Text]) }
|
|
: var { (startPosn $1, endPosn $1, [getVar $1]) }
|
|
| var ',' VarList { case $3 of (_, end, xs) -> (startPosn $1, end, getVar $1:xs) }
|
|
|
|
Statement :: { Statement }
|
|
: VarList ':' Exp { spanSt $1 $3 $ Decl (thd $1) $3 }
|
|
| var LhsList '=' Exp { spanSt $1 $4 $ Defn (getVar $1) (makeLams $2 $4) }
|
|
| '{-#' Pragma '#-}' { spanSt $1 $3 $ $2 }
|
|
|
|
ReplStatement :: { Statement }
|
|
: Exp { spanSt $1 $1 $ ReplNf $1 }
|
|
| ':t' Exp { spanSt $1 $2 $ ReplTy $2 }
|
|
| ':let' VarList ':' Exp { spanSt $1 $4 $ Decl (thd $2) $4 }
|
|
| ':let' var LhsList '=' Exp { spanSt $1 $5 $ Defn (getVar $2) (makeLams $3 $5) }
|
|
| '{-#' Pragma '#-}' { spanSt $1 $3 $ $2 }
|
|
|
|
Program :: { [Statement] }
|
|
: Statement { [$1] }
|
|
| Semis Program { $2 }
|
|
| Statement Semis Program { $1:$3 }
|
|
|
|
Semis :: { () }
|
|
: ';' { () }
|
|
| ';' Semis { () }
|
|
|
|
Pragma :: { Statement }
|
|
: 'PRIMITIVE' var var { Builtin (getVar $2) (getVar $3) }
|
|
| 'PRIMITIVE' var { Builtin (getVar $2) (getVar $2) }
|
|
|
|
System :: { [(Condition, Expr)] }
|
|
: {- empty system -} { [] }
|
|
| NeSystem { $1 }
|
|
|
|
NeSystem :: { [(Condition, Expr) ]}
|
|
: SystemLhs '->' Exp { [($1, $3)] }
|
|
| SystemLhs '->' Exp ',' NeSystem { ($1, $3):$5 }
|
|
|
|
SystemLhs :: { Condition }
|
|
: Formula 'as' var { Condition $1 (Just (getVar $3)) }
|
|
| Formula { Condition $1 Nothing }
|
|
|
|
Formula :: { Formula }
|
|
: Disjn { $1 }
|
|
| Disjn '&&' Disjn { $1 `FAnd` $3 }
|
|
|
|
Disjn :: { Formula }
|
|
: FAtom { $1 }
|
|
| FAtom '||' FAtom { $1 `FOr` $3 }
|
|
|
|
FAtom :: { Formula }
|
|
: '(' var '=' var ')' {%
|
|
case $4 of
|
|
Token (TokVar x) _ _
|
|
| x == T.pack "i0" -> pure (FIs0 (getVar $2))
|
|
| x == T.pack "i1" -> pure (FIs1 (getVar $2))
|
|
x -> parseError (x, ["i0", "i1"])
|
|
}
|
|
|
|
{
|
|
lexer cont = alexMonadScan >>= cont
|
|
|
|
parseError x = alexError (show x)
|
|
|
|
makeLams xs b = foldr (uncurry Lam) b xs
|
|
makePis p xs t b = foldr (flip (Pi p) t) b xs
|
|
makeSigmas xs t b = foldr (flip Sigma t) b xs
|
|
|
|
class HasPosn a where
|
|
startPosn :: a -> Posn
|
|
endPosn :: a -> Posn
|
|
|
|
instance HasPosn Token where
|
|
startPosn (Token _ l c) = Posn l c
|
|
endPosn (Token t l c) = Posn l (c + tokSize t)
|
|
|
|
instance HasPosn Expr where
|
|
startPosn (Span _ s _) = s
|
|
startPosn _ = error "no start posn in parsed expression?"
|
|
|
|
endPosn (Span _ _ e) = e
|
|
endPosn _ = error "no end posn in parsed expression?"
|
|
|
|
instance HasPosn (Posn, Posn, a) where
|
|
startPosn (s, _, _) = s
|
|
endPosn (_, e, _) = e
|
|
|
|
thd :: (a, b, c) -> c
|
|
thd (x, y, z) = z
|
|
|
|
|
|
span s e ex = Span ex (startPosn s) (endPosn e)
|
|
spanSt s e ex = SpanSt ex (startPosn s) (endPosn e)
|
|
|
|
getVar (Token (TokVar s) _ _) = s
|
|
getVar _ = error "getVar non-var"
|
|
}
|