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