]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Transaction.hs
Remove old Yesod scaffolding.
[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 type instance H.Date H.:@ Transaction = Date
73 instance H.GetI H.Date Transaction where
74 getI_ _ = NonNull.head . transaction_dates
75 instance H.SetI H.Date Transaction where
76 setI_ _ d t = t{transaction_dates =
77 NonNull.ncons d $ NonNull.tail $ transaction_dates t}
78
79 type instance H.Postings H.:@ Transaction = Postings
80 instance H.GetI H.Postings Transaction where
81 getI_ _ = transaction_postings
82 instance H.SetI H.Postings Transaction where
83 setI_ _ transaction_postings t = t{transaction_postings}
84
85 transaction :: Transaction
86 transaction =
87 Transaction
88 { transaction_comments = []
89 , transaction_dates = NonNull.ncons H.date_epoch []
90 , transaction_postings = mempty
91 , transaction_sourcepos = initialPos ""
92 , transaction_tags = mempty
93 , transaction_wording = ""
94 }
95
96 {-
97 -- ** Type 'Transaction_Anchor'
98 newtype Transaction_Anchor = Transaction_Anchor Anchor
99 deriving (Data, Eq, NFData, Ord, Show, Typeable)
100 -- ** Type 'Transaction_Anchors'
101 newtype Transaction_Anchors = Transaction_Anchors Anchors
102 deriving (Data, Eq, Monoid, NFData, Ord, Show, Typeable)
103 type instance MT.Element Transaction_Anchors = Transaction_Anchor
104 -}
105
106 -- ** Type 'Transaction_Tag'
107 newtype Transaction_Tag = Transaction_Tag Tag
108 deriving (Data, Eq, NFData, Ord, Show, Typeable)
109 -- ** Type 'Transaction_Tags'
110 newtype Transaction_Tags = Transaction_Tags Tags
111 deriving (Data, Eq, Monoid, NFData, Ord, Show, Typeable)
112 type instance MT.Element Transaction_Tags = Transaction_Tag
113
114 -- ** Type 'Transactions'
115 newtype Transactions = Transactions (Map Account [Transaction])
116 deriving (Data, Eq, NFData, Ord, Show, Typeable)
117
118 type instance MT.Element Transactions = Transaction
119 instance H.Transactions Transactions
120
121 -- ** Type 'Wording'
122 newtype Wording = Wording Text
123 deriving (Data, Eq, IsString, NFData, Ord, Show, Typeable)
124
125
126
127
128
129
130
131 {-
132
133 -- Transaction
134 instance H.Transaction Transaction where
135 type Transaction_Posting Transaction = Posting
136 type Transaction_Postings Transaction = Compose (Map Account) [] Posting
137 transaction_date = fst . transaction_dates
138 transaction_description = transaction_wording
139 transaction_postings = Compose . transaction_postings
140 transaction_tags = transaction_tags
141 instance H.Transaction (Charted Transaction) where
142 type Transaction_Posting (Charted Transaction) = H.Transaction_Posting Transaction
143 type Transaction_Postings (Charted Transaction) = H.Transaction_Postings Transaction
144 transaction_date = H.transaction_date . charted
145 transaction_description = H.transaction_description . charted
146 transaction_postings = H.transaction_postings . charted
147 transaction_tags = H.transaction_tags . charted
148
149 -- Journal
150 instance H.Journal_Transaction Transaction
151 instance H.Journal_Transaction (Charted Transaction)
152
153 -- Stats
154 instance H.Stats_Transaction Transaction where
155 stats_transaction_postings_count = Map.size . transaction_postings
156 instance H.Stats_Transaction (Charted Transaction) where
157 stats_transaction_postings_count = H.stats_transaction_postings_count . charted
158
159 -- GL
160 instance H.GL_Transaction Transaction where
161 type GL_Transaction_Line Transaction = Transaction
162 gl_transaction_line = id
163 {-
164 gl_transaction_postings_filter f t =
165 t{ transaction_postings =
166 Map.mapMaybe
167 (\post -> case List.filter f post of
168 [] -> Nothing
169 posts -> Just posts)
170 (transaction_postings t)
171 }
172 -}
173 instance H.GL_Transaction (Charted Transaction) where
174 type GL_Transaction_Line (Charted Transaction) = H.GL_Transaction_Line Transaction
175 gl_transaction_line = H.gl_transaction_line . charted
176 {-
177 gl_transaction_postings_filter f (Charted c t) =
178 Charted c
179 t{ transaction_postings =
180 Map.mapMaybe
181 (\post -> case List.filter f $ ({-Charted c <$>-} post) of
182 [] -> Nothing
183 posts -> Just $ {-charted <$>-} posts)
184 (transaction_postings t)
185 }
186 -}
187
188 {-
189 instance Filter.Transaction (Charted Transaction) where
190 type Transaction_Posting (Charted Transaction) = Charted Posting
191 type Transaction_Postings (Charted Transaction) = Compose (Map Account) []
192 transaction_date = fst . transaction_dates . Chart.charted
193 transaction_wording = transaction_wording . Chart.charted
194 transaction_postings (Chart.Charted c t) =
195 fmap (Chart.Charted c) $
196 Compose $ transaction_postings t
197 {-
198 transaction_postings_virtual (Chart.Charted c t) =
199 fmap (Chart.Charted c) $
200 Compose
201 [ Compose $ transaction_virtual_postings t
202 , Compose $ transaction_balanced_virtual_postings t
203 ]
204 -}
205 transaction_tags = transaction_tags . Chart.charted
206 -}
207 -}
208 -- | Return a 'Map' associating
209 -- the given 'Transaction's with their respective 'Date'.
210 transaction_by_date :: [Transaction] -> (Compose (Map Date) []) Transaction
211 transaction_by_date =
212 Compose .
213 Map.fromListWith (flip mappend) .
214 List.map (\t -> (NonNull.head $ transaction_dates t, [t]))