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

{
import Data.Char -- needed by the lexer

-- Environments:
type Env = String -> Int

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

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

%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 }
       '+'   { PLUS }
       '*'   { MULT }
       '('   { LPAREN }
       ')'   { RPAREN }
       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) -> (update e $1 ($3 e), o) }
    | print '(' exp ')'     { \(e,o) -> (e, o++show($3 e ::Int)++"\n") }

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

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

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

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


data Token = ID String | NUM Int | PLUS | MULT | LPAREN | RPAREN
           | SEMICOLON | ASSIGN | PRINT
  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) = MULT : lexer cs
lexer ('(':cs) = LPAREN : lexer cs
lexer (')':cs) = RPAREN : lexer cs
lexer (';':cs) = SEMICOLON : lexer cs
lexer ('=':cs) = ASSIGN : lexer cs

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

lexId cs =
   case span isAlpha cs of
      (var,rest)  -> (if  var=="print" then PRINT else ID var) : lexer rest

runprog = interpreter . lexer

-- putStr (runprog "x=2 ; print (3+x*5)")
-- putStr (runprog "x=2 ; print(x); y=3+x*5; print(y)")

}