lib/Hcompta/Tag.hs

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