{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
module Hcompta.Model.Filter.Read where

import           Prelude hiding (filter)
import           Control.Applicative ((<$>){-, (<*>)-}, (<*))
import           Control.Monad (liftM)
-- import           Control.Monad.Trans.Except (ExceptT(..), throwE)
import qualified Data.Char
import           Data.Data
import qualified Data.Foldable
import           Data.Functor.Identity (Identity)
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.Model.Account as Account
import qualified Hcompta.Model.Filter as Filter
import           Hcompta.Model.Filter
                  ( -- Filter(..)
                    Test_Account
                  , Test_Account_Section(..)
                  , Test_Bool(..)
                  , Test_Num_Abs(..)
                  , Test_Ord(..)
                  , Test_Posting(..)
                  , Test_Text(..)
                  , Test_Transaction(..)
                  , Test_Balance(..)
                  )
import qualified Hcompta.Lib.Parsec as R

-- * Parsers' types

-- ** Type 'Context'

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

context :: Context
context = Context

-- ** Type 'Error'

data Error
 =   Error_Unknown
 deriving (Eq, Show)

-- * Reading

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

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

-- ** 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 Context m (ParsecT s Context m t)]
 -> ParsecT s Context 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
	  , prefix "not " Filter.Not
	  ]
	, [ binary " & "   Filter.And                     R.AssocLeft
	  , binary " and " Filter.And                     R.AssocLeft
	  , binary " - "   (flip Filter.And . Filter.Not) R.AssocLeft
	  , binary " but " (flip Filter.And . Filter.Not) R.AssocLeft
	  ]
	, [ binary " + "  Filter.Or R.AssocLeft
	  , binary " or " Filter.Or 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 =
	lexeme $ R.try $
		(R.string name
		>> R.notFollowedBy test_bool_operator_letter
		<?> ("end of " ++ show 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 Context m (ParsecT s Context m t)]
 ->  ParsecT s Context m (Test_Bool t)
test_bool_term terms = do
	r <- R.choice_try
	 ( (R.lookAhead (R.try $ R.char '(')
		>> (return $ parens $
			Data.Foldable.foldr Filter.And Filter.Any <$>
			R.many (R.spaces >> expr) ))
	 : map ((Filter.Bool <$>) <$>) terms
	 ) <* R.spaces <?> "filter expression"
	r
	where
		expr =
			R.lookAhead (R.try R.anyToken)
			>> R.notFollowedBy (R.char ')')
			>> test_bool terms

lexeme
 :: Stream s m Char
 => ParsecT s u m a -> ParsecT s u m a
lexeme p = p <* R.spaces

parens
 :: Stream s m Char
 => ParsecT s u m a -> ParsecT s u m a
parens = R.between (lexeme $ R.char '(') (lexeme $ 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
	 ]

-- ** 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_name_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_name_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_name_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_name_sep >> R.lookAhead (R.try account_section_end)))
		 >> return Test_Account_Section_Many
	 ]
	where
		account_section_end =
			R.choice_try
			 [ R.char account_name_sep >> return ()
			 , R.space_horizontal >> return ()
			 , R.eof
			 ]

-- ** Read 'Test_Account'
account_name_sep :: Char
account_name_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_name_sep

-- ** 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 m Char, Filter.Transaction t)
 => ParsecT s Context 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 m Char, Filter.Transaction t)
 => [ParsecT s Context m (ParsecT s Context m (Test_Transaction t))]
test_transaction_terms =
	[ return
		( Filter.Test_Transaction_Posting
		. Filter.Test_Posting_Account
		<$> test_account )
	-- , jump [ "account","acct" ] comp_text test_account
	-- , jump [ "amount", "amt" ] comp_num parseFilterAmount
	-- , jump [ "atag" ] comp_text parseFilterATag
	-- , jump [ "balance", "bal" ] comp_num parseFilterBalance
	-- , jump [ "code" ] comp_text parseFilterCode
	-- , jump [ "date" ] (R.char '=') parseFilterDate
	-- , jump [ "date2", "edate" ] (R.char '=') parseFilterDate2
	-- , jump [ "depth" ] comp_num parseFilterDepth
	-- , jump [ "description","descr","desc" ] comp_text parseFilterDesc
	-- , jump [ "real" ] (R.char '=') parseFilterReal
	-- , jump [ "status" ] (R.char '=') parseFilterStatus
	-- , jump [ "sym" ] comp_text parseFilterSym
	-- , jump [ "tag" ] comp_text parseFilterTag
	-- , R.lookAhead comp_num >> return parseFilterAmount
	]
	-- where
		-- jump :: Stream s m Char => [String] -> ParsecT s u m b -> a -> ParsecT s u m a
		-- jump l next r =
		-- 	R.choice_try
		-- 	 (map (\s -> R.string s >> return r) l)
		-- 	 <* R.lookAhead next

-- ** Read 'Test_Balance'
test_balance
 :: (Stream s m Char, Filter.Balance t)
 => 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)
 => [ParsecT s Context m (ParsecT s Context m (Test_Balance t))]
test_balance_terms =
	[ return
		( Filter.Test_Balance_Account
		<$> test_account )
	]

-- * Parsing
read ::
 ( Stream s (R.Error_State Error Identity) Char
 , Show t
 )
 => ParsecT s Context (R.Error_State Error Identity) (Test_Bool t)
 -> s -> Either [R.Error Error] (Test_Bool t)
read t s =
	R.runParser_with_Error t context "" s

{-

account :: Stream s m Char => ParsecT s Context m Filter
account = do
	o <- R.optionMaybe comp_text
	liftM (Filter.Account $ fromMaybe Comp_Text_Exact o)
	 (liftM (accountNameComponents) $ string (" \t"++"+-&"))

parseFilterAmount :: Stream s m Char => ParsecT s Context m Filter
parseFilterAmount = do
	Filter.Amount
	 <$> comp_num
	 <*> comp_num_abs
	 <*> amount

parseFilterATag :: Stream s m Char => ParsecT s Context m Filter
parseFilterATag = do
	c <- comp_text
	liftM (uncurry (ATag c))
	 parseTag

--parseFilterCode :: Stream s m Char => ParsecT s Context m Filter
--parseFilterCode = do
--	string "code="
--	liftM Code $
--	 try (do {
		--		choice
		--		 [ inparen
		--		 , R.many nonspace
		--		 ]
		--		return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v
		--	 })

parseFilterBalance :: Stream s m Char => ParsecT s Context m Filter
parseFilterBalance = do
	nc <- comp_num
	absc <- comp_num_abs
	a <- parseAmount Nothing
	return $ Bal (nc, absc) a

parseFilterDate :: Stream s m Char => ParsecT s Context m Filter
parseFilterDate = do
	R.char '='
	ctx <- getState
	liftM Date $
	 periodexprdatespan (qCtxDay ctx)

parseFilterDate2 :: Stream s m Char => ParsecT s Context m Filter
parseFilterDate2 = do
	R.char '='
	ctx <- getState
	liftM Date2 $
	 periodexprdatespan (qCtxDay ctx)

parseFilterDesc :: Stream s m Char => ParsecT s Context m Filter
parseFilterDesc = do
	c <- comp_text
	liftM (Desc c)
	 (string "")

parseFilterDepth :: Stream s m Char => ParsecT s Context m Filter
parseFilterDepth = do
	c <- comp_num
	liftM (Depth c . fromIntegral) $
	 parseDecimal

parseFilterReal :: Stream s m Char => ParsecT s Context m Filter
parseFilterReal = do
	R.char '='
	liftM Real bool

-- | Read the boolean value part of a "status:" query, allowing "*" as
-- another way to spell True, similar to the journal file format.
parseFilterStatus :: Stream s m Char => ParsecT s Context m Filter
parseFilterStatus = do
	R.char '='
	liftM Status $
	 try (R.char '*' >> return True) <|> bool

--parseFilterSym :: Stream s m Char => ParsecT s Context m Filter
--parseFilterSym = do
--	string "cur="
--	liftM Sym
--	 commoditysymbol

parseFilterTag :: Stream s m Char => ParsecT s Context m Filter
parseFilterTag = do
	c <- comp_text
	liftM (uncurry (Tag c))
	 parseTag
-}