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.Monad (Monad(..), sequence_, forM_, mapM_, when, (>=>))
  21 import Data.Bool
  22 import Data.Char (Char)
  23 import Data.Default.Class (Default(..))
  24 import Data.Eq (Eq(..))
  25 import Data.Foldable (Foldable(..), concat, any)
  26 import Data.Function (($), (.), const, flip, on)
  27 import Data.Functor (Functor(..), (<$>))
  28 import Data.Functor.Compose (Compose(..))
  29 import Data.Int (Int)
  30 import Data.Map.Strict (Map)
  31 import Data.Maybe (Maybe(..), mapMaybe)
  32 import Data.Monoid (Monoid(..))
  33 import Data.Ord (Ord(..))
  34 import Data.Semigroup (Semigroup(..))
  35 import Data.String (String)
  36 import Data.Text (Text)
  37 import Data.TreeSeq.Strict (Tree(..), Trees)
  38 import Data.Tuple (snd)
  39 import Prelude (Num(..))
  40 import System.FilePath (FilePath)
  41 import Text.Blaze ((!))
  42 import Text.Blaze.Html (Html)
  43 import Text.Show (Show(..))
  44 import qualified Control.Monad.Trans.State as S
  45 import qualified Data.List as List
  46 import qualified Data.Map.Strict as Map
  47 import qualified Data.Set as Set
  48 import qualified Data.Text as Text
  49 import qualified Data.Text.Lazy as TL
  50 import qualified Data.TreeSeq.Strict.Zipper as Tree
  51 import qualified Text.Blaze.Html5 as H
  52 import qualified Text.Blaze.Html5.Attributes  as HA
  53 import qualified Text.Blaze.Internal as H
  54
  55 import Text.Blaze.Utils
  56 import Data.Locale hiding (localize, Index)
  57 import qualified Data.Locale as Locale
  58
  59 import Language.DTC.Document (Document)
  60 import Language.DTC.Write.XML ()
  61 import Language.XML (XmlName(..), XmlPos(..))
  62 import qualified Language.DTC.Document as DTC
  63 import qualified Language.DTC.Index as Index
  64 -- import Debug.Trace (trace)
  65
  66 (<&>) :: Functor f => f a -> (a -> b) -> f b
  67 (<&>) = flip (<$>)
  68 infixl 4 <&>
  69
  70 -- * Type 'Html5'
  71 type Html5 = StateMarkup State ()
  72
  73 -- ** Type 'State'
  74 data State
  75  =   State
  76  { styles   :: Map FilePath CSS
  77  , scripts  :: Map FilePath Script
  78  , localize :: MsgHtml5 -> Html5
  79  , indexs   :: Map XmlPos ( [[Index.Term]]
  80                           , Map Index.Term [Index.Ref] )
  81  }
  82 state :: State
  83 state = State
  84  { styles   = mempty
  85  , scripts  = mempty
  86  , localize = html5ify . show
  87  , indexs   = mempty
  88  }
  89 type CSS = Text
  90 type Script = Text
  91
  92 -- ** Type 'Keys'
  93 data Keys
  94  = Keys
  95  { keys_index :: Map XmlPos [[Index.Term]]
  96  } deriving (Show)
  97
  98 keys :: Trees DTC.BodyKey DTC.BodyValue -> Keys
  99 keys body = foldl' flt (Keys mempty) (Compose body)
 100         where
 101         flt acc = \case
 102          DTC.Index{..} -> acc{keys_index =
 103                 Map.insert pos terms $ keys_index acc}
 104          _ -> acc
 105
 106 -- ** Class 'Html5ify'
 107 class Html5ify a where
 108         html5ify :: a -> Html5
 109 instance Html5ify Char where
 110         html5ify = html5ify . H.toMarkup
 111 instance Html5ify Text where
 112         html5ify = html5ify . H.toMarkup
 113 instance Html5ify String where
 114         html5ify = html5ify . H.toMarkup
 115 instance Html5ify H.Markup where
 116         html5ify = Compose . return
 117 instance Html5ify DTC.Title where
 118         html5ify (DTC.Title t) = html5ify t
 119 instance Html5ify DTC.Ident where
 120         html5ify (DTC.Ident i) = html5ify i
 121
 122 html5Document ::
 123  Localize ls Html5 MsgHtml5 =>
 124  Locales ls =>
 125  LocaleIn ls -> Document -> Html
 126 html5Document locale DTC.Document{..} = do
 127         let Keys{..} = keys body
 128         let (body',indexs) =
 129                 if null keys_index
 130                 then (body, mempty)
 131                 else
 132                         let allTerms = (Set.fromList . concat) `foldMap` keys_index in
 133                         (<$> S.runState
 134                                  (Index.indexify body)
 135                                  Index.state
 136                                          { Index.state_terms = Map.fromSet (const []) allTerms
 137                                          }) $ \Index.State{state_terms} ->
 138                                 (<$> keys_index) $ \terms ->
 139                                         (terms,) $
 140                                         Map.intersection state_terms $
 141                                         Map.fromSet (const ()) $
 142                                         Set.fromList $ concat $
 143                                         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 >>= Tree.axis_repeat Tree.axis_following1) $
 188                         html5ify
 189
 190 instance Html5ify BodyCursor where
 191         html5ify z =
 192                 case Tree.current z of
 193                  TreeN k _ts -> html5BodyKey z k
 194                  Tree0 v -> html5BodyValue z v
 195
 196 html5BodyKey :: BodyCursor -> DTC.BodyKey -> Html5
 197 html5BodyKey z = \case
 198          DTC.Section{..} ->
 199                 H.section ! HA.class_ "section"
 200                           ! HA.id (attrValue pos) $$ do
 201                         html5CommonAttrs attrs $
 202                                 H.table ! HA.class_ "section-header" $$
 203                                         H.tbody $$
 204                                                 H.tr $$ do
 205                                                         H.td ! HA.class_ "section-number" $$ do
 206                                                                 html5SectionNumber $
 207                                                                         xmlPosAncestors pos
 208                                                         H.td ! HA.class_ "section-title" $$ do
 209                                                                 (case List.length $ xmlPosAncestors pos of
 210                                                                  0 -> H.h1
 211                                                                  1 -> H.h2
 212                                                                  2 -> H.h3
 213                                                                  3 -> H.h4
 214                                                                  4 -> H.h5
 215                                                                  5 -> H.h6
 216                                                                  _ -> H.h6) $$
 217                                                                         html5ify title
 218                         forM_ (Tree.axis_child z) $
 219                                 html5ify
 220 html5BodyValue :: BodyCursor -> DTC.BodyValue -> Html5
 221 html5BodyValue z = \case
 222          DTC.Vertical v -> do
 223                 html5ify v
 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 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 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 verts
 257          DTC.Index{pos} -> do
 258                 (allTerms,refsByTerm) <- liftStateMarkup $ S.gets $ (Map.! pos) . indexs
 259                 let chars = Index.aliasesByChar 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) $ \term ->
 286                                                                                 refsByTerm Map.! term
 287                                                                 sequence_ $
 288                                                                         List.intersperse ", " $
 289                                                                         (<$> refs) $ \ref@Index.Ref{..} ->
 290                                                                                 H.a ! HA.href ("#"<>attrValue ref) $$
 291                                                                                         html5ify $
 292                                                                                                 List.intercalate "." $
 293                                                                                                 List.reverse $
 294                                                                                                 (<$> xmlPosAncestors section) $ \(_n,c) -> show c
 295
 296 html5ToC :: Int -> BodyCursor -> Html5
 297 html5ToC depth z =
 298         case Tree.current z of
 299          TreeN DTC.Section{..} _ts -> do
 300                 H.li $$ do
 301                         H.table ! HA.class_ "toc-entry" $$
 302                                 H.tbody $$
 303                                         H.tr $$ do
 304                                                 H.td ! HA.class_ "section-number" $$
 305                                                         html5SectionRef $ xmlPosAncestors pos
 306                                                 H.td ! HA.class_ "section-title" $$
 307                                                         html5ify $
 308                                                                 DTC.unTitle title >>= \case
 309                                                                  DTC.Iref{..} -> text
 310                                                                  DTC.Note{} -> []
 311                                                                  h -> [h]
 312                         let sections =
 313                                 ($ z) $ Tree.axis_child
 314                                 `Tree.axis_filter_current` \case
 315                                  TreeN DTC.Section{} _ -> True
 316                                  _ -> False
 317                         when (depth > 0 && not (null sections)) $
 318                                 H.ul $$
 319                                         forM_ sections $
 320                                                 html5ToC (depth - 1)
 321          _ -> pure ()
 322
 323 html5ToF :: Int -> BodyCursor -> Html5
 324 html5ToF depth z =
 325         case Tree.current z of
 326          Tree0 v ->
 327                 case v of
 328                  DTC.Figure{..} ->
 329                         H.tr $$ do
 330                                 H.td ! HA.class_ "figure-number" $$
 331                                         H.a ! HA.href ("#"<>attrValue pos) $$
 332                                                 html5ify type_
 333                                 H.td ! HA.class_ "figure-name" $$
 334                                         html5ify title
 335                  _ -> pure ()
 336          _ -> pure ()
 337
 338 instance Html5ify [DTC.Vertical] where
 339         html5ify = mapM_ html5ify
 340 instance Html5ify DTC.Vertical where
 341         html5ify = \case
 342          DTC.Para{..} ->
 343                 html5CommonAttrs attrs $
 344                 H.p ! HA.class_ "para"
 345                     ! HA.id (attrValue pos) $$ do
 346                         html5ify horis
 347          DTC.OL{..} ->
 348                 html5CommonAttrs attrs $
 349                 H.ol ! HA.class_ "ol"
 350                      ! HA.id (attrValue pos) $$ do
 351                         forM_ items $ \item ->
 352                                 H.li $$ html5ify item
 353          DTC.UL{..} ->
 354                 html5CommonAttrs attrs $
 355                 H.ul ! HA.class_ "ul"
 356                      ! HA.id (attrValue pos) $$ do
 357                         forM_ items $ \item ->
 358                                 H.li $$ html5ify item
 359          DTC.RL{..} ->
 360                 html5CommonAttrs attrs $
 361                 H.div ! HA.class_ "rl"
 362                       ! HA.id (attrValue pos) $$ do
 363                         H.table $$
 364                                 forM_ refs html5ify
 365          DTC.Comment t ->
 366                 html5ify $ H.Comment (H.Text t) ()
 367 instance Html5ify DTC.Horizontal where
 368         html5ify = \case
 369          DTC.BR       -> html5ify H.br
 370          DTC.B    hs  -> H.strong $$ html5ify hs
 371          DTC.Code hs  -> H.code   $$ html5ify hs
 372          DTC.Del  hs  -> H.del    $$ html5ify hs
 373          DTC.I    hs  -> H.i      $$ html5ify hs
 374          DTC.Note _   -> ""
 375          DTC.Q    hs  ->
 376                 H.span ! HA.class_ "q" $$ do
 377                         "« "::Html5
 378                         H.i $$ html5ify hs
 379                         " »"
 380          DTC.SC   hs  -> H.span ! HA.class_ "smallcaps" $$ html5ify hs
 381          DTC.Sub  hs  -> H.sub $$ html5ify hs
 382          DTC.Sup  hs  -> H.sup $$ html5ify hs
 383          DTC.U    hs  -> H.span ! HA.class_ "underline" $$ html5ify hs
 384          DTC.Eref{..} ->
 385                 H.a ! HA.class_ "eref"
 386                     ! HA.href (attrValue href) $$
 387                         html5ify text
 388          DTC.Iref{..} ->
 389                 H.span ! HA.class_ "iref"
 390                        ! HA.id (attrValue Index.Ref{term, count, section=def}) $$
 391                         html5ify text
 392          DTC.Ref{..}  ->
 393                 H.a ! HA.class_ "ref"
 394                     ! HA.href ("#"<>attrValue to) $$
 395                 if null text
 396                 then html5ify to
 397                 else html5ify text
 398          DTC.Rref{..} ->
 399                 H.a ! HA.class_ "rref"
 400                     ! HA.href (attrValue to) $$
 401                         html5ify text
 402          DTC.Plain t  -> html5ify t
 403 instance AttrValue Index.Ref where
 404         attrValue Index.Ref{..} =
 405                 "iref" <> "." <> attrValue term <>
 406                 if count > 0
 407                 then "." <> attrValue count
 408                 else ""
 409 instance Html5ify [DTC.Horizontal] where
 410         html5ify = mapM_ html5ify
 411 instance Html5ify DTC.About where
 412         html5ify DTC.About{..} =
 413                 forM_ titles $ \(DTC.Title title) ->
 414                         html5ify $ DTC.Q title
 415 instance Html5ify DTC.Reference where
 416         html5ify DTC.Reference{..} =
 417                 H.tr $$ do
 418                         H.td ! HA.class_ "reference-key" $$
 419                                 html5ify id
 420                         H.td ! HA.class_ "reference-content" $$
 421                                 html5ify about
 422
 423 html5CommonAttrs :: DTC.CommonAttrs -> Html5 -> Html5
 424 html5CommonAttrs DTC.CommonAttrs{..} =
 425         Compose . (addClass . addId <$>) . getCompose
 426         where
 427         addClass =
 428                 case classes of
 429                  [] -> \x -> x
 430                  _  -> H.AddCustomAttribute "class" (H.Text $ Text.unwords classes)
 431         addId =
 432                 case id of
 433                  Nothing -> \x -> x
 434                  Just (DTC.Ident i) ->
 435                         H.AddCustomAttribute "id" (H.Text i)
 436
 437 html5SectionNumber :: [(XmlName,Int)] -> Html5
 438 html5SectionNumber = go [] . List.reverse
 439         where
 440         go :: [(XmlName,Int)] -> [(XmlName,Int)] -> Html5
 441         go _rs [] = pure ()
 442         go rs (a@(_n,cnt):as) = do
 443                 H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors (a:rs)) $$
 444                         html5ify $ show cnt
 445                 html5ify '.'
 446                 go (a:rs) as
 447
 448 html5SectionRef :: [(XmlName,Int)] -> Html5
 449 html5SectionRef as =
 450         H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors as) $$
 451                 case as of
 452                  [(_n,c)] -> do
 453                         html5ify $ show c
 454                         html5ify '.'
 455                  _ ->
 456                         html5ify $
 457                                 Text.intercalate "." $
 458                                 Text.pack . show . snd <$> as
 459
 460 textXmlPosAncestors :: [(XmlName,Int)] -> Text
 461 textXmlPosAncestors =
 462         snd . foldr (\(n,c) (nParent,acc) ->
 463                 (n,
 464                         (if Text.null acc
 465                                 then acc
 466                                 else acc <> ".") <>
 467                         Text.pack
 468                          (if n == nParent
 469                                 then show c
 470                                 else show n<>show c)
 471                 )
 472          )
 473          ("","")
 474
 475 -- * Class 'Plainify'
 476 class Plainify a where
 477         plainify :: a -> TL.Text
 478 instance Plainify DTC.Horizontal where
 479         plainify = \case
 480          DTC.BR       -> "\n"
 481          DTC.B    hs  -> "*"<>plainify hs<>"*"
 482          DTC.Code hs  -> "`"<>plainify hs<>"`"
 483          DTC.Del  hs  -> "-"<>plainify hs<>"-"
 484          DTC.I    hs  -> "/"<>plainify hs<>"/"
 485          DTC.Note _   -> ""
 486          DTC.Q    hs  -> "« "<>plainify hs<>" »"
 487          DTC.SC   hs  -> plainify hs
 488          DTC.Sub  hs  -> plainify hs
 489          DTC.Sup  hs  -> plainify hs
 490          DTC.U    hs  -> "_"<>plainify hs<>"_"
 491          DTC.Eref{..} -> plainify text
 492          DTC.Iref{..} -> plainify text
 493          DTC.Ref{..}  -> plainify text
 494          DTC.Rref{..} -> plainify text
 495          DTC.Plain t  -> TL.fromStrict t
 496 instance Plainify [DTC.Horizontal] where
 497         plainify = foldMap plainify
 498 instance Plainify DTC.Title where
 499         plainify (DTC.Title t) = plainify t
 500
 501 instance AttrValue XmlPos where
 502         attrValue = attrValue . textXmlPosAncestors . xmlPosAncestors
 503
 504 -- * Type 'MsgHtml5'
 505 data MsgHtml5
 506  =   MsgHTML5_Table_of_Contents
 507  deriving (Show)
 508 instance Html5ify MsgHtml5 where
 509         html5ify msg = do
 510                 loc <- liftStateMarkup $ S.gets localize
 511                 loc msg
 512 instance LocalizeIn FR Html5 MsgHtml5 where
 513         localizeIn _ = \case
 514          MsgHTML5_Table_of_Contents -> "Sommaire"
 515 instance LocalizeIn EN Html5 MsgHtml5 where
 516         localizeIn _ = \case
 517          MsgHTML5_Table_of_Contents -> "Summary"