Language/DTC/Write/HTML5.hs

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