Polissage : n'utilise pas TypeSynonymInstances.
[comptalang.git] / lib / Hcompta / Format / Ledger.hs
index 3b7ab56d09603132a97e4d9cb76e19f258d3644e..30a01737856ff1a08d2f0d330cec4063cf895b4e 100644 (file)
@@ -1,26 +1,36 @@
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
 module Hcompta.Format.Ledger where
 
+-- import           Control.Applicative (Const(..))
 import           Data.Data (Data(..))
+-- import qualified Data.Foldable as Data.Foldable
+import           Data.Functor.Compose (Compose(..))
+import qualified Data.List
+import           Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Data.Map
+import           Data.Text (Text)
 import           Data.Typeable (Typeable)
 import           Text.Parsec.Pos (SourcePos, initialPos)
-import qualified Data.Map.Strict as Data.Map
-import qualified Data.List as Data.List
-import qualified Data.Time.Clock       as Time
-import qualified Data.Time.Clock.POSIX as Time
 
+import           Hcompta.Account (Account)
+import           Hcompta.Amount (Amount)
+import qualified Hcompta.Amount as Amount
+-- import           Hcompta.Balance (Balance(..))
+import qualified Hcompta.Balance as Balance
+import           Hcompta.Date (Date)
+import qualified Hcompta.Date as Date
+import qualified Hcompta.Filter as Filter
+-- import           Hcompta.Lib.Consable
 import           Hcompta.Lib.Parsec ()
-import qualified Hcompta.Calc.Balance as Calc.Balance
-import           Hcompta.Model.Date (Date)
-import qualified Hcompta.Model.Date as Date
-import           Hcompta.Model.Account (Account)
--- import qualified Hcompta.Model.Account as Account
-import           Hcompta.Model.Amount (Amount)
-import qualified Hcompta.Model.Amount as Amount
-import           Data.Text (Text)
+-- import           Hcompta.GL (GL(..))
+import qualified Hcompta.GL as GL
+import qualified Hcompta.Journal as Journal
 
 type Code = Text
 type Description = Text
@@ -29,26 +39,25 @@ type Comment = Text
 
 -- * The 'Journal' type
 
-data Journal
- =   Journal
+data Monoid ts => Journal ts
+ =  Journal
  { journal_file           :: FilePath
- , journal_includes       :: [Journal]
- , journal_last_read_time :: Time.UTCTime
- , journal_transactions   :: Transaction_by_Date
- , journal_unit_styles    :: Data.Map.Map Amount.Unit Amount.Style
+ , journal_includes       :: [Journal ts]
+ , journal_last_read_time :: Date
+ , journal_transactions   :: !ts
+ , journal_unit_styles    :: Map Amount.Unit Amount.Style
  } deriving (Data, Eq, Show, Typeable)
 
-journal :: Journal
+journal :: Monoid ts => Journal ts
 journal =
        Journal
-        { journal_file = ""
-        , journal_includes = []
-        , journal_last_read_time = Time.posixSecondsToUTCTime 0
-        , journal_transactions = Data.Map.empty
-        , journal_unit_styles = Data.Map.empty
+        { journal_file = mempty
+        , journal_includes = mempty
+        , journal_last_read_time = Date.nil
+        , journal_transactions = mempty
+        , journal_unit_styles = mempty
         }
 
-
 -- * The 'Transaction' type
 
 data Transaction
@@ -74,32 +83,75 @@ transaction =
         , transaction_comments_after = []
         , transaction_dates = (Date.nil, [])
         , transaction_description = ""
-        , transaction_postings = Data.Map.empty
-        , transaction_virtual_postings = Data.Map.empty
-        , transaction_balanced_virtual_postings = Data.Map.empty
+        , transaction_postings = mempty
+        , transaction_virtual_postings = mempty
+        , transaction_balanced_virtual_postings = mempty
         , transaction_sourcepos = initialPos ""
         , transaction_status = False
-        , transaction_tags = Data.Map.empty
+        , transaction_tags = mempty
         }
 
--- ** The 'Transaction_by_Date' mapping
-
-type Transaction_by_Date
- = Data.Map.Map Date.UTC [Transaction]
-
--- | Return a Data.'Data.Map.Map' associating
+instance Filter.Transaction Transaction where
+       type Transaction_Posting  Transaction = Posting
+       type Transaction_Postings Transaction = Compose [] (Compose (Map Account) [])
+       transaction_date        = fst . transaction_dates
+       transaction_description = transaction_description
+       transaction_postings t  =
+               Compose
+                [ Compose $ transaction_postings t
+                , Compose $ transaction_virtual_postings t
+                , Compose $ transaction_balanced_virtual_postings t
+                ]
+       transaction_tags        = transaction_tags
+
+instance Journal.Transaction Transaction where
+       transaction_date = fst . transaction_dates
+
+instance GL.Transaction Transaction where
+       type Transaction_Posting  Transaction = Posting
+       type Transaction_Postings Transaction = Compose [] (Compose (Map Account) [])
+       transaction_date = fst . transaction_dates
+       transaction_postings t =
+               Compose
+                [ Compose $ transaction_postings t
+                , Compose $ transaction_virtual_postings t
+                , Compose $ transaction_balanced_virtual_postings t
+                ]
+       transaction_postings_filter f t =
+               t{ transaction_postings =
+                       Data.Map.mapMaybe
+                        (\p -> case filter f p of
+                                [] -> Nothing
+                                ps -> Just ps)
+                        (transaction_postings t)
+                , transaction_virtual_postings =
+                       Data.Map.mapMaybe
+                        (\p -> case filter f p of
+                                [] -> Nothing
+                                ps -> Just ps)
+                        (transaction_virtual_postings t)
+                , transaction_balanced_virtual_postings =
+                       Data.Map.mapMaybe
+                        (\p -> case filter f p of
+                                [] -> Nothing
+                                ps -> Just ps)
+                        (transaction_balanced_virtual_postings t)
+                }
+
+-- | Return a 'Data.Map.Map' associating
 --   the given 'Transaction's with their respective 'Date'.
-transaction_by_Date :: [Transaction] -> Transaction_by_Date
+transaction_by_Date :: [Transaction] -> (Compose (Map Date) []) Transaction
 transaction_by_Date =
+       Compose .
        Data.Map.fromListWith (flip (++)) .
-       Data.List.map (\t -> (Date.to_UTC $ fst $ transaction_dates t, [t]))
+       Data.List.map (\t -> (fst $ transaction_dates t, [t]))
 
 -- * The 'Posting' type
 
 data Posting
  =   Posting
  { posting_account   :: Account
- , posting_amounts   :: Amount.By_Unit
+ , posting_amounts   :: Map Amount.Unit Amount
  , posting_comments  :: [Comment]
  , posting_dates     :: [Date]
  , posting_sourcepos :: SourcePos
@@ -117,32 +169,42 @@ posting :: Account -> Posting
 posting acct =
        Posting
         { posting_account = acct
-        , posting_amounts = Data.Map.empty
-        , posting_comments = []
-        , posting_dates = []
+        , posting_amounts = mempty
+        , posting_comments = mempty
+        , posting_dates = mempty
         , posting_status = False
         , posting_sourcepos = initialPos ""
-        , posting_tags = Data.Map.empty
+        , posting_tags = mempty
         }
 
-instance Calc.Balance.Posting Posting
- where
+instance
+ Balance.Posting Posting where
+       type Posting_Amount Posting = Amount.Sum Amount
+       posting_account = posting_account
+       posting_amounts = Data.Map.map Amount.sum . posting_amounts
+       posting_set_amounts amounts p =
+               p { posting_amounts=Data.Map.map Amount.sum_balance amounts }
+
+instance Filter.Posting Posting where
        type Posting_Amount Posting = Amount
-       type Posting_Unit   Posting = Amount.Unit
        posting_account = posting_account
        posting_amounts = posting_amounts
-       posting_make acct amounts = (posting acct) { posting_amounts=amounts }
+
+instance GL.Posting Posting where
+       type Posting_Amount Posting = Amount.Sum (Map Amount.Unit Amount)
+       posting_account = posting_account
+       posting_amount  = Amount.sum . posting_amounts
 
 -- ** The 'Posting' mappings
 
 type Posting_by_Account
- = Data.Map.Map Account [Posting]
+ = Map Account [Posting]
 
 type Posting_by_Amount_and_Account
- = Data.Map.Map Amount.By_Unit Posting_by_Account
+ = Map Amount.By_Unit Posting_by_Account
 
 type Posting_by_Signs_and_Account
- = Data.Map.Map Amount.Signs Posting_by_Account
+ = Map Amount.Signs Posting_by_Account
 
 -- | Return a Data.'Data.Map.Map' associating the given 'Posting's with their respective 'Account'.
 posting_by_Account :: [Posting] -> Posting_by_Account
@@ -155,25 +217,25 @@ posting_by_Amount_and_Account :: Posting_by_Account -> Posting_by_Amount_and_Acc
 posting_by_Amount_and_Account =
        Data.Map.foldlWithKey
         (flip (\acct ->
-               Data.List.foldl
+               Data.List.foldl'
                 (flip (\p ->
                        Data.Map.insertWith
                         (Data.Map.unionWith (++))
                         (posting_amounts p)
                         (Data.Map.singleton acct [p])))))
-        Data.Map.empty
+        mempty
 
 posting_by_Signs_and_Account :: Posting_by_Account -> Posting_by_Signs_and_Account
 posting_by_Signs_and_Account =
        Data.Map.foldlWithKey
         (flip (\acct ->
-               Data.List.foldl
+               Data.List.foldl'
                 (flip (\p ->
                        Data.Map.insertWith
                         (Data.Map.unionWith (++))
                         (Amount.signs $ posting_amounts p)
                         (Data.Map.singleton acct [p])))))
-        Data.Map.empty
+        mempty
 
 -- * The 'Tag' type
 
@@ -181,7 +243,7 @@ type Tag = (Tag_Name, Tag_Value)
 type Tag_Name = Text
 type Tag_Value = Text
 
-type Tag_by_Name = Data.Map.Map Tag_Name [Tag_Value]
+type Tag_by_Name = Map Tag_Name [Tag_Value]
 
 -- | Return a 'Data.Map.Map' associating the 'Value's of the given 'Tag's with their respective 'Name'.
 tag_by_Name :: [Tag] -> Tag_by_Name