lcc/Hcompta/LCC/Tag.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   4 {-# LANGUAGE MultiParamTypeClasses #-}
   5 {-# LANGUAGE NamedFieldPuns #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 {-# OPTIONS_GHC -fno-warn-orphans #-}
   8 module Hcompta.LCC.Tag where
   9
  10 import Control.DeepSeq (NFData(..))
  11 import Data.Data (Data(..))
  12 import Data.Eq (Eq(..))
  13 import Data.Function (($), flip)
  14 import Data.List.NonEmpty (NonEmpty)
  15 import Data.Map.Strict (Map)
  16 import qualified Data.Map.Strict as Map
  17 import qualified Data.MonoTraversable as MT
  18 import Data.Monoid (Monoid(..))
  19 import Data.NonNull (NonNull)
  20 import Data.Ord (Ord(..))
  21 import Data.Semigroup (Semigroup(..))
  22 import Data.Text (Text)
  23 import Data.TreeMap.Strict (TreeMap)
  24 import qualified Data.TreeMap.Strict as TreeMap
  25 import Data.Typeable (Typeable)
  26 import Prelude (seq)
  27 import Text.Show (Show)
  28
  29 import qualified Hcompta as H
  30 import Hcompta.LCC.Name
  31
  32 -- * Type 'Tag'
  33 data Tag
  34  =   Tag
  35  { tag_path  :: Tag_Path
  36  , tag_value :: Tag_Value
  37  }
  38  deriving (Data, Eq, Show, Typeable)
  39 instance NFData Tag where
  40         rnf (Tag p v) = rnf p `seq` rnf v
  41
  42 -- ** Type 'Tag_Path'
  43 newtype Tag_Path = Tag_Path (NonEmpty Tag_Path_Section)
  44  deriving (Data, Eq, NFData, Ord, Semigroup, Show, Typeable)
  45 instance H.Tag_Path Tag_Path
  46 type Tag_Path_Section = Name
  47
  48 -- ** Type 'Tag_Value'
  49 newtype Tag_Value = Tag_Value Text
  50  deriving (Data, Eq, NFData, Show, Typeable)
  51 instance H.Tag_Value Tag_Value
  52
  53 -- * Type 'Tags'
  54 newtype Tags
  55  =      Tags (TreeMap Tag_Path_Section [Tag_Value])
  56  deriving (Data, Eq, NFData, Show, Typeable)
  57 instance Monoid Tags where
  58         mempty = Tags mempty
  59         mappend (Tags x) (Tags y) =
  60                 Tags $ TreeMap.union (flip mappend) x y
  61 type instance MT.Element Tags = Tag