module FailParser where

infixl 2 `opt`
infixl 3 <!|>, <|!>
infixl 4 <$>, <$, <*>, *>, <*, <**>, <??>, <->>

newtype Parser a = P (String -> Pos -> Result a)

data Result a = Result a String Pos | Error String
 deriving Show

type Pos = (Int,Int)

nextPos :: Char -> Pos -> Pos
nextPos '\n' (l,c) = (l+1,0)
nextPos _    (l,c) = (l,c+1)

message :: String -> Pos -> String
message msg (l,c) = msg ++ " in line " ++ show l ++ " at column " ++ show c

errMsg :: String -> Pos -> Result a
errMsg = (Error.).message

unexpected c = errMsg $ "unexpected symbol '" ++ [c] ++ "'"

instance Monad Parser where
  return = pSucceed
  fail s = pFail (message s)
  (>>=)  = (<->>)

parse :: Parser a -> String -> Result a
parse (P p) s = p s (0,0)


pSucceed :: a -> Parser a
pSucceed v = P (Result v)

pFail :: (Pos -> String) -> Parser a
pFail msg = P (\_ pos -> Error (msg pos))

pPred :: (Char -> Bool) -> Parser Char
pPred pred = P p
 where
  p [] pos = errMsg "insufficient input" pos
  p (t:ts) pos
    | pred t    = Result t ts (nextPos t pos)
    | otherwise = unexpected t pos

pSym :: Char -> Parser Char
pSym t = pPred (t==)

pAnyOf :: String -> Parser Char
pAnyOf = foldr (<|!>) (pFail (message "unexpected symbol")) . map pSym

opt :: Parser a -> a -> Parser a
p `opt` x = p <|!> pSucceed x

(<!|>) :: Parser a -> Parser a -> Parser a
P p <!|> P q
  = P (\ts pos -> case p ts pos of
                    res@(Result _ _ _) -> res
                    err@(Error _) -> case q ts pos of
                      res@(Result _ _ _) -> res
                      Error _ -> err) 

(<|!>) :: Parser a -> Parser a -> Parser a
P p <|!> P q
  = P (\ts pos -> case p ts pos of
                    res@(Result _ _ _) -> res
                    Error _ -> q ts pos) 

(<*>) :: Parser (a -> b) -> Parser a -> Parser b
P p <*> P q
  = P (\ts pos -> case p ts pos of
                    Result f ts1 pos1 -> case q ts1 pos1 of
                      Result x ts2 pos2 -> Result (f x) ts2 pos2
                      Error msg -> Error msg
                    Error msg -> Error msg)

(<$>) :: (a -> b) -> Parser a -> Parser b
f <$> p = pSucceed f <*> p

(<$) :: a -> Parser b -> Parser a
f <$ p = const f <$> p

(*>) :: Parser a -> Parser b -> Parser b
p *> q = const id <$> p <*> q

(<*) :: Parser a -> Parser b -> Parser a
p <* q = flip (const id) <$> p <*> q

(<**>) :: Parser a -> Parser (a -> b) -> Parser b
p <**> q = flip ($) <$> p <*> q

(<??>) :: Parser a -> Parser (a -> a) -> Parser a
p <??> q = p <**> (q `opt` id)

pFoldr :: (a -> b -> b) -> b -> Parser a -> Parser b
pFoldr op e p = q where q = (op <$> p <*> q) `opt` e

pFoldrSep :: (a -> b -> b) -> b -> Parser c -> Parser a -> Parser b
pFoldrSep op e sep p = (op <$> p <*> pFoldr op e (sep *> p)) `opt` e

pList :: Parser a -> Parser [a]
pList = pFoldr (:) []

pListSep :: Parser a -> Parser b -> Parser [b]
pListSep = pFoldrSep (:) []

pSome :: Parser a -> Parser [a]
pSome p = (:) <$> p <*> pList p

(<->>) :: Parser a -> (a -> Parser b) -> Parser b
P p <->> f
  = P (\ts pos -> case p ts pos of
                    Result x ts' pos' -> let P q = f x in q ts' pos'
                    Error msg -> Error msg)

check :: (a -> Bool) -> Parser a -> Parser a
check pred (P p)
  = P (\ts pos -> case p ts pos of
                    res@(Result x _ _) -> if pred x then res
                                           else errMsg "check failed" pos
                    err@(Error _) -> err)