Language/DTC/Write/HTML5.hs

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