]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/GL.hs
Ajout : CLI.Command.* : intégration de --reduce-date.
[comptalang.git] / lib / Hcompta / GL.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE NamedFieldPuns #-}
5 {-# LANGUAGE StandaloneDeriving #-}
6 {-# LANGUAGE TypeFamilies #-}
7 {-# OPTIONS_GHC -fno-warn-deprecations #-} -- FIXME: to be removed when dropping GHC-7.6 support
8 -- | General Ledger
9 module Hcompta.GL where -- General Ledger
10
11 import Control.Exception (assert)
12 import Data.Data
13 import qualified Data.Foldable
14 -- import Data.Foldable (Foldable)
15 import Data.Functor.Compose (Compose(..))
16 import Data.Maybe (fromMaybe)
17 import qualified Data.Sequence
18 import Data.Sequence (Seq, (><), (|>), ViewR(..))
19 import qualified Data.Traversable
20 import qualified Data.Map.Strict as Data.Map
21 import Data.Map.Strict (Map)
22 import Data.Typeable ()
23
24 import qualified Hcompta.Account as Account
25 import Hcompta.Account (Account)
26 import Hcompta.Date (Date)
27 import qualified Hcompta.Lib.TreeMap as TreeMap
28 import Hcompta.Lib.TreeMap (TreeMap)
29
30 -- * Requirements' interface
31
32 -- ** Class 'Amount'
33 class
34 ( Data (Amount_Unit a)
35 , Data a
36 , Eq a
37 , Ord (Amount_Unit a)
38 , Show (Amount_Unit a)
39 , Show a
40 , Typeable (Amount_Unit a)
41 ) => Amount a where
42 type Amount_Unit a
43 amount_add :: a -> a -> a
44
45 -- ** Class 'Posting'
46
47 -- | A 'posting' used to produce a 'GL'
48 -- must be an instance of this class.
49 class Amount (Posting_Amount p)
50 => Posting p where
51 type Posting_Amount p
52 posting_account :: p -> Account
53 posting_amount :: p -> Posting_Amount p
54
55 instance (Amount amount)
56 => Posting (Account, amount)
57 where
58 type Posting_Amount (Account, amount) = amount
59 posting_account (x, _) = x
60 posting_amount (_, x) = x
61
62 -- ** Class 'Transaction'
63
64 class
65 ( Posting (Transaction_Posting t)
66 , Data (Transaction_Posting t)
67 , Eq (Transaction_Posting t)
68 , Show (Transaction_Posting t)
69 , Foldable (Transaction_Postings t)
70 ) => Transaction t where
71 type Transaction_Posting t
72 type Transaction_Postings t :: * -> *
73 transaction_date :: t -> Date
74 transaction_postings :: t -> Transaction_Postings t (Transaction_Posting t)
75
76 instance
77 ( Posting posting
78 , Data posting
79 , Eq posting
80 , Show posting
81 ) => Transaction (Date, Map Account ([] posting))
82 where
83 type Transaction_Posting (Date, Map Account ([] posting)) = posting
84 type Transaction_Postings (Date, Map Account ([] posting)) = Compose (Map Account) []
85 transaction_date = fst
86 transaction_postings = Compose . snd
87
88 -- * Type 'GL'
89
90 newtype Transaction transaction
91 => GL transaction
92 = GL (TreeMap Account.Name (Map Date (Seq (GL_Line transaction))))
93 deriving instance ( Transaction transaction
94 , Data transaction
95 , Typeable transaction
96 , Typeable GL_Line
97 ) => Data (GL transaction)
98 deriving instance ( Transaction transaction
99 , Eq transaction
100 ) => Eq (GL transaction)
101 deriving instance ( Transaction transaction
102 , Show transaction
103 ) => Show (GL transaction)
104 deriving instance Typeable1 GL
105 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
106
107 data
108 Transaction transaction
109 => GL_Line transaction
110 = GL_Line
111 { gl_line_transaction :: transaction
112 , gl_line_posting :: Transaction_Posting transaction
113 , gl_line_sum :: Posting_Amount (Transaction_Posting transaction)
114 }
115 deriving instance ( Transaction transaction
116 , Data transaction
117 , Typeable transaction
118 , Typeable GL_Line
119 ) => Data (GL_Line transaction)
120 deriving instance ( Transaction transaction
121 , Eq transaction
122 ) => Eq (GL_Line transaction)
123 deriving instance ( Transaction transaction
124 , Show transaction
125 ) => Show (GL_Line transaction)
126 deriving instance Typeable1 GL_Line
127 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
128
129 -- ** Constructors
130
131 nil
132 :: Transaction transaction
133 => GL transaction
134 nil = GL TreeMap.empty
135
136 -- | Return the given 'GL'
137 -- updated by the given 'Transaction'.
138 general_ledger
139 :: Transaction transaction
140 => transaction
141 -> GL transaction
142 -> GL transaction
143 general_ledger t (GL gl) =
144 GL $
145 Data.Foldable.foldr
146 ((\p ->
147 let first_line =
148 GL_Line
149 { gl_line_transaction = t
150 , gl_line_posting = p
151 , gl_line_sum = posting_amount p
152 } in
153 let single =
154 Data.Map.singleton (transaction_date t) $
155 Data.Sequence.singleton first_line in
156 TreeMap.insert
157 (\_new old ->
158 let (nlt, leq, neq, ngt) =
159 case Data.Map.splitLookup (transaction_date t) old of
160 (olt, Nothing, ogt) | Data.Map.null olt ->
161 (olt, first_line, Data.Sequence.singleton first_line, ogt)
162 (olt, Nothing, ogt) ->
163 let line =
164 case Data.Sequence.viewr $ snd $ Data.Map.findMax olt of
165 (_:>GL_Line{gl_line_sum = s}) ->
166 first_line{gl_line_sum = amount_add s $ posting_amount p}
167 _ -> first_line
168 in (olt, line, Data.Sequence.singleton line, ogt)
169 (olt, Just oeq, ogt) ->
170 case Data.Sequence.viewr oeq of
171 (_:>GL_Line{gl_line_sum = s}) ->
172 let line = first_line{gl_line_sum = amount_add s $ posting_amount p} in
173 (olt, line, oeq |> line, ogt)
174 _ -> (olt, first_line, Data.Sequence.singleton first_line, ogt)
175 in
176 Data.Map.union nlt $
177 Data.Map.insert (transaction_date t) neq $
178 Data.Map.map (fmap (\l -> l{gl_line_sum =
179 amount_add (gl_line_sum leq) $
180 gl_line_sum l})) ngt
181 )
182 (posting_account p)
183 single
184 ))
185 gl
186 (transaction_postings t)
187
188 -- * Type 'Expanded'
189
190 -- | Descending propagation of 'Amount's accross 'Account's.
191 type Expanded transaction
192 = TreeMap Account.Name (GL_Line_Expanded transaction)
193 data Transaction transaction
194 => GL_Line_Expanded transaction
195 = GL_Line_Expanded
196 { exclusive :: Map Date (Seq (GL_Line transaction))
197 , inclusive :: Map Date (Seq (GL_Line transaction)) -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
198 }
199 deriving instance ( Transaction transaction
200 , Data transaction
201 ) => Data (GL_Line_Expanded transaction)
202 deriving instance ( Transaction transaction
203 , Eq transaction
204 ) => Eq (GL_Line_Expanded transaction)
205 deriving instance ( Transaction transaction
206 , Show transaction
207 ) => Show (GL_Line_Expanded transaction)
208 deriving instance Typeable1 GL_Line_Expanded
209 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
210
211 -- | Return the given 'GL' with:
212 --
213 -- * all missing 'Account.ascending' 'Account's inserted,
214 --
215 -- * and every mapped 'GL_Line'
216 -- added with any 'GL_Line'
217 -- of the 'Account's for which it is 'Account.ascending'.
218 expanded
219 :: Transaction transaction
220 => GL transaction
221 -> Expanded transaction
222 expanded (GL gl) =
223 let from_value = fromMaybe (assert False undefined) . TreeMap.node_value in
224 TreeMap.map_by_depth_first
225 (\descendants value ->
226 let nodes = TreeMap.nodes descendants in
227 let exclusive = fromMaybe Data.Map.empty value in
228 GL_Line_Expanded
229 { exclusive
230 , inclusive =
231 getCompose $
232 snd $
233 Data.Traversable.mapAccumL
234 (\ms line ->
235 let pamt = posting_amount $ gl_line_posting line in
236 case ms of
237 Nothing -> (Just pamt, line)
238 Just s ->
239 let ls = amount_add s pamt in
240 ( Just ls
241 , line{gl_line_sum=ls} )
242 ) Nothing $
243 Compose $
244 Data.Map.foldr
245 (Data.Map.unionWith (><) . inclusive . from_value)
246 exclusive nodes
247 })
248 gl