lcc/Hcompta/LCC/Posting.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   4 {-# LANGUAGE MultiParamTypeClasses #-}
   5 {-# LANGUAGE NamedFieldPuns #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE RecordWildCards #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9 module Hcompta.LCC.Posting where
  10
  11 import           Control.DeepSeq (NFData(..))
  12 import           Data.Data (Data(..))
  13 import           Data.Eq (Eq(..))
  14 import           Data.Function (($), (.), flip)
  15 import           Data.Functor ((<$>))
  16 import qualified Data.List as List
  17 import           Data.Map.Strict (Map)
  18 import qualified Data.Map.Strict as Map
  19 import           Data.Maybe (Maybe(..))
  20 import           Data.Monoid (Monoid(..))
  21 import           Data.Text (Text)
  22 import qualified Data.TreeMap.Strict as TreeMap
  23 import           Data.Typeable (Typeable)
  24 import           Prelude (seq)
  25 import           Text.Parsec.Pos (SourcePos, initialPos)
  26 import           Text.Show (Show)
  27 import qualified Data.MonoTraversable as MT
  28
  29 import qualified Hcompta as H
  30
  31 import           Hcompta.LCC.Account
  32 import           Hcompta.LCC.Amount
  33 import           Hcompta.LCC.Anchor
  34 import           Hcompta.LCC.Tag
  35
  36 -- * Type 'Posting'
  37 data Posting
  38  =   Posting
  39  {   posting_account        :: Account
  40  ,   posting_account_anchor :: Maybe (Account_Anchor, Maybe Account)
  41  ,   posting_amounts        :: Amounts
  42  ,   posting_anchors        :: Posting_Anchors
  43  ,   posting_comments       :: [Comment]
  44  ,   posting_dates          :: [Date]
  45  ,   posting_sourcepos      :: SourcePos
  46  ,   posting_tags           :: Posting_Tags
  47  } deriving (Data, Eq, Show, Typeable)
  48 instance NFData Posting where
  49         rnf Posting{..} =
  50                 rnf posting_account `seq`
  51                 rnf posting_account_anchor `seq`
  52                 rnf posting_amounts `seq`
  53                 rnf posting_anchors `seq`
  54                 rnf posting_comments `seq`
  55                 rnf posting_dates `seq`
  56                 -- rnf posting_sourcepos `seq`
  57                 rnf posting_tags
  58 instance H.Get (TreeMap.Path Account_Section) Posting where
  59         get = H.get . posting_account
  60 instance H.Get (Map Unit (H.Polarized Quantity)) Posting where
  61         get Posting{posting_amounts = Amounts amts} = H.polarize <$> amts
  62 instance H.Set (Map Unit (H.Polarized Quantity)) Posting where
  63         set amts p = p{posting_amounts = Amounts $ H.depolarize <$> amts}
  64
  65 posting :: Account -> Posting
  66 posting acct =
  67         Posting
  68          { posting_account        = acct
  69          , posting_account_anchor = Nothing
  70          , posting_amounts        = H.quantity_zero
  71          , posting_anchors        = mempty
  72          , posting_comments       = mempty
  73          , posting_dates          = mempty
  74          , posting_sourcepos      = initialPos ""
  75          , posting_tags           = mempty
  76          }
  77
  78 postings_by_account :: [Posting] -> Map Account [Posting]
  79 postings_by_account =
  80         Map.fromListWith (flip mappend) .
  81         List.map (\p -> (posting_account p, [p]))
  82
  83 instance H.Posting Posting
  84
  85 type instance H.Account H.:@ Posting = Account
  86 instance H.GetI H.Account Posting where
  87         getI _ = posting_account
  88 instance H.SetI H.Account Posting where
  89         setI _ posting_account p = p{posting_account}
  90
  91 type instance H.Amounts H.:@ Posting = Amounts
  92 instance H.GetI H.Amounts Posting where
  93         getI _ = posting_amounts
  94 instance H.SetI H.Amounts Posting where
  95         setI _ posting_amounts p = p{posting_amounts}
  96
  97 -- * Type 'Posting_Anchor'
  98 newtype Posting_Anchor = Posting_Anchor Anchor
  99  deriving (Data, Eq, NFData, Show, Typeable)
 100 -- * Type 'Posting_Anchors'
 101 newtype Posting_Anchors = Posting_Anchors Anchors
 102  deriving (Data, Eq, Monoid, NFData, Show, Typeable)
 103 type instance MT.Element Posting_Anchors = Posting_Anchor
 104
 105 -- * Type 'Posting_Tag'
 106 newtype Posting_Tag = Posting_Tag Tag
 107  deriving (Data, Eq, NFData, Show, Typeable)
 108 -- * Type 'Posting_Tags'
 109 newtype Posting_Tags = Posting_Tags Tags
 110  deriving (Data, Eq, Monoid, NFData, Show, Typeable)
 111 type instance MT.Element Posting_Tags = Posting_Tag
 112
 113 -- ** Type 'Comment'
 114 newtype Comment = Comment Text
 115  deriving (Data, Eq, NFData, Show, Typeable)
 116
 117 -- * Type 'Postings'
 118 newtype Postings = Postings (Map Account [Posting])
 119  deriving (Data, Eq, NFData, Show, Typeable)
 120 instance Monoid Postings where
 121         mempty = Postings mempty
 122         mappend (Postings x) (Postings y) =
 123                 Postings $ Map.unionWith (flip mappend) x y
 124
 125 type instance MT.Element Postings = Posting
 126 instance H.Postings Postings
 127
 128
 129 {-
 130 -- Posting
 131 instance H.Posting Posting where
 132         type Posting_Account Posting = Account
 133         type Posting_Amount  Posting = Amount
 134         type Amounts Posting = [Amount]
 135         posting_account = posting_account
 136         posting_amounts = (uncurry Amount <$>) . Map.toList . posting_amounts
 137 instance H.Posting (Charted Posting) where
 138         type Posting_Account (Charted Posting) = Charted Account
 139         type Posting_Amount  (Charted Posting) = H.Posting_Amount  Posting
 140         type Amounts (Charted Posting) = H.Amounts Posting
 141         posting_account = (H.posting_account <$>)
 142         posting_amounts = H.posting_amounts . charted
 143
 144 -- Balance
 145 instance H.Balance_Posting Posting where
 146         type Balance_Posting_Quantity Posting = H.Polarized Quantity
 147         balance_posting_amounts = (H.polarize <$>) . posting_amounts
 148         balance_posting_amounts_set amounts p =
 149                 p { posting_amounts = H.depolarize <$> amounts }
 150 instance H.Balance_Posting (Charted Posting) where
 151         type Balance_Posting_Quantity (Charted Posting) = H.Balance_Posting_Quantity Posting
 152         balance_posting_amounts = H.balance_posting_amounts . charted
 153         balance_posting_amounts_set amounts (Charted c p) =
 154                 Charted c p{ posting_amounts = H.depolarize <$> amounts }
 155
 156 -- GL
 157 instance H.GL_Posting Posting where
 158         type GL_Posting_Quantity Posting = Map Unit (H.Polarized Quantity)
 159         gl_posting_quantity = (H.polarize <$>) . posting_amounts
 160 instance H.GL_Posting (Charted Posting) where
 161         type GL_Posting_Quantity (Charted Posting) = H.GL_Posting_Quantity Posting
 162         gl_posting_quantity = H.gl_posting_quantity . charted
 163 -}