amelia
/
cubical


{

{-# LANGUAGE FlexibleContexts, 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)


import Debug.Trace


}


%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 _ _ }


 START { Token TokLStart _ _ }

 END { Token TokLEnd _ _ }


 '[' { 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 _ _ }


 'let' { Token TokLet _ _ }

 'in' { Token TokIn _ _ }

 'data' { Token TokData _ _ }

 'case' { Token TokCase _ _ }

 'where' { Token TokWhere _ _ }


 '&&' { Token TokAnd _ _ }

 '||' { Token TokOr _ _ }


 '.1' { Token TokPi1 _ _ }

 '.2' { Token TokPi2 _ _ }


 'PRIMITIVE' { Token TokPrim _ _ }

 'postulate' { Token TokPostulate _ _ }


 ':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 }

 | '\\' 'case' Block(CaseList) { span $1 $3 $ LamCase (thd $3) }

 | '(' 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 }


 | 'let' Block(LetList) 'in' Exp { span $1 $4 $ Let (thd $2) $4 }


 | 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) }


LetItem :: { LetItem }

 : var ':' Exp { LetDecl (getVar $1) $3 }

 | var LhsList '=' Rhs { LetBind (getVar $1) (makeLams $2 $4) }


LetList :: { [LetItem] }

 : { [] }

 | LetItem { [$1] }

 | LetItem ';' LetList { $1:$3 }


CaseItem :: { (Pattern, Expr) }

 : Pattern '->' Exp { ($1, $3) }


CaseList :: { [(Pattern, Expr)] }

 : { [] }

 | CaseItem { [$1] }

 | CaseItem Semis CaseList { $1:$3 }


Pattern :: { Pattern }

 : PatVarList { makePattern $1 }


PatVarList :: { (Posn, Posn, [Text]) }

 : var { (startPosn $1, endPosn $1, [getVar $1]) }

 | var PatVarList { case $2 of (_, end, xs) -> (startPosn $1, end, getVar $1:xs) }


Statement :: { Statement }

 : VarList ':' Exp { spanSt $1 $3 $ Decl (thd $1) $3 }

 | var LhsList '=' Rhs { spanSt $1 $4 $ Defn (getVar $1) (makeLams $2 $4) }

 | '{-#' Pragma '#-}' { spanSt $1 $3 $ $2 }


 | 'postulate' Block(Postulates) { spanSt $1 $2 $ Postulate (thd $2) }

 | 'data' var Parameters ':' Exp 'where' Block(Constructors)

 { spanSt $1 $7 $ Data (getVar $2) $3 $5 (thd $7) }


Constructors :: { [(Posn, Posn, Constructor)] }

 : { [] }

 | var ':' Exp { [(startPosn $1, endPosn $3, Point (getVar $1) $3)] }

 | var PatVarList ':' Exp '[' Faces ']' { [(startPosn $1, endPosn $7, Path (getVar $1) (thd $2) $4 $6)] }

 | var ':' Exp Semis Constructors { (startPosn $1, endPosn $3, Point (getVar $1) $3):$5 }

 | var PatVarList ':' Exp '[' Faces ']' Semis Constructors

 { (startPosn $1, endPosn $7, Path (getVar $1) (thd $2) $4 $6):$9 }


Parameters :: { [(Text, Plicity, Expr)] }

 : {- empty -} { [] }

 | '(' var ':' Exp ')' Parameters { (getVar $2, Ex, $4):$6 }

 | '{' var ':' Exp '}' Parameters { (getVar $2, Im, $4):$6 }


Rhs :: { Expr }

 : Exp { $1 }

 | Exp 'where' START LetList END { span $1 $5 $ Let $4 $1 }


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 }


Postulates :: { [(Text, Expr)] }

 : var ':' Exp { [(getVar $1, $3)] }

 | var ':' Exp Semis Postulates { (getVar $1, $3):$5 }


StatementSeq :: { [Statement] }

 : Statement { [$1] }

 | Statement Semis { [$1] }

 | Statement Semis Program { $1:$3 }


Program :: { [Statement] }

 : { [] }

 | Semis { [] }

 | StatementSeq { $1 }

 | Semis StatementSeq { $2 }


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 }


Faces :: { [(Formula, Expr)] }

 : {- empty system -} { [] }

 | NeFaces { $1 }


NeFaces :: { [(Formula, Expr) ]}

 : Formula '->' Exp { [($1, $3)] }

 | Formula '->' Exp ',' NeFaces { ($1, $3):$5 }


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"])

 }


Block(p)

 : START p END { (startPosn $1, endPosn $3, $2) }

 | '{' p '}' { (startPosn $1, endPosn $3, $2) }


{

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"


makePattern (_, _, [x]) = PCap x

makePattern (_, _, (x:xs)) = PCon x xs

}