{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Hcompta.Filter.Read where

import           Prelude hiding (filter)
-- import           Control.Applicative ((<$>), (<*))
import           Control.Exception (assert)
import           Control.Monad (liftM, join, when, (>=>), void)
-- import           Control.Monad.Trans.Except (ExceptT(..), throwE)
import qualified Data.Char
import           Data.Data
import qualified Data.Foldable
import           Data.Functor.Identity (Identity)
import           Data.Maybe (catMaybes)
import qualified Data.Time.Clock as Time
import qualified Text.Parsec.Expr as R
import qualified Text.Parsec as R hiding
                  ( char
                  , anyChar
                  , crlf
                  , newline
                  , noneOf
                  , oneOf
                  , satisfy
                  , space
                  , spaces
                  , string
                  )
-- import qualified Text.Parsec.Expr as R
import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
import           Data.String (fromString)
import qualified Data.Text as Text
import           Data.Text (Text)
import           Data.Typeable ()

import           Hcompta.Lib.Interval (Interval)
import qualified Hcompta.Lib.Interval as Interval
import qualified Hcompta.Lib.Regex as Regex
-- import           Hcompta.Lib.Regex (Regex)
import qualified Hcompta.Account as Account
import qualified Hcompta.Amount as Amount
import           Hcompta.Amount (Amount)
import qualified Hcompta.Amount.Read as Amount.Read
import qualified Hcompta.Amount.Unit as Unit
import qualified Hcompta.Date as Date
import           Hcompta.Date (Date)
import qualified Hcompta.Date.Read as Date.Read
import qualified Hcompta.Filter as Filter
import           Hcompta.Filter hiding (Amount)
import qualified Hcompta.Lib.Parsec as R

-- * Parsers' types

-- ** Type 'Context'

data Context
 =   Context
 { context_date :: Date
 } deriving (Data, Eq, Show, Typeable)

context :: Context
context =
	Context
	 { context_date = Date.nil
	 }

-- ** Type 'Error'

data Error
 =   Error_Unknown
 |   Error_Filter_Date          Date.Read.Error
 |   Error_Filter_Date_Interval (Integer, Integer)
 deriving (Show)

-- * Read

read ::
 ( Stream s (R.Error_State Error Identity) Char
 , Show t
 )
 => ParsecT s Context (R.Error_State Error Identity) (Filter_Bool t)
 -> s -> IO (Either [R.Error Error] (Filter_Bool t))
read t s = do
	context_date <- Time.getCurrentTime
	return $
		R.runParser_with_Error t context{context_date} "" s

-- ** Read 'Filter_Text'
filter_text
 :: (Stream s m Char, Monad r)
 => ParsecT s u m (String -> r Filter_Text)
filter_text =
	R.choice_try
	 [ R.char '~' >> return (Regex.of_StringM >=> (return . Filter_Text_Regex))
	 , R.char '=' >> return (\s -> return (Filter_Text_Exact $ Text.pack s))
	 ,               return (\s -> return (Filter_Text_Exact $ Text.pack s))
	 ]

filter_text_operator
 :: Stream s m Char
 => ParsecT s u m String
filter_text_operator =
	R.choice_try
	 [ R.string "="
	 , R.string "~"
	 ]

-- ** Read 'Filter_Ord'
filter_ord
 :: (Stream s m Char, Ord o)
 => ParsecT s u m (o -> Filter_Ord o)
filter_ord =
	R.choice_try
	 [ R.string "="  >> return (Filter_Ord Eq)
	 , R.string "<=" >> return (Filter_Ord Le) -- NOTE: before "<"
	 , R.string ">=" >> return (Filter_Ord Ge) -- NOTE: before ">"
	 , R.string "<"  >> return (Filter_Ord Lt)
	 , R.string ">"  >> return (Filter_Ord Gt)
	 ]

filter_ord_operator
 :: Stream s m Char
 => ParsecT s u m String
filter_ord_operator =
	R.choice_try
	 [ R.string "="
	 , R.string "<="
	 , R.string ">="
	 , R.string "<"
	 , R.string ">"
	 ]

-- ** Read 'Filter_Num_Abs'
filter_num_abs
 :: (Stream s m Char, Num n)
 => ParsecT s u m (Filter_Ord n -> m (Either (Filter_Ord n) (Filter_Num_Abs n)))
filter_num_abs =
	R.choice_try
	 [ R.char '+' >> return (return . Right . Filter_Num_Abs)
	 , return (return . Left)
	 ]

text :: Stream s m Char => String -> ParsecT s Context m Text
text none_of =
	fromString <$>
	R.choice_try
	 [ borders inside
	 , R.many $ R.noneOf ("() " ++ none_of)
	 ]
	where
		borders = R.between (R.char '(') (R.char ')')
		inside = liftM concat $ R.many (R.choice_try [borders preserve_inside, R.many1 $ R.noneOf "()"])
		preserve_inside = inside >>= (\x -> return $ '(':(x++[')']))

-- ** Read 'Filter_Bool'

filter_bool
 :: (Stream s m Char)
 => [ParsecT s u m (ParsecT s u m t)]
 -> ParsecT s u m (Filter_Bool t)
filter_bool terms =
	R.buildExpressionParser
	 filter_bool_operators
	 (filter_bool_term terms)
	<?> "filter_bool"

filter_bool_operators
 :: Stream s m Char
 => R.OperatorTable s u m (Filter.Filter_Bool t)
filter_bool_operators =
	[ [ prefix "- "   Filter.Not
	  ]
	, [ binary " & "  Filter.And R.AssocLeft
	  ]
	, [ binary " + "  Filter.Or R.AssocLeft
	  , binary " - "  (\x -> Filter.And x . Filter.Not) R.AssocLeft
	  ]
	]
	where
		binary name fun = R.Infix  (filter_bool_operator name >> return fun)
		prefix name fun = R.Prefix (filter_bool_operator name >> return fun)
		-- postfix name fun       = Text.Parsec.Expr.Postfix (filter_bool_operator name >> return fun)

filter_bool_operator
 :: Stream s m Char
 => String -> ParsecT s u m ()
filter_bool_operator name =
	R.try $
		(R.string name
		>> R.notFollowedBy filter_bool_operator_letter
		-- <* R.spaces
		<?> name)

filter_bool_operator_letter
 :: Stream s m Char => ParsecT s u m Char
filter_bool_operator_letter =
	R.oneOf ['-', '&', '+']

filter_bool_term
 :: Stream s m Char
 => [ParsecT s u m (ParsecT s u m t)]
 ->  ParsecT s u m (Filter_Bool t)
filter_bool_term terms = do
	join (R.choice_try
	 ( (R.lookAhead (R.try (R.spaces >> R.char '('))
		>> (return $ parens $
			Data.Foldable.foldr Filter.And Filter.Any <$>
			R.many (R.try (R.spaces >> expr)) ))
	 : map ((Filter.Bool <$>) <$>) terms
	 ) <* R.spaces <?> "boolean-expression")
	where
		expr =
			R.lookAhead (R.try R.anyToken)
			>> R.notFollowedBy (R.char ')')
			>> filter_bool terms

parens
 :: Stream s m Char
 => ParsecT s u m a
 -> ParsecT s u m a
parens =
	R.between
	 (R.spaces >> R.char '(')
	 (R.spaces >> R.char ')')

bool :: Stream s m Char => ParsecT s u m Bool
bool = do
	R.choice_try
	 [ R.choice_try
		 [ R.string "1"
		 , R.string "true"
		 , R.string "t"
		 ] >> return True
	 , R.choice_try
		 [ R.string "0"
		 , R.string "false"
		 , R.string "f"
		 ] >> return False
	 ]

jump :: Stream s m Char
 => [String]
 -> ParsecT s u m b
 -> a
 -> ParsecT s u m a
jump prefixes next r =
	R.choice_try
	 (map (\s -> R.string s >> return r) prefixes)
	 <* R.lookAhead (R.try next)

-- ** Read Account.'Account.Name'
account_name :: Stream s m Char => ParsecT s u m Account.Name
account_name = do
	fromString <$> do
	R.many1 $ R.try account_name_char
	where
		account_name_char :: Stream s m Char => ParsecT s u m Char
		account_name_char = do
			c <- R.anyChar
			case c of
			 -- _ | c == comment_begin -> R.parserZero
			 -- _ | c == account_section_sep -> R.parserZero
			 _ | R.is_space_horizontal c -> do
				_ <- R.notFollowedBy $ R.space_horizontal
				return c <* (R.lookAhead $ R.try $
				 ( R.try (R.char account_section_sep)
				 <|> account_name_char
				 ))
			 _ | not (Data.Char.isSpace c) -> return c
			 _ -> R.parserZero

-- ** Read 'Filter_Account_Section'
filter_account_section
 :: (Stream s m Char)
 => ParsecT s u m Filter_Account_Section
filter_account_section = do
	R.choice_try
	 [ R.char '*'
		 <* R.lookAhead account_section_end
		 >> return Filter_Account_Section_Any
	 , R.char '~'
		 >> R.many1 (R.satisfy (\c -> c /= account_section_sep && not (Data.Char.isSpace c)))
		 >>= (liftM (Filter_Account_Section_Text . Filter_Text_Regex) . Regex.of_StringM)
	 , R.many1 (R.satisfy (\c -> c /= account_section_sep && not (Data.Char.isSpace c)))
		 >>= (liftM (Filter_Account_Section_Text . Filter_Text_Exact) . return . Text.pack)
	 , R.lookAhead account_section_end
		 >> R.many (R.try (R.char account_section_sep >> R.lookAhead (R.try account_section_end)))
		 >> return Filter_Account_Section_Many
	 ]
	where
		account_section_end =
			R.choice_try
			 [ void $ R.char account_section_sep
			 , void $ R.space_horizontal
			 , R.eof
			 ]

-- ** Read 'Filter_Account'
account_section_sep :: Char
account_section_sep = ':'

filter_account
 :: Stream s m Char
 => ParsecT s u m Filter_Account
filter_account = do
	R.notFollowedBy $ R.space_horizontal
	Filter_Ord o () <-
		R.option (Filter_Ord Eq ()) $ R.try $
			(\f -> f ()) <$> filter_ord
	fmap (Filter_Account o) $
		R.many1_separated filter_account_section $
			R.char account_section_sep

filter_account_operator
 :: Stream s m Char
 => ParsecT s u m String
filter_account_operator =
	filter_text_operator

-- ** Read 'Filter_Amount'
filter_amount
 :: Stream s m Char
 => ParsecT s u m (Filter_Amount Amount)
filter_amount = do
	R.notFollowedBy $ R.space_horizontal
	R.choice_try
	 [ filter_ord
		>>= \tst -> do
			amt <- Amount.Read.amount
			return $
			 (Filter_Amount_Section_Quantity (tst $ Amount.quantity amt))
			 : case Unit.text $ Amount.unit amt of
				 unit | Text.null unit -> []
				 unit                  -> [Filter_Amount_Section_Unit (Filter_Unit (Filter_Text_Exact unit))]
	 , filter_text
		>>= \tst -> do
			unit <- Amount.Read.unit >>= tst . Text.unpack . Unit.text
			return $ [Filter_Amount_Section_Unit (Filter_Unit unit)]
	 ]

filter_amount_operator
 :: Stream s m Char
 => ParsecT s u m String
filter_amount_operator =
	R.choice_try
	 [ filter_ord_operator
	 , filter_text_operator
	 ]

-- ** Read 'Filter_Date'
filter_date
 :: (Stream s (R.Error_State Error m) Char, Monad m)
 => ParsecT s Context (R.Error_State Error m) (Filter_Bool Filter_Date)
filter_date = do
	join $ R.choice_try
	 [ R.char '=' >>
		(return $ read_date_pattern)
	 , filter_ord >>= \tst ->
		return $ do
			ctx <- R.getState
			let (year, _, _) = Date.gregorian $ context_date ctx
			liftM (Bool . Filter_Date_UTC . tst) $
				Date.Read.date Error_Filter_Date (Just year)
	 ]
	where
		read_date_pattern
		 :: (Stream s (R.Error_State Error m) Char, Monad m)
		 => ParsecT s u (R.Error_State Error m) (Filter_Bool Filter_Date)
		read_date_pattern = (do
			let read2 = of_digits <$> (R.try (R.count 2 R.digit) <|> R.count 1 R.digit)
			n0 <- read_interval Error_Filter_Date_Interval $ of_digits <$> R.many1 R.digit
			n1 <- R.option Nothing $ R.try $ do
				_  <- R.char '/'
				Just <$> read_interval Error_Filter_Date_Interval read2
			n2 <- R.option Nothing $ R.try $ do
				_ <- R.char '/'
				Just <$> read_interval Error_Filter_Date_Interval read2
			let (year, month, dom) =
				case (n1, n2) of
				 (Nothing, Nothing) ->
					( Interval.unlimited
					, n0
					, Interval.unlimited )
				 (Just d1, Nothing) ->
					( Interval.unlimited
					, n0
					, d1 )
				 (Nothing, Just _d2) -> assert False undefined
				 (Just d1, Just d2) ->
					( n0
					, d1
					, d2 )
			(hour, minute, second) <-
				R.option (Interval.unlimited, Interval.unlimited, Interval.unlimited) $ R.try $ do
					_ <- R.char '_'
					hour   <- read_interval Error_Filter_Date_Interval read2
					sep    <- Date.Read.hour_separator
					minute <- read_interval Error_Filter_Date_Interval read2
					second <- R.option Interval.unlimited $ R.try $ do
						_    <- R.char sep
						read_interval Error_Filter_Date_Interval $ of_digits <$> R.many1 R.digit
					-- tz <- R.option Time.utc $ R.try $ do
					-- 	-- R.skipMany $ R.space_horizontal
					-- 	Date.Read.time_zone
					return
					 ( hour
					 , minute
					 , second
					 )
			return $
				foldr And Any $
				catMaybes $
				 [ just_when_limited (Filter_Date_Year   . Filter_Interval_In) year
				 , just_when_limited (Filter_Date_Month  . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) month)
				 , just_when_limited (Filter_Date_DoM    . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) dom)
				 , just_when_limited (Filter_Date_Hour   . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) hour)
				 , just_when_limited (Filter_Date_Minute . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) minute)
				 , just_when_limited (Filter_Date_Second . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) second)
				 ]
			) <?> "date-filter"
			where
				of_digits :: Num n => [Char] -> n
				of_digits = fromInteger . R.integer_of_digits 10
				just_when_limited f x =
					if x == Interval.unlimited
					then Nothing
					else Just $ Bool $ f x

read_interval
 :: (Stream s (R.Error_State e m) Char, Monad m, Ord x)
 => ((x, x) -> e)
 -> ParsecT s u (R.Error_State e m) x
 -> ParsecT s u (R.Error_State e m) (Interval (Interval.Unlimitable x))
read_interval err read_digits = do
	l <- R.choice_try
		 [ R.string ".." >> return Interval.Unlimited_low
		 , Interval.Limited <$> read_digits
		 ]
	R.choice_try
	 [ when (l /= Interval.Unlimited_low)
		 (void $ R.string "..") >> do
		h <- R.choice_try
			 [ Interval.Limited <$> read_digits
			 , return Interval.Unlimited_high
			 ]
		case (Interval.<=..<=) l h of
		 Nothing -> R.fail_with "interval" (err $ (Interval.limited l, Interval.limited h))
		 Just i  -> return i
	 , return $
		case l of
		 Interval.Limited _ -> Interval.point l
		 _                  -> Interval.unlimited
	 ]

filter_date_operator
 :: Stream s m Char
 => ParsecT s u m String
filter_date_operator =
	filter_ord_operator

-- ** Read 'Filter_Tag'
tag_name_sep :: Char
tag_name_sep = ':'

filter_tag_name
 :: Stream s m Char
 => ParsecT s u m Filter_Tag
filter_tag_name = do
	make_filter_text <- filter_text
	R.choice_try
	 [ R.char '*'
		 <* R.lookAhead filter_tag_name_end
		 >> return (Filter_Tag_Name Filter_Text_Any)
	 , R.many1 (R.notFollowedBy (R.try filter_tag_name_end) >> R.anyChar)
		 >>= (liftM Filter_Tag_Name . make_filter_text)
	 ]
	where
		filter_tag_name_end =
			R.choice_try
			 [ void $ filter_text_operator
			 , void $ R.space_horizontal
			 , R.eof
			 ]
filter_tag_value
 :: Stream s m Char
 => ParsecT s u m Filter_Tag
filter_tag_value = do
	make_filter_text <- filter_text
	R.choice_try
	 [ R.char '*'
		 <* R.lookAhead filter_tag_value_end
		 >> return (Filter_Tag_Value Filter_Text_Any)
	 , R.many1 (R.notFollowedBy (R.try filter_tag_value_end) >> R.anyChar)
		 >>= (liftM Filter_Tag_Value . make_filter_text)
	 ]
	where
		filter_tag_value_end =
			R.choice_try
			 [ void $ R.space_horizontal
			 , R.eof
			 ]

filter_tag
 :: Stream s m Char
 => ParsecT s u m (Filter_Bool Filter_Tag)
filter_tag = do
	n <- filter_tag_name
	R.choice_try
	 [ R.lookAhead (R.try $ filter_tag_operator)
		 >> And (Bool n) . Bool <$> filter_tag_value
	 , return $ Bool n
	 ]

filter_tag_operator
 :: Stream s m Char
 => ParsecT s u m String
filter_tag_operator =
	filter_text_operator

-- ** Read 'Filter_Posting'
filter_posting
 :: (Stream s m Char, Filter.Posting t)
 => ParsecT s Context m (Filter_Bool (Filter_Posting t))
filter_posting =
	Data.Foldable.foldr Filter.And Filter.Any <$>
	do R.many $
		R.spaces
		>> R.lookAhead R.anyToken
		>> filter_bool filter_posting_terms

filter_posting_terms
 :: (Stream s m Char, Filter.Posting t)
 => [ParsecT s Context m (ParsecT s Context m (Filter_Posting t))]
filter_posting_terms =
	[ return
		( Filter.Filter_Posting_Account
		<$> filter_account )
	]

-- ** Read 'Filter_Transaction'
filter_transaction
 :: (Stream s (R.Error_State Error m) Char, Monad m, Filter.Transaction t
 , Posting_Amount (Transaction_Posting t) ~ Amount)
 => ParsecT s Context (R.Error_State Error m) (Filter_Bool (Filter_Transaction t))
filter_transaction =
	Data.Foldable.foldr Filter.And Filter.Any <$>
	do R.many $
		R.spaces
		>> R.lookAhead R.anyToken
		>> filter_bool filter_transaction_terms

filter_transaction_terms
 :: (Stream s (R.Error_State Error m) Char, Filter.Transaction t, Monad m
 , Posting_Amount (Transaction_Posting t) ~ Amount)
 => [ParsecT s Context (R.Error_State Error m)
    (ParsecT s Context (R.Error_State Error m) (Filter_Transaction t))]
filter_transaction_terms =
	-- , jump [ "atag" ] comp_text parseFilterATag
	-- , jump [ "code" ] comp_text parseFilterCode
	[ jump [ "date" ] filter_date_operator
		(Filter.Filter_Transaction_Date <$> filter_date)
	, jump [ "tag" ] filter_tag_operator
		(Filter.Filter_Transaction_Tag <$> filter_tag)
	, jump [ "amount" ] filter_amount_operator
		(( Filter.Filter_Transaction_Posting
		 . Filter.Filter_Posting_Amount
		 ) <$> filter_amount)
	-- , jump [ "date2", "edate" ] (R.char '=') parseFilterDate2
	-- , jump [ "description","descr","desc" ] comp_text parseFilterDesc
	-- , jump [ "real" ] (R.char '=') parseFilterReal
	-- , jump [ "status" ] (R.char '=') parseFilterStatus
	-- , jump [ "sym" ] comp_text parseFilterSym
	-- , R.lookAhead comp_num >> return parseFilterAmount
	, return
		( Filter.Filter_Transaction_Posting
		. Filter.Filter_Posting_Account
		<$> filter_account )
	]

-- ** Read 'Filter_Balance'
filter_balance
 :: (Stream s m Char, Filter.Balance t, Balance_Amount t ~ Amount)
 => ParsecT s Context m (Filter_Bool (Filter_Balance t))
filter_balance =
	Data.Foldable.foldr Filter.And Filter.Any <$>
	do R.many $
		R.spaces
		>> R.lookAhead R.anyToken
		>> filter_bool filter_balance_terms

filter_balance_terms
 :: (Stream s m Char, Filter.Balance t, Balance_Amount t ~ Amount)
 => [ParsecT s Context m (ParsecT s Context m (Filter_Balance t))]
filter_balance_terms =
	[ jump [ "D" ] filter_amount_operator
		( Filter.Filter_Balance_Positive
		<$> filter_amount )
	, jump [ "C" ] filter_amount_operator
		( Filter.Filter_Balance_Negative
		<$> filter_amount )
	, jump [ "B" ] filter_amount_operator
		( Filter.Filter_Balance_Amount
		<$> filter_amount )
	, return
		( Filter.Filter_Balance_Account
		<$> filter_account )
	]

-- ** Read 'Filter_GL'
filter_gl
 :: (Stream s m Char, Filter.GL t, GL_Amount t ~ Amount)
 => ParsecT s Context m (Filter_Bool (Filter_GL t))
filter_gl =
	Data.Foldable.foldr Filter.And Filter.Any <$>
	do R.many $
		R.spaces
		>> R.lookAhead R.anyToken
		>> filter_bool filter_gl_terms

filter_gl_terms
 :: (Stream s m Char, Filter.GL t, GL_Amount t ~ Amount)
 => [ParsecT s Context m (ParsecT s Context m (Filter_GL t))]
filter_gl_terms =
	[ jump [ "D" ] filter_amount_operator
		( Filter.Filter_GL_Amount_Positive
		<$> filter_amount )
	, jump [ "C" ] filter_amount_operator
		( Filter.Filter_GL_Amount_Negative
		<$> filter_amount )
	, jump [ "B" ] filter_amount_operator
		( Filter.Filter_GL_Amount_Balance
		<$> filter_amount )
	, jump [ "RD" ] filter_amount_operator
		( Filter.Filter_GL_Sum_Positive
		<$> filter_amount )
	, jump [ "RC" ] filter_amount_operator
		( Filter.Filter_GL_Sum_Negative
		<$> filter_amount )
	, jump [ "RB" ] filter_amount_operator
		( Filter.Filter_GL_Sum_Balance
		<$> filter_amount )
	, return
		( Filter.Filter_GL_Account
		<$> filter_account )
	]