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 instance NFData Tag where
  36         rnf (Tag p d) = rnf p `seq` rnf d
  37
  38 -- ** Type 'Tag_Path'
  39 newtype Tag_Path = Tag_Path (NonNull [Tag_Path_Section])
  40  deriving (Data, Eq, NFData, Ord, Semigroup, Show, Typeable)
  41 instance H.Tag_Path Tag_Path
  42 type Tag_Path_Section = Name
  43
  44 -- ** Type 'Tag_Data'
  45 newtype Tag_Data = Tag_Data Text
  46  deriving (Data, Eq, NFData, Ord, Show, Typeable)
  47 instance H.Tag_Data Tag_Data
  48
  49 -- * Type 'Tags'
  50 newtype Tags
  51  =      Tags (TreeMap Tag_Path_Section [Tag_Data])
  52  deriving (Data, Eq, NFData, Ord, Show, Typeable)
  53 instance Semigroup Tags where
  54         Tags x <> Tags y =
  55                 Tags $ TreeMap.union (flip (<>)) x y
  56 instance Monoid Tags where
  57         mempty  = Tags mempty
  58         mappend = (<>)
  59 type instance MT.Element Tags = Tag