-- a simple interpreter for a language with statements and prints
-- implemented as semantic actions

{
import Data.Char -- needed by the lexer
}

%name interpreter       -- name of created function
%tokentype { Token }    -- type of accepted tokens
                        -- parser :: [Token] -> t with t type of attribute of
                        -- first rule

%token ';'   { SEMICOLON }
       '='   { ASSIGN }
       print { PRINT }
       if    { IF }
       then  { THEN }
       else  { ELSE }
       while { WHILE }
       do    { DO }
       '+'   { PLUS }
       '-'   { MINUS }
       '*'   { MULT }
       '('   { LPAREN }
       ')'   { RPAREN }
       '>'   { GREATER }
       id    { ID $$ }
       num   { NUM $$ }

%%                      -- as in yacc

-- semantic action of statements have type (env,output) -> (env,output)

program : stmts             { snd ($1 (emptyEnv,"")) }

stmts : stm ';' stmts       { $3 . $1 }
      | stm                 { $1 }

stm : id '=' exp            { \(e,o) -> (updateEnv e $1 ($3 e),o) }
    | print '(' exp ')'     { \(e,o) -> (e,o ++ show($3 e ::Int) ++ "\n") }
    | if bexp then stm else stm { \(e,o)->if $2 e then $4 (e,o) else $6 (e,o) }
    | while bexp do stm     { let whilesem (e,o) = if $2 e
                                                   then whilesem ($4 (e,o))
                                                   else (e,o)
                               in whilesem }
    | '(' stmts ')'         { $2 }

exp : exp '+' term          { \e -> ($1 e + $3 e)::Int }  -- typing required
    | exp '-' term          { \e -> ($1 e - $3 e)::Int }
    | term                  { $1 }

term : term '*' factor      { \e -> ($1 e * $3 e)::Int }
     | factor               { $1 }

factor : id                 { \e -> e $1 }
       | num                { \_ -> $1 }
       | '(' exp ')'        { $2 }

bexp : exp '=' exp          { \e->$1 e == ($3 e ::Int) }
     | exp '>' exp          { \e->$1 e > ($3 e ::Int) }

{
-- Environments:
type Env = String -> Int

-- the empty environment:
emptyEnv :: Env
emptyEnv n = error ("Access to undefined variable "++n)

-- update the environment:
updateEnv :: Env -> String -> Int -> Env
updateEnv e n v = \m -> if n==m then v else e m

happyError :: [Token] -> a
happyError _ = error "Parse error"


-- scanner:

data Token = ID String | NUM Int | PLUS | MINUS | MULT | LPAREN | RPAREN
           | SEMICOLON | ASSIGN | PRINT | IF | THEN | ELSE | WHILE | DO
           | GREATER
  deriving Show


lexer :: String -> [Token]
lexer [] = []
lexer (c:cs) 
       | isSpace c = lexer cs
       | isAlpha c = lexId (c:cs)
       | isDigit c = lexNum (c:cs)
lexer ('+':cs) = PLUS : lexer cs
lexer ('-':cs) = MINUS : lexer cs
lexer ('*':cs) = MULT : lexer cs
lexer ('(':cs) = LPAREN : lexer cs
lexer (')':cs) = RPAREN : lexer cs
lexer (';':cs) = SEMICOLON : lexer cs
lexer ('=':cs) = ASSIGN : lexer cs
lexer ('>':cs) = GREATER : lexer cs

lexNum cs = NUM (read num) : lexer rest
      where (num,rest) = span isDigit cs

lexId cs =
   case span isAlpha cs of
      (var,rest)  -> (case var of
                       "print" -> PRINT
                       "if"    -> IF
                       "then"  -> THEN
                       "else"  -> ELSE
                       "while" -> WHILE
                       "do"    -> DO
                       otherwise -> ID var) : lexer rest

runprog = interpreter . lexer

-- putStr (runprog "x=2 ; print (3+x*5)")
-- putStr (runprog "x=2 ; if x=3 then print(0) else print(x)")
-- putStr (runprog "x=2 ; x=x+1; if x=3 then print(0) else print(x)")
-- putStr (runprog "x=10 ; while x>0 do (print(x) ; x=x-1)")
-- putStr (runprog "x=1; p=1; while 10>x do (print(p) ; p=p*x; x=x+1)")

}