----------------------------------------------------------------------
-- Parsing arithmetic expressions using monadic parser combinators  --
----------------------------------------------------------------------

module Monadic_AE_Parser where

import Char
import Monad

-- a = Tokentyp, b= Ergebnistyp
newtype Parser a b = P ([a] -> [(b,[a])])

instance Monad (Parser a ) where
    return = result
    (>>=)  = bind
    fail _ = zero

-- basic parsers

result       :: b -> Parser a b
result x     = P (\s -> [(x,s)])

zero         :: Parser a b
zero         = P $ \_ -> []

item         :: Parser a a
item        = P $ \l -> case l of
	                  []      -> []
			  (a:as)  -> [(a,as)]


bind         :: Parser a b -> (b-> Parser a c) -> Parser a c
bind (P p) f     = P $ \s -> concat [q inp | (v,inp) <- p s, let P q = f v ]


instance MonadPlus (Parser a) where
    mzero = zero
    mplus = plus

plus         :: Parser a b -> Parser a b -> Parser a b
plus (P p) (P q)  = P $ \s -> p s ++ q s

infixr 4 ||| 
(|||) :: Parser a b -> Parser a b -> Parser a b
(|||) = mplus

checkChar         :: Char -> Parser Char Char
checkChar c = P $ \ cs -> case cs of 
                            []     -> []
                            (a:as) -> if c == a then [(c,as)] else []


tok          :: Eq a => [a] -> Parser a [a]
tok s       = P $ \cs -> loop s cs
                where loop []     cs            = [(s,cs)]
                      loop (s:ss) (c:cs) | s==c = loop ss cs
                      loop _      _             = []

----------------------------------------------------------
-- Translation of Grammar Rules into Parser Functions   --
----------------------------------------------------------
{-
-- E -> TH 
expr :: Parser Char [Int]
expr = term                 >>= \lt -> 
       hexpr                >>= \le ->
       return (1:lt++le)

-- H -> +TH | eps 
hexpr = (checkChar '+'        >>= \c -> 
         term                 >>= \lt -> 
         hexpr                >>= \le ->
         result (2:lt++le)) ||| result [3]

-- T -> FG
term = factor               >>= \lf -> 
       hterm                >>= \lt ->
       result (4:lf++lt)


-- G -> *FG | eps
hterm =  (checkChar '*'       >>= \c -> 
         factor               >>= \lf -> 
         hterm                >>= \lt ->
         result (5:lf++lt)) ||| result [6]
-- F -> (E) | a 
factor =   (checkChar '(' >>= \c -> 
           expr           >>= \le -> 
           checkChar ')' >>= \c ->
           result (7:le)) ||| (checkChar 'a' >>= \ c -> result [8])
-}
parseRD :: String -> [Int]
parseRD s = let (P parse_expr) = expr 
            in  case parse_expr s of
                  ((l,""):xs) -> l
                  _ -> error "syntax error in expression"

----------------------------------------------------------
-- Parser Functions Using do notation   --
----------------------------------------------------------

-- E -> TH 
expr :: Parser Char [Int]
expr = do lt <- term                  
          le <- hexpr                
          return (1:lt++le)

-- H -> +TH | eps 
hexpr = (do c  <- checkChar '+'  
            lt <- term 
            le <- hexpr  
            return (2:lt++le))
        |||    
        return [3]

-- T -> FG
term = do lf <- factor  
          lt <- hterm 
          return (4:lf++lt)


-- G -> *FG | eps
hterm =  (do c  <- checkChar '*'
             lf <- factor                
             lt <- hterm                
             return (5:lf++lt)) ||| return [6]
            
-- F -> (E) | a 
factor =   (do c  <- checkChar '('  
               le <- expr            
               c  <- checkChar ')' 
               return (7:le)) ||| 
           (do c <- checkChar 'a' 
               return [8])


----------------------------------------------------------
-- Parser Functions producing abstract syntax tree
----------------------------------------------------------

data Expr = Plus Expr Expr | Mult Expr Expr | Factor
            | Empty 
            deriving Show
           
empty :: Expr -> Bool           
empty Empty = True
empty _     = False 


-- E -> TH 
expr3 :: Parser Char Expr
expr3 = do lt <- term3                  
           le <- hexpr3                
           return (if empty le then lt else Plus lt le)

-- H -> +TH | eps 
hexpr3 = (do c  <- checkChar '+'  
             lt <- term3 
             le <- hexpr3  
             return (if empty le then lt else Plus lt le))
        |||    
        return Empty

-- T -> FG
term3 = do lf <- factor3  
           lt <- hterm3 
           return (if empty lt then lf else Mult lf lt)


-- G -> *FG | eps
hterm3 =  (do c  <- checkChar '*'
              lf <- factor3                
              lt <- hterm3               
              return (if empty lt then lf else Mult lf lt)) 
              ||| return Empty
            
-- F -> (E) | a 
factor3 =   (do c  <- checkChar '('  
                le <- expr3            
                c  <- checkChar ')' 
                return le) ||| 
            (do c <- checkChar 'a' 
                return Factor)

parseRD3 :: String -> Expr
parseRD3 s = let (P parse_expr) = expr3 
             in  case parse_expr s of
                   ((l,""):xs) -> l
                   _ -> error "syntax error in expression"