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 Data.MonoTraversable as MT
+import qualified Data.TreeMap.Strict as TreeMap
-import qualified Hcompta as H
+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)
+ { tag_path :: Tag_Path
+ , tag_data :: Tag_Data
+ } deriving (Data, Eq, Ord, Show, Typeable)
+
instance NFData Tag where
- rnf (Tag p v) = rnf p `seq` rnf v
+ rnf (Tag p d) = rnf p `seq` rnf d
-- ** Type 'Tag_Path'
-newtype Tag_Path = Tag_Path (NonEmpty Tag_Path_Section)
+newtype Tag_Path = Tag_Path (NonNull [Tag_Path_Section])
deriving (Data, Eq, NFData, Ord, Semigroup, Show, Typeable)
-instance H.Tag_Path Tag_Path
+
+-- 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 '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_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
+ = Tags (TreeMap Tag_Path_Section [Tag_Data])
+ deriving (Data, Eq, NFData, Ord, Show, Typeable)
+
type instance MT.Element Tags = Tag
+
+instance Semigroup Tags where
+ Tags x <> Tags y =
+ Tags $ TreeMap.union (flip (<>)) x y
+instance Monoid Tags where
+ mempty = Tags mempty
+ mappend = (<>)