{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Hdoc.DTC.Write.HTML5 where import Control.Applicative (Applicative(..)) import Control.Category as Cat import Control.Monad 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.Functor.Compose (Compose(..)) import Data.Int (Int) import Data.Map.Strict (Map) import Data.Maybe (Maybe(..), maybe, mapMaybe, fromJust, maybeToList, listToMaybe, fromMaybe, isJust) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) import Data.String (String, IsString(..)) import Data.Text (Text) import Data.TreeSeq.Strict (Tree(..), tree0) import Data.Tuple (snd) import Prelude (mod, (*), Fractional(..), Double, toRational, RealFrac(..), error) import System.FilePath (FilePath) import Text.Blaze ((!)) import Text.Blaze.Html (Html) import Text.Show (Show(..)) import qualified Control.Monad.Trans.State as S import qualified Data.ByteString.Lazy as BS import qualified Data.Char as Char 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.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.Text.Lazy.Builder as TL.Builder import qualified Data.Text.Lazy.Builder.Int as TL.Builder import qualified Data.Text.Lazy.Encoding as TL import qualified Data.TreeMap.Strict as TreeMap import qualified Data.TreeSeq.Strict as TreeSeq import qualified Data.TreeSeq.Strict.Zipper as Tree import qualified Hjugement as MJ -- import qualified Text.Blaze.Internal as B import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as HA import qualified Text.Blaze.Internal as H import qualified Data.Tree as Tree import Text.Blaze.Utils import Data.Locale hiding (Index) import Hdoc.Utils () import Hdoc.DTC.Document as DTC import Hdoc.DTC.Write.Plain (Plainify(..)) import Hdoc.DTC.Write.XML () import qualified Hdoc.DTC.Index as Index import qualified Hdoc.DTC.Anchor as Anchor import qualified Hdoc.DTC.Write.Plain as Plain 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 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) writeHTML5 :: Config -> DTC.Document -> Html writeHTML5 conf@Config{..} doc@DTC.Document{..} = do let state_mapping@Mapping{..} :: Mapping = mappingOf doc let (body',state_rrefs,state_notes,state_indexs) = let irefs = foldMap Index.irefsOfTerms mapping_index in let (body0, Anchor.State{state_irefs, state_rrefs=rrefs, state_notes=notes}) = Anchor.anchorify body `S.runState` def{Anchor.state_irefs=irefs} in (body0,rrefs,notes,) $ (<$> mapping_index) $ \terms -> (terms,) $ TreeMap.intersection const state_irefs $ Index.irefsOfTerms terms let state_plainify = def{Plain.state_l10n = loqualize config_locale} let (html5Body, endState) = runStateMarkup def { state_mapping , state_indexs , state_rrefs , state_notes , state_plainify , state_l10n = loqualize config_locale } $ do html5Judgments html5DocumentHead head html5ify body' H.docType H.html ! HA.lang (attrify $ countryCode config_locale) $ do html5Head conf endState head body H.body $ html5Body html5Head :: Config -> State -> Head -> Body -> Html html5Head Config{..} State{..} Head{DTC.about=About{..}} body = do 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 body) $ \case Tree k@BodySection{} _ -> Just k _ -> Nothing forM_ chapters $ \case BodySection{..} -> H.link ! HA.rel "Chapter" ! HA.title (attrify $ plainify title) ! HA.href (refIdent $ identify pos) _ -> mempty unless (any (\DTC.Link{..} -> rel == "stylesheet" && href /= URL "") links) $ do 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" $ -- NOTE: as a special case, H.style wraps its content into an External, -- so it does not HTML-escape its content. H.toMarkup css forM_ state_styles $ \style -> H.style ! HA.type_ "text/css" $ H.toMarkup style unless (any (\DTC.Link{rel} -> rel == "script") links) $ do forM_ state_scripts $ \script -> H.script ! HA.type_ "application/javascript" $ H.toMarkup script html5DocumentHead :: Head -> Html5 html5DocumentHead Head{DTC.about=About{..}, judgments} = do unless (null authors) $ do H.div ! HA.class_ "document-head" $$ H.table $$ do H.tbody $$ do H.tr $$ do H.td ! HA.class_ "left" $$ docHeaders H.td ! HA.class_ "right" $$ docAuthors unless (null titles) $ H.div ! HA.class_ "title" $$ do forM_ titles $ \title -> H.h1 $$ html5ify title st <- liftStateMarkup S.get 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 = 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 loc <- 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) $ header $ do headerName $ html5ify name headerValue $ html5ify $ Tree PlainEref{href} plain forM_ date $ \d -> header $ do headerName $ l10n_Header_Date loc headerValue $ html5ify d forM_ url $ \href -> header $ do headerName $ l10n_Header_Address loc 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 loc <- liftStateMarkup $ S.gets state_l10n Plain.l10n_Colon loc headerValue :: Html5 -> Html5 headerValue hdr = H.td ! HA.class_ "header-value" $$ do hdr -- * 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_locale :: LocaleIn locales , config_generator :: TL.Text } instance Default Config where def = Config { config_css = Right "style/dtc-html5.css" , config_locale = LocaleIn @'[EN] en_US , config_generator = "https://hackage.haskell.org/package/hdoc" } -- * Type 'Html5' type Html5 = StateMarkup State () instance IsString Html5 where fromString = html5ify -- * Type 'State' data State = State -- RW { state_styles :: Map FilePath TL.Text , state_scripts :: Map FilePath TL.Text , state_notes :: Anchor.Notes -- TODO: could be a list , state_judgments :: HS.HashSet Judgment , state_opinions :: HM.HashMap Judgment [MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade)] -- RO , state_mapping :: Mapping , state_indexs :: Map Pos (Terms, Index.Irefs) -- TODO: could be a list , state_rrefs :: Anchor.Rrefs , state_plainify :: Plain.State , state_l10n :: Loqualization (L10n Html5) } instance Default State where def = State { state_styles = def , state_scripts = def , state_mapping = 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 } -- ** Type 'Mapping' -- | Collect 'Block's by mapping them by their 'Pos' or 'Ident'. data Mapping = Mapping { mapping_index :: Map Pos Terms , mapping_figure :: Map TL.Text (Map Pos (Maybe Title)) , mapping_reference :: Map Ident About , mapping_judges :: HM.HashMap Ident [Judge] , mapping_grades :: HM.HashMap Ident [Grade] , mapping_judgments :: HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])] } deriving (Show) instance Default Mapping where def = Mapping { mapping_index = def , mapping_figure = def , mapping_reference = def , mapping_judges = def , mapping_grades = def , mapping_judgments = def } instance Semigroup Mapping where x<>y = Mapping { mapping_index = Map.union (mapping_index x) (mapping_index y) , mapping_figure = Map.unionWith (<>) (mapping_figure x) (mapping_figure y) , mapping_reference = Map.union (mapping_reference x) (mapping_reference y) , mapping_judges = HM.union (mapping_judges x) (mapping_judges y) , mapping_grades = HM.union (mapping_grades x) (mapping_grades y) , mapping_judgments = HM.unionWith (<>) (mapping_judgments x) (mapping_judgments y) } instance Monoid Mapping where mempty = def mappend = (<>) -- *** Class 'MappingOf' class MappingOf a where mappingOf :: a -> Mapping instance MappingOf Document where mappingOf Document{head=Head{judgments=js}, body} = (foldMap mappingOf body) { mapping_judgments = choicesBySectionByJudgment HM.empty $ TreeSeq.Tree (choicesByJudgment js) $ choicesByJudgmentBySection body } choicesByJudgment :: [Judgment] -> HM.HashMap Judgment (Maybe MJ.Share, [Choice]) choicesByJudgment js = HM.fromList $ (<$> js) $ \j@Judgment{..} -> (j,(importance, choices)) choicesByJudgmentBySection :: Body -> TreeSeq.Trees (HM.HashMap Judgment (Maybe MJ.Share, [Choice])) choicesByJudgmentBySection bod = bod >>= \(Tree b bs) -> case b of BodyBlock{} -> mempty BodySection{judgments} -> pure $ let choicesJ = choicesByJudgment judgments in Tree choicesJ $ -- NOTE: if the 'BodySection' has a child which -- is not a 'BodySection' itself, then add "phantom" 'Judgment's -- which will inherit from this 'BodySection'. -- This enables judges to express something on material not in a sub 'BodySection'. let childrenBlocksJudgments = if (`any`bs) $ \case Tree BodyBlock{} _ -> True _ -> False then Seq.singleton $ Tree ((Nothing,[]) <$ choicesJ) Seq.empty else Seq.empty in childrenBlocksJudgments <> choicesByJudgmentBySection bs choicesBySectionByJudgment :: HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])] -> TreeSeq.Tree (HM.HashMap Judgment (Maybe MJ.Share, [Choice])) -> HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])] choicesBySectionByJudgment inh (TreeSeq.Tree selfJ childrenJS) = HM.unionWith (\selfS childrenS -> (<$> selfS) $ \(Tree.Node choices old) -> Tree.Node choices (old<>childrenS)) (selfSJ <> inh) childrenSJ where selfSJ = (\cs -> [Tree.Node cs []]) <$> selfJ childrenSJ = foldl' (\accJ childJ -> HM.unionWith (<>) accJ $ choicesBySectionByJudgment (([Tree.Node (Nothing,[]) []] <$ selfJ) <> inh) childJ ) HM.empty childrenJS instance MappingOf (Tree BodyNode) where mappingOf (Tree n ts) = case n of BodyBlock b -> mappingOf b BodySection{} -> foldMap mappingOf ts instance MappingOf DTC.Block where mappingOf = \case BlockPara _p -> def -- mappingOf p BlockBreak{} -> def BlockToC{} -> def BlockToF{} -> def BlockAside{..} -> foldMap mappingOf blocks BlockIndex{..} -> def{mapping_index = Map.singleton pos terms} BlockFigure{..} -> def{mapping_figure= Map.singleton type_ (Map.singleton pos mayTitle)} -- <> foldMap mappingOf paras BlockReferences{..} -> def{mapping_reference= Map.fromList $ (<$> refs) $ \DTC.Reference{id=id', ..} -> (id', about) } BlockGrades{attrs=CommonAttrs{id=i}, ..} -> def{mapping_grades = HM.singleton (fromMaybe "" i) scale} BlockJudges{attrs=CommonAttrs{id=i}, ..} -> def{mapping_judges = HM.singleton (fromMaybe "" i) jury} {- instance MappingOf Judgment where mappingOf Judgment{..} = def def{mapping_judgments = HM.singleton (judges,grades,question) (Tree.Node choices []) } -- <> foldMap mappingOf choices instance MappingOf Para where mappingOf = \case ParaItem item -> mappingOf item ParaItems{..} -> foldMap mappingOf items instance MappingOf ParaItem where mappingOf = \case ParaPlain{} -> def ParaArtwork{} -> def ParaQuote{..} -> foldMap mappingOf paras ParaComment{} -> def ParaOL items -> foldMap mappingOf items ParaUL items -> foldMap (foldMap mappingOf) items ParaJudgment{} -> def instance MappingOf ListItem where mappingOf ListItem{..} = foldMap mappingOf paras instance MappingOf Choice where mappingOf Choice{..} = foldMap mappingOf title <> foldMap mappingOf opinions instance MappingOf Opinion where mappingOf Opinion{..} = foldMap mappingOf comment instance MappingOf Title where mappingOf (Title t) = mappingOf t instance MappingOf Plain where mappingOf = foldMap mappingOf instance MappingOf (Tree PlainNode) where mappingOf (Tree n ts) = case n of PlainBreak -> def PlainText{} -> def PlainGroup -> mappingOf ts PlainB -> mappingOf ts PlainCode -> mappingOf ts PlainDel -> mappingOf ts PlainI -> mappingOf ts PlainSpan{} -> mappingOf ts PlainSub -> mappingOf ts PlainSup -> mappingOf ts PlainSC -> mappingOf ts PlainU -> mappingOf ts PlainNote{..} -> foldMap mappingOf note PlainQ -> mappingOf ts PlainEref{} -> mappingOf ts PlainIref{} -> mappingOf ts PlainRef{} -> mappingOf ts PlainRref{..} -> mappingOf ts -} -- * 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 -- * Type 'BodyCursor' -- | Cursor to navigate within a 'Body' according to many axis (like in XSLT). type BodyCursor = Tree.Zipper BodyNode instance Html5ify Body where html5ify body = forM_ (Tree.zippers body) $ \z -> forM_ (Tree.axis_repeat Tree.axis_following_sibling_nearest `Tree.runAxis` z) $ html5ify instance Html5ify BodyCursor where html5ify z = let Tree b bs = Tree.current z in case b of BodyBlock BlockToC{..} -> do H.nav ! HA.class_ "toc" ! HA.id (attrify $ identify pos) $$ do H.span ! HA.class_ "toc-name" $$ H.a ! HA.href (refIdent $ identify pos) $$ do Loqualization loc <- liftStateMarkup $ S.gets state_l10n Plain.l10n_Table_of_Contents loc H.ul $$ forM_ (Tree.axis_following_sibling `Tree.runAxis` z) $ html5ifyToC depth BodyBlock blk -> html5ify blk BodySection{..} -> do st <- liftStateMarkup S.get do -- notes let mayNotes = do p <- posParent $ pos_Ancestors pos let (ns, as) = Map.updateLookupWithKey (\_ _ -> Nothing) p $ state_notes st (,as) <$> ns case mayNotes of Nothing -> mempty Just (secNotes, state_notes) -> do liftStateMarkup $ S.modify' $ \s -> s{state_notes} html5ify secNotes html5CommonAttrs attrs{classes="section":classes attrs} $ H.section ! HA.id (attrify $ identify pos) $$ 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 H.aside ! HA.class_ "aside" $$ do let choicesJ = 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 H.table ! HA.id (attrify $ escapeIdent $ identify title) ! HA.class_ "section-header" $$ H.tbody $$ H.tr $$ do H.td ! HA.class_ "section-number" $$ do html5SectionNumber $ pos_Ancestors pos H.td ! HA.class_ "section-title" $$ do (case List.length $ pos_Ancestors pos of 0 -> H.h1 1 -> H.h2 2 -> H.h3 3 -> H.h4 4 -> H.h5 5 -> H.h6 _ -> H.h6) $$ html5ify title forM_ (Tree.axis_child `Tree.runAxis` z) $ html5ify do -- judgments liftStateMarkup $ S.modify' $ \s -> s{ state_judgments = state_judgments st } do -- notes notes <- liftStateMarkup $ S.gets state_notes html5ify $ Map.lookup (pos_Ancestors pos) notes instance Html5ify [Anchor.Note] where html5ify notes = H.aside ! HA.class_ "notes" $$ do Compose $ pure H.hr H.table $$ H.tbody $$ forM_ (List.reverse notes) $ \Anchor.Note{..} -> H.tr $$ do H.td ! HA.class_ "note-ref" $$ do H.a ! HA.class_ "note-number" ! HA.id ("note."<>attrify note_number) ! HA.href ("#note."<>attrify note_number) $$ do html5ify note_number ". "::Html5 H.a ! HA.href ("#note-ref."<>attrify note_number) $$ do "↑" H.td $$ html5ify note_content instance Html5ify Block where html5ify = \case BlockPara para -> html5ify para BlockBreak{..} -> html5CommonAttrs attrs { classes = "page-break":"print-only":classes attrs } $ H.div $$ H.p $$ " " -- NOTE: force page break BlockToC{..} -> mempty -- NOTE: done in Html5ify BodyCursor BlockToF{..} -> do H.nav ! HA.class_ "tof" ! HA.id (attrify $ identify pos) $$ H.table ! HA.class_ "tof" $$ H.tbody $$ html5ifyToF types BlockAside{..} -> html5CommonAttrs attrs $ H.aside ! HA.class_ "aside" $$ do forM_ blocks html5ify BlockFigure{..} -> html5CommonAttrs attrs { classes = "figure":("figure-"<>type_):classes attrs , DTC.id = Just $ Ident $ Plain.text def $ pos_AncestorsWithFigureNames pos } $ 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 pos) $$ mempty else H.td ! HA.class_ "figure-number" $$ do H.a ! HA.href (refIdent $ identify $ pos_AncestorsWithFigureNames pos) $$ do html5ify type_ html5ify $ pos_AncestorsWithFigureNames pos forM_ mayTitle $ \title -> do H.td ! HA.class_ "figure-colon" $$ do unless (TL.null type_) $ do Loqualization loc <- liftStateMarkup $ S.gets state_l10n Plain.l10n_Colon loc H.td ! HA.class_ "figure-title" $$ do html5ify title H.div ! HA.class_ "figure-content" $$ do html5ify paras BlockIndex{pos} -> do (allTerms,refsByTerm) <- liftStateMarkup $ S.gets $ (Map.! pos) . state_indexs let chars = Index.termsByChar allTerms H.div ! HA.class_ "index" ! HA.id (attrify $ identify pos) $$ do H.nav ! HA.class_ "index-nav" $$ do forM_ (Map.keys chars) $ \char -> H.a ! HA.href (refIdent (identify pos <> "." <> identify char)) $$ html5ify char H.dl ! HA.class_ "index-chars" $$ forM_ (Map.toList chars) $ \(char,terms) -> do H.dt $$ do let i = identify pos <> "." <> 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) $$ 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 html5CommasDot $ (<$> anchs) $ \(term,DTC.Anchor{..}) -> H.a ! HA.class_ "index-iref" ! HA.href (refIdent $ identifyIrefCount term count) $$ html5ify $ pos_Ancestors section BlockReferences{..} -> html5CommonAttrs attrs { classes = "references":classes attrs , DTC.id = Just $ Ident $ Plain.text def $ pos_Ancestors pos } $ H.div $$ do H.table $$ forM_ refs html5ify BlockGrades{..} -> html5CommonAttrs attrs { classes = "grades":classes attrs , DTC.id = Just $ Ident $ Plain.text def $ pos_Ancestors pos } $ 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{..} -> html5CommonAttrs attrs { classes = "judges":classes attrs , DTC.id = Just $ Ident $ Plain.text def $ pos_Ancestors pos } $ H.div $$ do mempty html5ifyToC :: Maybe DTC.Nat -> BodyCursor -> Html5 html5ifyToC depth z = let Tree n _ts = Tree.current z in case n of BodySection{..} -> do H.li $$ do H.table ! HA.class_ "toc-entry" $$ H.tbody $$ H.tr $$ do H.td ! HA.class_ "section-number" $$ html5SectionRef $ pos_Ancestors pos H.td ! HA.class_ "section-title" $$ html5ify $ cleanPlain $ unTitle title when (maybe True (> Nat 1) depth && not (null sections)) $ H.ul $$ forM_ sections $ html5ifyToC (depth >>= predNat) _ -> pure () where sections = (`Tree.runAxis` z) $ Tree.axis_child `Tree.axis_filter_current` \case Tree BodySection{} _ -> True _ -> False html5ifyToF :: [TL.Text] -> Html5 html5ifyToF types = do figuresByType <- liftStateMarkup $ S.gets $ mapping_figure . state_mapping let figures = Map.foldMapWithKey (\ty -> ((ty,) <$>)) $ if null types then figuresByType else Map.intersection figuresByType $ Map.fromList [(ty,()) | ty <- types] forM_ (Map.toList figures) $ \(pos, (type_, title)) -> H.tr $$ do H.td ! HA.class_ "figure-number" $$ H.a ! HA.href (refIdent $ identify pos) $$ do html5ify type_ html5ify $ pos_Ancestors pos forM_ title $ \ti -> H.td ! HA.class_ "figure-title" $$ html5ify $ cleanPlain $ unTitle ti cleanPlain :: Plain -> Plain cleanPlain ps = ps >>= \case Tree PlainIref{} ls -> cleanPlain ls Tree PlainNote{} _ -> mempty Tree n ts -> pure $ Tree n $ cleanPlain ts instance Html5ify Para where html5ify = \case ParaItem{..} -> html5CommonAttrs def { classes="para":cls item } $ html5ify item ParaItems{..} -> html5CommonAttrs attrs { classes = "para":classes attrs , DTC.id = id_ pos } $ H.div $$ forM_ items $ \item -> html5AttrClass (cls item) $ html5ify item where id_ = Just . Ident . Plain.text def . pos_Ancestors cls = \case ParaPlain{} -> [] ParaArtwork{..} -> ["artwork", "artwork-"<>type_] ParaQuote{..} -> ["quote", "quote-"<>type_] ParaComment{} -> [] ParaOL{} -> ["ol"] ParaUL{} -> ["ul"] ParaJudgment{} -> ["judgment"] 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.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 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 (error $ show grades) MJ.grades $ -- unknown grades HM.lookup grades (mapping_grades $ state_mapping st) let judgmentJudges = fromMaybe (error $ show judges) $ -- unknown judges HM.lookup judges (mapping_judges $ state_mapping 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 (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 -> error $ show ko -- unknown judge -- TODO: handle ko html5Judgment question choices $ HM.fromList judgmentChoices 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 loc <- 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 loc :: 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 Mapping{..} :: Mapping <- liftStateMarkup $ S.gets state_mapping opinionsByChoiceByNodeBySectionByJudgment <- forM (HM.toList mapping_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 (error $ show grades) MJ.grades $ -- unknown grades HM.lookup grades mapping_grades let judgmentJudges = fromMaybe (error $ show judges) $ -- unknown judges HM.lookup judges mapping_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 -> 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 -> 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} 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 ls) = 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 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 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}} 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 -> mempty Just 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 loc <- liftStateMarkup $ S.gets state_l10n Plain.l10n_Quote (html5ify $ Tree PlainI ls) loc 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{..} -> H.span ! HA.class_ "iref" ! HA.id (attrify $ identifyIrefCount term count) $$ html5ify ls PlainRef{..} -> H.a ! HA.class_ "ref" ! HA.href (refIdent $ escapeIdent to) $$ if null ls then html5ify $ unIdent to else html5ify ls PlainRref{..} -> do refs <- liftStateMarkup $ S.gets $ mapping_reference . state_mapping case Map.lookup to refs of Nothing -> do "["::Html5 H.span ! HA.class_ "rref-broken" $$ html5ify to "]" Just About{..} -> do unless (null ls) $ forM_ (List.take 1 titles) $ \(Title title) -> do html5ify $ Tree PlainQ $ case url of Nothing -> title Just u -> pure $ Tree (PlainEref u) title " "::Html5 "["::Html5 H.a ! HA.class_ "rref" ! HA.href ("#rref."<>attrify to) ! HA.id ("rref."<>attrify to<>maybe "" (\Anchor{..} -> "."<>attrify count) anchor) $$ html5ify to "]" instance Html5ify [Title] where html5ify = html5ify . fold . List.intersperse sep . toList where sep = Title $ Seq.singleton $ tree0 $ PlainText " — " instance Html5ify About where html5ify About{..} = do html5Lines [ html5CommasDot $ concat $ [ html5Titles titles , html5ify <$> authors , html5ify <$> maybeToList date , html5ify <$> maybeToList editor , html5ify <$> series ] , forM_ url $ \u -> H.span ! HA.class_ "print-only" $$ do "<"::Html5 html5ify u ">" ] 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) = html5ify $ Tree PlainQ $ case url of Nothing -> title Just u -> pure $ Tree (PlainEref u) title instance Html5ify Serie where html5ify s@Serie{id=id_, name} = do Loqualization loc <- liftStateMarkup $ S.gets state_l10n case urlSerie s of Nothing -> do html5ify name Plain.l10n_Colon loc :: Html5 html5ify id_ Just href -> do html5ify $ Tree PlainEref{href} $ Seq.fromList [ tree0 $ PlainText $ unName name , tree0 $ PlainText $ Plain.l10n_Colon loc , tree0 $ PlainText id_ ] instance Html5ify Entity where html5ify Entity{..} = do case () of _ | not (TL.null email) -> do H.span ! HA.class_ "no-print" $$ html5ify $ Tree (PlainEref $ URL $ "mailto:"<>email) $ pure $ tree0 $ PlainText name 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 -> html5ify $ Tree (PlainEref u) $ pure $ tree0 $ PlainText name _ -> html5ify $ tree0 $ PlainText name forM_ org $ \o -> do " ("::Html5 html5ify o ")"::Html5 instance Html5ify Words where html5ify = html5ify . Index.plainifyWords instance Html5ify Alias where html5ify Alias{id=id_, ..} = do H.a ! HA.class_ "alias" ! HA.id (attrify $ identify id_) $$ mempty instance Html5ify URL where html5ify (URL url) = H.a ! HA.class_ "eref" ! HA.href (attrify url) $$ html5ify url instance Html5ify Date where html5ify date = do Loqualization loc <- liftStateMarkup $ S.gets state_l10n Plain.l10n_Date date loc instance Html5ify Reference where html5ify Reference{id=id_, ..} = H.tr $$ do H.td ! HA.class_ "reference-key" $$ html5ify $ Tree PlainRref{anchor=Nothing, to=id_} Seq.empty H.td ! HA.class_ "reference-content" $$ do html5ify about rrefs <- liftStateMarkup $ S.gets state_rrefs case Map.lookup id_ rrefs of Nothing -> pure () Just anchs -> H.span ! HA.class_ "reference-rrefs" $$ html5CommasDot $ (<$> List.reverse anchs) $ \Anchor{..} -> H.a ! HA.class_ "reference-rref" ! HA.href ("#rref."<>attrify id_<>"."<>attrify count) $$ html5ify $ pos_Ancestors section instance Html5ify PosPath 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 sp <- liftStateMarkup $ S.gets state_plainify let (t,sp') = Plain.runPlain p sp html5ify t liftStateMarkup $ S.modify $ \s -> s{state_plainify=sp'} {- instance Html5ify SVG.Element where html5ify svg = html5ify $ B.preEscapedLazyText $ SVG.renderText svg instance Semigroup SVG.Element where (<>) = mappend -} html5CommasDot :: [Html5] -> Html5 html5CommasDot [] = pure () html5CommasDot hs = do sequence_ $ List.intersperse ", " hs "." html5Lines :: [Html5] -> Html5 html5Lines hs = sequence_ $ List.intersperse (html5ify H.br) hs html5Words :: [Html5] -> Html5 html5Words hs = sequence_ $ List.intersperse " " hs 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 :: PosPath -> Html5 html5SectionNumber = go mempty where go :: PosPath -> PosPath -> Html5 go prev next = case Seq.viewl next of Seq.EmptyL -> pure () a@(_n,rank) Seq.:< as -> do H.a ! HA.href (refIdent $ identify $ prev Seq.|> a) $$ html5ify $ show rank when (not (null as) || null prev) $ do html5ify '.' go (prev Seq.|>a) as html5SectionRef :: PosPath -> Html5 html5SectionRef as = H.a ! HA.href (refIdent $ identify as) $$ html5ify as -- * Class 'Identify' class Identify a where identify :: a -> Ident instance Identify Char where identify = Ident . TL.singleton instance Identify String where identify = Ident . TL.pack instance Identify TL.Text where identify = Ident instance Identify (Tree PlainNode) where identify (Tree n ls) = case n of PlainBreak -> identify '\n' PlainText t -> identify t PlainGroup -> identify ls PlainB -> identify ls PlainCode -> identify ls PlainDel -> identify ls PlainI -> identify ls PlainSpan{} -> identify ls PlainSub -> identify ls PlainSup -> identify ls PlainSC -> identify ls PlainU -> identify ls PlainNote{} -> "" PlainQ -> identify ls PlainEref{} -> identify ls PlainIref{} -> identify ls PlainRef{} -> identify ls PlainRref{..} -> identify to instance Identify Ident where identify (Ident p) = identify p instance Identify Plain where identify = foldMap identify instance Identify Title where identify (Title p) = identify p instance Identify PosPath where identify = escapeIdentHead . snd . foldl' (\(nameParent,acc) (name,rank) -> (name, (if TL.null $ unIdent acc then acc else acc <> ".") <> (if name == nameParent then identify (show rank) else escapeIdentTail $ identify (show name)<>identify (show rank)) ) ) ("",mempty) instance Identify Pos where identify = identify . pos_Ancestors instance Identify Path where identify (Path a) = identify a instance Identify Int where identify = fromString . show instance Identify Nat where identify (Nat a) = identify a instance Identify Nat1 where identify (Nat1 a) = identify a instance Identify Anchor where identify Anchor{..} = identify section <> "." <> identify count refIdent :: Ident -> H.AttributeValue refIdent i = "#"<>attrify i escapeIdent :: Ident -> Ident escapeIdent = escapeIdentHead . escapeIdentTail escapeIdentHead :: Ident -> Ident escapeIdentHead (Ident i) = Ident i escapeIdentTail :: Ident -> Ident escapeIdentTail (Ident i) = Ident $ TL.foldr (\c accum -> (<> accum) $ case c of ' ' -> "+" _ | Char.isAlphaNum c || c == '-' -> TL.singleton c _ -> "_"<>bytes where enc = TL.encodeUtf8 $ TL.singleton c bytes = BS.foldr (\b acc -> escape b<>acc) "" enc escape = TL.Builder.toLazyText . TL.Builder.hexadecimal ) "" i identifyIref :: Words -> Ident identifyIref term = "iref" <> "." <> identify (Index.plainifyWords term) identifyIrefCount :: Words -> Nat1 -> Ident identifyIrefCount term count = "iref" <> "." <> identify (Index.plainifyWords term) <> "." <> identify count -- '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 instance L10n Html5 EN where l10n_Header_Address _loc = "Address" l10n_Header_Date _loc = "Date" l10n_Header_Origin _loc = "Origin" l10n_Header_Source _loc = "Source" l10n_Header_Version _loc = "Version" instance L10n Html5 FR where l10n_Header_Address _loc = "Adresse" l10n_Header_Date _loc = "Date" l10n_Header_Origin _loc = "Origine" l10n_Header_Source _loc = "Source" l10n_Header_Version _loc = "Version" instance Plain.L10n Html5 EN where l10n_Colon loc = html5ify (Plain.l10n_Colon loc :: TL.Text) l10n_Table_of_Contents loc = html5ify (Plain.l10n_Table_of_Contents loc :: TL.Text) l10n_Date date loc = html5ify (Plain.l10n_Date date loc :: TL.Text) l10n_Quote msg _loc = 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 loc = html5ify (Plain.l10n_Colon loc :: TL.Text) l10n_Table_of_Contents loc = html5ify (Plain.l10n_Table_of_Contents loc :: TL.Text) l10n_Date date loc = html5ify (Plain.l10n_Date date loc :: TL.Text) l10n_Quote msg _loc = 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}}