{-# 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(..), any, concat, fold) import Data.Function (($), (.), const, on) import Data.Functor ((<$>), (<$)) import Data.Functor.Compose (Compose(..)) import Data.Hashable (hash) import Data.List.NonEmpty (NonEmpty(..)) import Data.Locale hiding (Index) import Data.Maybe (Maybe(..), maybe, mapMaybe, maybeToList, listToMaybe, 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.Category as Cat 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 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 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_section = 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 html5Judgments html5ify err html5DocumentHead head html5ify body html5Head <- writeHTML5Head conf ro endWriter head body 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 {- let (checkedBody,checkState) = let state_collect = Analyze.collect doc in Analyze.check body `S.runState` def { Analyze.state_irefs = foldMap Analyze.irefsOfTerms $ Analyze.all_index state_collect , Analyze.state_collect } let (html5Body, endState) = runComposeRWS def { state_collect {- , state_indexs = (<$> Analyze.all_index state_collect) $ \terms -> (terms,) $ TM.intersection const state_irefs $ Analyze.irefsOfTerms terms , state_notes -} , state_rrefs , state_section = body , state_l10n = loqualize config_locale , state_plainify = def{Plain.reader_l10n = loqualize config_locale} } $ do html5Judgments html5ify state_errors html5DocumentHead head html5ify checkedBody html5Head <- writeHTML5Head conf endState head return $ do let State{..} = endState H.docType H.html ! HA.lang (attrify $ countryCode config_locale) $ do html5Head H.body $ do {- 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 -> Head -> Body -> IO Html writeHTML5Head Config{..} Reader{..} Writer{..} Head{DTC.head_about=About{..}} body = do csss :: Html <- do -- unless (any (\DTC.Link{..} -> rel == "stylesheet" && href /= 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{rel} -> 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 (null about_titles) $ do H.title $ H.toMarkup $ Plain.text reader_plainify $ List.head about_titles forM_ about_links $ \Link{..} -> case rel of "stylesheet" | URL "" <- href -> H.style ! HA.type_ "text/css" $ H.toMarkup $ Plain.text def plain _ -> H.link ! HA.rel (attrify rel) ! HA.href (attrify href) forM_ about_url $ \href -> H.link ! HA.rel "self" ! HA.href (attrify href) unless (TL.null config_generator) $ do H.meta ! HA.name "generator" ! HA.content (attrify config_generator) unless (null about_tags) $ H.meta ! HA.name "keywords" ! HA.content (attrify $ TL.intercalate ", " about_tags) let chapters = (`mapMaybe` toList body) $ \case Tree (BodySection s) _ -> Just s _ -> Nothing forM_ chapters $ \Section{..} -> H.link ! HA.rel "Chapter" ! HA.title (attrify $ plainify section_title) ! 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 html5DocumentHead :: Head -> HTML5 html5DocumentHead Head{DTC.head_about=About{..}, head_judgments} = 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" $$ docHeaders H.td ! HA.class_ "right" $$ docAuthors 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 do -- judgments st <- composeLift RWS.get let sectionJudgments = {-debug "sectionJudgments" $-} HS.fromList head_judgments let opinsBySectionByJudgment = {-debug "opinsBySectionByJudgment" $-} state_opinions st `HM.intersection` HS.toMap sectionJudgments composeLift $ RWS.modify $ \s -> s{ state_judgments = head_judgments , state_opinions = -- NOTE: drop current opinions of the judgments of this section HM.unionWith (const List.tail) (state_opinions s) opinsBySectionByJudgment } unless (null opinsBySectionByJudgment) $ do let choicesJ = Analyze.choicesByJudgment head_judgments forM_ head_judgments $ \judgment@Judgment{..} -> do -- NOTE: preserve the wanted order let opinsBySection = opinsBySectionByJudgment HM.!judgment H.div ! HA.class_ "judgment section-judgment document-judgment" $$ do html5ify judgment { judgment_opinionsByChoice = listToMaybe opinsBySection , judgment_choices = maybe [] snd $ HM.lookup judgment choicesJ } where docHeaders = 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 name) $ header $ do headerName $ html5ify name headerValue $ html5ify $ Tree PlainEref{eref_href=href} plain forM_ about_date $ \d -> header $ do headerName $ l10n_Header_Date l10n headerValue $ html5ify d forM_ about_url $ \href -> header $ do headerName $ l10n_Header_Address l10n headerValue $ html5ify $ tree0 $ PlainEref{eref_href=href} forM_ about_headers $ \Header{..} -> header $ do headerName $ html5ify header_name headerValue $ html5ify header_value docAuthors = 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 -- 'Html5ify' instances 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 Body where html5ify body = localComposeRWS (\ro -> ro{reader_section = 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{..} -> do localComposeRWS (\ro -> ro{reader_section = 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_ section_aliases html5ify st <- composeLift RWS.get do -- judgments let sectionJudgments = -- NOTE: merge inherited judgments with those of thie section, -- while preserving their appearing order. List.nubBy ((==) `on` hash) $ state_judgments st <> section_judgments let opinsBySectionByJudgment = -- NOTE: gather opinions of the judgments of this section. state_opinions st `HM.intersection` HS.toMap (HS.fromList sectionJudgments) let dropChildrenBlocksJudgments = -- NOTE: drop the "phantom" judgments concerning the 'BodyBlock's -- directly children of this 'BodySection'. if (`any`bs) $ \case Tree BodyBlock{} _ -> True _ -> False then List.tail else Cat.id composeLift $ RWS.modify $ \s -> s{ state_judgments = sectionJudgments , state_opinions = -- NOTE: drop current opinions of the judgments of this section HM.unionWith (const $ List.tail . dropChildrenBlocksJudgments) (state_opinions s) opinsBySectionByJudgment } unless (null opinsBySectionByJudgment) $ do composeLift $ RWS.tell def { writer_styles = HS.singleton $ Left "dtc-judgment.css" } H.aside ! HA.class_ "aside" $$ do let choicesJ = Analyze.choicesByJudgment section_judgments forM_ sectionJudgments $ \judgment@Judgment{..} -> do let opinsBySection = opinsBySectionByJudgment HM.!judgment H.div ! HA.class_ "judgment section-judgment" $$ do html5ify judgment { judgment_opinionsByChoice = listToMaybe opinsBySection , judgment_choices = maybe [] snd $ HM.lookup judgment choicesJ } 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 $$ H.tr $$ do H.td ! HA.class_ "section-number" $$ do html5SectionNumber $ XML.pos_ancestors section_posXML H.td ! HA.class_ "section-title" $$ do (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) $$ html5ify section_title html5ify bs do -- judgments composeLift $ RWS.modify $ \s -> s{ state_judgments = state_judgments st } 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_section} <- composeLift RWS.ask forM_ reader_section $ 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), ref) -> H.a ! HA.class_ "index-iref" ! HA.href (refIdent $ identifyIref term $ Just $ Nat1 num) $$ case ref of Left{} -> "0"::HTML5 Right Section{section_posXML=posSection} -> html5ify $ XML.pos_ancestors posSection BlockReferences{..} -> html5CommonAttrs attrs { attrs_classes = "references":attrs_classes attrs , attrs_id = Just $ Ident $ Plain.text def $ XML.pos_ancestors posXML } $ H.div $$ do H.table $$ forM_ refs html5ify BlockGrades{..} -> html5CommonAttrs attrs { attrs_classes = "grades":attrs_classes attrs , attrs_id = Just $ Ident $ Plain.text def $ 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 . Ident . Plain.text def . 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{..} -> do Reader{..} <- composeLift RWS.ask State{state_errors=errs@Analyze.Errors{..}} <- composeLift RWS.get case () of _ | Just num <- HM.lookup tag_ident errors_tag_unknown -> do composeLift $ RWS.modify $ \s -> s { state_errors = errs { Analyze.errors_tag_unknown = HM.adjust succNat1 tag_ident errors_tag_unknown } } H.span ! HA.class_ "tag tag-unknown" ! HA.id (attrify $ identifyTag "-unknown" tag_ident (Just num)) $$ html5ify tag_ident | Just num <- HM.lookup tag_ident errors_tag_ambiguous -> do composeLift $ RWS.modify $ \s -> s { state_errors = errs { Analyze.errors_tag_ambiguous = HM.adjust succNat1 tag_ident errors_tag_ambiguous } } H.span ! HA.class_ "tag tag-ambiguous" ! HA.id (attrify $ identifyTag "-ambiguous" tag_ident (Just num)) $$ html5ify tag_ident | otherwise -> do H.a ! HA.class_ "tag" ! HA.href (refIdent $ identifyTag "" tag_ident Nothing) $$ html5ify tag_ident PlainRref{..} -> do Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask State{state_errors=errs@Analyze.Errors{..}, ..} <- composeLift RWS.get case toList $ HM.lookupDefault def rref_to all_reference of [] -> do let num = HM.lookup rref_to errors_rref_unknown composeLift $ RWS.modify $ \s -> s { state_errors = errs { Analyze.errors_rref_unknown = HM.adjust succNat1 rref_to errors_rref_unknown } } "["::HTML5 H.span ! HA.class_ "reference reference-unknown" ! HA.id (attrify $ identifyReference "-unknown" rref_to num) $$ html5ify rref_to "]" [Reference{..}] -> do let num = HM.lookupDefault (Nat1 1) rref_to state_rrefs composeLift $ RWS.modify $ \s -> s { state_rrefs = HM.insert rref_to (succNat1 num) state_rrefs } let a = H.a ! HA.class_ "reference" ! HA.href (refIdent $ identifyReference "" rref_to Nothing) ! HA.id (attrify $ identifyReference "" rref_to $ Just num) let ref = do "["::HTML5 a $$ html5ify rref_to "]" case toList ps of [] -> ref [Tree (PlainText "") _] -> do refs <- composeLift $ RWS.asks $ Analyze.all_reference . reader_all case toList <$> HM.lookup rref_to refs of Just [Reference{reference_about=About{..}}] -> do forM_ (List.take 1 about_titles) $ \(Title title) -> do html5ify $ Tree PlainQ $ case about_url of Nothing -> title Just u -> pure $ Tree (PlainEref u) title " "::HTML5 ref _ -> mempty _ -> do a $$ html5ify ps H.span ! HA.class_ "print-only" $$ do " "::HTML5 ref _ -> do case toList ps of [] -> mempty [Tree (PlainText "") _] -> mempty _ -> do html5ify ps " "::HTML5 "["::HTML5 H.span ! HA.class_ "reference reference-ambiguous" $$ html5ify rref_to "]" 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 H.p $$ html5CommasDot $ concat $ [ html5Titles about_titles , html5ify <$> about_authors , html5ify <$> maybeToList about_date , html5ify <$> maybeToList about_editor , html5ify <$> about_series ] forM_ about_url $ \u -> do H.p ! HA.class_ "reference-url print-only" $$ do "<"::HTML5 html5ify u ">" 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 about_url of Nothing -> title Just u -> pure $ Tree (PlainEref u) 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" $$ html5ify $ Tree (PlainEref $ URL $ "mailto:"<>entity_email) $ pure $ tree0 $ PlainText entity_name H.span ! HA.class_ "print-only" $$ html5ify $ Tree (PlainEref $ URL entity_email) $ pure $ tree0 $ PlainText $ entity_name <> orgs entity_org where orgs = maybe "" $ \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 = do Loqualization l10n <- composeLift $ RWS.asks reader_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 num -> do composeLift $ RWS.modify $ \s -> s { state_errors = errs { Analyze.errors_reference_ambiguous = HM.insert reference_id (succNat1 num) errors_reference_ambiguous } } H.span ! HA.class_ "reference reference-ambiguous" ! HA.id (attrify $ identifyReference "-ambiguous" reference_id $ Just num) $$ html5ify reference_id "]" H.td ! HA.class_ "reference-content" $$ do html5ify reference_about case HM.lookup reference_id all_rrefs of Nothing -> pure () Just anchs -> when (isNothing $ HM.lookup reference_id errors_reference_ambiguous) $ do H.p ! HA.class_ "reference-rrefs" $$ html5CommasDot $ (<$> List.zip (toList anchs) [1..]) $ \((_loc, maySection),num) -> H.a ! HA.class_ "reference-rref" ! HA.href (refIdent $ identifyReference "" reference_id $ Just $ Nat1 num) $$ case maySection of Left{} -> "0"::HTML5 Right Section{section_posXML=posSection} -> html5ify $ XML.pos_ancestors posSection 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 SVG.Element where html5ify svg = html5ify $ B.preEscapedLazyText $ SVG.renderText svg instance Semigroup SVG.Element where (<>) = mappend -} html5CommasDot :: [HTML5] -> HTML5 html5CommasDot [] = pure () html5CommasDot hs = do sequence_ $ List.intersperse ", " hs "." html5Lines :: [HTML5] -> HTML5 html5Lines hs = sequence_ $ List.intersperse (html5ify H.br) hs html5Words :: [HTML5] -> HTML5 html5Words hs = sequence_ $ List.intersperse " " hs html5SectionNumber :: XML.Ancestors -> HTML5 html5SectionNumber = go mempty 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 html5SectionRef :: XML.Ancestors -> HTML5 html5SectionRef as = H.a ! HA.href (refIdent $ identify as) $$ html5ify as 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{..} -> do H.li $$ do H.table ! HA.class_ "toc-entry" $$ H.tbody $$ H.tr $$ do H.td ! HA.class_ "section-number" $$ html5SectionRef $ XML.pos_ancestors section_posXML H.td ! HA.class_ "section-title" $$ html5ify $ cleanPlain $ unTitle section_title 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