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 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 instance H.Postings Postings
 155 instance Semigroup Postings where
 156         Postings x <> Postings y =
 157                 Postings $ Map.unionWith (flip (<>)) x y
 158 instance Monoid Postings where
 159         mempty  = Postings mempty
 160         mappend = (<>)
 161 type instance MT.Element Postings = Posting
 162 instance MT.MonoFunctor Postings where
 163         omap f (Postings m) = Postings (MT.omap f `MT.omap` m)
 164 instance MT.MonoFoldable Postings where
 165         ofoldMap f   (Postings m) = MT.ofoldMap f   (Compose m)
 166         ofoldr f a   (Postings m) = MT.ofoldr f a   (Compose m)
 167         ofoldr1Ex f  (Postings m) = MT.ofoldr1Ex f  (Compose m)
 168         ofoldl1Ex' f (Postings m) = MT.ofoldl1Ex' f (Compose m)
 169         ofoldl' f a  (Postings m) = MT.ofoldl' f a  (Compose m)
 170
 171
 172 {-
 173 -- Posting
 174 instance H.Posting Posting where
 175         type Posting_Account Posting = Account
 176         type Posting_Amount  Posting = Amount
 177         type Amounts Posting = [Amount]
 178         posting_account = posting_account
 179         posting_amounts = (uncurry Amount <$>) . Map.toList . posting_amounts
 180 instance H.Posting (Charted Posting) where
 181         type Posting_Account (Charted Posting) = Charted Account
 182         type Posting_Amount  (Charted Posting) = H.Posting_Amount  Posting
 183         type Amounts (Charted Posting) = H.Amounts Posting
 184         posting_account = (H.posting_account <$>)
 185         posting_amounts = H.posting_amounts . charted
 186
 187 -- Balance
 188 instance H.Balance_Posting Posting where
 189         type Balance_Posting_Quantity Posting = H.Polarized Quantity
 190         balance_posting_amounts = (H.polarize <$>) . posting_amounts
 191         balance_posting_amounts_set amounts p =
 192                 p { posting_amounts = H.depolarize <$> amounts }
 193 instance H.Balance_Posting (Charted Posting) where
 194         type Balance_Posting_Quantity (Charted Posting) = H.Balance_Posting_Quantity Posting
 195         balance_posting_amounts = H.balance_posting_amounts . charted
 196         balance_posting_amounts_set amounts (Charted c p) =
 197                 Charted c p{ posting_amounts = H.depolarize <$> amounts }
 198
 199 -- GL
 200 instance H.GL_Posting Posting where
 201         type GL_Posting_Quantity Posting = Map Unit (H.Polarized Quantity)
 202         gl_posting_quantity = (H.polarize <$>) . posting_amounts
 203 instance H.GL_Posting (Charted Posting) where
 204         type GL_Posting_Quantity (Charted Posting) = H.GL_Posting_Quantity Posting
 205         gl_posting_quantity = H.gl_posting_quantity . charted
 206 -}