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.Text (Text)
  38 import Data.Tuple (snd)
  39 import Prelude (Num(..))
  40 import Text.Blaze ((!))
  41 import Text.Blaze.Html (Html)
  42 import Text.Show (Show(..))
  43 import qualified Data.List as List
  44 import qualified Data.Text as Text
  45 import qualified Data.Text.Lazy as TL
  46 import qualified Text.Blaze.Html5 as H
  47 import qualified Text.Blaze.Html5.Attributes  as HA
  48 import qualified Text.Blaze.Internal as H
  49
  50 import Text.Blaze.Utils
  51
  52 import Data.Locale
  53 import Language.DTC.Document (Document)
  54 import Language.DTC.Write.XML ()
  55 import Language.XML (XmlName(..), XmlPos(..))
  56 import qualified Language.DTC.Document as DTC
  57
  58 -- import Debug.Trace (trace)
  59
  60 instance H.ToMarkup DTC.Ident where
  61         toMarkup (DTC.Ident i) = H.toMarkup i
  62 instance AttrValue XmlPos where
  63         attrValue = attrValue . textXmlPosAncestors . xmlPosAncestors
  64
  65 -- * Type 'InhHtml5'
  66 data InhHtml5
  67  =   InhHtml5
  68  {   inhHtml5_localize :: MsgHtml5 -> Html
  69  }
  70 inhHtml5 :: InhHtml5
  71 inhHtml5 = InhHtml5
  72  { inhHtml5_localize = localizeIn @EN EN_US
  73  }
  74
  75 -- * Type 'MsgHtml5'
  76 data MsgHtml5
  77  =   MsgHTML5_Table_of_Contents
  78 instance LocalizeIn FR Html MsgHtml5 where
  79         localizeIn _ MsgHTML5_Table_of_Contents = "Sommaire"
  80 instance LocalizeIn EN Html MsgHtml5 where
  81         localizeIn _ MsgHTML5_Table_of_Contents = "Table of Contents"
  82
  83 {- NOTE: composing state and markups
  84 type HtmlM st = Compose (S.State st) H.MarkupM
  85 instance Monad (HtmlM st) where
  86         return = pure
  87         Compose sma >>= a2csmb =
  88                 Compose $ sma >>= \ma ->
  89                         case ma >>= H.Empty . a2csmb of
  90                          H.Append _ma (H.Empty csmb) ->
  91                                 H.Append ma <$> getCompose csmb
  92                          _ -> undefined
  93
  94 ($$) :: (Html -> Html) -> HTML -> HTML
  95 ($$) f m = Compose $ f <$> getCompose m
  96 infixr 0 $$
  97 -}
  98
  99 unMarkupValue :: H.MarkupM a -> b -> H.MarkupM b
 100 unMarkupValue = \case
 101  H.Parent x0 x1 x2 m          -> H.Parent x0 x1 x2 . unMarkupValue m
 102  H.CustomParent x0 m          -> H.CustomParent x0 . unMarkupValue m
 103  H.Leaf x0 x1 x2 _            -> H.Leaf x0 x1 x2
 104  H.CustomLeaf x0 x1 _         -> H.CustomLeaf x0 x1
 105  H.Content x0 _               -> H.Content x0
 106  H.Comment x0 _               -> H.Comment x0
 107  H.Append x0 m                -> H.Append x0 . unMarkupValue m
 108  H.AddAttribute x0 x1 x2 m    -> H.AddAttribute x0 x1 x2 . unMarkupValue m
 109  H.AddCustomAttribute x0 x1 m -> H.AddCustomAttribute x0 x1 . unMarkupValue m
 110  H.Empty _                    -> H.Empty
 111
 112 markupValue :: H.MarkupM a -> a
 113 markupValue m0 = case m0 of
 114  H.Parent _ _ _ m1           -> markupValue m1
 115  H.CustomParent _ m1         -> markupValue m1
 116  H.Leaf _ _ _ x              -> x
 117  H.CustomLeaf _ _ x          -> x
 118  H.Content _ x               -> x
 119  H.Comment _ x               -> x
 120  H.Append _ m1               -> markupValue m1
 121  H.AddAttribute _ _ _ m1     -> markupValue m1
 122  H.AddCustomAttribute _ _ m1 -> markupValue m1
 123  H.Empty x                   -> x
 124
 125 html5Document ::
 126  Localize ls Html MsgHtml5 =>
 127  LocaleIn ls -> Document -> Html
 128 html5Document loc DTC.Document{..} = do
 129         let inh = InhHtml5
 130                  { inhHtml5_localize = localize loc
 131                  }
 132         H.docType
 133         H.html $ do
 134                 H.head $ do
 135                         H.meta ! HA.httpEquiv "Content-Type"
 136                                ! HA.content "text/html; charset=UTF-8"
 137                         whenSome (DTC.titles $ DTC.about (head :: DTC.Head)) $ \ts ->
 138                                 let t = textHorizontals $ List.head $ (DTC.unTitle <$> ts) <> [[DTC.Plain ""]] in
 139                                 H.title $ H.toMarkup t
 140                         -- link ! rel "Chapter" ! title "SomeTitle">
 141                         H.link ! HA.rel "stylesheet"
 142                                ! HA.type_ "text/css"
 143                                ! HA.href "style/dtc-html5.css"
 144                 H.body $
 145                         html5Body inh body
 146
 147 html5Body :: InhHtml5 -> [DTC.Body] -> Html
 148 html5Body _inh [] = mempty
 149 html5Body inh@InhHtml5{..} (b:bs) =
 150         case b of
 151          DTC.Section{..} -> do
 152                 H.section
 153                  ! 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 $ xmlPosAncestors pos
 161                                                         H.td ! HA.class_ "section-title" $ do
 162                                                                 html5Horizontals $ DTC.unTitle title
 163                         html5Body inh body
 164                 html5Body inh bs
 165                 {- aliases :: [Alias]
 166                 -}
 167          DTC.Verticals vs -> do
 168                 html5Verticals vs
 169                 html5Body inh bs
 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                                         inhHtml5_localize MsgHTML5_Table_of_Contents
 176                         H.ul $
 177                                 html5ToC d bs
 178                 html5Body inh bs
 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                         ""
 184                 html5Body inh bs
 185
 186 html5ToC :: Int -> [DTC.Body] -> Html
 187 html5ToC _depth [] = mempty
 188 html5ToC depth (b:bs) =
 189         case b of
 190          DTC.Section{..} -> do
 191                 H.li $ do
 192                         H.table ! HA.class_ "toc-entry" $
 193                                 H.tbody $
 194                                         H.tr $ do
 195                                                 H.td $
 196                                                         html5SectionRef $ xmlPosAncestors pos
 197                                                 H.td $
 198                                                         html5Horizontals $ DTC.unTitle title
 199                         when (depth > 0) $
 200                                 H.ul $ html5ToC (depth - 1) body
 201                 html5ToC depth bs
 202          _ -> html5ToC depth bs
 203
 204 textXmlPosAncestors :: [(XmlName,Int)] -> Text
 205 textXmlPosAncestors =
 206         snd . foldr (\(n,c) (nParent,acc) ->
 207                 (n,
 208                         (if Text.null acc
 209                                 then acc
 210                                 else acc <> ".") <>
 211                         Text.pack
 212                          (if n == nParent
 213                                 then show c
 214                                 else show n<>show c)
 215                 )
 216          ) ("","")
 217
 218 html5SectionNumber :: [(XmlName,Int)] -> Html
 219 html5SectionNumber = go [] . List.reverse
 220         where
 221         go :: [(XmlName,Int)] -> [(XmlName,Int)] -> Html
 222         go _rs [] = mempty
 223         go rs (a@(_n,cnt):as) = do
 224                 H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors (a:rs)) $
 225                         H.toMarkup $ show cnt
 226                 H.toMarkup '.'
 227                 go (a:rs) as
 228
 229 html5SectionRef :: [(XmlName,Int)] -> Html
 230 html5SectionRef as =
 231         H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors as) $
 232                 case as of
 233                  [(_n,c)] -> do
 234                         H.toMarkup $ show c
 235                         H.toMarkup '.'
 236                  _ ->
 237                         H.toMarkup $
 238                                 Text.intercalate "." $
 239                                 Text.pack . show . snd <$> as
 240
 241 html5Verticals :: [DTC.Vertical] -> Html
 242 html5Verticals = foldMap html5Vertical
 243
 244 html5Vertical :: DTC.Vertical -> Html
 245 html5Vertical = \case
 246          DTC.Para{..} ->
 247                 html5CommonAttrs attrs $
 248                 H.div ! HA.class_ "para"
 249                       ! HA.id (attrValue pos) $ do
 250                         html5Horizontals horis
 251          DTC.OL{..} ->
 252                 html5CommonAttrs attrs $
 253                 H.ol ! HA.class_ "ol"
 254                      ! HA.id (attrValue pos) $ do
 255                         forM_ items $ \item ->
 256                                 H.li $ html5Verticals item
 257          DTC.UL{..} ->
 258                 html5CommonAttrs attrs $
 259                 H.ul ! HA.class_ "ul"
 260                      ! HA.id (attrValue pos) $ do
 261                         forM_ items $ \item ->
 262                                 H.li $ html5Verticals item
 263          DTC.RL{..} ->
 264                 html5CommonAttrs attrs $
 265                 H.div ! HA.class_ "rl"
 266                       ! HA.id (attrValue pos) $ do
 267                         H.table $
 268                                 forM_ refs html5Reference
 269          DTC.Comment t ->
 270                 H.Comment (H.Text t) ()
 271          DTC.Figure{..} ->
 272                 html5CommonAttrs attrs $
 273                 H.div ! HA.class_ (attrValue $ "figure-"<>type_)
 274                       ! HA.id (attrValue pos) $ do
 275                         H.table ! HA.class_ "figure-caption" $
 276                                 H.tbody $
 277                                         H.tr $ do
 278                                                 H.td ! HA.class_ "figure-number" $ do
 279                                                         H.a ! HA.href "" $ H.toMarkup type_
 280                                                         ": "
 281                                                 H.td ! HA.class_ "figure-name" $
 282                                                         html5Horizontals $ DTC.unTitle title
 283                         H.div ! HA.class_ "figure-content" $ do
 284                                 html5Verticals verts
 285         {-
 286          Index{..} ->
 287          Artwork{..} ->
 288         -}
 289
 290 html5Reference :: DTC.Reference -> Html
 291 html5Reference DTC.Reference{..} =
 292         H.tr $ do
 293                 H.td ! HA.class_ "reference-key" $
 294                         H.toMarkup id
 295                 H.td ! HA.class_ "reference-content" $
 296                         html5About about
 297
 298 html5About :: DTC.About -> Html
 299 html5About DTC.About{..} =
 300         forM_ titles $ \(DTC.Title title) -> do
 301                 html5Horizontal $ DTC.Q title
 302         {-
 303         authors
 304         editor
 305         date
 306         version
 307         keywords
 308         links
 309         series
 310         includes
 311         -}
 312
 313 html5CommonAttrs :: DTC.CommonAttrs -> Html -> Html
 314 html5CommonAttrs DTC.CommonAttrs{..} =
 315         (case classes of
 316          [] -> \x -> x
 317          _  -> H.AddCustomAttribute "class" (H.Text $ Text.unwords classes)) .
 318         case id of
 319          Nothing -> \x -> x
 320          Just (DTC.Ident i) ->
 321                         H.AddCustomAttribute "id" (H.Text i)
 322
 323 html5Horizontal :: DTC.Horizontal -> Html
 324 html5Horizontal = \case
 325          DTC.BR       -> H.br
 326          DTC.B    hs  -> H.strong $ html5Horizontals hs
 327          DTC.Code hs  -> H.code   $ html5Horizontals hs
 328          DTC.Del  hs  -> H.del    $ html5Horizontals hs
 329          DTC.I    hs  -> H.i      $ html5Horizontals hs
 330          DTC.Note _   -> ""
 331          DTC.Q    hs  -> "« "<>H.i (html5Horizontals hs)<>" »"
 332          DTC.SC   hs  -> html5Horizontals hs
 333          DTC.Sub  hs  -> H.sub $ html5Horizontals hs
 334          DTC.Sup  hs  -> H.sup $ html5Horizontals hs
 335          DTC.U    hs  -> H.span ! HA.class_ "underline" $ html5Horizontals hs
 336          DTC.Eref{..} -> H.a ! HA.class_ "eref" ! HA.href (attrValue href) $ html5Horizontals text
 337          DTC.Iref{..} -> H.a ! HA.class_ "iref" ! HA.href (attrValue to)   $ html5Horizontals text
 338          DTC.Ref{..}  ->
 339                 H.a ! HA.class_ "ref"
 340                     ! HA.href ("#"<>attrValue to) $
 341                 if null text
 342                 then H.toMarkup to
 343                 else html5Horizontals text
 344          DTC.Rref{..} -> H.a ! HA.class_ "rref" ! HA.href (attrValue to)   $ html5Horizontals text
 345          DTC.Plain t  -> H.toMarkup t
 346
 347 html5Horizontals :: [DTC.Horizontal] -> Html
 348 html5Horizontals = mapM_ html5Horizontal
 349
 350 textHorizontal :: DTC.Horizontal -> TL.Text
 351 textHorizontal = \case
 352          DTC.BR       -> "\n"
 353          DTC.B    hs  -> "*"<>textHorizontals hs<>"*"
 354          DTC.Code hs  -> "`"<>textHorizontals hs<>"`"
 355          DTC.Del  hs  -> "-"<>textHorizontals hs<>"-"
 356          DTC.I    hs  -> "/"<>textHorizontals hs<>"/"
 357          DTC.Note _   -> ""
 358          DTC.Q    hs  -> "« "<>textHorizontals hs<>" »"
 359          DTC.SC   hs  -> textHorizontals hs
 360          DTC.Sub  hs  -> textHorizontals hs
 361          DTC.Sup  hs  -> textHorizontals hs
 362          DTC.U    hs  -> "_"<>textHorizontals hs<>"_"
 363          DTC.Eref{..} -> textHorizontals text
 364          DTC.Iref{..} -> textHorizontals text
 365          DTC.Ref{..}  -> textHorizontals text
 366          DTC.Rref{..} -> textHorizontals text
 367          DTC.Plain t  -> TL.fromStrict t
 368
 369 textHorizontals :: [DTC.Horizontal] -> TL.Text
 370 textHorizontals = foldMap textHorizontal