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 module Language.DTC.Write.HTML5 where
  11
  12 -- import Control.Monad.Trans.Class (MonadTrans(..))
  13 -- import Data.Functor.Identity (Identity(..))
  14 -- import Data.Sequence (Seq)
  15 -- import Data.Set (Set)
  16 -- import Data.Traversable (Traversable(..))
  17 -- import qualified Data.Sequence as Seq
  18 -- import qualified Data.TreeSeq.Strict as Tree
  19 import Prelude (undefined)
  20 import Control.Applicative (Applicative(..))
  21 import Control.Monad (Monad(..), sequence_, forM_, mapM_, when, (>=>))
  22 import Data.Bool
  23 import Data.Char (Char)
  24 import Data.Default.Class (Default(..))
  25 import Data.Eq (Eq(..))
  26 import Data.Foldable (Foldable(..), concat, any)
  27 import Data.Function (($), (.), const, flip, on)
  28 import Data.Functor (Functor(..), (<$>))
  29 import Data.Functor.Compose (Compose(..))
  30 import Data.Int (Int)
  31 import Data.Map.Strict (Map)
  32 import Data.Maybe (Maybe(..), mapMaybe, fromMaybe, fromJust)
  33 import Data.Monoid (Monoid(..))
  34 import Data.Ord (Ord(..))
  35 import Data.Semigroup (Semigroup(..))
  36 import Data.String (String)
  37 import Data.Text (Text)
  38 import Data.TreeSeq.Strict (Tree(..), Trees)
  39 import Data.Tuple (snd)
  40 import Prelude (Num(..))
  41 import System.FilePath (FilePath)
  42 import Text.Blaze ((!))
  43 import Text.Blaze.Html (Html)
  44 import Text.Show (Show(..))
  45 import qualified Control.Monad.Trans.State as S
  46 import qualified Data.List as List
  47 import qualified Data.Map.Strict as Map
  48 import qualified Data.Set as Set
  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 import qualified Data.TreeMap.Strict as TreeMap
  56 import qualified Data.Strict.Maybe as Strict
  57
  58 import Text.Blaze.Utils
  59 import Data.Locale hiding (localize, Index)
  60 import qualified Data.Locale as Locale
  61
  62 import Language.DTC.Document (Document)
  63 import Language.DTC.Write.XML ()
  64 import Language.XML (XmlName(..), XmlPos(..))
  65 import qualified Language.DTC.Document as DTC
  66 import qualified Language.DTC.Index as Index
  67 -- import Debug.Trace (trace)
  68
  69 (<&>) :: Functor f => f a -> (a -> b) -> f b
  70 (<&>) = flip (<$>)
  71 infixl 4 <&>
  72
  73 -- * Type 'Html5'
  74 type Html5 = StateMarkup State ()
  75
  76 -- ** Type 'State'
  77 data State
  78  =   State
  79  { styles   :: Map FilePath CSS
  80  , scripts  :: Map FilePath Script
  81  , localize :: MsgHtml5 -> Html5
  82  , indexs   :: Map XmlPos (DTC.Terms, Index.Refs)
  83  }
  84 state :: State
  85 state = State
  86  { styles   = mempty
  87  , scripts  = mempty
  88  , localize = html5ify . show
  89  , indexs   = mempty
  90  }
  91 type CSS = Text
  92 type Script = Text
  93
  94 -- ** Type 'Keys'
  95 data Keys
  96  = Keys
  97  { keys_index :: Map XmlPos DTC.Terms
  98  } deriving (Show)
  99
 100 keys :: Trees DTC.BodyKey DTC.BodyValue -> Keys
 101 keys body = foldl' flt (Keys mempty) (Compose body)
 102         where
 103         flt acc = \case
 104          DTC.Index{..} -> acc{keys_index =
 105                 Map.insert pos terms $ keys_index acc}
 106          _ -> acc
 107
 108 -- ** Class 'Html5ify'
 109 class Html5ify a where
 110         html5ify :: a -> Html5
 111 instance Html5ify Char where
 112         html5ify = html5ify . H.toMarkup
 113 instance Html5ify Text where
 114         html5ify = html5ify . H.toMarkup
 115 instance Html5ify String where
 116         html5ify = html5ify . H.toMarkup
 117 instance Html5ify H.Markup where
 118         html5ify = Compose . return
 119 instance Html5ify DTC.Title where
 120         html5ify (DTC.Title t) = html5ify t
 121 instance Html5ify DTC.Ident where
 122         html5ify (DTC.Ident i) = html5ify i
 123
 124 html5Document ::
 125  Localize ls Html5 MsgHtml5 =>
 126  Locales ls =>
 127  LocaleIn ls -> Document -> Html
 128 html5Document locale DTC.Document{..} = do
 129         let Keys{..} = keys body
 130         let (body',indexs) =
 131                 case foldMap Index.refsOfTerms keys_index of
 132                  refs | null refs -> (body, mempty)
 133                       | otherwise ->
 134                         (<$> S.runState
 135                                  (Index.indexify body)
 136                                  Index.state
 137                                          { Index.state_refs = refs
 138                                          }) $ \Index.State{state_refs} ->
 139                                 (<$> keys_index) $ \terms ->
 140                                         (terms,) $
 141                                         TreeMap.intersection const state_refs $
 142                                         Index.refsOfTerms terms
 143         let (html5Body, State{styles,scripts}) =
 144                 runStateMarkup state{indexs} $ do
 145                         liftStateMarkup $ S.modify $ \s -> s{localize = Locale.localize locale}
 146                         html5ify body'
 147
 148         H.docType
 149         H.html ! HA.lang (attrValue $ countryCode locale) $ do
 150                 H.head $ do
 151                         H.meta ! HA.httpEquiv "Content-Type"
 152                                ! HA.content "text/html; charset=UTF-8"
 153                         whenSome (DTC.titles $ DTC.about (head :: DTC.Head)) $ \ts ->
 154                                 H.title $
 155                                         H.toMarkup $ plainify $ List.head ts
 156                         forM_ (DTC.links $ DTC.about (head :: DTC.Head)) $ \DTC.Link{rel, href} ->
 157                                 H.link ! HA.rel (attrValue rel)
 158                                        ! HA.href (attrValue href)
 159                         H.meta ! HA.name "generator"
 160                                ! HA.content "tct"
 161                         let chapters =
 162                                 (`mapMaybe` toList body) $ \case
 163                                  TreeN k@DTC.Section{} _ -> Just k
 164                                  _ -> Nothing
 165                         forM_ chapters $ \DTC.Section{..} ->
 166                                 H.link ! HA.rel "Chapter"
 167                                        ! HA.title (attrValue $ plainify title)
 168                                        ! HA.href ("#"<>attrValue pos)
 169                         H.link ! HA.rel "stylesheet"
 170                                ! HA.type_ "text/css"
 171                                ! HA.href "style/dtc-html5.css"
 172                         forM_ styles $ \style ->
 173                                 H.style ! HA.type_ "text/css" $
 174                                         H.toMarkup style
 175                         forM_ scripts $ \script ->
 176                                 H.script ! HA.type_ "application/javascript" $
 177                                         H.toMarkup script
 178                 H.body
 179                         html5Body
 180
 181 -- * Type 'BodyCursor'
 182 -- | Cursor to navigate within a 'DTC.Body' according to many axis (like in XSLT).
 183 type BodyCursor = Tree.Zipper DTC.BodyKey DTC.BodyValue
 184 instance Html5ify DTC.Body where
 185         html5ify body =
 186                 forM_ (Tree.zippers body >>= Tree.axis_repeat Tree.axis_following_sibling_nearest) $
 187                         html5ify
 188
 189 instance Html5ify BodyCursor where
 190         html5ify z =
 191                 case Tree.current z of
 192                  TreeN k _ts -> html5BodyKey z k
 193                  Tree0 v -> html5BodyValue z v
 194
 195 html5BodyKey :: BodyCursor -> DTC.BodyKey -> Html5
 196 html5BodyKey z = \case
 197          DTC.Section{..} ->
 198                 H.section ! HA.class_ "section"
 199                           ! HA.id (attrValue pos) $$ do
 200                         html5CommonAttrs attrs $
 201                                 H.table ! HA.class_ "section-header" $$
 202                                         H.tbody $$
 203                                                 H.tr $$ do
 204                                                         H.td ! HA.class_ "section-number" $$ do
 205                                                                 html5SectionNumber $
 206                                                                         xmlPosAncestors pos
 207                                                         H.td ! HA.class_ "section-title" $$ do
 208                                                                 (case List.length $ xmlPosAncestors pos of
 209                                                                  0 -> H.h1
 210                                                                  1 -> H.h2
 211                                                                  2 -> H.h3
 212                                                                  3 -> H.h4
 213                                                                  4 -> H.h5
 214                                                                  5 -> H.h6
 215                                                                  _ -> H.h6) $$
 216                                                                         html5ify title
 217                         forM_ (Tree.axis_child z) $
 218                                 html5ify
 219 html5BodyValue :: BodyCursor -> DTC.BodyValue -> Html5
 220 html5BodyValue z = \case
 221          DTC.Vertical v -> do
 222                 html5ify v
 223          DTC.ToC{..} -> do
 224                 H.nav ! HA.class_ "toc"
 225                       ! HA.id (attrValue pos) $$ do
 226                         H.span ! HA.class_ "toc-name" $$
 227                                 H.a ! HA.href (attrValue pos) $$
 228                                         html5ify MsgHTML5_Table_of_Contents
 229                         H.ul $$
 230                                 forM_ (Tree.axis_following_sibling z) $
 231                                         html5ToC d
 232                 where d = case depth of { Just (DTC.Nat n) -> n; _ -> 0 }
 233          DTC.ToF{..} -> do
 234                 H.nav ! HA.class_ "tof"
 235                       ! HA.id (attrValue pos) $$
 236                         H.table ! HA.class_ "tof" $$
 237                                 H.tbody $$
 238                                         forM_ (Tree.axis_preceding z) $
 239                                                 html5ToF d
 240                 where d = case depth of { Just (DTC.Nat n) -> n; _ -> 0 }
 241          DTC.Figure{..} ->
 242                 html5CommonAttrs attrs $
 243                 H.div ! HA.class_ (attrValue $ "figure-"<>type_)
 244                       ! HA.id (attrValue pos) $$ do
 245                         H.table ! HA.class_ "figure-caption" $$
 246                                 H.tbody $$
 247                                         H.tr $$ do
 248                                                 H.td ! HA.class_ "figure-number" $$ do
 249                                                         H.a ! HA.href ("#"<>attrValue pos) $$
 250                                                                 html5ify type_
 251                                                         ": "
 252                                                 H.td ! HA.class_ "figure-name" $$
 253                                                         html5ify title
 254                         H.div ! HA.class_ "figure-content" $$ do
 255                                 html5ify verts
 256          DTC.Index{pos} -> do
 257                 (allTerms,refsByTerm) <- liftStateMarkup $ S.gets $ (Map.! pos) . indexs
 258                 let chars = Index.termsByChar allTerms
 259                 H.div ! HA.class_ "index"
 260                       ! HA.id (attrValue pos) $$ do
 261                         H.nav ! HA.class_ "index-nav-chars" $$ do
 262                                 forM_ (Map.keys chars) $ \char ->
 263                                         H.a ! HA.href ("#"<>(attrValue pos <> "." <> attrValue char)) $$
 264                                                 html5ify char
 265                         H.dl $$
 266                                 forM_ (Map.toList chars) $ \(char,terms) -> do
 267                                         H.dt $$
 268                                                 let i = attrValue pos <> "." <> attrValue char in
 269                                                 H.a ! HA.id i
 270                                                     ! HA.href ("#"<>i) $$
 271                                                         html5ify char
 272                                         H.dd $$
 273                                                 H.dl ! HA.class_ "index-char-refs" $$ do
 274                                                 forM_ terms $ \aliases -> do
 275                                                         H.dt $$
 276                                                                 forM_ aliases $ \term ->
 277                                                                         H.ul $$
 278                                                                                 H.li ! HA.id (attrValue Index.Ref{term, count=0, section=def}) $$
 279                                                                                         html5ify term
 280                                                         H.dd $$ do
 281                                                                 let refs =
 282                                                                         List.sortBy
 283                                                                          (compare `on` Index.section) $
 284                                                                         (`foldMap` aliases) $ \words -> fromJust $ do
 285                                                                                 path <- Index.pathFromWords words
 286                                                                                 Strict.maybe Nothing Just $
 287                                                                                         TreeMap.lookup path refsByTerm
 288                                                                 sequence_ $
 289                                                                         List.intersperse ", " $
 290                                                                         (<$> refs) $ \ref@Index.Ref{..} ->
 291                                                                                 H.a ! HA.href ("#"<>attrValue ref) $$
 292                                                                                         html5ify $
 293                                                                                                 List.intercalate "." $
 294                                                                                                 List.reverse $
 295                                                                                                 (<$> xmlPosAncestors section) $ \(_n,c) -> show c
 296
 297 instance Html5ify DTC.Words where
 298         html5ify = html5ify . Index.plainifyWords
 299
 300 html5ToC :: Int -> BodyCursor -> Html5
 301 html5ToC depth z =
 302         case Tree.current z of
 303          TreeN DTC.Section{..} _ts -> do
 304                 H.li $$ do
 305                         H.table ! HA.class_ "toc-entry" $$
 306                                 H.tbody $$
 307                                         H.tr $$ do
 308                                                 H.td ! HA.class_ "section-number" $$
 309                                                         html5SectionRef $ xmlPosAncestors pos
 310                                                 H.td ! HA.class_ "section-title" $$
 311                                                         html5ify $
 312                                                                 DTC.unTitle title >>= \case
 313                                                                  DTC.Iref{..} -> text
 314                                                                  DTC.Note{} -> []
 315                                                                  h -> [h]
 316                         let sections =
 317                                 ($ z) $ Tree.axis_child
 318                                 `Tree.axis_filter_current` \case
 319                                  TreeN DTC.Section{} _ -> True
 320                                  _ -> False
 321                         when (depth > 0 && not (null sections)) $
 322                                 H.ul $$
 323                                         forM_ sections $
 324                                                 html5ToC (depth - 1)
 325          _ -> pure ()
 326
 327 html5ToF :: Int -> BodyCursor -> Html5
 328 html5ToF depth z =
 329         case Tree.current z of
 330          Tree0 v ->
 331                 case v of
 332                  DTC.Figure{..} ->
 333                         H.tr $$ do
 334                                 H.td ! HA.class_ "figure-number" $$
 335                                         H.a ! HA.href ("#"<>attrValue pos) $$
 336                                                 html5ify type_
 337                                 H.td ! HA.class_ "figure-name" $$
 338                                         html5ify title
 339                  _ -> pure ()
 340          _ -> pure ()
 341
 342 instance Html5ify [DTC.Vertical] where
 343         html5ify = mapM_ html5ify
 344 instance Html5ify DTC.Vertical where
 345         html5ify = \case
 346          DTC.Para{..} ->
 347                 html5CommonAttrs attrs $
 348                 H.p ! HA.class_ "para"
 349                     ! HA.id (attrValue pos) $$ do
 350                         html5ify horis
 351          DTC.OL{..} ->
 352                 html5CommonAttrs attrs $
 353                 H.ol ! HA.class_ "ol"
 354                      ! HA.id (attrValue pos) $$ do
 355                         forM_ items $ \item ->
 356                                 H.li $$ html5ify item
 357          DTC.UL{..} ->
 358                 html5CommonAttrs attrs $
 359                 H.ul ! HA.class_ "ul"
 360                      ! HA.id (attrValue pos) $$ do
 361                         forM_ items $ \item ->
 362                                 H.li $$ html5ify item
 363          DTC.RL{..} ->
 364                 html5CommonAttrs attrs $
 365                 H.div ! HA.class_ "rl"
 366                       ! HA.id (attrValue pos) $$ do
 367                         H.table $$
 368                                 forM_ refs html5ify
 369          DTC.Comment t ->
 370                 html5ify $ H.Comment (H.Text t) ()
 371 instance Html5ify DTC.Horizontal where
 372         html5ify = \case
 373          DTC.BR       -> html5ify H.br
 374          DTC.B    hs  -> H.strong $$ html5ify hs
 375          DTC.Code hs  -> H.code   $$ html5ify hs
 376          DTC.Del  hs  -> H.del    $$ html5ify hs
 377          DTC.I    hs  -> H.i      $$ html5ify hs
 378          DTC.Note _   -> ""
 379          DTC.Q    hs  ->
 380                 H.span ! HA.class_ "q" $$ do
 381                         "« "::Html5
 382                         H.i $$ html5ify hs
 383                         " »"
 384          DTC.SC   hs  -> H.span ! HA.class_ "smallcaps" $$ html5ify hs
 385          DTC.Sub  hs  -> H.sub $$ html5ify hs
 386          DTC.Sup  hs  -> H.sup $$ html5ify hs
 387          DTC.U    hs  -> H.span ! HA.class_ "underline" $$ html5ify hs
 388          DTC.Eref{..} ->
 389                 H.a ! HA.class_ "eref"
 390                     ! HA.href (attrValue href) $$
 391                         html5ify text
 392          DTC.Iref{..} ->
 393                 H.span ! HA.class_ "iref"
 394                        ! HA.id (attrValue Index.Ref{term, count, section=def}) $$
 395                         html5ify text
 396          DTC.Ref{..}  ->
 397                 H.a ! HA.class_ "ref"
 398                     ! HA.href ("#"<>attrValue to) $$
 399                 if null text
 400                 then html5ify to
 401                 else html5ify text
 402          DTC.Rref{..} ->
 403                 H.a ! HA.class_ "rref"
 404                     ! HA.href (attrValue to) $$
 405                         html5ify text
 406          DTC.Plain t  -> html5ify t
 407 instance AttrValue Index.Ref where
 408         attrValue Index.Ref{..} =
 409                 "iref" <> "." <> attrValue (Index.plainifyWords term) <>
 410                 if count > 0
 411                 then "." <> attrValue count
 412                 else ""
 413 instance Html5ify [DTC.Horizontal] where
 414         html5ify = mapM_ html5ify
 415 instance Html5ify DTC.About where
 416         html5ify DTC.About{..} =
 417                 forM_ titles $ \(DTC.Title title) ->
 418                         html5ify $ DTC.Q title
 419 instance Html5ify DTC.Reference where
 420         html5ify DTC.Reference{..} =
 421                 H.tr $$ do
 422                         H.td ! HA.class_ "reference-key" $$
 423                                 html5ify id
 424                         H.td ! HA.class_ "reference-content" $$
 425                                 html5ify about
 426
 427 html5CommonAttrs :: DTC.CommonAttrs -> Html5 -> Html5
 428 html5CommonAttrs DTC.CommonAttrs{..} =
 429         Compose . (addClass . addId <$>) . getCompose
 430         where
 431         addClass =
 432                 case classes of
 433                  [] -> \x -> x
 434                  _  -> H.AddCustomAttribute "class" (H.Text $ Text.unwords classes)
 435         addId =
 436                 case id of
 437                  Nothing -> \x -> x
 438                  Just (DTC.Ident i) ->
 439                         H.AddCustomAttribute "id" (H.Text i)
 440
 441 html5SectionNumber :: [(XmlName,Int)] -> Html5
 442 html5SectionNumber = go [] . List.reverse
 443         where
 444         go :: [(XmlName,Int)] -> [(XmlName,Int)] -> Html5
 445         go _rs [] = pure ()
 446         go rs (a@(_n,cnt):as) = do
 447                 H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors (a:rs)) $$
 448                         html5ify $ show cnt
 449                 html5ify '.'
 450                 go (a:rs) as
 451
 452 html5SectionRef :: [(XmlName,Int)] -> Html5
 453 html5SectionRef as =
 454         H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors as) $$
 455                 case as of
 456                  [(_n,c)] -> do
 457                         html5ify $ show c
 458                         html5ify '.'
 459                  _ ->
 460                         html5ify $
 461                                 Text.intercalate "." $
 462                                 Text.pack . show . snd <$> as
 463
 464 textXmlPosAncestors :: [(XmlName,Int)] -> Text
 465 textXmlPosAncestors =
 466         snd . foldr (\(n,c) (nParent,acc) ->
 467                 (n,
 468                         (if Text.null acc
 469                                 then acc
 470                                 else acc <> ".") <>
 471                         Text.pack
 472                          (if n == nParent
 473                                 then show c
 474                                 else show n<>show c)
 475                 )
 476          )
 477          ("","")
 478
 479 -- * Class 'Plainify'
 480 class Plainify a where
 481         plainify :: a -> TL.Text
 482 instance Plainify DTC.Horizontal where
 483         plainify = \case
 484          DTC.BR       -> "\n"
 485          DTC.B    hs  -> "*"<>plainify hs<>"*"
 486          DTC.Code hs  -> "`"<>plainify hs<>"`"
 487          DTC.Del  hs  -> "-"<>plainify hs<>"-"
 488          DTC.I    hs  -> "/"<>plainify hs<>"/"
 489          DTC.Note _   -> ""
 490          DTC.Q    hs  -> "« "<>plainify hs<>" »"
 491          DTC.SC   hs  -> plainify hs
 492          DTC.Sub  hs  -> plainify hs
 493          DTC.Sup  hs  -> plainify hs
 494          DTC.U    hs  -> "_"<>plainify hs<>"_"
 495          DTC.Eref{..} -> plainify text
 496          DTC.Iref{..} -> plainify text
 497          DTC.Ref{..}  -> plainify text
 498          DTC.Rref{..} -> plainify text
 499          DTC.Plain t  -> TL.fromStrict t
 500 instance Plainify [DTC.Horizontal] where
 501         plainify = foldMap plainify
 502 instance Plainify DTC.Title where
 503         plainify (DTC.Title t) = plainify t
 504
 505 instance AttrValue XmlPos where
 506         attrValue = attrValue . textXmlPosAncestors . xmlPosAncestors
 507
 508 -- * Type 'MsgHtml5'
 509 data MsgHtml5
 510  =   MsgHTML5_Table_of_Contents
 511  deriving (Show)
 512 instance Html5ify MsgHtml5 where
 513         html5ify msg = do
 514                 loc <- liftStateMarkup $ S.gets localize
 515                 loc msg
 516 instance LocalizeIn FR Html5 MsgHtml5 where
 517         localizeIn _ = \case
 518          MsgHTML5_Table_of_Contents -> "Sommaire"
 519 instance LocalizeIn EN Html5 MsgHtml5 where
 520         localizeIn _ = \case
 521          MsgHTML5_Table_of_Contents -> "Summary"