]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Posting.hs
Remove old Yesod scaffolding.
[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 Data.Word (Word)
27 import Prelude (seq)
28 import System.IO (FilePath)
29 import Text.Show (Show)
30 import qualified Data.List as List
31 import qualified Data.Map.Strict as Map
32 import qualified Data.MonoTraversable as MT
33 import qualified Data.Strict as S
34 import qualified Data.Time.Clock as Time
35 import qualified Data.TreeMap.Strict as TreeMap
36
37 import qualified Hcompta as H
38
39 import Hcompta.LCC.Account
40 import Hcompta.LCC.Amount
41 import Hcompta.LCC.Tag
42
43 deriving instance (Data a, Data b) => Data (S.Pair a b)
44 instance (NFData a, NFData b) => NFData (S.Pair a b) where
45 rnf (a S.:!: b) = rnf a `seq` rnf b
46
47 -- * Type 'Date'
48 type Date = Time.UTCTime
49
50 -- * Type 'SourcePos'
51 data SourcePos
52 = SourcePos FilePath {-# UNPACK #-} !PosFile {-# UNPACK #-} !PosFile
53 deriving (Data, Eq, Ord, Show, Typeable)
54
55 initialPos :: FilePath -> SourcePos
56 initialPos p = SourcePos p (PosFile 0) (PosFile 0)
57
58 -- ** Type 'PosFile'
59 newtype PosFile = PosFile (Word)
60 deriving (Data, Eq, Ord, Show, Typeable)
61
62 -- ** Type 'SourceRange'
63 data SourceRange
64 = SourceRange SourcePos SourcePos
65 deriving (Data, Eq, Ord, Show, Typeable)
66
67 -- * Type 'Posting'
68 data Posting
69 = Posting
70 { posting_account :: !Account
71 , posting_account_ref :: !(S.Maybe (S.Pair Tag_Path (S.Maybe Account)))
72 , posting_amounts :: !Amounts
73 , posting_comments :: ![Comment]
74 , posting_dates :: ![Date]
75 , posting_sourcepos :: !SourcePos
76 , posting_tags :: !Posting_Tags
77 } deriving (Data, Eq, Ord, Show, Typeable)
78 instance NFData Posting where
79 rnf Posting{..} =
80 rnf posting_account `seq`
81 rnf posting_account_ref `seq`
82 rnf posting_amounts `seq`
83 rnf posting_comments `seq`
84 rnf posting_dates `seq`
85 -- rnf posting_sourcepos `seq`
86 rnf posting_tags
87 instance H.Get (TreeMap.Path Account_Section) Posting where
88 get = H.get . posting_account
89 instance H.Get (Map Unit (H.Polarized Quantity)) Posting where
90 get Posting{posting_amounts = Amounts amts} = H.polarize <$> amts
91 instance H.Set (Map Unit (H.Polarized Quantity)) Posting where
92 set amts p = p{posting_amounts = Amounts $ H.depolarize <$> amts}
93 instance H.Get (H.Balance_Amounts Unit Quantity) Posting where
94 get = H.get . posting_amounts
95
96 posting :: Account -> Posting
97 posting acct =
98 Posting
99 { posting_account = acct
100 , posting_account_ref = S.Nothing
101 , posting_amounts = H.quantity_zero
102 , posting_comments = mempty
103 , posting_dates = mempty
104 , posting_sourcepos = initialPos ""
105 , posting_tags = mempty
106 }
107
108 postings_by_account :: [Posting] -> Map Account [Posting]
109 postings_by_account =
110 Map.fromListWith (flip mappend) .
111 List.map (\p -> (posting_account p, [p]))
112
113 instance H.Posting Posting
114
115 type instance H.Account H.:@ Posting = Account
116 instance H.GetI H.Account Posting where
117 getI_ _ = posting_account
118 instance H.SetI H.Account Posting where
119 setI_ _ posting_account p = p{posting_account}
120
121 type instance H.Amounts H.:@ Posting = Amounts
122 instance H.GetI H.Amounts Posting where
123 getI_ _ = posting_amounts
124 instance H.SetI H.Amounts Posting where
125 setI_ _ posting_amounts p = p{posting_amounts}
126
127 {-
128 -- * Type 'Posting_Anchor'
129 newtype Posting_Anchor = Posting_Anchor Anchor
130 deriving (Data, Eq, NFData, Ord, Show, Typeable)
131 -- * Type 'Posting_Anchors'
132 newtype Posting_Anchors = Posting_Anchors Anchors
133 deriving (Data, Eq, Monoid, NFData, Ord, Semigroup, Show, Typeable)
134 type instance MT.Element Posting_Anchors = Posting_Anchor
135 -}
136
137 -- * Type 'Posting_Tag'
138 newtype Posting_Tag = Posting_Tag Tag
139 deriving (Data, Eq, NFData, Ord, Show, Typeable)
140 -- * Type 'Posting_Tags'
141 newtype Posting_Tags = Posting_Tags Tags
142 deriving (Data, Eq, Monoid, NFData, Ord, Semigroup, Show, Typeable)
143 type instance MT.Element Posting_Tags = Posting_Tag
144
145 -- ** Type 'Comment'
146 newtype Comment = Comment Text
147 deriving (Data, Eq, NFData, Ord, Show, Typeable)
148
149 -- * Type 'Postings'
150 newtype Postings = Postings (Map Account [Posting])
151 deriving (Data, Eq, NFData, Ord, Show, Typeable)
152 unPostings :: Postings -> Map Account [Posting]
153 unPostings (Postings ps) = ps
154 type instance H.Postings H.:@ Postings = Postings
155 instance H.Get Postings Postings where
156 get = id
157 instance H.Postings Postings
158 instance Semigroup Postings where
159 Postings x <> Postings y =
160 Postings $ Map.unionWith (flip (<>)) x y
161 instance Monoid Postings where
162 mempty = Postings mempty
163 mappend = (<>)
164 type instance MT.Element Postings = Posting
165 instance MT.MonoFunctor Postings where
166 omap f (Postings m) = Postings (MT.omap f `MT.omap` m)
167 instance MT.MonoFoldable Postings where
168 ofoldMap f (Postings m) = MT.ofoldMap f (Compose m)
169 ofoldr f a (Postings m) = MT.ofoldr f a (Compose m)
170 ofoldr1Ex f (Postings m) = MT.ofoldr1Ex f (Compose m)
171 ofoldl1Ex' f (Postings m) = MT.ofoldl1Ex' f (Compose m)
172 ofoldl' f a (Postings m) = MT.ofoldl' f a (Compose m)
173
174
175 {-
176 -- Posting
177 instance H.Posting Posting where
178 type Posting_Account Posting = Account
179 type Posting_Amount Posting = Amount
180 type Amounts Posting = [Amount]
181 posting_account = posting_account
182 posting_amounts = (uncurry Amount <$>) . Map.toList . posting_amounts
183 instance H.Posting (Charted Posting) where
184 type Posting_Account (Charted Posting) = Charted Account
185 type Posting_Amount (Charted Posting) = H.Posting_Amount Posting
186 type Amounts (Charted Posting) = H.Amounts Posting
187 posting_account = (H.posting_account <$>)
188 posting_amounts = H.posting_amounts . charted
189
190 -- Balance
191 instance H.Balance_Posting Posting where
192 type Balance_Posting_Quantity Posting = H.Polarized Quantity
193 balance_posting_amounts = (H.polarize <$>) . posting_amounts
194 balance_posting_amounts_set amounts p =
195 p { posting_amounts = H.depolarize <$> amounts }
196 instance H.Balance_Posting (Charted Posting) where
197 type Balance_Posting_Quantity (Charted Posting) = H.Balance_Posting_Quantity Posting
198 balance_posting_amounts = H.balance_posting_amounts . charted
199 balance_posting_amounts_set amounts (Charted c p) =
200 Charted c p{ posting_amounts = H.depolarize <$> amounts }
201
202 -- GL
203 instance H.GL_Posting Posting where
204 type GL_Posting_Quantity Posting = Map Unit (H.Polarized Quantity)
205 gl_posting_quantity = (H.polarize <$>) . posting_amounts
206 instance H.GL_Posting (Charted Posting) where
207 type GL_Posting_Quantity (Charted Posting) = H.GL_Posting_Quantity Posting
208 gl_posting_quantity = H.gl_posting_quantity . charted
209 -}