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.Arrow (second)
   9 import           Control.Applicative (Applicative(..))
  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.List.NonEmpty (NonEmpty(..))
  16 import qualified Data.List.NonEmpty as NonEmpty
  17 import           Data.Map.Strict (Map)
  18 import qualified Data.Map.Strict as Data.Map
  19 import           Data.Maybe (Maybe(..))
  20 import           Data.Monoid (Monoid(..))
  21 import           Data.Text (Text)
  22 import qualified Data.Text as Text
  23 import           Data.Typeable ()
  24 import           Prelude (($), (.), Int)
  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 'Section'.
  32 type Tag = (Path, Value)
  33 type Section   = Text
  34 type Path      = NonEmpty Section
  35 type Value     = Text
  36 newtype Tags
  37  =      Tags (Map Path [Value])
  38  deriving (Data, Eq, Show, Typeable)
  39 unTags :: Tags -> Map Path [Value]
  40 unTags (Tags m) = m
  41
  42 instance Monoid Tags where
  43         mempty = Tags mempty
  44         mappend (Tags x0) (Tags x1) =
  45                 Tags (Data.Map.unionWith mappend x0 x1)
  46 instance Consable Tag Tags where
  47         mcons = cons
  48 instance NFData Tags where
  49         rnf (Tags m) = rnf m
  50
  51 -- | Return the given 'Tags' with the given 'Tag' incorporated.
  52 cons :: Tag -> Tags -> Tags
  53 cons (p, v) (Tags xs) = Tags $ mcons (p, [v]) xs
  54
  55 -- | Return the 'Tag' formed by the given 'Path' and 'Value'.
  56 tag :: Path -> Value -> Tag
  57 tag = (,)
  58
  59 -- | Return the 'Value' formed by the given 'Section' and 'Section's.
  60 path :: Section -> [Section] -> Path
  61 path = (:|)
  62
  63 -- | Return the 'Value' of a 'Tag', if any.
  64 value :: Tag -> Maybe Value
  65 value (_, v) | Text.null v = Nothing
  66 value (_, v) = Just v
  67
  68 -- | Return the number of 'Section's in the given 'Tag'.
  69 depth :: Path -> Int
  70 depth = NonEmpty.length
  71
  72 -- | Return a 'Path' from the given list.
  73 from_List :: [(Path, Value)] -> Tags
  74 from_List = Tags . Data.Map.fromListWith (flip mappend) . fmap (second pure)