Language/DTC/Write/HTML5.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DeriveFunctor #-}
   3 {-# LANGUAGE DisambiguateRecordFields #-}
   4 {-# LANGUAGE DuplicateRecordFields #-}
   5 {-# LANGUAGE ExistentialQuantification #-}
   6 {-# LANGUAGE FlexibleInstances #-}
   7 {-# LANGUAGE FlexibleContexts #-}
   8 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   9 {-# LANGUAGE MultiParamTypeClasses #-}
  10 {-# LANGUAGE OverloadedStrings #-}
  11 {-# LANGUAGE RecordWildCards #-}
  12 {-# LANGUAGE ScopedTypeVariables #-}
  13 {-# LANGUAGE TypeApplications #-}
  14 {-# LANGUAGE ViewPatterns #-}
  15 {-# OPTIONS_GHC -fno-warn-orphans #-}
  16 -- | Render a DTC source file in HTML5.
  17 module Language.DTC.Write.HTML5 where
  18
  19 -- import Control.Monad.Trans.Class (MonadTrans(..))
  20 -- import Data.Bool
  21 -- import Data.Functor.Identity (Identity(..))
  22 -- import qualified Data.Map.Strict as Map
  23 -- import qualified Data.TreeSeq.Strict as Tree
  24 import Control.Applicative (Applicative(..))
  25 import Control.Monad (Monad(..), forM_, mapM_, when{-, (>=>)-})
  26 import Data.Char (Char)
  27 import Data.Eq (Eq(..))
  28 import Data.Foldable (Foldable(..))
  29 import Data.Function (($), (.))
  30 import Data.Functor ((<$>))
  31 import Data.Functor.Compose (Compose(..))
  32 import Data.Int (Int)
  33 import Data.Map.Strict (Map)
  34 import Data.Maybe (Maybe(..))
  35 import Data.Monoid (Monoid(..))
  36 import Data.Ord (Ord(..))
  37 import Data.Semigroup (Semigroup(..))
  38 import Data.Sequence (Seq)
  39 import Data.String (String)
  40 import Data.Text (Text)
  41 import Data.TreeSeq.Strict (Tree(..))
  42 import Data.Tuple (snd)
  43 import Prelude (Num(..))
  44 import Text.Blaze ((!))
  45 import Text.Blaze.Html (Html)
  46 import Text.Show (Show(..))
  47 import qualified Control.Monad.Trans.State as S
  48 import qualified Data.List as List
  49 import qualified Data.Text as Text
  50 import qualified Data.Text.Lazy as TL
  51 import qualified Data.TreeSeq.Strict.Zipper as Tree
  52 import qualified Text.Blaze.Html5 as H
  53 import qualified Text.Blaze.Html5.Attributes  as HA
  54 import qualified Text.Blaze.Internal as H
  55
  56 import Text.Blaze.Utils
  57 import Data.Locale hiding (localize)
  58 import qualified Data.Locale as Locale
  59
  60 import Language.DTC.Document (Document)
  61 import Language.DTC.Write.XML ()
  62 import Language.XML (XmlName(..), XmlPos(..))
  63 import qualified Language.DTC.Document as DTC
  64 -- import Debug.Trace (trace)
  65
  66 -- * Type 'Html5'
  67 type Html5 = StateMarkup StateHtml5 ()
  68
  69 -- ** Type 'StateHtml5'
  70 data StateHtml5
  71  =   StateHtml5
  72  { styles   :: Map Text CSS
  73  , scripts  :: Map Text Script
  74  , localize :: MsgHtml5 -> Html5
  75  }
  76 stateHtml5 :: StateHtml5
  77 stateHtml5 = StateHtml5
  78  { styles   = mempty
  79  , scripts  = mempty
  80  , localize = html5ify . show
  81  }
  82 type CSS = Text
  83 type Script = Text
  84
  85 -- ** Class 'Html5ify'
  86 class Html5ify a where
  87         html5ify :: a -> Html5
  88 instance Html5ify Char where
  89         html5ify = html5ify . H.toMarkup
  90 instance Html5ify Text where
  91         html5ify = html5ify . H.toMarkup
  92 instance Html5ify String where
  93         html5ify = html5ify . H.toMarkup
  94 instance Html5ify H.Markup where
  95         html5ify = Compose . return
  96 instance Html5ify DTC.Title where
  97         html5ify (DTC.Title t) = html5ify t
  98 instance Html5ify DTC.Ident where
  99         html5ify (DTC.Ident i) = html5ify i
 100
 101
 102 html5Document ::
 103  Localize ls Html5 MsgHtml5 =>
 104  Locales ls =>
 105  LocaleIn ls -> Document -> Html
 106 html5Document locale DTC.Document{..} = do
 107         let (h, StateHtml5{..}) =
 108                 runStateMarkup stateHtml5 $ do
 109                         liftStateMarkup $ S.modify $ \s -> s{localize = Locale.localize locale}
 110                         html5ify body
 111         H.docType
 112         H.html ! HA.lang (attrValue $ countryCode locale) $ do
 113                 H.head $ do
 114                         H.meta ! HA.httpEquiv "Content-Type"
 115                                ! HA.content "text/html; charset=UTF-8"
 116                         whenSome (DTC.titles $ DTC.about (head :: DTC.Head)) $ \ts ->
 117                                 H.title $
 118                                         H.toMarkup $
 119                                         plainify $
 120                                         List.head $
 121                                         (DTC.unTitle <$> ts) <> [[DTC.Plain ""]]
 122                         -- link ! rel "Chapter" ! title "SomeTitle">
 123                         H.meta ! HA.name "generator"
 124                                ! HA.content "tct"
 125                         H.link ! HA.rel "stylesheet"
 126                                ! HA.type_ "text/css"
 127                                ! HA.href "style/dtc-html5.css"
 128                         forM_ styles $ \style ->
 129                                 H.style ! HA.type_ "text/css" $
 130                                         H.toMarkup style
 131                         forM_ scripts $ \script ->
 132                                 H.script ! HA.type_ "application/javascript" $
 133                                         H.toMarkup script
 134                 H.body h
 135
 136 -- * Type 'BodyZip'
 137 -- | Cursor to navigate within a 'DTC.Body' according to many axis (like in XSLT).
 138 type BodyZip = Tree.Zipper DTC.BodyKey (Seq DTC.BodyValue)
 139 instance Html5ify DTC.Body where
 140         html5ify body =
 141                 forM_ (Tree.zippers body) $
 142                         html5ify
 143
 144 instance Html5ify BodyZip where
 145         html5ify z =
 146                 case Tree.current z of
 147                  TreeN k _ts -> html5BodyKey z k
 148                  Tree0 vs -> forM_ vs $ html5BodyValue z
 149
 150 html5BodyKey :: BodyZip -> DTC.BodyKey -> Html5
 151 html5BodyKey z = \case
 152          DTC.Section{..} ->
 153                 H.section ! HA.class_ "section"
 154                           ! HA.id (attrValue pos) $$ do
 155                         html5CommonAttrs attrs $
 156                                 H.table ! HA.class_ "section-header" $$
 157                                         H.tbody $$
 158                                                 H.tr $$ do
 159                                                         H.td ! HA.class_ "section-number" $$ do
 160                                                                 html5SectionNumber $
 161                                                                         xmlPosAncestors pos
 162                                                         H.td ! HA.class_ "section-title" $$ do
 163                                                                 html5ify title
 164                         forM_ (Tree.axis_child z) $
 165                                 html5ify
 166 html5BodyValue :: BodyZip -> DTC.BodyValue -> Html5
 167 html5BodyValue z = \case
 168          DTC.Vertical v -> do
 169                 html5ify v
 170          DTC.ToC{..} -> do
 171                 H.nav ! HA.class_ "toc"
 172                       ! HA.id (attrValue pos) $$ do
 173                         H.span ! HA.class_ "toc-name" $$
 174                                 H.a ! HA.href (attrValue pos) $$
 175                                         html5ify MsgHTML5_Table_of_Contents
 176                         H.ul $$
 177                                 forM_ (Tree.axis_following_sibling z) $
 178                                         html5ToC d
 179                 where d = case depth of { Just (DTC.Nat n) -> n; _ -> 0 }
 180          DTC.ToF{..} -> do
 181                 H.nav ! HA.class_ "tof"
 182                       ! HA.id (attrValue pos) $$
 183                         H.table ! HA.class_ "tof" $$
 184                                 H.tbody $$
 185                                         forM_ (Tree.axis_preceding z) $
 186                                                 html5ToF d
 187                 where d = case depth of { Just (DTC.Nat n) -> n; _ -> 0 }
 188          DTC.Figure{..} ->
 189                 html5CommonAttrs attrs $
 190                 H.div ! HA.class_ (attrValue $ "figure-"<>type_)
 191                       ! HA.id (attrValue pos) $$ do
 192                         H.table ! HA.class_ "figure-caption" $$
 193                                 H.tbody $$
 194                                         H.tr $$ do
 195                                                 H.td ! HA.class_ "figure-number" $$ do
 196                                                         H.a ! HA.href ("#"<>attrValue pos) $$
 197                                                                 html5ify type_
 198                                                         ": "
 199                                                 H.td ! HA.class_ "figure-name" $$
 200                                                         html5ify title
 201                         H.div ! HA.class_ "figure-content" $$ do
 202                                 html5ify verts
 203 html5ToC :: Int -> BodyZip -> Html5
 204 html5ToC depth z =
 205         case Tree.current z of
 206          TreeN DTC.Section{..} _ts -> do
 207                 H.li $$ do
 208                         H.table ! HA.class_ "toc-entry" $$
 209                                 H.tbody $$
 210                                         H.tr $$ do
 211                                                 H.td $$
 212                                                         html5SectionRef $ xmlPosAncestors pos
 213                                                 H.td $$
 214                                                         html5ify title
 215                         when (depth > 0) $
 216                                 H.ul $$
 217                                         forM_ (Tree.axis_child z) $
 218                                                 html5ToC (depth - 1)
 219          _ -> pure ()
 220 html5ToF :: Int -> BodyZip -> Html5
 221 html5ToF depth z =
 222         case Tree.current z of
 223          Tree0 bs ->
 224                 forM_ bs $ \case
 225                  DTC.Figure{..} ->
 226                         H.tr $$ do
 227                                 H.td ! HA.class_ "figure-number" $$
 228                                         H.a ! HA.href ("#"<>attrValue pos) $$
 229                                                 html5ify type_
 230                                 H.td ! HA.class_ "figure-name" $$
 231                                         html5ify title
 232                  _ -> pure ()
 233          _ -> pure ()
 234
 235 instance Html5ify [DTC.Vertical] where
 236         html5ify = mapM_ html5ify
 237 instance Html5ify DTC.Vertical where
 238         html5ify = \case
 239          DTC.Para{..} ->
 240                 html5CommonAttrs attrs $
 241                 H.div ! HA.class_ "para"
 242                       ! HA.id (attrValue pos) $$ do
 243                         html5ify horis
 244          DTC.OL{..} ->
 245                 html5CommonAttrs attrs $
 246                 H.ol ! HA.class_ "ol"
 247                      ! HA.id (attrValue pos) $$ do
 248                         forM_ items $ \item ->
 249                                 H.li $$ html5ify item
 250          DTC.UL{..} ->
 251                 html5CommonAttrs attrs $
 252                 H.ul ! HA.class_ "ul"
 253                      ! HA.id (attrValue pos) $$ do
 254                         forM_ items $ \item ->
 255                                 H.li $$ html5ify item
 256          DTC.RL{..} ->
 257                 html5CommonAttrs attrs $
 258                 H.div ! HA.class_ "rl"
 259                       ! HA.id (attrValue pos) $$ do
 260                         H.table $$
 261                                 forM_ refs html5ify
 262          DTC.Comment t ->
 263                 html5ify $ H.Comment (H.Text t) ()
 264         {-
 265          Index{..} ->
 266          Artwork{..} ->
 267         -}
 268 instance Html5ify DTC.Horizontal where
 269         html5ify = \case
 270                  DTC.BR       -> html5ify H.br
 271                  DTC.B    hs  -> H.strong $$ html5ify hs
 272                  DTC.Code hs  -> H.code   $$ html5ify hs
 273                  DTC.Del  hs  -> H.del    $$ html5ify hs
 274                  DTC.I    hs  -> H.i      $$ html5ify hs
 275                  DTC.Note _   -> ""
 276                  DTC.Q    hs  -> do
 277                         "« "::Html5
 278                         H.i $$ html5ify hs
 279                         " »"
 280                  DTC.SC   hs  -> html5ify hs
 281                  DTC.Sub  hs  -> H.sub $$ html5ify hs
 282                  DTC.Sup  hs  -> H.sup $$ html5ify hs
 283                  DTC.U    hs  -> H.span ! HA.class_ "underline" $$ html5ify hs
 284                  DTC.Eref{..} ->
 285                         H.a ! HA.class_ "eref"
 286                             ! HA.href (attrValue href) $$
 287                                 html5ify text
 288                  DTC.Iref{..} ->
 289                         H.a ! HA.class_ "iref"
 290                             ! HA.href (attrValue to) $$
 291                                 html5ify text
 292                  DTC.Ref{..}  ->
 293                         H.a ! HA.class_ "ref"
 294                             ! HA.href ("#"<>attrValue to) $$
 295                         if null text
 296                         then html5ify to
 297                         else html5ify text
 298                  DTC.Rref{..} ->
 299                         H.a ! HA.class_ "rref"
 300                             ! HA.href (attrValue to) $$
 301                                 html5ify text
 302                  DTC.Plain t  -> Compose $ return $ H.toMarkup t
 303 instance Html5ify [DTC.Horizontal] where
 304         html5ify = mapM_ html5ify
 305 instance Html5ify DTC.About where
 306         html5ify DTC.About{..} =
 307                 forM_ titles $ \(DTC.Title title) ->
 308                         html5ify $ DTC.Q title
 309 instance Html5ify DTC.Reference where
 310         html5ify DTC.Reference{..} =
 311                 H.tr $$ do
 312                         H.td ! HA.class_ "reference-key" $$
 313                                 html5ify id
 314                         H.td ! HA.class_ "reference-content" $$
 315                                 html5ify about
 316
 317 html5CommonAttrs :: DTC.CommonAttrs -> Html5 -> Html5
 318 html5CommonAttrs DTC.CommonAttrs{..} =
 319         Compose . (addClass . addId <$>) . getCompose
 320         where
 321         addClass =
 322                 case classes of
 323                  [] -> \x -> x
 324                  _  -> H.AddCustomAttribute "class" (H.Text $ Text.unwords classes)
 325         addId =
 326                 case id of
 327                  Nothing -> \x -> x
 328                  Just (DTC.Ident i) ->
 329                         H.AddCustomAttribute "id" (H.Text i)
 330
 331 html5SectionNumber :: [(XmlName,Int)] -> Html5
 332 html5SectionNumber = go [] . List.reverse
 333         where
 334         go :: [(XmlName,Int)] -> [(XmlName,Int)] -> Html5
 335         go _rs [] = pure ()
 336         go rs (a@(_n,cnt):as) = do
 337                 H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors (a:rs)) $$
 338                         html5ify $ show cnt
 339                 html5ify '.'
 340                 go (a:rs) as
 341
 342 html5SectionRef :: [(XmlName,Int)] -> Html5
 343 html5SectionRef as =
 344         H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors as) $$
 345                 case as of
 346                  [(_n,c)] -> do
 347                         html5ify $ show c
 348                         html5ify '.'
 349                  _ ->
 350                         html5ify $
 351                                 Text.intercalate "." $
 352                                 Text.pack . show . snd <$> as
 353
 354 textXmlPosAncestors :: [(XmlName,Int)] -> Text
 355 textXmlPosAncestors =
 356         snd . foldr (\(n,c) (nParent,acc) ->
 357                 (n,
 358                         (if Text.null acc
 359                                 then acc
 360                                 else acc <> ".") <>
 361                         Text.pack
 362                          (if n == nParent
 363                                 then show c
 364                                 else show n<>show c)
 365                 )
 366          )
 367          ("","")
 368
 369 -- * Class 'Plainify'
 370 class Plainify a where
 371         plainify :: a -> TL.Text
 372 instance Plainify DTC.Horizontal where
 373         plainify = \case
 374          DTC.BR       -> "\n"
 375          DTC.B    hs  -> "*"<>plainify hs<>"*"
 376          DTC.Code hs  -> "`"<>plainify hs<>"`"
 377          DTC.Del  hs  -> "-"<>plainify hs<>"-"
 378          DTC.I    hs  -> "/"<>plainify hs<>"/"
 379          DTC.Note _   -> ""
 380          DTC.Q    hs  -> "« "<>plainify hs<>" »"
 381          DTC.SC   hs  -> plainify hs
 382          DTC.Sub  hs  -> plainify hs
 383          DTC.Sup  hs  -> plainify hs
 384          DTC.U    hs  -> "_"<>plainify hs<>"_"
 385          DTC.Eref{..} -> plainify text
 386          DTC.Iref{..} -> plainify text
 387          DTC.Ref{..}  -> plainify text
 388          DTC.Rref{..} -> plainify text
 389          DTC.Plain t  -> TL.fromStrict t
 390 instance Plainify [DTC.Horizontal] where
 391         plainify = foldMap plainify
 392
 393 instance AttrValue XmlPos where
 394         attrValue = attrValue . textXmlPosAncestors . xmlPosAncestors
 395
 396 -- * Type 'MsgHtml5'
 397 data MsgHtml5
 398  =   MsgHTML5_Table_of_Contents
 399  deriving (Show)
 400 instance Html5ify MsgHtml5 where
 401         html5ify msg = do
 402                 loc <- liftStateMarkup $ S.gets localize
 403                 loc msg
 404 instance LocalizeIn FR Html5 MsgHtml5 where
 405         localizeIn _ MsgHTML5_Table_of_Contents = "Sommaire"
 406 instance LocalizeIn EN Html5 MsgHtml5 where
 407         localizeIn _ MsgHTML5_Table_of_Contents = "Summary"