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

import           Control.Monad (void)
import           Control.Monad.Trans.Class (lift)
import           Control.Monad.Trans.State (StateT(..), get, put)
import           Data.Bool
import           Data.Char (Char)
import qualified Data.Char
import           Data.Either
import           Data.Eq (Eq(..))
import           Data.Foldable (elem, notElem, foldl')
import           Data.Functor (Functor(..))
import           Data.Functor.Identity (Identity(..))
import qualified Data.List
import           Data.Maybe (Maybe(..))
import           Data.Ord (Ord(..))
import           Data.String (String)
import           Prelude ( ($), (.)
                         , Integer
                         , Integral(..)
                         , Monad(..)
                         , Num(..)
                         , Show(..)
                         , const
                         , seq
                         )
import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
import qualified Text.Parsec as R hiding (satisfy, string, char, space, newline, crlf)
import qualified Text.Parsec.Pos as R

-- * 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 ((<|>) . R.try) 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 = foldl' updatePosChar

-- | 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 = R.tokens show updatePosString

-- | 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 (`elem` cs)

-- | Like 'R.noneOf' but using fixed 'satisfy'.
noneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
noneOf cs = satisfy (`notElem` 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 $ fmap (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
	_ <- (void R.anyChar <|> 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)
 => 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)
 => 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 )
 => 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 (fmap map_ko ko)])
		fail msg
	where commit_position = (void R.anyChar) <|> 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 =
	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 = (void (R.try (string "\r\n") <|> R.try (string "\n"))) <?> "newline"