{-# 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.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.MonoTraversable as MT
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 qualified Data.TreeMap.Strict as TreeMap
import Data.Typeable (Typeable)
import Prelude (seq)
import Text.Show (Show)

import qualified Hcompta as H
import Hcompta.LCC.Name

-- * Type 'Tag'
data Tag
 =   Tag
 { tag_path  :: Tag_Path
 , tag_value :: Tag_Value
 }
 deriving (Data, Eq, Show, Typeable)
instance NFData Tag where
	rnf (Tag p v) = rnf p `seq` rnf v

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

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

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