{
module Parser where

import Grammar
import Monad
import MutableArray
import ST

#include "tokens.h"

countH :: P Int
countH _ = liftM Ok $ _ccall_ countC

svalH :: P String
svalH _ = liftM Ok $
  do n <- slenH -- changed !
     a <- stToIO $ newCharArray (0, n-1)
     _ccall_ svalC a n
     s <- stToIO $ sequence [ readCharArray a i | i <- [0..n-1] ]
     return $ takeWhile (/= '\0') s

-- new !

slenH :: IO Int
slenH = _ccall_ slenC

ivalH :: P Int
ivalH _ = liftM Ok $ _ccall_ ivalC

yylexH :: P Int
yylexH _ = liftM Ok $ _ccall_ yylexC

}

%name parser
%tokentype { Token }

%monad { P } { thenP } { returnP }
%lexer { flexer } { TokenEOF }

%token
        LPAREN          { TokenLPAREN          }
        RPAREN          { TokenRPAREN          }
        IF              { TokenIF              } 
        DECISION        { TokenDECISION        } 
        CASE            { TokenCASE            } 
        ELSEIF          { TokenELSEIF          } 
        ARM             { TokenARM             } 
        EQUALS          { TokenEQUALS          } 
        AND             { TokenAND             } 
        OR              { TokenOR              } 
        VAR             { TokenVAR             } 
        WILDCARD        { TokenWILDCARD        } 
        INT             { TokenINT $$          } 
        STRING          { TokenSTRING $$       } 

%%

character       :: { Character }
                : LPAREN rules RPAREN
                  {%
                    returnP $2
                  }

rules           :: { [Rule] }
                : rule rules
                  {
                    $1 : $2
                  }
                | -- eps
                  {
                    []
                  }

rule            :: { Rule }
                : LPAREN statenumbers stmt RPAREN
                  {
                    ($2 , $3)
                  }

stmt            :: { Stmt }
                : LPAREN IF condition stmt LPAREN elseifs RPAREN stmt RPAREN
                  {
                    IF (($3,$4) : $6) $8
                  }
                | LPAREN DECISION newstate utterance RPAREN
                  {
                    DECISION $3 $4
                  }
                | LPAREN CASE variable LPAREN arms RPAREN stmt RPAREN
                  {
                    CASE $3 $5 $7
                  }

elseifs         :: { [(Condition,Stmt)] }
                : elseif elseifs
                  {
                    $1 : $2
                  }
                | -- eps
                  {
                    []
                  }

elseif          :: { (Condition,Stmt) }
                : LPAREN ELSEIF condition stmt RPAREN
                  {
                    ($3 , $4)
                  }

arms            :: { [Arm] }
                : arm arms
                  {
                    $1 : $2
                  }
                | -- eps
                  {
                    []
                  }

arm             :: { Arm }
                : LPAREN ARM valueset stmt RPAREN
                  {
                    ($3 , $4)
                  }

conditions      :: { [Condition] }
                : condition conditions
                  {
                    $1 : $2
                  }
                | -- eps
                  {
                    []
                  }

condition       :: { Condition }
                : LPAREN EQUALS variable INT RPAREN
                  {
                    EQUALS $3 $4
                  }
                | LPAREN AND conditions RPAREN
                  {
                    AND $3
                  }
                | LPAREN OR conditions RPAREN
                  {
                    OR $3
                  }

variable        :: { Variable }
                : LPAREN VAR STRING RPAREN
                  {
                    $3
                  }

statenumbers    :: { [StateNumber] }
                : ints
                  {
                    $1
                  }

newstate        :: { NewState }
                : INT
                  {
                   STATE $1
                  }
                | WILDCARD
                  {
                    WILDCARD []
                  }

utterance       :: { Utterance }
                : STRING
                  {
                    $1
                  }

valueset        :: { ValueSet }
                : LPAREN ints RPAREN
                  {
                    $2
                  }

ints            :: { [Int] }
                : INT ints
                  {
                    $1 : $2
                  }
                | -- eps
                  {
                    []
                  }

{

data Error a = Ok a
             | Fail String

type P a = Int -> IO (Error a)

thenP :: P a -> (a -> P b) -> P b
ma `thenP` f = \l ->
  do res <- ma l
     case res of
       Ok a   -> f a l
       Fail s -> return (Fail s)

returnP :: a -> P a
returnP a = \l -> return (Ok a)

type Parse = P Character
parser :: Parse

data Token = TokenLPAREN
           | TokenRPAREN
           | TokenIF
           | TokenDECISION
           | TokenCASE
           | TokenELSEIF
           | TokenARM
           | TokenEQUALS
           | TokenAND
           | TokenOR
           | TokenVAR
           | TokenWILDCARD
           | TokenINT Int
           | TokenSTRING String
           | TokenEOF

flexer :: (Token -> Parse) -> Parse
flexer cont =
  yylexH `thenP` \l ->
    case l of
      T_LPAREN    -> cont TokenLPAREN
      T_RPAREN    -> cont TokenRPAREN
      T_IF        -> cont TokenIF
      T_DECISION  -> cont TokenDECISION
      T_CASE      -> cont TokenCASE
      T_ELSEIF    -> cont TokenELSEIF
      T_ARM       -> cont TokenARM
      T_EQUALS    -> cont TokenEQUALS
      T_AND       -> cont TokenAND
      T_OR        -> cont TokenOR
      T_VAR       -> cont TokenVAR
      T_WILDCARD  -> cont TokenWILDCARD
      T_INT       -> ivalH `thenP` \i -> cont (TokenINT i)
      T_STRING    -> svalH `thenP` \s -> cont (TokenSTRING s)
      _           -> cont TokenEOF

happyError :: Parse
happyError l =
  do (Ok x) <- countH l
     return $ Fail ("parse error at position " ++ show x ++ endl)

endl :: String
endl = "\n"

}