Language/DTC/Write/HTML5.hs

   1 {-# LANGUAGE DisambiguateRecordFields #-}
   2 {-# LANGUAGE DuplicateRecordFields #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5 {-# LANGUAGE ViewPatterns #-}
   6 {-# OPTIONS_GHC -fno-warn-orphans #-}
   7 -- | Render a DTC source file in HTML5.
   8 module Language.DTC.Write.HTML5 where
   9
  10 import Control.Monad (forM_, mapM_)
  11 -- import Data.Bool
  12 -- import Data.Eq (Eq(..))
  13 import Data.Foldable (Foldable(..))
  14 import Data.Function (($), (.))
  15 import Data.Functor ((<$>))
  16 import Data.Maybe (Maybe(..))
  17 import Data.Semigroup (Semigroup(..))
  18 import Text.Blaze ((!))
  19 import Text.Blaze.Html (Html)
  20 import qualified Data.List as L
  21 import qualified Data.Text as Text
  22 import qualified Data.Text.Lazy as TL
  23 import qualified Text.Blaze.Html5 as H
  24 import qualified Text.Blaze.Html5.Attributes  as HA
  25 import qualified Text.Blaze.Internal as H
  26
  27 import Text.Blaze.Utils
  28
  29 import Language.DTC.Document (Document)
  30 import Language.DTC.Write.XML ()
  31 import qualified Language.DTC.Document as DTC
  32
  33 instance H.ToMarkup DTC.Ident where
  34         toMarkup (DTC.Ident i) = H.toMarkup i
  35
  36 html5Document :: Document -> Html
  37 html5Document DTC.Document{..} = do
  38         H.docType
  39         H.html $ do
  40                 H.head $ do
  41                         H.meta ! HA.httpEquiv "Content-Type"
  42                                ! HA.content "text/html; charset=UTF-8"
  43                         whenSome (DTC.titles $ DTC.about (head :: DTC.Head)) $ \ts ->
  44                                 let t = textHorizontals $ L.head $ (DTC.unTitle <$> ts) <> [[DTC.Plain ""]] in
  45                                 H.title $ H.toMarkup t
  46                         -- link ! rel "Chapter" ! title "SomeTitle">
  47                         H.link ! HA.rel "stylesheet"
  48                                ! HA.type_ "text/css"
  49                                ! HA.href "style/dtc-html5.css"
  50                 H.body $
  51                         forM_ body html5Body
  52
  53 html5Body :: DTC.Body -> Html
  54 html5Body = \case
  55          DTC.Section{..} ->
  56                 html5CommonAttrs attrs $
  57                 H.section $ do
  58                         H.table ! HA.class_ "section-header" $
  59                                 H.tbody $
  60                                         H.tr $ do
  61                                                 H.td ! HA.class_ "section-number" $
  62                                                         "N.N.N"
  63                                                 H.td ! HA.class_ "section-title" $
  64                                                         html5Horizontals $ DTC.unTitle title
  65                         forM_ body html5Body
  66                 {- aliases :: [Alias]
  67                 -}
  68          DTC.Verticals vs -> html5Verticals vs
  69
  70 html5Verticals :: [DTC.Vertical] -> Html
  71 html5Verticals = foldMap html5Vertical
  72
  73 html5Vertical :: DTC.Vertical -> Html
  74 html5Vertical = \case
  75          DTC.Para{..} ->
  76                 html5CommonAttrs attrs $
  77                 H.div ! HA.class_ "para" $
  78                         html5Horizontals horis
  79          DTC.OL{..} ->
  80                 html5CommonAttrs attrs $
  81                 H.ol ! HA.class_ "ol" $
  82                         forM_ items $ \item ->
  83                                 H.li $ html5Verticals item
  84          DTC.UL{..} ->
  85                 html5CommonAttrs attrs $
  86                 H.ul ! HA.class_ "ul" $
  87                         forM_ items $ \item ->
  88                                 H.li $ html5Verticals item
  89          DTC.RL{..} ->
  90                 html5CommonAttrs attrs $
  91                 H.div ! HA.class_ "rl" $
  92                         H.table $
  93                                 forM_ refs html5Reference
  94          DTC.Comment t ->
  95                 H.Comment (H.Text t) ()
  96          DTC.Figure{..} ->
  97                 html5CommonAttrs attrs $
  98                 H.div ! HA.class_ (attrValue $ "figure-"<>type_) $ do
  99                         H.table ! HA.class_ "figure-caption" $
 100                                 H.tbody $
 101                                         H.tr $ do
 102                                                 H.td ! HA.class_ "figure-number" $ do
 103                                                         H.a ! HA.href "" $ H.toMarkup type_
 104                                                         ": "
 105                                                 H.td ! HA.class_ "figure-name" $
 106                                                         html5Horizontals $ DTC.unTitle title
 107                         H.div ! HA.class_ "figure-content" $ do
 108                                 html5Verticals verts
 109          DTC.ToC{..} ->
 110                 H.nav ! HA.class_ "toc" $ ""
 111          DTC.ToF{..} ->
 112                 H.nav ! HA.class_ "tof" $ ""
 113         {-
 114          Index{..} ->
 115          Artwork{..} ->
 116         -}
 117
 118 html5Reference :: DTC.Reference -> Html
 119 html5Reference DTC.Reference{..} =
 120         H.tr $ do
 121                 H.td ! HA.class_ "reference-key" $
 122                         H.toMarkup id
 123                 H.td ! HA.class_ "reference-content" $
 124                         html5About about
 125
 126 html5About :: DTC.About -> Html
 127 html5About DTC.About{..} =
 128         forM_ titles $ \(DTC.Title title) -> do
 129                 html5Horizontal $ DTC.Q title
 130         {-
 131         authors
 132         editor
 133         date
 134         version
 135         keywords
 136         links
 137         series
 138         includes
 139         -}
 140
 141 html5CommonAttrs :: DTC.CommonAttrs -> Html -> Html
 142 html5CommonAttrs DTC.CommonAttrs{..} =
 143         (case classes of
 144          [] -> \x -> x
 145          _  -> H.AddCustomAttribute "class" (H.Text $ Text.unwords classes)) .
 146         case id of
 147          Nothing -> \x -> x
 148          Just (DTC.Ident i) ->
 149                         H.AddCustomAttribute "id" (H.Text i)
 150
 151 html5Horizontal :: DTC.Horizontal -> Html
 152 html5Horizontal = \case
 153          DTC.BR       -> H.br
 154          DTC.B    hs  -> H.strong $ html5Horizontals hs
 155          DTC.Code hs  -> H.code   $ html5Horizontals hs
 156          DTC.Del  hs  -> H.del    $ html5Horizontals hs
 157          DTC.I    hs  -> H.i      $ html5Horizontals hs
 158          DTC.Note _   -> ""
 159          DTC.Q    hs  -> "« "<>H.i (html5Horizontals hs)<>" »"
 160          DTC.SC   hs  -> html5Horizontals hs
 161          DTC.Sub  hs  -> H.sub $ html5Horizontals hs
 162          DTC.Sup  hs  -> H.sup $ html5Horizontals hs
 163          DTC.U    hs  -> H.span ! HA.class_ "underline" $ html5Horizontals hs
 164          DTC.Eref{..} -> H.a ! HA.class_ "eref" ! HA.href (attrValue href) $ html5Horizontals text
 165          DTC.Iref{..} -> H.a ! HA.class_ "iref" ! HA.href (attrValue to)   $ html5Horizontals text
 166          DTC.Ref{..}  -> H.a ! HA.class_ "ref"  ! HA.href (attrValue to)   $ html5Horizontals text
 167          DTC.Rref{..} -> H.a ! HA.class_ "rref" ! HA.href (attrValue to)   $ html5Horizontals text
 168          DTC.Plain t  -> H.toMarkup t
 169
 170 html5Horizontals :: [DTC.Horizontal] -> Html
 171 html5Horizontals = mapM_ html5Horizontal
 172
 173 textHorizontal :: DTC.Horizontal -> TL.Text
 174 textHorizontal = \case
 175          DTC.BR       -> "\n"
 176          DTC.B    hs  -> "*"<>textHorizontals hs<>"*"
 177          DTC.Code hs  -> "`"<>textHorizontals hs<>"`"
 178          DTC.Del  hs  -> "-"<>textHorizontals hs<>"-"
 179          DTC.I    hs  -> "/"<>textHorizontals hs<>"/"
 180          DTC.Note _   -> ""
 181          DTC.Q    hs  -> "« "<>textHorizontals hs<>" »"
 182          DTC.SC   hs  -> textHorizontals hs
 183          DTC.Sub  hs  -> textHorizontals hs
 184          DTC.Sup  hs  -> textHorizontals hs
 185          DTC.U    hs  -> "_"<>textHorizontals hs<>"_"
 186          DTC.Eref{..} -> textHorizontals text
 187          DTC.Iref{..} -> textHorizontals text
 188          DTC.Ref{..}  -> textHorizontals text
 189          DTC.Rref{..} -> textHorizontals text
 190          DTC.Plain t  -> TL.fromStrict t
 191
 192 textHorizontals :: [DTC.Horizontal] -> TL.Text
 193 textHorizontals = foldMap textHorizontal