]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/GL.hs
Use symantic-document instead of walderleijen-ansi-text.
[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 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(..))
28
29 import Hcompta.Account
30 import Hcompta.Amount
31 import Hcompta.Date
32 import qualified Hcompta.Lib.Strict as Strict
33 import Hcompta.Posting
34 import Hcompta.Quantity
35 import Hcompta.Has
36
37 -- * Type 'GL'
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)
42 type GL tran
43 = GL_ tran
44 (Date :@ tran)
45 (MT.Element (Account :@ (MT.Element (Postings :@ tran))))
46 (MT.Element (Postings :@ tran))
47 (Amount :@ (MT.Element (Postings :@ tran)))
48
49 gl_empty :: GL tran
50 gl_empty = GL TreeMap.empty
51
52 -- * Type 'GL_Account'
53 -- | 'GL' operations works on this type of 'Account'.
54 type GL_Account = TreeMap.Path
55
56 -- | Return the given 'GL'
57 -- updated by the given 'GL_Transaction'.
58 --
59 -- NOTE: to reduce memory consumption when applying 'gl_cons' iteratively,
60 -- the given 'GL' is matched strictly.
61 gl_cons ::
62 ( post ~ MT.Element (Postings :@ tran)
63 , acct_sect ~ MT.Element (Account :@ post)
64 , GetI Postings tran
65 , GetI Date tran
66 , GetI Amount post
67 , Get (GL_Account acct_sect) post
68 , MT.MonoFoldable (Postings :@ tran)
69 , Addable (Amount :@ post)
70 , Ord acct_sect
71 , Ord (Date :@ tran)
72 ) => tran -> GL tran -> GL tran
73 gl_cons tran (GL !gl) =
74 GL $
75 MT.ofoldl'
76 (flip $ \post ->
77 let first_line =
78 GL_Line
79 { gl_line_transaction = tran
80 , gl_line_posting = post
81 , gl_line_sum = getI @Amount post
82 } in
83 let single =
84 Map.singleton (getI @Date tran) $
85 Seq.singleton first_line in
86 TreeMap.insert
87 (\_new old ->
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) ->
93 let line =
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}
97 _ -> first_line
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)
105 in
106 Map.union nlt $
107 Map.insert (getI @Date tran) neq $
108 Map.map
109 (fmap (\l -> l{gl_line_sum =
110 quantity_add (gl_line_sum leq) $ gl_line_sum l}))
111 ngt
112 )
113 (get post)
114 single
115 )
116 gl
117 (getI @Postings tran)
118
119 gl_union ::
120 ( post ~ MT.Element (Postings :@ tran)
121 , Ord (MT.Element (Account :@ post))
122 , Ord (Date :@ tran)
123 ) => GL tran -> GL tran -> GL tran
124 gl_union (GL x) (GL y) =
125 GL $ TreeMap.union (Map.unionWith (flip (<>))) x y
126
127 -- ** Type 'GL_Line'
128 data GL_Line tran post amt
129 = GL_Line
130 { gl_line_transaction :: tran
131 , gl_line_posting :: post
132 , gl_line_sum :: amt
133 }
134 deriving (Data, Eq, Show, Typeable)
135 instance -- NFData
136 ( NFData tran
137 , NFData post
138 , NFData amt
139 ) => NFData (GL_Line tran post amt) where
140 rnf GL_Line{..} =
141 rnf gl_line_transaction `seq`
142 rnf gl_line_posting `seq`
143 rnf gl_line_sum
144
145
146 -- * Type 'ExpandedGL'
147
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)
152 type ExpandedGL tran
153 = ExpandedGL_ tran
154 (Date :@ tran)
155 (MT.Element (Account :@ (MT.Element (Postings :@ tran))))
156 (MT.Element (Postings :@ tran))
157 (Amount :@ (MT.Element (Postings :@ tran)))
158
159 -- ** Type 'ExpandedGL_Line'
160 -- |
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)))
167
168 -- | Return the given 'GL' with:
169 --
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'.
174 expanded_gl ::
175 ( post ~ MT.Element (Postings :@ tran)
176 , GetI Amount post
177 , Addable (Amount :@ post)
178 , MT.MonoFoldable (Postings :@ tran)
179 , Ord (MT.Element (Account :@ post))
180 , Ord (Date :@ tran)
181 ) => GL tran -> ExpandedGL tran
182 expanded_gl (GL gl) =
183 let from_value =
184 Strict.fromMaybe (assert False undefined) .
185 TreeMap.node_value in
186 ExpandedGL $
187 TreeMap.map_by_depth_first
188 (\(TreeMap nodes) value ->
189 let exclusive = Strict.fromMaybe Map.empty value in
190 Strict.Clusive
191 { Strict.exclusive
192 , Strict.inclusive =
193 getCompose $
194 snd $
195 Traversable.mapAccumL -- NOTE: recalc 'gl_line_sum's
196 (\may_sum line ->
197 let amt = getI @Amount $ gl_line_posting line in
198 case may_sum of
199 Nothing -> (Just amt, line)
200 Just last_sum ->
201 let new_sum = quantity_add last_sum amt in
202 ( Just new_sum
203 , line{gl_line_sum=new_sum} )
204 ) Nothing $
205 Compose $
206 Map.foldr
207 (Map.unionWith (flip (><)) . Strict.inclusive . from_value)
208 exclusive nodes
209 })
210 gl