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