]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Transaction.hs
stack: bump to lts-12.25
[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.Semigroup (Semigroup(..))
21 import Data.String (IsString)
22 import Data.Text (Text)
23 import Data.Typeable (Typeable)
24 import Prelude (flip, seq)
25 import Text.Show (Show)
26 import qualified Data.List as List
27 import qualified Data.Map.Strict as Map
28 import qualified Data.MonoTraversable as MT
29 import qualified Data.NonNull as NonNull
30
31 import Language.Symantic.Grammar (Source(..))
32 import qualified Hcompta as H
33
34 import Hcompta.LCC.Tag
35 import Hcompta.LCC.Posting
36
37 -- * Type 'Transaction'
38 data Transaction src
39 = Transaction
40 { transaction_comments :: [Comment]
41 , transaction_dates :: NonNull [Date]
42 , transaction_postings :: Postings src
43 , transaction_sourcepos :: src
44 , transaction_tags :: Transaction_Tags
45 , transaction_wording :: Wording
46 } deriving (Data, Eq, Ord, Show, Typeable)
47 transaction_date :: Transaction src -> Date
48 transaction_date = NonNull.head . transaction_dates
49 -- instance H.Transaction Transaction
50 instance NFData src => NFData (Transaction src) 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 src) = Posting src
59 instance MT.MonoFunctor (Transaction src) where
60 omap f t = t{transaction_postings = f `MT.omap` transaction_postings t}
61 instance MT.MonoFoldable (Transaction src) 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 src) (Transaction src) 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 :: Source src => Transaction src
88 transaction =
89 Transaction
90 { transaction_comments = []
91 , transaction_dates = NonNull.ncons H.epoch []
92 , transaction_postings = mempty
93 , transaction_sourcepos = noSource
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, Semigroup, Monoid, NFData, Ord, Show, Typeable)
114 type instance MT.Element Transaction_Tags = Transaction_Tag
115
116 -- ** Type 'Transactions'
117 newtype Transactions src = Transactions (Map Date [Transaction src])
118 deriving (Data, Eq, NFData, Ord, Show, Typeable)
119 instance Semigroup (Transactions src) where
120 Transactions x <> Transactions y = Transactions $
121 Map.unionWith (flip (<>)) x y
122 instance Monoid (Transactions src) where
123 mempty = Transactions mempty
124 mappend = (<>)
125 instance H.Zeroable (Transactions src) where
126 zero = Transactions mempty
127
128 type instance MT.Element (Transactions src) = Transaction src
129 -- instance H.Transactions Transactions
130
131 -- ** Type 'Wording'
132 newtype Wording = Wording Text
133 deriving (Data, Eq, IsString, NFData, Ord, Show, Typeable)
134
135
136
137
138
139
140
141 {-
142
143 -- Transaction
144 instance H.Transaction Transaction where
145 type Transaction_Posting Transaction = Posting
146 type Transaction_Postings Transaction = Compose (Map Account) [] Posting
147 transaction_date = fst . transaction_dates
148 transaction_description = transaction_wording
149 transaction_postings = Compose . transaction_postings
150 transaction_tags = transaction_tags
151 instance H.Transaction (Charted Transaction) where
152 type Transaction_Posting (Charted Transaction) = H.Transaction_Posting Transaction
153 type Transaction_Postings (Charted Transaction) = H.Transaction_Postings Transaction
154 transaction_date = H.transaction_date . charted
155 transaction_description = H.transaction_description . charted
156 transaction_postings = H.transaction_postings . charted
157 transaction_tags = H.transaction_tags . charted
158
159 -- Journal
160 instance H.Journal_Transaction Transaction
161 instance H.Journal_Transaction (Charted Transaction)
162
163 -- Stats
164 instance H.Stats_Transaction Transaction where
165 stats_transaction_postings_count = Map.size . transaction_postings
166 instance H.Stats_Transaction (Charted Transaction) where
167 stats_transaction_postings_count = H.stats_transaction_postings_count . charted
168
169 -- GL
170 instance H.GL_Transaction Transaction where
171 type GL_Transaction_Line Transaction = Transaction
172 gl_transaction_line = id
173 {-
174 gl_transaction_postings_filter f t =
175 t{ transaction_postings =
176 Map.mapMaybe
177 (\post -> case List.filter f post of
178 [] -> Nothing
179 posts -> Just posts)
180 (transaction_postings t)
181 }
182 -}
183 instance H.GL_Transaction (Charted Transaction) where
184 type GL_Transaction_Line (Charted Transaction) = H.GL_Transaction_Line Transaction
185 gl_transaction_line = H.gl_transaction_line . charted
186 {-
187 gl_transaction_postings_filter f (Charted c t) =
188 Charted c
189 t{ transaction_postings =
190 Map.mapMaybe
191 (\post -> case List.filter f $ ({-Charted c <$>-} post) of
192 [] -> Nothing
193 posts -> Just $ {-charted <$>-} posts)
194 (transaction_postings t)
195 }
196 -}
197
198 {-
199 instance Filter.Transaction (Charted Transaction) where
200 type Transaction_Posting (Charted Transaction) = Charted Posting
201 type Transaction_Postings (Charted Transaction) = Compose (Map Account) []
202 transaction_date = fst . transaction_dates . Chart.charted
203 transaction_wording = transaction_wording . Chart.charted
204 transaction_postings (Chart.Charted c t) =
205 fmap (Chart.Charted c) $
206 Compose $ transaction_postings t
207 {-
208 transaction_postings_virtual (Chart.Charted c t) =
209 fmap (Chart.Charted c) $
210 Compose
211 [ Compose $ transaction_virtual_postings t
212 , Compose $ transaction_balanced_virtual_postings t
213 ]
214 -}
215 transaction_tags = transaction_tags . Chart.charted
216 -}
217 -}
218 -- | Return a 'Map' associating
219 -- the given 'Transaction's with their respective 'Date'.
220 transaction_by_date :: [Transaction src] -> (Compose (Map Date) []) (Transaction src)
221 transaction_by_date =
222 Compose .
223 Map.fromListWith (flip mappend) .
224 List.map (\t -> (NonNull.head $ transaction_dates t, [t]))