lib/Hcompta/Account.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   5 {-# LANGUAGE MultiParamTypeClasses #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 module Hcompta.Account where
   8
   9 import           Control.DeepSeq (NFData)
  10 import           Data.Data
  11 import           Data.Eq (Eq)
  12 import qualified Data.Foldable as Foldable
  13 import           Data.List.NonEmpty (NonEmpty(..))
  14 import qualified Data.List.NonEmpty as NonEmpty
  15 import           Data.Maybe (Maybe(..))
  16 import           Data.Monoid (Monoid(..))
  17 import           Data.Ord (Ord)
  18 import           Prelude (($), (.), Integer, Num(..), const, id)
  19 import           Text.Show (Show(..))
  20
  21 import           Hcompta.Anchor
  22 import           Hcompta.Lib.Consable (Consable(..))
  23 import qualified Hcompta.Lib.NonEmpty as NonEmpty
  24 import           Hcompta.Tag
  25
  26 -- * Class 'Account'
  27 class
  28  ( Ord  a
  29  , Data a
  30  , Data   (Account_Section a)
  31  , NFData (Account_Section a)
  32  , Ord    (Account_Section a)
  33  , Show   (Account_Section a)
  34  , Show a
  35  ) => Account a where
  36         type Account_Section  a
  37         account_path :: a -> Account_Path (Account_Section a)
  38 type Account_Path = NonEmpty
  39 instance (Data s, NFData s, Ord s, Show s) => Account (NonEmpty s) where
  40         type Account_Section (NonEmpty s) = s
  41         account_path = id
  42
  43 -- | Return the 'Account' formed by the given 'Account_Section' and 'Account_Section's.
  44 account :: section -> [section] -> Account_Path section
  45 account = (:|)
  46
  47 -- | Return the number of 'Account_Section's in the given 'Account_Path'.
  48 account_depth :: Account a => a -> Integer
  49 account_depth = Foldable.foldl' (\d -> const $ d + 1) 0 . account_path
  50
  51 -- | Return the given 'Account' without its last 'Account_Section' if any.
  52 account_parent :: Account_Path a -> Maybe (Account_Path a)
  53 account_parent = NonEmpty.parent
  54
  55 -- | Apply the given function to all the prefixes
  56 -- of the given 'Account_Path' (including itself).
  57 account_foldr :: Account_Path s -> (Account_Path s -> a -> a) -> a -> a
  58 account_foldr (n0:|n0s) = go [] n0s
  59         where
  60                 go s [] f acc = f (n0:|s) acc
  61                 go s (n:ns) f acc =
  62                         go (s `mappend` [n]) ns f (f (n0:|s) acc)
  63
  64 -- | Return an 'Account_Path' from the given list.
  65 account_from_List :: [s] -> Account_Path s
  66 account_from_List = NonEmpty.fromList
  67
  68 -- * Type 'Account_Anchor'
  69 newtype Account_Anchor
  70  =      Account_Anchor Anchor
  71  deriving (Data, Eq, NFData, Ord, Show, Typeable)
  72 newtype Account_Anchors
  73  =      Account_Anchors Anchors
  74  deriving (Data, Eq, Monoid, NFData, Show, Typeable)
  75
  76 instance Consable Anchor Account_Anchors where
  77         mcons a (Account_Anchors anchors) =
  78                 Account_Anchors $ mcons a anchors
  79
  80 account_anchor :: Anchor_Path -> Account_Anchor
  81 account_anchor = Account_Anchor . anchor
  82
  83 -- | Return the given 'Account_Anchors' with the given 'Account_Anchor' incorporated.
  84 account_anchor_cons :: Account_Anchor -> Account_Anchors -> Account_Anchors
  85 account_anchor_cons (Account_Anchor t) (Account_Anchors ts) =
  86         Account_Anchors $ anchor_cons t ts
  87
  88 -- * Type 'Account_Tag'
  89 newtype Account_Tag
  90  =      Account_Tag Tag
  91  deriving (Data, Eq, NFData, Ord, Show, Typeable)
  92 newtype Account_Tags
  93  =      Account_Tags Tags
  94  deriving (Data, Eq, Monoid, NFData, Show, Typeable)
  95
  96 instance Consable Tag Account_Tags where
  97         mcons t (Account_Tags tags) =
  98                 Account_Tags $ mcons t tags
  99
 100 account_tag :: Tag_Path -> Tag_Value -> Account_Tag
 101 account_tag p v = Account_Tag $ tag p v
 102
 103 -- | Return the given 'Account_Tags' with the given 'Account_Tag' incorporated.
 104 account_tag_cons :: Account_Tag -> Account_Tags -> Account_Tags
 105 account_tag_cons (Account_Tag t) (Account_Tags ts) =
 106         Account_Tags $ tag_cons t ts