{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.LCC.Tag where

import Control.DeepSeq (NFData(..))
import Data.Data (Data(..))
import Data.Eq (Eq(..))
import Data.Function (($), flip)
import Data.Monoid (Monoid(..))
import Data.NonNull (NonNull)
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Data.TreeMap.Strict (TreeMap)
import Data.Typeable (Typeable)
import Prelude (seq)
import Text.Show (Show)
import qualified Data.MonoTraversable as MT
import qualified Data.TreeMap.Strict as TreeMap

import qualified Hcompta as H
import Hcompta.LCC.Name

-- * Type 'Tag'
data Tag
 =   Tag
 {   tag_path :: Tag_Path
 ,   tag_data :: Tag_Data
 } deriving (Data, Eq, Ord, Show, Typeable)
instance NFData Tag where
	rnf (Tag p d) = rnf p `seq` rnf d

-- ** Type 'Tag_Path'
newtype Tag_Path = Tag_Path (NonNull [Tag_Path_Section])
 deriving (Data, Eq, NFData, Ord, Semigroup, Show, Typeable)
instance H.Tag_Path Tag_Path
type Tag_Path_Section = Name

-- ** Type 'Tag_Data'
newtype Tag_Data = Tag_Data Text
 deriving (Data, Eq, NFData, Ord, Show, Typeable)
instance H.Tag_Data Tag_Data

-- * Type 'Tags'
newtype Tags
 =      Tags (TreeMap Tag_Path_Section [Tag_Data])
 deriving (Data, Eq, NFData, Ord, Show, Typeable)
instance Semigroup Tags where
	Tags x <> Tags y =
		Tags $ TreeMap.union (flip (<>)) x y
instance Monoid Tags where
	mempty  = Tags mempty
	mappend = (<>)
type instance MT.Element Tags = Tag