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, id)
  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.Show (Show)
  28 import qualified Data.List as List
  29 import qualified Data.Map.Strict as Map
  30 import qualified Data.MonoTraversable as MT
  31 import qualified Data.Strict as S
  32 import qualified Data.Time.Clock as Time
  33 import qualified Data.TreeMap.Strict as TreeMap
  34
  35 import Language.Symantic.Grammar (Source(..))
  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 src
  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   :: !src
  58  ,   posting_tags        :: !Posting_Tags
  59  } deriving (Data, Eq, Ord, Show, Typeable)
  60 instance NFData src => NFData (Posting src) 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 {-
  70 type instance H.UnitFor     Posting = Unit
  71 type instance H.QuantityFor Posting = H.Polarized Quantity
  72 type instance H.AccountFor  Posting = Account
  73 -}
  74
  75 instance H.Get (TreeMap.Path NameAccount) (Posting src) where
  76         get = H.to . posting_account
  77 instance H.Get Account (Posting src) where
  78         get Posting{posting_account = acct} = acct
  79 instance H.Get (Map Unit Quantity) (Posting src) where
  80         get Posting{posting_amounts = Amounts amts} = amts
  81 instance H.Set (Map Unit Quantity) (Posting src) where
  82         set amts p = p{posting_amounts = Amounts amts}
  83 instance H.Get (Map Unit (H.Polarized Quantity)) (Posting src) where
  84         get Posting{posting_amounts = Amounts amts} = H.polarize <$> amts
  85 instance H.Set (Map Unit (H.Polarized Quantity)) (Posting src) where
  86         set amts p = p{posting_amounts = Amounts $ H.depolarize <$> amts}
  87 -- instance H.Get (H.Balance_Amounts Unit Quantity) Posting where
  88 --      get = H.get . posting_amounts
  89
  90 {-
  91 instance H.ConsBalByAccount Posting where
  92         consBalByAccount Posting
  93          { posting_account = Account acct
  94          , posting_amounts = Amounts amts
  95          } = H.consBalByAccount (acct, H.polarize <$> amts)
  96 instance H.ConsBalByUnit Posting where
  97         consBalByUnit Posting
  98          { posting_account = Account acct
  99          , posting_amounts = Amounts amts
 100          } = H.consBalByUnit (acct, H.polarize <$> amts)
 101 type instance H.AccountFor (Account, Amounts) = Account
 102 -}
 103
 104 posting :: Source src => Account -> Posting src
 105 posting acct =
 106         Posting
 107          { posting_account     = acct
 108          , posting_account_ref = S.Nothing
 109          , posting_amounts     = H.zero
 110          , posting_comments    = mempty
 111          , posting_dates       = mempty
 112          , posting_sourcepos   = noSource
 113          , posting_tags        = mempty
 114          }
 115
 116 postings_by_account :: [Posting src] -> Map Account [Posting src]
 117 postings_by_account =
 118         Map.fromListWith (flip (<>)) .
 119         List.map (\p -> (posting_account p, [p]))
 120
 121 {-
 122 instance H.Posting Posting
 123
 124 type instance H.Account H.:@ Posting = Account
 125 instance H.GetI H.Account Posting where
 126         getI = posting_account
 127 instance H.SetI H.Account Posting where
 128         setI posting_account p = p{posting_account}
 129
 130 type instance H.Amounts H.:@ Posting = Amounts
 131 instance H.GetI H.Amounts Posting where
 132         getI = posting_amounts
 133 instance H.SetI H.Amounts (Posting src) where
 134         setI posting_amounts p = p{posting_amounts}
 135 -}
 136
 137 {-
 138 -- * Type 'Posting_Anchor'
 139 newtype Posting_Anchor = Posting_Anchor Anchor
 140  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 141 -- * Type 'Posting_Anchors'
 142 newtype Posting_Anchors = Posting_Anchors Anchors
 143  deriving (Data, Eq, Monoid, NFData, Ord, Semigroup, Show, Typeable)
 144 type instance MT.Element Posting_Anchors = Posting_Anchor
 145 -}
 146
 147 -- * Type 'Posting_Tag'
 148 newtype Posting_Tag = Posting_Tag Tag
 149  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 150 -- * Type 'Posting_Tags'
 151 newtype Posting_Tags = Posting_Tags Tags
 152  deriving (Data, Eq, Monoid, NFData, Ord, Semigroup, Show, Typeable)
 153 type instance MT.Element Posting_Tags = Posting_Tag
 154
 155 -- ** Type 'Comment'
 156 newtype Comment = Comment Text
 157  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 158
 159 -- * Type 'Postings'
 160 newtype Postings src = Postings (Map Account [Posting src])
 161  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 162 unPostings :: Postings src -> Map Account [Posting src]
 163 unPostings (Postings ps) = ps
 164 -- type instance H.Postings H.:@ Postings = Postings
 165 instance H.Get (Postings src) (Postings src) where
 166         get = id
 167 -- instance H.Postings Postings
 168 instance Semigroup (Postings src) where
 169         Postings x <> Postings y = Postings $ Map.unionWith (flip (<>)) x y
 170 instance Monoid (Postings src) where
 171         mempty  = Postings mempty
 172         mappend = (<>)
 173 type instance MT.Element (Postings src) = Posting src
 174 instance MT.MonoFunctor (Postings src) where
 175         omap f (Postings m) = Postings (MT.omap f `MT.omap` m)
 176 instance MT.MonoFoldable (Postings src) where
 177         ofoldMap f   (Postings m) = MT.ofoldMap f   (Compose m)
 178         ofoldr f a   (Postings m) = MT.ofoldr f a   (Compose m)
 179         ofoldr1Ex f  (Postings m) = MT.ofoldr1Ex f  (Compose m)
 180         ofoldl1Ex' f (Postings m) = MT.ofoldl1Ex' f (Compose m)
 181         ofoldl' f a  (Postings m) = MT.ofoldl' f a  (Compose m)
 182
 183
 184 {-
 185 -- Posting
 186 instance H.Posting Posting where
 187         type Posting_Account Posting = Account
 188         type Posting_Amount  Posting = Amount
 189         type Amounts Posting = [Amount]
 190         posting_account = posting_account
 191         posting_amounts = (uncurry Amount <$>) . Map.toList . posting_amounts
 192 instance H.Posting (Charted Posting) where
 193         type Posting_Account (Charted Posting) = Charted Account
 194         type Posting_Amount  (Charted Posting) = H.Posting_Amount  Posting
 195         type Amounts (Charted Posting) = H.Amounts Posting
 196         posting_account = (H.posting_account <$>)
 197         posting_amounts = H.posting_amounts . charted
 198
 199 -- Balance
 200 instance H.Balance_Posting Posting where
 201         type Balance_Posting_Quantity Posting = H.Polarized Quantity
 202         balance_posting_amounts = (H.polarize <$>) . posting_amounts
 203         balance_posting_amounts_set amounts p =
 204                 p { posting_amounts = H.depolarize <$> amounts }
 205 instance H.Balance_Posting (Charted Posting) where
 206         type Balance_Posting_Quantity (Charted Posting) = H.Balance_Posting_Quantity Posting
 207         balance_posting_amounts = H.balance_posting_amounts . charted
 208         balance_posting_amounts_set amounts (Charted c p) =
 209                 Charted c p{ posting_amounts = H.depolarize <$> amounts }
 210
 211 -- GL
 212 instance H.GL_Posting Posting where
 213         type GL_Posting_Quantity Posting = Map Unit (H.Polarized Quantity)
 214         gl_posting_quantity = (H.polarize <$>) . posting_amounts
 215 instance H.GL_Posting (Charted Posting) where
 216         type GL_Posting_Quantity (Charted Posting) = H.GL_Posting_Quantity Posting
 217         gl_posting_quantity = H.gl_posting_quantity . charted
 218 -}