import List
import Monad
import Char
import Lang

-- parser jako monada

data Parser a = P {unP :: String -> [(a, String)]}

instance Monad Parser where
  P p >>= f = P (\s -> concatMap appf (p s))
    where
      appf (a, rest) = unP (f a) rest
  return x = P (\s -> [(x, s)])
  fail _ = P (\_ -> [])

instance MonadPlus Parser where
  P p `mplus` P q = P (\s -> p s ++ q s)
  mzero = P (\_ -> [])

-- primitivni parsery

item::Parser Char
item = P item'
  where
   item' [] = []
   item' (h:t) = [(h,t)]

eof::Parser Bool
eof = P eof'
  where
   eof' [] = [(True,[])]
   eof' s = [(False,s)]

peek::Parser Char
peek = P peek'
  where
   peek' [] = []
   peek' (h : t) = [(h,(h:t))]

-- spusteni parsovani

parse::Parser a -> String -> [(a, String)]
parse = unP

-- odvozene parsery

seq::Parser a -> Parser b -> Parser (a,b)
seq pa pb = 
  do
    a <- pa
    b <- pb
    return (a,b)

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

char::Char -> Parser Char
char c = sat (== c)

digit::Parser Char
digit = sat isDigit

-- liftM2::(a->b->c)->ma->mb->mc

many::Parser a -> Parser [a]
many p = liftM2 (:) p (many p) `mplus` return []

many1::Parser a->Parser [a]
many1 p = liftM2 (:) p (many p)

word::Parser String
word = many (sat isAlpha)

number::Parser Integer
number =
  do
    w <- many1 (sat isDigit)
    return (read w)

ident :: Parser String
ident =
  do
    h <- sat isAlpha
    w <- many (sat isAlphaNum)
    return (h:w)

addOp :: Parser (Expr->Expr->Expr)
addOp = (char '+' >> return Plus) `mplus` (char '-' >> return Minus)

mulOp :: Parser (Expr->Expr->Expr)
mulOp = (char '*' >> return Mul) `mplus` (char '/' >> return Div)

-- parser pro klauzuli typu
-- res = res neco1 | neco2

leftRec::(a->Parser a)->Parser a->Parser a
leftRec neco1 neco2 = neco2 >>= neco1'
  where
    neco1' val = (neco1 val >>= neco1') `mplus` return val

expr::Parser Expr
expr = leftRec addMulExpr mulExpr
  where
    addMulExpr x =
      do
        op <- addOp
        y <- mulExpr
        return (op x y)

mulExpr::Parser Expr
mulExpr = leftRec mulTerm term
  where
    mulTerm x =
      do
        op <- mulOp
        y <- term
        return (op x y)

term = (ident >>= return . Var) `mplus` (number >>= return . Num) `mplus`
  do
    char '('
    x <- expr
    char ')'
    return x

-- parse word ("a")
-- [("a",""),("","a")]

-- head $ fst $ head $ parse word ("a" ++ [undefined])
-- *** Exception: Prelude.undefined
-- proc (s linym vyhodnocovanim)?

-- head $ fst $ head $ parse word ("a" ++ [undefined])
-- *** Exception: Prelude.undefined
-- null $ parse word ("a" ++ [undefined])
-- *** Exception: Prelude.undefined
-- proc (s linym vyhodnocovanim)?

force::Parser a->Parser a
force (P f) = P f'
  where
    f' s = let r = f s in (fst(head r), snd(head r)):tail r

forcedMany::Parser a -> Parser [a]
forcedMany p = force (liftM2 (:) p (forcedMany p) `mplus` return [])

lazyWord::Parser String
lazyWord = forcedMany (sat isAlpha)

-- head $ fst $ head $ parse lazyWord ("a" ++ [undefined])
-- 'a'

-- omezeni backtrackovani:

first::Parser a->Parser a
first (P f) = P f'
  where
    f' s = case f s of
            [] -> []
            (h:_) -> [h]

try::Parser a->Parser a->Parser a
try (P f1) (P f2) = P f
  where
    f s = case f1 s of
            [] -> f2 s
            r -> r