module Codec.MIME.String.Internal.ABNF
      (Parser, apply, parse,
       pPred, pSucceed, pFail, pEOI, (<*>), (<|>), (<| ), (<!>), nested_parse,
       pChar, pString, (<$>), (<$ ), (<* ), ( |>),
       pMany, pAtLeast, pAtMost, pExactly, pFromTo, pOptDef, pMaybe
      ) where

import Data.Word

newtype Parser inp res = Parser ([(inp, Pos)] -> ParseResult inp res)

data ParseResult inp res = Success res [(inp, Pos)] !Pos
                         | Fail !Pos

type Line = Integer
type Column = Integer
data Pos = Pos !Line !Column
         | EOI
    deriving (Eq, Ord)

get_pos :: [(a, Pos)] -> Pos
get_pos [] = EOI
get_pos ((_, p):_) = p

show_pos :: Pos -> String
show_pos EOI = "End of input"
show_pos (Pos l c) = "Line " ++ show l ++ ", column " ++ show c

infixl 6 <$>, <$, <*>, <*
infixr 3 <|>, <|, |>

posify :: String -> [(Char, Pos)]
posify = f 1 1
    where f _ _ []        = []
          f l c ('\n':xs) = ('\n', Pos l c):f (l+1) 1     xs
          f l c (x   :xs) = (x,    Pos l c):f l     (c+1) xs

apply :: Parser Char a -> String -> Either (a, String) String
apply (Parser p) xs
 = case p $ posify xs of
       Success res ys _ -> Left (res, map fst ys)
       Fail pos -> Right ("Error: Failed at " ++ show_pos pos)

parse :: Parser Char a -> String -> Either a String
parse (Parser p) xs
 = case p $ posify xs of
       Success res [] _ -> Left res
       Success _ ((_, pos):_) _ ->
           Right ("Error: Only consumed up to " ++ show_pos pos)
       Fail pos ->
           Right ("Error: Failed at " ++ show_pos pos)

-- Primitive combinators

pPred :: (inp -> Bool) -> Parser inp inp
pPred p = Parser
        $ \inp -> case inp of
                      ((x, pos):inp')
                       | p x -> Success x inp' pos
                      _ -> Fail (get_pos inp)

pSucceed :: res -> Parser a res
pSucceed x = Parser $ \inp -> Success x inp (get_pos inp)

pFail :: Parser a res
pFail = Parser $ \inp -> Fail (get_pos inp)

pEOI :: Parser a ()
pEOI = Parser $ \inp -> case inp of
                            [] -> Success () [] EOI
                            _ -> Fail (get_pos inp)

(<*>) :: Parser inp (a -> b) -> Parser inp a -> Parser inp b
Parser p <*> Parser q = Parser $ \inp ->
                        case p inp of
                            Fail pos -> Fail pos
                            Success f inp' pos ->
                                case q inp' of
                                    Fail pos' -> Fail (pos `max` pos')
                                    Success x inp'' pos' ->
                                        Success (f x) inp'' (pos `max` pos')

(<|>) :: Parser inp a -> Parser inp a -> Parser inp a
Parser p <|> Parser q = Parser $ \inp ->
                        case (p inp, q inp) of
                            (Fail posp, Fail posq) -> Fail (posp `max` posq)
                            (Fail posp, Success x inp' posq) ->
                                Success x inp' (posp `max` posq)
                            (Success x inp' posp, Fail posq) ->
                                Success x inp' (posp `max` posq)
                            (rp@(Success _ _ posp), rq@(Success _ _ posq))
                                -> if posp >= posq then rp else rq

(<| ) :: Parser inp a -> Parser inp a -> Parser inp a
Parser p <|  Parser q = Parser $ \inp ->
                        case p inp of
                            Fail posp ->
                                case q inp of
                                    Fail posq -> Fail (posp `max` posq)
                                    Success x inp' posq ->
                                        Success x inp' (posp `max` posq)
                            s -> s

(<!>) :: Parser inp a -> Parser inp b -> Parser inp a
Parser p <!> Parser q = Parser $ \inp -> case q inp of
                                             Fail _ ->
                                                 p inp
                                             Success _ _ pos -> Fail pos

check_fails_empty :: Parser inp a -> ()
check_fails_empty (Parser p) = case p [] of
                                   Fail _ -> ()
                                   _ -> error "check_fails_empty failed"

nested_parse :: Parser Char String -> Parser Char a -> Parser Char a
nested_parse (Parser p1) (Parser p2)
 = Parser
 $ \inp -> case p1 inp of
               Fail pos -> Fail pos
               Success inp' rem_inp pos ->
                   case p2 $ posify inp' of
                       Fail pos' -> Fail (pos `max` pos')
                       Success x [] pos' -> Success x rem_inp (pos `max` pos')
                       Success _ _ pos' -> Fail (pos `max` pos')

-- Derived combinators

pChar :: Char -> Parser Char Char
pChar c = pPred (c ==)

pString :: String -> Parser Char String
pString "" = pSucceed ""
pString (c:cs) = (:) <$> pChar c <*> pString cs

(<$>) :: (a -> b) -> Parser inp a -> Parser inp b
x <$> q = pSucceed x <*> q

(<$ ) :: a -> Parser inp b -> Parser inp a
x <$  q = pSucceed x <*  q

(<* ) :: Parser inp a -> Parser inp b -> Parser inp a
p <*  q = (\x _ -> x) <$> p <*> q

( |>) :: Parser inp a -> Parser inp a -> Parser inp a
p  |> q = q <|  p

pMany :: Parser inp a -> Parser inp [a]
pMany p = check_fails_empty p `seq` ((:) <$> p <*> pMany p) <|  pSucceed []

pAtLeast :: Word -> Parser inp a -> Parser inp [a]
pAtLeast 0 p = pMany p
pAtLeast n p = ((:) <$> p <*> pAtLeast (n-1) p)

pAtMost :: Word -> Parser inp a -> Parser inp [a]
pAtMost 0 _ = pSucceed []
pAtMost n p = ((:) <$> p <*> pAtMost (n-1) p) <|  pSucceed []

pExactly :: Word -> Parser inp a -> Parser inp [a]
pExactly 0 _ = pSucceed []
pExactly n p = ((:) <$> p <*> pExactly (n-1) p)

pFromTo :: Word -> Word -> Parser inp a -> Parser inp [a]
pFromTo 0 t p = pAtMost t p
pFromTo _ 0 _ = error "Codec.MIME.String.Internal.ABNF.pFromTo: Bad arguments"
pFromTo f t p = ((:) <$> p <*> pFromTo (f-1) (t-1) p)

pOptDef :: a -> Parser inp a -> Parser inp a
pOptDef x p = p <|  pSucceed x

pMaybe :: Parser inp a -> Parser inp (Maybe a)
pMaybe p = Just <$> p <|  pSucceed Nothing