{
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

%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 TokLambda _ _ }
  
  '->'    { Token TokArrow _ _ }
  ':'     { Token TokColon _ _ }
  ';'     { Token TokSemi  _ _ }
  '='     { Token TokEqual _ _ }
  ','     { Token TokComma _ _ }
  '*'     { Token TokStar _ _ }

  '.1'     { Token TokPi1 _ _ }
  '.2'     { Token TokPi2 _ _ }

%%

Exp :: { Expr }
Exp
  : Exp ExpProj                       { span $1 $2 $ App Ex $1 $2 }
  | Exp '{' Exp '}'                   { span $1 $4 $ App Im $1 $3 }

  | '\\' LambdaList '->' Exp          { span $1 $4 $ makeLams $2 $4 }
  | '(' VarList ':' Exp ')' ProdTail  { span $1 $6 $ makePis Ex $2 $4 $6 }
  | '{' VarList ':' Exp '}' ProdTail  { span $1 $6 $ makePis Im $2 $4 $6 }
  | ExpProj '->' Exp                  { span $1 $3 $ Pi Ex (T.singleton '_') $1 $3 }

  | '(' VarList ':' Exp ')' '*'  Exp  { span $1 $7 $ makeSigmas $2 $4 $7 }
  | ExpProj '*' Exp                   { span $1 $3 $ Sigma (T.singleton '_') $1 $3 }

  | ExpProj                           { $1 }

ProdTail :: { Expr }
  : '(' VarList ':' Exp ')' ProdTail  { span $1 $6 $ makePis Ex $2 $4 $6 }
  | '{' VarList ':' Exp '}' ProdTail  { span $1 $6 $ makePis Im $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 :: { [Text] }
  : var         { [getVar $1] }
  | var VarList { getVar $1:$2 }

ExpProj :: { Expr }
  : ExpProj '.1' { span $1 $2 $ Proj1 $1 }
  | ExpProj '.2' { span $1 $2 $ Proj2 $1 }
  | Atom         { $1 }

Atom :: { Expr }
  : var           { span $1 $1 $ Var (getVar $1) }
  | '(' Tuple ')' { span $1 $3 $ $2 }

Tuple :: { Expr }
  : Exp           { $1 }
  | Exp ',' Tuple { span $1 $3 $ Pair $1 $3 }

Statement :: { Statement }
  : var ':' Exp         { Decl (getVar $1) $3 }
  | var LhsList '=' Exp { Defn (getVar $1) (makeLams $2 $4) }

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

{
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?"

span s e ex = Span ex (startPosn s) (endPosn e)

getVar (Token (TokVar s) _ _) = s
getVar _ = error "getVar non-var"
}