lib/Hcompta/Tag.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE MultiParamTypeClasses #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Hcompta.Tag where
   7
   8 import           Control.Applicative (Applicative(..))
   9 import           Control.Arrow (second)
  10 import           Control.DeepSeq (NFData(..))
  11 import           Data.Data
  12 import           Data.Eq (Eq)
  13 import           Data.Function (($), (.), flip)
  14 import           Data.Functor (Functor(..))
  15 import           Data.Int (Int)
  16 import           Data.List.NonEmpty (NonEmpty(..))
  17 import qualified Data.List.NonEmpty as NonEmpty
  18 import           Data.Map.Strict (Map)
  19 import qualified Data.Map.Strict as Data.Map
  20 import           Data.Maybe (Maybe(..))
  21 import           Data.Monoid (Monoid(..))
  22 import           Data.Text (Text)
  23 import qualified Data.Text as Text
  24 import           Data.Typeable ()
  25 import           Text.Show (Show)
  26
  27 import           Hcompta.Lib.Consable
  28
  29 -- * The 'Tag' type
  30
  31 -- | An 'Tag' is a non-empty list of 'Tag_Section'.
  32 type Tag = (Tag_Path, Tag_Value)
  33 type Tag_Section   = Text
  34 type Tag_Path      = NonEmpty Tag_Section
  35 type Tag_Value     = Text
  36
  37 -- * Type 'Tags'
  38 newtype Tags
  39  =      Tags (Map Tag_Path [Tag_Value])
  40  deriving (Data, Eq, Show, Typeable)
  41 unTags :: Tags -> Map Tag_Path [Tag_Value]
  42 unTags (Tags m) = m
  43
  44 instance Monoid Tags where
  45         mempty = Tags mempty
  46         mappend (Tags x0) (Tags x1) =
  47                 Tags (Data.Map.unionWith mappend x0 x1)
  48 instance Consable Tag Tags where
  49         mcons = tag_cons
  50 instance NFData Tags where
  51         rnf (Tags m) = rnf m
  52
  53 -- | Return the given 'Tags' with the given 'Tag' incorporated.
  54 tag_cons :: Tag -> Tags -> Tags
  55 tag_cons (p, v) (Tags xs) = Tags $ mcons (p, [v]) xs
  56
  57 -- | Return the 'Tag' formed by the given 'Tag_Path' and 'Tag_Value'.
  58 tag :: Tag_Path -> Tag_Value -> Tag
  59 tag = (,)
  60
  61 -- | Return the 'Tag_Value' formed by the given 'Tag_Section' and 'Tag_Section's.
  62 tag_path :: Tag_Section -> [Tag_Section] -> Tag_Path
  63 tag_path = (:|)
  64
  65 -- | Return the 'Tag_Value' of a 'Tag', if any.
  66 tag_value :: Tag -> Maybe Tag_Value
  67 tag_value (_, v) | Text.null v = Nothing
  68 tag_value (_, v) = Just v
  69
  70 -- | Return the number of 'Tag_Section's in the given 'Tag'.
  71 tag_depth :: Tag_Path -> Int
  72 tag_depth = NonEmpty.length
  73
  74 -- | Return a 'Tag_Path' from the given list.
  75 tag_from_List :: [(Tag_Path, Tag_Value)] -> Tags
  76 tag_from_List = Tags . Data.Map.fromListWith (flip mappend) . fmap (second pure)