Hdoc/DTC/Write/HTML5/Ident.hs

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