ledger/Hcompta/Format/Ledger/Posting.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE NamedFieldPuns #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 module Hcompta.Format.Ledger.Posting where
   7
   8 import           Control.DeepSeq (NFData(..))
   9 import           Data.Bool
  10 import           Data.Data (Data(..))
  11 import           Data.Eq (Eq(..))
  12 import           Data.Function (($), (.), flip)
  13 import qualified Data.List as List
  14 import           Data.List.NonEmpty (NonEmpty(..))
  15 import           Data.Map.Strict (Map)
  16 import qualified Data.Map.Strict as Map
  17 import           Data.Maybe (Maybe(..))
  18 import           Data.Monoid (Monoid(..))
  19 import           Data.Text (Text)
  20 import           Data.Tuple (uncurry)
  21 import           Data.Typeable (Typeable)
  22 import           Prelude (seq, undefined)
  23 import           Text.Parsec.Pos (SourcePos, initialPos)
  24 import           Text.Show (Show)
  25
  26 import qualified Hcompta.Balance as Balance
  27 import qualified Hcompta.Chart as Chart
  28 import           Hcompta.Date (Date)
  29 import qualified Hcompta.Filter as Filter
  30 import qualified Hcompta.GL as GL
  31 import           Hcompta.Lib.Parsec ()
  32 import qualified Hcompta.Polarize as Polarize
  33 import           Hcompta.Posting (Posting_Tags(..))
  34 import qualified Hcompta.Posting as Posting
  35 import qualified Hcompta.Stats as Stats
  36 import           Hcompta.Tag (Tags(..))
  37
  38 import           Hcompta.Format.Ledger.Account
  39 import           Hcompta.Format.Ledger.Amount
  40 import           Hcompta.Format.Ledger.Chart
  41
  42 -- * Type 'Posting_Type'
  43
  44 data Posting_Type
  45  =   Posting_Type_Regular
  46  |   Posting_Type_Virtual
  47  |   Posting_Type_Virtual_Balanced
  48  deriving (Data, Eq, Show, Typeable)
  49
  50 data Posting_Typed posting
  51  =   Posting_Typed Posting_Type posting
  52  deriving (Data, Eq, Show, Typeable)
  53
  54 posting_type :: Posting -> Posting_Type
  55 posting_type Posting{posting_tags=Posting_Tags (Tags attrs)} =
  56         case Map.lookup ("Virtual":|[]) attrs of
  57          Nothing -> Posting_Type_Regular
  58          Just l | "Balanced" `List.elem` l -> Posting_Type_Virtual_Balanced
  59          Just _  -> Posting_Type_Virtual
  60
  61 -- * Type 'Comment'
  62
  63 type Comment = Text
  64
  65 -- * Type 'Posting'
  66
  67 data Posting
  68  =   Posting
  69  { posting_account   :: Account
  70  , posting_amounts   :: Map Unit Quantity
  71  , posting_comments  :: [Comment]
  72  , posting_dates     :: [Date]
  73  , posting_sourcepos :: SourcePos
  74  , posting_status    :: Bool
  75  , posting_tags      :: Posting_Tags
  76  } deriving (Data, Eq, Show, Typeable)
  77 instance NFData Posting where
  78         rnf
  79          Posting
  80          { posting_account
  81          , posting_amounts
  82          , posting_comments
  83          , posting_dates
  84          -- , posting_sourcepos
  85          , posting_status
  86          , posting_tags
  87          } =
  88                 rnf posting_account `seq`
  89                 rnf posting_amounts `seq`
  90                 rnf posting_comments `seq`
  91                 rnf posting_dates `seq`
  92                 -- rnf posting_sourcepos `seq`
  93                 rnf posting_status `seq`
  94                 rnf posting_tags
  95
  96 posting :: Account -> Posting
  97 posting acct =
  98         Posting
  99          { posting_account   = acct
 100          , posting_amounts   = mempty
 101          , posting_comments  = mempty
 102          , posting_dates     = mempty
 103          , posting_status    = False
 104          , posting_sourcepos = initialPos ""
 105          , posting_tags      = mempty
 106          }
 107
 108 postings_by_account :: [Posting] -> Map Account [Posting]
 109 postings_by_account =
 110         Map.fromListWith (flip mappend) .
 111         List.map (\p -> (posting_account p, [p]))
 112
 113 instance Posting.Posting Posting where
 114         type Posting_Account   Posting = Account
 115         type Posting_Amount    Posting = Amount
 116         type Posting_Amounts   Posting = []
 117         posting_account = posting_account
 118         posting_amounts = List.map (uncurry Amount) . Map.toList . posting_amounts
 119
 120 instance Posting.Posting (Charted Posting) where
 121         type Posting_Account   (Charted Posting) = Charted Account
 122         type Posting_Amount    (Charted Posting) = Posting.Posting_Amount  Posting
 123         type Posting_Amounts   (Charted Posting) = Posting.Posting_Amounts Posting
 124         posting_account (Chart.Charted c p) = Chart.Charted c $ Posting.posting_account p
 125         posting_amounts = Posting.posting_amounts . Chart.charted
 126
 127 instance Balance.Posting Posting where
 128         type Posting_Account   Posting = Account
 129         type Posting_Quantity  Posting = Polarize.Polarized Quantity
 130         type Posting_Unit      Posting = Unit
 131         posting_account = posting_account
 132         posting_amounts = Map.map Polarize.polarize . posting_amounts
 133         posting_set_amounts amounts p =
 134                 p { posting_amounts=Map.map Polarize.depolarize amounts }
 135
 136 instance Balance.Posting (Charted Posting) where
 137         type Posting_Account   (Charted Posting) = Account
 138         type Posting_Quantity  (Charted Posting) = Balance.Posting_Quantity Posting
 139         type Posting_Unit      (Charted Posting) = Balance.Posting_Unit     Posting
 140         posting_account = posting_account . Chart.charted
 141         posting_amounts = Map.map Polarize.polarize . posting_amounts . Chart.charted
 142         posting_set_amounts amounts (Chart.Charted c p) =
 143                 Chart.Charted c p{ posting_amounts=Map.map Polarize.depolarize amounts }
 144
 145 instance Filter.Posting (Charted Posting) where
 146         posting_type = undefined
 147          -- NOTE: the posting_type will be given to Filter.test
 148          --       through instance Posting p => Posting (Posting_Typed p)
 149          --       by Filter.transaction_postings
 150          --       and Filter.transaction_postings_virtual
 151
 152 instance GL.Posting     Posting where
 153         type Posting_Account  Posting = Account
 154         type Posting_Quantity Posting = Map Unit (Polarize.Polarized Quantity)
 155         posting_account  = posting_account
 156         posting_quantity = Map.map Polarize.polarize . posting_amounts
 157
 158 instance GL.Posting     (Charted Posting) where
 159         type Posting_Account  (Charted Posting) = Account
 160         type Posting_Quantity (Charted Posting) = GL.Posting_Quantity Posting
 161         posting_account  = GL.posting_account  . Chart.charted
 162         posting_quantity = GL.posting_quantity . Chart.charted
 163
 164 instance Stats.Posting  Posting where
 165         type Posting_Account  Posting = Account
 166         type Posting_Quantity Posting = Quantity
 167         type Posting_Unit     Posting = Unit
 168         posting_account = posting_account
 169         posting_amounts = posting_amounts
 170
 171 {-
 172 -- ** 'Posting' mappings
 173
 174 type Posting_by_Account
 175  = Map Account [Posting]
 176
 177 type Posting_by_Amount_and_Account
 178  = Map (Map Unit Amount) Posting_by_Account
 179
 180 type Posting_by_Signs_and_Account
 181  = Map Signs Posting_by_Account
 182
 183 -- | Return a Data.'Map.Map' associating the given 'Posting's with their respective 'Account'.
 184 posting_by_Account :: [Posting] -> Posting_by_Account
 185 posting_by_Account =
 186         Map.fromListWith (flip mappend) .
 187         Data.List.map
 188          (\p -> (posting_account p, [p]))
 189
 190 posting_by_Amount_and_Account :: Posting_by_Account -> Posting_by_Amount_and_Account
 191 posting_by_Amount_and_Account =
 192         Map.foldlWithKey
 193          (flip (\acct ->
 194                 Data.List.foldl'
 195                  (flip (\p ->
 196                         Map.insertWith
 197                          (Map.unionWith mappend)
 198                          (posting_amounts p)
 199                          (Map.singleton acct [p])))))
 200          mempty
 201
 202 posting_by_Signs_and_Account :: Posting_by_Account -> Posting_by_Signs_and_Account
 203 posting_by_Signs_and_Account =
 204         Map.foldlWithKey
 205          (flip (\acct ->
 206                 Data.List.foldl'
 207                  (flip (\p ->
 208                         Map.insertWith
 209                          (Map.unionWith mappend)
 210                          (signs $ posting_amounts p)
 211                          (Map.singleton acct [p])))))
 212          mempty
 213 -}