]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/GL.hs
Refactor hcompta-lib.
[comptalang.git] / lib / Hcompta / GL.hs
1 -- | General Ledger
2 module Hcompta.GL where
3
4 import Control.DeepSeq (NFData(..))
5 import Control.Exception (assert)
6 import Data.Bool
7 import Data.Data
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 Data.Maybe (Maybe(..))
14 import Data.Ord (Ord(..))
15 import Data.Sequence (Seq, (><), (|>), ViewR(..))
16 import Data.TreeMap.Strict (TreeMap(..))
17 import Data.Tuple (snd)
18 import Data.Typeable ()
19 import Prelude (seq, undefined)
20 import Text.Show (Show(..))
21 import qualified Data.Map.Strict as Map
22 import qualified Data.MonoTraversable as MT
23 import qualified Data.Sequence as Seq
24 import qualified Data.Strict.Maybe as Strict
25 import qualified Data.Traversable as Traversable
26 import qualified Data.TreeMap.Strict as TM
27
28 import Hcompta.Data
29 import Hcompta.Quantity
30 import qualified Hcompta.Lib.Strict as Strict
31
32 -- * Type 'GL'
33 newtype GL txn date post name amt
34 = GL (TreeMap name
35 (Map date (Seq (LineGL txn post amt))))
36 deriving (Data, Eq, NFData, Show, Typeable)
37
38 instance Zeroable (GL txn date post name amt) where
39 zero = GL zero
40 instance (Ord name, Ord date) => Addable (GL txn date post name amt) where
41 GL x + GL y = GL $ TM.union (Map.unionWith (flip (+))) x y
42 -- | NOTE: to reduce memory consumption when applying '(+=)' iteratively,
43 -- the given 'GL' is matched strictly.
44 instance ( post ~ MT.Element posts
45 , MT.MonoFoldable posts
46 , Get posts txn
47 , Get date txn
48 , Get amt post
49 , Get (TM.Path name) post
50 , Addable amt
51 , Ord name
52 , Ord date
53 ) =>
54 Sumable (GL txn date post name amt) (txn, posts) where
55 GL !gl += (txn, posts) = GL $
56 MT.ofoldl'
57 (flip $ \post ->
58 let first_line =
59 LineGL
60 { lineGL_transaction = txn
61 , lineGL_posting = post
62 , lineGL_sum = get @amt post
63 } in
64 let single =
65 Map.singleton (get @date txn) $
66 Seq.singleton first_line in
67 TM.insert
68 (\_new old ->
69 let (nlt, leq, neq, ngt) =
70 case Map.splitLookup (get @date txn) old of
71 (olt, Nothing, ogt) | Map.null olt ->
72 (olt, first_line, Seq.singleton first_line, ogt)
73 (olt, Nothing, ogt) ->
74 let line =
75 case Seq.viewr $ snd $ Map.findMax olt of
76 (_:>LineGL{lineGL_sum = s}) ->
77 first_line{lineGL_sum = s + get @amt post}
78 _ -> first_line
79 in (olt, line, Seq.singleton line, ogt)
80 (olt, Just oeq, ogt) ->
81 case Seq.viewr oeq of
82 (_:>LineGL{lineGL_sum = s}) ->
83 let line = first_line{lineGL_sum = s + get @amt post} in
84 (olt, line, oeq |> line, ogt)
85 _ -> (olt, first_line, Seq.singleton first_line, ogt)
86 in
87 Map.union nlt $
88 Map.insert (get @date txn) neq $
89 Map.map
90 (fmap (\l -> l{lineGL_sum =
91 lineGL_sum leq + lineGL_sum l}))
92 ngt
93 )
94 (get post)
95 single
96 )
97 gl
98 posts
99
100 -- ** Type 'LineGL'
101 data LineGL txn post amt
102 = LineGL
103 { lineGL_transaction :: txn
104 , lineGL_posting :: post
105 , lineGL_sum :: amt
106 } deriving (Data, Eq, Show, Typeable)
107 instance (NFData txn, NFData post, NFData amt) => NFData (LineGL txn post amt) where
108 rnf LineGL{..} =
109 rnf lineGL_transaction `seq`
110 rnf lineGL_posting `seq`
111 rnf lineGL_sum
112
113 -- * Type 'ExpandedGL'
114 -- | Descending propagation of amounts accross accounts.
115 newtype ExpandedGL txn date post name amt
116 = ExpandedGL (TreeMap name (LineExpandedGL txn date post amt))
117 deriving (Data, Eq, NFData, Show, Typeable)
118
119 -- ** Type 'LineExpandedGL'
120 -- |
121 -- * 'Strict.exclusive': contains the original 'LineGL's.
122 -- * 'Strict.inclusive': contains ('+') folded
123 -- over 'Strict.exclusive' and 'Strict.inclusive'
124 -- of 'TM.node_descendants'.
125 type LineExpandedGL txn date post amt
126 = Strict.Clusive (Map date (Seq (LineGL txn post amt)))
127
128 -- | Return the given 'GL' with:
129 --
130 -- * all missing parent accounts inserted;
131 -- * and every mapped 'LineGL' added with any 'LineGL'
132 -- of the accounts for which it is parent.
133 expandedGL ::
134 forall txn date post name amt.
135 ( Get amt post
136 , Addable amt
137 , Ord name
138 , Ord date
139 ) =>
140 GL txn date post name amt ->
141 ExpandedGL txn date post name amt
142 expandedGL (GL gl) =
143 let from_value =
144 Strict.fromMaybe (assert False undefined) .
145 TM.node_value in
146 ExpandedGL $
147 TM.map_by_depth_first
148 (\(TreeMap nodes) value ->
149 let exclusive = Strict.fromMaybe Map.empty value in
150 Strict.Clusive
151 { Strict.exclusive
152 , Strict.inclusive =
153 getCompose $
154 snd $
155 Traversable.mapAccumL -- NOTE: recalc 'lineGL_sum's
156 (\may_sum line ->
157 let amt = get @amt $ lineGL_posting line in
158 case may_sum of
159 Nothing -> (Just amt, line)
160 Just last_sum ->
161 let new_sum = last_sum + amt in
162 ( Just new_sum
163 , line{lineGL_sum=new_sum} )
164 ) Nothing $
165 Compose $
166 Map.foldr
167 (Map.unionWith (flip (><)) . Strict.inclusive . from_value)
168 exclusive nodes
169 })
170 gl