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 -}