lib/Hcompta/Format/Ledger.hs

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