-- ----------------------------------------
--
-- Monadic version of simple expression
-- evaluator with additional exception
-- handling.
--
-- ----------------------------------------

module Parser where

import Data.Maybe          ( fromMaybe )
import Data.Char

import Control.Monad
import Control.Monad.Error
import Control.Monad.Reader
 
-- ----------------------------------------
-- syntactic domains
 
data Expr  = Const  Int
           | Var    Id
           | Let    Id    Expr Expr
           | Binary BinOp Expr Expr
             deriving (Show)
 
data BinOp = Add | Sub | Mul | Div | Mod
             deriving (Eq, Show)
 
type Id    = String
 
-- ----------------------------------------
-- semantic domains
 
data ResVal a
           = Val { val :: a }
           | Exc { exc :: String }
             deriving (Show)
 
newtype Result a
           = Res { unRes :: Env -> ResVal a } 
 
type Env   = [(Id, Int)]
 
-- ----------------------------------------
-- the reader monad combined with
-- the exception monad
 
instance Monad Result where
  return x      = Res $ \ env -> Val x
  (Res f) >>= g = Res $ \ env ->
                  case f env of
                  (Exc e) -> (Exc e)
                  (Val v) -> unRes (g v) env
 
instance MonadError String Result where
  throwError s  = Res $ \ env -> Exc s
 
  -- not yet used in expression evaluation
  catchError (Res f) handler
                = Res $ \ env ->
                  case f env of
                  (Exc e) -> unRes (handler e) env
                  x       -> x
 
instance MonadReader Env Result where
  ask       = Res $ \ env -> Val env
  local f c = Res $ \ env -> unRes c (f env)

-- ----------------------------------------
-- the meaning of an expression
 
eval :: Expr -> Result Int
eval (Const i)
  = return i
 
eval (Binary op l r)
  = do
    mf <- lookupMft op
    mf (eval l) (eval r)
 
eval (Var id)
  = do
    env <- ask
    case lookup id env of
      Nothing -> throwError
                 $ "free variable "
                   ++ show id
                   ++ " found"
      Just v  -> return v
 
eval (Let id e1 e2)
  = do
    v1 <- eval e1
    local (addEnv id v1)
          (eval e2)
    where
    addEnv i v = ((i, v) :)
 
-- ----------------------------------------
-- the meaning of binary operators
 
type MF = Result Int -> Result Int ->
          Result Int
 
lookupMft :: BinOp -> Result MF
lookupMft op
  = case lookup op mft of
    Nothing -> throwError
               "operation not yet implemented"
    Just mf -> return mf
 
mft :: [(BinOp, MF)]
mft
  = [ (Add, liftM2 (+))
    , (Sub, liftM2 (-))
    , (Mul, liftM2 (*))
    , (Div, \ x -> join . liftM2 div' x)
    ]
 
div' :: Int -> Int -> Result Int
div' x y
  | y == 0    = throwError
                "division by zero"
  | otherwise = return (x `div` y)
 
-- ----------------------------------------
-- evaluate an expression within a given env
 
evalEnv :: Expr -> Env -> ResVal Int
evalEnv = unRes . eval
 
eval'   :: Expr -> ResVal Int
eval' e =  evalEnv e []
 
-- ----------------------------------------
-- sample expressions
 
e1 = Binary Mul (Binary Add (Const 2)
                            (Const 4)
                )
                (Const 7)
e2 = Binary Div (Const 1) (Const 0)
e3 = Binary Mod (Const 1) (Const 0)
e4 = Var "x"
e5 = Binary Mul (Binary Add e4
                            (Const 1)
                ) e4
e4' = Let "x" (Const 42) e4
e5' = Let "x" (Const 6)  e5 
 
v1 = eval' e1
v2 = eval' e2
v3 = eval' e3
 
v4  = evalEnv e4 [("x", 42)]
v5  = evalEnv e5 [("x",  6)]
v4' = eval'   e4'
v5' = eval'   e5'
 
-- ----------------------------------------








-- ============================================ --
-- ================== PARSER ================== --
-- ============================================ --

newtype Parser a = MkParser ( String -> [(a, String)] )

parse                  :: Parser a -> String -> [(a, String)]
parse (MkParser f) inp = f inp

instance Monad Parser where
  return x = MkParser (\ input -> [(x, input)])
  p >>= f  = MkParser (\ input -> case parse p input of
                                    []        -> []
                                    [(v,out)] -> parse (f v) out
                      )

-- Parser that always fails
failure :: Parser a
failure = MkParser (\ _ -> [])

-- Parser that returns the first item of a string
item :: Parser Char
item = MkParser (\ input -> case input of
                              []     -> []
                              (c:cs) -> [(c,cs)]
                )

-- combining two parsers
orelse :: Parser a -> Parser a -> Parser a
orelse p q = MkParser (\ input -> case parse p input of
                                 []         -> parse q input
                                 [(v, out)] -> [(v, out)]
                   )

-- Parser that return a char that satisfies a property
sat   :: (Char -> Bool) -> Parser Char
sat p = do c <- item
           if p c then return c
                  else failure

-- some useful parsers
digit = sat isDigit
lower = sat isLower
upper = sat isUpper
letter = sat isAlpha
alphanum = sat isAlphaNum

-- Parser for one certain character
char :: Char -> Parser Char
char c = sat (==c)

-- Parser for a certain string
string :: String -> Parser String
string [] = return []
string (c:cs) = do char c
                   string cs
                   return (c:cs)

-- repeat a parser
many   :: Parser a -> Parser [a]
many p = atLeastOne p `orelse` return []

atLeastOne :: Parser a -> Parser [a]
atLeastOne p = do x <- p
                  xs <- many p
                  return (x:xs)

-- a whitespace parser
space :: Parser ()
space = do many (sat isSpace)
           return ()

-- a natural number parser
nat :: Parser Int
nat = do n <- atLeastOne digit
         return (read n)

-- a parser to discard spaces
token :: Parser a -> Parser a
token p = do space
             r <- p
             space
             return r

-- a parser for a certain symbol discarding spaces
symbol :: String -> Parser String
symbol sym = token (string sym)

iden :: Parser Expr
iden = natConst `orelse` variable

variable :: Parser Expr
variable = do v <- token (atLeastOne letter)
              return (Var v)

natConst :: Parser Expr
natConst = do i <- token nat
              return (Const i)

-- now our parser for arithmetic expressions
pBinOpAddSub :: Parser BinOp
pBinOpAddSub = do op <- symbol "+" `orelse` symbol "-"
                  case  op of
                    "+" -> return Add
                    "-" -> return Sub
pBinOpMulDiv :: Parser BinOp
pBinOpMulDiv = do op <- symbol "*" `orelse` symbol "/" `orelse` symbol "%"
                  case  op of
                    "*" -> return Mul
                    "/" -> return Div
                    "%" -> return Mod

pLet :: Parser Expr
pLet = do symbol "let"
          v <- token (atLeastOne letter)
          symbol "="
          z <- pExpr
          symbol "in"
          a <- pExpr
          return (Let v z a)

pExpr :: Parser Expr
pExpr =  pLet `orelse`
         do t <- pTerm
            do o <- pBinOpAddSub
               e <- pExpr
               return (Binary o t e)
               `orelse` return t

pTerm :: Parser Expr
pTerm =  do f <- pFactor
            do o <- pBinOpMulDiv
               t <- pTerm
               return (Binary o f t)
               `orelse` return f

pFactor :: Parser Expr
pFactor =  do symbol "("
              e <- pExpr
              symbol ")"
              return e
              `orelse` iden

doParse   :: String -> Expr
doParse s = case parse pExpr s of
              [(n,[])]  -> n
              [(_,out)] -> error ("unused input '" ++ out ++ "'")
              []        -> error "invalid input"

doEval :: String -> ResVal Int
doEval = eval' . doParse

doPretty :: String -> String
doPretty = pp . doParse

pp :: Expr -> String
pp (Const i)      = show i
pp (Binary o a b) = "(" ++ pp a ++ " " ++ ppOp o ++ " " ++ pp b ++ ")"
pp (Var v)        = v
pp (Let v z e)    = "let " ++ v ++ " = " ++ pp z ++ " in " ++ pp e

ppOp :: BinOp -> String
ppOp Add = "+"
ppOp Sub = "-"
ppOp Mul = "*"
ppOp Div = "/"
ppOp Mod = "%"