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 Hdoc.DTC.Analyze.Index (plainifyWords)
  35 import qualified Hdoc.DTC.Write.Plain as Plain
  36 import qualified Hdoc.XML as XML
  37
  38 -- * Class 'Identify'
  39 class Identify a where
  40         identify :: a -> Ident
  41 instance Identify Char where
  42         identify = Ident . TL.singleton
  43 instance Identify String where
  44         identify = Ident . TL.pack
  45 instance Identify TL.Text where
  46         identify = Ident
  47 instance Identify Ident where
  48         identify (Ident p) = identify p
  49 instance Identify XML.Ancestors where
  50         identify =
  51                 Ident .
  52                 escapeIdentHead .
  53                 snd . foldl' (\(nameParent,acc) (name,rank) ->
  54                         (name,
  55                                 (if TL.null acc then acc else acc <> ".") <>
  56                                 (if name == nameParent
  57                                         then unIdent $ identify $ show rank
  58                                         else identifyString (show name)<>"."<>identifyString (show rank))
  59                         )
  60                  )
  61                  ("",mempty)
  62                 where identifyString = escapeIdentTail . TL.pack
  63 instance Identify XML.Pos where
  64         identify = identify . XML.pos_ancestors
  65 instance Identify Int where
  66         identify = fromString . show
  67 instance Identify Nat where
  68         identify (Nat a) = identify a
  69 instance Identify Nat1 where
  70         identify (Nat1 a) = identify a
  71 instance Identify Anchor where
  72         identify Anchor{..} = identify anchor_section <> "." <> identify anchor_count
  73
  74 refIdent :: Ident -> H.AttributeValue
  75 refIdent i = "#"<>attrify i
  76
  77 escapeIdent :: TL.Text -> Ident
  78 escapeIdent = Ident . escapeIdentHead . escapeIdentTail
  79 escapeIdentHead :: TL.Text -> TL.Text
  80 escapeIdentHead = Cat.id
  81 escapeIdentTail :: TL.Text -> TL.Text
  82 escapeIdentTail =
  83         TL.foldr
  84          (\c accum -> (<> accum) $ case c of
  85                  ' ' -> "+"
  86                  _ | Char.isAlphaNum c
  87                    || c == '-'
  88                    -> TL.singleton c
  89                  _ -> "_"<>bytes
  90                         where
  91                         enc    = TL.encodeUtf8 $ TL.singleton c
  92                         bytes  = BS.foldr (\b acc -> escape b<>acc) "" enc
  93                         escape = TL.Builder.toLazyText . TL.Builder.hexadecimal
  94          ) ""
  95
  96 identifyIref :: Words -> Maybe Nat1 -> Ident
  97 identifyIref term count =
  98         "iref"
  99          <> "." <> identify (escapeIdent $ plainifyWords term)
 100          <> maybe "" (("."<>) . identify) count
 101
 102 identifyTag :: Ident -> Ident -> Maybe Nat1 -> Ident
 103 identifyTag suffix tag count =
 104         (if suffix == Ident ""
 105                 then ""
 106                 else "tag" <> suffix <> ".")
 107          <> escapeIdent (unIdent tag)
 108          <> maybe "" (("."<>) . identify) count
 109
 110 identifyReference :: Ident -> Ident -> Maybe Nat1 -> Ident
 111 identifyReference suffix to count =
 112         "reference" <> suffix
 113          <> "." <> to
 114          <> maybe "" (("."<>) . identify) count
 115
 116 cleanPlain :: Plain -> Plain
 117 cleanPlain ps =
 118         ps >>= \case
 119          Tree PlainIref{} ls -> cleanPlain ls
 120          Tree PlainNote{} _  -> mempty
 121          Tree n ts -> return $ Tree n $ cleanPlain ts
 122
 123 identifyPlain :: Loqualization (Plain.L10n Plain.Plain) -> Plain -> Ident
 124 identifyPlain reader_l10n =
 125         escapeIdent .
 126         Plain.text def{Plain.reader_l10n}
 127
 128 identifyTitle :: Loqualization (Plain.L10n Plain.Plain) -> Title -> Ident
 129 identifyTitle state_l10n = identifyPlain state_l10n . unTitle