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 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 -> Ident
  97 identifyIref term =
  98         "iref"
  99          <> "." <> identify (Index.plainifyWords term)
 100 identifyIrefCount :: Words -> Nat1 -> Ident
 101 identifyIrefCount term count =
 102         "iref"
 103          <> "." <> identify (Index.plainifyWords term)
 104          <> "." <> identify count
 105
 106 identifyTag :: Ident -> Loqualization (Plain.L10n Plain.Plain) -> Plain -> Maybe Nat1 -> Ident
 107 identifyTag suffix state_l10n to count =
 108         "tag" <> suffix
 109          <> "." <> identifyPlain state_l10n to
 110          <> maybe "" (("."<>) . identify) count
 111
 112 identifyReference :: Ident -> Ident -> Maybe Nat1 -> Ident
 113 identifyReference suffix to count =
 114         "reference" <> suffix
 115          <> "." <> to
 116          <> maybe "" (("."<>) . identify) count
 117
 118 cleanPlain :: Plain -> Plain
 119 cleanPlain ps =
 120         ps >>= \case
 121          Tree PlainIref{} ls -> cleanPlain ls
 122          Tree PlainNote{} _  -> mempty
 123          Tree n ts -> return $ Tree n $ cleanPlain ts
 124
 125 identifyPlain :: Loqualization (Plain.L10n Plain.Plain) -> Plain -> Ident
 126 identifyPlain state_l10n =
 127         escapeIdent .
 128         Plain.text def{Plain.state_l10n}
 129
 130 identifyTitle :: Loqualization (Plain.L10n Plain.Plain) -> Title -> Ident
 131 identifyTitle state_l10n = identifyPlain state_l10n . unTitle