]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Account.hs
Fix balance tests to use new TreeMap.
[comptalang.git] / lib / Hcompta / Account.hs
1 {-# LANGUAGE UndecidableInstances #-}
2 module Hcompta.Account where
3
4 {-
5 import Control.DeepSeq (NFData)
6 import Data.Data
7 import Data.Eq (Eq)
8 import qualified Data.Foldable as Foldable
9 import qualified Data.List.NonEmpty as NonEmpty
10 import Data.Maybe (Maybe(..))
11 import Data.Ord (Ord)
12 import Prelude (($), (.), Integer, Num(..), const, id)
13 import Text.Show (Show(..))
14 -}
15
16 import Data.Monoid (Monoid(..))
17 import Data.Text (Text)
18 import Data.List.NonEmpty (NonEmpty(..))
19 import Data.NonNull (NonNull)
20 import qualified Data.Sequences as Seqs
21 import qualified Data.MonoTraversable as MT
22 import Data.Proxy (Proxy(..))
23
24 import Hcompta.Tag
25 import Hcompta.Name
26
27 class Account a where
28 type Account_Section a = MT.Element a
29
30
31 {-
32 -- * Type 'Account'
33 type Account = NonNull [Account_Section]
34 type Account_Section = Name
35
36 -- * Type 'Account_Anchor'
37 newtype Account_Anchor
38 = Account_Anchor Anchor
39 deriving (Data, Eq, NFData, Ord, Show, Typeable
40 , MT.Functor, MT.Foldable
41 , Seqs.SemiSequence, Seqs.IsSequence)
42 newtype Account_Anchors
43 = Account_Anchors Anchors
44 deriving (Data, Eq, Monoid, NFData, Show, Typeable)
45
46 class Sym_Account term where
47 -}
48
49 {-
50 -- * Class 'Account'
51 class
52 ( Ord a
53 , Data a
54 , Data (Account_Section a)
55 , NFData (Account_Section a)
56 , Ord (Account_Section a)
57 , Show (Account_Section a)
58 , Show a
59 ) => Account a where
60 type Account_Section a
61 account_path :: a -> Account_Path (Account_Section a)
62 type Account_Path = NonEmpty
63 instance (Data s, NFData s, Ord s, Show s) => Account (NonEmpty s) where
64 type Account_Section (NonEmpty s) = s
65 account_path = id
66
67 -- | Return the 'Account' formed by the given 'Account_Section' and 'Account_Section's.
68 account :: section -> [section] -> Account_Path section
69 account = (:|)
70
71 -- | Return the number of 'Account_Section's in the given 'Account_Path'.
72 account_depth :: Account a => a -> Integer
73 account_depth = Foldable.foldl' (\d -> const $ d + 1) 0 . account_path
74
75 -- | Return the given 'Account' without its last 'Account_Section' if any.
76 account_parent :: Account_Path a -> Maybe (Account_Path a)
77 account_parent = NonEmpty.parent
78
79 -- | Apply the given function to all the prefixes
80 -- of the given 'Account_Path' (including itself).
81 account_foldr :: Account_Path s -> (Account_Path s -> a -> a) -> a -> a
82 account_foldr (n0:|n0s) = go [] n0s
83 where
84 go s [] f acc = f (n0:|s) acc
85 go s (n:ns) f acc =
86 go (s `mappend` [n]) ns f (f (n0:|s) acc)
87
88 -- | Return an 'Account_Path' from the given list.
89 account_from_List :: [s] -> Account_Path s
90 account_from_List = NonEmpty.fromList
91
92 -- * Type 'Account_Anchor'
93 newtype Account_Anchor
94 = Account_Anchor Anchor
95 deriving (Data, Eq, NFData, Ord, Show, Typeable)
96 newtype Account_Anchors
97 = Account_Anchors Anchors
98 deriving (Data, Eq, NFData, Semigroup, Show, Typeable)
99
100 instance Consable Anchor Account_Anchors where
101 mcons a (Account_Anchors anchors) =
102 Account_Anchors $ mcons a anchors
103
104 account_anchor :: Anchor_Path -> Account_Anchor
105 account_anchor = Account_Anchor . anchor
106
107 -- | Return the given 'Account_Anchors' with the given 'Account_Anchor' incorporated.
108 account_anchor_cons :: Account_Anchor -> Account_Anchors -> Account_Anchors
109 account_anchor_cons (Account_Anchor t) (Account_Anchors ts) =
110 Account_Anchors $ anchor_cons t ts
111
112 -- * Type 'Account_Tag'
113 newtype Account_Tag
114 = Account_Tag Tag
115 deriving (Data, Eq, NFData, Ord, Show, Typeable)
116 newtype Account_Tags
117 = Account_Tags Tags
118 deriving (Data, Eq, NFData, Semigroup, Show, Typeable)
119
120 instance Consable Tag Account_Tags where
121 mcons t (Account_Tags tags) =
122 Account_Tags $ mcons t tags
123
124 account_tag :: Tag_Path -> Tag_Value -> Account_Tag
125 account_tag p v = Account_Tag $ tag p v
126
127 -- | Return the given 'Account_Tags' with the given 'Account_Tag' incorporated.
128 account_tag_cons :: Account_Tag -> Account_Tags -> Account_Tags
129 account_tag_cons (Account_Tag t) (Account_Tags ts) =
130 Account_Tags $ tag_cons t ts
131 -}