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