src/Textphile/DTC/Write/HTML5/Ident.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 module Textphile.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 import qualified Symantic.XML as XML
  30
  31 import Text.Blaze.Utils
  32
  33 import Textphile.Utils ()
  34 import Textphile.DTC.Document as DTC
  35 import Textphile.DTC.Analyze.Index (plainifyWords)
  36 import qualified Textphile.DTC.Write.Plain as Plain
  37 import qualified Textphile.XML as XML
  38
  39 -- * Class 'Identify'
  40 class Identify a where
  41         identify :: a -> Ident
  42 instance Identify Char where
  43         identify = Ident . TL.singleton
  44 instance Identify String where
  45         identify = Ident . TL.pack
  46 instance Identify TL.Text where
  47         identify = Ident
  48 instance Identify Ident where
  49         identify (Ident p) = identify p
  50 instance Identify XML.Ancestors where
  51         identify =
  52                 Ident .
  53                 escapeIdentHead .
  54                 snd . foldl' (\(nameParent,acc) (name,rank) ->
  55                         (Just name,
  56                                 (if TL.null acc then acc else acc <> ".") <>
  57                                 (if Just name == nameParent
  58                                         then unIdent $ identify $ show rank
  59                                         else identifyString (show $ XML.qNameLocal name)<>"."<>identifyString (show rank))
  60                         )
  61                  )
  62                  (Nothing, mempty)
  63                 where identifyString = escapeIdentTail . TL.pack
  64 {-
  65 instance Plainify XML.Ancestors where -- TODO: no need to be in Plainify, better in Ident
  66         plainify =
  67                 plainify .
  68                 snd . foldl' (\(nParent,acc) (n,c) ->
  69                         (n,
  70                                 (if TL.null acc then acc else acc <> ".") <>
  71                                 (if n == nParent
  72                                         then TL.pack (show c)
  73                                         else TL.pack (show n)<>TL.pack (show c))
  74                         )
  75                  )
  76                  ("","")
  77 -}
  78 instance Identify XML.Pos where
  79         identify = identify . XML.pos_ancestors
  80 instance Identify Int where
  81         identify = fromString . show
  82 instance Identify Nat where
  83         identify (Nat a) = identify a
  84 instance Identify Nat1 where
  85         identify (Nat1 a) = identify a
  86 instance Identify Anchor where
  87         identify Anchor{..} = identify anchor_section <> "." <> identify anchor_count
  88
  89 refIdent :: Ident -> H.AttributeValue
  90 refIdent i = "#"<>attrify i
  91
  92 escapeIdent :: TL.Text -> Ident
  93 escapeIdent = Ident . escapeIdentHead . escapeIdentTail
  94 escapeIdentHead :: TL.Text -> TL.Text
  95 escapeIdentHead = Cat.id
  96 escapeIdentTail :: TL.Text -> TL.Text
  97 escapeIdentTail =
  98         TL.foldr
  99          (\c accum -> (<> accum) $ case c of
 100                  ' ' -> "+"
 101                  _ | Char.isAlphaNum c
 102                    || c == '-'
 103                    -> TL.singleton c
 104                  _ -> "_"<>bytes
 105                         where
 106                         enc    = TL.encodeUtf8 $ TL.singleton c
 107                         bytes  = BS.foldr (\b acc -> escape b<>acc) "" enc
 108                         escape = TL.Builder.toLazyText . TL.Builder.hexadecimal
 109          ) ""
 110
 111 identifyIref :: Words -> Maybe Nat1 -> Ident
 112 identifyIref term count =
 113         "iref"
 114          <> "." <> identify (escapeIdent $ plainifyWords term)
 115          <> maybe "" (("."<>) . identify) count
 116
 117 identifyTag :: Ident -> Ident -> Maybe Nat1 -> Ident
 118 identifyTag suffix tag count =
 119         (if suffix == Ident ""
 120                 then ""
 121                 else "tag" <> suffix <> ".")
 122          <> escapeIdent (unIdent tag)
 123          <> maybe "" (("."<>) . identify) count
 124
 125 identifyAt :: Ident -> Ident -> Maybe Nat1 -> Ident
 126 identifyAt suffix ref count =
 127         (if suffix == Ident ""
 128                 then ""
 129                 else "at" <> suffix <> ".")
 130          <> escapeIdent (unIdent ref)
 131          <> maybe "" (("."<>) . identify) count
 132
 133 identifyPage :: Ident -> PathPage -> Maybe Nat1 -> Ident
 134 identifyPage suffix page count =
 135         (if suffix == Ident ""
 136                 then ""
 137                 else "page" <> suffix <> ".")
 138          <> escapeIdent page
 139          <> maybe "" (("."<>) . identify) count
 140
 141 identifyReference :: Ident -> Ident -> Maybe Nat1 -> Ident
 142 identifyReference suffix to count =
 143         "reference" <> suffix
 144          <> "." <> escapeIdent (unIdent to)
 145          <> maybe "" (("."<>) . identify) count
 146
 147 cleanPlain :: Plain -> Plain
 148 cleanPlain ps =
 149         ps >>= \case
 150          Tree PlainIref{} ls -> cleanPlain ls
 151          Tree PlainNote{} _  -> mempty
 152          Tree n ts -> return $ Tree n $ cleanPlain ts
 153
 154 identifyPlain :: Loqualization (Plain.L10n Plain.Plain) -> Plain -> Ident
 155 identifyPlain reader_l10n =
 156         escapeIdent .
 157         Plain.text def{Plain.reader_l10n}
 158
 159 identifyTitle :: Loqualization (Plain.L10n Plain.Plain) -> Title -> Ident
 160 identifyTitle state_l10n = identifyPlain state_l10n . unTitle