amelia
/
cubical


{

{-# LANGUAGE FlexibleInstances #-}

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

 '(' { Token TokOParen _ _ }

 ')' { Token TokCParen _ _ }


 '{' { Token TokOBrace _ _ }

 '}' { Token TokCBrace _ _ }


 '{-#' { Token TokOPragma _ _ }

 '#-}' { Token TokCPragma _ _ }


 '\\' { Token TokLambda _ _ }


 '->' { Token TokArrow _ _ }

 ':' { Token TokColon _ _ }

 ';' { Token TokSemi _ _ }

 '=' { Token TokEqual _ _ }

 ',' { Token TokComma _ _ }

 '*' { Token TokStar _ _ }


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

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


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

 | Statement ';' Program { $1:$3 }


Pragma :: { Statement }

 : 'PRIMITIVE' var var { Builtin (getVar $2) (getVar $3) }

 | 'PRIMITIVE' var { Builtin (getVar $2) (getVar $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"

}