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