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