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 Data.Word (Word)
  27 import Prelude (seq)
  28 import System.IO (FilePath)
  29 import Text.Show (Show)
  30 import qualified Data.List as List
  31 import qualified Data.Map.Strict as Map
  32 import qualified Data.MonoTraversable as MT
  33 import qualified Data.Strict as S
  34 import qualified Data.Time.Clock as Time
  35 import qualified Data.TreeMap.Strict as TreeMap
  36
  37 import qualified Hcompta as H
  38
  39 import Hcompta.LCC.Account
  40 import Hcompta.LCC.Amount
  41 import Hcompta.LCC.Tag
  42
  43 deriving instance (Data a, Data b) => Data (S.Pair a b)
  44 instance (NFData a, NFData b) => NFData (S.Pair a b) where
  45         rnf (a S.:!: b)  = rnf a `seq` rnf b
  46
  47 -- * Type 'Date'
  48 type Date = Time.UTCTime
  49
  50 -- * Type 'SourcePos'
  51 data SourcePos
  52  =   SourcePos FilePath {-# UNPACK #-} !PosFile {-# UNPACK #-} !PosFile
  53  deriving (Data, Eq, Ord, Show, Typeable)
  54
  55 initialPos :: FilePath -> SourcePos
  56 initialPos p = SourcePos p (PosFile 0) (PosFile 0)
  57
  58 -- ** Type 'PosFile'
  59 newtype PosFile = PosFile (Word)
  60  deriving (Data, Eq, Ord, Show, Typeable)
  61
  62 -- ** Type 'SourceRange'
  63 data SourceRange
  64  =   SourceRange SourcePos SourcePos
  65  deriving (Data, Eq, Ord, Show, Typeable)
  66
  67 -- * Type 'Posting'
  68 data Posting
  69  =   Posting
  70  {   posting_account     :: !Account
  71  ,   posting_account_ref :: !(S.Maybe (S.Pair Tag_Path (S.Maybe Account)))
  72  ,   posting_amounts     :: !Amounts
  73  ,   posting_comments    :: ![Comment]
  74  ,   posting_dates       :: ![Date]
  75  ,   posting_sourcepos   :: !SourcePos
  76  ,   posting_tags        :: !Posting_Tags
  77  } deriving (Data, Eq, Ord, Show, Typeable)
  78 instance NFData Posting where
  79         rnf Posting{..} =
  80                 rnf posting_account `seq`
  81                 rnf posting_account_ref `seq`
  82                 rnf posting_amounts `seq`
  83                 rnf posting_comments `seq`
  84                 rnf posting_dates `seq`
  85                 -- rnf posting_sourcepos `seq`
  86                 rnf posting_tags
  87 instance H.Get (TreeMap.Path Account_Section) Posting where
  88         get = H.get . posting_account
  89 instance H.Get (Map Unit (H.Polarized Quantity)) Posting where
  90         get Posting{posting_amounts = Amounts amts} = H.polarize <$> amts
  91 instance H.Set (Map Unit (H.Polarized Quantity)) Posting where
  92         set amts p = p{posting_amounts = Amounts $ H.depolarize <$> amts}
  93 instance H.Get (H.Balance_Amounts Unit Quantity) Posting where
  94         get = H.get . posting_amounts
  95
  96 posting :: Account -> Posting
  97 posting acct =
  98         Posting
  99          { posting_account     = acct
 100          , posting_account_ref = S.Nothing
 101          , posting_amounts     = H.quantity_zero
 102          , posting_comments    = mempty
 103          , posting_dates       = mempty
 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 H.Posting Posting
 114
 115 type instance H.Account H.:@ Posting = Account
 116 instance H.GetI H.Account Posting where
 117         getI_ _ = posting_account
 118 instance H.SetI H.Account Posting where
 119         setI_ _ posting_account p = p{posting_account}
 120
 121 type instance H.Amounts H.:@ Posting = Amounts
 122 instance H.GetI H.Amounts Posting where
 123         getI_ _ = posting_amounts
 124 instance H.SetI H.Amounts Posting where
 125         setI_ _ posting_amounts p = p{posting_amounts}
 126
 127 {-
 128 -- * Type 'Posting_Anchor'
 129 newtype Posting_Anchor = Posting_Anchor Anchor
 130  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 131 -- * Type 'Posting_Anchors'
 132 newtype Posting_Anchors = Posting_Anchors Anchors
 133  deriving (Data, Eq, Monoid, NFData, Ord, Semigroup, Show, Typeable)
 134 type instance MT.Element Posting_Anchors = Posting_Anchor
 135 -}
 136
 137 -- * Type 'Posting_Tag'
 138 newtype Posting_Tag = Posting_Tag Tag
 139  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 140 -- * Type 'Posting_Tags'
 141 newtype Posting_Tags = Posting_Tags Tags
 142  deriving (Data, Eq, Monoid, NFData, Ord, Semigroup, Show, Typeable)
 143 type instance MT.Element Posting_Tags = Posting_Tag
 144
 145 -- ** Type 'Comment'
 146 newtype Comment = Comment Text
 147  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 148
 149 -- * Type 'Postings'
 150 newtype Postings = Postings (Map Account [Posting])
 151  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 152 unPostings :: Postings -> Map Account [Posting]
 153 unPostings (Postings ps) = ps
 154 type instance H.Postings H.:@ Postings = Postings
 155 instance H.Get Postings Postings where
 156         get = id
 157 instance H.Postings Postings
 158 instance Semigroup Postings where
 159         Postings x <> Postings y =
 160                 Postings $ Map.unionWith (flip (<>)) x y
 161 instance Monoid Postings where
 162         mempty  = Postings mempty
 163         mappend = (<>)
 164 type instance MT.Element Postings = Posting
 165 instance MT.MonoFunctor Postings where
 166         omap f (Postings m) = Postings (MT.omap f `MT.omap` m)
 167 instance MT.MonoFoldable Postings where
 168         ofoldMap f   (Postings m) = MT.ofoldMap f   (Compose m)
 169         ofoldr f a   (Postings m) = MT.ofoldr f a   (Compose m)
 170         ofoldr1Ex f  (Postings m) = MT.ofoldr1Ex f  (Compose m)
 171         ofoldl1Ex' f (Postings m) = MT.ofoldl1Ex' f (Compose m)
 172         ofoldl' f a  (Postings m) = MT.ofoldl' f a  (Compose m)
 173
 174
 175 {-
 176 -- Posting
 177 instance H.Posting Posting where
 178         type Posting_Account Posting = Account
 179         type Posting_Amount  Posting = Amount
 180         type Amounts Posting = [Amount]
 181         posting_account = posting_account
 182         posting_amounts = (uncurry Amount <$>) . Map.toList . posting_amounts
 183 instance H.Posting (Charted Posting) where
 184         type Posting_Account (Charted Posting) = Charted Account
 185         type Posting_Amount  (Charted Posting) = H.Posting_Amount  Posting
 186         type Amounts (Charted Posting) = H.Amounts Posting
 187         posting_account = (H.posting_account <$>)
 188         posting_amounts = H.posting_amounts . charted
 189
 190 -- Balance
 191 instance H.Balance_Posting Posting where
 192         type Balance_Posting_Quantity Posting = H.Polarized Quantity
 193         balance_posting_amounts = (H.polarize <$>) . posting_amounts
 194         balance_posting_amounts_set amounts p =
 195                 p { posting_amounts = H.depolarize <$> amounts }
 196 instance H.Balance_Posting (Charted Posting) where
 197         type Balance_Posting_Quantity (Charted Posting) = H.Balance_Posting_Quantity Posting
 198         balance_posting_amounts = H.balance_posting_amounts . charted
 199         balance_posting_amounts_set amounts (Charted c p) =
 200                 Charted c p{ posting_amounts = H.depolarize <$> amounts }
 201
 202 -- GL
 203 instance H.GL_Posting Posting where
 204         type GL_Posting_Quantity Posting = Map Unit (H.Polarized Quantity)
 205         gl_posting_quantity = (H.polarize <$>) . posting_amounts
 206 instance H.GL_Posting (Charted Posting) where
 207         type GL_Posting_Quantity (Charted Posting) = H.GL_Posting_Quantity Posting
 208         gl_posting_quantity = H.gl_posting_quantity . charted
 209 -}