{-# 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 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
-- <eref>
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
">"
-- <tag>
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
-- <at>
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
-- <ref>
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
"]"
-- <iref>
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