{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.Lib.Parsec where

import           Control.Monad.Trans.State (StateT(..), get, put)
-- import           Control.Monad.Trans.Class (lift, MonadTrans(..))
import qualified Data.Char
import           Data.Functor.Identity (Identity(..))
import qualified Data.List
import qualified Text.Parsec as R hiding (satisfy, string, char, space, newline, crlf)
import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
import qualified Text.Parsec.Pos as R
import           Control.Monad.Trans.Class (lift)

-- * Combinators

-- | Like 'Text.Parsec.choice' but with 'Text.Parsec.try' on each case.
choice_try :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a
choice_try = Data.List.foldr (\a -> (<|>) (R.try a)) R.parserZero
-- choice_try = R.choice . Data.List.map R.try

-- | Like 'Text.Parsec.sepBy' but without parsing an ending separator.
many_separated
 :: Stream s m t
 => ParsecT s u m a
 -> ParsecT s u m b
 -> ParsecT s u m [a]
many_separated p sep =
	many1_separated p sep <|> return []

-- | Like 'Text.Parsec.sepBy1' but without parsing an ending separator.
many1_separated
 :: Stream s m t
 => ParsecT s u m a
 -> ParsecT s u m b
 -> ParsecT s u m [a]
many1_separated p sep = do
	x <- p
	xs <- R.many (R.try (sep >> p))
	return $ x:xs
-- (:) <$> p <*> R.many (R.try (sep >> p))

-- | Make a 'Text.Parsec.ParsecT' also return its user state.
and_state
 :: Stream s m t
 => ParsecT s u m a
 -> ParsecT s u m (a, u)
and_state p = do
	a <- p
	s <- R.getState
	return (a, s)

-- ** Fixed 'R.satisfy'

-- | Like 'R.updatePosChar' but without '\t' being special.
updatePosChar :: R.SourcePos -> Char -> R.SourcePos
updatePosChar pos c =
	case c of
	 '\n' -> R.newPos (R.sourceName pos) (R.sourceLine pos + 1) 1
	 _    -> R.newPos (R.sourceName pos) (R.sourceLine pos) (R.sourceColumn pos + 1)

-- | Like 'R.updatePosString' but using fixed 'updatePosChar'.
updatePosString :: R.SourcePos -> String -> R.SourcePos
updatePosString pos s = foldl updatePosChar pos s

-- | Like 'R.updatePosChar' but using fixed 'updatePosChar'.
satisfy :: (Stream s m Char) => (Char -> Bool) -> ParsecT s u m Char
satisfy f = R.tokenPrim (\c -> show [c])
                        (\pos c _cs -> updatePosChar pos c)
                        (\c -> if f c then Just c else Nothing)

-- | Like 'R.string' but using fixed 'updatePosString'.
string :: (Stream s m Char) => String -> ParsecT s u m String
string s = R.tokens show updatePosString s

-- | Like 'R.char' but using fixed 'satisfy'.
char :: (Stream s m Char) => Char -> ParsecT s u m Char
char c = satisfy (==c)  <?> show [c]

-- | Like 'R.anyChar' but using fixed 'satisfy'.
anyChar :: (Stream s m Char) => ParsecT s u m Char
anyChar = satisfy (const True)

-- | Like 'R.oneOf' but using fixed 'satisfy'.
oneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
oneOf cs = satisfy (\c -> elem c cs)

-- | Like 'R.noneOf' but using fixed 'satisfy'.
noneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
noneOf cs = satisfy (\c -> not (elem c cs))

-- ** Custom 'ParsecT' errors

-- | Use the 'StateT' monad transformer
--   to attach custom errors to the 'ParsecT' monad.
--
-- NOTE: this is a poor man's hack to overcome 'Parsec'’s limitation.
type Error_State e = StateT (R.SourcePos, [Error e])
data Error e
 =   Error_Parser R.ParseError -- ^ 'Error' raised by 'R.fail'.
 |   Error_Custom R.SourcePos e -- ^ 'Error' raised by 'fail_with'.
 |   Error_At     R.SourcePos [Error e] -- ^ 'Error' raised by 'runParserT_with_Error_fail'.
 deriving (Show)

instance Functor Error where
	fmap _ (Error_Parser e)     = Error_Parser e
	fmap f (Error_Custom pos e) = Error_Custom pos (f e)
	fmap f (Error_At pos es)    = Error_At pos $ map (fmap f) es

-- | Like 'R.parserFail'
--   but fail with given custom error.
fail_with :: (Stream s (Error_State e m) Char, Monad m)
 => String -> e -> ParsecT s u (Error_State e m) r
fail_with msg err = do
	(sp, se) <- lift get
	rp <- R.getPosition -- NOTE: reported position
	_ <- ((R.anyChar >> return ()) <|> R.eof)
	 -- NOTE: somehow commits that this character has an error
	p <- R.getPosition -- NOTE: compared position
	case () of
	 _ | R.sourceLine   p  > R.sourceLine   sp ||
	    (R.sourceLine   p == R.sourceLine   sp &&
	     R.sourceColumn p  > R.sourceColumn sp)
	   -> lift $ put (p, Error_Custom rp err:[])
	 _ | R.sourceLine   p == R.sourceLine   sp &&
	     R.sourceColumn p == R.sourceColumn sp
	   -> lift $ put (p, Error_Custom rp err:se)
	 _ -> return ()
	R.parserFail msg

-- | Like 'R.runParserT' but return as error an 'Error' list
runParserT_with_Error
 :: (Stream s (Error_State e m) Char, Monad m, Show r, Show e)
 => ParsecT s u (Error_State e m) r
 -> u -> R.SourceName -> s
 -> m (Either [Error e] r)
runParserT_with_Error p u sn s = do
	(r, (sp, se)) <- runStateT
	 (R.runParserT p u sn s)
	 (R.initialPos sn, [])
	case r of
	 Left pe | R.sourceLine   (R.errorPos pe)  < R.sourceLine   sp ||
	          (R.sourceLine   (R.errorPos pe) == R.sourceLine   sp &&
	           R.sourceColumn (R.errorPos pe)  < R.sourceColumn sp)
	         -> return $ Left $ se -- NOTE: custom errors detected at a greater position
	 Left pe | R.sourceLine   (R.errorPos pe) == R.sourceLine   sp &&
	           R.sourceColumn (R.errorPos pe) == R.sourceColumn sp
	         -> return $ Left $ se -- NOTE: prefer custom errors
	 Left pe -> return $ Left $ Error_Parser pe:[]
	 Right x -> return $ Right x

-- | Like 'R.runParserT_with_Error'
--   but applied on the 'Identity' monad.
runParser_with_Error
 :: (Stream s (Error_State e Identity) Char, Show r, Show e)
 => ParsecT s u (Error_State e Identity) r
 -> u -> R.SourceName -> s
 -> Either [Error e] r
runParser_with_Error p u sn s =
	runIdentity $
	runParserT_with_Error p u sn s

-- | Like 'R.runParserT_with_Error'
--   but propagate any failure to a calling 'ParsecT' monad.
runParserT_with_Error_fail ::
 ( Stream s1 (Error_State ee m) Char
 , Stream s (Error_State e (ParsecT s1 u1 (Error_State ee m))) Char
 , Monad m, Show r, Show e, Show ee )
 => String
 -> (Error e -> Error ee)
 -> ParsecT s u (Error_State e (ParsecT s1 u1 (Error_State ee m))) r
 -> u -> R.SourceName -> s
 -> ParsecT s1 u1 (Error_State ee m) r
runParserT_with_Error_fail msg map_ko p u sn s = do
	r <- runParserT_with_Error p u sn s
	case r of
	 Right ok -> return ok
	 Left ko -> do
		rpos <- R.getPosition
		_ <- commit_position
		pos <- R.getPosition
		lift $ put (pos, Error_At rpos (map map_ko ko):[])
		fail msg
	where commit_position = (R.anyChar >> return ()) <|> R.eof

-- ** Mapping inner monad

-- | Like an instance Control.Functor.Morph.'MFunctor' of @R.ParsecT s u@
--   but also requiring a second 'Monad' constraint
--   on the returned base container.
--
-- NOTE: This code is not used by Hcompta, still is left here
-- because it was not trivial to write it,
-- so eventually it may help others.

hoist :: (Monad m, Monad n) => (forall a. m a -> n a) -> ParsecT s u m b -> ParsecT s u n b
hoist nat m = R.mkPT $ \s -> do
	c <- nat $ R.runParsecT m s
	return $ case c of
		 R.Consumed mrep -> R.Consumed $ nat mrep
		 R.Empty    mrep -> R.Empty    $ nat mrep

-- | Map the type of a 'StateT'.
--
-- NOTE: This code is not used by Hcompta, still is left here
-- because it was not trivial to write it,
-- so eventually it may help others.
smap :: Monad m => (s1 -> s0) -> (s0 -> s1) -> StateT s0 m a -> StateT s1 m a
smap s1_to_s0 s0_to_s1 st =
	StateT (\s1_begin -> do
		(a, s0_end) <- runStateT st (s1_to_s0 s1_begin)
		return (a, s0_to_s1 s0_end))

-- * Numbers

-- | Return the 'Integer' obtained by multiplying the given digits
--   with the power of the given base respective to their rank.
integer_of_digits
 :: Integer -- ^ Base.
 -> [Char]  -- ^ Digits (MUST be recognised by 'Data.Char.digitToInt').
 -> Integer
integer_of_digits base =
	Data.List.foldl (\x d ->
		base*x + toInteger (Data.Char.digitToInt d)) 0

decimal :: Stream s m Char => ParsecT s u m Integer
decimal = integer 10 R.digit
hexadecimal :: Stream s m Char => ParsecT s u m Integer
hexadecimal = R.oneOf "xX" >> integer 16 R.hexDigit
octal :: Stream s m Char => ParsecT s u m Integer
octal = R.oneOf "oO" >> integer 8 R.octDigit

-- | Parse an 'Integer'.
integer :: Stream s m t
        => Integer
        -> ParsecT s u m Char
        -> ParsecT s u m Integer
integer base digit = do
	digits <- R.many1 digit
	let n = integer_of_digits base digits
	seq n (return n)

-- * Whites

-- | Return 'True' if and only if the given 'Char' is an horizontal space.
is_space_horizontal :: Char -> Bool
is_space_horizontal c = c /= '\n' && c /= '\r' && Data.Char.isSpace c

-- | Like 'R.space' but using fixed 'satisfy'.
space :: Stream s m Char => ParsecT s u m Char
{-# INLINEABLE space #-}
space = satisfy Data.Char.isSpace <?> "space"

-- | Like 'R.spaces' but using fixed 'satisfy'.
spaces :: Stream s m Char => ParsecT s u m ()
{-# INLINEABLE spaces #-}
spaces = R.skipMany space <?> "spaces"

-- | Like 'R.tab' but using fixed 'satisfy'.
tab :: (Stream s m Char) => ParsecT s u m Char
{-# INLINEABLE tab #-}
tab = char '\t' <?> "tab"

-- | Parse only a 'Char' which passes 'satisfy' 'is_space_horizontal'.
space_horizontal :: Stream s m Char => ParsecT s u m Char
{-# INLINEABLE space_horizontal #-}
space_horizontal = satisfy is_space_horizontal <?> "horizontal-space"

new_line :: Stream s m Char => ParsecT s u m ()
{-# INLINEABLE new_line #-}
new_line = ((R.try (string "\r\n") <|> R.try (string "\n")) >> return ()) <?> "newline"