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