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 {-# LANGUAGE TypeOperators #-}
  10 {-# LANGUAGE StandaloneDeriving #-}
  11 {-# OPTIONS_GHC -fno-warn-orphans #-}
  12 module Hcompta.LCC.Posting where
  13
  14 import Control.DeepSeq (NFData(..))
  15 import Data.Data (Data(..))
  16 import Data.Eq (Eq(..))
  17 import Data.Function (($), (.), flip)
  18 import Data.Functor ((<$>))
  19 import Data.Functor.Compose (Compose(..))
  20 import Data.Map.Strict (Map)
  21 import Data.Monoid (Monoid(..))
  22 import Data.Ord (Ord(..))
  23 import Data.Semigroup (Semigroup(..))
  24 import Data.Text (Text)
  25 import Data.Typeable (Typeable)
  26 import Prelude (seq)
  27 import Text.Megaparsec.Pos (SourcePos, initialPos)
  28 import Text.Show (Show)
  29 import qualified Data.List as List
  30 import qualified Data.Map.Strict as Map
  31 import qualified Data.MonoTraversable as MT
  32 import qualified Data.Strict as S
  33 import qualified Data.Time.Clock as Time
  34 import qualified Data.TreeMap.Strict as TreeMap
  35
  36 import qualified Hcompta as H
  37
  38 import           Hcompta.LCC.Account
  39 import           Hcompta.LCC.Amount
  40 import           Hcompta.LCC.Tag
  41
  42 deriving instance (Data a, Data b) => Data (S.Pair a b)
  43 instance (NFData a, NFData b) => NFData (S.Pair a b) where
  44         rnf (a S.:!: b)  = rnf a `seq` rnf b
  45
  46 -- * Type 'Date'
  47 type Date = Time.UTCTime
  48
  49 -- * Type 'Posting'
  50 data Posting
  51  =   Posting
  52  {   posting_account     :: !Account
  53  ,   posting_account_ref :: !(S.Maybe (S.Pair Tag_Path (S.Maybe Account)))
  54  ,   posting_amounts     :: !Amounts
  55  ,   posting_comments    :: ![Comment]
  56  ,   posting_dates       :: ![Date]
  57  ,   posting_sourcepos   :: !SourcePos
  58  ,   posting_tags        :: !Posting_Tags
  59  } deriving (Data, Eq, Ord, Show, Typeable)
  60 instance NFData Posting where
  61         rnf Posting{..} =
  62                 rnf posting_account `seq`
  63                 rnf posting_account_ref `seq`
  64                 rnf posting_amounts `seq`
  65                 rnf posting_comments `seq`
  66                 rnf posting_dates `seq`
  67                 -- rnf posting_sourcepos `seq`
  68                 rnf posting_tags
  69 instance H.Get (TreeMap.Path Account_Section) Posting where
  70         get = H.get . posting_account
  71 instance H.Get (Map Unit (H.Polarized Quantity)) Posting where
  72         get Posting{posting_amounts = Amounts amts} = H.polarize <$> amts
  73 instance H.Set (Map Unit (H.Polarized Quantity)) Posting where
  74         set amts p = p{posting_amounts = Amounts $ H.depolarize <$> amts}
  75 instance H.Get (H.Balance_Amounts Unit Quantity) Posting where
  76         get = H.get . posting_amounts
  77
  78 posting :: Account -> Posting
  79 posting acct =
  80         Posting
  81          { posting_account     = acct
  82          , posting_account_ref = S.Nothing
  83          , posting_amounts     = H.quantity_zero
  84          , posting_comments    = mempty
  85          , posting_dates       = mempty
  86          , posting_sourcepos   = initialPos ""
  87          , posting_tags        = mempty
  88          }
  89
  90 postings_by_account :: [Posting] -> Map Account [Posting]
  91 postings_by_account =
  92         Map.fromListWith (flip mappend) .
  93         List.map (\p -> (posting_account p, [p]))
  94
  95 instance H.Posting Posting
  96
  97 type instance H.Account H.:@ Posting = Account
  98 instance H.GetI H.Account Posting where
  99         getI_ _ = posting_account
 100 instance H.SetI H.Account Posting where
 101         setI_ _ posting_account p = p{posting_account}
 102
 103 type instance H.Amounts H.:@ Posting = Amounts
 104 instance H.GetI H.Amounts Posting where
 105         getI_ _ = posting_amounts
 106 instance H.SetI H.Amounts Posting where
 107         setI_ _ posting_amounts p = p{posting_amounts}
 108
 109 {-
 110 -- * Type 'Posting_Anchor'
 111 newtype Posting_Anchor = Posting_Anchor Anchor
 112  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 113 -- * Type 'Posting_Anchors'
 114 newtype Posting_Anchors = Posting_Anchors Anchors
 115  deriving (Data, Eq, Monoid, NFData, Ord, Semigroup, Show, Typeable)
 116 type instance MT.Element Posting_Anchors = Posting_Anchor
 117 -}
 118
 119 -- * Type 'Posting_Tag'
 120 newtype Posting_Tag = Posting_Tag Tag
 121  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 122 -- * Type 'Posting_Tags'
 123 newtype Posting_Tags = Posting_Tags Tags
 124  deriving (Data, Eq, Monoid, NFData, Ord, Semigroup, Show, Typeable)
 125 type instance MT.Element Posting_Tags = Posting_Tag
 126
 127 -- ** Type 'Comment'
 128 newtype Comment = Comment Text
 129  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 130
 131 -- * Type 'Postings'
 132 newtype Postings = Postings (Map Account [Posting])
 133  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 134 unPostings :: Postings -> Map Account [Posting]
 135 unPostings (Postings ps) = ps
 136 instance H.Postings Postings
 137 instance Semigroup Postings where
 138         Postings x <> Postings y =
 139                 Postings $ Map.unionWith (flip (<>)) x y
 140 instance Monoid Postings where
 141         mempty  = Postings mempty
 142         mappend = (<>)
 143 type instance MT.Element Postings = Posting
 144 instance MT.MonoFunctor Postings where
 145         omap f (Postings m) = Postings (MT.omap f `MT.omap` m)
 146 instance MT.MonoFoldable Postings where
 147         ofoldMap f   (Postings m) = MT.ofoldMap f   (Compose m)
 148         ofoldr f a   (Postings m) = MT.ofoldr f a   (Compose m)
 149         ofoldr1Ex f  (Postings m) = MT.ofoldr1Ex f  (Compose m)
 150         ofoldl1Ex' f (Postings m) = MT.ofoldl1Ex' f (Compose m)
 151         ofoldl' f a  (Postings m) = MT.ofoldl' f a  (Compose m)
 152
 153
 154 {-
 155 -- Posting
 156 instance H.Posting Posting where
 157         type Posting_Account Posting = Account
 158         type Posting_Amount  Posting = Amount
 159         type Amounts Posting = [Amount]
 160         posting_account = posting_account
 161         posting_amounts = (uncurry Amount <$>) . Map.toList . posting_amounts
 162 instance H.Posting (Charted Posting) where
 163         type Posting_Account (Charted Posting) = Charted Account
 164         type Posting_Amount  (Charted Posting) = H.Posting_Amount  Posting
 165         type Amounts (Charted Posting) = H.Amounts Posting
 166         posting_account = (H.posting_account <$>)
 167         posting_amounts = H.posting_amounts . charted
 168
 169 -- Balance
 170 instance H.Balance_Posting Posting where
 171         type Balance_Posting_Quantity Posting = H.Polarized Quantity
 172         balance_posting_amounts = (H.polarize <$>) . posting_amounts
 173         balance_posting_amounts_set amounts p =
 174                 p { posting_amounts = H.depolarize <$> amounts }
 175 instance H.Balance_Posting (Charted Posting) where
 176         type Balance_Posting_Quantity (Charted Posting) = H.Balance_Posting_Quantity Posting
 177         balance_posting_amounts = H.balance_posting_amounts . charted
 178         balance_posting_amounts_set amounts (Charted c p) =
 179                 Charted c p{ posting_amounts = H.depolarize <$> amounts }
 180
 181 -- GL
 182 instance H.GL_Posting Posting where
 183         type GL_Posting_Quantity Posting = Map Unit (H.Polarized Quantity)
 184         gl_posting_quantity = (H.polarize <$>) . posting_amounts
 185 instance H.GL_Posting (Charted Posting) where
 186         type GL_Posting_Quantity (Charted Posting) = H.GL_Posting_Quantity Posting
 187         gl_posting_quantity = H.gl_posting_quantity . charted
 188 -}