lib/Hcompta/Model/Filter.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE MultiParamTypeClasses #-}
   5 {-# LANGUAGE StandaloneDeriving #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 module Hcompta.Model.Filter where
   8
   9 import           Prelude hiding (filter)
  10 import           Control.Applicative (pure, (<$>), (<*>))
  11 import           Data.Data
  12 import qualified Data.Foldable
  13 import           Data.Foldable (Foldable(..))
  14 import           Data.Traversable (Traversable(..))
  15 import           Data.Monoid (Monoid(..))
  16 import           Data.Typeable ()
  17 import           Data.Text (Text)
  18 -- import qualified Data.Text as Text
  19 -- import qualified Data.Map.Strict as Data.Map
  20 import           Data.Map.Strict (Map)
  21 import           Text.Regex.TDFA ()
  22 import           Text.Regex.Base ()
  23 import           Text.Regex.TDFA.Text ()
  24
  25 import qualified Data.List.NonEmpty as NonEmpty
  26 -- import           Data.List.NonEmpty (NonEmpty(..))
  27 import qualified Hcompta.Lib.Regex as Regex
  28 import qualified Hcompta.Lib.Foldable as Lib.Foldable
  29 import           Hcompta.Lib.Regex (Regex)
  30 import qualified Hcompta.Model.Date as Date ()
  31 import           Hcompta.Model.Date (Date)
  32 import qualified Hcompta.Model.Account as Account
  33 import           Hcompta.Model.Account (Account)
  34 -- import qualified Hcompta.Model.Date as Date
  35 import qualified Hcompta.Calc.Balance as Calc.Balance
  36
  37 -- * Requirements' interface
  38
  39 -- ** Class 'Unit'
  40
  41 class Unit a where
  42         unit_text :: a -> Text
  43
  44 -- ** Class 'Amount'
  45
  46 class
  47  ( Ord  (Amount_Quantity a)
  48  , Show (Amount_Quantity a)
  49  , Show (Amount_Unit a)
  50  , Unit (Amount_Unit a)
  51  )
  52  => Amount a where
  53         type Amount_Quantity a
  54         type Amount_Unit     a
  55         amount_unit     :: a -> Amount_Unit a
  56         amount_quantity :: a -> Amount_Quantity a
  57
  58 instance (Amount a, Calc.Balance.Amount a)
  59  => Amount (Calc.Balance.Amount_Sum a) where
  60         type Amount_Quantity (Calc.Balance.Amount_Sum a) = Amount_Quantity a
  61         type Amount_Unit     (Calc.Balance.Amount_Sum a) = Amount_Unit     a
  62         amount_quantity = amount_quantity . Calc.Balance.amount_sum_balance
  63         amount_unit     = amount_unit     . Calc.Balance.amount_sum_balance
  64
  65 -- ** Class 'Posting'
  66
  67 class Amount (Posting_Amount p)
  68  => Posting p where
  69         type Posting_Amount p
  70         posting_account :: p -> Account
  71         posting_amounts :: p -> Map (Amount_Unit (Posting_Amount p)) (Posting_Amount p)
  72
  73 -- ** Class 'Transaction'
  74
  75 class Posting (Transaction_Posting t)
  76  => Transaction t where
  77         type Transaction_Posting t
  78         transaction_date        :: t -> Date
  79         transaction_description :: t -> Text
  80         transaction_postings    :: t -> Map Account [Transaction_Posting t]
  81
  82 -- ** Class 'Balance'
  83
  84 class Amount (Balance_Amount b)
  85  => Balance b where
  86         type Balance_Amount b
  87         balance_account :: b -> Account
  88         balance_amount  :: b -> Balance_Amount b
  89
  90 instance (Amount a, Calc.Balance.Amount a)
  91  => Balance (Account, Calc.Balance.Amount_Sum a) where
  92         type Balance_Amount (Account, Calc.Balance.Amount_Sum a) = a
  93         balance_account = fst
  94         balance_amount  = Calc.Balance.amount_sum_balance . snd
  95
  96 -- * Class 'Test'
  97
  98 class Test p x where
  99         test :: p -> x -> Bool
 100
 101 filter
 102  :: (Foldable t, Test p x, Monoid x)
 103  => p -> t x -> x
 104 filter p =
 105         Data.Foldable.foldMap
 106          (\x -> if test p x then x else mempty)
 107
 108 -- ** Type 'Test_Text'
 109
 110 data Test_Text
 111  =   Test_Text_Exact Text
 112  |   Test_Text_Regex Regex
 113  deriving (Eq, Show, Typeable)
 114
 115 instance Test Test_Text Text where
 116         test p x =
 117                 case p of
 118                  Test_Text_Exact m -> (==) m x
 119                  Test_Text_Regex m -> Regex.match m x
 120
 121 -- ** Type 'Test_Ord'
 122
 123 data     Ord        o
 124  => Test_Ord        o
 125  =  Test_Ord_Lt     o
 126  |  Test_Ord_Lt_Eq  o
 127  |  Test_Ord_Gt     o
 128  |  Test_Ord_Gt_Eq  o
 129  |  Test_Ord_Eq     o
 130  deriving (Data, Eq, Show, Typeable)
 131
 132 instance (Ord o, o ~ x)
 133  => Test (Test_Ord o) x where
 134         test p x =
 135                 case p of
 136                  Test_Ord_Lt    o -> (<)  o x
 137                  Test_Ord_Lt_Eq o -> (<=) o x
 138                  Test_Ord_Gt    o -> (>)  o x
 139                  Test_Ord_Gt_Eq o -> (>=) o x
 140                  Test_Ord_Eq    o -> (==) o x
 141
 142 -- ** Type 'Test_Num_Abs'
 143
 144 newtype Num n
 145  => Test_Num_Abs n
 146  =  Test_Num_Abs (Test_Ord n)
 147  deriving (Data, Eq, Show, Typeable)
 148
 149 instance (Num n, Ord x, n ~ x)
 150  => Test (Test_Num_Abs n) x where
 151         test (Test_Num_Abs f) x = test f (abs x)
 152
 153 -- ** Type 'Test_Bool'
 154
 155 data Test_Bool p
 156  =   Any
 157  |   Bool p
 158  |   Not (Test_Bool p)
 159  |   And (Test_Bool p) (Test_Bool p)
 160  |   Or  (Test_Bool p) (Test_Bool p)
 161  deriving (Show)
 162 instance Functor Test_Bool where
 163         fmap _ Any         = Any
 164         fmap f (Bool x)    = Bool (f x)
 165         fmap f (Not t)     = Not (fmap f t)
 166         fmap f (And t0 t1) = And (fmap f t0) (fmap f t1)
 167         fmap f (Or  t0 t1) = Or  (fmap f t0) (fmap f t1)
 168 instance Foldable Test_Bool where
 169         foldr _ acc Any         = acc
 170         foldr f acc (Bool p)    = f p acc
 171         foldr f acc (Not t)     = Data.Foldable.foldr f acc t
 172         foldr f acc (And t0 t1) = Data.Foldable.foldr f (Data.Foldable.foldr f acc t0) t1
 173         foldr f acc (Or  t0 t1) = Data.Foldable.foldr f (Data.Foldable.foldr f acc t0) t1
 174 instance Traversable Test_Bool where
 175         traverse _ Any         = pure Any
 176         traverse f (Bool x)    = Bool <$> f x
 177         traverse f (Not t)     = Not  <$> traverse f t
 178         traverse f (And t0 t1) = And  <$> traverse f t0 <*> traverse f t1
 179         traverse f (Or  t0 t1) = Or   <$> traverse f t0 <*> traverse f t1
 180 instance Test p x => Test (Test_Bool p) x where
 181         test Any         _ = True
 182         test (Bool p)    x = test p x
 183         test (Not t)     x = not $ test t x
 184         test (And t0 t1) x = test t0 x && test t1 x
 185         test (Or  t0 t1) x = test t0 x || test t1 x
 186
 187 bool :: Test p x => Test_Bool p -> x -> Bool
 188 bool Any         _ = True
 189 bool (Bool p)    x = test p x
 190 bool (Not t)     x = not $ test t x
 191 bool (And t0 t1) x = test t0 x && test t1 x
 192 bool (Or  t0 t1) x = test t0 x || test t1 x
 193
 194 -- ** Type 'Test_Unit'
 195
 196 newtype Test_Unit
 197  =      Test_Unit Test_Text
 198  deriving (Eq, Show, Typeable)
 199
 200 instance Unit u => Test Test_Unit u where
 201         test (Test_Unit f) = test f . unit_text
 202
 203 -- ** Type 'Test_Account'
 204
 205 type Test_Account
 206  =  [Test_Account_Section]
 207
 208 data Test_Account_Section
 209  =   Test_Account_Section_Any
 210  |   Test_Account_Section_Skip
 211  |   Test_Account_Section_Text Test_Text
 212  deriving (Eq, Show, Typeable)
 213
 214 instance Test Test_Account Account where
 215         test f acct =
 216                 comp f (NonEmpty.toList acct)
 217                 where
 218                         comp :: [Test_Account_Section] -> [Account.Name] -> Bool
 219                         comp [] [] = True
 220                         comp [Test_Account_Section_Skip] _  = True
 221                         comp [] _  = True
 222                         {-
 223                         comp (s:[]) (n:_) =
 224                                 case s of
 225                                  Test_Account_Section_Any    -> True
 226                                  Test_Account_Section_Skip   -> True
 227                                  Test_Account_Section_Text m -> test m n
 228                         -}
 229                         comp so@(s:ss) no@(n:ns) =
 230                                 case s of
 231                                  Test_Account_Section_Any    -> comp ss ns
 232                                  Test_Account_Section_Skip   -> comp ss no || comp so ns
 233                                  Test_Account_Section_Text m -> test m n && comp ss ns
 234                         comp _ []  = False
 235
 236 -- ** Type 'Test_Amount'
 237
 238 type Test_Quantity q
 239  =   Test_Ord q
 240
 241 data     Amount a
 242  => Test_Amount a
 243  =  Test_Amount
 244  {  test_amount_quantity :: Test_Quantity (Amount_Quantity a)
 245  ,  test_amount_unit     :: Test_Unit
 246  } deriving (Typeable)
 247 deriving instance Amount a => Eq   (Test_Amount a)
 248 deriving instance Amount a => Show (Test_Amount a)
 249
 250 instance Amount a
 251  => Test (Test_Amount a) a where
 252         test (Test_Amount fq fu) amt =
 253                 test fu (amount_unit amt) &&
 254                 test fq (amount_quantity amt)
 255
 256 -- ** Type 'Test_Posting'
 257
 258 data     Posting posting
 259  => Test_Posting posting
 260  =  Test_Posting_Account Test_Account
 261  |  Test_Posting_Amount (Test_Amount (Posting_Amount posting))
 262  |  Test_Posting_Unit Test_Unit
 263  deriving (Typeable)
 264  -- Virtual
 265  -- Description Comp_String String
 266  -- Date Date.Span
 267  -- Account_Tag Comp_String String (Maybe (Comp_String, String))
 268  -- Account_Balance Comp_Num Comp_Num_Absolute Amount
 269  -- Depth Comp_Num Int
 270  -- None
 271  -- Real Bool
 272  -- Status Bool
 273  -- Tag Comp_String Tag.Name (Maybe (Comp_String, Tag.Value))
 274 deriving instance Posting p => Eq   (Test_Posting p)
 275 deriving instance Posting p => Show (Test_Posting p)
 276
 277 instance Posting p
 278  => Test (Test_Posting p) p where
 279         test (Test_Posting_Account f) p =
 280                 test f $ posting_account p
 281         test (Test_Posting_Amount  f) p =
 282                 Data.Foldable.any (test f) $ posting_amounts p
 283         test (Test_Posting_Unit    f) p =
 284                 Data.Foldable.any (test f . amount_unit) $ posting_amounts p
 285
 286 newtype Cross t = Cross t
 287 instance (Transaction t, Transaction_Posting t ~ p, Posting p)
 288  => Test (Test_Transaction t) (Cross p) where
 289         test pr (Cross p) =
 290                 case pr of
 291                  (Test_Transaction_Description _) -> True
 292                  (Test_Transaction_Posting     f) -> test f p
 293
 294 -- ** Type 'Test_Transaction'
 295
 296 data      Transaction t
 297  =>  Test_Transaction t
 298  =   Test_Transaction_Description Test_Text
 299  |   Test_Transaction_Posting (Test_Posting (Transaction_Posting t))
 300  deriving (Typeable)
 301 deriving instance Transaction t => Eq   (Test_Transaction t)
 302 deriving instance Transaction t => Show (Test_Transaction t)
 303
 304 instance Transaction t
 305  => Test (Test_Transaction t) t where
 306         test (Test_Transaction_Description f) t =
 307                 test f $ transaction_description t
 308         test (Test_Transaction_Posting f) t =
 309                 Data.Foldable.any (test f) $
 310                 Lib.Foldable.Composition $
 311                 transaction_postings t
 312
 313 -- ** Type 'Test_Balance'
 314
 315 data      Balance b
 316  =>  Test_Balance b
 317  =   Test_Balance_Account         Test_Account
 318  |   Test_Balance_Amount          (Test_Amount (Balance_Amount b))
 319  deriving (Typeable)
 320 deriving instance Balance b => Eq   (Test_Balance b)
 321 deriving instance Balance b => Show (Test_Balance b)
 322
 323 instance Balance b
 324  => Test (Test_Balance b) b where
 325         test (Test_Balance_Account f) b =
 326                 test f $ balance_account b
 327         test (Test_Balance_Amount f) b =
 328                 test f $ balance_amount b