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