{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Hdoc.DTC.Write.HTML5 ( module Hdoc.DTC.Write.HTML5 , module Hdoc.DTC.Write.HTML5.Ident , module Hdoc.DTC.Write.HTML5.Base , module Hdoc.DTC.Write.HTML5.Judgment -- , module Hdoc.DTC.Write.HTML5.Error ) where import Control.Applicative (Applicative(..)) import Control.Monad (Monad(..), (=<<), forM_, mapM_, sequence_) import Data.Bool import Data.Default.Class (Default(..)) import Data.Either (Either(..)) import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..), concat, fold) import Data.Function (($), (.), const, on) import Data.Functor ((<$>), (<$)) import Data.Functor.Compose (Compose(..)) import Data.List.NonEmpty (NonEmpty(..)) import Data.Locale hiding (Index) import Data.Maybe (Maybe(..), maybe, mapMaybe, isNothing, fromMaybe) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Prelude (succ) import Data.Sequence (Seq) import Data.Semigroup (Semigroup(..)) import Data.String (String) import Data.TreeSeq.Strict (Tree(..), tree0) import Data.Tuple (snd) import System.FilePath (()) import System.IO (IO) import Text.Blaze ((!)) import Text.Blaze.Html (Html) import Text.Show (Show(..)) import qualified Control.Monad.Trans.RWS.Strict as RWS import qualified Control.Monad.Trans.Reader as R import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS import qualified Data.List as List import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text import qualified Data.Text.Lazy as TL import qualified Data.TreeMap.Strict as TM import qualified Safe import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as HA import qualified Text.Blaze.Internal as H import Control.Monad.Utils import Hdoc.DTC.Document as DTC import Hdoc.DTC.Write.HTML5.Base import Hdoc.DTC.Write.HTML5.Error () import Hdoc.DTC.Write.HTML5.Ident import Hdoc.DTC.Write.HTML5.Judgment import Hdoc.DTC.Write.Plain (Plainify(..)) import Hdoc.DTC.Write.XML () import Hdoc.Utils import Text.Blaze.Utils import Text.Blaze.XML () import qualified Hdoc.DTC.Analyze.Check as Analyze import qualified Hdoc.DTC.Analyze.Collect as Analyze import qualified Hdoc.DTC.Analyze.Index as Analyze import qualified Hdoc.DTC.Write.Plain as Plain import qualified Hdoc.TCT.Cell as TCT import qualified Hdoc.Utils as FS import qualified Hdoc.XML as XML import qualified Paths_hdoc as Hdoc import Debug.Trace debug :: Show a => String -> a -> a debug msg a = trace (msg<>": "<>show a) a debugOn :: Show b => String -> (a -> b) -> a -> a debugOn msg get a = trace (msg<>": "<>show (get a)) a debugWith :: String -> (a -> String) -> a -> a debugWith msg get a = trace (msg<>": "<>get a) a writeHTML5 :: Config -> DTC.Document -> IO Html writeHTML5 conf@Config{..} doc_init = do let all_index = Analyze.collectIndex doc_init let (doc@DTC.Document{..}, all_irefs) = Analyze.indexifyDocument (fold all_index) doc_init let all = Analyze.collect doc `R.runReader` def let err = Analyze.errors all let ro = def { reader_l10n = loqualize config_locale , reader_plainify = def{Plain.reader_l10n = loqualize config_locale} , reader_all = all -- , reader_body = body } let st = def { state_errors = debug "errors" $ Nat1 1 <$ err , state_notes = fold $ toList <$> Analyze.all_notes all , state_indices = (<$> toList all_index) $ \terms -> (terms,) $ TM.intersection const all_irefs $ Analyze.indexOfTerms terms } let (html5Body, _endState, endWriter) = runComposeRWS ro st $ do analyseJudgments doc html5ify err html5ify doc html5Head <- writeHTML5Head conf ro endWriter doc return $ do H.docType H.html ! HA.lang (attrify $ countryCode config_locale) $ do html5Head H.body $ do {- NOTE: unless (null state_scripts) $ do -- NOTE: indicate that JavaScript is active. H.script ! HA.type_ "application/javascript" $ "document.body.className = \"script\";" -} html5Body writeHTML5Head :: Config -> Reader -> Writer -> Document -> IO Html writeHTML5Head Config{..} Reader{..} Writer{..} Document{..} = do csss :: Html <- do -- unless (any (\DTC.Link{..} -> link_rel == "stylesheet" && link_url /= URL "") links) $ do (`foldMap` writer_styles) $ \case Left css -> do content <- FS.readFile =<< Hdoc.getDataFileName ("style"css) return $ H.style ! HA.type_ "text/css" $ H.toMarkup content Right content -> return $ do H.style ! HA.type_ "text/css" $ -- NOTE: as a special case, H.style wraps its content into an External, -- so it does not HTML-escape its content. H.toMarkup content scripts :: Html <- (`foldMap` writer_scripts) $ \script -> do content <- FS.readFile =<< Hdoc.getDataFileName ("style"script) return $ H.script ! HA.type_ "application/javascript" $ H.toMarkup content {- if not (any (\DTC.Link{link_rel} -> link_rel == "script") links) then do else mempty case config_js of Left "" -> mempty Left js -> H.script ! HA.src (attrify js) ! HA.type_ "application/javascript" $ mempty Right js -> H.script ! HA.type_ "application/javascript" $ H.toMarkup js -} return $ H.head $ do H.meta ! HA.httpEquiv "Content-Type" ! HA.content "text/html; charset=UTF-8" unless (TL.null config_generator) $ do H.meta ! HA.name "generator" ! HA.content (attrify config_generator) case document_head of Nothing -> mempty Just Head{head_section=Section{section_about=About{..}}, ..} -> do case about_titles of title:_ -> H.title $ H.toMarkup $ Plain.text reader_plainify title _ -> mempty forM_ about_links $ \Link{..} -> case link_rel of "stylesheet" | URL "" <- link_url -> H.style ! HA.type_ "text/css" $ H.toMarkup $ Plain.text def link_plain _ -> H.link ! HA.rel (attrify link_rel) ! HA.href (attrify link_url) unless (null about_tags) $ H.meta ! HA.name "keywords" ! HA.content (attrify $ TL.intercalate ", " about_tags) let chapters = (`mapMaybe` toList document_body) $ \case Tree (BodySection s) _ -> Just s _ -> Nothing forM_ chapters $ \Section{..} -> H.link ! HA.rel "Chapter" ! HA.title (attrify $ plainify $ Safe.headDef def about_titles) ! HA.href (refIdent $ identify section_posXML) case config_css of Left "" -> mempty Left css -> H.link ! HA.rel "stylesheet" ! HA.type_ "text/css" ! HA.href (attrify css) Right css -> H.style ! HA.type_ "text/css" $ H.toMarkup css csss scripts instance Html5ify Document where html5ify Document{document_head=Nothing, ..} = html5ify document_body html5ify Document{document_head=Just Head{..}, ..} = do localComposeRWS (\ro -> ro{reader_section = [head_section], reader_body = body}) $ do ro <- composeLift RWS.ask unless (null about_authors) $ do H.div ! HA.class_ "document-head" $$ H.table $$ do H.tbody $$ do H.tr $$ do H.td ! HA.class_ "left" $$ html5Headers H.td ! HA.class_ "right" $$ html5Roles unless (null about_titles) $ do H.div ! HA.class_ "title" ! HA.id "document-title." $$ do forM_ about_titles $ \title -> H.h1 ! HA.id (attrify $ identifyTitle (Plain.reader_l10n $ reader_plainify ro) title) $$ html5ify title html5SectionJudgments html5ify body where body = head_body <> document_body Section{section_about=About{..}, ..} = head_section html5Headers = H.table ! HA.class_ "document-headers" $$ H.tbody $$ do Loqualization l10n <- composeLift $ RWS.asks reader_l10n forM_ about_series $ \s@Serie{..} -> header $ case urlSerie s of Nothing -> do headerName $ html5ify serie_name headerValue $ html5ify serie_id Just href -> do headerName $ html5ify serie_name headerValue $ H.a ! HA.href (attrify href) $$ html5ify serie_id forM_ about_links $ \Link{..} -> unless (TL.null $ unName link_role) $ header $ do headerName $ html5ify link_role headerValue $ html5ify $ Tree PlainEref{eref_href=link_url} link_plain forM_ about_dates $ \d@Date{..} -> header $ do headerName $ if TL.null $ unName date_role then l10n_Header_Date l10n else html5ify date_role headerValue $ html5ify d {- forM_ about_headers $ \Header{..} -> header $ do headerName $ html5ify header_name headerValue $ html5ify header_value -} html5Roles = H.table ! HA.class_ "document-authors" $$ H.tbody $$ do forM_ about_authors $ \a -> H.tr $$ H.td ! HA.class_ "author" $$ html5ify a header :: HTML5 -> HTML5 header hdr = H.tr ! HA.class_ "header" $$ hdr headerName :: HTML5 -> HTML5 headerName hdr = H.td ! HA.class_ "header-name" $$ do hdr Loqualization l10n <- composeLift $ RWS.asks reader_l10n Plain.l10n_Colon l10n headerValue :: HTML5 -> HTML5 headerValue hdr = H.td ! HA.class_ "header-value" $$ do hdr instance Html5ify Body where html5ify body = localComposeRWS (\ro -> ro{reader_body = body}) $ go body where go bs = case Seq.viewl bs of Seq.EmptyL -> popNotes >>= html5Notes curr Seq.:< next -> do case curr of Tree BodySection{} _ -> popNotes >>= html5Notes _ -> mempty html5ify curr go next instance Html5ify (Tree BodyNode) where html5ify (Tree b bs) = do case b of BodyBlock blk -> html5ify blk BodySection section@Section{section_about=About{..}, ..} -> do localComposeRWS (\ro -> ro { reader_section = section : reader_section ro , reader_body = bs }) $ do Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask notes <- popNotes html5CommonAttrs section_attrs { attrs_classes = "section":attrs_classes section_attrs , attrs_id = Nothing } $ do H.section ! HA.id (attrify $ identify section_posXML) $$ do forM_ about_aliases html5ify html5SectionJudgments let mayId = case attrs_id section_attrs of Just ident | Just [_] <- toList <$> HM.lookup ident all_section -> Just $ identifyTag "" ident Nothing _ -> Nothing H.table ! HA.class_ "section-header" !?? mayAttr HA.id mayId $$ H.tbody $$ case about_titles of [] -> H.tr $$ do H.td ! HA.class_ "section-number" $$ do html5SectionAnchor section title:titles -> do let hN = case List.length $ XML.pos_ancestors section_posXML of 0 -> H.h1 1 -> H.h2 2 -> H.h3 3 -> H.h4 4 -> H.h5 5 -> H.h6 _ -> H.h6 H.tr $$ do H.td ! HA.class_ "section-number" $$ do html5SectionAnchor section H.td ! HA.class_ "section-title" $$ do hN $$ html5ify title forM_ titles $ \t -> H.tr $$ do H.td $$ mempty H.td ! HA.class_ "section-title" $$ do hN $$ html5ify t html5ify bs html5Notes notes {- FIXME do -- notes notes <- composeLift $ S.gets state_notes maybe mempty html5Notes $ Map.lookup (XML.pos_ancestors section_posXML) notes -} instance Html5ify Block where html5ify = \case BlockPara para -> html5ify para BlockBreak{..} -> html5CommonAttrs attrs { attrs_classes = "page-break":"print-only":attrs_classes attrs } $ H.div $$ H.p $$ " " -- NOTE: force page break BlockToC{..} -> H.nav ! HA.class_ "toc" ! HA.id (attrify $ identify posXML) $$ do H.span ! HA.class_ "toc-name" $$ H.a ! HA.href (refIdent $ identify posXML) $$ do Loqualization l10n <- composeLift $ RWS.asks reader_l10n Plain.l10n_Table_of_Contents l10n H.ul $$ do Reader{reader_body} <- composeLift RWS.ask forM_ reader_body $ html5ifyToC depth BlockToF{..} -> do H.nav ! HA.class_ "tof" ! HA.id (attrify $ identify posXML) $$ H.table ! HA.class_ "tof" $$ H.tbody $$ html5ifyToF types BlockAside{..} -> html5CommonAttrs attrs $ H.aside ! HA.class_ "aside" $$ do forM_ blocks html5ify BlockFigure{..} -> html5CommonAttrs attrs { attrs_classes = "figure":("figure-"<>type_):attrs_classes attrs , attrs_id = Just $ identify $ XML.pos_ancestorsWithFigureNames posXML } $ H.div $$ do H.table ! HA.class_ "figure-caption" $$ H.tbody $$ H.tr $$ do if TL.null type_ then H.a ! HA.href (refIdent $ identify posXML) $$ mempty else H.td ! HA.class_ "figure-number" $$ do H.a ! HA.href (refIdent $ identify $ XML.pos_ancestorsWithFigureNames posXML) $$ do html5ify type_ html5ify $ XML.pos_ancestorsWithFigureNames posXML forM_ mayTitle $ \title -> do H.td ! HA.class_ "figure-colon" $$ do unless (TL.null type_) $ do Loqualization l10n <- composeLift $ RWS.asks reader_l10n Plain.l10n_Colon l10n H.td ! HA.class_ "figure-title" $$ do html5ify title H.div ! HA.class_ "figure-content" $$ do html5ify paras BlockIndex{posXML} -> do State{..} <- composeLift RWS.get composeLift $ do RWS.tell def { writer_styles = HS.singleton $ Left "dtc-index.css" } RWS.modify $ \s -> s{state_indices=List.tail state_indices} let (allTerms,refsByTerm) = List.head state_indices let chars = Analyze.termsByChar allTerms H.div ! HA.class_ "index" ! HA.id (attrify $ identify posXML) $$ do H.nav ! HA.class_ "index-nav" $$ do forM_ (Map.keys chars) $ \char -> H.a ! HA.href (refIdent (identify posXML <> "." <> identify char)) $$ html5ify char H.dl ! HA.class_ "index-chars" $$ forM_ (Map.toList chars) $ \(char,terms) -> do H.dt $$ do let i = identify posXML <> "." <> identify char H.a ! HA.id (attrify i) ! HA.href (refIdent i) $$ html5ify char H.dd $$ H.dl ! HA.class_ "index-term" $$ do forM_ terms $ \aliases -> do H.dt $$ H.ul ! HA.class_ "index-aliases" $$ forM_ (List.take 1 aliases) $ \term -> do H.li ! HA.id (attrify $ identifyIref term Nothing) $$ html5ify term H.dd $$ do let sortedRefs = List.sortBy (compare `on` snd) $ (`foldMap` aliases) $ \term -> fromMaybe def $ do path <- DTC.pathFromWords term refs <- Strict.maybe Nothing Just $ TM.lookup path refsByTerm return $ Seq.foldrWithIndex (\num ref acc -> ((term, succ num), ref):acc) [] $ Seq.reverse refs html5CommasDot $ (<$> sortedRefs) $ \((term, num), section) -> H.a ! HA.class_ "index-iref" ! HA.href (refIdent $ identifyIref term $ Just $ Nat1 num) $$ html5ify $ XML.pos_ancestors $ section_posXML section BlockReferences{..} -> html5CommonAttrs attrs { attrs_classes = "references":attrs_classes attrs , attrs_id = Just $ identify $ XML.pos_ancestors posXML } $ H.div $$ do H.table $$ forM_ refs html5ify BlockGrades{..} -> html5CommonAttrs attrs { attrs_classes = "grades":attrs_classes attrs , attrs_id = Just $ identify $ XML.pos_ancestors posXML } $ H.div $$ do -- let dg = List.head $ List.filter default_ scale -- let sc = MJ.Scale (Set.fromList scale) dg -- o :: Map choice grade -- os :: Opinions (Map judge (Opinion choice grade)) mempty -- html5ify $ show b BlockJudges js -> html5ify js instance Html5ify Para where html5ify = \case ParaItem{..} -> html5CommonAttrs def { attrs_classes = "para":cls item } $ html5ify item ParaItems{..} -> html5CommonAttrs attrs { attrs_classes = "para":attrs_classes attrs , attrs_id = id_ posXML } $ H.div $$ forM_ items $ \item -> html5AttrClass (cls item) $ html5ify item where id_ = Just . identify . XML.pos_ancestors cls = \case ParaPlain{} -> [] ParaArtwork{..} -> ["artwork", "artwork-"<>type_] ParaQuote{..} -> ["quote", "quote-"<>type_] ParaComment{} -> [] ParaOL{} -> ["ol"] ParaUL{} -> ["ul"] ParaJudgment Judgment{..} -> ["judgment"] <> when (null judgment_opinionsByChoice) ["judgment-error"] instance Html5ify ParaItem where html5ify = \case ParaPlain p -> H.p $$ html5ify p ParaArtwork{..} -> H.pre $$ do html5ify text ParaQuote{..} -> H.div $$ do html5ify paras ParaComment t -> html5ify $ H.Comment (H.String $ TL.unpack t) () ParaOL items -> H.dl $$ do forM_ items $ \ListItem{..} -> do H.dt ! HA.class_ "name" $$ do html5ify name "."::HTML5 H.dd ! HA.class_ "value" $$ html5ify paras ParaUL items -> H.dl $$ do forM_ items $ \item -> do H.dt $$ "—" H.dd $$ html5ify item ParaJudgment j -> html5ify j instance Html5ify [Para] where html5ify = mapM_ html5ify instance Html5ify Plain where html5ify ps = case Seq.viewl ps of Seq.EmptyL -> mempty curr Seq.:< next -> case curr of -- NOTE: gather adjacent PlainNotes Tree PlainNote{} _ | (notes, rest) <- Seq.spanl (\case {Tree PlainNote{} _ -> True; _ -> False}) next -> do H.sup ! HA.class_ "note-numbers" $$ do html5ify curr forM_ notes $ \note -> do ", "::HTML5 html5ify note " "::HTML5 html5ify rest -- _ -> do html5ify curr html5ify next instance Html5ify (Tree PlainNode) where html5ify (Tree n ps) = case n of PlainBreak -> html5ify H.br PlainText t -> html5ify t PlainGroup -> html5ify ps PlainB -> H.strong $$ html5ify ps PlainCode -> H.code $$ html5ify ps PlainDel -> H.del $$ html5ify ps PlainI -> do i <- composeLift $ RWS.asks reader_italic H.em ! HA.class_ (if i then "even" else "odd") $$ localComposeRWS (\ro -> ro{reader_italic=not i}) $ html5ify ps PlainSpan{..} -> html5CommonAttrs attrs $ H.span $$ html5ify ps PlainSub -> H.sub $$ html5ify ps PlainSup -> H.sup $$ html5ify ps PlainSC -> H.span ! HA.class_ "smallcaps" $$ html5ify ps PlainU -> H.span ! HA.class_ "underline" $$ html5ify ps PlainNote{..} -> do num <- composeLift $ do num <- RWS.gets state_note_num_ref RWS.modify $ \s -> s{state_note_num_ref=succNat1 num} return num H.a ! HA.class_ "note-ref" ! HA.id ("note-ref."<>attrify num) ! HA.href ("#note."<>attrify num) $$ html5ify num PlainQ -> do H.span ! HA.class_ "q" $$ do Loqualization l10n <- composeLift $ RWS.asks reader_l10n Plain.l10n_Quote (html5ify $ Tree PlainI ps) l10n -- PlainEref{..} -> do H.a ! HA.class_ "eref no-print" ! HA.href (attrify eref_href) $$ if null ps then html5ify $ unURL eref_href else html5ify ps H.span ! HA.class_ "eref print-only" $$ do unless (null ps) $ do html5ify ps " "::HTML5 "<"::HTML5 html5ify eref_href ">" -- PlainTag{..} -- backward | tag_back -> do Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask State{state_errors=Analyze.Errors{..}} <- composeLift RWS.get case HM.lookup tag_ident all_tag of Nothing -> pure () Just anchs -> H.span ! HA.class_ "tag-backs" $$ html5Commas $ (<$> List.zip (toList anchs) [1..]) $ \((_loc, maySection),idNum) -> H.a ! HA.class_ "tag-back" ! HA.href (refIdent $ identifyTag "-back" tag_ident $ Just $ Nat1 idNum) $$ html5SectionNumber maySection -- forward | otherwise -> do State{state_tag} <- composeLift RWS.get let idNum = HM.lookupDefault (Nat1 1) tag_ident state_tag composeLift $ RWS.modify $ \s -> s { state_tag = HM.insert tag_ident (succNat1 idNum) state_tag } H.span ! HA.class_ "tag" ! HA.id (attrify $ identifyTag "-back" tag_ident $ Just idNum) $$ html5ify tag_ident -- PlainAt{..} -- backward | at_back -> do Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask State{state_errors=Analyze.Errors{..}} <- composeLift RWS.get case HM.lookup at_ident all_at of Nothing -> pure () Just anchs -> H.span ! HA.class_ "at-backs" $$ html5Commas $ (<$> List.zip (toList anchs) [1..]) $ \((_loc, maySection),idNum) -> H.a ! HA.class_ "at-back" ! HA.href (refIdent $ identifyAt "-back" at_ident $ Just $ Nat1 idNum) $$ html5SectionNumber maySection -- forward | otherwise -> do Reader{..} <- composeLift RWS.ask State{state_errors=errs@Analyze.Errors{..}, ..} <- composeLift RWS.get let idNum = HM.lookupDefault (Nat1 1) at_ident state_at composeLift $ RWS.modify $ \s -> s { state_at = HM.insert at_ident (succNat1 idNum) state_at } case () of -- unknown _ | Just errNum <- HM.lookup at_ident errors_at_unknown -> do composeLift $ RWS.modify $ \s -> s { state_errors = errs { Analyze.errors_at_unknown = HM.adjust succNat1 at_ident errors_at_unknown } } H.span ! HA.class_ "at at-unknown" ! HA.id (attrify $ identifyAt "-unknown" at_ident (Just errNum)) $$ H.span ! HA.class_ "at at-unknown" ! HA.id (attrify $ identifyAt "-back" at_ident $ Just idNum) $$ html5ify at_ident -- ambiguous | Just errNum <- HM.lookup at_ident errors_at_ambiguous -> do composeLift $ RWS.modify $ \s -> s { state_errors = errs { Analyze.errors_at_ambiguous = HM.adjust succNat1 at_ident errors_at_ambiguous } } H.span ! HA.class_ "at at-ambiguous" ! HA.id (attrify $ identifyAt "-ambiguous" at_ident (Just errNum)) $$ H.span ! HA.class_ "at at-ambiguous" ! HA.id (attrify $ identifyAt "-back" at_ident $ Just idNum) $$ html5ify at_ident -- known | otherwise -> do H.a ! HA.class_ "at" ! HA.href (refIdent $ identifyAt "" at_ident Nothing) ! HA.id (attrify $ identifyAt "-back" at_ident $ Just idNum) $$ html5ify at_ident -- PlainRef{..} -> do Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask State{state_errors=errs@Analyze.Errors{..}, ..} <- composeLift RWS.get let idNum = HM.lookupDefault (Nat1 1) ref_ident state_ref composeLift $ RWS.modify $ \s -> s { state_ref = HM.insert ref_ident (succNat1 idNum) state_ref } case toList $ HM.lookupDefault def ref_ident all_reference of -- unknown [] -> do let errNum = HM.lookup ref_ident errors_ref_unknown composeLift $ RWS.modify $ \s -> s { state_errors = errs { Analyze.errors_ref_unknown = HM.adjust succNat1 ref_ident errors_ref_unknown } } H.span ! HA.class_ "reference reference-unknown" ! HA.id (attrify $ identifyReference "-unknown" ref_ident errNum) $$ do "["::HTML5 html5ify ref_ident "]" -- known [Reference{..}] -> do let a = H.a ! HA.href (refIdent $ identifyReference "" ref_ident Nothing) let ref = do H.span ! HA.class_ "reference" ! HA.id (attrify $ identifyReference "" ref_ident $ Just idNum) $$ do "["::HTML5 a $$ html5ify ref_ident "]" case toList ps of [] -> ref [Tree (PlainText "") _] -> do refs <- composeLift $ RWS.asks $ Analyze.all_reference . reader_all case toList <$> HM.lookup ref_ident refs of Just [Reference{reference_about=About{..}}] -> do forM_ (List.take 1 about_titles) $ \(Title title) -> do html5ify $ Tree PlainQ $ case List.filter ((\rel -> rel == "" || rel == "self") . link_rel) about_links of [] -> title Link{..}:_ -> pure $ Tree (PlainEref link_url) title " "::HTML5 ref _ -> mempty _ -> do a $$ html5ify ps H.span ! HA.class_ "print-only" $$ do " "::HTML5 ref -- ambiguous _ -> do case toList ps of [] -> mempty [Tree (PlainText "") _] -> mempty _ -> do html5ify ps " "::HTML5 H.span ! HA.class_ "reference reference-ambiguous" $$ do "["::HTML5 html5ify ref_ident "]" -- PlainIref{..} -> case pathFromWords iref_term of Nothing -> html5ify ps Just path -> do Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask State{state_irefs} <- composeLift RWS.get let num = Strict.fromMaybe (Nat1 1) $ TM.lookup path state_irefs composeLift $ RWS.modify $ \s -> s { state_irefs = TM.insert const path (succNat1 num) state_irefs } H.span ! HA.class_ "iref" ! HA.id (attrify $ identifyIref iref_term $ Just num) $$ html5ify ps instance Html5ify [Title] where html5ify = html5ify . fold . List.intersperse sep . toList where sep = Title $ Seq.singleton $ tree0 $ PlainText " — " instance Html5ify Title where html5ify (Title t) = html5ify t instance Html5ify About where html5ify About{..} = do Loqualization l10n <- composeLift $ RWS.asks reader_l10n H.p $$ html5CommasDot $ concat [ html5Titles about_titles , html5ify <$> about_authors , html5ify <$> about_dates , html5ify <$> about_series ] forM_ about_links $ \Link{..} -> case () of _ | link_rel == "" || link_rel == "self" -> H.p ! HA.class_ "reference-url print-only" $$ do html5ify $ Tree PlainEref{eref_href=link_url} link_plain _ -> H.p ! HA.class_ "reference-url" $$ do html5ify link_role Plain.l10n_Colon l10n :: HTML5 html5ify $ Tree PlainEref{eref_href=link_url} link_plain forM_ about_description $ \description -> do H.div ! HA.class_ "reference-description" $$ do html5ify description where html5Titles :: [Title] -> [HTML5] html5Titles ts | null ts = [] html5Titles ts = [html5Title $ joinTitles ts] where joinTitles = fold . List.intersperse sep . toList sep = Title $ Seq.singleton $ tree0 $ PlainText " — " html5Title (Title title) = do H.span ! HA.class_ "no-print" $$ html5ify $ Tree PlainQ $ case List.filter ((\rel -> rel == "" || rel == "self") . link_rel) about_links of [] -> title Link{..}:_ -> pure $ Tree (PlainEref link_url) title H.span ! HA.class_ "print-only" $$ html5ify $ Tree PlainQ title instance Html5ify Serie where html5ify s@Serie{..} = do Loqualization l10n <- composeLift $ RWS.asks reader_l10n case urlSerie s of Nothing -> do html5ify serie_name Plain.l10n_Colon l10n :: HTML5 html5ify serie_id Just href -> do html5ify $ Tree PlainEref{eref_href=href} $ Seq.fromList [ tree0 $ PlainText $ unName serie_name , tree0 $ PlainText $ Plain.l10n_Colon l10n , tree0 $ PlainText serie_id ] instance Html5ify Entity where html5ify Entity{..} = do case () of _ | not (TL.null entity_email) -> do H.span ! HA.class_ "no-print" $$ do html5ify $ Tree (PlainEref $ URL $ "mailto:"<>entity_email) $ pure $ tree0 $ PlainText entity_name html5ify $ orgs entity_org H.span ! HA.class_ "print-only" $$ html5ify $ Tree (PlainEref $ URL entity_email) $ pure $ tree0 $ PlainText $ entity_name <> orgs entity_org where orgs = foldMap $ \Entity{entity_name=name, entity_org=org} -> " ("<>name<>orgs org<>")" _ | Just u <- entity_url -> html5ify $ Tree (PlainEref u) $ pure $ tree0 $ PlainText entity_name _ -> html5ify $ tree0 $ PlainText entity_name instance Html5ify Words where html5ify = html5ify . Analyze.plainifyWords instance Html5ify Alias where html5ify Alias{..} = do Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask let mayId = case attrs_id alias_attrs of Just ident | Just [_] <- toList <$> HM.lookup ident all_section -> Just $ identifyTag "" ident Nothing _ -> Nothing H.a ! HA.class_ "alias" !?? mayAttr HA.id mayId $$ mempty instance Html5ify URL where html5ify (URL url) = H.a ! HA.class_ "url" ! HA.href (attrify url) $$ html5ify url instance Html5ify Date where html5ify date@Date{..} = do Loqualization l10n <- composeLift $ RWS.asks reader_l10n case (date_rel, date_role) of ("", "") -> ""::HTML5 (_, "") -> do html5ify date_rel Plain.l10n_Colon l10n _ -> do html5ify date_role Plain.l10n_Colon l10n Plain.l10n_Date date l10n instance Html5ify Reference where html5ify Reference{..} = do Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask State{state_errors=errs@Analyze.Errors{..}, ..} <- composeLift RWS.get H.tr $$ do H.td ! HA.class_ "reference-key" $$ do "["::HTML5 case HM.lookup reference_id errors_reference_ambiguous of Nothing -> H.a ! HA.class_ "reference" ! HA.href (refIdent $ identifyReference "" reference_id Nothing) ! HA.id (attrify $ identifyReference "" reference_id Nothing) $$ html5ify reference_id Just errNum -> do composeLift $ RWS.modify $ \s -> s { state_errors = errs { Analyze.errors_reference_ambiguous = HM.insert reference_id (succNat1 errNum) errors_reference_ambiguous } } H.span ! HA.class_ "reference reference-ambiguous" ! HA.id (attrify $ identifyReference "-ambiguous" reference_id $ Just errNum) $$ html5ify reference_id "]" H.td ! HA.class_ "reference-content" $$ do html5ify reference_about case HM.lookup reference_id all_ref of Nothing -> pure () Just anchs -> when (isNothing $ HM.lookup reference_id errors_reference_ambiguous) $ do H.p ! HA.class_ "ref-backs" $$ html5CommasDot $ (<$> List.zip (toList anchs) [1..]) $ \((_loc, maySection),num) -> H.a ! HA.class_ "ref-back" ! HA.href (refIdent $ identifyReference "" reference_id $ Just $ Nat1 num) $$ html5SectionNumber maySection instance Html5ify XML.Ancestors where html5ify ancs = case toList ancs of [(_n,c)] -> do html5ify $ show c html5ify '.' as -> html5ify $ Text.intercalate "." $ Text.pack . show . snd <$> as instance Html5ify Plain.Plain where html5ify p = do rp <- composeLift $ RWS.asks reader_plainify html5ify $ Plain.runPlain p rp instance Html5ify TCT.Location where html5ify = \case s:|[] -> H.span ! HA.class_ "tct-location" $$ html5ify $ show s ss -> do H.ul ! HA.class_ "tct-location" $$ forM_ ss $ \s -> H.li $$ html5ify $ show s {- instance Html5ify SVG.Element where html5ify svg = html5ify $ B.preEscapedLazyText $ SVG.renderText svg instance Semigroup SVG.Element where (<>) = mappend -} html5Commas :: [HTML5] -> HTML5 html5Commas [] = pure () html5Commas hs = do sequence_ $ List.intersperse ", " hs html5CommasDot :: [HTML5] -> HTML5 html5CommasDot [] = pure () html5CommasDot hs = do html5Commas hs "." html5Lines :: [HTML5] -> HTML5 html5Lines hs = sequence_ $ List.intersperse (html5ify H.br) hs html5Words :: [HTML5] -> HTML5 html5Words hs = sequence_ $ List.intersperse " " hs html5SectionAnchor :: Section -> HTML5 html5SectionAnchor = go mempty . XML.pos_ancestors . section_posXML where go :: XML.Ancestors -> XML.Ancestors -> HTML5 go prev next = case Seq.viewl next of Seq.EmptyL -> pure () a@(_n,rank) Seq.:< as -> do H.a ! HA.href (refIdent $ identify $ prev Seq.|> a) $$ html5ify $ show rank when (not (null as) || null prev) $ do html5ify '.' go (prev Seq.|>a) as html5SectionTo :: Section -> HTML5 html5SectionTo Section{..} = H.a ! HA.href (refIdent $ identify ancestors) $$ html5ify ancestors where ancestors = XML.pos_ancestors section_posXML html5SectionNumber :: Section -> HTML5 html5SectionNumber Section{..} = html5ify $ XML.pos_ancestors section_posXML popNotes :: ComposeRWS Reader Writer State H.MarkupM (Seq [Para]) popNotes = do st <- composeLift RWS.get case {-debug "state_notes" $-} state_notes st of [] -> return mempty curr:next -> do composeLift $ RWS.modify $ \s -> s{state_notes=next} return curr html5Notes :: Seq [Para] -> HTML5 html5Notes notes = do unless (null notes) $ do H.aside ! HA.class_ "notes" $$ do Compose $ pure H.hr H.table $$ H.tbody $$ forM_ notes $ \content -> do num <- composeLift $ do n <- RWS.gets state_note_num_content RWS.modify $ \s -> s{state_note_num_content=succNat1 n} return n H.tr $$ do H.td ! HA.class_ "note-ref" $$ do H.a ! HA.class_ "note-number" ! HA.id ("note."<>attrify num) ! HA.href ("#note."<>attrify num) $$ do html5ify num ". "::HTML5 H.a ! HA.href ("#note-ref."<>attrify num) $$ do "↑" H.td $$ html5ify content html5ifyToC :: Maybe DTC.Nat -> Tree BodyNode -> HTML5 html5ifyToC depth (Tree b bs) = case b of BodySection section@Section{section_about=About{..}, ..} -> do H.li $$ do H.table ! HA.class_ "toc-entry" $$ H.tbody $$ case about_titles of [] -> H.tr $$ do H.td ! HA.class_ "section-number" $$ html5SectionTo section title:titles -> do H.tr $$ do H.td ! HA.class_ "section-number" $$ html5SectionTo section H.td ! HA.class_ "section-title" $$ html5ify $ cleanPlain $ unTitle title forM_ titles $ \t -> H.tr $$ do H.td ! HA.class_ "section-title" $$ html5ify $ cleanPlain $ unTitle t when (maybe True (> Nat 1) depth && not (null sections)) $ H.ul $$ forM_ sections $ html5ifyToC (depth >>= predNat) _ -> mempty where sections = (`Seq.filter` bs) $ \case Tree BodySection{} _ -> True _ -> False html5ifyToF :: [TL.Text] -> HTML5 html5ifyToF types = do figuresByType <- composeLift $ RWS.asks $ Analyze.all_figure . reader_all let figures = Map.unions $ ((\(ty,ts) -> (ty,) <$> ts) <$>) $ HM.toList $ if null types then figuresByType else HM.intersection figuresByType $ HM.fromList [(ty,()) | ty <- types] forM_ (Map.toList figures) $ \(posXML, (type_, title)) -> H.tr $$ do H.td ! HA.class_ "figure-number" $$ H.a ! HA.href (refIdent $ identify posXML) $$ do html5ify type_ html5ify $ XML.pos_ancestors posXML forM_ title $ \ti -> H.td ! HA.class_ "figure-title" $$ html5ify $ cleanPlain $ unTitle ti -- 'Attrify' instance Attrify Plain.Plain where attrify p = attrify $ Plain.runPlain p def