1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE DeriveDataTypeable #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE MultiParamTypeClasses #-}
6 {-# LANGUAGE NamedFieldPuns #-}
7 {-# LANGUAGE StandaloneDeriving #-}
8 {-# LANGUAGE TypeFamilies #-}
9 {-# OPTIONS_GHC -fno-warn-deprecations #-} -- FIXME: to be removed when dropping GHC-7.6 support
11 module Hcompta.GL where
13 -- import Control.Applicative (Const(..))
14 import Control.DeepSeq (NFData(..))
15 import Control.Exception (assert)
18 import Data.Eq (Eq(..))
19 import qualified Data.Foldable
20 import Data.Foldable (Foldable(..))
21 import Data.Functor (Functor(..))
22 import Data.Functor.Compose (Compose(..))
23 import Data.List (filter)
24 import Data.Map.Strict (Map)
25 import qualified Data.Map.Strict as Map
26 import Data.Maybe (Maybe(..))
27 import Data.Monoid (Monoid(..))
28 import qualified Data.Sequence
29 import Data.Sequence (Seq, (><), (|>), ViewR(..))
30 import qualified Data.Strict.Maybe as Strict
31 import qualified Data.Traversable
32 import Data.Tuple (fst, snd)
33 import Data.Typeable ()
34 import Prelude (($), (.), flip, seq, undefined)
35 import Text.Show (Show(..))
37 import Hcompta.Quantity (Addable(..))
38 import Hcompta.Account (Account(..))
39 import Hcompta.Date (Date)
40 import qualified Hcompta.Lib.TreeMap as TreeMap
41 import Hcompta.Lib.TreeMap (TreeMap)
43 -- * Requirements' interface
48 ( Account (Posting_Account p)
49 , Addable (Posting_Quantity p)
50 , Data (Posting_Quantity p)
51 , NFData (Posting_Quantity p)
52 , Show (Posting_Quantity p)
54 type Posting_Account p
55 type Posting_Quantity p
56 posting_account :: p -> Posting_Account p
57 posting_quantity :: p -> Posting_Quantity p
63 => Posting (account, quantity)
65 type Posting_Account (account, quantity) = account
66 type Posting_Quantity (account, quantity) = quantity
67 posting_account (x, _) = x
68 posting_quantity (_, x) = x
70 -- ** Class 'Transaction'
73 ( Data (Transaction_Posting t)
74 , Posting (Transaction_Posting t)
75 , NFData (Transaction_Posting t)
76 , Show (Transaction_Posting t)
77 , Foldable (Transaction_Postings t)
78 ) => Transaction t where
79 type Transaction_Posting t
80 type Transaction_Postings t :: * -> *
81 transaction_date :: t -> Date
82 transaction_postings :: t -> Transaction_Postings t (Transaction_Posting t)
83 transaction_postings_filter :: (Transaction_Posting t -> Bool) -> t -> t
85 {- NOTE: not needed so far.
91 , account ~ Posting_Account posting
92 ) => Transaction (Date, Map account ([] posting))
94 type Transaction_Posting (Date, Map account ([] posting)) = posting
95 type Transaction_Postings (Date, Map account ([] posting)) = Compose (Map account) []
96 transaction_date = fst
97 transaction_postings = Compose . snd
98 transaction_postings_filter f =
101 (\p -> case filter f p of
112 ) => Transaction (Date, [posting])
114 type Transaction_Posting (Date, [posting]) = posting
115 type Transaction_Postings (Date, [posting]) = []
116 transaction_date = fst
117 transaction_postings = snd
118 transaction_postings_filter = fmap . filter
122 newtype Transaction transaction
124 = GL (TreeMap (Account_Section (Posting_Account (Transaction_Posting transaction)))
126 (Seq (GL_Line transaction))))
127 deriving instance ( Transaction transaction
129 ) => Data (GL transaction)
130 deriving instance ( Transaction transaction
132 ) => Show (GL transaction)
133 deriving instance Typeable1 GL
134 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
135 instance Transaction transaction
136 => Monoid (GL transaction) where
142 ) => NFData (GL t) where
146 Transaction transaction
147 => GL_Line transaction
149 { gl_line_transaction :: transaction
150 , gl_line_posting :: Transaction_Posting transaction
151 , gl_line_sum :: Posting_Quantity (Transaction_Posting transaction)
153 deriving instance ( Transaction transaction
155 , Typeable transaction
157 ) => Data (GL_Line transaction)
158 deriving instance ( Transaction transaction
160 ) => Show (GL_Line transaction)
161 deriving instance Typeable1 GL_Line
162 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
166 ) => NFData (GL_Line t) where
167 rnf (GL_Line x y z) = rnf x `seq` rnf y `seq` rnf z
172 :: Transaction transaction
176 -- | Return the given 'GL'
177 -- updated by the given 'Transaction'.
179 -- NOTE: to reduce memory consumption when 'cons'ing iteratively,
180 -- the given 'GL' is matched strictly.
182 :: Transaction transaction
192 { gl_line_transaction = t
193 , gl_line_posting = p
194 , gl_line_sum = posting_quantity p
197 Map.singleton (transaction_date t) $
198 Data.Sequence.singleton first_line in
201 let (nlt, leq, neq, ngt) =
202 case Map.splitLookup (transaction_date t) old of
203 (olt, Nothing, ogt) | Map.null olt ->
204 (olt, first_line, Data.Sequence.singleton first_line, ogt)
205 (olt, Nothing, ogt) ->
207 case Data.Sequence.viewr $ snd $ Map.findMax olt of
208 (_:>GL_Line{gl_line_sum = s}) ->
209 first_line{gl_line_sum = quantity_add s $ posting_quantity p}
211 in (olt, line, Data.Sequence.singleton line, ogt)
212 (olt, Just oeq, ogt) ->
213 case Data.Sequence.viewr oeq of
214 (_:>GL_Line{gl_line_sum = s}) ->
215 let line = first_line{gl_line_sum = quantity_add s $ posting_quantity p} in
216 (olt, line, oeq |> line, ogt)
217 _ -> (olt, first_line, Data.Sequence.singleton first_line, ogt)
220 Map.insert (transaction_date t) neq $
222 (fmap (\l -> l{gl_line_sum =
223 quantity_add (gl_line_sum leq) $ gl_line_sum l}))
226 (account_path $ posting_account p)
230 (transaction_postings t)
233 :: Transaction transaction
237 union (GL gl0) (GL gl1) =
240 (Map.unionWith mappend)
245 -- | Descending propagation of 'Amount's accross 'Account's.
246 type Expanded transaction
247 = TreeMap (Account_Section (Posting_Account (Transaction_Posting transaction)))
248 (GL_Line_Expanded transaction)
249 data Transaction transaction
250 => GL_Line_Expanded transaction
252 { exclusive :: !(Map Date (Seq (GL_Line transaction)))
253 , inclusive :: !(Map Date (Seq (GL_Line transaction))) -- ^ 'quantity_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
255 deriving instance ( Transaction transaction
257 ) => Data (GL_Line_Expanded transaction)
258 deriving instance ( Transaction transaction
260 ) => Show (GL_Line_Expanded transaction)
261 deriving instance Typeable1 GL_Line_Expanded
262 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
264 -- | Return the given 'GL' with:
266 -- * all missing 'Account.ascending' 'Account's inserted,
268 -- * and every mapped 'GL_Line'
269 -- added with any 'GL_Line'
270 -- of the 'Account's for which it is 'Account.ascending'.
272 :: Transaction transaction
274 -> Expanded transaction
276 let from_value = Strict.fromMaybe (assert False undefined) . TreeMap.node_value in
277 TreeMap.map_by_depth_first
278 (\(TreeMap.TreeMap nodes) value ->
279 let exclusive = Strict.fromMaybe Map.empty value in
285 Data.Traversable.mapAccumL -- NOTE: recalc 'gl_line_sum's
287 let qty = posting_quantity $ gl_line_posting line in
289 Nothing -> (Just qty, line)
291 let new_sum = quantity_add last_sum qty in
293 , line{gl_line_sum=new_sum} )
297 (Map.unionWith (flip (><)) . inclusive . from_value)