lib/Hcompta/Account.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 {-# LANGUAGE UndecidableInstances #-}
   6 module Hcompta.Account where
   7
   8 {-
   9 import           Control.DeepSeq (NFData)
  10 import           Data.Data
  11 import           Data.Eq (Eq)
  12 import qualified Data.Foldable as Foldable
  13 import qualified Data.List.NonEmpty as NonEmpty
  14 import           Data.Maybe (Maybe(..))
  15 import           Data.Ord (Ord)
  16 import           Prelude (($), (.), Integer, Num(..), const, id)
  17 import           Text.Show (Show(..))
  18 -}
  19
  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(..))
  28
  29 import Hcompta.Anchor
  30 import Hcompta.Tag
  31 import Hcompta.Name
  32
  33 class Account a where
  34 type Account_Section a = MT.Element a
  35
  36 _Account :: Proxy Account
  37 _Account = Proxy
  38
  39
  40 {-
  41 -- * Type 'Account'
  42 type Account         = NonNull [Account_Section]
  43 type Account_Section = Name
  44
  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)
  54
  55 class Sym_Account term where
  56 -}
  57
  58 {-
  59 -- * Class 'Account'
  60 class
  61  ( Ord  a
  62  , Data a
  63  , Data   (Account_Section a)
  64  , NFData (Account_Section a)
  65  , Ord    (Account_Section a)
  66  , Show   (Account_Section a)
  67  , Show a
  68  ) => Account a where
  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
  74         account_path = id
  75
  76 -- | Return the 'Account' formed by the given 'Account_Section' and 'Account_Section's.
  77 account :: section -> [section] -> Account_Path section
  78 account = (:|)
  79
  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
  83
  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
  87
  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
  92         where
  93                 go s [] f acc = f (n0:|s) acc
  94                 go s (n:ns) f acc =
  95                         go (s `mappend` [n]) ns f (f (n0:|s) acc)
  96
  97 -- | Return an 'Account_Path' from the given list.
  98 account_from_List :: [s] -> Account_Path s
  99 account_from_List = NonEmpty.fromList
 100
 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)
 108
 109 instance Consable Anchor Account_Anchors where
 110         mcons a (Account_Anchors anchors) =
 111                 Account_Anchors $ mcons a anchors
 112
 113 account_anchor :: Anchor_Path -> Account_Anchor
 114 account_anchor = Account_Anchor . anchor
 115
 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
 120
 121 -- * Type 'Account_Tag'
 122 newtype Account_Tag
 123  =      Account_Tag Tag
 124  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 125 newtype Account_Tags
 126  =      Account_Tags Tags
 127  deriving (Data, Eq, Monoid, NFData, Show, Typeable)
 128
 129 instance Consable Tag Account_Tags where
 130         mcons t (Account_Tags tags) =
 131                 Account_Tags $ mcons t tags
 132
 133 account_tag :: Tag_Path -> Tag_Value -> Account_Tag
 134 account_tag p v = Account_Tag $ tag p v
 135
 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
 140 -}