lib/Hcompta/Format/Ledger.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE NamedFieldPuns #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# LANGUAGE TupleSections #-}
   7 {-# LANGUAGE TypeFamilies #-}
   8 module Hcompta.Format.Ledger where
   9
  10 -- import           Control.Applicative (Const(..))
  11 import           Data.Data (Data(..))
  12 -- import qualified Data.Foldable as Data.Foldable
  13 import           Data.Functor.Compose (Compose(..))
  14 import qualified Data.List
  15 import           Data.Map.Strict (Map)
  16 import qualified Data.Map.Strict as Data.Map
  17 import           Data.Text (Text)
  18 import           Data.Typeable (Typeable)
  19 import           Text.Parsec.Pos (SourcePos, initialPos)
  20
  21 import           Hcompta.Account (Account)
  22 import           Hcompta.Amount (Amount)
  23 import qualified Hcompta.Amount as Amount
  24 -- import           Hcompta.Balance (Balance(..))
  25 import qualified Hcompta.Balance as Balance
  26 import           Hcompta.Date (Date)
  27 import qualified Hcompta.Date as Date
  28 import qualified Hcompta.Filter as Filter
  29 -- import           Hcompta.Lib.Consable
  30 import           Hcompta.Lib.Parsec ()
  31 -- import           Hcompta.GL (GL(..))
  32 import qualified Hcompta.GL as GL
  33 import qualified Hcompta.Journal as Journal
  34
  35 type Code = Text
  36 type Description = Text
  37 type Status = Bool
  38 type Comment = Text
  39
  40 -- * The 'Journal' type
  41
  42 data Monoid ts => Journal ts
  43  =  Journal
  44  { journal_file           :: FilePath
  45  , journal_includes       :: [Journal ts]
  46  , journal_last_read_time :: Date
  47  , journal_transactions   :: !ts
  48  , journal_unit_styles    :: Map Amount.Unit Amount.Style
  49  } deriving (Data, Eq, Show, Typeable)
  50
  51 journal :: Monoid ts => Journal ts
  52 journal =
  53         Journal
  54          { journal_file = mempty
  55          , journal_includes = mempty
  56          , journal_last_read_time = Date.nil
  57          , journal_transactions = mempty
  58          , journal_unit_styles = mempty
  59          }
  60
  61 -- * The 'Transaction' type
  62
  63 data Transaction
  64  =   Transaction
  65  { transaction_code                      :: Code
  66  , transaction_comments_before           :: [Comment]
  67  , transaction_comments_after            :: [Comment]
  68  , transaction_dates                     :: (Date, [Date])
  69  , transaction_description               :: Description
  70  , transaction_postings                  :: Posting_by_Account
  71  , transaction_virtual_postings          :: Posting_by_Account
  72  , transaction_balanced_virtual_postings :: Posting_by_Account
  73  , transaction_sourcepos                 :: SourcePos
  74  , transaction_status                    :: Status
  75  , transaction_tags                      :: Tag_by_Name
  76  } deriving (Data, Eq, Show, Typeable)
  77
  78 transaction :: Transaction
  79 transaction =
  80         Transaction
  81          { transaction_code = ""
  82          , transaction_comments_before = []
  83          , transaction_comments_after = []
  84          , transaction_dates = (Date.nil, [])
  85          , transaction_description = ""
  86          , transaction_postings = mempty
  87          , transaction_virtual_postings = mempty
  88          , transaction_balanced_virtual_postings = mempty
  89          , transaction_sourcepos = initialPos ""
  90          , transaction_status = False
  91          , transaction_tags = mempty
  92          }
  93
  94 instance Filter.Transaction Transaction where
  95         type Transaction_Posting  Transaction = Posting
  96         type Transaction_Postings Transaction = Compose [] (Compose (Map Account) [])
  97         transaction_date        = fst . transaction_dates
  98         transaction_description = transaction_description
  99         transaction_postings t  =
 100                 Compose
 101                  [ Compose $ transaction_postings t
 102                  , Compose $ transaction_virtual_postings t
 103                  , Compose $ transaction_balanced_virtual_postings t
 104                  ]
 105         transaction_tags        = transaction_tags
 106
 107 instance Journal.Transaction Transaction where
 108         transaction_date = fst . transaction_dates
 109
 110 instance GL.Transaction Transaction where
 111         type Transaction_Posting  Transaction = Posting
 112         type Transaction_Postings Transaction = Compose [] (Compose (Map Account) [])
 113         transaction_date = fst . transaction_dates
 114         transaction_postings t =
 115                 Compose
 116                  [ Compose $ transaction_postings t
 117                  , Compose $ transaction_virtual_postings t
 118                  , Compose $ transaction_balanced_virtual_postings t
 119                  ]
 120         transaction_postings_filter f t =
 121                 t{ transaction_postings =
 122                         Data.Map.mapMaybe
 123                          (\p -> case filter f p of
 124                                  [] -> Nothing
 125                                  ps -> Just ps)
 126                          (transaction_postings t)
 127                  , transaction_virtual_postings =
 128                         Data.Map.mapMaybe
 129                          (\p -> case filter f p of
 130                                  [] -> Nothing
 131                                  ps -> Just ps)
 132                          (transaction_virtual_postings t)
 133                  , transaction_balanced_virtual_postings =
 134                         Data.Map.mapMaybe
 135                          (\p -> case filter f p of
 136                                  [] -> Nothing
 137                                  ps -> Just ps)
 138                          (transaction_balanced_virtual_postings t)
 139                  }
 140
 141 -- | Return a 'Data.Map.Map' associating
 142 --   the given 'Transaction's with their respective 'Date'.
 143 transaction_by_Date :: [Transaction] -> (Compose (Map Date) []) Transaction
 144 transaction_by_Date =
 145         Compose .
 146         Data.Map.fromListWith (flip (++)) .
 147         Data.List.map (\t -> (fst $ transaction_dates t, [t]))
 148
 149 -- * The 'Posting' type
 150
 151 data Posting
 152  =   Posting
 153  { posting_account   :: Account
 154  , posting_amounts   :: Map Amount.Unit Amount
 155  , posting_comments  :: [Comment]
 156  , posting_dates     :: [Date]
 157  , posting_sourcepos :: SourcePos
 158  , posting_status    :: Bool
 159  , posting_tags      :: Tag_by_Name
 160  } deriving (Data, Eq, Show, Typeable)
 161
 162 data Posting_Type
 163  =   Posting_Type_Regular
 164  |   Posting_Type_Virtual
 165  |   Posting_Type_Virtual_Balanced
 166  deriving (Data, Eq, Read, Show, Typeable)
 167
 168 posting :: Account -> Posting
 169 posting acct =
 170         Posting
 171          { posting_account = acct
 172          , posting_amounts = mempty
 173          , posting_comments = mempty
 174          , posting_dates = mempty
 175          , posting_status = False
 176          , posting_sourcepos = initialPos ""
 177          , posting_tags = mempty
 178          }
 179
 180 instance
 181  Balance.Posting Posting where
 182         type Posting_Amount Posting = Amount.Sum Amount
 183         posting_account = posting_account
 184         posting_amounts = Data.Map.map Amount.sum . posting_amounts
 185         posting_set_amounts amounts p =
 186                 p { posting_amounts=Data.Map.map Amount.sum_balance amounts }
 187
 188 instance Filter.Posting Posting where
 189         type Posting_Amount Posting = Amount
 190         posting_account = posting_account
 191         posting_amounts = posting_amounts
 192
 193 instance GL.Posting Posting where
 194         type Posting_Amount Posting = Amount.Sum (Map Amount.Unit Amount)
 195         posting_account = posting_account
 196         posting_amount  = Amount.sum . posting_amounts
 197
 198 -- ** The 'Posting' mappings
 199
 200 type Posting_by_Account
 201  = Map Account [Posting]
 202
 203 type Posting_by_Amount_and_Account
 204  = Map Amount.By_Unit Posting_by_Account
 205
 206 type Posting_by_Signs_and_Account
 207  = Map Amount.Signs Posting_by_Account
 208
 209 -- | Return a Data.'Data.Map.Map' associating the given 'Posting's with their respective 'Account'.
 210 posting_by_Account :: [Posting] -> Posting_by_Account
 211 posting_by_Account =
 212         Data.Map.fromListWith (flip (++)) .
 213         Data.List.map
 214          (\p -> (posting_account p, [p]))
 215
 216 posting_by_Amount_and_Account :: Posting_by_Account -> Posting_by_Amount_and_Account
 217 posting_by_Amount_and_Account =
 218         Data.Map.foldlWithKey
 219          (flip (\acct ->
 220                 Data.List.foldl'
 221                  (flip (\p ->
 222                         Data.Map.insertWith
 223                          (Data.Map.unionWith (++))
 224                          (posting_amounts p)
 225                          (Data.Map.singleton acct [p])))))
 226          mempty
 227
 228 posting_by_Signs_and_Account :: Posting_by_Account -> Posting_by_Signs_and_Account
 229 posting_by_Signs_and_Account =
 230         Data.Map.foldlWithKey
 231          (flip (\acct ->
 232                 Data.List.foldl'
 233                  (flip (\p ->
 234                         Data.Map.insertWith
 235                          (Data.Map.unionWith (++))
 236                          (Amount.signs $ posting_amounts p)
 237                          (Data.Map.singleton acct [p])))))
 238          mempty
 239
 240 -- * The 'Tag' type
 241
 242 type Tag = (Tag_Name, Tag_Value)
 243 type Tag_Name = Text
 244 type Tag_Value = Text
 245
 246 type Tag_by_Name = Map Tag_Name [Tag_Value]
 247
 248 -- | Return a 'Data.Map.Map' associating the 'Value's of the given 'Tag's with their respective 'Name'.
 249 tag_by_Name :: [Tag] -> Tag_by_Name
 250 tag_by_Name =
 251         Data.Map.fromListWith (flip (++)) .
 252         Data.List.map (\(n, v) -> (n, [v]))