-- --------------------------------
-- Monadische Parser
-- Mathias Leonhardt, Thorben Gülck
-- --------------------------------

import Char

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

-- Funktion zur Anwendung eines Parsers auf eine Eingabe

apply :: Parser a -> String -> [(a, String)]
apply (MkParser p) input = p input

instance Monad Parser where

  return result = MkParser parser where 
    parser input = [(result, input)]

  p >>= qfunc = MkParser parser where
    parser input = 
      [(result2, rest2) |
       (result1, rest1) <- apply p input,
       (result2, rest2) <- apply (qfunc result1) rest1]

-- erstes Zeichen lesen und als Ergebnis 
-- zurueckgeben

item :: Parser Char
item = MkParser parser where
       parser [] = []
       parser (c:cs) = [(c,cs)]

-- Beispiele:

-- apply item ""
-- []

-- apply item "abc"
-- [('a',"bc")]

-- Verkettung mehrerer item-Parser
-- Lesen des 1. und 3. Zeichen einer Eingabe

read_1_3 :: Parser (Char, Char)
read_1_3 = do
           x <- item
           item -- verwerfen des zweiten Zeichens
           y <- item
           return (x, y)

-- Beispiele:

-- apply read_1_3 "abcdef"
-- [('a', 'c'), "def"]

-- apply read_1_3 "ab"
-- []

-- Neutrales Element bzgl. >>=: return

-- Nullelement bzgl. >>= (schlaegt immer fehl):

zero :: Parser a
zero = MkParser parser where
       parser input = []

-- Anwendungsbeispiel fuer item und zero:

sat :: (Char -> Bool) -> Parser Char
sat pred = do
           c <- item
           if pred c then return c else zero

-- Ueberlesen eines Zeichens
char :: Char -> Parser ()
char x = do
         sat (==x)
         return ()

-- Beispiele:

-- apply (char 'a') "abc"
-- [((), "bc")]

-- apply (char 'a') "def"
-- []

-- Ueberlesen einer Zeichenfolge
string :: String -> Parser ()
string [] = return ()
string (x:xs) = do
                char x
                string xs
                return ()

-- Beispiele:

-- apply (string "abc") "abcdef"
-- [((), "def")]

-- apply (string "abc") "aaadef"
-- []

lower :: Parser Char
lower = sat isLower

-- Beispiele:

-- apply lower "abc"
-- [('a', "bc")]

-- apply lower "Abc"
-- []

alphanum :: Parser Char
alphanum = sat isAlphaNum

-- upper, letter entsprechend

digit :: Parser Int
digit = do
        d <- sat isDigit
        return (ord d - ord '0')

-- Beispiel:

-- apply digit "123"
-- [(1, "23")]

-- apply digit "abc"
-- []

addition :: Parser Int
addition = do
           m <- digit
           char '+'
           n <- digit
           return (m + n)

plus :: Parser a -> Parser a -> Parser a
p `plus` q = MkParser parser where 
             parser input = apply p input ++ apply q input

-- plus bildet Monoid mit zero als neutralem Element
-- zero `plus` p = p
-- p `plus` zero = p
-- p `plus` (q `plus` r) = (p `plus` q) `plus` r

-- Weiterhin gilt das Distributivgesetz:
-- (p `plus` q) >>= r  = (p >>= r) `plus` (q >>= r)

lowers :: Parser String
lowers = (do
          c <- lower
          cs <- lowers
          return (c:cs)) `plus` return ""

-- lowers "isUpper"
-- [("is", "Upper"), ("i", "sUpper"), ("", "isUpper")]

-- deterministische Version einer Alternative
-- (falls p und q deterministisch):

orelse :: Parser a -> Parser a -> Parser a
p `orelse` q = MkParser parser where 
               parser input = case apply p input of
                              [] -> apply q input
                              res -> res

-- Vorsicht mit orelse!
-- Einfache arithmetische Ausdruecke: 1, 1+2
-- expr = digit `orelse` addition ?
-- expr = addition `orelse` digit ?
-- -> Faktorisieren!

-- 0..n
many :: Parser a -> Parser [a]
many parser = (do
               x <- parser
               xs <- many parser
               return (x:xs)) `orelse` return []

-- 1..n
some :: Parser a -> Parser [a]
some parser = do
              x <- parser
              xs <- many parser
              return (x:xs)

-- Beispiel: Bezeichner parsen
ident :: Parser String
ident = do
        c <- lower
        cs <- many alphanum
        return (c:cs)

-- Beispiel: Natuerliche Zahl parsen
nat :: Parser Int
nat = do
      digits <- some digit
      return (foldl1 (+) digits)
      where
      m + n = 10*m + n

-- Beispiel: Ganze Zahl parsen
int :: Parser Int
int = (do
       char '-'
       n <- nat
       return (-n)) `orelse` nat

-- Beispiel: Liste ganzer Zahlen wie: [1,2,3]
ints :: Parser [Int]
ints = do
       char '['
       n <- int
       ns <- many (do {char ','; int})
       char ']'
       return (n:ns)

-- Abstraktion: Wiederholung mit Trennzeichen
somewith :: Parser b -> Parser a -> Parser [a]
somewith q p = do
               x <- p
               xs <- many (do {q; p})
               return (x:xs)

-- Analog zu many:
manywith :: Parser b -> Parser a -> Parser [a]
manywith q p = somewith q p `orelse` return []

space :: Parser ()
space = do
        many (sat isSpace)
        return ()

token :: Parser a -> Parser a
token parser = do
               space
               x <- parser
               space
               return x

symbol :: String -> Parser ()
symbol xs = token (string xs)

-- apply (symbol "Hallo") "    Hallo     Welt"
-- apply (do {symbol "--"; many (alphanum `orelse` (sat isSpace))}) "   -- ein Kommentar"

parens  :: Parser ()
parens  = (do 
           char '('
           parens
           char ')'
           parens) `orelse` return ()

-- Beispiel für arithmetische Ausdruecke
           
expr :: Parser Int
expr =  do
        t <- term
        (do
         symbol "+"               
         e <- expr
         return (t+e)) `orelse` return t
         
term :: Parser Int
term =  do
        f <- factor
        (do
         symbol "*"
         t <- term
         return (f*t)) `orelse` return f
         
factor :: Parser Int
factor =  (do
           symbol "("
           e <- expr
           symbol ")"
           return e) `orelse` nat

eval :: String -> Int
eval input =  case (apply expr input) of
              [(n,[])]  -> n
              [(_,out)] -> error ("unused input " ++ out)
              []        -> error "invalid input"