{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} module Hcompta.Model.Filter where import Prelude hiding (filter) import Control.Applicative (pure, (<$>), (<*>)) import Data.Data import qualified Data.Foldable import Data.Foldable (Foldable(..)) import Data.Traversable (Traversable(..)) 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 qualified Hcompta.Lib.Foldable as Lib.Foldable import Hcompta.Lib.Regex (Regex) import qualified Hcompta.Model.Date as Date () import Hcompta.Model.Date (Date) import qualified Hcompta.Model.Account as Account import Hcompta.Model.Account (Account) -- import qualified Hcompta.Model.Date as Date import qualified Hcompta.Calc.Balance as Calc.Balance -- * Requirements' interface -- ** Class 'Unit' class Unit a where unit_text :: a -> Text -- ** Class 'Amount' class ( Ord (Amount_Quantity a) , Show (Amount_Quantity a) , Show (Amount_Unit a) , Unit (Amount_Unit a) ) => Amount a where type Amount_Quantity a type Amount_Unit a amount_unit :: a -> Amount_Unit a amount_quantity :: a -> Amount_Quantity a instance (Amount a, Calc.Balance.Amount a) => Amount (Calc.Balance.Amount_Sum a) where type Amount_Quantity (Calc.Balance.Amount_Sum a) = Amount_Quantity a type Amount_Unit (Calc.Balance.Amount_Sum a) = Amount_Unit a amount_quantity = amount_quantity . Calc.Balance.amount_sum_balance amount_unit = amount_unit . Calc.Balance.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] -- ** Class 'Balance' class Amount (Balance_Amount b) => Balance b where type Balance_Amount b balance_account :: b -> Account balance_amount :: b -> Balance_Amount b instance (Amount a, Calc.Balance.Amount a) => Balance (Account, Calc.Balance.Amount_Sum a) where type Balance_Amount (Account, Calc.Balance.Amount_Sum a) = a balance_account = fst balance_amount = Calc.Balance.amount_sum_balance . snd -- * 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_Exact Text | Test_Text_Regex Regex deriving (Eq, Show, Typeable) instance Test Test_Text Text where test p x = case p of 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_Lt_Eq o | Test_Ord_Gt o | Test_Ord_Gt_Eq o | Test_Ord_Eq o 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 -> (<) o x Test_Ord_Lt_Eq o -> (<=) o x Test_Ord_Gt o -> (>) o x Test_Ord_Gt_Eq o -> (>=) o x Test_Ord_Eq o -> (==) o x -- ** 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) 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_Skip | 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_Skip] _ = True comp [] _ = True {- comp (s:[]) (n:_) = case s of Test_Account_Section_Any -> True Test_Account_Section_Skip -> 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_Skip -> 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_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 -- ** Type 'Test_Transaction' data Transaction t => Test_Transaction t = Test_Transaction_Description Test_Text | Test_Transaction_Posting (Test_Posting (Transaction_Posting t)) deriving (Typeable) deriving instance Transaction t => Eq (Test_Transaction t) 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) $ Lib.Foldable.Composition $ transaction_postings t -- ** Type 'Test_Balance' data Balance b => Test_Balance b = Test_Balance_Account Test_Account | Test_Balance_Amount (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