Hdoc/DTC/Write/HTML5/Ident.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 module Hdoc.DTC.Write.HTML5.Ident where
   4
   5 import Control.Category as Cat
   6 import Control.Monad (Monad(..))
   7 import Data.Bool
   8 import Data.Char (Char)
   9 import Data.Default.Class (Default(..))
  10 import Data.Eq (Eq(..))
  11 import Data.Foldable (Foldable(..))
  12 import Data.Function (($))
  13 import Data.Int (Int)
  14 import Data.Locale (Loqualization)
  15 import Data.Maybe (Maybe(..), maybe)
  16 import Data.Monoid (Monoid(..))
  17 import Data.Semigroup (Semigroup(..))
  18 import Data.String (String, IsString(..))
  19 import Data.TreeSeq.Strict (Tree(..))
  20 import Data.Tuple (snd)
  21 import Text.Show (Show(..))
  22 import qualified Data.ByteString.Lazy as BS
  23 import qualified Data.Char as Char
  24 import qualified Data.Text.Lazy as TL
  25 import qualified Data.Text.Lazy.Builder as TL.Builder
  26 import qualified Data.Text.Lazy.Builder.Int as TL.Builder
  27 import qualified Data.Text.Lazy.Encoding as TL
  28 import qualified Text.Blaze.Html5 as H
  29
  30 import Text.Blaze.Utils
  31
  32 import Hdoc.Utils ()
  33 import Hdoc.DTC.Document as DTC
  34 import qualified Hdoc.DTC.Index as Index
  35 import qualified Hdoc.DTC.Write.Plain as Plain
  36
  37 -- * Class 'Identify'
  38 class Identify a where
  39         identify :: a -> Ident
  40 instance Identify Char where
  41         identify = Ident . TL.singleton
  42 instance Identify String where
  43         identify = Ident . TL.pack
  44 instance Identify TL.Text where
  45         identify = Ident
  46 instance Identify Ident where
  47         identify (Ident p) = identify p
  48 instance Identify XmlPosPath where
  49         identify =
  50                 Ident .
  51                 escapeIdentHead .
  52                 snd . foldl' (\(nameParent,acc) (name,rank) ->
  53                         (name,
  54                                 (if TL.null acc then acc else acc <> ".") <>
  55                                 (if name == nameParent
  56                                         then unIdent $ identify $ show rank
  57                                         else identifyString (show name)<>"."<>identifyString (show rank))
  58                         )
  59                  )
  60                  ("",mempty)
  61                 where identifyString = escapeIdentTail . TL.pack
  62 instance Identify XmlPos where
  63         identify = identify . xmlPos_Ancestors
  64 instance Identify Path where
  65         identify (Path a) = identify a
  66 instance Identify Int where
  67         identify = fromString . show
  68 instance Identify Nat where
  69         identify (Nat a) = identify a
  70 instance Identify Nat1 where
  71         identify (Nat1 a) = identify a
  72 instance Identify Anchor where
  73         identify Anchor{..} = identify section <> "." <> identify count
  74
  75 refIdent :: Ident -> H.AttributeValue
  76 refIdent i = "#"<>attrify i
  77
  78 escapeIdent :: TL.Text -> Ident
  79 escapeIdent = Ident . escapeIdentHead . escapeIdentTail
  80 escapeIdentHead :: TL.Text -> TL.Text
  81 escapeIdentHead = Cat.id
  82 escapeIdentTail :: TL.Text -> TL.Text
  83 escapeIdentTail =
  84         TL.foldr
  85          (\c accum -> (<> accum) $ case c of
  86                  ' ' -> "+"
  87                  _ | Char.isAlphaNum c
  88                    || c == '-'
  89                    -> TL.singleton c
  90                  _ -> "_"<>bytes
  91                         where
  92                         enc    = TL.encodeUtf8 $ TL.singleton c
  93                         bytes  = BS.foldr (\b acc -> escape b<>acc) "" enc
  94                         escape = TL.Builder.toLazyText . TL.Builder.hexadecimal
  95          ) ""
  96
  97 identifyIref :: Words -> Ident
  98 identifyIref term =
  99         "iref"
 100          <> "." <> identify (Index.plainifyWords term)
 101 identifyIrefCount :: Words -> Nat1 -> Ident
 102 identifyIrefCount term count =
 103         "iref"
 104          <> "." <> identify (Index.plainifyWords term)
 105          <> "." <> identify count
 106
 107 identifyTag :: Ident -> Loqualization (Plain.L10n Plain.Plain) -> Plain -> Maybe Nat1 -> Ident
 108 identifyTag suffix state_l10n to count =
 109         "tag" <> suffix
 110          <> "." <> identifyPlain state_l10n to
 111          <> maybe "" (("."<>) . identify) count
 112
 113 identifyReference :: Ident -> Ident -> Maybe Nat1 -> Ident
 114 identifyReference suffix to count =
 115         "reference" <> suffix
 116          <> "." <> to
 117          <> maybe "" (("."<>) . identify) count
 118
 119 cleanPlain :: Plain -> Plain
 120 cleanPlain ps =
 121         ps >>= \case
 122          Tree PlainIref{} ls -> cleanPlain ls
 123          Tree PlainNote{} _  -> mempty
 124          Tree n ts -> return $ Tree n $ cleanPlain ts
 125
 126 identifyPlain :: Loqualization (Plain.L10n Plain.Plain) -> Plain -> Ident
 127 identifyPlain state_l10n =
 128         escapeIdent .
 129         Plain.text def{Plain.state_l10n}
 130
 131 identifyTitle :: Loqualization (Plain.L10n Plain.Plain) -> Title -> Ident
 132 identifyTitle state_l10n = identifyPlain state_l10n . unTitle