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.Monoid (Monoid(..))
  15 import Data.NonNull (NonNull)
  16 import Data.Ord (Ord(..))
  17 import Data.Semigroup (Semigroup(..))
  18 import Data.Text (Text)
  19 import Data.TreeMap.Strict (TreeMap)
  20 import Data.Typeable (Typeable)
  21 import Prelude (seq)
  22 import Text.Show (Show)
  23 import qualified Data.MonoTraversable as MT
  24 import qualified Data.TreeMap.Strict as TreeMap
  25
  26 import qualified Hcompta as H ()
  27 import Hcompta.LCC.Name
  28
  29 -- * Type 'Tag'
  30 data Tag
  31  =   Tag
  32  {   tag_path :: Tag_Path
  33  ,   tag_data :: Tag_Data
  34  } deriving (Data, Eq, Ord, Show, Typeable)
  35
  36 instance NFData Tag where
  37         rnf (Tag p d) = rnf p `seq` rnf d
  38
  39 -- ** Type 'Tag_Path'
  40 newtype Tag_Path = Tag_Path (NonNull [Tag_Path_Section])
  41  deriving (Data, Eq, NFData, Ord, Semigroup, Show, Typeable)
  42
  43 -- instance H.Tag_Path Tag_Path
  44 type Tag_Path_Section = Name
  45
  46 -- ** Type 'Tag_Data'
  47 newtype Tag_Data = Tag_Data Text
  48  deriving (Data, Eq, NFData, Ord, Show, Typeable)
  49
  50 -- instance H.Tag_Data Tag_Data
  51
  52 -- * Type 'Tags'
  53 newtype Tags
  54  =      Tags (TreeMap Tag_Path_Section [Tag_Data])
  55  deriving (Data, Eq, NFData, Ord, Show, Typeable)
  56
  57 type instance MT.Element Tags = Tag
  58
  59 instance Semigroup Tags where
  60         Tags x <> Tags y =
  61                 Tags $ TreeMap.union (flip (<>)) x y
  62 instance Monoid Tags where
  63         mempty  = Tags mempty
  64         mappend = (<>)