module Hcompta.Model.Filter.Read where

import           Control.Monad (liftM)
import           Control.Applicative ((<$>))
import           Data.Maybe (isJust)
import qualified Text.Parsec as R
import qualified Text.Parsec.Expr as R
import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))

import qualified Hcompta.Model.Filter as Filter
import           Hcompta.Model.Filter (Comp_Number(..), Comp_String(..))

-- * The 'Context' type

data Context
 =   Context
 { context_day :: !Day
 } deriving (Data, Eq, Show, Typeable)

-- * Comparing

comp_string :: Stream s m Char => ParsecT s u m Comp_String
comp_string =
	R.choice_try
	 [ R.string "=" >> return Comp_String_Eq
	 , R.string "~" >> return Comp_String_Regexp
	 ]

comp_number :: Stream s m Char => ParsecT s u m Comp_Number
comp_number =
	R.choice_try
	 [ R.string "="  >> return Comp_Number_Eq
	 , R.string "<=" >> return Comp_Number_Lt_Eq
	 , R.string ">=" >> return Comp_Number_Gt_Eq
	 , R.string "<"  >> return Comp_Number_Lt
	 , R.string ">"  >> return Comp_Number_Gt
	 ]

comp_number_absolute :: Stream s m Char => ParsecT s u m Comp_Num_Absolute
comp_number_absolute =
	liftM isJust $ R.optionMaybe (char '+')

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

parseBool :: Stream s m Char => ParsecT s u m Bool
parseBool = 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
	 ]

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

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

parseFilterATag :: Stream s m Char => ParsecT s Context m Filter
parseFilterATag = do
	c <- comp_string
	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_number
	absc <- comp_number_absolute
	a <- parseAmount Nothing
	return $ Bal (nc, absc) a

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

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

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

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

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

-- | Parse 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
	char '='
	liftM Status $
	 try (char '*' >> return True) <|> parseBool

--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_string
	liftM (uncurry (Tag c))
	 parseTag

parens :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a
parens = between (parseLexeme $ char '(') (parseLexeme $ char ')')

operators :: Stream s m Char => R.OperatorTable s u m Filter
operators =
	[ [ prefix "- "   Filter.Not
	  , prefix "not " Filter.Not
	  ]
	, [ binary " & "   Filter.And R.AssocLeft
	  , binary " and " Filter.And R.AssocLeft
	  , binary " - "   (\x y -> Filter.And x (Filter.Not y)) R.AssocLeft
	  , binary " but " (\x y -> Filter.And x (Filter.Not y)) R.AssocLeft
	  ]
	, [ binary " + "  Filter.Or R.AssocLeft
	  , binary " or " Filter.Or R.AssocLeft
	  ]
	]
	where
		binary  name fun assoc = R.Infix  (do{ operator name; return fun }) assoc
		prefix  name fun       = R.Prefix (do{ operator name; return fun })
		-- postfix name fun       = Text.Parsec.Expr.Postfix (do{ operator name; return fun })

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

operator :: Stream s m Char => String -> ParsecT s u m ()
operator name =
	parseLexeme $ try $
	do{ R.string name
	  ; R.notFollowedBy operator_letter <?> ("end of " ++ show name)
	  }

parseFilterTerm :: Stream s m Char => ParsecT s Context m Filter
parseFilterTerm = do
	r <- R.choice_try
	 [ R.lookAhead (char '(')
		>> (return $
			parens (liftM (foldl (\acc x -> case acc of { Any -> x; _ -> And acc x }) Any) $
			R.many $ (parseWhiteSpace >> R.lookAhead R.anyToken >> R.notFollowedBy (char ')') >> parseFilterExpr)))
	 , jump [ "account","acct" ] comp_string parseFilterAccount
	 , jump [ "amount", "amt" ] comp_number parseFilterAmount
	 , jump [ "atag" ] comp_string parseFilterATag
	 , jump [ "balance", "bal" ] comp_number parseFilterBalance
	 -- , jump [ "code" ] comp_string parseFilterCode
	 , jump [ "date" ] (char '=') parseFilterDate
	 , jump [ "date2", "edate" ] (char '=') parseFilterDate2
	 , jump [ "depth" ] comp_number parseFilterDepth
	 , jump [ "description","descr","desc" ] comp_string parseFilterDesc
	 , jump [ "real" ] (char '=') parseFilterReal
	 , jump [ "status" ] (char '=') parseFilterStatus
	 -- , jump [ "sym" ] comp_string parseFilterSym
	 , jump [ "tag" ] comp_string parseFilterTag
	 , R.lookAhead comp_number >> return parseFilterAmount
	 , return parseFilterAccount
	 ] <* parseWhiteSpace <?> "query expression"
	r
	where
		jump l next r = R.choice_try (map (\s -> R.string s >> return r) l) <* R.lookAhead next

expr :: Stream s m Char => ParsecT s Context m Filter
expr = R.buildExpressionParser operators parseFilterTerm <?> "query"

filter :: Stream s m Char => ParsecT s Context m Filter
filter =
	liftM (foldl (\acc x -> case acc of { Any -> x; _ -> And acc x }) Any) $
		R.many $ (parseWhiteSpace >> R.lookAhead R.anyToken >> parseFilterExpr)

{-

query :: Day -> String -> Either ParseError Filter
query d s = runParser (parseFilter <* eof) QCtx{qCtxDay=d} "" s

simplifyFilter :: Filter -> Filter
simplifyFilter q =
  -- let q' = simplify q
  -- in if q' == q then q else simplifyFilter q'
  simplify q -- NOTE: should be stable without recurring
  where
    simplify (And None _) = None
    simplify (And _ None) = None
    simplify (And Any Any) = Any
    simplify (And q q'@(Date _)) = simplify (And q' q) -- XXX: useful?
    simplify (And q q') | q == q' = simplify q
                        | otherwise = case (simplify q, simplify q') of
                                       (None, _) -> None
                                       (_, None) -> None
                                       (Any, q') -> q'
                                       (q, Any) -> q
                                       (q, q') -> And q q'
    simplify (Or None q') = simplify q'
    simplify (Or q None) = simplify q
    simplify (Or Any _) = Any
    simplify (Or _ Any) = Any
    -- simplify (Or q q'@(Date _)) = simplify (Or q' q)
    simplify (Or q q') | q == q' = simplify q
                       | otherwise = case (simplify q, simplify q') of
                                      (None, q') -> q'
                                      (q, None) -> q
                                      (Any, _) -> q'
                                      (_, Any) -> q
                                      (q, q') -> Or q q'
    simplify (Date (DateSpan Nothing Nothing)) = Any
    simplify (Date2 (DateSpan Nothing Nothing)) = Any
    simplify q = q
-}