{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module Hcompta.Filter where

-- import           Control.Applicative (pure, (<$>), (<*>))
import           Data.Data
import qualified Data.Fixed
import qualified Data.Foldable
-- import           Data.Foldable (Foldable(..))
import qualified Data.Functor.Compose
-- import qualified Data.List
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Data.Map
import qualified Data.Monoid
-- import           Data.Monoid (Monoid(..))
import           Data.Text (Text)
-- import qualified Data.Text as Text
-- import qualified Data.Time.Calendar as Time
-- import           Data.Traversable (Traversable(..))
import           Data.Typeable ()
import           Prelude hiding (filter)
import           Text.Regex.Base ()
import           Text.Regex.TDFA ()
import           Text.Regex.TDFA.Text ()

import qualified Data.List.NonEmpty as NonEmpty
-- import           Data.List.NonEmpty (NonEmpty(..))
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.Lib.TreeMap as TreeMap
-- import           Hcompta.Lib.TreeMap (TreeMap)
import qualified Hcompta.Amount as Amount
import qualified Hcompta.Amount.Unit as Amount.Unit
import qualified Hcompta.Date as Date
import           Hcompta.Date (Date)
import qualified Hcompta.Account as Account
import           Hcompta.Account (Account)
-- import qualified Hcompta.Date as Date
import qualified Hcompta.Balance as Balance
import qualified Hcompta.GL as GL

-- * Requirements' interface

-- ** Class 'Unit'

class Unit a where
	unit_text :: a -> Text

instance Unit Amount.Unit where
	unit_text = Amount.Unit.text

instance Unit Text where
	unit_text = id

-- ** Class 'Amount'

class
 ( Ord  (Amount_Quantity a)
 , Show (Amount_Quantity a)
 , Show (Amount_Unit a)
 , Unit (Amount_Unit a)
 )
 =>  Amount a where
	type Amount_Unit     a
	type Amount_Quantity a
	amount_unit     :: a -> Amount_Unit a
	amount_quantity :: a -> Amount_Quantity a

instance Amount Amount.Amount where
	type Amount_Unit     Amount.Amount = Amount.Unit
	type Amount_Quantity Amount.Amount = Amount.Quantity
	amount_quantity = Amount.quantity
	amount_unit     = Amount.unit

instance (Amount a, GL.Amount a)
 => Amount (Amount.Sum a) where
	type Amount_Unit     (Amount.Sum a) = Amount_Unit a
	type Amount_Quantity (Amount.Sum a) = Amount_Quantity a
	amount_quantity = amount_quantity . Amount.sum_balance
	amount_unit     = amount_unit     . Amount.sum_balance

-- ** Class 'Posting'

class Amount (Posting_Amount p)
 => Posting p where
	type Posting_Amount p
	posting_account :: p -> Account
	posting_amounts :: p -> Map (Amount_Unit (Posting_Amount p)) (Posting_Amount p)

-- ** Class 'Transaction'

class Posting (Transaction_Posting t)
 => Transaction t where
	type Transaction_Posting t
	transaction_date        :: t -> Date
	transaction_description :: t -> Text
	transaction_postings    :: t -> Map Account [Transaction_Posting t]
	transaction_tags        :: t -> Map Text [Text]

-- ** Class 'Balance'

class Amount (Balance_Amount b)
 => Balance b where
	type Balance_Amount b
	balance_account  :: b -> Account
	balance_amount   :: b -> Balance_Amount b
	balance_positive :: b -> Maybe (Balance_Amount b)
	balance_negative :: b -> Maybe (Balance_Amount b)

instance (Amount a, Balance.Amount a)
 => Balance (Account, Amount.Sum a) where
	type Balance_Amount (Account, Amount.Sum a) = a
	balance_account = fst
	balance_amount (_, amt) =
		case amt of
		 Amount.Sum_Negative n -> n
		 Amount.Sum_Positive p -> p
		 Amount.Sum_Both n p   -> Balance.amount_add n p
	balance_positive = Amount.sum_positive . snd
	balance_negative = Amount.sum_negative . snd

-- ** Class 'GL'

class Amount (GL_Amount r)
 => GL r where
	type GL_Amount r
	gl_account         :: r -> Account
	gl_date            :: r -> Date
	gl_amount_positive :: r -> Maybe (GL_Amount r)
	gl_amount_negative :: r -> Maybe (GL_Amount r)
	gl_amount_balance  :: r ->        GL_Amount r
	gl_sum_positive    :: r -> Maybe (GL_Amount r)
	gl_sum_negative    :: r -> Maybe (GL_Amount r)
	gl_sum_balance     :: r ->        GL_Amount r

instance (Amount a, GL.Amount a)
 => GL (Account, Date, Amount.Sum a, Amount.Sum a) where
	type GL_Amount (Account, Date, Amount.Sum a, Amount.Sum a) = a
	gl_account         (x, _, _, _) = x
	gl_date            (_, x, _, _) = x
	gl_amount_positive (_, _, x, _) = Amount.sum_positive x
	gl_amount_negative (_, _, x, _) = Amount.sum_negative x
	gl_amount_balance  (_, _, x, _) = Amount.sum_balance  x
	gl_sum_positive    (_, _, _, x) = Amount.sum_positive x
	gl_sum_negative    (_, _, _, x) = Amount.sum_negative x
	gl_sum_balance     (_, _, _, x) = Amount.sum_balance  x

-- * Newtypes to avoid overlapping instances

newtype Scalar x
 =      Scalar x
instance Functor Scalar where
	fmap f (Scalar x) = Scalar (f x)

-- * Class 'Test'

newtype Simplified p
 = Simplified { simplified :: Either p Bool }
 deriving (Eq, Show)
instance Functor Simplified where
	fmap _f (Simplified (Right b)) = Simplified (Right b)
	fmap f  (Simplified (Left x))  = Simplified (Left $ f x)

-- | Conjonctive ('&&') 'Monoid'.
instance Monoid p => Monoid (Simplified p) where
	mempty = Simplified (Right True)
	mappend (Simplified x) (Simplified y) =
		Simplified $
		case (x, y) of
		 (Right bx   , Right by   ) -> Right (bx && by)
		 (Right True , Left _fy   ) -> y
		 (Right False, Left _fy   ) -> x
		 (Left _fx   , Right True ) -> x
		 (Left _fx   , Right False) -> y
		 (Left fx    , Left  fy   ) -> Left $ fx `mappend` fy

class Test p x where
	test :: p -> x -> Bool
	simplify :: p -> Maybe x -> Simplified p
	simplify p _x = Simplified $ Left p

filter
 :: (Foldable t, Test p x, Monoid x)
 => p -> t x -> x
filter p =
	Data.Foldable.foldMap
	 (\x -> if test p x then x else mempty)

-- ** Type 'Test_Text'

data Test_Text
 =   Test_Text_Any
 |   Test_Text_Exact Text
 |   Test_Text_Regex Regex
 deriving (Eq, Show, Typeable)

instance Test Test_Text Text where
	test p x =
		case p of
		 Test_Text_Any     -> True
		 Test_Text_Exact m -> (==) m x
		 Test_Text_Regex m -> Regex.match m x

-- ** Type 'Test_Ord'

data Test_Ord    o
 =  Test_Ord_Lt  o
 |  Test_Ord_Le  o
 |  Test_Ord_Gt  o
 |  Test_Ord_Ge  o
 |  Test_Ord_Eq  o
 |  Test_Ord_Any
 deriving (Data, Eq, Show, Typeable)

instance Functor Test_Ord where
	fmap f x =
		case x of
		 Test_Ord_Lt o -> Test_Ord_Lt (f o)
		 Test_Ord_Le o -> Test_Ord_Le (f o)
		 Test_Ord_Gt o -> Test_Ord_Gt (f o)
		 Test_Ord_Ge o -> Test_Ord_Ge (f o)
		 Test_Ord_Eq o -> Test_Ord_Eq (f o)
		 Test_Ord_Any  -> Test_Ord_Any
instance (Ord o, o ~ x)
 => Test (Test_Ord o) (Scalar x) where
	test p (Scalar x) =
		case p of
		 Test_Ord_Lt o -> (<)  x o
		 Test_Ord_Le o -> (<=) x o
		 Test_Ord_Gt o -> (>)  x o
		 Test_Ord_Ge o -> (>=) x o
		 Test_Ord_Eq o -> (==) x o
		 Test_Ord_Any  -> True
instance (Ord o, o ~ x)
 => Test (Test_Ord o) (Interval x) where
	test p i =
		let l = Interval.low i in
		let h = Interval.high i in
		case p of
		 Test_Ord_Lt o -> case compare (Interval.limit h) o of
		                   LT -> True
		                   EQ -> Interval.adherence h == Interval.Out
		                   GT -> False
		 Test_Ord_Le o -> Interval.limit h <= o
		 Test_Ord_Gt o -> case compare (Interval.limit l) o of
		                   LT -> False
		                   EQ -> Interval.adherence l == Interval.Out
		                   GT -> True
		 Test_Ord_Ge o -> Interval.limit l >= o
		 Test_Ord_Eq o -> Interval.limit l == o && Interval.limit h == o
		 Test_Ord_Any  -> True

-- ** Type 'Test_Interval'

data Test_Interval x
 =   Test_Interval_In (Interval (Interval.Unlimitable x))
 deriving (Eq, Ord, Show)
--instance Functor Test_Interval where
--	fmap f (Test_Interval_In i) = Test_Interval_In (fmap (fmap f) i)
instance (Ord o, o ~ x)
 => Test (Test_Interval o) (Scalar (Interval.Unlimitable x)) where
	test (Test_Interval_In p) (Scalar x) =
		Interval.locate x p == EQ
instance (Ord o, o ~ x)
 => Test (Test_Interval o) (Interval (Interval.Unlimitable x)) where
	test (Test_Interval_In p) i = Interval.into i p

-- ** Type 'Test_Num_Abs'

newtype Num n
 => Test_Num_Abs n
 =  Test_Num_Abs (Test_Ord n)
 deriving (Data, Eq, Show, Typeable)

instance (Num n, Ord x, n ~ x)
 => Test (Test_Num_Abs n) x where
	test (Test_Num_Abs f) x = test f (Scalar (abs x))

-- ** Type 'Test_Bool'

data Test_Bool p
 =   Any
 |   Bool p
 |   Not (Test_Bool p)
 |   And (Test_Bool p) (Test_Bool p)
 |   Or  (Test_Bool p) (Test_Bool p)
 deriving (Show)
deriving instance Eq p => Eq (Test_Bool p)
instance Functor Test_Bool where
	fmap _ Any         = Any
	fmap f (Bool x)    = Bool (f x)
	fmap f (Not t)     = Not (fmap f t)
	fmap f (And t0 t1) = And (fmap f t0) (fmap f t1)
	fmap f (Or  t0 t1) = Or  (fmap f t0) (fmap f t1)
-- | Conjonctive ('And') 'Monoid'.
instance Monoid (Test_Bool p) where
	mempty  = Any
	mappend = And
instance Foldable Test_Bool where
	foldr _ acc Any         = acc
	foldr f acc (Bool p)    = f p acc
	foldr f acc (Not t)     = Data.Foldable.foldr f acc t
	foldr f acc (And t0 t1) = Data.Foldable.foldr f (Data.Foldable.foldr f acc t0) t1
	foldr f acc (Or  t0 t1) = Data.Foldable.foldr f (Data.Foldable.foldr f acc t0) t1
instance Traversable Test_Bool where
	traverse _ Any         = pure Any
	traverse f (Bool x)    = Bool <$> f x
	traverse f (Not t)     = Not  <$> traverse f t
	traverse f (And t0 t1) = And  <$> traverse f t0 <*> traverse f t1
	traverse f (Or  t0 t1) = Or   <$> traverse f t0 <*> traverse f t1
instance Test p x => Test (Test_Bool p) x where
	test Any         _ = True
	test (Bool p)    x = test p x
	test (Not t)     x = not $ test t x
	test (And t0 t1) x = test t0 x && test t1 x
	test (Or  t0 t1) x = test t0 x || test t1 x
	
	simplify Any         _ = Simplified $ Right True
	simplify (Bool p)    x =
		Simplified $
		case simplified (simplify p x) of
		 Left p' -> Left (Bool p')
		 Right b -> Right b
	simplify (Not t)     x =
		Simplified $
		case simplified (simplify t x) of
		 Left p' -> Left (Not $ p')
		 Right b -> Right b
	simplify (And t0 t1) x =
		Simplified $
		case (simplified $ simplify t0 x, simplified $ simplify t1 x) of
		 (Right b0, Right  b1) -> Right (b0 && b1)
		 (Right b0, Left   p1) -> if b0 then Left p1 else Right False
		 (Left  p0, Right  b1) -> if b1 then Left p0 else Right False
		 (Left  p0, Left   p1) -> Left (And p0 p1)
	simplify (Or t0 t1) x =
		Simplified $
		case (simplified $ simplify t0 x, simplified $ simplify t1 x) of
		 (Right b0, Right b1) -> Right (b0 || b1)
		 (Right b0, Left  p1) -> if b0 then Right True else Left p1
		 (Left  p0, Right b1) -> if b1 then Right True else Left p0
		 (Left  p0, Left  p1) -> Left (Or p0 p1)

bool :: Test p x => Test_Bool p -> x -> Bool
bool Any         _ = True
bool (Bool p)    x = test p x
bool (Not t)     x = not $ test t x
bool (And t0 t1) x = test t0 x && test t1 x
bool (Or  t0 t1) x = test t0 x || test t1 x

-- ** Type 'Test_Unit'

newtype Test_Unit
 =      Test_Unit Test_Text
 deriving (Eq, Show, Typeable)

instance Unit u => Test Test_Unit u where
	test (Test_Unit f) = test f . unit_text

-- ** Type 'Test_Account'

type Test_Account
 =  [Test_Account_Section]

data Test_Account_Section
 =   Test_Account_Section_Any
 |   Test_Account_Section_Many
 |   Test_Account_Section_Text Test_Text
 deriving (Eq, Show, Typeable)

instance Test Test_Account Account where
	test f acct =
		comp f (NonEmpty.toList acct)
		where
			comp :: [Test_Account_Section] -> [Account.Name] -> Bool
			comp [] [] = True
			comp [Test_Account_Section_Many] _  = True
			comp [] _ = False
			{-
			comp (s:[]) (n:_) =
				case s of
				 Test_Account_Section_Any    -> True
				 Test_Account_Section_Many   -> True
				 Test_Account_Section_Text m -> test m n
			-}
			comp so@(s:ss) no@(n:ns) =
				case s of
				 Test_Account_Section_Any    -> comp ss ns
				 Test_Account_Section_Many   -> comp ss no || comp so ns
				 Test_Account_Section_Text m -> test m n && comp ss ns
			comp _ []  = False

-- ** Type 'Test_Amount'

type Test_Quantity q
 =   Test_Ord q

data     Amount a
 => Test_Amount a
 =  Test_Amount
 {  test_amount_quantity :: Test_Quantity (Amount_Quantity a)
 ,  test_amount_unit     :: Test_Unit
 } deriving (Typeable)
deriving instance Amount a => Eq   (Test_Amount a)
deriving instance Amount a => Show (Test_Amount a)

instance Amount a
 => Test (Test_Amount a) a where
	test (Test_Amount fq fu) amt =
		test fu (amount_unit amt) &&
		test fq (Scalar (amount_quantity amt))

-- ** Type 'Test_Date'

data Test_Date
 =   Test_Date_UTC    (Test_Ord      Date)
 |   Test_Date_Year   (Test_Interval Integer)
 |   Test_Date_Month  (Test_Interval Int)
 |   Test_Date_DoM    (Test_Interval Int)
 |   Test_Date_Hour   (Test_Interval Int)
 |   Test_Date_Minute (Test_Interval Int)
 |   Test_Date_Second (Test_Interval Data.Fixed.Pico)
 deriving (Typeable)
deriving instance Show (Test_Date)

instance Test Test_Date Date where
	test (Test_Date_UTC    f) d = test f $ Scalar d
	test (Test_Date_Year   f) d = test f $ Scalar $ Interval.Limited $ Date.year   d
	test (Test_Date_Month  f) d = test f $ Scalar $ Interval.Limited $ Date.month  d
	test (Test_Date_DoM    f) d = test f $ Scalar $ Interval.Limited $ Date.dom    d
	test (Test_Date_Hour   f) d = test f $ Scalar $ Interval.Limited $ Date.hour   d
	test (Test_Date_Minute f) d = test f $ Scalar $ Interval.Limited $ Date.minute d
	test (Test_Date_Second f) d = test f $ Scalar $ Interval.Limited $ Date.second d

instance Test Test_Date (Interval (Interval.Unlimitable Date)) where
	test (Test_Date_UTC    f) d = test (Interval.Limited <$> f)  d
	test (Test_Date_Year   f) d = maybe False (test f) $ Interval.fmap (fmap Date.year)   d
	test (Test_Date_Month  f) d = maybe False (test f) $ Interval.fmap (fmap Date.month)  d
	test (Test_Date_DoM    f) d = maybe False (test f) $ Interval.fmap (fmap Date.dom)    d
	test (Test_Date_Hour   f) d = maybe False (test f) $ Interval.fmap (fmap Date.hour)   d
	test (Test_Date_Minute f) d = maybe False (test f) $ Interval.fmap (fmap Date.minute) d
	test (Test_Date_Second f) d = maybe False (test f) $ Interval.fmap (fmap Date.second) d

-- ** Type 'Test_Tag'

data Test_Tag
 =   Test_Tag_Name  Test_Text
 |   Test_Tag_Value Test_Text
 deriving (Typeable)
deriving instance Show (Test_Tag)

instance Test Test_Tag (Text, Text) where
	test (Test_Tag_Name  f) (x, _) = test f x
	test (Test_Tag_Value f) (_, x) = test f x

-- ** Type 'Test_Posting'

data     Posting posting
 => Test_Posting posting
 =  Test_Posting_Account Test_Account
 |  Test_Posting_Amount (Test_Amount (Posting_Amount posting))
 |  Test_Posting_Unit Test_Unit
 deriving (Typeable)
 -- Virtual
 -- Description Comp_String String
 -- Date Date.Span
 -- Account_Tag Comp_String String (Maybe (Comp_String, String))
 -- Account_Balance Comp_Num Comp_Num_Absolute Amount
 -- Depth Comp_Num Int
 -- None
 -- Real Bool
 -- Status Bool
 -- Tag Comp_String Tag.Name (Maybe (Comp_String, Tag.Value))
deriving instance Posting p => Eq   (Test_Posting p)
deriving instance Posting p => Show (Test_Posting p)

instance Posting p
 => Test (Test_Posting p) p where
	test (Test_Posting_Account f) p =
		test f $ posting_account p
	test (Test_Posting_Amount  f) p =
		Data.Foldable.any (test f) $ posting_amounts p
	test (Test_Posting_Unit    f) p =
		Data.Foldable.any (test f . amount_unit) $ posting_amounts p

newtype Cross t = Cross t
instance (Transaction t, Transaction_Posting t ~ p, Posting p)
 => Test (Test_Transaction t) (Cross p) where
	test pr (Cross p) =
		case pr of
		 (Test_Transaction_Description _) -> True
		 (Test_Transaction_Posting     f) -> test f p
		 (Test_Transaction_Date        _) -> True  -- TODO: use posting_date
		 (Test_Transaction_Tag         _) -> False -- TODO: use posting_tags

-- ** Type 'Test_Transaction'

data      Transaction t
 =>  Test_Transaction t
 =   Test_Transaction_Description Test_Text
 |   Test_Transaction_Posting (Test_Posting (Transaction_Posting t))
 |   Test_Transaction_Date (Test_Bool Test_Date)
 |   Test_Transaction_Tag (Test_Bool Test_Tag)
 deriving (Typeable)
deriving instance Transaction t => Show (Test_Transaction t)

instance Transaction t
 => Test (Test_Transaction t) t where
	test (Test_Transaction_Description f) t =
		test f $ transaction_description t
	test (Test_Transaction_Posting f) t =
		Data.Foldable.any (test f) $
		Data.Functor.Compose.Compose $
		transaction_postings t
	test (Test_Transaction_Date f) t =
		test f $ transaction_date t
	test (Test_Transaction_Tag f) t =
		Data.Monoid.getAny $
		Data.Map.foldrWithKey
		 (\n -> mappend . Data.Monoid.Any .
			Data.Foldable.any (test f . (n,)))
		 (Data.Monoid.Any False) $
		transaction_tags t

-- ** Type 'Test_Balance'

data      Balance b
 =>  Test_Balance b
 =   Test_Balance_Account Test_Account
 |   Test_Balance_Amount   (Test_Amount (Balance_Amount b))
 |   Test_Balance_Positive (Test_Amount (Balance_Amount b))
 |   Test_Balance_Negative (Test_Amount (Balance_Amount b))
 deriving (Typeable)
deriving instance Balance b => Eq   (Test_Balance b)
deriving instance Balance b => Show (Test_Balance b)

instance Balance b
 => Test (Test_Balance b) b where
	test (Test_Balance_Account f) b =
		test f $ balance_account b
	test (Test_Balance_Amount f) b =
		test f $ balance_amount b
	test (Test_Balance_Positive f) b =
		Data.Foldable.any (test f) $
		balance_positive b
	test (Test_Balance_Negative f) b =
		Data.Foldable.any (test f) $
		balance_negative b

-- ** Type 'Test_GL'

data      GL r
 =>  Test_GL r
 =   Test_GL_Account Test_Account
 |   Test_GL_Amount_Positive (Test_Amount (GL_Amount r))
 |   Test_GL_Amount_Negative (Test_Amount (GL_Amount r))
 |   Test_GL_Amount_Balance  (Test_Amount (GL_Amount r))
 |   Test_GL_Sum_Positive    (Test_Amount (GL_Amount r))
 |   Test_GL_Sum_Negative    (Test_Amount (GL_Amount r))
 |   Test_GL_Sum_Balance     (Test_Amount (GL_Amount r))
 deriving (Typeable)
deriving instance GL r => Eq   (Test_GL r)
deriving instance GL r => Show (Test_GL r)

instance GL r
 => Test (Test_GL r) r where
	test (Test_GL_Account f) r =
		test f $ gl_account r
	test (Test_GL_Amount_Positive f) r =
		Data.Foldable.any (test f) $
		gl_amount_positive r
	test (Test_GL_Amount_Negative f) r =
		Data.Foldable.any (test f) $
		gl_amount_negative r
	test (Test_GL_Amount_Balance f) r =
		test f $ gl_amount_balance r
	test (Test_GL_Sum_Positive f) r =
		Data.Foldable.any (test f) $
		gl_sum_positive r
	test (Test_GL_Sum_Negative f) r =
		Data.Foldable.any (test f) $
		gl_sum_negative r
	test (Test_GL_Sum_Balance f) r =
		test f $ gl_sum_balance r