lib/Hcompta/Account.hs

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