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                         (Just name,
  55                                 (if TL.null acc then acc else acc <> ".") <>
  56                                 (if Just name == nameParent
  57                                         then unIdent $ identify $ show rank
  58                                         else identifyString (show name)<>"."<>identifyString (show rank))
  59                         )
  60                  )
  61                  (Nothing, mempty)
  62                 where identifyString = escapeIdentTail . TL.pack
  63 {-
  64 instance Plainify XML.Ancestors where -- TODO: no need to be in Plainify, better in Ident
  65         plainify =
  66                 plainify .
  67                 snd . foldl' (\(nParent,acc) (n,c) ->
  68                         (n,
  69                                 (if TL.null acc then acc else acc <> ".") <>
  70                                 (if n == nParent
  71                                         then TL.pack (show c)
  72                                         else TL.pack (show n)<>TL.pack (show c))
  73                         )
  74                  )
  75                  ("","")
  76 -}
  77 instance Identify XML.Pos where
  78         identify = identify . XML.pos_ancestors
  79 instance Identify Int where
  80         identify = fromString . show
  81 instance Identify Nat where
  82         identify (Nat a) = identify a
  83 instance Identify Nat1 where
  84         identify (Nat1 a) = identify a
  85 instance Identify Anchor where
  86         identify Anchor{..} = identify anchor_section <> "." <> identify anchor_count
  87
  88 refIdent :: Ident -> H.AttributeValue
  89 refIdent i = "#"<>attrify i
  90
  91 escapeIdent :: TL.Text -> Ident
  92 escapeIdent = Ident . escapeIdentHead . escapeIdentTail
  93 escapeIdentHead :: TL.Text -> TL.Text
  94 escapeIdentHead = Cat.id
  95 escapeIdentTail :: TL.Text -> TL.Text
  96 escapeIdentTail =
  97         TL.foldr
  98          (\c accum -> (<> accum) $ case c of
  99                  ' ' -> "+"
 100                  _ | Char.isAlphaNum c
 101                    || c == '-'
 102                    -> TL.singleton c
 103                  _ -> "_"<>bytes
 104                         where
 105                         enc    = TL.encodeUtf8 $ TL.singleton c
 106                         bytes  = BS.foldr (\b acc -> escape b<>acc) "" enc
 107                         escape = TL.Builder.toLazyText . TL.Builder.hexadecimal
 108          ) ""
 109
 110 identifyIref :: Words -> Maybe Nat1 -> Ident
 111 identifyIref term count =
 112         "iref"
 113          <> "." <> identify (escapeIdent $ plainifyWords term)
 114          <> maybe "" (("."<>) . identify) count
 115
 116 identifyTag :: Ident -> Ident -> Maybe Nat1 -> Ident
 117 identifyTag suffix tag count =
 118         (if suffix == Ident ""
 119                 then ""
 120                 else "tag" <> suffix <> ".")
 121          <> escapeIdent (unIdent tag)
 122          <> maybe "" (("."<>) . identify) count
 123
 124 identifyAt :: Ident -> Ident -> Maybe Nat1 -> Ident
 125 identifyAt suffix ref count =
 126         (if suffix == Ident ""
 127                 then ""
 128                 else "at" <> suffix <> ".")
 129          <> escapeIdent (unIdent ref)
 130          <> maybe "" (("."<>) . identify) count
 131
 132 identifyReference :: Ident -> Ident -> Maybe Nat1 -> Ident
 133 identifyReference suffix to count =
 134         "reference" <> suffix
 135          <> "." <> to
 136          <> maybe "" (("."<>) . identify) count
 137
 138 cleanPlain :: Plain -> Plain
 139 cleanPlain ps =
 140         ps >>= \case
 141          Tree PlainIref{} ls -> cleanPlain ls
 142          Tree PlainNote{} _  -> mempty
 143          Tree n ts -> return $ Tree n $ cleanPlain ts
 144
 145 identifyPlain :: Loqualization (Plain.L10n Plain.Plain) -> Plain -> Ident
 146 identifyPlain reader_l10n =
 147         escapeIdent .
 148         Plain.text def{Plain.reader_l10n}
 149
 150 identifyTitle :: Loqualization (Plain.L10n Plain.Plain) -> Title -> Ident
 151 identifyTitle state_l10n = identifyPlain state_l10n . unTitle