Ajout : Control.Monad.Classes.{StateFix,StateInstance}.
[comptalang.git] / lib / Hcompta / Filter.hs
index b197cb927583ba6fe93a46c030e4165d4a11260c..a6e8a3d901b07cf21bef4e54fb6e5457fc52beff 100644 (file)
@@ -43,7 +43,7 @@ import           Text.Regex.TDFA.Text ()
 import qualified Hcompta.Account as Account
 import           Hcompta.Account (Account_Tags(..))
 import qualified Hcompta.Balance as Balance
-import qualified Hcompta.Chart as Chart
+-- import qualified Hcompta.Chart as Chart
 import           Hcompta.Date (Date)
 import qualified Hcompta.Date as Date
 import qualified Hcompta.Filter.Amount as Filter.Amount
@@ -82,17 +82,19 @@ instance Path_Section Text where
 type Account_Section = Text
 type Account_Path = Path Account_Section
 
-class Account a where
+class Account a where
        account_path :: a -> Account_Path
-       account_tags :: a -> Account_Tags
+       account_tags :: j -> a -> Account_Tags
 
 instance Account (Account_Tags, Account_Path) where
        account_path = snd
-       account_tags = fst
+       account_tags _j = fst
 
+{-
 instance Account (Chart.Charted Account_Path Account_Path) where
        account_path = Chart.charted
        account_tags (Chart.Charted c a) = Chart.account_tags a c
+-}
 
 -- ** Class 'Amount'
 
@@ -128,48 +130,17 @@ instance Amount Filter.Amount.Amount where
 
 class
  ( Posting.Posting p
- , Account (Posting.Posting_Account p)
- , Amount  (Posting.Posting_Amount  p)
- ) => Posting p where
-       posting_type :: p -> Posting_Type
-
-data Posting_Type
- =   Posting_Type_Regular
- |   Posting_Type_Virtual
- deriving (Data, Eq, Show, Typeable)
-
-newtype Posting_Typed posting
- =      Posting_Typed (Posting_Type, posting)
- deriving (Data, Show, Functor)
-
-instance
- ( Posting.Posting p
- ) =>      Posting.Posting (Posting_Typed p) where
-       type   Posting_Account (Posting_Typed p) = Posting.Posting_Account p
-       type   Posting_Amount  (Posting_Typed p) = Posting.Posting_Amount  p
-       type   Posting_Amounts (Posting_Typed p) = Posting.Posting_Amounts p
-       posting_account        (Posting_Typed p) = Posting.posting_account (snd p)
-       posting_amounts        (Posting_Typed p) = Posting.posting_amounts (snd p)
-instance Posting p
- =>      Posting (Posting_Typed p) where
-       posting_type   (Posting_Typed p) = fst p
-
-instance Balance.Posting p
- =>      Balance.Posting (Posting_Typed p) where
-       type Posting_Account   (Posting_Typed p) = Balance.Posting_Account  p
-       type Posting_Quantity  (Posting_Typed p) = Balance.Posting_Quantity p
-       type Posting_Unit      (Posting_Typed p) = Balance.Posting_Unit     p
-       posting_account        (Posting_Typed p) = Balance.posting_account (snd p)
-       posting_amounts        (Posting_Typed p) = Balance.posting_amounts (snd p)
-       posting_set_amounts  m (Posting_Typed p) = Posting_Typed $ second (Balance.posting_set_amounts m) p
+ , Account j (Posting.Posting_Account p)
+ , Amount    (Posting.Posting_Amount  p)
+ ) => Posting j p
 
 -- ** Class 'Transaction'
 
 class
- ( Posting  (Transaction_Posting  t)
- , Foldable (Transaction_Postings t)
+ ( Posting  (Transaction_Posting  t)
+ , Foldable   (Transaction_Postings t)
  )
- =>    Transaction          t where
+ =>    Transaction        j t where
        type Transaction_Posting  t
        type Transaction_Postings t :: * -> *
        transaction_date            :: t -> Date
@@ -180,9 +151,9 @@ class
 -- ** Class 'Balance'
 
 class
- ( Account (Balance_Account b)
+ ( Account (Balance_Account b)
  , Amount  (Balance_Amount  b)
- ) =>  Balance         b where
+ ) =>  Balance       j b where
        type Balance_Account b
        type Balance_Amount  b
        balance_account :: b -> Balance_Account b
@@ -200,9 +171,9 @@ instance
 -- ** Class 'GL'
 
 class
- ( Account (GL_Account g)
- , Amount  (GL_Amount  g)
- ) =>  GL         g where
+ ( Account (GL_Account g)
+ , Amount    (GL_Amount  g)
+ ) =>  GL       j g where
        type GL_Account g
        type GL_Amount  g
        gl_account :: g -> GL_Account g
@@ -355,16 +326,16 @@ instance Ord o
                let h = Interval.high i in
                case f of
                 Filter_Ord Lt o -> case compare (Interval.limit h) o of
-                                  LT -> True
-                                  EQ -> Interval.adherence h == Interval.Out
-                                  GT -> False
+                                    LT -> True
+                                    EQ -> Interval.adherence h == Interval.Out
+                                    GT -> False
                 Filter_Ord Le o -> Interval.limit h <= o
                 Filter_Ord Eq o -> Interval.limit l == o && Interval.limit h == o
                 Filter_Ord Ge o -> Interval.limit l >= o
                 Filter_Ord Gt o -> case compare (Interval.limit l) o of
-                                  LT -> False
-                                  EQ -> Interval.adherence l == Interval.Out
-                                  GT -> True
+                                    LT -> False
+                                    EQ -> Interval.adherence l == Interval.Out
+                                    GT -> True
                 Filter_Ord_Any  -> True
        simplify f =
                Simplified $
@@ -605,8 +576,8 @@ deriving instance Account a => Show (Filter_Account_Component a)
 instance Account a
  =>      Filter     (Filter_Account_Component a) where
        type   Filter_Key (Filter_Account_Component a) = a
-       test (Filter_Account_Path      f) a = test f $ account_path a
-       test (Filter_Account_Tag f) a =
+       test (Filter_Account_Path f) a = test f $ account_path a
+       test (Filter_Account_Tag  f) a =
                let Account_Tags tags = account_tags a in
                test f tags
        simplify f =
@@ -666,25 +637,6 @@ instance Amount a
                 Filter_Amount_Section_Quantity ff -> Filter_Amount_Section_Quantity <$> simplify ff
                 Filter_Amount_Section_Unit     ff -> Filter_Amount_Section_Unit     <$> simplify ff
 
--- ** Type 'Filter_Posting_Type'
-
-data Filter_Posting_Type
- =   Filter_Posting_Type_Any
- |   Filter_Posting_Type_Exact Posting_Type
- deriving (Data, Eq, Show, Typeable)
-
-instance Filter   Filter_Posting_Type where
-       type Filter_Key Filter_Posting_Type = Posting_Type
-       test f p =
-               case f of
-                Filter_Posting_Type_Any      -> True
-                Filter_Posting_Type_Exact ff -> ff == p
-       simplify f =
-               Simplified $
-               case f of
-                Filter_Posting_Type_Any     -> Right True
-                Filter_Posting_Type_Exact _ -> Left f
-
 -- ** Type 'Filter_Date'
 
 data Filter_Date
@@ -791,12 +743,11 @@ instance Filter   Filter_Tag_Value where
 
 -- ** Type 'Filter_Posting'
 
-data       Posting p
- => Filter_Posting p
+data     Posting j p
+ => Filter_Posting p
  =  Filter_Posting_Account  (Filter_Account           (Posting.Posting_Account p))
  |  Filter_Posting_Amount   (Filter_Amount            (Posting.Posting_Amount  p))
  |  Filter_Posting_Unit     (Filter_Unit (Amount_Unit (Posting.Posting_Amount  p))) -- TODO: remove: Filter_Posting_Amount should be enough
- |  Filter_Posting_Type     Filter_Posting_Type
  deriving (Typeable)
  -- Virtual
  -- Wording Comp_String String
@@ -818,15 +769,12 @@ instance Posting p
                test f $ Posting.posting_account p
        test (Filter_Posting_Amount f) p =
                any (test f) $ Posting.posting_amounts p
-       test (Filter_Posting_Type f) p =
-               test f $ posting_type p
        test (Filter_Posting_Unit f) p =
                any (test f . amount_unit) $ Posting.posting_amounts p
        simplify f =
                case f of
                 Filter_Posting_Account ff -> Filter_Posting_Account <$> simplify ff
                 Filter_Posting_Amount  ff -> Filter_Posting_Amount  <$> simplify ff
-                Filter_Posting_Type    ff -> Filter_Posting_Type    <$> simplify ff
                 Filter_Posting_Unit    ff -> Filter_Posting_Unit    <$> simplify ff
 
 {-
@@ -853,11 +801,11 @@ instance Monoid Forall_Simplified_Bool_Filter_Posting_Decimal where
 
 -- ** Type 'Filter_Transaction'
 
-data        Transaction t
- =>  Filter_Transaction t
+data        Transaction t
+ =>  Filter_Transaction t
  =   Filter_Transaction_Date    (Filter_Bool Filter_Date)
  -- |   Filter_Transaction_Posting (Filter_Bool (Filter_Posting (Posting_Typed (Transaction_Posting t))))
- |   Filter_Transaction_Posting (Filter_Bool (Filter_Posting (Posting_Typed (Transaction_Posting t))))
+ |   Filter_Transaction_Posting (Filter_Bool (Filter_Posting (Transaction_Posting t)))
  |   Filter_Transaction_Tag     Filter_Tags
  |   Filter_Transaction_Wording Filter_Wording
  deriving (Typeable)
@@ -868,9 +816,7 @@ instance Transaction t
  =>    Filter     (Filter_Transaction t) where
        type Filter_Key (Filter_Transaction t) = t
        test (Filter_Transaction_Posting f) t =
-               any
-                (test f . Posting_Typed . (Posting_Type_Regular,))
-                (transaction_postings t)
+               any (test f) (transaction_postings t)
        test (Filter_Transaction_Date f) t =
                test f $ transaction_date t
        test (Filter_Transaction_Tag f) t =