{-# OPTIONS_GHC -fno-warn-noncanonical-monad-instances #-}

import Data.Char
import Data.Monoid
import Control.Applicative
import Control.Monad.Except

-- A type for parsing
type PState = String
newtype Parser a = Parser { runParser :: PState -> [(a, PState)] }

instance Functor Parser where
    fmap f p = p >>= return . f

instance Applicative Parser where
    pure = return
    f <*> p = f >>= \g-> (p >>= return . g)

instance Monad (Parser) where
    return a  = Parser $ \x -> [(a, x)]
    (Parser m) >>= k = Parser $ \x -> 
       [(b, z) | (a,y) <- m x, (b,z) <- (runParser $ k $ a) $ y]

-- A type for parse trees
data Term = Cons Int | Neg Term | Add Term Term
    deriving (Show)

-- Parsing an item
item :: Parser Char
item = Parser $ (\x-> case x of [] -> []; (a:y) -> [(a,y)])

-- Example: two items
twoItems :: Parser (Char, Char)
twoItems = do a <- item; b <- item; return (a,b)

-- Alternation
dummy :: Parser a
dummy = Parser $ \x -> []

(<+>) :: Parser a -> Parser a -> Parser a
m <+> n = Parser $ \x -> (runParser m) x ++ (runParser n) x

-- Laws:
-- dummy <+> m = m
-- m <+> dummy = m
-- m <+> (n <+> k) = (m <+> n) <+> k

-- Example: one or two
oneOrTwo :: Parser String
oneOrTwo =  (do x <- item; return [x])
  <+> (do x <- item; y <- item; return [x, y])

-- Filtering
(|>) :: Parser a -> (a -> Bool) -> Parser a
m |> p = do x <- m; if p x then return x else dummy
-- Laws:
-- dummy |> p = dummy
-- (m <+> n) |> p = (m |> p) <+> (n |> p)

letter :: Parser Char
letter = item |> isLetter

digit :: Parser Int
digit = do x <- (item |> isDigit); return (digitToInt x)

lit :: Char -> Parser Char
lit c = item |> (==c)

-- Iteration
iter :: Parser a -> Parser [a]
iter m = (do x <- m; xs <- iter m; return $ x : xs) <+> (return [])

-- Example: parsing numbers
number :: Parser Int
number = do x <- digit; xs <- iter digit; return $ asNumber $ x:xs
  where asNumber = foldl ((+).(*10)) 0

-- Biased choice
(<+) :: Parser a -> Parser a -> Parser a
(Parser f) <+ (Parser g) = Parser $ \x -> 
  let y = f x in if null y then g x else y

-- Iteration
riter :: Parser a -> Parser [a]
riter m = (do x <- m; xs <- riter m; return $ x : xs) <+ (return [])

-- Example: (runParser $ riter $ oneOrTwo ) "any"

maxnumber :: Parser Int
maxnumber = do x <- digit; xs <- riter digit; return $ asNumber $ x:xs
  where asNumber = foldl ((+).(*10)) 0

-- We now can parse terms according to grammar
-- term ::= number | '(' term ')' | term + term | -term

minterm :: Parser Term
minterm = (do x <- maxnumber; return $ Cons x)
    <+ (do lit '('; x <- term; lit ')'; return x)
    <+ (do lit '-'; x <- minterm; return $ Neg x)

term :: Parser Term
term = (do x <- minterm; lit '+'; y <- term; return $ Add x y)
    <+ minterm

-- Parser, throwing exceptions
type ExParser = ExceptT String Parser

exItem :: ExParser Char
exItem = lift $ item

exItem' :: ExParser Char
exItem' = ExceptT $ Parser $ (\x-> case x of
  [] -> [(Left $ "Could not parse", x)]; 
  (a:y) -> [(Right a,y)])

-- compare to
-- item :: Parser Char
-- item = Parser $ (\x-> case x of [] -> []; (a:y) -> [(a,y)])

-- example: runParser $ (runExceptT $ exItem')) ""