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