]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Transaction.hs
Gather into Writeable instances.
[comptalang.git] / lcc / Hcompta / LCC / Transaction.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
4 {-# LANGUAGE MultiParamTypeClasses #-}
5 {-# LANGUAGE OverloadedStrings #-}
6 {-# LANGUAGE NamedFieldPuns #-}
7 {-# LANGUAGE RecordWildCards #-}
8 {-# LANGUAGE TypeFamilies #-}
9 module Hcompta.LCC.Transaction where
10
11 import Control.DeepSeq (NFData(..))
12 import Data.Data (Data(..))
13 import Data.Eq (Eq(..))
14 import Data.Function (($), (.))
15 import Data.Functor.Compose (Compose(..))
16 import Data.Map.Strict (Map)
17 import Data.Monoid (Monoid(..))
18 import Data.NonNull (NonNull)
19 import Data.Ord (Ord(..))
20 import Data.String (IsString)
21 import Data.Text (Text)
22 import Data.Typeable (Typeable)
23 import Prelude (flip, seq)
24 import Text.Show (Show)
25 import qualified Data.List as List
26 import qualified Data.Map.Strict as Map
27 import qualified Data.MonoTraversable as MT
28 import qualified Data.NonNull as NonNull
29
30 import qualified Hcompta as H
31
32 import Hcompta.LCC.Account
33 import Hcompta.LCC.Tag
34 import Hcompta.LCC.Posting
35 -- import Hcompta.LCC.Chart
36
37 -- * Type 'Transaction'
38 data Transaction
39 = Transaction
40 { transaction_comments :: [Comment]
41 , transaction_dates :: NonNull [Date]
42 , transaction_postings :: Postings
43 , transaction_sourcepos :: SourcePos
44 , transaction_tags :: Transaction_Tags
45 , transaction_wording :: Wording
46 } deriving (Data, Eq, Ord, Show, Typeable)
47 transaction_date :: Transaction -> Date
48 transaction_date = NonNull.head . transaction_dates
49 -- instance H.Transaction Transaction
50 instance NFData Transaction where
51 rnf Transaction{..} =
52 rnf transaction_comments `seq`
53 rnf transaction_dates `seq`
54 rnf transaction_postings `seq`
55 -- rnf transaction_sourcepos `seq`
56 rnf transaction_tags `seq`
57 rnf transaction_wording
58 type instance MT.Element Transaction = Posting
59 instance MT.MonoFunctor Transaction where
60 omap f t = t{transaction_postings = f `MT.omap` transaction_postings t}
61 instance MT.MonoFoldable Transaction where
62 ofoldMap f = MT.ofoldMap f . transaction_postings
63 ofoldr f a = MT.ofoldr f a . transaction_postings
64 ofoldl' f a = MT.ofoldl' f a . transaction_postings
65 ofoldr1Ex f = MT.ofoldr1Ex f . transaction_postings
66 ofoldl1Ex' f = MT.ofoldl1Ex' f . transaction_postings
67
68 -- type instance H.Postings H.:@ Transaction = Postings
69 instance H.Get Postings Transaction where
70 get = transaction_postings
71
72 {-
73 type instance H.Date H.:@ Transaction = Date
74 instance H.GetI H.Date Transaction where
75 getI = NonNull.head . transaction_dates
76 instance H.SetI H.Date Transaction where
77 setI d t = t{transaction_dates =
78 NonNull.ncons d $ NonNull.tail $ transaction_dates t}
79
80 type instance H.Postings H.:@ Transaction = Postings
81 instance H.GetI H.Postings Transaction where
82 getI = transaction_postings
83 instance H.SetI H.Postings Transaction where
84 setI transaction_postings t = t{transaction_postings}
85 -}
86
87 transaction :: Transaction
88 transaction =
89 Transaction
90 { transaction_comments = []
91 , transaction_dates = NonNull.ncons H.epoch []
92 , transaction_postings = mempty
93 , transaction_sourcepos = initialPos ""
94 , transaction_tags = mempty
95 , transaction_wording = ""
96 }
97
98 {-
99 -- ** Type 'Transaction_Anchor'
100 newtype Transaction_Anchor = Transaction_Anchor Anchor
101 deriving (Data, Eq, NFData, Ord, Show, Typeable)
102 -- ** Type 'Transaction_Anchors'
103 newtype Transaction_Anchors = Transaction_Anchors Anchors
104 deriving (Data, Eq, Monoid, NFData, Ord, Show, Typeable)
105 type instance MT.Element Transaction_Anchors = Transaction_Anchor
106 -}
107
108 -- ** Type 'Transaction_Tag'
109 newtype Transaction_Tag = Transaction_Tag Tag
110 deriving (Data, Eq, NFData, Ord, Show, Typeable)
111 -- ** Type 'Transaction_Tags'
112 newtype Transaction_Tags = Transaction_Tags Tags
113 deriving (Data, Eq, Monoid, NFData, Ord, Show, Typeable)
114 type instance MT.Element Transaction_Tags = Transaction_Tag
115
116 -- ** Type 'Transactions'
117 newtype Transactions = Transactions (Map Account [Transaction])
118 deriving (Data, Eq, NFData, Ord, Show, Typeable)
119
120 type instance MT.Element Transactions = Transaction
121 -- instance H.Transactions Transactions
122
123 -- ** Type 'Wording'
124 newtype Wording = Wording Text
125 deriving (Data, Eq, IsString, NFData, Ord, Show, Typeable)
126
127
128
129
130
131
132
133 {-
134
135 -- Transaction
136 instance H.Transaction Transaction where
137 type Transaction_Posting Transaction = Posting
138 type Transaction_Postings Transaction = Compose (Map Account) [] Posting
139 transaction_date = fst . transaction_dates
140 transaction_description = transaction_wording
141 transaction_postings = Compose . transaction_postings
142 transaction_tags = transaction_tags
143 instance H.Transaction (Charted Transaction) where
144 type Transaction_Posting (Charted Transaction) = H.Transaction_Posting Transaction
145 type Transaction_Postings (Charted Transaction) = H.Transaction_Postings Transaction
146 transaction_date = H.transaction_date . charted
147 transaction_description = H.transaction_description . charted
148 transaction_postings = H.transaction_postings . charted
149 transaction_tags = H.transaction_tags . charted
150
151 -- Journal
152 instance H.Journal_Transaction Transaction
153 instance H.Journal_Transaction (Charted Transaction)
154
155 -- Stats
156 instance H.Stats_Transaction Transaction where
157 stats_transaction_postings_count = Map.size . transaction_postings
158 instance H.Stats_Transaction (Charted Transaction) where
159 stats_transaction_postings_count = H.stats_transaction_postings_count . charted
160
161 -- GL
162 instance H.GL_Transaction Transaction where
163 type GL_Transaction_Line Transaction = Transaction
164 gl_transaction_line = id
165 {-
166 gl_transaction_postings_filter f t =
167 t{ transaction_postings =
168 Map.mapMaybe
169 (\post -> case List.filter f post of
170 [] -> Nothing
171 posts -> Just posts)
172 (transaction_postings t)
173 }
174 -}
175 instance H.GL_Transaction (Charted Transaction) where
176 type GL_Transaction_Line (Charted Transaction) = H.GL_Transaction_Line Transaction
177 gl_transaction_line = H.gl_transaction_line . charted
178 {-
179 gl_transaction_postings_filter f (Charted c t) =
180 Charted c
181 t{ transaction_postings =
182 Map.mapMaybe
183 (\post -> case List.filter f $ ({-Charted c <$>-} post) of
184 [] -> Nothing
185 posts -> Just $ {-charted <$>-} posts)
186 (transaction_postings t)
187 }
188 -}
189
190 {-
191 instance Filter.Transaction (Charted Transaction) where
192 type Transaction_Posting (Charted Transaction) = Charted Posting
193 type Transaction_Postings (Charted Transaction) = Compose (Map Account) []
194 transaction_date = fst . transaction_dates . Chart.charted
195 transaction_wording = transaction_wording . Chart.charted
196 transaction_postings (Chart.Charted c t) =
197 fmap (Chart.Charted c) $
198 Compose $ transaction_postings t
199 {-
200 transaction_postings_virtual (Chart.Charted c t) =
201 fmap (Chart.Charted c) $
202 Compose
203 [ Compose $ transaction_virtual_postings t
204 , Compose $ transaction_balanced_virtual_postings t
205 ]
206 -}
207 transaction_tags = transaction_tags . Chart.charted
208 -}
209 -}
210 -- | Return a 'Map' associating
211 -- the given 'Transaction's with their respective 'Date'.
212 transaction_by_date :: [Transaction] -> (Compose (Map Date) []) Transaction
213 transaction_by_date =
214 Compose .
215 Map.fromListWith (flip mappend) .
216 List.map (\t -> (NonNull.head $ transaction_dates t, [t]))