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

import           Prelude hiding (filter)
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           Data.Traversable (Traversable(..))
import qualified Data.Monoid
import           Data.Monoid (Monoid(..))
import           Data.Typeable ()
import           Data.Text (Text)
-- import qualified Data.Text as Text
import qualified Data.Map.Strict as Data.Map
import           Data.Map.Strict (Map)
import           Text.Regex.TDFA ()
import           Text.Regex.Base ()
import           Text.Regex.TDFA.Text ()

import qualified Data.List.NonEmpty as NonEmpty
-- import           Data.List.NonEmpty (NonEmpty(..))
import qualified Hcompta.Lib.Regex as Regex
import           Hcompta.Lib.Regex (Regex)
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

-- * Class 'Test'

class Test p x where
	test :: p -> x -> Bool

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     Ord     o
 => 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 (Ord o, o ~ x)
 => Test (Test_Ord o) x where
	test p 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

-- ** Type 'Test_Range'

data Test_Range a
 =   Test_Range_Eq a
 |   Test_Range_In (Maybe a) (Maybe a)
 deriving (Show)

test_range_all :: Test_Range a
test_range_all =
	Test_Range_In Nothing Nothing

instance (Ord o, o ~ x)
 => Test (Test_Range o) x where
	test p x =
		case p of
		 Test_Range_Eq o                   -> (==)  x o
		 Test_Range_In (Just a0) (Just a1) -> (<=) a0 x && (<=) x a1
		 Test_Range_In Nothing   (Just a1) ->              (<=) x a1
		 Test_Range_In (Just a0) Nothing   -> (<=) a0 x
		 Test_Range_In Nothing   Nothing   -> True
instance Functor Test_Range where
	fmap f (Test_Range_Eq a)     = Test_Range_Eq (f a)
	fmap f (Test_Range_In a0 a1) = Test_Range_In (fmap f a0) (fmap f a1)

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

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 (amount_quantity amt)

-- ** Type 'Test_Date'

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

instance Test Test_Date Date where
	test (Test_Date_UTC    f) d = test f d
	test (Test_Date_Year   f) d = test f $ Date.year   d
	test (Test_Date_Month  f) d = test f $ Date.month  d
	test (Test_Date_DoM    f) d = test f $ Date.dom    d
	test (Test_Date_Hour   f) d = test f $ Date.hour   d
	test (Test_Date_Minute f) d = test f $ Date.minute d
	test (Test_Date_Second f) d = test f $ 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