1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE TypeFamilies #-}
5 {-# LANGUAGE UndecidableInstances #-}
6 module Hcompta.Account where
9 import Control.DeepSeq (NFData)
12 import qualified Data.Foldable as Foldable
13 import qualified Data.List.NonEmpty as NonEmpty
14 import Data.Maybe (Maybe(..))
16 import Prelude (($), (.), Integer, Num(..), const, id)
17 import Text.Show (Show(..))
20 import Data.Monoid (Monoid(..))
21 import Data.Text (Text)
22 import Data.List.NonEmpty (NonEmpty(..))
23 import Language.Symantic
24 import Data.NonNull (NonNull)
25 import qualified Data.Sequences as Seqs
26 import qualified Data.MonoTraversable as MT
27 import Data.Proxy (Proxy(..))
34 type Account_Section a = MT.Element a
36 _Account :: Proxy Account
42 type Account = NonNull [Account_Section]
43 type Account_Section = Name
45 -- * Type 'Account_Anchor'
46 newtype Account_Anchor
47 = Account_Anchor Anchor
48 deriving (Data, Eq, NFData, Ord, Show, Typeable
49 , MT.Functor, MT.Foldable
50 , Seqs.SemiSequence, Seqs.IsSequence)
51 newtype Account_Anchors
52 = Account_Anchors Anchors
53 deriving (Data, Eq, Monoid, NFData, Show, Typeable)
55 class Sym_Account term where
63 , Data (Account_Section a)
64 , NFData (Account_Section a)
65 , Ord (Account_Section a)
66 , Show (Account_Section a)
69 type Account_Section a
70 account_path :: a -> Account_Path (Account_Section a)
71 type Account_Path = NonEmpty
72 instance (Data s, NFData s, Ord s, Show s) => Account (NonEmpty s) where
73 type Account_Section (NonEmpty s) = s
76 -- | Return the 'Account' formed by the given 'Account_Section' and 'Account_Section's.
77 account :: section -> [section] -> Account_Path section
80 -- | Return the number of 'Account_Section's in the given 'Account_Path'.
81 account_depth :: Account a => a -> Integer
82 account_depth = Foldable.foldl' (\d -> const $ d + 1) 0 . account_path
84 -- | Return the given 'Account' without its last 'Account_Section' if any.
85 account_parent :: Account_Path a -> Maybe (Account_Path a)
86 account_parent = NonEmpty.parent
88 -- | Apply the given function to all the prefixes
89 -- of the given 'Account_Path' (including itself).
90 account_foldr :: Account_Path s -> (Account_Path s -> a -> a) -> a -> a
91 account_foldr (n0:|n0s) = go [] n0s
93 go s [] f acc = f (n0:|s) acc
95 go (s `mappend` [n]) ns f (f (n0:|s) acc)
97 -- | Return an 'Account_Path' from the given list.
98 account_from_List :: [s] -> Account_Path s
99 account_from_List = NonEmpty.fromList
101 -- * Type 'Account_Anchor'
102 newtype Account_Anchor
103 = Account_Anchor Anchor
104 deriving (Data, Eq, NFData, Ord, Show, Typeable)
105 newtype Account_Anchors
106 = Account_Anchors Anchors
107 deriving (Data, Eq, Monoid, NFData, Show, Typeable)
109 instance Consable Anchor Account_Anchors where
110 mcons a (Account_Anchors anchors) =
111 Account_Anchors $ mcons a anchors
113 account_anchor :: Anchor_Path -> Account_Anchor
114 account_anchor = Account_Anchor . anchor
116 -- | Return the given 'Account_Anchors' with the given 'Account_Anchor' incorporated.
117 account_anchor_cons :: Account_Anchor -> Account_Anchors -> Account_Anchors
118 account_anchor_cons (Account_Anchor t) (Account_Anchors ts) =
119 Account_Anchors $ anchor_cons t ts
121 -- * Type 'Account_Tag'
124 deriving (Data, Eq, NFData, Ord, Show, Typeable)
127 deriving (Data, Eq, Monoid, NFData, Show, Typeable)
129 instance Consable Tag Account_Tags where
130 mcons t (Account_Tags tags) =
131 Account_Tags $ mcons t tags
133 account_tag :: Tag_Path -> Tag_Value -> Account_Tag
134 account_tag p v = Account_Tag $ tag p v
136 -- | Return the given 'Account_Tags' with the given 'Account_Tag' incorporated.
137 account_tag_cons :: Account_Tag -> Account_Tags -> Account_Tags
138 account_tag_cons (Account_Tag t) (Account_Tags ts) =
139 Account_Tags $ tag_cons t ts