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 depth
 234          DTC.ToF{..} -> do
 235                 H.nav ! HA.class_ "tof"
 236                       ! HA.id (attrValue pos) $$
 237                         H.table ! HA.class_ "tof" $$
 238                                 H.tbody $$
 239                                         forM_ (Tree.axis_preceding `Tree.runAxis` z) $
 240                                                 html5ToF $ maybe 0 DTC.unNat depth
 241          DTC.Figure{..} ->
 242                 html5CommonAttrs attrs $
 243                 H.div ! HA.class_ ("figure " <> 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) $$ do
 250                                                                 html5ify type_
 251                                                                 html5PosAncestors $ xmlPosAncestors pos
 252                                                         html5ify $ MsgHTML5_Colon
 253                                                         " "
 254                                                 H.td ! HA.class_ "figure-name" $$
 255                                                         html5ify title
 256                         H.div ! HA.class_ "figure-content" $$ do
 257                                 html5ify blocks
 258          DTC.Index{pos} -> do
 259                 (allTerms,refsByTerm) <- liftStateMarkup $ S.gets $ (Map.! pos) . indexs
 260                 let chars = Index.termsByChar allTerms
 261                 H.div ! HA.class_ "index"
 262                       ! HA.id (attrValue pos) $$ do
 263                         H.nav ! HA.class_ "index-nav" $$ do
 264                                 forM_ (Map.keys chars) $ \char ->
 265                                         H.a ! HA.href ("#"<>(attrValue pos <> "." <> attrValue char)) $$
 266                                                 html5ify char
 267                         H.dl ! HA.class_ "index-chars" $$
 268                                 forM_ (Map.toList chars) $ \(char,terms) -> do
 269                                         H.dt $$
 270                                                 let i = attrValue pos <> "." <> attrValue char in
 271                                                 H.a ! HA.id i
 272                                                     ! HA.href ("#"<>i) $$
 273                                                         html5ify char
 274                                         H.dd $$
 275                                                 H.dl ! HA.class_ "index-term" $$ do
 276                                                 forM_ terms $ \aliases -> do
 277                                                         H.dt $$
 278                                                                 H.ul ! HA.class_ "index-aliases" $$
 279                                                                         forM_ (listToMaybe aliases) $ \term ->
 280                                                                                 H.li ! HA.id (attrValue Index.Ref{term, count=0, section=def}) $$
 281                                                                                         html5ify term
 282                                                         H.dd $$ do
 283                                                                 let refs =
 284                                                                         List.sortBy (compare `on` Index.section) $
 285                                                                         (`foldMap` aliases) $ \words -> fromJust $ do
 286                                                                                 path <- Index.pathFromWords words
 287                                                                                 Strict.maybe Nothing (Just . List.reverse) $
 288                                                                                         TreeMap.lookup path refsByTerm
 289                                                                 sequence_ $
 290                                                                         List.intersperse ", " $
 291                                                                         (<$> refs) $ \ref@Index.Ref{..} ->
 292                                                                                 H.a ! HA.href ("#"<>attrValue ref) $$
 293                                                                                         html5ify $
 294                                                                                                 List.intercalate "." $
 295                                                                                                 List.reverse $
 296                                                                                                 (<$> xmlPosAncestors section) $ \(_n,c) -> show c
 297
 298 instance Html5ify DTC.Words where
 299         html5ify = html5ify . Index.plainifyWords
 300
 301 html5ToC :: Maybe DTC.Nat -> BodyCursor -> Html5
 302 html5ToC depth z =
 303         case Tree.current z of
 304          TreeN DTC.Section{..} _ts -> do
 305                 H.li $$ do
 306                         H.table ! HA.class_ "toc-entry" $$
 307                                 H.tbody $$
 308                                         H.tr $$ do
 309                                                 H.td ! HA.class_ "section-number" $$
 310                                                         html5SectionRef $ xmlPosAncestors pos
 311                                                 H.td ! HA.class_ "section-title" $$
 312                                                         html5ify $
 313                                                                 DTC.unTitle title >>= (`Tree.bindTrees` \case
 314                                                                  TreeN DTC.Iref{} ls -> ls
 315                                                                  TreeN DTC.Note{} _ -> mempty
 316                                                                  h -> pure h)
 317                         when (maybe True (> DTC.Nat 1) depth && not (null sections)) $
 318                                 H.ul $$
 319                                         forM_ sections $
 320                                                 html5ToC (depth >>= DTC.predNat)
 321          _ -> pure ()
 322         where
 323         sections =
 324                 (`Tree.runAxis` z) $
 325                 Tree.axis_child
 326                 `Tree.axis_filter_current` \case
 327                  TreeN DTC.Section{} _ -> True
 328                  _ -> False
 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                 html5PosAncestors as
 459
 460 html5PosAncestors :: [(XmlName,Int)] -> Html5
 461 html5PosAncestors as =
 462         case as of
 463          [(_n,c)] -> do
 464                 html5ify $ show c
 465                 html5ify '.'
 466          _ ->
 467                 html5ify $
 468                         Text.intercalate "." $
 469                         List.reverse $
 470                         Text.pack . show . snd <$> as
 471
 472 textXmlPosAncestors :: [(XmlName,Int)] -> Text
 473 textXmlPosAncestors =
 474         snd . foldr (\(n,c) (nParent,acc) ->
 475                 (n,
 476                         (if Text.null acc
 477                                 then acc
 478                                 else acc <> ".") <>
 479                         Text.pack
 480                          (if n == nParent
 481                                 then show c
 482                                 else show n<>show c)
 483                 )
 484          )
 485          ("","")
 486
 487 -- * Class 'Plainify'
 488 class Plainify a where
 489         plainify :: a -> TL.Text
 490 instance Plainify TL.Text where
 491         plainify = id
 492 instance Plainify Text where
 493         plainify = TL.fromStrict
 494 instance Plainify DTC.Para where
 495         plainify = foldMap plainify
 496 instance Plainify DTC.Lines where
 497         plainify = \case
 498          Tree0 v ->
 499                 case v of
 500                  DTC.BR -> "\n"
 501                  DTC.Plain p -> plainify p
 502          TreeN k ls ->
 503                 case k of
 504                  DTC.B        -> "*"<>plainify ls<>"*"
 505                  DTC.Code     -> "`"<>plainify ls<>"`"
 506                  DTC.Del      -> "-"<>plainify ls<>"-"
 507                  DTC.I        -> "/"<>plainify ls<>"/"
 508                  DTC.Note     -> ""
 509                  DTC.Q        -> "« "<>plainify ls<>" »"
 510                  DTC.SC       -> plainify ls
 511                  DTC.Sub      -> plainify ls
 512                  DTC.Sup      -> plainify ls
 513                  DTC.U        -> "_"<>plainify ls<>"_"
 514                  DTC.Eref{..} -> plainify ls
 515                  DTC.Iref{..} -> plainify ls
 516                  DTC.Ref{..}  -> plainify ls
 517                  DTC.Rref{..} -> plainify ls
 518 instance Plainify DTC.Title where
 519         plainify (DTC.Title t) = plainify t
 520
 521 instance AttrValue XmlPos where
 522         attrValue = attrValue . textXmlPosAncestors . xmlPosAncestors
 523
 524 -- * Type 'MsgHtml5'
 525 data MsgHtml5
 526  =   MsgHTML5_Table_of_Contents
 527  |   MsgHTML5_Colon
 528  |   MsgHTML5_QuoteOpen
 529  |   MsgHTML5_QuoteClose
 530  deriving (Show)
 531 instance Html5ify MsgHtml5 where
 532         html5ify msg = do
 533                 loc <- liftStateMarkup $ S.gets localize
 534                 loc msg
 535 instance LocalizeIn FR Html5 MsgHtml5 where
 536         localizeIn _ = \case
 537          MsgHTML5_Table_of_Contents -> "Sommaire"
 538          MsgHTML5_Colon -> " :"
 539          MsgHTML5_QuoteOpen -> "« "
 540          MsgHTML5_QuoteClose -> " »"
 541 instance LocalizeIn EN Html5 MsgHtml5 where
 542         localizeIn _ = \case
 543          MsgHTML5_Table_of_Contents -> "Summary"
 544          MsgHTML5_Colon -> ":"
 545          MsgHTML5_QuoteOpen  -> "“"
 546          MsgHTML5_QuoteClose -> "”"