{----

Basic monadic parser combinators which include information for offside
rule parsing.

----}

module MonParserOff where

import Control.Monad.State
import Control.Monad.Reader

type Pos = (Int, Int)
type PString = (Pos, String)

type Parser a = ReaderT Pos (StateT PString []) a

runParser p s = runStateT (runReaderT p (0, 0)) ((0, 0),s)

item :: Parser Char
item = do 
    st@(pos,x:xs) <- get 
    defpos <- ask
    put $ newstate st 
    if onside pos defpos then return x else mzero

onside :: Pos -> Pos -> Bool
onside (l, c) (dl, dc) = (c > dc) || (l == dl)

newstate :: PString -> PString
newstate ((l,c), x:xs) = (newpos x, xs) where
    newpos '\n' = (l+1, 0)
    newpos _ = (l, c+1)


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

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

string :: String -> Parser String
string "" = return ""
string (x:xs) = do char x; string xs; return $ x:xs

digit :: Parser Char
digit = sat (\x -> '0' <= x && x <= '9')

lower :: Parser Char
lower = sat (\x -> 'a' <= x && x <= 'z')

upper :: Parser Char
upper = sat (\x -> 'A' <= x && x <= 'Z')

letter :: Parser Char
letter = lower `mplus` upper

alphanum :: Parser Char
alphanum = letter `mplus` digit

many :: Parser a -> Parser [a]
many p = more `mplus` (return []) where
    more = do x <- p; xs <- many p; return $ x:xs

ident :: Parser String
ident = do
    x <- letter
    xs <- many alphanum
    return $ x:xs

many1 :: Parser a -> Parser [a]
many1 p = do
    x <- p
    xs <- many p
    return $ x:xs

{-
nat :: Parser Int
nat = do
    x <- many1 digit
    return $ eval x
  where
    eval l = foldl op 0 l
    x `op` y = (fromEnum y - fromEnum '0') + 10*x
-}

int :: Parser Int
int = do
    op <- (do char '-'; return negate) `mplus` (return id)
    x <- nat
    return $ op x


sepby1 :: Parser a -> Parser b -> Parser [a]
p `sepby1` sep = do
    x <- p
    xs <- many (do sep; p)
    return $ x:xs

bracket :: Parser a -> Parser b -> Parser c -> Parser b
bracket open p close = do open; x <- p; close; return x

ints :: Parser [Int]
ints = bracket (char '[') (int `sepby1` (char ',')) (char ']')

sepby :: Parser a -> Parser b -> Parser [a]
p `sepby` sep = (p `sepby1` sep) `mplus` (return [])

list :: Parser a -> Parser [a]
list p = bracket (char '[') (p `sepby` (char ',')) (char ']')


chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a
p `chainl1` op = do
    x <- p 
    rest x
  where
    rest x = do (doop x) `mplus` (return x)
    doop x = do f <- op; y <- p; rest $ f x y

chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
chainl p op v = (p `chainl1` op) `mplus` (return v)

--
-- sepby1 in terms of chainl1
--
sepby1' p sep = chainl1 (do x <- p; return [x])  (do sep; return (++))
sepby' p sep = (p `sepby1'` sep) `mplus` (return [])
list' p = bracket (char '[') (p `sepby'` (char ',')) (char ']')

nat = getNat `chainl1` (return $ \x y -> 10*x + y) where
    getNat = do x <- digit; return $ toInt x
    toInt x = fromEnum x - fromEnum '0'


chainr1 :: Parser a -> Parser (a -> a -> a) -> Parser a
p `chainr1` op = do
    x <- p
    rest x
  where
    rest x = do (doop x) `mplus` (return x)
    doop x = do f <- op; y <- p `chainr1` op; return $ f x y

chainr :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
chainr p op v = (p `chainr1` op) `mplus` (return v)


--
-- Better Laziness
--
force :: Parser a -> Parser a
force p = ReaderT $ \env -> StateT $ \inp -> let x = runStateT (runReaderT p env) inp in
    (fst (head x), snd (head x)) : tail x

many' :: Parser a -> Parser [a]
many' p = force $ more `mplus` (return []) where
    more = do x <- p; xs <- many' p; return $ x:xs

many1' :: Parser a -> Parser [a]
many1' p = do
    x <- p
    xs <- many' p
    return $ x:xs

--
-- Removing Space Leak
--
first :: Parser a -> Parser a
first p = ReaderT $ \env-> StateT $ \inp -> case runStateT (runReaderT p env) inp of
    [] -> []
    (x:_) -> return x

(+++) :: Parser a -> Parser a -> Parser a
p +++ q = first $ p `mplus` q