2 module Hcompta.GL where
4 import Control.DeepSeq (NFData(..))
5 import Control.Exception (assert)
8 import Data.Eq (Eq(..))
9 import Data.Function (($), (.), flip)
10 import Data.Functor (Functor(..))
11 import Data.Functor.Compose (Compose(..))
12 import Data.Map.Strict (Map)
13 import qualified Data.Map.Strict as Map
14 import Data.Maybe (Maybe(..))
15 import qualified Data.MonoTraversable as MT
16 import Data.Ord (Ord(..))
17 import Data.Semigroup (Semigroup(..))
18 import Data.Sequence (Seq, (><), (|>), ViewR(..))
19 import qualified Data.Sequence as Seq
20 import qualified Data.Strict.Maybe as Strict
21 import qualified Data.Traversable as Traversable
22 import Data.TreeMap.Strict (TreeMap(..))
23 import qualified Data.TreeMap.Strict as TreeMap
24 import Data.Tuple (snd)
25 import Data.Typeable ()
26 import Prelude (seq, undefined)
27 import Text.Show (Show(..))
29 import Hcompta.Account
32 import qualified Hcompta.Lib.Strict as Strict
33 import Hcompta.Posting
34 import Hcompta.Quantity
38 newtype GL_ tran date acct_sect post amt
39 = GL (TreeMap acct_sect
40 (Map date (Seq (GL_Line tran post amt))))
41 deriving (Data, Eq, NFData, Show, Typeable)
45 (MT.Element (Account :@ (MT.Element (Postings :@ tran))))
46 (MT.Element (Postings :@ tran))
47 (Amount :@ (MT.Element (Postings :@ tran)))
50 gl_empty = GL TreeMap.empty
52 -- * Type 'GL_Account'
53 -- | 'GL' operations works on this type of 'Account'.
54 type GL_Account = TreeMap.Path
56 -- | Return the given 'GL'
57 -- updated by the given 'GL_Transaction'.
59 -- NOTE: to reduce memory consumption when applying 'gl_cons' iteratively,
60 -- the given 'GL' is matched strictly.
62 ( post ~ MT.Element (Postings :@ tran)
63 , acct_sect ~ MT.Element (Account :@ post)
67 , Get (GL_Account acct_sect) post
68 , MT.MonoFoldable (Postings :@ tran)
69 , Addable (Amount :@ post)
72 ) => tran -> GL tran -> GL tran
73 gl_cons tran (GL !gl) =
79 { gl_line_transaction = tran
80 , gl_line_posting = post
81 , gl_line_sum = getI @Amount post
84 Map.singleton (getI @Date tran) $
85 Seq.singleton first_line in
88 let (nlt, leq, neq, ngt) =
89 case Map.splitLookup (getI @Date tran) old of
90 (olt, Nothing, ogt) | Map.null olt ->
91 (olt, first_line, Seq.singleton first_line, ogt)
92 (olt, Nothing, ogt) ->
94 case Seq.viewr $ snd $ Map.findMax olt of
95 (_:>GL_Line{gl_line_sum = s}) ->
96 first_line{gl_line_sum = quantity_add s $ getI @Amount post}
98 in (olt, line, Seq.singleton line, ogt)
99 (olt, Just oeq, ogt) ->
100 case Seq.viewr oeq of
101 (_:>GL_Line{gl_line_sum = s}) ->
102 let line = first_line{gl_line_sum = quantity_add s $ getI @Amount post} in
103 (olt, line, oeq |> line, ogt)
104 _ -> (olt, first_line, Seq.singleton first_line, ogt)
107 Map.insert (getI @Date tran) neq $
109 (fmap (\l -> l{gl_line_sum =
110 quantity_add (gl_line_sum leq) $ gl_line_sum l}))
117 (getI @Postings tran)
120 ( post ~ MT.Element (Postings :@ tran)
121 , Ord (MT.Element (Account :@ post))
123 ) => GL tran -> GL tran -> GL tran
124 gl_union (GL x) (GL y) =
125 GL $ TreeMap.union (Map.unionWith (flip (<>))) x y
128 data GL_Line tran post amt
130 { gl_line_transaction :: tran
131 , gl_line_posting :: post
134 deriving (Data, Eq, Show, Typeable)
139 ) => NFData (GL_Line tran post amt) where
141 rnf gl_line_transaction `seq`
142 rnf gl_line_posting `seq`
146 -- * Type 'ExpandedGL'
148 -- | Descending propagation of 'Amount's accross 'Account's.
149 newtype ExpandedGL_ tran date acct_sect post amt
150 = ExpandedGL (TreeMap acct_sect (ExpandedGL_Line tran date post amt))
151 deriving (Data, Eq, NFData, Show, Typeable)
155 (MT.Element (Account :@ (MT.Element (Postings :@ tran))))
156 (MT.Element (Postings :@ tran))
157 (Amount :@ (MT.Element (Postings :@ tran)))
159 -- ** Type 'ExpandedGL_Line'
161 -- * 'Strict.exclusive': contains the original 'GL_Line's.
162 -- * 'Strict.inclusive': contains 'quantity_add' folded
163 -- over 'Strict.exclusive' and 'Strict.inclusive'
164 -- of 'TreeMap.node_descendants'
165 type ExpandedGL_Line tran date post amt
166 = Strict.Clusive (Map date (Seq (GL_Line tran post amt)))
168 -- | Return the given 'GL' with:
170 -- * all missing 'Account.parent' 'Account's inserted;
171 -- * and every mapped 'GL_Line'
172 -- added with any 'GL_Line'
173 -- of the 'Account's for which it is 'Account.parent'.
175 ( post ~ MT.Element (Postings :@ tran)
177 , Addable (Amount :@ post)
178 , MT.MonoFoldable (Postings :@ tran)
179 , Ord (MT.Element (Account :@ post))
181 ) => GL tran -> ExpandedGL tran
182 expanded_gl (GL gl) =
184 Strict.fromMaybe (assert False undefined) .
185 TreeMap.node_value in
187 TreeMap.map_by_depth_first
188 (\(TreeMap nodes) value ->
189 let exclusive = Strict.fromMaybe Map.empty value in
195 Traversable.mapAccumL -- NOTE: recalc 'gl_line_sum's
197 let amt = getI @Amount $ gl_line_posting line in
199 Nothing -> (Just amt, line)
201 let new_sum = quantity_add last_sum amt in
203 , line{gl_line_sum=new_sum} )
207 (Map.unionWith (flip (><)) . Strict.inclusive . from_value)