lib/Hcompta/Tag.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Hcompta.Tag where
   7
   8 import           Control.Applicative (Applicative(..))
   9 import           Control.Arrow (second)
  10 import           Control.DeepSeq (NFData(..))
  11 import           Data.Data
  12 import           Data.Eq (Eq)
  13 import           Data.Function (($), (.), flip)
  14 import           Data.Functor (Functor(..))
  15 import           Data.Int (Int)
  16 import           Data.Map.Strict (Map)
  17 import qualified Data.Map.Strict as Map
  18 import           Data.Proxy (Proxy(..))
  19 import           Data.Maybe (Maybe(..))
  20 import           Data.Monoid (Monoid(..))
  21 import qualified Data.Sequences as Seqs
  22 import           Data.NonNull (NonNull)
  23 import           Data.Text (Text)
  24 import qualified Data.Text as Text
  25 import           Data.Tuple (fst, snd)
  26 import           Data.Typeable ()
  27 import           Text.Show (Show)
  28 import qualified Data.MonoTraversable as MT
  29
  30 import           Hcompta.Lib.Consable
  31 import           Hcompta.Name
  32 import           Hcompta.Has
  33 -- import           Language.Symantic as Sym
  34
  35 -- * Class 'Tag'
  36 class
  37  ( HasI Tag_Path a
  38  , HasI Tag_Value a
  39  ) => Tag a
  40
  41 _Tag :: Proxy Tag
  42 _Tag = Proxy
  43
  44 _Tags :: Proxy Tags
  45 _Tags = Proxy
  46
  47 class Tag_Path t
  48 class Tag_Value t
  49 class Tag (MT.Element ts) => Tags ts
  50
  51 {-
  52 class Tag t where
  53         type Tag_Path t
  54         type Tag_Value t
  55         tag_path  :: t -> Tag_Path t
  56         tag_value :: t -> Tag_Value t
  57 instance Tag       (path, value) where
  58         type   Tag_Path  (path, value) = path
  59         type   Tag_Value (path, value) = value
  60         tag_path  = fst
  61         tag_value = snd
  62
  63 -- * Class 'Tags'
  64 class Tag (Tags_Tag ts) => Tags ts where
  65         type Tags_Tag ts
  66 instance
  67  Tag t =>
  68  Tags [t] where
  69         type Tags_Tag [t] = t
  70 instance
  71  Tags ts =>
  72  Tags (Map path ts) where
  73         type Tags_Tag (Map path ts) = Tags_Tag ts
  74 -}
  75 {-
  76 -- * Class 'Tags_of'
  77 class Tags (Tags_Of a) => Tags_of a where
  78         type Tags_Of a
  79         tags_of :: a -> Tags_Of a
  80 -}
  81
  82 {-
  83 -- * The 'Tag' type
  84
  85 -- | An 'Tag' is a non-empty list of 'Tag_Section'.
  86 type Tag         = (Tag_Path, Tag_Value)
  87 type Tag_Path    = NonNull [Tag_Section]
  88 type Tag_Section = Name
  89 type Tag_Value   = Text
  90
  91 -- * Type 'Tags'
  92 newtype Tags
  93  =      Tags (Map Tag_Path [Tag_Value])
  94  deriving (Data, Eq, NFData, Show, Typeable
  95  , MT.MonoFunctor, MT.MonoFoldable)
  96 unTags :: Tags -> Map Tag_Path [Tag_Value]
  97 unTags (Tags m) = m
  98 -}
  99
 100
 101 {-
 102 instance Monoid Tags where
 103         mempty = Tags mempty
 104         mappend (Tags x) (Tags y) =
 105                 Tags (Map.unionWith (flip mappend) x y)
 106 instance Consable Tag Tags where
 107         mcons = tag_cons
 108 instance NFData Tags where
 109         rnf (Tags m) = rnf m
 110 -- | Return the given 'Tags' with the given 'Tag' incorporated.
 111 tag_cons :: Tag -> Tags -> Tags
 112 tag_cons (p, v) (Tags xs) = Tags $ mcons (p, [v]) xs
 113
 114 -- | Return the 'Tag' formed by the given 'Tag_Path' and 'Tag_Value'.
 115 tag :: Tag_Path -> Tag_Value -> Tag
 116 tag = (,)
 117
 118 -- | Return the 'Tag_Value' formed by the given 'Tag_Section' and 'Tag_Section's.
 119 tag_path :: Tag_Section -> [Tag_Section] -> Tag_Path
 120 tag_path = (:|)
 121
 122 -- | Return the 'Tag_Value' of a 'Tag', if any.
 123 tag_value :: Tag -> Maybe Tag_Value
 124 tag_value (_, v) | Text.null v = Nothing
 125 tag_value (_, v) = Just v
 126
 127 -- | Return the number of 'Tag_Section's in the given 'Tag'.
 128 tag_depth :: Tag_Path -> Int
 129 tag_depth = NonEmpty.length
 130
 131 -- | Return a 'Tag_Path' from the given list.
 132 tag_from_List :: [(Tag_Path, Tag_Value)] -> Tags
 133 tag_from_List = Tags . Map.fromListWith (flip mappend) . fmap (second pure)
 134 -}