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