lcc/Hcompta/LCC/Chart.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE DeriveFunctor #-}
   3 {-# LANGUAGE DeriveTraversable #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5 module Hcompta.LCC.Chart where
   6
   7 import Control.DeepSeq (NFData(..))
   8 import Data.Data
   9 import Data.Eq (Eq)
  10 import Data.Function (($), (.))
  11 import Data.Map.Strict (Map)
  12 import Data.Monoid (Monoid(..))
  13 import Data.Semigroup (Semigroup(..))
  14 import Data.Strict.Maybe as Strict
  15 import Data.TreeMap.Strict (TreeMap)
  16 import Data.Typeable ()
  17 import Prelude (seq)
  18 import Text.Show (Show)
  19 import qualified Data.Map.Strict as Map
  20 import qualified Data.TreeMap.Strict        as TreeMap
  21 import qualified Data.TreeMap.Strict.Zipper as TreeMap
  22
  23 import Hcompta.LCC.Account
  24 import Hcompta.LCC.Tag
  25
  26 -- * Type 'Chart'
  27 data Chart
  28  =   Chart
  29  {   chart_accounts :: !(TreeMap Account_Section Account_Tags)
  30  ,   chart_tags     :: !(Map Tag_Path (Map Account ()))
  31  } deriving (Data, Eq, Show, Typeable)
  32 instance NFData Chart where
  33         rnf Chart{..} =
  34                 rnf chart_accounts `seq`
  35                 rnf chart_tags
  36 instance Semigroup Chart where
  37         x <> y =
  38                 Chart
  39                  { chart_accounts = TreeMap.union (<>) (chart_accounts x) (chart_accounts y)
  40                  , chart_tags     = Map.unionWith (<>) (chart_tags x) (chart_tags y)
  41                  }
  42 instance Monoid Chart where
  43         mempty = Chart
  44          { chart_accounts = mempty
  45          , chart_tags     = mempty
  46          }
  47         mappend = (<>)
  48
  49 -- * Zipper
  50
  51 type Zipper_Chart = TreeMap.Zipper Account_Section Account_Tags
  52 type Zipper_Account_Tags = TreeMap.Zipper Tag_Path_Section [Tag_Data]
  53 type Chart_Select = Zipper_Chart -> [Zipper_Chart]
  54 type Zipper_Select k a = TreeMap.Zipper k a -> [TreeMap.Zipper k a]
  55 type Zipper_SelectF f k a = TreeMap.Zipper k a -> f (TreeMap.Zipper k a)
  56
  57 zipper_chart :: Chart -> Zipper_Chart
  58 zipper_chart = TreeMap.zipper . chart_accounts
  59
  60 zipper_accounts_tags :: Zipper_Chart -> Zipper_Account_Tags
  61 zipper_accounts_tags z =
  62         case TreeMap.node_value $ TreeMap.zipper_self z of
  63          Strict.Just (Account_Tags (Tags tags)) -> TreeMap.zipper tags
  64          _ -> TreeMap.zipper TreeMap.empty
  65
  66 {-
  67 -- * Type 'Charted'
  68 data Charted a
  69  =   Charted
  70  {   chart   :: Chart
  71  ,   charted :: a
  72  } deriving (Data, Eq, Foldable, Functor, Show, Traversable, Typeable)
  73
  74 instance Ord a => Ord (Charted a) where
  75         compare = compare `on` charted
  76
  77
  78 instance H.Account (Charted Account)
  79 -- /child::A
  80 account_step account_child (\a -> "A" == a_name a)
  81 -- /child::A/child::B
  82 account_step account_child (\a -> "A" == a_name a) >=>
  83 account_step account_child (\a -> "B" == a_name a)
  84 -}