|
|
- {
- {-# 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"
- }
|