]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Posting.hs
stack: bump to lts-12.25
[comptalang.git] / lcc / Hcompta / LCC / Posting.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
4 {-# LANGUAGE MultiParamTypeClasses #-}
5 {-# LANGUAGE NamedFieldPuns #-}
6 {-# LANGUAGE OverloadedStrings #-}
7 {-# LANGUAGE RecordWildCards #-}
8 {-# LANGUAGE TypeFamilies #-}
9 {-# LANGUAGE TypeOperators #-}
10 {-# LANGUAGE StandaloneDeriving #-}
11 {-# OPTIONS_GHC -fno-warn-orphans #-}
12 module Hcompta.LCC.Posting where
13
14 import Control.DeepSeq (NFData(..))
15 import Data.Data (Data(..))
16 import Data.Eq (Eq(..))
17 import Data.Function (($), (.), flip, id)
18 import Data.Functor ((<$>))
19 import Data.Functor.Compose (Compose(..))
20 import Data.Map.Strict (Map)
21 import Data.Monoid (Monoid(..))
22 import Data.Ord (Ord(..))
23 import Data.Semigroup (Semigroup(..))
24 import Data.Text (Text)
25 import Data.Typeable (Typeable)
26 import Prelude (seq)
27 import Text.Show (Show)
28 import qualified Data.List as List
29 import qualified Data.Map.Strict as Map
30 import qualified Data.MonoTraversable as MT
31 import qualified Data.Strict as S
32 import qualified Data.Time.Clock as Time
33 import qualified Data.TreeMap.Strict as TreeMap
34
35 import Language.Symantic.Grammar (Source(..))
36 import qualified Hcompta as H
37
38 import Hcompta.LCC.Account
39 import Hcompta.LCC.Amount
40 import Hcompta.LCC.Tag
41
42 deriving instance (Data a, Data b) => Data (S.Pair a b)
43 instance (NFData a, NFData b) => NFData (S.Pair a b) where
44 rnf (a S.:!: b) = rnf a `seq` rnf b
45
46 -- * Type 'Date'
47 type Date = Time.UTCTime
48
49 -- * Type 'Posting'
50 data Posting src
51 = Posting
52 { posting_account :: !Account
53 , posting_account_ref :: !(S.Maybe (S.Pair Tag_Path (S.Maybe Account)))
54 , posting_amounts :: !Amounts
55 , posting_comments :: ![Comment]
56 , posting_dates :: ![Date]
57 , posting_sourcepos :: !src
58 , posting_tags :: !Posting_Tags
59 } deriving (Data, Eq, Ord, Show, Typeable)
60 instance NFData src => NFData (Posting src) where
61 rnf Posting{..} =
62 rnf posting_account `seq`
63 rnf posting_account_ref `seq`
64 rnf posting_amounts `seq`
65 rnf posting_comments `seq`
66 rnf posting_dates `seq`
67 rnf posting_sourcepos `seq`
68 rnf posting_tags
69 {-
70 type instance H.UnitFor Posting = Unit
71 type instance H.QuantityFor Posting = H.Polarized Quantity
72 type instance H.AccountFor Posting = Account
73 -}
74
75 instance H.Get (TreeMap.Path NameAccount) (Posting src) where
76 get = H.to . posting_account
77 instance H.Get Account (Posting src) where
78 get Posting{posting_account = acct} = acct
79 instance H.Get (Map Unit Quantity) (Posting src) where
80 get Posting{posting_amounts = Amounts amts} = amts
81 instance H.Set (Map Unit Quantity) (Posting src) where
82 set amts p = p{posting_amounts = Amounts amts}
83 instance H.Get (Map Unit (H.Polarized Quantity)) (Posting src) where
84 get Posting{posting_amounts = Amounts amts} = H.polarize <$> amts
85 instance H.Set (Map Unit (H.Polarized Quantity)) (Posting src) where
86 set amts p = p{posting_amounts = Amounts $ H.depolarize <$> amts}
87 -- instance H.Get (H.Balance_Amounts Unit Quantity) Posting where
88 -- get = H.get . posting_amounts
89
90 {-
91 instance H.ConsBalByAccount Posting where
92 consBalByAccount Posting
93 { posting_account = Account acct
94 , posting_amounts = Amounts amts
95 } = H.consBalByAccount (acct, H.polarize <$> amts)
96 instance H.ConsBalByUnit Posting where
97 consBalByUnit Posting
98 { posting_account = Account acct
99 , posting_amounts = Amounts amts
100 } = H.consBalByUnit (acct, H.polarize <$> amts)
101 type instance H.AccountFor (Account, Amounts) = Account
102 -}
103
104 posting :: Source src => Account -> Posting src
105 posting acct =
106 Posting
107 { posting_account = acct
108 , posting_account_ref = S.Nothing
109 , posting_amounts = H.zero
110 , posting_comments = mempty
111 , posting_dates = mempty
112 , posting_sourcepos = noSource
113 , posting_tags = mempty
114 }
115
116 postings_by_account :: [Posting src] -> Map Account [Posting src]
117 postings_by_account =
118 Map.fromListWith (flip (<>)) .
119 List.map (\p -> (posting_account p, [p]))
120
121 {-
122 instance H.Posting Posting
123
124 type instance H.Account H.:@ Posting = Account
125 instance H.GetI H.Account Posting where
126 getI = posting_account
127 instance H.SetI H.Account Posting where
128 setI posting_account p = p{posting_account}
129
130 type instance H.Amounts H.:@ Posting = Amounts
131 instance H.GetI H.Amounts Posting where
132 getI = posting_amounts
133 instance H.SetI H.Amounts (Posting src) where
134 setI posting_amounts p = p{posting_amounts}
135 -}
136
137 {-
138 -- * Type 'Posting_Anchor'
139 newtype Posting_Anchor = Posting_Anchor Anchor
140 deriving (Data, Eq, NFData, Ord, Show, Typeable)
141 -- * Type 'Posting_Anchors'
142 newtype Posting_Anchors = Posting_Anchors Anchors
143 deriving (Data, Eq, Monoid, NFData, Ord, Semigroup, Show, Typeable)
144 type instance MT.Element Posting_Anchors = Posting_Anchor
145 -}
146
147 -- * Type 'Posting_Tag'
148 newtype Posting_Tag = Posting_Tag Tag
149 deriving (Data, Eq, NFData, Ord, Show, Typeable)
150 -- * Type 'Posting_Tags'
151 newtype Posting_Tags = Posting_Tags Tags
152 deriving (Data, Eq, Monoid, NFData, Ord, Semigroup, Show, Typeable)
153 type instance MT.Element Posting_Tags = Posting_Tag
154
155 -- ** Type 'Comment'
156 newtype Comment = Comment Text
157 deriving (Data, Eq, NFData, Ord, Show, Typeable)
158
159 -- * Type 'Postings'
160 newtype Postings src = Postings (Map Account [Posting src])
161 deriving (Data, Eq, NFData, Ord, Show, Typeable)
162 unPostings :: Postings src -> Map Account [Posting src]
163 unPostings (Postings ps) = ps
164 -- type instance H.Postings H.:@ Postings = Postings
165 instance H.Get (Postings src) (Postings src) where
166 get = id
167 -- instance H.Postings Postings
168 instance Semigroup (Postings src) where
169 Postings x <> Postings y = Postings $ Map.unionWith (flip (<>)) x y
170 instance Monoid (Postings src) where
171 mempty = Postings mempty
172 mappend = (<>)
173 type instance MT.Element (Postings src) = Posting src
174 instance MT.MonoFunctor (Postings src) where
175 omap f (Postings m) = Postings (MT.omap f `MT.omap` m)
176 instance MT.MonoFoldable (Postings src) where
177 ofoldMap f (Postings m) = MT.ofoldMap f (Compose m)
178 ofoldr f a (Postings m) = MT.ofoldr f a (Compose m)
179 ofoldr1Ex f (Postings m) = MT.ofoldr1Ex f (Compose m)
180 ofoldl1Ex' f (Postings m) = MT.ofoldl1Ex' f (Compose m)
181 ofoldl' f a (Postings m) = MT.ofoldl' f a (Compose m)
182
183
184 {-
185 -- Posting
186 instance H.Posting Posting where
187 type Posting_Account Posting = Account
188 type Posting_Amount Posting = Amount
189 type Amounts Posting = [Amount]
190 posting_account = posting_account
191 posting_amounts = (uncurry Amount <$>) . Map.toList . posting_amounts
192 instance H.Posting (Charted Posting) where
193 type Posting_Account (Charted Posting) = Charted Account
194 type Posting_Amount (Charted Posting) = H.Posting_Amount Posting
195 type Amounts (Charted Posting) = H.Amounts Posting
196 posting_account = (H.posting_account <$>)
197 posting_amounts = H.posting_amounts . charted
198
199 -- Balance
200 instance H.Balance_Posting Posting where
201 type Balance_Posting_Quantity Posting = H.Polarized Quantity
202 balance_posting_amounts = (H.polarize <$>) . posting_amounts
203 balance_posting_amounts_set amounts p =
204 p { posting_amounts = H.depolarize <$> amounts }
205 instance H.Balance_Posting (Charted Posting) where
206 type Balance_Posting_Quantity (Charted Posting) = H.Balance_Posting_Quantity Posting
207 balance_posting_amounts = H.balance_posting_amounts . charted
208 balance_posting_amounts_set amounts (Charted c p) =
209 Charted c p{ posting_amounts = H.depolarize <$> amounts }
210
211 -- GL
212 instance H.GL_Posting Posting where
213 type GL_Posting_Quantity Posting = Map Unit (H.Polarized Quantity)
214 gl_posting_quantity = (H.polarize <$>) . posting_amounts
215 instance H.GL_Posting (Charted Posting) where
216 type GL_Posting_Quantity (Charted Posting) = H.GL_Posting_Quantity Posting
217 gl_posting_quantity = H.gl_posting_quantity . charted
218 -}