{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hcompta.Lib.Parsec where

import           Control.Monad.Trans.State (StateT(..), get, put)
import           Control.Monad.Trans.Class (lift, MonadTrans(..))
import           Control.Monad.Identity (Identity(..))
import qualified Data.Char
import qualified Data.List
import qualified Text.Parsec as R
import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
import qualified Text.Parsec.Pos as R
import qualified Text.Parsec.Error 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 (\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)

-- ** Custom 'ParsecT' errors.

-- | Use the 'StateT' monad transformer
--   to attach custom errors to the 'ParsecT' monad.
type Error e = StateT (R.SourcePos, [e])

fail_with :: (Stream s (Error e m) Char, Monad m)
 => String -> e -> ParsecT s u (Error e m) r
fail_with msg err = do
	(sp, se) <- lift get
	p <- R.getPosition
	case () of
	 _ | R.sourceLine   p > R.sourceLine   sp &&
	     R.sourceColumn p > R.sourceColumn sp
	   -> lift $ put (p, err:[])
	 _ | R.sourceLine   p == R.sourceLine   sp &&
	     R.sourceColumn p == R.sourceColumn sp
	   -> lift $ put (sp, err:se)
	 _ -> return ()
	R.parserFail msg

runParserT_with_Error
 :: (Stream s (Error e m) Char, Monad m)
 => ParsecT s u (Error e m) r
 -> u -> R.SourceName -> s
 -> m (Either (R.ParseError, [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.sourceColumn (R.errorPos pe) < R.sourceColumn sp
	         -> return $ Left (R.newErrorUnknown sp, se)
	 Left pe | R.sourceLine   (R.errorPos pe) == R.sourceLine   sp &&
	           R.sourceColumn (R.errorPos pe) == R.sourceColumn sp
	         -> return $ Left (case se of {[] -> pe; _ -> R.newErrorUnknown sp}, se)
	 Left pe -> return $ Left (pe, [])
	 Right x -> return $ Right x

runParser_with_Error
 :: (Stream s (Error e Identity) Char)
 => ParsecT s u (Error e Identity) r
 -> u -> R.SourceName -> s
 -> Either (R.ParseError, [e]) r
runParser_with_Error p u sn s =
	runIdentity $
	runParserT_with_Error p u sn s

-- * 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

space_horizontal :: Stream s m Char => ParsecT s u m Char
{-# INLINEABLE space_horizontal #-}
space_horizontal = R.satisfy is_space_horizontal <?> "horizontal-space"

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