import Text.Read

{-
This is a recursive-descent parser for the grammar:

        expr -> term | term + expr | term - expr
	term -> factor | factor * term | factor / term
	factor -> const | ( expr )

Here const is a String that can be interpreted as an integer
value (e.g., "8", "72").
-}

-- Code from 
-- Chapter 12 of Programming in Haskell,
-- Graham Hutton, Cambridge University Press, 2016.
-- Tree relabelling example 

-- The state monad (Note: State data type defined below)

newtype ST a = S (State -> (a,State))

app :: ST a -> State -> (a,State)
app (S st) x = st x

instance Functor ST where
   -- fmap :: (a -> b) -> ST a -> ST b
   fmap g st = S (\s -> let (x,s') = app st s in (g x, s'))

instance Applicative ST where
   -- pure :: a -> ST a
   pure x = S (\s -> (x,s))

   -- (<*>) :: ST (a -> b) -> ST a -> ST b
   stf <*> stx = S (\s ->
      let (f,s')  = app stf s
          (x,s'') = app stx s' in (f x, s''))

instance Monad ST where
   -- (>>=) :: ST a -> (a -> ST b) -> ST b
   st >>= f = S (\s -> let (x,s') = app st s in app (f x) s')



-- my own data types and functions

-- State is either a token stream (list of Strings) indicated by Tkn
-- or an error indicated by Err. State transformers should do
-- nothing if they encounter an error state

data State = Tkn [String]          -- good token stream
           | Err [String] String   -- syntax error with error msg
           deriving Show


-- produce next token in stream, update State
--
nextToken :: ST String
nextToken = S g where 
                g (Tkn (tk:tks)) = (tk, Tkn tks)
                g (Tkn []) = ("", Tkn [])
                g (Err tks msg) = ("", Err tks msg)


-- produce next token in stream, keep State unchanged
--
lookAhead :: ST String
lookAhead = S g where 
                g (Tkn (tk:tks)) = (tk, Tkn (tk:tks) )
                g (Tkn []) = ("", Tkn [])
                g (Err tks msg) = ("", Err tks msg)


-- actually identical to nextToken, but intended to be used 
-- without binding to indicate that the next token is skipped
-- over. Likely used in conjunction with lookAhead.
--
eatToken :: ST () 
eatToken = S g where 
               g (Tkn (tk:tks)) = ((), Tkn tks)
               g (Tkn []) = ((), Tkn [])
               g (Err tks msg) = ((), Err tks msg)


-- the next token must be the indicated string value.
-- if not, enter error State
--
expect :: String -> ST ()
expect str = S g where
               g (Tkn (tk:tks)) = if (tk == str) then ((), Tkn tks) 
                                else ((), Err (tk:tks) ("expecting a " ++ str))
               g (Tkn []) = ((), Err [] ("EOF encountered while expecting a " ++ str) )
               g (Err tks msg) = ((), Err tks msg)


-- my own expression trees

data ETree = Nada
           | Value Int 
           | Plus   ETree ETree 
           | Times  ETree ETree 
           | Minus  ETree ETree
           | Divide ETree ETree
           deriving Show


-- enter error State with given error message
--
errorETree :: String -> ST ETree
errorETree str = S g where
                  g (Tkn tks) = (Nada, Err tks str)
                  g (Err tks msg) = (Nada, Err tks msg)


-- parse: factor -> const | ( expr )
--
factor :: ST ETree
factor = do

   tk <- nextToken

   if tk == "(" then do
      tree <- expr
      expect ")"
      return tree

   else do
      case (readMaybe tk :: Maybe Int) of
         Nothing -> errorETree ("'"++ tk ++ "' is not a number")
         Just n  -> return (Value n)


-- parse: term -> factor | factor * term | factor / term
--
term :: ST ETree
term = do

   tree1 <- factor
   tk <- lookAhead

   case tk of
      "*" -> do
         eatToken 
         tree2 <- term
         return (Times tree1 tree2)

      "/" -> do
         eatToken 
         tree2 <- term
         return (Divide tree1 tree2)

      _ -> return tree1


-- parse: expr -> term | term + expr | term - expr
--
expr :: ST ETree
expr = do

   tree1 <- term 
   tk <- lookAhead

   case tk of
      "+" -> do
         eatToken 
         tree2 <- expr
         return (Plus tree1 tree2)

      "-" -> do
         eatToken 
         tree2 <- expr
         return (Minus tree1 tree2)

      _ -> return tree1


-- Main program does the I/O
--
main = do

   putStrLn "Enter an expression: (separate with spaces)"
   input <- getLine
   putStrLn ""

   let (tree, state) = app expr (Tkn (words input)) in
      case state of

         Tkn [] -> do
            putStrLn "Syntactically correct expression:"
            putStrLn (show tree)

         Tkn tks -> do
            putStrLn "Parsed a prefix:"
            putStrLn (show tree)
            putStr   "Remaining input: "
            putStrLn (unwords tks)

         Err tks msg -> do
            putStrLn ("Error encontered:" ++ msg)
            putStr   "Remaining input: "
            putStrLn (unwords tks)
            putStr   "Parsed input: "
            putStrLn (show tree)