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                  ]
 103         transaction_postings_virtual t  =
 104                 Compose
 105                  [ Compose $ transaction_virtual_postings t
 106                  , Compose $ transaction_balanced_virtual_postings t
 107                  ]
 108         transaction_tags        = transaction_tags
 109
 110 instance Journal.Transaction Transaction where
 111         transaction_date = fst . transaction_dates
 112
 113 instance GL.Transaction Transaction where
 114         type Transaction_Posting  Transaction = Posting
 115         type Transaction_Postings Transaction = Compose [] (Compose (Map Account) [])
 116         transaction_date = fst . transaction_dates
 117         transaction_postings t =
 118                 Compose
 119                  [ Compose $ transaction_postings t
 120                  , Compose $ transaction_virtual_postings t
 121                  , Compose $ transaction_balanced_virtual_postings t
 122                  ]
 123         transaction_postings_filter f t =
 124                 t{ transaction_postings =
 125                         Data.Map.mapMaybe
 126                          (\p -> case filter f p of
 127                                  [] -> Nothing
 128                                  ps -> Just ps)
 129                          (transaction_postings t)
 130                  , transaction_virtual_postings =
 131                         Data.Map.mapMaybe
 132                          (\p -> case filter f p of
 133                                  [] -> Nothing
 134                                  ps -> Just ps)
 135                          (transaction_virtual_postings t)
 136                  , transaction_balanced_virtual_postings =
 137                         Data.Map.mapMaybe
 138                          (\p -> case filter f p of
 139                                  [] -> Nothing
 140                                  ps -> Just ps)
 141                          (transaction_balanced_virtual_postings t)
 142                  }
 143
 144 -- | Return a 'Data.Map.Map' associating
 145 --   the given 'Transaction's with their respective 'Date'.
 146 transaction_by_Date :: [Transaction] -> (Compose (Map Date) []) Transaction
 147 transaction_by_Date =
 148         Compose .
 149         Data.Map.fromListWith (flip (++)) .
 150         Data.List.map (\t -> (fst $ transaction_dates t, [t]))
 151
 152 -- * The 'Posting' type
 153
 154 data Posting
 155  =   Posting
 156  { posting_account   :: Account
 157  , posting_amounts   :: Map Amount.Unit Amount
 158  , posting_comments  :: [Comment]
 159  , posting_dates     :: [Date]
 160  , posting_sourcepos :: SourcePos
 161  , posting_status    :: Bool
 162  , posting_tags      :: Tag_by_Name
 163  } deriving (Data, Eq, Show, Typeable)
 164
 165 posting :: Account -> Posting
 166 posting acct =
 167         Posting
 168          { posting_account = acct
 169          , posting_amounts = mempty
 170          , posting_comments = mempty
 171          , posting_dates = mempty
 172          , posting_status = False
 173          , posting_sourcepos = initialPos ""
 174          , posting_tags = mempty
 175          }
 176
 177 instance
 178  Balance.Posting Posting where
 179         type Posting_Amount Posting = Amount.Sum Amount
 180         posting_account = posting_account
 181         posting_amounts = Data.Map.map Amount.sum . posting_amounts
 182         posting_set_amounts amounts p =
 183                 p { posting_amounts=Data.Map.map Amount.sum_balance amounts }
 184
 185 instance Filter.Posting Posting where
 186         type Posting_Amount   Posting = Amount
 187         posting_account = posting_account
 188         posting_amounts = posting_amounts
 189         posting_type    = undefined
 190          -- NOTE: the posting_type will be given to Filter.test
 191          --       through instance Posting p => Posting (Posting_Type, p)
 192          --       by Filter.transaction_postings
 193          --       and Filter.transaction_postings_virtual
 194
 195 instance GL.Posting Posting where
 196         type Posting_Amount Posting = Amount.Sum (Map Amount.Unit Amount)
 197         posting_account = posting_account
 198         posting_amount  = Amount.sum . posting_amounts
 199
 200 -- ** The 'Posting' mappings
 201
 202 type Posting_by_Account
 203  = Map Account [Posting]
 204
 205 type Posting_by_Amount_and_Account
 206  = Map Amount.By_Unit Posting_by_Account
 207
 208 type Posting_by_Signs_and_Account
 209  = Map Amount.Signs Posting_by_Account
 210
 211 -- | Return a Data.'Data.Map.Map' associating the given 'Posting's with their respective 'Account'.
 212 posting_by_Account :: [Posting] -> Posting_by_Account
 213 posting_by_Account =
 214         Data.Map.fromListWith (flip (++)) .
 215         Data.List.map
 216          (\p -> (posting_account p, [p]))
 217
 218 posting_by_Amount_and_Account :: Posting_by_Account -> Posting_by_Amount_and_Account
 219 posting_by_Amount_and_Account =
 220         Data.Map.foldlWithKey
 221          (flip (\acct ->
 222                 Data.List.foldl'
 223                  (flip (\p ->
 224                         Data.Map.insertWith
 225                          (Data.Map.unionWith (++))
 226                          (posting_amounts p)
 227                          (Data.Map.singleton acct [p])))))
 228          mempty
 229
 230 posting_by_Signs_and_Account :: Posting_by_Account -> Posting_by_Signs_and_Account
 231 posting_by_Signs_and_Account =
 232         Data.Map.foldlWithKey
 233          (flip (\acct ->
 234                 Data.List.foldl'
 235                  (flip (\p ->
 236                         Data.Map.insertWith
 237                          (Data.Map.unionWith (++))
 238                          (Amount.signs $ posting_amounts p)
 239                          (Data.Map.singleton acct [p])))))
 240          mempty
 241
 242 -- * The 'Tag' type
 243
 244 type Tag = (Tag_Name, Tag_Value)
 245 type Tag_Name = Text
 246 type Tag_Value = Text
 247
 248 type Tag_by_Name = Map Tag_Name [Tag_Value]
 249
 250 -- | Return a 'Data.Map.Map' associating the 'Value's of the given 'Tag's with their respective 'Name'.
 251 tag_by_Name :: [Tag] -> Tag_by_Name
 252 tag_by_Name =
 253         Data.Map.fromListWith (flip (++)) .
 254         Data.List.map (\(n, v) -> (n, [v]))