lib/Hcompta/Model/Filter.hs

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