{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hdoc.DTC.Write.HTML5 where
+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(..), join, (=<<), forM, forM_, mapM_, sequence_)
+import Control.Monad (Monad(..), (=<<), forM_, mapM_, sequence_)
import Data.Bool
-import Data.Char (Char)
import Data.Default.Class (Default(..))
import Data.Either (Either(..))
import Data.Eq (Eq(..))
-import Data.Foldable (Foldable(..), concat, any)
-import Data.Function (($), (.), const, on)
-import Data.Functor ((<$>))
+import Data.Foldable (Foldable(..), concat, fold)
+import Data.Function (($), (.), const, on)
+import Data.Functor ((<$>), (<$))
import Data.Functor.Compose (Compose(..))
-import Data.Int (Int)
-import Data.IntMap.Strict (IntMap)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Locale hiding (Index)
-import Data.Map.Strict (Map)
-import Data.Maybe (Maybe(..), maybe, mapMaybe, fromJust, maybeToList, listToMaybe, fromMaybe, isJust)
+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.Sequence (Seq(..))
-import Data.String (String, IsString(..))
-import Data.Text (Text)
+import Data.String (String)
import Data.TreeSeq.Strict (Tree(..), tree0)
-import Data.Tuple (fst, snd)
-import Prelude (mod, (*), Fractional(..), Double, toRational, RealFrac(..))
-import System.FilePath (FilePath, (</>))
+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.State as S
-import qualified Data.Char as Char
+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.IntMap.Strict as IntMap
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
-import qualified Data.Set as Set
import qualified Data.Strict.Maybe as Strict
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
-import qualified Data.Tree as Tree
-import qualified Data.TreeMap.Strict as TreeMap
-import qualified Data.TreeSeq.Strict as TreeSeq
-import qualified Hjugement as MJ
-import qualified Prelude (error)
+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.Check as Check
-import qualified Hdoc.DTC.Collect as Collect
-import qualified Hdoc.DTC.Index as Index
+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
debugWith :: String -> (a -> String) -> a -> a
debugWith msg get a = trace (msg<>": "<>get a) a
-showJudgments :: HM.HashMap (Ident,Ident,Maybe Title) [Tree.Tree [Choice]] -> String
-showJudgments js =
- Tree.drawForest $
- ((show <$>) <$>) $
- -- Tree.Node (Left ("","",Nothing)) $
- (<$> HM.toList js) $ \((j,g,q),ts) ->
- Tree.Node
- (Left (unIdent j,unIdent g,Plain.text def <$> q))
- ((Right <$>) <$> ts)
-
--- * Type 'HTML5'
-type HTML5 = StateMarkup State ()
-instance IsString HTML5 where
- fromString = html5ify
-
--- ** Type 'Config'
-data Config =
- forall locales.
- ( Locales locales
- , Loqualize locales (L10n HTML5)
- , Loqualize locales (Plain.L10n Plain.Plain)
- ) =>
- Config
- { config_css :: Either FilePath TL.Text
- , config_js :: Either FilePath TL.Text
- , config_locale :: LocaleIn locales
- , config_generator :: TL.Text
- }
-instance Default Config where
- def = Config
- { config_css = Right "style/dtc-html5.css"
- , config_js = Right "style/dtc-html5.js"
- , config_locale = LocaleIn @'[EN] en_US
- , config_generator = "https://hackage.haskell.org/package/hdoc"
- }
-
--- ** Type 'State'
-data State = State
- -- RW
- { state_styles :: HS.HashSet (Either FilePath TL.Text)
- , state_scripts :: HS.HashSet FilePath
- , state_notes :: Check.NotesBySection
- , state_judgments :: HS.HashSet Judgment
- , state_opinions :: HM.HashMap Judgment [MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade)]
- -- RO
- , state_section :: TreeSeq.Trees BodyNode
- , state_collect :: Collect.All
- , state_indexs :: Map XML.Pos (Terms, Index.Irefs) -- TODO: could be a list
- , state_rrefs :: HM.HashMap Ident [(Maybe Section,Nat1)]
- , state_plainify :: Plain.State
- , state_l10n :: Loqualization (L10n HTML5)
- }
-instance Default State where
- def = State
- { state_styles = HS.fromList [Left "dtc-html5.css"]
- , state_scripts = def
- , state_section = def
- , state_collect = def
- , state_indexs = def
- , state_rrefs = def
- , state_notes = def
- , state_plainify = def
- , state_l10n = Loqualization EN_US
- , state_judgments = HS.empty
- , state_opinions = def
- }
-
writeHTML5 :: Config -> DTC.Document -> IO Html
-writeHTML5 conf@Config{..} doc@DTC.Document{..} = do
- let collect@Collect.All{..} = Collect.collect doc
- let (checkedBody,checkState) =
- Check.check body `S.runState` def
- { Check.state_irefs = foldMap Index.irefsOfTerms all_index
- , Check.state_collect = collect
+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 (html5Body, endState) =
- let Check.State{..} = checkState in
- runStateMarkup def
- { state_collect
- , state_indexs =
- (<$> all_index) $ \terms ->
+ 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,) $
- TreeMap.intersection const state_irefs $
- Index.irefsOfTerms terms
- , state_rrefs
- , state_notes
- , state_section = body
- , state_l10n = loqualize config_locale
- , state_plainify = def{Plain.state_l10n = loqualize config_locale}
- } $ do
- html5Judgments
- html5ify state_errors
- html5DocumentHead head
- html5ify checkedBody
- html5Head <- writeHTML5Head conf endState head
+ 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
- let State{..} = endState
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" $
-}
html5Body
-writeHTML5Head :: Config -> State -> Head -> IO Html
-writeHTML5Head Config{..} State{..} Head{DTC.about=About{..}} = do
- csss :: Html <-
- -- unless (any (\DTC.Link{..} -> rel == "stylesheet" && href /= URL "") links) $ do
- (`foldMap` state_styles) $ \case
+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 $ H.style ! HA.type_ "text/css" $
+ 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
- {-
- 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
- -}
scripts :: Html <-
- (`foldMap` state_scripts) $ \script -> do
+ (`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)
+ {-
+ if not (any (\DTC.Link{link_rel} -> link_rel == "script") links)
then do
else
mempty
$ 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 titles) $ do
- H.title $
- H.toMarkup $ Plain.text state_plainify $ List.head titles
- forM_ 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_ 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 tags) $
- H.meta ! HA.name "keywords"
- ! HA.content (attrify $ TL.intercalate ", " tags)
- let chapters =
- (`mapMaybe` toList state_section) $ \case
- Tree (BodySection s) _ -> Just s
- _ -> Nothing
- forM_ chapters $ \Section{..} ->
- H.link ! HA.rel "Chapter"
- ! HA.title (attrify $ plainify title)
- ! HA.href (refIdent $ identify xmlPos)
+ 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
-html5DocumentHead :: Head -> HTML5
-html5DocumentHead Head{DTC.about=About{..}, judgments} = do
- st <- liftStateMarkup S.get
- unless (null authors) $ do
- H.div ! HA.class_ "document-head" $$
- H.table $$ do
+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
- H.tr $$ do
- H.td ! HA.class_ "left" $$ docHeaders
- H.td ! HA.class_ "right" $$ docAuthors
- unless (null titles) $ do
- H.div ! HA.class_ "title"
- ! HA.id "document-title." $$ do
- forM_ titles $ \title ->
- H.h1 ! HA.id (attrify $ identifyTitle (Plain.state_l10n $ state_plainify st) title) $$
- html5ify title
- do -- judgments
- let sectionJudgments = HS.fromList judgments
- let opinsBySectionByJudgment = state_opinions st `HM.intersection` HS.toMap sectionJudgments
- liftStateMarkup $ S.modify' $ \s ->
- s{ state_judgments = sectionJudgments
- , 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 = Collect.choicesByJudgment judgments
- forM_ (HM.toList opinsBySectionByJudgment) $ \(judgment@Judgment{question},opinsBySection) -> do
- H.div ! HA.class_ "judgment section-judgment document-judgment" $$ do
- let choices = maybe [] snd $ HM.lookup judgment choicesJ
- let opins = List.head opinsBySection
- html5Judgment question choices opins
- where
- docHeaders =
- H.table ! HA.class_ "document-headers" $$
- H.tbody $$ do
- Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
- forM_ series $ \s@Serie{id=id_, name} ->
- header $
- case urlSerie s of
- Nothing -> do
- headerName $ html5ify name
- headerValue $ html5ify id_
- Just href -> do
- headerName $ html5ify name
- headerValue $
- H.a ! HA.href (attrify href) $$
- html5ify id_
- forM_ links $ \Link{..} ->
- unless (TL.null $ unName name) $
+ 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 $ html5ify name
- headerValue $ html5ify $ Tree PlainEref{href} plain
- forM_ date $ \d ->
- header $ do
- headerName $ l10n_Header_Date l10n
- headerValue $ html5ify d
- forM_ url $ \href ->
- header $ do
- headerName $ l10n_Header_Address l10n
- headerValue $ html5ify $ tree0 $ PlainEref{href}
- forM_ headers $ \Header{..} ->
- header $ do
- headerName $ html5ify name
- headerValue $ html5ify value
- docAuthors =
- H.table ! HA.class_ "document-authors" $$
- H.tbody $$ do
- forM_ 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 <- liftStateMarkup $ S.gets state_l10n
- Plain.l10n_Colon l10n
- headerValue :: HTML5 -> HTML5
- headerValue hdr =
- H.td ! HA.class_ "header-value" $$ do
- hdr
-
--- * Class 'Html5ify'
-class Html5ify a where
- html5ify :: a -> HTML5
-instance Html5ify H.Markup where
- html5ify = Compose . return
-instance Html5ify Char where
- html5ify = html5ify . H.toMarkup
-instance Html5ify Text where
- html5ify = html5ify . H.toMarkup
-instance Html5ify TL.Text where
- html5ify = html5ify . H.toMarkup
-instance Html5ify String where
- html5ify = html5ify . H.toMarkup
-instance Html5ify Title where
- html5ify (Title t) = html5ify t
-instance Html5ify Ident where
- html5ify (Ident i) = html5ify i
-instance Html5ify Int where
- html5ify = html5ify . show
-instance Html5ify Name where
- html5ify (Name i) = html5ify i
-instance Html5ify Nat where
- html5ify (Nat n) = html5ify n
-instance Html5ify Nat1 where
- html5ify (Nat1 n) = html5ify n
-instance Html5ify a => Html5ify (Maybe a) where
- html5ify = foldMap html5ify
-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 Check.Errors where
- html5ify Check.Errors{..} = do
- st@State
- { state_collect = Collect.All{..}
- , state_l10n = Loqualization (l10n::FullLocale lang)
- , ..
- } <- liftStateMarkup S.get
- let errors :: [ ( Int{-errKind-}
- , HTML5{-errKindDescr-}
- , [(Plain{-errTypeKey-}, [(TCT.Location{-errPos-}, Ident{-errId-})])]
- ) ] =
- List.zipWith
- (\errKind (errKindDescr, errByPosByKey) ->
- (errKind, errKindDescr l10n, errByPosByKey))
- [1::Int ..]
- [ (l10n_Error_Tag_unknown , errorTag st "-unknown" errors_tag_unknown)
- , (l10n_Error_Tag_ambiguous , errorTag st "-ambiguous" errors_tag_ambiguous)
- , (l10n_Error_Rref_unknown , errorReference "-unknown" errors_rref_unknown)
- , (l10n_Error_Reference_ambiguous, errorReference "-ambiguous" errors_reference_ambiguous)
- ]
- let numErrors = Nat $ sum $ (<$> errors) $ \(_typ, _descr, errByPosByKey) ->
- sum $ length . snd <$> errByPosByKey
- when (numErrors > Nat 0) $ do
- liftStateMarkup $ S.put st
- { state_styles =
- HS.insert (Left "dtc-errors.css") $
- HS.insert (Right $
- -- NOTE: Implement a CSS-powered show/hide logic, using :target
- "\n@media screen {" <>
- "\n\t.error-filter:target .errors-list > li {display:none;}" <>
- (`foldMap` errors) (\(num, _description, errs) ->
- if null errs then "" else
- let err = "error-type"<>TL.pack (show num)<>"\\." in
- "\n\t.error-filter#"<>err<>":target .errors-list > li."<>err
- <>" {display:list-item}" <>
- "\n\t.error-filter#"<>err<>":target .errors-nav > ul > li."<>err
- <>" {list-style-type:disc;}"
- ) <>
- "\n}"
- )
- state_styles
- }
- filterIds errors $ H.div ! HA.class_ "document-errors" ! HA.id "document-errors." $$ do
- H.nav ! HA.class_ "errors-nav" $$ do
- H.p ! HA.class_ "errors-all" $$
- H.a ! HA.href (refIdent "document-errors.") $$ do
- l10n_Errors_All l10n numErrors :: HTML5
- H.ul $$
- forM_ errors $
- \(errKind, errKindDescr, errs) -> do
- unless (null errs) $ do
- H.li ! HA.class_ (attrify $ errorType errKind) $$ do
- H.a ! HA.href (refIdent $ errorType errKind) $$ do
- errKindDescr
- " ("::HTML5
- html5ify $ sum $ length . snd <$> errs
- ")"
- H.ol ! HA.class_ "errors-list" $$ do
- let errByPosByKey :: Map TCT.Location{-errPos-} ( Int{-errKind-}
- , HTML5{-errKindDescr-}
- , Plain{-errKey-}
- , [(TCT.Location{-errPos-}, Ident{-errId-})] ) =
- (`foldMap`errors) $ \(errKind, errKindDescr, errByKey) ->
- (`foldMap`errByKey) $ \(errKey, errByPos) ->
- Map.singleton
- (fst $ List.head errByPos)
- -- NOTE: sort using the first position of this errKind with this errKey.
- (errKind, errKindDescr, errKey, errByPos)
- forM_ errByPosByKey $
- \(errKind, errKindDescr, errKey, errByPos) -> do
- H.li ! HA.class_ (attrify $ errorType errKind) $$ do
- H.span ! HA.class_ "error-message" $$ do
- H.span ! HA.class_ "error-kind" $$ do
- errKindDescr
- Plain.l10n_Colon l10n :: HTML5
- html5ify errKey
- H.ol ! HA.class_ "error-position" $$
- forM_ errByPos $ \(errPos, errId) ->
- H.li $$
- H.a ! HA.href (refIdent errId) $$
- html5ify errPos
- where
- errorType num = identify $ "error-type"<>show num<>"."
- -- | Nest error id= to enable showing/hidding errors using :target pseudo-class.
- filterIds [] h = h
- filterIds ((num, _description, errs):es) h =
- if null errs
- then filterIds es h
- else do
- H.div ! HA.class_ "error-filter"
- ! HA.id (attrify $ errorType num) $$
- filterIds es h
- errorTag :: State -> Ident -> HM.HashMap Title (Seq TCT.Location) -> [(Plain, [(TCT.Location,Ident)])]
- errorTag State{state_plainify=Plain.State{state_l10n}} suffix errs =
- (<$> HM.toList errs) $ \(Title tag, errPositions) ->
- ( tag
- , List.zipWith
- (\num -> (,identifyTag suffix state_l10n tag (Just $ Nat1 num)))
- [1::Int ..] (toList errPositions)
- )
- errorReference :: Ident -> HM.HashMap Ident (Seq TCT.Location) -> [(Plain, [(TCT.Location,Ident)])]
- errorReference suffix errs =
- (<$> HM.toList errs) $ \(id, errPositions) ->
- ( pure $ tree0 $ PlainText $ unIdent id
- , List.zipWith
- (\num -> (,identifyReference suffix id (Just $ Nat1 num)))
- [1::Int ..] (toList errPositions)
- )
+ 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 = do
- liftStateMarkup $ S.modify' $ \s -> s{state_section = body}
- mapM_ html5ify body
- case Seq.viewr body of
- _ Seq.:> Tree BodyBlock{} _ -> do
- notes <- liftStateMarkup $ S.gets state_notes
- maybe mempty html5Notes $
- Map.lookup mempty notes
- _ -> mempty
+ 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) =
+ html5ify (Tree b bs) = do
case b of
BodyBlock blk -> html5ify blk
- BodySection Section{..} -> do
- st@State{state_collect=Collect.All{..}} <- liftStateMarkup S.get
- liftStateMarkup $ S.modify' $ \s -> s{state_section = bs}
- do -- notes
- let mayNotes = do
- sectionPosPath <- XML.ancestors $ XML.pos_ancestors xmlPos
- let (sectionNotes, notes) = Map.updateLookupWithKey (\_ _ -> Nothing) sectionPosPath $ state_notes st
- (,notes) <$> sectionNotes
- case mayNotes of
- Nothing -> mempty
- Just (sectionNotes, state_notes) -> do
- liftStateMarkup $ S.modify' $ \s -> s{state_notes}
- html5Notes sectionNotes
- html5CommonAttrs attrs{classes="section":classes attrs, id=Nothing} $
- H.section ! HA.id (attrify $ identify xmlPos) $$ do
- forM_ aliases html5ify
- do -- judgments
- let sectionJudgments = state_judgments st `HS.union` HS.fromList judgments
- let opinsBySectionByJudgment = state_opinions st `HM.intersection` HS.toMap 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
- liftStateMarkup $ S.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
- liftStateMarkup $ S.modify' $ \s -> s
- { state_styles = HS.insert (Left "dtc-judgment.css") $ state_styles s }
- H.aside ! HA.class_ "aside" $$ do
- let choicesJ = Collect.choicesByJudgment judgments
- forM_ (HM.toList opinsBySectionByJudgment) $ \(judgment@Judgment{question},opinsBySection) -> do
- H.div ! HA.class_ "judgment section-judgment" $$ do
- let choices = maybe [] snd $ HM.lookup judgment choicesJ
- let opins = List.head opinsBySection
- html5Judgment question choices opins
- let mayId =
- case toList <$> HM.lookup title all_section of
- Just [_] -> Just $ identifyTitle (Plain.state_l10n $ state_plainify st) title
- _ -> 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 xmlPos
- H.td ! HA.class_ "section-title" $$ do
- (case List.length $ XML.pos_ancestors xmlPos of
- 0 -> H.h1
- 1 -> H.h2
- 2 -> H.h3
- 3 -> H.h4
- 4 -> H.h5
- 5 -> H.h6
- _ -> H.h6) $$
- html5ify title
- forM_ bs html5ify
- do -- judgments
- liftStateMarkup $ S.modify' $ \s ->
- s{ state_judgments = state_judgments st }
- do -- notes
- notes <- liftStateMarkup $ S.gets state_notes
- maybe mempty html5Notes $
- Map.lookup (XML.pos_ancestors xmlPos) notes
- liftStateMarkup $ S.modify' $ \s -> s{state_section = state_section st}
+ 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
- { classes = "page-break":"print-only":classes 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 xmlPos) $$ do
+ ! HA.id (attrify $ identify posXML) $$ do
H.span ! HA.class_ "toc-name" $$
- H.a ! HA.href (refIdent $ identify xmlPos) $$ do
- Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
+ H.a ! HA.href (refIdent $ identify posXML) $$ do
+ Loqualization l10n <- composeLift $ RWS.asks reader_l10n
Plain.l10n_Table_of_Contents l10n
H.ul $$ do
- State{state_section} <- liftStateMarkup S.get
- forM_ state_section $ html5ifyToC depth
+ Reader{reader_body} <- composeLift RWS.ask
+ forM_ reader_body $ html5ifyToC depth
BlockToF{..} -> do
H.nav ! HA.class_ "tof"
- ! HA.id (attrify $ identify xmlPos) $$
+ ! HA.id (attrify $ identify posXML) $$
H.table ! HA.class_ "tof" $$
H.tbody $$
html5ifyToF types
forM_ blocks html5ify
BlockFigure{..} ->
html5CommonAttrs attrs
- { classes = "figure":("figure-"<>type_):classes attrs
- , DTC.id = Just $ Ident $ Plain.text def $ XML.pos_ancestorsWithFigureNames xmlPos
+ { 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 xmlPos) $$ mempty
+ 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 xmlPos) $$ do
+ H.a ! HA.href (refIdent $ identify $ XML.pos_ancestorsWithFigureNames posXML) $$ do
html5ify type_
- html5ify $ XML.pos_ancestorsWithFigureNames xmlPos
+ html5ify $ XML.pos_ancestorsWithFigureNames posXML
forM_ mayTitle $ \title -> do
H.td ! HA.class_ "figure-colon" $$ do
unless (TL.null type_) $ do
- Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
+ 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{xmlPos} -> do
- st@State{..} <- liftStateMarkup S.get
- liftStateMarkup $ S.put st
- { state_styles = HS.insert (Left "dtc-index.css") state_styles }
- let (allTerms,refsByTerm) = state_indexs Map.!xmlPos
- let chars = Index.termsByChar allTerms
+ 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 xmlPos) $$ do
+ ! HA.id (attrify $ identify posXML) $$ do
H.nav ! HA.class_ "index-nav" $$ do
forM_ (Map.keys chars) $ \char ->
- H.a ! HA.href (refIdent (identify xmlPos <> "." <> identify 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 xmlPos <> "." <> identify char
+ let i = identify posXML <> "." <> identify char
H.a ! HA.id (attrify i)
! HA.href (refIdent i) $$
html5ify char
H.dt $$
H.ul ! HA.class_ "index-aliases" $$
forM_ (List.take 1 aliases) $ \term -> do
- H.li ! HA.id (attrify $ identifyIref term) $$
+ H.li ! HA.id (attrify $ identifyIref term Nothing) $$
html5ify term
- H.dd $$
- let anchs =
- List.sortBy (compare `on` DTC.section . snd) $
- (`foldMap` aliases) $ \words ->
- fromJust $ do
- path <- Index.pathFromWords words
- Strict.maybe Nothing (Just . ((words,) <$>) . List.reverse) $
- TreeMap.lookup path refsByTerm in
+ 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 $
- (<$> anchs) $ \(term,Anchor{..}) ->
- H.a ! HA.class_ "index-iref"
- ! HA.href (refIdent $ identifyIrefCount term count) $$
- html5ify $ XML.pos_ancestors section
+ (<$> 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
- { classes = "references":classes attrs
- , DTC.id = Just $ Ident $ Plain.text def $ XML.pos_ancestors xmlPos
+ { 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
- { classes = "grades":classes attrs
- , DTC.id = Just $ Ident $ Plain.text def $ XML.pos_ancestors xmlPos
+ { 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
-- os :: Opinions (Map judge (Opinion choice grade))
mempty
-- html5ify $ show b
- BlockJudges{..} ->
- html5CommonAttrs attrs
- { classes = "judges":classes attrs
- , DTC.id = Just $ Ident $ Plain.text def $ XML.pos_ancestors xmlPos
- } $
- H.div $$ do
- mempty
+ BlockJudges js -> html5ify js
instance Html5ify Para where
html5ify = \case
ParaItem{..} ->
html5CommonAttrs def
- { classes="para":cls item
+ { attrs_classes = "para":cls item
} $
html5ify item
ParaItems{..} ->
html5CommonAttrs attrs
- { classes = "para":classes attrs
- , DTC.id = id_ xmlPos
+ { 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
+ id_ = Just . identify . XML.pos_ancestors
cls = \case
- ParaPlain{} -> []
- ParaArtwork{..} -> ["artwork", "artwork-"<>type_]
- ParaQuote{..} -> ["quote", "quote-"<>type_]
- ParaComment{} -> []
- ParaOL{} -> ["ol"]
- ParaUL{} -> ["ul"]
- ParaJudgment{} -> ["judgment"]
+ 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
ParaQuote{..} -> H.div $$ do html5ify paras
ParaComment t -> html5ify $ H.Comment (H.String $ TL.unpack t) ()
ParaOL items ->
- H.table $$ do
- H.tbody $$
- forM_ items $ \ListItem{..} -> do
- H.tr $$ do
- H.td ! HA.class_ "name" $$ do
- html5ify name
- "."::HTML5
- H.td ! HA.class_ "value" $$
- html5ify paras
+ 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 Judgment where
- html5ify Judgment{..} = do
- st <- liftStateMarkup S.get
- H.div $$ do
- let judgmentGrades =
- maybe (Prelude.error $ show grades) MJ.grades $ -- unknown grades
- HM.lookup grades (Collect.all_grades $ state_collect st)
- let judgmentJudges =
- fromMaybe (Prelude.error $ show judges) $ -- unknown judges
- HM.lookup judges (Collect.all_judges $ state_collect st)
- let defaultGradeByJudge =
- let defaultGrade =
- List.head
- [ g | g <- Set.toList judgmentGrades
- , isDefault $ MJ.unRank g
- ] in
- HM.fromList
- [ (name, defaultGrade`fromMaybe`judgeDefaultGrade)
- | DTC.Judge{name,defaultGrades} <- judgmentJudges
- , let judgeDefaultGrade = do
- jdg <- listToMaybe [g | (n,g) <- defaultGrades, n == grades]
- listToMaybe
- [ g | g <- Set.toList judgmentGrades
- , let DTC.Grade{name=n} = MJ.unRank g
- , n == jdg
- ]
- ]
- judgmentChoices <- forM choices $ \c@DTC.Choice{opinions} -> do
- gradeByJudge <- forM opinions $ \DTC.Opinion{judge,grade} -> do
- let grd =
- fromMaybe (Prelude.error $ show grade) $ -- unknown grade
- listToMaybe
- [ MJ.singleGrade g | g <- Set.toList judgmentGrades
- , let Grade{name} = MJ.unRank g
- , name == grade
- ]
- return (judge, grd)
- case MJ.opinions defaultGradeByJudge $ HM.fromList gradeByJudge of
- (ok,ko) | null ko -> return (c, ok)
- | otherwise -> Prelude.error $ show ko -- unknown judge
- -- TODO: handle ko
- html5Judgment question choices $ HM.fromList judgmentChoices
instance Html5ify [Para] where
html5ify = mapM_ html5ify
instance Html5ify Plain where
html5ify curr
html5ify next
instance Html5ify (Tree PlainNode)
- where html5ify (Tree n ls) =
+ where html5ify (Tree n ps) =
case n of
PlainBreak -> html5ify H.br
PlainText t -> html5ify t
- PlainGroup -> html5ify ls
- PlainB -> H.strong $$ html5ify ls
- PlainCode -> H.code $$ html5ify ls
- PlainDel -> H.del $$ html5ify ls
+ PlainGroup -> html5ify ps
+ PlainB -> H.strong $$ html5ify ps
+ PlainCode -> H.code $$ html5ify ps
+ PlainDel -> H.del $$ html5ify ps
PlainI -> do
- i <- liftStateMarkup $ do
- i <- S.gets $ Plain.state_italic . state_plainify
- S.modify $ \s ->
- s{state_plainify=
- (state_plainify s){Plain.state_italic=
- not i}}
- return i
+ i <- composeLift $ RWS.asks reader_italic
H.em ! HA.class_ (if i then "even" else "odd") $$
- html5ify ls
- liftStateMarkup $
- S.modify $ \s ->
- s{state_plainify=
- (state_plainify s){Plain.state_italic=i}}
+ localComposeRWS (\ro -> ro{reader_italic=not i}) $
+ html5ify ps
PlainSpan{..} ->
html5CommonAttrs attrs $
- H.span $$ html5ify ls
- PlainSub -> H.sub $$ html5ify ls
- PlainSup -> H.sup $$ html5ify ls
- PlainSC -> H.span ! HA.class_ "smallcaps" $$ html5ify ls
- PlainU -> H.span ! HA.class_ "underline" $$ html5ify ls
- PlainNote{..} ->
- case number of
- Nothing -> Prelude.error "[BUG] PlainNote has no number."
- Just num ->
- H.a ! HA.class_ "note-ref"
- ! HA.id ("note-ref."<>attrify num)
- ! HA.href ("#note."<>attrify num) $$
- html5ify num
+ 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 <- liftStateMarkup $ S.gets state_l10n
- Plain.l10n_Quote (html5ify $ Tree PlainI ls) l10n
- PlainEref{..} ->
- H.a ! HA.class_ "eref"
- ! HA.href (attrify href) $$
- if null ls
- then html5ify $ unURL href
- else html5ify ls
- PlainIref{..} ->
- case anchor of
- Nothing -> html5ify ls
- Just Anchor{count} ->
- H.span ! HA.class_ "iref"
- ! HA.id (attrify $ identifyIrefCount term count) $$
- html5ify ls
- PlainTag{error} -> do
- st <- liftStateMarkup S.get
- let l10n = Plain.state_l10n $ state_plainify st
- case error of
- Nothing ->
- H.a ! HA.class_ "tag"
- ! HA.href (refIdent $ identifyTitle l10n $ Title ls) $$
- html5ify ls
- Just (ErrorTarget_Unknown num) ->
- H.span ! HA.class_ "tag tag-unknown"
- ! HA.id (attrify $ identifyTag "-unknown" l10n ls (Just num)) $$
- html5ify ls
- Just (ErrorTarget_Ambiguous num) ->
- H.span ! HA.class_ "tag tag-ambiguous"
- ! HA.id (attrify $ identifyTag "-ambiguous" l10n ls num) $$
- html5ify ls
- PlainRref{..} -> do
- case error of
- Nothing ->
- let ref = 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
- H.a ! HA.class_ "reference"
- ! HA.href (refIdent $ identifyReference "" to Nothing)
- ! HA.id (attrify $ identifyReference "" to number) $$
- html5ify to
- "]" in
- case toList ls of
+ 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 <- liftStateMarkup $ S.gets $ Collect.all_reference . state_collect
- case toList <$> HM.lookup to refs of
- Just [Reference{about=About{..}}] -> do
- forM_ (List.take 1 titles) $ \(Title title) -> 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 url of
- Nothing -> title
- Just u -> pure $ Tree (PlainEref u) title
+ case List.filter ((\rel -> rel == "" || rel == "self") . link_rel) about_links of
+ [] -> title
+ Link{..}:_ -> pure $ Tree (PlainEref link_url) title
" "::HTML5
ref
_ -> mempty
_ -> do
- H.a ! HA.class_ "reference"
- ! HA.href (refIdent $ identifyReference "" to Nothing)
- ! HA.id (attrify $ identifyReference "" to number) $$
- html5ify ls
+ a $$ html5ify ps
H.span ! HA.class_ "print-only" $$ do
" "::HTML5
ref
- Just (ErrorTarget_Unknown num) -> do
- "["::HTML5
- H.span ! HA.class_ "reference reference-unknown"
- ! HA.id (attrify $ identifyReference "-unknown" to $ Just num) $$
- html5ify to
- "]"
- Just (ErrorTarget_Ambiguous num) -> do
- case toList ls of
+ -- ambiguous
+ _ -> do
+ case toList ps of
[] -> mempty
[Tree (PlainText "") _] -> mempty
_ -> do
- html5ify ls
+ html5ify ps
" "::HTML5
- "["::HTML5
- H.span ! HA.class_ "reference reference-ambiguous"
- !?? mayAttr HA.id (attrify . identifyReference "-ambiguous" to . Just <$> num) $$
- html5ify to
- "]"
+ 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
- html5Lines
- [ html5CommasDot $ concat $
- [ html5Titles titles
- , html5ify <$> authors
- , html5ify <$> maybeToList date
- , html5ify <$> maybeToList editor
- , html5ify <$> series
+ Loqualization l10n <- composeLift $ RWS.asks reader_l10n
+ H.p $$
+ html5CommasDot $ concat
+ [ html5Titles about_titles
+ , html5ify <$> about_authors
+ , html5ify <$> about_dates
+ , html5ify <$> about_series
]
- , forM_ url $ \u ->
- H.span ! HA.class_ "print-only" $$ do
- "<"::HTML5
- html5ify u
- ">"
- ]
+ 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 = []
where
joinTitles = fold . List.intersperse sep . toList
sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
- html5Title (Title title) =
- html5ify $ Tree PlainQ $
- case url of
- Nothing -> title
- Just u -> pure $ Tree (PlainEref u) title
+ 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{id=id_, name} = do
- Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
+ html5ify s@Serie{..} = do
+ Loqualization l10n <- composeLift $ RWS.asks reader_l10n
case urlSerie s of
Nothing -> do
- html5ify name
+ html5ify serie_name
Plain.l10n_Colon l10n :: HTML5
- html5ify id_
+ html5ify serie_id
Just href -> do
html5ify $
- Tree PlainEref{href} $
+ Tree PlainEref{eref_href=href} $
Seq.fromList
- [ tree0 $ PlainText $ unName name
+ [ tree0 $ PlainText $ unName serie_name
, tree0 $ PlainText $ Plain.l10n_Colon l10n
- , tree0 $ PlainText id_
+ , tree0 $ PlainText serie_id
]
instance Html5ify Entity where
html5ify Entity{..} = do
case () of
- _ | not (TL.null email) -> do
- H.span ! HA.class_ "no-print" $$
+ _ | not (TL.null entity_email) -> do
+ H.span ! HA.class_ "no-print" $$ do
html5ify $
- Tree (PlainEref $ URL $ "mailto:"<>email) $
- pure $ tree0 $ PlainText name
+ Tree (PlainEref $ URL $ "mailto:"<>entity_email) $
+ pure $ tree0 $ PlainText entity_name
+ html5ify $ orgs entity_org
H.span ! HA.class_ "print-only" $$
html5ify $
- Tree PlainGroup $ Seq.fromList
- [ tree0 $ PlainText name
- , tree0 $ PlainText " <"
- , Tree (PlainEref $ URL $ "mailto:"<>email) $
- pure $ tree0 $ PlainText email
- , tree0 $ PlainText ">"
- ]
- _ | Just u <- url ->
+ 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 name
+ pure $ tree0 $ PlainText entity_name
_ ->
html5ify $
- tree0 $ PlainText name
- forM_ org $ \o -> do
- " ("::HTML5
- html5ify o
- ")"::HTML5
+ tree0 $ PlainText entity_name
instance Html5ify Words where
- html5ify = html5ify . Index.plainifyWords
+ html5ify = html5ify . Analyze.plainifyWords
instance Html5ify Alias where
html5ify Alias{..} = do
- st@State{state_collect=Collect.All{..}} <- liftStateMarkup S.get
- let l10n = Plain.state_l10n $ state_plainify st
- case toList <$> HM.lookup title all_section of
- Just [_] ->
- H.a ! HA.class_ "alias"
- ! HA.id (attrify $ identifyTitle l10n title) $$
- mempty
- _ -> mempty
+ 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_ "eref"
+ H.a ! HA.class_ "url"
! HA.href (attrify url) $$
html5ify url
instance Html5ify Date where
- html5ify date = do
- Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
+ 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{..} =
+ 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" $$
- html5ify $ tree0 PlainRref
- { number = Nothing
- , locTCT = def
- , to = id
- , error = (<$> error) $ \case
- ErrorAnchor_Ambiguous num -> ErrorTarget_Ambiguous (Just num)
- }
+ 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 about
- rrefs <- liftStateMarkup $ S.gets state_rrefs
- case HM.lookup id rrefs of
+ html5ify reference_about
+ case HM.lookup reference_id all_ref of
Nothing -> pure ()
Just anchs ->
- H.span ! HA.class_ "reference-rrefs" $$
- html5CommasDot $
- (<$> List.reverse anchs) $ \(maySection,num) ->
- H.a ! HA.class_ "reference-rref"
- ! HA.href (refIdent $ identifyReference "" id $ Just num) $$
- case maySection of
- Nothing -> "0"::HTML5
- Just Section{xmlPos=posSection} -> html5ify $ XML.pos_ancestors posSection
+ 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
Text.pack . show . snd <$> as
instance Html5ify Plain.Plain where
html5ify p = do
- sp <- liftStateMarkup $ S.gets state_plainify
- let (t,sp') = Plain.runPlain p sp
- html5ify t
- liftStateMarkup $ S.modify $ \s -> s{state_plainify=sp'}
+ 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 =
(<>) = mappend
-}
+html5Commas :: [HTML5] -> HTML5
+html5Commas [] = pure ()
+html5Commas hs = do
+ sequence_ $ List.intersperse ", " hs
+
html5CommasDot :: [HTML5] -> HTML5
html5CommasDot [] = pure ()
html5CommasDot hs = do
- sequence_ $ List.intersperse ", " hs
+ html5Commas hs
"."
html5Lines :: [HTML5] -> HTML5
html5Words :: [HTML5] -> HTML5
html5Words hs = sequence_ $ List.intersperse " " hs
-html5AttrClass :: [TL.Text] -> HTML5 -> HTML5
-html5AttrClass = \case
- [] -> Cat.id
- cls ->
- Compose .
- (H.AddCustomAttribute "class"
- (H.String $ TL.unpack $ TL.unwords cls) <$>) .
- getCompose
-
-html5AttrId :: Ident -> HTML5 -> HTML5
-html5AttrId (Ident id_) =
- Compose .
- (H.AddCustomAttribute "id"
- (H.String $ TL.unpack id_) <$>) .
- getCompose
-
-html5CommonAttrs :: CommonAttrs -> HTML5 -> HTML5
-html5CommonAttrs CommonAttrs{id=id_, ..} =
- html5AttrClass classes .
- maybe Cat.id html5AttrId id_
-
-html5SectionNumber :: XML.Ancestors -> HTML5
-html5SectionNumber = go mempty
+html5SectionAnchor :: Section -> HTML5
+html5SectionAnchor = go mempty . XML.pos_ancestors . section_posXML
where
go :: XML.Ancestors -> XML.Ancestors -> HTML5
go prev next =
html5ify '.'
go (prev Seq.|>a) as
-html5SectionRef :: XML.Ancestors -> HTML5
-html5SectionRef as =
- H.a ! HA.href (refIdent $ identify as) $$
- html5ify as
+html5SectionTo :: Section -> HTML5
+html5SectionTo Section{..} =
+ H.a ! HA.href (refIdent $ identify ancestors) $$
+ html5ify ancestors
+ where ancestors = XML.pos_ancestors section_posXML
-html5Notes :: IntMap [Para] -> HTML5
-html5Notes notes =
- H.aside ! HA.class_ "notes" $$ do
- Compose $ pure H.hr
- H.table $$
- H.tbody $$
- forM_ (IntMap.toList notes) $ \(number,content) ->
- H.tr $$ do
- H.td ! HA.class_ "note-ref" $$ do
- H.a ! HA.class_ "note-number"
- ! HA.id ("note."<>attrify number)
- ! HA.href ("#note."<>attrify number) $$ do
- html5ify number
- ". "::HTML5
- H.a ! HA.href ("#note-ref."<>attrify number) $$ do
- "↑"
- H.td $$
- html5ify content
+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{..} -> do
+ BodySection section@Section{section_about=About{..}, ..} -> 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 xmlPos
- H.td ! HA.class_ "section-title" $$
- html5ify $ cleanPlain $ unTitle title
+ 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 $
html5ifyToF :: [TL.Text] -> HTML5
html5ifyToF types = do
- figuresByType <- liftStateMarkup $ S.gets $ Collect.all_figure . state_collect
+ figuresByType <- composeLift $ RWS.asks $ Analyze.all_figure . reader_all
let figures =
- Map.foldMapWithKey (\ty -> ((ty,) <$>)) $
+ Map.unions $
+ ((\(ty,ts) -> (ty,) <$> ts) <$>) $
+ HM.toList $
if null types
then figuresByType
else
- Map.intersection figuresByType $
- Map.fromList [(ty,()) | ty <- types]
- forM_ (Map.toList figures) $ \(xmlPos, (type_, title)) ->
+ 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 xmlPos) $$ do
+ H.a ! HA.href (refIdent $ identify posXML) $$ do
html5ify type_
- html5ify $ XML.pos_ancestors xmlPos
+ html5ify $ XML.pos_ancestors posXML
forM_ title $ \ti ->
H.td ! HA.class_ "figure-title" $$
html5ify $ cleanPlain $ unTitle ti
-html5Judgment ::
- Maybe Title ->
- [Choice] ->
- MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade) ->
- HTML5
-html5Judgment question choices distByJudgeByChoice = do
- let commentJGC = HM.fromList
- [ (choice_, HM.fromListWith (<>)
- [ (grade, HM.singleton judge comment)
- | Opinion{..} <- opinions ])
- | choice_@Choice{opinions} <- choices ]
- case question of
- Nothing -> mempty
- Just title -> H.div ! HA.class_ "question" $$ html5ify title
- H.dl ! HA.class_ "choices" $$ do
- let meritByChoice@(MJ.MeritByChoice meritC) = MJ.meritByChoice distByJudgeByChoice
- let ranking = MJ.majorityRanking meritByChoice
- forM_ ranking $ \(choice_@DTC.Choice{title}, majorityValue) -> do
- H.dt ! HA.class_ "choice-title" $$ do
- html5ify title
- H.dd ! HA.class_ "choice-merit" $$ do
- let distByJudge = distByJudgeByChoice HM.!choice_
- let numJudges = HM.size distByJudge
- html5MeritHistogram majorityValue numJudges
- let grades = Map.keys $ MJ.unMerit $ meritC HM.!choice_
- let commentJG = HM.lookup choice_ commentJGC
- html5MeritComments distByJudge grades commentJG
-
-html5MeritComments ::
- MJ.Opinions Name (MJ.Ranked Grade) ->
- [MJ.Ranked Grade] ->
- Maybe (HM.HashMap Name (HM.HashMap Name (Maybe Title))) ->
- HTML5
-html5MeritComments distJ grades commentJG = do
- Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
- H.ul ! HA.class_ "merit-comments" $$ do
- forM_ grades $ \grade@(MJ.unRank -> DTC.Grade{name=grade_name, color}) -> do
- let commentJ = commentJG >>= HM.lookup grade_name
- let judgesWithComment =
- -- FIXME: sort accents better: « e é f » not « e f é »
- List.sortOn (TL.map Char.toLower . unName . (\(j,_,_) -> j))
- [ (judge, importance, commentJ >>= HM.lookupDefault Nothing judge)
- | (judge, dist) <- HM.toList distJ
- , importance <- maybeToList $ Map.lookup grade dist ]
- forM_ judgesWithComment $ \(judge, importance, comment) ->
- H.li ! HA.class_ ("merit-comment" <> if isJust comment then " judge-comment" else "") $$ do
- H.span
- ! HA.class_ ("judge" <> if judge`HM.member`fromMaybe HM.empty commentJ then "" else " inactive")
- ! HA.style ("color:"<>attrify color<>";") $$ do
- unless (importance == 1) $ do
- H.span ! HA.class_ "section-importance" $$ do
- let percent =
- (round::Double -> Int) $
- fromRational $ importance * 100
- html5ify $ show percent
- "%"::HTML5
- html5ify judge
- case comment of
- Nothing -> mempty
- Just p -> do
- Plain.l10n_Colon l10n :: HTML5
- html5ify p
-
-html5MeritHistogram :: MJ.MajorityValue (MJ.Ranked Grade) -> Int -> HTML5
-html5MeritHistogram (MJ.MajorityValue majVal) numJudges = do
- H.div ! HA.class_ "merit-histogram" $$ do
- forM_ majVal $ \(MJ.unRank -> DTC.Grade{name=grade_name, title=grade_title, color},count) -> do
- let percent :: Double =
- fromRational $ (toRational $ (ceiling::Double -> Int) $ fromRational $
- (count / toRational numJudges) * 100 * 1000) / 1000
- let bcolor = "background-color:"<>attrify color<>";"
- let width = "width:"<>attrify percent<>"%;"
- let display = if percent == 0 then "display:none;" else ""
- H.div
- ! HA.class_ "merit-grade"
- ! HA.alt (attrify grade_name) -- FIXME: do not work
- ! HA.style (bcolor<>display<>width) $$ do
- H.div
- ! HA.class_ "grade-name" $$ do
- case grade_title of
- Nothing -> html5ify grade_name
- Just t -> html5ify t
-
-html5Judgments :: HTML5
-html5Judgments = do
- Collect.All{..} <- liftStateMarkup $ S.gets state_collect
- opinionsByChoiceByNodeBySectionByJudgment <-
- forM (HM.toList all_judgments) $ \(judgment@Judgment{judges,grades}, choicesBySection) -> do
- -- WARNING: only the fields of 'Judgment' used in its 'Hashable' instance
- -- can safely be used here: 'judges' and 'grades' are ok
- let judgmentGrades =
- maybe (Prelude.error $ show grades) MJ.grades $ -- unknown grades
- HM.lookup grades all_grades
- let judgmentJudges =
- fromMaybe (Prelude.error $ show judges) $ -- unknown judges
- HM.lookup judges all_judges
- let defaultGradeByJudge =
- let defaultGrade =
- List.head
- [ g | g <- Set.toList judgmentGrades
- , isDefault $ MJ.unRank g
- ] in
- HM.fromList
- [ (name, defaultGrade`fromMaybe`judgeDefaultGrade)
- | DTC.Judge{name,defaultGrades} <- judgmentJudges
- , let judgeDefaultGrade = do
- jdg <- listToMaybe [g | (n,g) <- defaultGrades, n == grades]
- listToMaybe
- [ g | g <- Set.toList judgmentGrades
- , let DTC.Grade{name=n} = MJ.unRank g
- , n == jdg
- ]
- ]
- opinionsByChoiceByNodeBySection <-
- forM choicesBySection $ \choicesTree -> do
- judgmentTree <- forM choicesTree $ \(section_importance, choices) -> do
- judgmentOpinions <- forM choices $ \choice_@DTC.Choice{opinions} -> do
- gradeByJudge <- forM opinions $ \DTC.Opinion{judge,grade,importance} -> do
- case listToMaybe
- [ g | g <- Set.toList judgmentGrades
- , let Grade{name} = MJ.unRank g
- , name == grade
- ] of
- Just grd -> return (judge, MJ.Section importance (Just grd))
- Nothing -> Prelude.error $ show grade -- unknown grade
- return (choice_, HM.fromList gradeByJudge)
- return $ MJ.SectionNode section_importance $ HM.fromList judgmentOpinions
- let judgmentChoices = HS.fromList $ snd $ Tree.rootLabel choicesTree
- -- NOTE: choices are determined by those at the root Tree.Node.
- -- NOTE: core Majority Judgment calculus handled here by MJ
- case MJ.opinionsBySection judgmentChoices defaultGradeByJudge judgmentTree of
- Right opinionsByChoiceByNode -> return opinionsByChoiceByNode
- Left err -> Prelude.error $ show err -- unknown choice, unknown judge, invalid shares
- -- NOTE: 'toList' returns a self-then-descending-then-following traversal of a 'Tree',
- -- this will match perfectly withw the 'html5ify' traversal:
- -- 'BodySection' by 'BodySection'.
- return (judgment, join $ toList <$> opinionsByChoiceByNodeBySection)
- liftStateMarkup $ S.modify' $ \st ->
- st{state_opinions = HM.fromList opinionsByChoiceByNodeBySectionByJudgment}
-
-- 'Attrify'
instance Attrify Plain.Plain where
- attrify p = attrify t
- where (t,_) = Plain.runPlain p def
-
--- * Class 'L10n'
-class
- ( Plain.L10n msg lang
- , Plain.L10n TL.Text lang
- ) => L10n msg lang where
- l10n_Header_Address :: FullLocale lang -> msg
- l10n_Header_Date :: FullLocale lang -> msg
- l10n_Header_Version :: FullLocale lang -> msg
- l10n_Header_Origin :: FullLocale lang -> msg
- l10n_Header_Source :: FullLocale lang -> msg
- l10n_Errors_All :: FullLocale lang -> Nat -> msg
- l10n_Error_Tag_unknown :: FullLocale lang -> msg
- l10n_Error_Tag_ambiguous :: FullLocale lang -> msg
- l10n_Error_Rref_unknown :: FullLocale lang -> msg
- l10n_Error_Reference_ambiguous :: FullLocale lang -> msg
-instance L10n HTML5 EN where
- l10n_Header_Address _l10n = "Address"
- l10n_Header_Date _l10n = "Date"
- l10n_Header_Origin _l10n = "Origin"
- l10n_Header_Source _l10n = "Source"
- l10n_Header_Version _l10n = "Version"
- l10n_Errors_All _l10n n = "All errors ("<>html5ify n<>")"
- l10n_Error_Tag_unknown _l10n = "Unknown tag"
- l10n_Error_Tag_ambiguous _l10n = "Ambiguous tag"
- l10n_Error_Rref_unknown _l10n = "Unknown reference"
- l10n_Error_Reference_ambiguous _l10n = "Ambiguous reference"
-instance L10n HTML5 FR where
- l10n_Header_Address _l10n = "Adresse"
- l10n_Header_Date _l10n = "Date"
- l10n_Header_Origin _l10n = "Origine"
- l10n_Header_Source _l10n = "Source"
- l10n_Header_Version _l10n = "Version"
- l10n_Errors_All _l10n n = "Toutes les erreurs ("<>html5ify n<>")"
- l10n_Error_Tag_unknown _l10n = "Tag inconnu"
- l10n_Error_Tag_ambiguous _l10n = "Tag ambigu"
- l10n_Error_Rref_unknown _l10n = "Référence inconnue"
- l10n_Error_Reference_ambiguous _l10n = "Référence ambiguë"
-
-instance Plain.L10n HTML5 EN where
- l10n_Colon l10n = html5ify (Plain.l10n_Colon l10n :: TL.Text)
- l10n_Table_of_Contents l10n = html5ify (Plain.l10n_Table_of_Contents l10n :: TL.Text)
- l10n_Date date l10n = html5ify (Plain.l10n_Date date l10n :: TL.Text)
- l10n_Quote msg _l10n = do
- depth <- liftStateMarkup $ S.gets $ Plain.state_quote . state_plainify
- let (o,c) :: (HTML5, HTML5) =
- case unNat depth `mod` 3 of
- 0 -> ("“","”")
- 1 -> ("« "," »")
- _ -> ("‟","„")
- o
- setDepth $ succNat depth
- msg
- setDepth $ depth
- c
- where
- setDepth d =
- liftStateMarkup $ S.modify' $ \s ->
- s{state_plainify=(state_plainify s){Plain.state_quote=d}}
-instance Plain.L10n HTML5 FR where
- l10n_Colon l10n = html5ify (Plain.l10n_Colon l10n :: TL.Text)
- l10n_Table_of_Contents l10n = html5ify (Plain.l10n_Table_of_Contents l10n :: TL.Text)
- l10n_Date date l10n = html5ify (Plain.l10n_Date date l10n :: TL.Text)
- l10n_Quote msg _l10n = do
- depth <- liftStateMarkup $ S.gets $ Plain.state_quote . state_plainify
- let (o,c) :: (HTML5, HTML5) =
- case unNat depth `mod` 3 of
- 0 -> ("« "," »")
- 1 -> ("“","”")
- _ -> ("‟","„")
- o
- setDepth $ succNat depth
- msg
- setDepth $ depth
- c
- where
- setDepth d =
- liftStateMarkup $ S.modify' $ \s ->
- s{state_plainify=(state_plainify s){Plain.state_quote=d}}
+ attrify p = attrify $ Plain.runPlain p def
sourcephile / git / doclang.git / blobdiff