{-# 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)
-- 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 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_Test_Date         Date.Read.Error
 deriving (Show)

-- * Read

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

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

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

-- ** Read 'Test_Ord'
test_ord
 :: (Stream s m Char, Ord o)
 => ParsecT s u m (o -> Test_Ord o)
test_ord =
	R.choice_try
	 [ R.string "="  >> return Test_Ord_Eq
	 , R.string "<=" >> return Test_Ord_Le
	 , R.string ">=" >> return Test_Ord_Ge
	 , R.string "<"  >> return Test_Ord_Lt
	 , R.string ">"  >> return Test_Ord_Gt
	 ]

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

-- ** Read 'Test_Num_Abs'
test_num_abs
 :: (Stream s m Char, Num n)
 => ParsecT s u m (Test_Ord n -> m (Either (Test_Ord n) (Test_Num_Abs n)))
test_num_abs =
	R.choice_try
	 [ R.char '+' >> return (return . Right . Test_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 'Test_Bool'

test_bool
 :: (Stream s m Char)
 => [ParsecT s u m (ParsecT s u m t)]
 -> ParsecT s u m (Test_Bool t)
test_bool terms =
	R.buildExpressionParser
	 test_bool_operators
	 (test_bool_term terms)
	<?> "test_bool"

test_bool_operators
 :: Stream s m Char
 => R.OperatorTable s u m (Filter.Test_Bool t)
test_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 assoc = R.Infix  (test_bool_operator name >> return fun) assoc
		prefix  name fun       = R.Prefix (test_bool_operator name >> return fun)
		-- postfix name fun       = Text.Parsec.Expr.Postfix (test_bool_operator name >> return fun)

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

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

test_bool_term
 :: Stream s m Char
 => [ParsecT s u m (ParsecT s u m t)]
 ->  ParsecT s u m (Test_Bool t)
test_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 ')')
			>> test_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 'Test_Account_Section'
test_account_section
 :: (Stream s m Char)
 => (String -> ParsecT s u m Test_Text)
 -> ParsecT s u m Test_Account_Section
test_account_section make_test_text = do
	R.choice_try
	 [ R.char '*'
		 <* R.lookAhead account_section_end
		 >> return Test_Account_Section_Any
	 , R.many1 (R.satisfy (\c -> c /= account_section_sep && not (Data.Char.isSpace c)))
		 >>= (liftM Test_Account_Section_Text . make_test_text)
	 , R.lookAhead account_section_end
		 >> R.many (R.try (R.char account_section_sep >> R.lookAhead (R.try account_section_end)))
		 >> return Test_Account_Section_Many
	 ]
	where
		account_section_end =
			R.choice_try
			 [ R.char account_section_sep >> return ()
			 , R.space_horizontal >> return ()
			 , R.eof
			 ]

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

test_account
 :: Stream s m Char
 => ParsecT s u m Test_Account
test_account = do
	R.notFollowedBy $ R.space_horizontal
	make_test_text <- test_text
	R.many1_separated (test_account_section make_test_text) $
		R.char account_section_sep

-- ** Read 'Test_Amount'
test_amount
 :: Stream s m Char
 => ParsecT s u m (Test_Amount Amount)
test_amount = do
	R.notFollowedBy $ R.space_horizontal
	tst <- test_ord
	amt <- Amount.Read.amount
	return $ Test_Amount
	 (tst $ Amount.quantity amt) $
	 (Test_Unit $
		case Unit.text $ Amount.unit amt of
		 unit | Text.null unit -> Test_Text_Any
		 unit                  -> Test_Text_Exact unit)

test_amount_operator
 :: Stream s m Char
 => ParsecT s u m String
test_amount_operator =
	test_ord_operator

-- ** Read 'Test_Date'
test_date
 :: (Stream s (R.Error_State Error m) Char, Monad m)
 => ParsecT s Context (R.Error_State Error m) (Test_Bool Test_Date)
test_date = do
	join $ R.choice_try
	 [ R.char '=' >>
		(return $ read_date_pattern)
	 , test_ord >>= \tst ->
		return $ do
			ctx <- R.getState
			let (year, _, _) = Date.gregorian $ context_date ctx
			Date.Read.date Error_Test_Date (Just year)
			>>= return . Bool . Test_Date_UTC . tst
	 ]
	where
		read_date_pattern
		 :: (Stream s (R.Error_State e m) Char, Monad m)
		 => ParsecT s u (R.Error_State e m) (Test_Bool Test_Date)
		read_date_pattern = (do
			let read2 = R.try (R.count 2 R.digit) <|> R.count 1 R.digit
			n0 <- read_range $ R.many1 R.digit
			n1 <- R.option Nothing $ R.try $ do
				_  <- R.char '/'
				Just <$> read_range read2
			n2 <- R.option Nothing $ R.try $ do
				_ <- R.char '/'
				Just <$> read_range read2
			let (year, month, dom) =
				case (n1, n2) of
				 (Nothing, Nothing) ->
					( test_range_all
					, of_digits <$> n0
					, test_range_all )
				 (Just d1, Nothing) ->
					( test_range_all
					, of_digits <$> n0
					, of_digits <$> d1 )
				 (Nothing, Just _d2) -> assert False undefined
				 (Just d1, Just d2) ->
					( R.integer_of_digits 10 <$> n0
					, of_digits <$> d1
					, of_digits <$> d2 )
			(hour, minute, second) <-
				R.option (test_range_all, test_range_all, test_range_all) $ R.try $ do
					R.skipMany1 $ R.space_horizontal
					hour <- read_range read2
					sep <- Date.Read.hour_separator
					minute <- read_range read2
					second <- R.option test_range_all $ R.try $ do
						_ <- R.char sep
						read_range $ R.many1 R.digit
					-- tz <- R.option Time.utc $ R.try $ do
					-- 	R.skipMany $ R.space_horizontal
					-- 	Date.Read.time_zone
					return
					 ( of_digits <$> hour
					 , of_digits <$> minute
					 , of_digits <$> second
					 )
			return $
				foldr And Any $
				catMaybes $
				 [ just_when_bounded Test_Date_Year   year
				 , just_when_bounded Test_Date_Month  month
				 , just_when_bounded Test_Date_DoM    dom
				 , just_when_bounded Test_Date_Hour   hour
				 , just_when_bounded Test_Date_Minute minute
				 , just_when_bounded Test_Date_Second second
				 ]
			) <?> "date-filter"
			where
				of_digits :: Num n => [Char] -> n
				of_digits = fromInteger . R.integer_of_digits 10
				just_when_bounded f x =
					case x of
					 Test_Range_In Nothing Nothing -> Nothing
					 _ -> Just $ Bool $ f x

read_range :: Stream s m Char
 => ParsecT s u m a
 -> ParsecT s u m (Test_Range a)
read_range read_digits = do
	a0 <- R.choice_try
		 [ R.char '*' >> return Nothing
		 , Just <$> read_digits
		 ]
	R.choice_try
	 [ R.char '-' >>
		(Test_Range_In a0 <$> R.choice_try
		 [ R.char '*' >> return Nothing
		 , Just <$> read_digits
		 ])
	 , return $ maybe test_range_all Test_Range_Eq a0
	 ]

test_date_operator
 :: Stream s m Char
 => ParsecT s u m String
test_date_operator =
	test_ord_operator

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

test_tag_name
 :: Stream s m Char
 => ParsecT s u m Test_Tag
test_tag_name = do
	make_test_text <- test_text
	R.choice_try
	 [ R.char '*'
		 <* R.lookAhead test_tag_name_end
		 >> return (Test_Tag_Name Test_Text_Any)
	 , R.many1 (R.notFollowedBy (R.try test_tag_name_end) >> R.anyChar)
		 >>= (liftM Test_Tag_Name . make_test_text)
	 ]
	where
		test_tag_name_end =
			R.choice_try
			 [ test_text_operator >> return ()
			 , R.space_horizontal >> return ()
			 , R.eof
			 ]
test_tag_value
 :: Stream s m Char
 => ParsecT s u m Test_Tag
test_tag_value = do
	make_test_text <- test_text
	R.choice_try
	 [ R.char '*'
		 <* R.lookAhead test_tag_value_end
		 >> return (Test_Tag_Value Test_Text_Any)
	 , R.many1 (R.notFollowedBy (R.try test_tag_value_end) >> R.anyChar)
		 >>= (liftM Test_Tag_Value . make_test_text)
	 ]
	where
		test_tag_value_end =
			R.choice_try
			 [ R.space_horizontal >> return ()
			 , R.eof
			 ]

test_tag
 :: Stream s m Char
 => ParsecT s u m (Test_Bool Test_Tag)
test_tag = do
	n <- test_tag_name
	R.choice_try
	 [ R.lookAhead (R.try $ test_tag_operator)
		 >> And (Bool n) . Bool <$> test_tag_value
	 , return $ Bool n
	 ]

test_tag_operator
 :: Stream s m Char
 => ParsecT s u m String
test_tag_operator =
	test_text_operator

-- ** Read 'Test_Posting'
test_posting
 :: (Stream s m Char, Filter.Posting t)
 => ParsecT s Context m (Test_Bool (Test_Posting t))
test_posting =
	Data.Foldable.foldr Filter.And Filter.Any <$>
	do R.many $
		R.spaces
		>> R.lookAhead R.anyToken
		>> test_bool test_posting_terms

test_posting_terms
 :: (Stream s m Char, Filter.Posting t)
 => [ParsecT s Context m (ParsecT s Context m (Test_Posting t))]
test_posting_terms =
	[ return
		( Filter.Test_Posting_Account
		<$> test_account )
	]

-- ** Read 'Test_Transaction'
test_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) (Test_Bool (Test_Transaction t))
test_transaction =
	Data.Foldable.foldr Filter.And Filter.Any <$>
	do R.many $
		R.spaces
		>> R.lookAhead R.anyToken
		>> test_bool test_transaction_terms

test_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) (Test_Transaction t))]
test_transaction_terms =
	-- , jump [ "atag" ] comp_text parseFilterATag
	-- , jump [ "code" ] comp_text parseFilterCode
	[ jump [ "date" ] test_date_operator
		(Filter.Test_Transaction_Date <$> test_date)
	, jump [ "tag" ] test_tag_operator
		(Filter.Test_Transaction_Tag <$> test_tag)
	, jump [ "amount" ] test_amount_operator
		(( Filter.Test_Transaction_Posting
		 . Filter.Test_Posting_Amount
		 ) <$> test_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.Test_Transaction_Posting
		. Filter.Test_Posting_Account
		<$> test_account )
	]

-- ** Read 'Test_Balance'
test_balance
 :: (Stream s m Char, Filter.Balance t, Balance_Amount t ~ Amount)
 => ParsecT s Context m (Test_Bool (Test_Balance t))
test_balance =
	Data.Foldable.foldr Filter.And Filter.Any <$>
	do R.many $
		R.spaces
		>> R.lookAhead R.anyToken
		>> test_bool test_balance_terms

test_balance_terms
 :: (Stream s m Char, Filter.Balance t, Balance_Amount t ~ Amount)
 => [ParsecT s Context m (ParsecT s Context m (Test_Balance t))]
test_balance_terms =
	[ jump [ "amount" ] test_amount_operator
		( Filter.Test_Balance_Amount
		<$> test_amount )
	, jump [ "debit" ] test_amount_operator
		( Filter.Test_Balance_Positive
		<$> test_amount )
	, jump [ "credit" ] test_amount_operator
		( Filter.Test_Balance_Negative
		<$> test_amount )
	, return
		( Filter.Test_Balance_Account
		<$> test_account )
	]