{
{-# OPTIONS_GHC -w #-}
module Tempus.Parser (
    parseProgram,
    parseDecl,
    parseType,
    parseExpr
) where

import Prelude hiding (lex)

import Tempus.Loc
import Tempus.Lexer
import Tempus.Syntax

}

%name pparseProgram prog
%name pparseDecl decl
%name pparseType type
%name pparseExpr expr

%tokentype { Loc Token }
%monad { Parser }
%lexer { lex } { Loc _ EOF }

%error { parseError }
%token
    var             { Loc _ (Variable _) }
    natlit          { Loc _ (NatLit _) }
    '='             { Loc $$ Equals }
    '->'            { Loc $$ ArrowRight }
    '+'             { Loc $$ Plus }
    '*'             { Loc $$ Times }
    '('             { Loc $$ ParenOpen }
    ')'             { Loc $$ ParenClose }
    '0'             { Loc $$ Zero }
    '1'             { Loc $$ One }
    mu              { Loc $$ Mu }
    nu              { Loc $$ Nu }
    '.'             { Loc $$ Dot }
    ','             { Loc $$ Comma }
    lam             { Loc $$ Lambda }
    '['             { Loc $$ SquareOpen }
    ']'             { Loc $$ SquareClose }
    langle          { Loc $$ AngleOpen }
    rangle          { Loc $$ AngleClose }
    '<*>'           { Loc $$ CircledAsterisk }
    '<.>'           { Loc $$ CircledDot }
    '?'             { Loc $$ QuestionMark }
    'behavior'      { Loc $$ KWBehavior }
    'case'          { Loc $$ KWCase }
    'const'         { Loc $$ KWConst }
    'event'         { Loc $$ KWEvent }
    'expand'        { Loc $$ KWExpand }
    'first'         { Loc $$ KWFirst }
    'fold'          { Loc $$ KWFold }
    'left'          { Loc $$ KWLeft }
    'positive'      { Loc $$ KWPositive }
    'never'         { Loc $$ KWNever }
    'pack'          { Loc $$ KWPack }
    'race'          { Loc $$ KWRace }
    'reflect'       { Loc $$ KWReflect }
    'right'         { Loc $$ KWRight }
    'second'        { Loc $$ KWSecond }
    'ultraswitch'   { Loc $$ KWUltraswitch }
    'type'          { Loc $$ KWType }
    'ultrajump'     { Loc $$ KWUltrajump }
    'unfold'        { Loc $$ KWUnfold }
    'unpack'        { Loc $$ KWUnpack }
    'value'         { Loc $$ KWValue }

%%

prog        :: { Program }
prog        : decls                             { reverse $1 }

decls       :: { [Decl] }
decls       :                                   { [] }
            | decls decl                        { $2 : $1 }

decl        :: { Decl }
decl        : typedecl                          { $1 }
            | valdecl                           { $1 }

typedecl    :: { Decl }
typedecl    : 'type' var formalargs '=' type    { DeclType $1 (var $2) (reverse $3) $5 }

formalargs  :: { [Var] }
formalargs  :                                   { [] }
            | formalargs var                    { var $2 : $1 }

valdecl     :: { Decl }
valdecl     : 'value' var '=' expr              { DeclVal $1 (var $2) $4 }

type        :: { Type }
type        : type0                             { $1 }

type0       :: { Type }
type0       : mutype                            { TyMu $1 }
            | nutype                            { TyNu $1 }
            | type1                             { $1 }

type1       :: { Type }
type1       : type2 '->' type1                  { TyFun $1 $3 }
            | type2                             { $1 }

type2       :: { Type }
type2       : type3 '+' type2                   { TyPlus $1 $3 }
            | type3                             { $1 }

type3       :: { Type }
type3       : type4 '*' type3                   { TyPair $1 $3 }
            | type4                             { $1 }

type4       :: { Type }
type4       : var typeargs                      { TyApp (var $1) $2 }
            | 'behavior' type5                  { TyBehav $2 }
            | 'event' type5                     { TyEvent $2 }
            | type5                             { $1 }

type5       :: { Type }
type5       : var                               { TyApp (var $1) [] }
            | 'positive'                        { TyNat }
            | '(' type0 ')'                     { $2 }
            | '0'                               { TyZero }
            | '1'                               { TyUnit }

typeargs    :: { [Type] }
typeargs    : type5                             { [$1] }
            | typeargs type5                    { $2 : $1 }

mutype      :: { MuType }
mutype      : mu var '.' type0                  { MuType (var $2) $4 }

nutype      :: { NuType }
nutype      : nu var '.' type0                  { NuType (var $2) $4 }

expr        :: { Expr }
expr        : expr0                             { $1 }

expr0       :: { Expr }
expr0       : expr1 ',' expr0                   { ExPair $1 $3 }
            | expr1                             { $1 }

expr1       :: { Expr }
expr1       : lam var '.' expr1                 { ExLam (var $2) $4 }
            | expr2                             { $1 }

expr2       :: { Expr }
expr2       : expr2 '<*>' expr3                 { ExLiftAppB $1 $3 }
            | expr2 '<.>' expr3                 { ExLiftAppE $1 $3 }
            | expr3                             { $1 }

expr3       :: { Expr }
expr3       : expr3 expr4                       { ExApp $1 $2 }
            | 'const' expr4                     { ExConst $2 }
            | 'behavior' expr4                  { ExBehav $2 }
            | 'event' expr4 expr4               { ExEvent $2 $3 }
            | foldvals '[' type ']' expr4       { $1 $3 $5 }
            | expr4                             { $1 }

expr4       :: { Expr }
expr4       : var                               { ExVar $ var $1 }
            | '1'                               { ExNatLit 1 }
            | natlit                            { ExNatLit $ nat $1 }
            | '(' expr0 ')'                     { $2 }
            | '?'                               { ExNull }
            | langle rangle                     { ExUnit }
            | '(' ')'                           { ExUnit }
            | packvals '[' type ']'             { $1 $3 }
            | baseval                           { $1 }

foldvals    :: { Type -> Expr -> Expr }
foldvals    : 'fold'                            { ExFold }
            | 'unfold'                          { ExUnfold }

packvals    :: { Type -> Expr }
packvals    : 'pack'                            { ExPack }
            | 'unpack'                          { ExUnpack }

baseval     :: { Expr }
baseval     : 'left'                            { ExLeft }
            | 'right'                           { ExRight }
            | 'case'                            { ExCase }
            | 'first'                           { ExFst }
            | 'second'                          { ExSnd }
            | 'expand'                          { ExExpand }
            | 'never'                           { ExNever }
            | 'race'                            { ExRace }
            | 'reflect'                         { ExReflect }
            | 'ultraswitch'                     { ExUSwitch }
            | 'ultrajump'                       { ExUJump }


{

-- | Parses a complete Tempus program.
parseProgram :: String -> ParseResult Program
parseProgram = initParser pparseProgram

-- | Parses a single Tempus type or value declaration.
parseDecl :: String -> ParseResult Decl
parseDecl = initParser pparseDecl

-- | Parses a Tempus type expression.
parseType :: String -> ParseResult Type
parseType = initParser pparseType

-- | Parses a Tempus expression.
parseExpr :: String -> ParseResult Expr
parseExpr = initParser pparseExpr


var :: Loc Token -> Var
var (Loc _ (Variable v)) = Var v
var _ = error "internal parser error: unexpected token in var"

nat :: Loc Token -> Integer
nat (Loc _ (NatLit i)) = i
nat _ = error "internal parser error: unexpected token in nat"

parseError :: Loc Token -> Parser a
parseError (Loc loc tok) = fail $ "error parsing token `" ++ showToken tok ++ "' at " ++ show loc

}