--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Control.Monad.Utils where
+
+import Control.Applicative (Applicative(..))
+import Control.Monad (Monad(..))
+import Data.Bool
+import Data.Foldable (Foldable(..))
+import Data.Function (($), (.))
+import Data.Functor ((<$>))
+import Data.Functor.Compose (Compose(..))
+import Data.Maybe (Maybe(..), maybe)
+import Data.Monoid (Monoid(..))
+import Data.Semigroup (Semigroup(..))
+import qualified Control.Monad.Trans.State as S
+
+unless :: (Applicative f, Monoid a) => Bool -> f a -> f a
+unless b fa = if b then pure mempty else fa
+{-# INLINABLE unless #-}
+
+when :: (Applicative f, Monoid a) => Bool -> f a -> f a
+when b fa = if b then fa else pure mempty
+{-# INLINABLE when #-}
+
+-- * Type 'ComposeState'
+-- | Composing state and a monad not affecting the state.
+type ComposeState st = Compose (S.State st)
+instance Semigroup (ComposeState st Maybe a) where
+ (<>) = (>>)
+instance Monoid (ComposeState st Maybe ()) where
+ mempty = pure ()
+ mappend = (<>)
+instance Monad (ComposeState st Maybe) where
+ return = pure
+ Compose sma >>= a2csmb =
+ Compose $ sma >>= \ma ->
+ maybe (return Nothing) getCompose $
+ ma >>= Just . a2csmb
+{- NOTE: the 'st' may need to use the 'String', so no such instance.
+instance Monad m => IsString (ComposeState st m ()) where
+ fromString = Compose . return . fromString
+-}
+
+-- | Lift a function over 'm' to a 'ComposeState' one.
+($$) :: (m a -> m a) -> ComposeState st m a -> ComposeState st m a
+($$) f m = Compose $ f <$> getCompose m
+infixr 0 $$
+
+liftComposeState :: Monad m => S.State st a -> ComposeState st m a
+liftComposeState = Compose . (return <$>)
+
+runComposeState :: st -> ComposeState st m a -> (m a, st)
+runComposeState st = (`S.runState` st) . getCompose
+
+evalComposeState :: st -> ComposeState st m a -> m a
+evalComposeState st = (`S.evalState` st) . getCompose
+
+-- * Folding
+-- | Lazy in the monoidal accumulator.
+foldlMapA :: (Foldable f, Monoid b, Applicative m) => (a -> m b) -> f a -> m b
+foldlMapA f = foldr (liftA2 mappend . f) (pure mempty)
+
+-- | Strict in the monoidal accumulator.
+-- For monads strict in the left argument of bind ('>>='),
+-- this will run in constant space.
+foldlMapM :: (Foldable f, Monoid b, Monad m) => (a -> m b) -> f a -> m b
+foldlMapM f xs = foldr go pure xs mempty
+ where
+ -- go :: a -> (b -> m b) -> b -> m b
+ go x k lb = f x >>= \rb -> let !b = lb`mappend`rb in k b
+
{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hdoc.DTC.Check where
+module Hdoc.DTC.Check
+ ( {-module Hdoc.DTC.Check
+ ,-} module Hdoc.DTC.Check.Base
+ -- , module Hdoc.DTC.Check.Judgment
+ ) where
--- import Control.Category
--- import Data.Char (Char)
--- import Data.Monoid (Monoid(..))
--- import Data.TreeMap.Strict (TreeMap(..))
--- import qualified Data.Char as Char
--- import qualified Data.Text.Lazy as TL
--- import qualified Data.TreeSeq.Strict as TreeSeq
--- import qualified Hjugement as MJ
import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Data.Bool
import Data.Default.Class (Default(..))
-import Data.Eq (Eq)
import Data.Foldable (Foldable(..))
-import Data.Function (($), const, flip)
+import Data.Function (($), (.), const, flip)
import Data.Functor ((<$>))
-import Data.IntMap.Strict (IntMap)
-import Data.Map.Strict (Map)
-import Data.Maybe (Maybe(..), maybe)
+import Data.Maybe (Maybe(..), maybe, listToMaybe)
import Data.Semigroup (Semigroup(..))
-import Data.Sequence (Seq)
import Data.Traversable (Traversable(..))
import Data.TreeSeq.Strict (Tree(..), tree0)
import Data.Tuple (snd)
-import Text.Show (Show)
+import Prelude (undefined)
import qualified Control.Monad.Trans.State as S
import qualified Data.HashMap.Strict as HM
import qualified Data.IntMap.Strict as IntMap
import qualified Data.Sequence as Seq
import qualified Data.Strict.Maybe as Strict
import qualified Data.TreeMap.Strict as TreeMap
-import qualified Prelude (error)
import Hdoc.DTC.Document
import Hdoc.DTC.Index
import Hdoc.DTC.Collect
-import qualified Hdoc.TCT.Cell as TCT
+import Hdoc.DTC.Check.Base
+import Hdoc.DTC.Check.Judgment ()
import qualified Hdoc.XML as XML
--- * Type 'State'
-data State = State
- { state_section :: Maybe Section -- RO
- , state_irefs :: Irefs
- , state_rrefs :: HM.HashMap Ident [(Maybe Section, Nat1)]
- -- , state_refs :: AnchorByIdent
- , state_notes :: NotesBySection
- , state_note :: Nat1
- , state_errors :: Errors
- , state_collect :: All
- }
-instance Default State where
- def = State
- { state_section = def
- , state_irefs = TreeMap.empty
- , state_rrefs = def
- -- , state_refs = def
- , state_notes = def
- , state_note = def
- , state_errors = def
- , state_collect = def
- }
-
--- ** Type 'AnchorByIdent'
-type AnchorByIdent = HM.HashMap Ident [Anchor]
-
--- ** Type 'Notes'
-type Notes = IntMap [Para]
-
--- *** Type 'NotesBySection'
-type NotesBySection = Map XML.Ancestors Notes
-
--- * Type 'Errors'
-data Errors = Errors
- { errors_tag_unknown :: HM.HashMap Title (Seq TCT.Location)
- , errors_tag_ambiguous :: HM.HashMap Title (Seq TCT.Location)
- , errors_rref_unknown :: HM.HashMap Ident (Seq TCT.Location)
- , errors_reference_ambiguous :: HM.HashMap Ident (Seq TCT.Location)
- } deriving (Eq,Show)
-instance Default Errors where
- def = Errors
- { errors_tag_unknown = def
- , errors_tag_ambiguous = def
- , errors_rref_unknown = def
- , errors_reference_ambiguous = def
- }
-
--- * Class 'Check'
-class Check a where
- check :: a -> S.State State a
-instance Check a => Check (Maybe a) where
- check = traverse check
instance Check Body where
check = traverse check
instance Check (Tree BodyNode) where
BodyBlock b -> BodyBlock <$> check b
instance Check Section where
check Section{..} =
- Section xmlPos attrs
- <$> check title
- <*> pure aliases
- <*> traverse check judgments
+ Section section_posXML section_attrs
+ <$> check section_title
+ <*> pure section_aliases
+ <*> traverse check section_judgments
instance Check Block where
check = \case
BlockPara p -> BlockPara <$> check p
b@BlockToF{} -> return b
b@BlockIndex{} -> return b
BlockAside{..} ->
- BlockAside xmlPos attrs
+ BlockAside posXML attrs
<$> traverse check blocks
BlockFigure{..} ->
- BlockFigure xmlPos type_ attrs
+ BlockFigure posXML type_ attrs
<$> check mayTitle
<*> traverse check paras
BlockReferences{..} ->
- BlockReferences xmlPos attrs
+ BlockReferences posXML attrs
<$> traverse check refs
- BlockJudges{..} ->
- BlockJudges xmlPos attrs
- <$> traverse check jury
+ BlockJudges js -> BlockJudges <$> check js
BlockGrades{..} ->
- BlockGrades xmlPos attrs
- <$> traverse check scale
+ BlockGrades posXML attrs
+ <$> check scale
instance Check Para where
check = \case
ParaItem{..} -> ParaItem <$> check item
- ParaItems{..} -> ParaItems xmlPos attrs <$> traverse check items
+ ParaItems{..} -> ParaItems posXML attrs <$> traverse check items
instance Check ParaItem where
check = \case
ParaPlain plain -> ParaPlain <$> check plain
check (Tree n ts) = do
st@State{state_collect=All{..}, ..} <- S.get
case n of
- PlainIref{term}
+ PlainIref{..}
| not $ null state_irefs
- , Just words <- pathFromWords term
- , Strict.Just anchs <- TreeMap.lookup words state_irefs -> do
+ , Just words <- pathFromWords iref_term
+ , Strict.Just anchors <- TreeMap.lookup words state_irefs -> do
-- NOTE: Insert new anchor for this index ref.
- let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
- let anch = Anchor{count, section=maybe def (xmlPos::Section -> XML.Pos) state_section}
+ let anchor = Anchor
+ { anchor_count = maybe def (succNat1 . anchor_count) $ listToMaybe anchors
+ , anchor_section = maybe def section_posXML state_section
+ }
S.put st
- { state_irefs = TreeMap.insert const words (anch:anchs) state_irefs }
- Tree PlainIref{term, anchor=Just anch}
+ { state_irefs = TreeMap.insert const words (anchor:anchors) state_irefs }
+ Tree PlainIref
+ { iref_term
+ , iref_anchor = Just anchor }
<$> traverse check ts
PlainText txt
| not $ null state_irefs -> do
-- NOTE: Find indexed words in this text.
- let (irefs,para) = indexifyWords (maybe def (xmlPos::Section -> XML.Pos) state_section) state_irefs (wordify txt)
+ let (irefs,para) = indexifyWords (maybe def section_posXML state_section) state_irefs (wordify txt)
S.put st
{ state_irefs = irefs }
return $ Tree PlainGroup para
PlainNote{..} -> do
-- NOTE: Insert new note for this section.
- let section = XML.pos_ancestors $ maybe def (xmlPos::Section -> XML.Pos) state_section
+ let section = XML.pos_ancestors $ maybe def section_posXML state_section
S.put st
{ state_note = succNat1 state_note }
- note' <- traverse check note
- let noteByNumber = IntMap.singleton (unNat1 state_note) note'
+ paras <- traverse check note_paras
+ let noteByNumber = IntMap.singleton (unNat1 state_note) note_paras
State{state_notes=notes} <- S.get
S.modify' $ \s -> s
{ state_notes = Map.insertWith (<>) section noteByNumber notes }
- Tree PlainNote{number=Just state_note, note=note'}
+ Tree PlainNote
+ { note_number = Just state_note
+ , note_paras = paras }
<$> traverse check ts -- NOTE: normally ts is empty anyway
PlainRref{..} -> do
- let targets = HM.lookupDefault Seq.empty to all_reference
+ let targets = HM.lookupDefault Seq.empty rref_to all_reference
case toList targets of
[] -> do
let err =
- HM.insertWith (flip (<>)) to (pure locTCT) $
+ HM.insertWith (flip (<>)) rref_to (pure rref_locTCT) $
errors_rref_unknown state_errors
S.put st
{ state_errors = state_errors
{ errors_rref_unknown = err }
}
- Tree PlainRref{error = Just $ ErrorTarget_Unknown $ Nat1 $ length $ err HM.!to, ..}
+ Tree PlainRref
+ { rref_error = Just $ ErrorTarget_Unknown $ Nat1 $ length $ err HM.!rref_to
+ , .. }
<$> traverse check ts
[_] -> do
let rrefs = HM.insertWith
(const $ \old ->
let (_sec,num) = List.head old in
(state_section, succNat1 num) : old)
- to [(state_section, Nat1 1)]
+ rref_to [(state_section, Nat1 1)]
state_rrefs
S.put st
{ state_rrefs = rrefs }
- Tree PlainRref{error = Nothing, number = Just $ snd $ List.head $ rrefs HM.!to, ..}
+ Tree PlainRref
+ { rref_error = Nothing
+ , rref_number = Just $ snd $ List.head $ rrefs HM.!rref_to
+ , .. }
<$> traverse check ts
_ ->
-- NOTE: ambiguity is checked when checking 'Reference'.
- Tree PlainRref{error = Just $ ErrorTarget_Ambiguous Nothing, number = Nothing, ..}
+ Tree PlainRref
+ { rref_error = Just $ ErrorTarget_Ambiguous Nothing
+ , rref_number = Nothing
+ , .. }
<$> traverse check ts
- PlainTag{locTCT} -> do
- let to = Title ts
- let targets = HM.lookupDefault Seq.empty to all_section
+ PlainTag{..} -> do
+ let tag_to = Title ts
+ let targets = HM.lookupDefault Seq.empty tag_to all_section
case toList targets of
[] -> do
let err =
- HM.insertWith (flip (<>)) to (pure locTCT) $
+ HM.insertWith (flip (<>)) tag_to (pure tag_locTCT) $
errors_tag_unknown state_errors
S.put st
{ state_errors = state_errors
{ errors_tag_unknown = err }
}
- Tree PlainTag{error = Just $ ErrorTarget_Unknown $ Nat1 $ length $ err HM.!to, ..}
+ Tree PlainTag
+ { tag_error = Just $ ErrorTarget_Unknown $ Nat1 $ length $ err HM.!tag_to
+ , .. }
<$> traverse check ts
[_] ->
- Tree PlainTag{error = Nothing, ..}
+ Tree PlainTag{tag_error = Nothing, ..}
<$> traverse check ts
_ -> do
let err =
- HM.insertWith (flip (<>)) to (pure locTCT) $
+ HM.insertWith (flip (<>)) tag_to (pure tag_locTCT) $
errors_tag_ambiguous state_errors
S.put st
{ state_errors = state_errors
{ errors_tag_ambiguous = err }
}
- Tree PlainTag{error = Just $ ErrorTarget_Ambiguous $ Just $ Nat1 $ length $ err HM.!to, ..}
+ Tree PlainTag
+ { tag_error = Just $ ErrorTarget_Ambiguous $ Just $ Nat1 $ length $ err HM.!tag_to
+ , .. }
<$> traverse check ts
_ -> Tree n <$> traverse check ts
instance Check Title where
instance Check Reference where
check Reference{..} = do
st@State{state_collect=All{..}, ..} <- S.get
- let targets = HM.lookupDefault Seq.empty id all_reference
+ let targets = HM.lookupDefault Seq.empty reference_id all_reference
case toList targets of
- [] -> Prelude.error "[BUG] check Reference"
+ [] -> undefined
[_] -> do
- about' <- check about
- return $ Reference{error=Nothing, about=about', ..}
+ about <- check reference_about
+ return $ Reference
+ { reference_error = Nothing
+ , reference_about = about
+ , .. }
_ -> do
let err =
- HM.insertWith (flip (<>)) id (pure locTCT) $
+ HM.insertWith (flip (<>)) reference_id (pure reference_locTCT) $
errors_reference_ambiguous state_errors
S.put st
{ state_errors = state_errors
{ errors_reference_ambiguous = err }
}
- about' <- check about
- return $ Reference{error=Just $ ErrorAnchor_Ambiguous $ Nat1 $ length $ err HM.!id, about=about', ..}
-instance Check Judgment where
- check Judgment{..} =
- Judgment opinionsByChoice judges grades importance
- <$> check question
- <*> traverse check choices
-instance Check Choice where
- check Choice{..} =
- Choice
- <$> check title
- <*> traverse check opinions
-instance Check Opinion where
- check Opinion{..} =
- Opinion judge grade importance
- <$> check comment
-instance Check Grade where
- check Grade{..} =
- Grade xmlPos name color isDefault
- <$> check title
-instance Check Judge where
- check Judge{..} =
- Judge name
- <$> check title
- <*> pure defaultGrades
+ about <- check reference_about
+ return $ Reference
+ { reference_error = Just $ ErrorAnchor_Ambiguous $ Nat1 $ length $ err HM.!reference_id
+ , reference_about = about
+ , .. }
--- /dev/null
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Hdoc.DTC.Check.Base where
+
+import Data.Default.Class (Default(..))
+import Data.Eq (Eq(..))
+import Data.IntMap.Strict (IntMap)
+import Data.Map.Strict (Map)
+import Data.Maybe (Maybe(..))
+import Data.Sequence (Seq)
+import Data.Traversable (Traversable(..))
+import Text.Show (Show)
+import qualified Control.Monad.Trans.State as S
+import qualified Data.HashMap.Strict as HM
+import qualified Data.TreeMap.Strict as TreeMap
+
+import Hdoc.DTC.Document
+import Hdoc.DTC.Index
+import Hdoc.DTC.Collect
+import qualified Hdoc.TCT.Cell as TCT
+import qualified Hdoc.XML as XML
+
+-- * Type 'State'
+data State = State
+ { state_section :: Maybe Section -- RO
+ , state_irefs :: Irefs
+ , state_rrefs :: HM.HashMap Ident [(Maybe Section, Nat1)]
+ -- , state_tags :: AnchorByIdent
+ , state_notes :: NotesBySection
+ , state_note :: Nat1
+ , state_errors :: Errors
+ , state_collect :: All
+ }
+instance Default State where
+ def = State
+ { state_section = def
+ , state_irefs = TreeMap.empty
+ , state_rrefs = def
+ -- , state_tags = def
+ , state_notes = def
+ , state_note = def
+ , state_errors = def
+ , state_collect = def
+ }
+
+-- ** Type 'AnchorByIdent'
+type AnchorByIdent = HM.HashMap Ident [Anchor]
+
+-- ** Type 'Notes'
+type Notes = IntMap [Para]
+
+-- *** Type 'NotesBySection'
+type NotesBySection = Map XML.Ancestors Notes
+
+-- * Type 'Errors'
+data Errors = Errors
+ { errors_tag_unknown :: HM.HashMap Title (Seq TCT.Location)
+ , errors_tag_ambiguous :: HM.HashMap Title (Seq TCT.Location)
+ , errors_rref_unknown :: HM.HashMap Ident (Seq TCT.Location)
+ , errors_reference_ambiguous :: HM.HashMap Ident (Seq TCT.Location)
+ , errors_judgment_judges_unknown :: HM.HashMap Ident (Seq (TCT.Location, XML.Pos))
+ , errors_judgment_grades_unknown :: HM.HashMap Ident (Seq (TCT.Location, XML.Pos))
+ , errors_judgment_grades_duplicated :: HM.HashMap Ident (Seq (TCT.Location, XML.Pos))
+ , errors_judgment_judge_unknown :: HM.HashMap Name (Seq (TCT.Location, XML.Pos))
+ , errors_judgment_judge_duplicated :: HM.HashMap Name (Seq (TCT.Location, XML.Pos))
+ , errors_judgment_grade_unknown :: HM.HashMap Name (Seq (TCT.Location, XML.Pos))
+ , errors_judgment_choice_duplicated :: HM.HashMap Title (Seq (TCT.Location, XML.Pos))
+ } deriving (Eq,Show)
+instance Default Errors where
+ def = Errors
+ { errors_tag_unknown = def
+ , errors_tag_ambiguous = def
+ , errors_rref_unknown = def
+ , errors_reference_ambiguous = def
+ , errors_judgment_judges_unknown = def
+ , errors_judgment_judge_unknown = def
+ , errors_judgment_judge_duplicated = def
+ , errors_judgment_grades_unknown = def
+ , errors_judgment_grades_duplicated = def
+ , errors_judgment_grade_unknown = def
+ , errors_judgment_choice_duplicated = def
+ }
+
+-- * Class 'Check'
+class Check a where
+ check :: a -> S.State State a
+instance Check a => Check (Maybe a) where
+ check = traverse check
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Hdoc.DTC.Check.Judgment where
+
+import Control.Arrow (second)
+import Control.Applicative (Applicative(..))
+import Control.Monad (Monad(..), forM, forM_, join)
+import Data.Bool
+import Data.Default.Class (Default(..))
+import Data.Eq (Eq(..))
+import Data.Foldable (Foldable(..))
+import Data.Function (($), (.), flip)
+import Data.Functor ((<$>), (<$))
+import Data.Functor.Compose (Compose(..))
+import Data.Maybe (Maybe(..), fromMaybe, listToMaybe)
+import Data.Ord (Ord(..))
+import Data.Semigroup (Semigroup(..))
+import Data.Traversable (Traversable(..))
+import Data.Tuple (snd)
+import qualified Control.Monad.Trans.State as S
+import qualified Data.HashMap.Strict as HM
+import qualified Data.HashSet as HS
+import qualified Data.List as List
+import qualified Data.Sequence as Seq
+import qualified Data.Set as Set
+import qualified Hjugement as MJ
+
+import Hdoc.DTC.Document
+import Hdoc.DTC.Collect
+import Hdoc.DTC.Check.Base
+import Control.Monad.Utils
+
+instance Check Title => Check Judges where
+ check Judges{..} = do
+ let duplicatedJudges = HM.filter ((> 1) . length) judges_byName
+ unless (null duplicatedJudges) $ do
+ S.modify' $ \s@State{state_errors} -> s
+ { state_errors = state_errors
+ { errors_judgment_judge_duplicated =
+ HM.unionWith (flip (<>))
+ (Seq.fromList . ((\Judge{..} -> (judge_locTCT, judge_posXML)) <$>) <$> duplicatedJudges) $
+ errors_judgment_judge_duplicated state_errors
+ }
+ }
+ Judges
+ judges_locTCT
+ judges_posXML
+ judges_attrs
+ <$> traverse (traverse check) judges_byName
+instance Check Title => Check [Grade] where
+ check = traverse check
+instance Check Title => Check Judgment where
+ check Judgment{..} = do
+ State{state_collect=All{..}} <- S.get
+ mayJudges <- do
+ case HM.lookup judgment_judgesId all_judges of
+ Just js -> return $ Just js
+ Nothing -> do
+ S.modify' $ \s@State{state_errors} -> s
+ { state_errors = state_errors
+ { errors_judgment_judges_unknown =
+ HM.insertWith (flip (<>)) judgment_judgesId (pure (judgment_locTCT, judgment_posXML)) $
+ errors_judgment_judges_unknown state_errors
+ }
+ }
+ return Nothing
+ mayGrades <- do
+ case HM.lookup judgment_gradesId all_grades of
+ Just gs -> return $ Just $ MJ.grades gs
+ Nothing -> do
+ S.modify' $ \s@State{state_errors} -> s
+ { state_errors = state_errors
+ { errors_judgment_grades_unknown =
+ HM.insertWith (flip (<>)) judgment_gradesId (pure (judgment_locTCT, judgment_posXML)) $
+ errors_judgment_grades_unknown state_errors
+ }
+ }
+ return Nothing
+ mayOpinionsByChoice <- getCompose $ do
+ Judges{..} <- Compose $ return mayJudges
+ grades <- Compose $ return mayGrades
+ let defaultGradeByJudge =
+ let defaultGrade =
+ List.head
+ [ g | g <- Set.toList grades
+ , grade_isDefault $ MJ.unRank g
+ ] in
+ (<$> judges_byName) $ \js ->
+ let Judge{..} = List.head js in
+ let judgeDefaultGrade = do
+ grade <- join $ listToMaybe <$> HM.lookup judgment_gradesId judge_defaultGrades
+ listToMaybe
+ [ g | g <- Set.toList grades
+ , grade_name (MJ.unRank g) == grade
+ ] in
+ defaultGrade`fromMaybe`judgeDefaultGrade
+ opinionsByChoice <-
+ forM judgment_choices $ \choice@Choice{..} -> do
+ gradeByJudge <- forM choice_opinions $ \opinion@Opinion{..} -> do
+ let mayGrade = do
+ listToMaybe
+ [ MJ.singleGrade g | g <- Set.toList grades
+ , grade_name (MJ.unRank g) == opinion_grade
+ ]
+ case mayGrade of
+ Just grd -> Compose $ return $ Just (opinion_judge, (opinion, grd))
+ Nothing -> do
+ liftComposeState $ S.modify' $ \s@State{state_errors} -> s
+ { state_errors = state_errors
+ { errors_judgment_grade_unknown =
+ HM.insertWith (flip (<>)) opinion_grade (pure (judgment_locTCT, judgment_posXML)) $
+ errors_judgment_grade_unknown state_errors
+ }
+ }
+ Compose $ return Nothing
+ let gradeByJudges = HM.fromListWith (flip (<>)) $ second pure <$> gradeByJudge
+ let duplicateJudges = HM.filter ((> 1) . length) gradeByJudges
+ unless (null duplicateJudges) (do
+ liftComposeState $ S.modify' $ \s@State{state_errors} -> s
+ { state_errors = state_errors
+ { errors_judgment_judge_duplicated =
+ HM.unionWith (flip (<>))
+ (((\(Opinion{..}, _g) -> (opinion_locTCT, opinion_posXML)) <$>) <$> duplicateJudges) $
+ errors_judgment_judge_duplicated state_errors
+ }
+ }
+ Compose $ return (Nothing::Maybe ())
+ ) *>
+ case MJ.opinions defaultGradeByJudge $ snd . List.head . toList <$> gradeByJudges of
+ (ok,ko) | null ko -> Compose $ return $ Just (choice, Seq.singleton (choice, ok))
+ | otherwise -> do
+ liftComposeState $ S.modify' $ \s@State{state_errors} -> s
+ { state_errors = state_errors
+ { errors_judgment_judge_unknown =
+ HM.unionWith (flip (<>))
+ (pure (judgment_locTCT, judgment_posXML) <$ HS.toMap ko) $
+ errors_judgment_judge_unknown state_errors
+ }
+ }
+ Compose $ return Nothing
+ let opinionsByChoices = HM.fromListWith (flip (<>)) opinionsByChoice
+ let duplicateChoices = HM.filter ((> 1) . length) opinionsByChoices
+ unless (null duplicateChoices) $ do
+ liftComposeState $ S.modify' $ \s@State{state_errors} -> s
+ { state_errors = state_errors
+ { errors_judgment_choice_duplicated =
+ HM.unionWith (flip (<>))
+ (HM.fromList $ (\(choice, os) ->
+ ( fromMaybe def $ choice_title choice
+ , (<$> os) $ \(Choice{..}, _ok) -> (choice_locTCT, choice_posXML)
+ )) <$> HM.toList duplicateChoices) $
+ errors_judgment_choice_duplicated state_errors
+ }
+ }
+ Compose $ return (Nothing::Maybe ())
+ Compose $ return $ Just $
+ snd . List.head . toList
+ <$> opinionsByChoices
+ Judgment mayOpinionsByChoice mayJudges mayGrades
+ judgment_posXML
+ judgment_locTCT
+ judgment_judgesId
+ judgment_gradesId
+ judgment_importance
+ <$> check judgment_question
+ <*> traverse check judgment_choices
+instance Check Title => Check Choice where
+ check Choice{..} =
+ Choice choice_locTCT choice_posXML
+ <$> check choice_title
+ <*> traverse check choice_opinions
+instance Check Title => Check Opinion where
+ check Opinion{..} =
+ Opinion
+ opinion_locTCT
+ opinion_posXML
+ opinion_judge
+ opinion_grade
+ opinion_importance
+ <$> check opinion_comment
+instance Check Title => Check Grade where
+ check Grade{..} =
+ Grade grade_posXML grade_name grade_color grade_isDefault
+ <$> check grade_title
+instance Check Title => Check Judge where
+ check Judge{..} = do
+ State{state_collect=All{..}} <- S.get
+ let duplicatedGrades = HM.filter ((> 1) . length) judge_defaultGrades
+ unless (null duplicatedGrades) $ do
+ S.modify' $ \s@State{state_errors} -> s
+ { state_errors = state_errors
+ { errors_judgment_grades_duplicated =
+ HM.unionWith (flip (<>))
+ (Seq.fromList . ((judge_locTCT, judge_posXML) <$) <$> duplicatedGrades) $
+ errors_judgment_grades_duplicated state_errors
+ }
+ }
+ forM_ (HM.toList judge_defaultGrades) $ \(gradesId,gradeId) ->
+ case HM.lookup gradesId all_grades of
+ Just grades -> do
+ return ()
+ Nothing -> do
+ S.modify' $ \s@State{state_errors} -> s
+ { state_errors = state_errors
+ { errors_judgment_grades_unknown =
+ HM.insertWith (flip (<>)) gradesId (pure (judge_locTCT, judge_posXML)) $
+ errors_judgment_grades_unknown state_errors
+ }
+ }
+ Judge
+ judge_locTCT
+ judge_posXML
+ judge_name
+ <$> check judge_title
+ <*> pure judge_defaultGrades
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Text.Lazy as TL
-import qualified Data.TreeSeq.Strict as TreeSeq
+import qualified Data.TreeSeq.Strict as TS
import qualified Hjugement as MJ
import qualified Data.Tree as Tree
, all_figure :: Map TL.Text (Map XML.Pos (Maybe Title))
, all_reference :: HM.HashMap Ident (Seq Reference)
, all_section :: HM.HashMap Title (Seq (Either Head Section))
- , all_judges :: HM.HashMap Ident [Judge]
+ , all_judges :: HM.HashMap Ident Judges
, all_grades :: HM.HashMap Ident [Grade]
, all_judgments :: HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])]
} deriving (Show)
(foldMap collect body)
{ all_judgments =
choicesBySectionByJudgment HM.empty $
- TreeSeq.Tree (choicesByJudgment js) $
+ TS.Tree (choicesByJudgment js) $
choicesByJudgmentBySection body
}
instance Collect (Tree BodyNode) where
collect (Tree n ts) =
case n of
BodyBlock b -> collect b
- BodySection s@Section{title, aliases} ->
- def{ all_section = HM.fromListWith (<>) $ (\(Alias t) -> (t, pure $ Right s)) <$> (Alias title : aliases) } <>
+ BodySection s@Section{..} ->
+ def{ all_section = HM.fromListWith (<>) $
+ (\(Alias t) -> (t, pure $ Right s))
+ <$> (Alias section_title : section_aliases)
+ } <>
foldMap collect ts
instance Collect DTC.Block where
collect = \case
BlockToC{} -> def
BlockToF{} -> def
BlockAside{..} -> foldMap collect blocks
- BlockIndex{..} -> def{all_index = Map.singleton xmlPos terms}
+ BlockIndex{..} -> def{all_index = Map.singleton posXML terms}
BlockFigure{..} ->
def{all_figure=
- Map.singleton type_ (Map.singleton xmlPos mayTitle)}
+ Map.singleton type_ (Map.singleton posXML mayTitle)}
-- <> foldMap collect paras
BlockReferences{..} ->
def{all_reference=
- HM.fromListWith (<>) $ (<$> refs) $ \ref@DTC.Reference{id} -> (id, pure ref)
+ HM.fromListWith (<>) $ (<$> refs) $ \ref@DTC.Reference{..} -> (reference_id, pure ref)
}
BlockGrades{attrs=CommonAttrs{id=i}, ..} ->
def{all_grades = HM.singleton (fromMaybe "" i) scale}
- BlockJudges{attrs=CommonAttrs{id=i}, ..} ->
- def{all_judges = HM.singleton (fromMaybe "" i) jury}
+ BlockJudges judges@Judges{judges_attrs=CommonAttrs{id=i}, ..} ->
+ def{all_judges = HM.singleton (fromMaybe "" i) judges}
{-
instance Collect Judgment where
collect Judgment{..} = def
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]))
+ (j,(judgment_importance, judgment_choices))
+
+choicesByJudgmentBySection :: Body -> TS.Trees (HM.HashMap Judgment (Maybe MJ.Share, [Choice]))
choicesByJudgmentBySection bod = bod >>= \(Tree b bs) ->
case b of
BodyBlock{} -> mempty
- BodySection Section{judgments} ->
+ BodySection Section{..} ->
pure $
- let choicesJ = choicesByJudgment judgments in
+ let choicesJ = choicesByJudgment section_judgments in
Tree choicesJ $
-- NOTE: if the 'BodySection' has a child which
-- is not a 'BodySection' itself, then add "phantom" 'Judgment's
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])) ->
+ TS.Tree (HM.HashMap Judgment (Maybe MJ.Share, [Choice])) ->
HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])]
-choicesBySectionByJudgment inh (TreeSeq.Tree selfJ childrenJS) =
+choicesBySectionByJudgment inh (TS.Tree selfJ childrenJS) =
HM.unionWith
(\selfS childrenS ->
(<$> selfS) $ \(Tree.Node choices old) ->
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
+import Data.Sequence (Seq(..))
import Data.String (IsString)
import GHC.Generics (Generic)
import System.FilePath (FilePath)
import Text.Show (Show)
import qualified Data.Char as Char
+import qualified Data.HashMap.Strict as HM
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
import qualified Data.TreeSeq.Strict as TS
-- Type 'Section'
data Section = Section
- { xmlPos :: !XML.Pos
- , attrs :: !CommonAttrs
- , title :: !Title
- , aliases :: ![Alias]
- , judgments :: ![Judgment]
+ { section_posXML :: !XML.Pos
+ , section_attrs :: !CommonAttrs
+ , section_title :: !Title
+ , section_aliases :: ![Alias]
+ , section_judgments :: ![Judgment]
} deriving (Eq,Show)
-- * Type 'Block'
data Block
= BlockPara Para
| BlockBreak { attrs :: !CommonAttrs }
- | BlockToC { xmlPos :: !XML.Pos
+ | BlockToC { posXML :: !XML.Pos
, attrs :: !CommonAttrs
, depth :: !(Maybe Nat)
}
- | BlockToF { xmlPos :: !XML.Pos
+ | BlockToF { posXML :: !XML.Pos
, attrs :: !CommonAttrs
, types :: ![TL.Text]
}
- | BlockAside { xmlPos :: !XML.Pos
+ | BlockAside { posXML :: !XML.Pos
, attrs :: !CommonAttrs
, blocks :: ![Block]
}
- | BlockFigure { xmlPos :: !XML.Pos
+ | BlockFigure { posXML :: !XML.Pos
, type_ :: !TL.Text
, attrs :: !CommonAttrs
, mayTitle :: !(Maybe Title)
, paras :: ![Para]
}
- | BlockIndex { xmlPos :: !XML.Pos
+ | BlockIndex { posXML :: !XML.Pos
, attrs :: !CommonAttrs
, terms :: !Terms
}
- | BlockReferences { xmlPos :: !XML.Pos
+ | BlockReferences { posXML :: !XML.Pos
, attrs :: !CommonAttrs
, refs :: ![Reference]
} -- FIXME: move to ParaReferences?
- | BlockJudges { xmlPos :: !XML.Pos
- , attrs :: !CommonAttrs
- , jury :: ![Judge]
- }
- | BlockGrades { xmlPos :: !XML.Pos
+ | BlockJudges !Judges
+ | BlockGrades { posXML :: !XML.Pos
, attrs :: !CommonAttrs
, scale :: ![Grade]
}
-- * Type 'Judgment'
data Judgment = Judgment
- { opinionsByChoice :: !(Maybe (MJ.OpinionsByChoice Choice Judge Grade))
- , judges :: !Ident
- , grades :: !Ident
- , importance :: !(Maybe MJ.Share)
- , question :: !(Maybe Title)
- , choices :: ![Choice]
+ { judgment_opinionsByChoice :: !(Maybe (MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade)))
+ , judgment_judges :: !(Maybe Judges)
+ , judgment_grades :: !(Maybe (MJ.Grades (MJ.Ranked Grade)))
+ , judgment_posXML :: !XML.Pos
+ , judgment_locTCT :: !TCT.Location
+ , judgment_judgesId :: !Ident
+ , judgment_gradesId :: !Ident
+ , judgment_importance :: !(Maybe MJ.Share)
+ , judgment_question :: !(Maybe Title)
+ , judgment_choices :: ![Choice]
} deriving (Show)
instance Eq Judgment where
x==y =
- judges x == judges y &&
- grades x == grades y &&
- question x == question y
+ judgment_judgesId x == judgment_judgesId y &&
+ judgment_gradesId x == judgment_gradesId y &&
+ judgment_question x == judgment_question y
instance Hashable Judgment where
hashWithSalt s Judgment{..} =
- s`hashWithSalt`judges
- `hashWithSalt`grades
- `hashWithSalt`question
+ s`hashWithSalt`judgment_judgesId
+ `hashWithSalt`judgment_gradesId
+ `hashWithSalt`judgment_question
+
+-- ** Type 'ErrorJudgment'
+data ErrorJudgment
+ = ErrorJudgment_Judges
+ | ErrorJudgment_Grades
+ deriving (Eq,Show)
+
+-- ** Type 'Judges'
+data Judges = Judges
+ { judges_locTCT :: !TCT.Location
+ , judges_posXML :: !XML.Pos
+ , judges_attrs :: !CommonAttrs
+ , judges_byName :: !(HM.HashMap Name [Judge])
+ } deriving (Eq,Show)
-- ** Type 'Judge'
data Judge = Judge
- { name :: !Name
- , title :: !(Maybe Title)
- , defaultGrades :: ![(Ident, Name)]
+ { judge_locTCT :: !TCT.Location
+ , judge_posXML :: !XML.Pos
+ , judge_name :: !Name
+ , judge_title :: !(Maybe Title)
+ , judge_defaultGrades :: !(HM.HashMap Ident [Name])
} deriving (Eq,Show)
-- ** Type 'Grade'
data Grade = Grade
- { xmlPos :: !XML.Pos
- , name :: !Name
- , color :: !TL.Text
- , isDefault :: !Bool
- , title :: !(Maybe Title)
+ { grade_posXML :: !XML.Pos
+ , grade_name :: !Name
+ , grade_color :: !TL.Text
+ , grade_isDefault :: !Bool
+ , grade_title :: !(Maybe Title)
} deriving (Eq,Show)
-- ** Type 'Choice'
data Choice = Choice
- { title :: !(Maybe Title)
- , opinions :: ![Opinion]
+ { choice_locTCT :: TCT.Location
+ , choice_posXML :: XML.Pos
+ , choice_title :: !(Maybe Title)
+ , choice_opinions :: ![Opinion]
} deriving (Show)
instance Eq Choice where
- (==) = (==)`on`(title::Choice -> Maybe Title)
+ (==) = (==)`on`choice_title
instance Hashable Choice where
hashWithSalt s Choice{..} =
- hashWithSalt s title
+ hashWithSalt s choice_title
-- ** Type 'Opinion'
data Opinion = Opinion
- { judge :: !Name
- , grade :: !Name
- , importance :: !(Maybe MJ.Share)
- , comment :: !(Maybe Title)
+ { opinion_locTCT :: !TCT.Location
+ , opinion_posXML :: !XML.Pos
+ , opinion_judge :: !Name
+ , opinion_grade :: !Name
+ , opinion_importance :: !(Maybe MJ.Share)
+ , opinion_comment :: !(Maybe Title)
} deriving (Eq,Show)
-- * Type 'Para'
data Para
= ParaItem { item :: !ParaItem }
- | ParaItems { xmlPos :: !XML.Pos
+ | ParaItems { posXML :: !XML.Pos
, attrs :: !CommonAttrs
, items :: ![ParaItem]
}
| PlainSub -- ^ Subscript
| PlainSup -- ^ Superscript
| PlainU -- ^ Underlined
- | PlainEref { href :: !URL } -- ^ External reference
- | PlainIref { anchor :: !(Maybe Anchor)
- , term :: !Words
+ | PlainEref { eref_href :: !URL } -- ^ External reference
+ | PlainIref { iref_anchor :: !(Maybe Anchor)
+ , iref_term :: !Words
} -- ^ Index reference
- | PlainTag { error :: !(Maybe ErrorTarget)
- , locTCT :: !TCT.Location
+ | PlainTag { tag_error :: !(Maybe ErrorTarget)
+ , tag_locTCT :: !TCT.Location
} -- ^ Reference
- | PlainRref { error :: !(Maybe ErrorTarget)
- , number :: !(Maybe Nat1)
- , locTCT :: !TCT.Location
- , to :: !Ident
+ | PlainRref { rref_error :: !(Maybe ErrorTarget)
+ , rref_number :: !(Maybe Nat1)
+ , rref_locTCT :: !TCT.Location
+ , rref_to :: !Ident
} -- ^ Reference reference
- | PlainSpan { attrs :: !CommonAttrs } -- ^ Neutral node
+ | PlainSpan { attrs :: !CommonAttrs } -- ^ Neutral node
-- Leafs
| PlainBreak -- ^ Line break (\n)
| PlainText TL.Text
- | PlainNote { number :: !(Maybe Nat1)
- , note :: ![Para]
+ | PlainNote { note_number :: !(Maybe Nat1)
+ , note_paras :: ![Para]
} -- ^ Footnote
deriving (Eq,Show)
-- ** Type 'Anchor'
data Anchor = Anchor
- { section :: !XML.Pos
- , count :: !Nat1
+ { anchor_section :: !XML.Pos
+ , anchor_count :: !Nat1
} deriving (Eq,Ord,Show)
-- * Type 'Name'
case n of
PlainGroup -> skip
PlainNote{} -> skip
- PlainIref{..} -> pure $ TS.Tree PlainIref{anchor=Nothing, ..} skip
- PlainRref{..} -> pure $ TS.Tree PlainRref{error=Nothing, number=Nothing, locTCT=def, ..} skip
+ PlainIref{..} -> pure $ TS.Tree PlainIref{ iref_anchor = Nothing, ..} skip
+ PlainRref{..} -> pure $ TS.Tree PlainRref{ rref_error = Nothing
+ , rref_number = Nothing
+ , rref_locTCT = def
+ , .. } skip
PlainSpan attrs -> pure $ TS.Tree n' skip
where n' = PlainSpan{attrs = CommonAttrs{ id = Nothing
, classes = List.sort $ classes attrs }}
PlainSub -> keep
PlainSup -> keep
PlainU -> keep
- PlainEref _to -> keep
- PlainTag{..} -> pure $ TS.Tree PlainTag{locTCT=def, ..} skip
+ PlainEref{..} -> keep
+ PlainTag{..} -> pure $ TS.Tree PlainTag{tag_locTCT=def, ..} skip
PlainBreak -> keep
PlainText{} -> keep
-- | Return the same hash if 'similarPlain' is applied on the 'Title' before hashing.
case n of
PlainGroup -> s
PlainNote{} -> s
- PlainIref{..} -> s`hashWithSalt`(0::Int)`hashWithSalt`term
+ PlainIref{..} -> s`hashWithSalt`(0::Int)`hashWithSalt`iref_term
PlainTag{..} -> s`hashWithSalt`(1::Int)
PlainSpan{..} -> s`hashWithSalt`(2::Int)`hashWithSalt`List.sort (classes attrs)
PlainB -> s`hashWithSalt`(3::Int)
PlainSub -> s`hashWithSalt`(9::Int)
PlainSup -> s`hashWithSalt`(10::Int)
PlainU -> s`hashWithSalt`(11::Int)
- PlainEref{..} -> s`hashWithSalt`(12::Int)`hashWithSalt`href
- PlainRref{..} -> s`hashWithSalt`(13::Int)`hashWithSalt`to
+ PlainEref{..} -> s`hashWithSalt`(12::Int)`hashWithSalt`eref_href
+ PlainRref{..} -> s`hashWithSalt`(13::Int)`hashWithSalt`rref_to
PlainBreak -> s`hashWithSalt`(14::Int)
PlainText t -> s`hashWithSalt`(15::Int)`hashWithSalt`t
-- * Type 'Reference'
data Reference = Reference
- { error :: !(Maybe ErrorAnchor)
- , xmlPos :: !XML.Pos
- , locTCT :: !TCT.Location
- , id :: !Ident
- , about :: !About
+ { reference_error :: !(Maybe ErrorAnchor)
+ , reference_posXML :: !XML.Pos
+ , reference_locTCT :: !TCT.Location
+ , reference_id :: !Ident
+ , reference_about :: !About
} deriving (Eq,Show)
-- * Type 'Date'
import Data.Function (($), const)
import Data.Functor ((<$>))
import Data.Map.Strict (Map)
-import Data.Maybe (Maybe(..), maybe)
+import Data.Maybe (Maybe(..), maybe, listToMaybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence ((|>))
Word w : next ->
case goWords irefs [] inp of
Nothing -> go (acc |> tree0 (PlainText w)) irefs next
- Just (anch, ls, ns, rs) ->
- let term = List.reverse ls in
- let lines = Seq.fromList $ tree0 . PlainText . plainifyWord <$> term in
- go (acc |> Tree PlainIref{term, anchor=Just anch} lines) rs ns
+ Just (anchor, ls, ns, rs) ->
+ let iref_term = List.reverse ls in
+ let lines = Seq.fromList $ tree0 . PlainText . plainifyWord <$> iref_term in
+ go (acc |> Tree PlainIref
+ { iref_term
+ , iref_anchor=Just anchor
+ } lines) rs ns
goWords ::
Irefs ->
Words -> Words ->
Strict.Just anchs ->
case goWords node_descendants prev' next of
Nothing ->
- let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c in
- let anch = Anchor{count, section} in
+ let anch = Anchor
+ { anchor_count = maybe def (succNat1 . anchor_count) $ listToMaybe anchs
+ , anchor_section = section } in
Just (anch, prev', next, TreeMap $
Map.insert w nod{TreeMap.node_value = Strict.Just $ anch:anchs} irefsByWord)
Just (anch, ls, ns, rs) ->
-- * Type 'State'
data State = State
- { state_xmlPos :: XML.Pos
- , state_locationTCT :: TCT.Location
+ { state_posXML :: XML.Pos
+ , state_locTCT :: TCT.Location
-- ^ Unfortunately Megaparsec's 'P.statePos'
-- is not a good fit to encode 'TCT.Location'.
} deriving (Eq,Show)
instance Default State where
def = State
- { state_xmlPos = def
- , state_locationTCT = def
+ { state_posXML = def
+ , state_locTCT = def
}
-- * Type 'Parser'
fail = P.label "fail" $ P.failure Nothing mempty
any = P.label "any" $ p_satisfyMaybe $ const $ Just ()
anyElem p = P.label "anyElem" $ do
- Cell state_locationTCT (n,ts) <- P.token check $ Just expected
- parserElement n (p n) (Cell state_locationTCT ts)
+ Cell state_locTCT (n,ts) <- P.token check $ Just expected
+ parserElement n (p n) (Cell state_locTCT ts)
where
expected = Tree (cell0 $ XML.NodeElem "*") mempty
check (Tree cell@(unCell -> XML.NodeElem e) ts) = Right $ (e,ts) <$ cell
try = P.try
parserElement :: XML.Name -> Parser a -> Cell XML.XMLs -> Parser a
-parserElement n p (Cell state_locationTCT ts) = do
+parserElement n p (Cell state_locTCT ts) = do
let mayNameOrFigureName
| n == "aside" = Nothing
-- NOTE: skip aside.
case mayNameOrFigureName of
Nothing -> do
st <- S.get
- S.put st{state_locationTCT}
+ S.put st{state_locTCT}
res <- parser p ts
S.put st
return res
Just nameOrFigureName -> do
- st@State{state_xmlPos} <- S.get
+ st@State{state_posXML} <- S.get
let incrPrecedingSibling name =
maybe (Nat1 1) succNat1 $
Map.lookup name $
- XML.pos_precedingSiblings state_xmlPos
+ XML.pos_precedingSiblings state_posXML
S.put State
- { state_xmlPos = state_xmlPos
+ { state_posXML = state_posXML
-- NOTE: in children, push current name incremented on ancestors
-- and reset preceding siblings.
{ XML.pos_precedingSiblings = mempty
- , XML.pos_ancestors = XML.pos_ancestors state_xmlPos |> (n, incrPrecedingSibling n)
+ , XML.pos_ancestors = XML.pos_ancestors state_posXML |> (n, incrPrecedingSibling n)
, XML.pos_ancestorsWithFigureNames =
- XML.pos_ancestorsWithFigureNames state_xmlPos |>
+ XML.pos_ancestorsWithFigureNames state_posXML |>
( nameOrFigureName
, incrPrecedingSibling nameOrFigureName )
}
- , state_locationTCT
+ , state_locTCT
}
res <- parser p ts
S.put st
- { state_xmlPos = state_xmlPos
+ { state_posXML = state_posXML
-- NOTE: after current, increment current name
-- and reset ancestors.
{ XML.pos_precedingSiblings =
(if n == nameOrFigureName then id
else Map.insertWith (const succNat1) nameOrFigureName (Nat1 1)) $
Map.insertWith (const succNat1) n (Nat1 1) $
- XML.pos_precedingSiblings state_xmlPos
+ XML.pos_precedingSiblings state_posXML
}
}
return res
f <$*> a = f P.<$?> ([],P.some a)
f <|*> a = f P.<|?> ([],P.some a)
instance DTC.Sym_DTC Parser where
- posXML = S.gets state_xmlPos
- locationTCT = S.gets state_locationTCT
+ positionXML = S.gets state_posXML
+ locationTCT = S.gets state_locTCT
readDTC ::
DTC.Sym_DTC Parser =>
| ErrorRead_Not_Nat1 Int
| ErrorRead_Not_Rational TL.Text
| ErrorRead_Not_Positive TL.Text
- -- | ErrorRead_Unexpected P.sourcePos XML
+ {- ErrorRead_Unexpected P.sourcePos XML -}
deriving (Eq,Ord,Show)
instance P.ShowErrorComponent ErrorRead where
showErrorComponent = show
{-# LANGUAGE OverloadedStrings #-}
module Hdoc.DTC.Sym where
-import Data.Bool (Bool(..))
import Control.Applicative (Applicative(..), (<$>), (<$))
+import Control.Arrow (second)
import Control.Monad (void)
+import Data.Bool (Bool(..))
import Data.Default.Class (Default(..))
import Data.Foldable (Foldable(..), concat)
-import Data.Function (($), (.))
+import Data.Function (($), (.), flip)
import Data.Maybe (Maybe(..))
+import Data.Semigroup (Semigroup(..))
import Data.TreeSeq.Strict (Tree(..), tree0)
import qualified Control.Applicative as Alt
+import qualified Data.HashMap.Strict as HM
import qualified Data.Sequence as Seq
import qualified Data.Text.Lazy as TL
-- when repr is respectively instanciated
-- on 'DTC.Parser' or 'RNC.RuleWriter'.
class RNC.Sym_RNC repr => Sym_DTC repr where
- posXML :: repr XML.Pos
+ positionXML :: repr XML.Pos
locationTCT :: repr TCT.Location
document :: repr DTC.Document
judgment :: repr DTC.Judgment
choice_ :: repr DTC.Choice
opinion :: repr DTC.Opinion
+ judges :: repr DTC.Judges
judge :: repr DTC.Judge
grade :: repr DTC.Grade
where
section =
DTC.Section
- <$> posXML
+ <$> positionXML
<*> commonAttrs
<*> title
<*> many alias
rule "blockToC" $
element "toc" $
DTC.BlockToC
- <$> posXML
+ <$> positionXML
<*> commonAttrs
<*> optional (attribute "depth" nat)
blockToF =
rule "blockToF" $
element "tof" $
DTC.BlockToF
- <$> posXML
+ <$> positionXML
<*> commonAttrs
<*> option [] (
element "ul" $
rule "blockIndex" $
element "index" $
DTC.BlockIndex
- <$> posXML
+ <$> positionXML
<*> commonAttrs
<*> option [] (
element "ul" $
rule "blockAside" $
element "aside" $
DTC.BlockAside
- <$> posXML
+ <$> positionXML
<*> commonAttrs
<*> many block
blockFigure =
rule "blockFigure" $
element "figure" $
DTC.BlockFigure
- <$> posXML
+ <$> positionXML
<*> attribute "type" text
<*> commonAttrs
<*> optional title
rule "blockReferences" $
element "references" $
DTC.BlockReferences
- <$> posXML
+ <$> positionXML
<*> commonAttrs
<*> many reference
- blockJudges =
- rule "blockJudges" $
- element "judges" $
- DTC.BlockJudges
- <$> posXML
- <*> commonAttrs
- <*> many judge
+ blockJudges = rule "blockJudges" $ DTC.BlockJudges <$> judges
blockGrades =
rule "blockGrades" $
element "grades" $
DTC.BlockGrades
- <$> posXML
+ <$> positionXML
<*> commonAttrs
- <*> many grade
+ <*> some grade
grade =
rule "grade" $
element "grade" $
DTC.Grade
- <$> posXML
+ <$> positionXML
<*> attribute "name" name
<*> attribute "color" text
<*> option False (True <$ attribute "default" text)
rule "paraItems" $
element "para" $
DTC.ParaItems
- <$> posXML
+ <$> positionXML
<*> commonAttrs
<*> many paraItem
plain = rule "plain" $ (Seq.fromList <$>) $ many plainNode
reference = rule "reference" $
element "reference" $
DTC.Reference Nothing
- <$> posXML
+ <$> positionXML
<*> locationTCT
<*> id
<*> about
where
attrs =
interleaved $
- DTC.Judgment Nothing
- <$$> attribute "judges" ident
+ DTC.Judgment def def def
+ <$$> positionXML
+ <||> locationTCT
+ <||> attribute "judges" ident
<||> attribute "grades" ident
<|?> (def, Just <$> attribute "importance" rationalPositive)
<|?> (def, Just <$> title)
rule "choice" $
element "choice" $
DTC.Choice
- <$> optional title
+ <$> locationTCT
+ <*> positionXML
+ <*> optional title
<*> many opinion
opinion =
rule "opinion" $
element "opinion" $
(interleaved $ DTC.Opinion
- <$?> (def, attribute "judge" name)
+ <$$> locationTCT
+ <||> positionXML
+ <|?> (def, attribute "judge" name)
<|?> (def, attribute "grade" name)
<|?> (def, Just <$> attribute "importance" rationalPositive))
<*> optional title
+ judges =
+ rule "judges" $
+ element "judges" $
+ DTC.Judges
+ <$> locationTCT
+ <*> positionXML
+ <*> commonAttrs
+ <*> judgesByName
+ where
+ judgesByName =
+ HM.fromListWith (flip (<>)) .
+ ((\j@DTC.Judge{..} -> (judge_name, pure j)) <$>)
+ <$> some judge
judge =
rule "judge" $
element "judge" $
DTC.Judge
- <$> attribute "name" name
+ <$> locationTCT
+ <*> positionXML
+ <*> attribute "name" name
<*> optional title
- <*> many defaultGrade
+ <*> defaultGrades
where
+ defaultGrades =
+ HM.fromListWith (flip (<>)) .
+ (second pure <$>)
+ <$> many defaultGrade
defaultGrade =
rule "default" $
element "default" $
<*> attribute "grade" (DTC.Name <$> text)
instance Sym_DTC RNC.Writer where
- posXML = RNC.writeText ""
+ positionXML = RNC.writeText ""
locationTCT = RNC.writeText ""
instance Sym_DTC RNC.RuleWriter where
- posXML = RNC.RuleWriter posXML
+ positionXML = RNC.RuleWriter positionXML
locationTCT = RNC.RuleWriter locationTCT
-- | RNC schema for DTC
, void $ judgment
, void $ choice_
, void $ opinion
+ , void $ judges
, void $ judge
, void $ grade
{-# 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.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, fromJust, maybeToList, listToMaybe)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
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 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 Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
import qualified Text.Blaze.Internal as H
import Hdoc.DTC.Write.Plain (Plainify(..))
import Hdoc.DTC.Write.XML ()
import Hdoc.Utils
+import Control.Monad.Utils
import Text.Blaze.Utils
import qualified Hdoc.DTC.Check as Check
import qualified Hdoc.DTC.Collect as Collect
import qualified Hdoc.Utils as FS
import qualified Hdoc.XML as XML
import qualified Paths_hdoc as Hdoc
+import Hdoc.DTC.Write.HTML5.Base
+import Hdoc.DTC.Write.HTML5.Judgment
+import Hdoc.DTC.Write.HTML5.Error ()
import Debug.Trace
debug :: Show a => String -> 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)
-
--- * 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) =
+ let state_collect = Collect.collect doc in
Check.check body `S.runState` def
- { Check.state_irefs = foldMap Index.irefsOfTerms all_index
- , Check.state_collect = collect
+ { Check.state_irefs = foldMap Index.irefsOfTerms $ Collect.all_index state_collect
+ , Check.state_collect
}
let (html5Body, endState) =
let Check.State{..} = checkState in
- runStateMarkup def
+ runComposeState def
{ state_collect
, state_indexs =
- (<$> all_index) $ \terms ->
+ (<$> Collect.all_index state_collect) $ \terms ->
(terms,) $
TreeMap.intersection const state_irefs $
Index.irefsOfTerms terms
_ -> Nothing
forM_ chapters $ \Section{..} ->
H.link ! HA.rel "Chapter"
- ! HA.title (attrify $ plainify title)
- ! HA.href (refIdent $ identify xmlPos)
+ ! HA.title (attrify $ plainify section_title)
+ ! HA.href (refIdent $ identify section_posXML)
csss
scripts
html5DocumentHead :: Head -> HTML5
html5DocumentHead Head{DTC.about=About{..}, judgments} = do
- st <- liftStateMarkup S.get
+ st <- liftComposeState S.get
unless (null authors) $ do
H.div ! HA.class_ "document-head" $$
H.table $$ do
do -- judgments
let sectionJudgments = HS.fromList judgments
let opinsBySectionByJudgment = state_opinions st `HM.intersection` HS.toMap sectionJudgments
- liftStateMarkup $ S.modify' $ \s ->
+ liftComposeState $ S.modify' $ \s ->
s{ state_judgments = sectionJudgments
, state_opinions =
-- NOTE: drop current opinions of the judgments of this section
}
unless (null opinsBySectionByJudgment) $ do
let choicesJ = Collect.choicesByJudgment judgments
- forM_ (HM.toList opinsBySectionByJudgment) $ \(judgment@Judgment{question},opinsBySection) -> do
+ forM_ (HM.toList opinsBySectionByJudgment) $ \(judgment@Judgment{..},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
+ html5ify judgment
+ { judgment_opinionsByChoice = listToMaybe opinsBySection
+ , judgment_choices = maybe [] snd $ HM.lookup judgment choicesJ
+ }
where
docHeaders =
H.table ! HA.class_ "document-headers" $$
H.tbody $$ do
- Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
+ Loqualization l10n <- liftComposeState $ S.gets state_l10n
forM_ series $ \s@Serie{id=id_, name} ->
header $
case urlSerie s of
unless (TL.null $ unName name) $
header $ do
headerName $ html5ify name
- headerValue $ html5ify $ Tree PlainEref{href} plain
+ headerValue $ html5ify $ Tree PlainEref{eref_href=href} plain
forM_ date $ \d ->
header $ do
headerName $ l10n_Header_Date l10n
forM_ url $ \href ->
header $ do
headerName $ l10n_Header_Address l10n
- headerValue $ html5ify $ tree0 $ PlainEref{href}
+ headerValue $ html5ify $ tree0 $ PlainEref{eref_href=href}
forM_ headers $ \Header{..} ->
header $ do
headerName $ html5ify name
headerName hdr =
H.td ! HA.class_ "header-name" $$ do
hdr
- Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
+ Loqualization l10n <- liftComposeState $ 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
+-- 'Html5ify' instances
instance Html5ify TCT.Location where
html5ify = \case
s:|[] ->
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)
- )
instance Html5ify Body where
html5ify body = do
- liftStateMarkup $ S.modify' $ \s -> s{state_section = body}
+ liftComposeState $ 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
+ notes <- liftComposeState $ S.gets state_notes
maybe mempty html5Notes $
Map.lookup mempty notes
_ -> mempty
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}
+ st@State{state_collect=Collect.All{..}} <- liftComposeState S.get
+ liftComposeState $ S.modify' $ \s -> s{state_section = bs}
do -- notes
let mayNotes = do
- sectionPosPath <- XML.ancestors $ XML.pos_ancestors xmlPos
+ sectionPosPath <- XML.ancestors $ XML.pos_ancestors section_posXML
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}
+ liftComposeState $ 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
+ html5CommonAttrs section_attrs{classes="section":classes section_attrs, id=Nothing} $
+ H.section ! HA.id (attrify $ identify section_posXML) $$ do
+ forM_ section_aliases html5ify
do -- judgments
- let sectionJudgments = state_judgments st `HS.union` HS.fromList judgments
+ let sectionJudgments = state_judgments st `HS.union` HS.fromList section_judgments
let opinsBySectionByJudgment = state_opinions st `HM.intersection` HS.toMap sectionJudgments
let dropChildrenBlocksJudgments =
-- NOTE: drop the "phantom" judgments concerning the 'BodyBlock's
_ -> False
then List.tail
else Cat.id
- liftStateMarkup $ S.modify' $ \s ->
+ liftComposeState $ S.modify' $ \s ->
s{ state_judgments = sectionJudgments
, state_opinions =
-- NOTE: drop current opinions of the judgments of this section
opinsBySectionByJudgment
}
unless (null opinsBySectionByJudgment) $ do
- liftStateMarkup $ S.modify' $ \s -> s
+ liftComposeState $ 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
+ let choicesJ = Collect.choicesByJudgment section_judgments
+ forM_ (HM.toList opinsBySectionByJudgment) $ \(judgment@Judgment{..},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
+ html5ify judgment
+ { judgment_opinionsByChoice = listToMaybe opinsBySection
+ , judgment_choices = maybe [] snd $ HM.lookup judgment choicesJ
+ }
let mayId =
- case toList <$> HM.lookup title all_section of
- Just [_] -> Just $ identifyTitle (Plain.state_l10n $ state_plainify st) title
+ case toList <$> HM.lookup section_title all_section of
+ Just [_] -> Just $ identifyTitle (Plain.state_l10n $ state_plainify st) section_title
_ -> Nothing
H.table
! HA.class_ "section-header"
H.tbody $$
H.tr $$ do
H.td ! HA.class_ "section-number" $$ do
- html5SectionNumber $ XML.pos_ancestors xmlPos
+ html5SectionNumber $ XML.pos_ancestors section_posXML
H.td ! HA.class_ "section-title" $$ do
- (case List.length $ XML.pos_ancestors xmlPos of
+ (case List.length $ XML.pos_ancestors section_posXML of
0 -> H.h1
1 -> H.h2
2 -> H.h3
4 -> H.h5
5 -> H.h6
_ -> H.h6) $$
- html5ify title
+ html5ify section_title
forM_ bs html5ify
do -- judgments
- liftStateMarkup $ S.modify' $ \s ->
+ liftComposeState $ S.modify' $ \s ->
s{ state_judgments = state_judgments st }
do -- notes
- notes <- liftStateMarkup $ S.gets state_notes
+ notes <- liftComposeState $ S.gets state_notes
maybe mempty html5Notes $
- Map.lookup (XML.pos_ancestors xmlPos) notes
- liftStateMarkup $ S.modify' $ \s -> s{state_section = state_section st}
+ Map.lookup (XML.pos_ancestors section_posXML) notes
+ liftComposeState $ S.modify' $ \s -> s{state_section = state_section st}
instance Html5ify Block where
html5ify = \case
BlockPara para -> html5ify para
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 <- liftComposeState $ S.gets state_l10n
Plain.l10n_Table_of_Contents l10n
H.ul $$ do
- State{state_section} <- liftStateMarkup S.get
+ State{state_section} <- liftComposeState S.get
forM_ state_section $ 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
BlockFigure{..} ->
html5CommonAttrs attrs
{ classes = "figure":("figure-"<>type_):classes attrs
- , DTC.id = Just $ Ident $ Plain.text def $ XML.pos_ancestorsWithFigureNames xmlPos
+ , DTC.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 <- liftComposeState $ S.gets state_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
+ BlockIndex{posXML} -> do
+ st@State{..} <- liftComposeState S.get
+ liftComposeState $ S.put st
{ state_styles = HS.insert (Left "dtc-index.css") state_styles }
- let (allTerms,refsByTerm) = state_indexs Map.!xmlPos
+ let (allTerms,refsByTerm) = state_indexs Map.!posXML
let chars = Index.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
html5ify term
H.dd $$
let anchs =
- List.sortBy (compare `on` DTC.section . snd) $
+ List.sortBy (compare `on` anchor_section . snd) $
(`foldMap` aliases) $ \words ->
fromJust $ do
path <- Index.pathFromWords words
html5CommasDot $
(<$> anchs) $ \(term,Anchor{..}) ->
H.a ! HA.class_ "index-iref"
- ! HA.href (refIdent $ identifyIrefCount term count) $$
- html5ify $ XML.pos_ancestors section
+ ! HA.href (refIdent $ identifyIrefCount term anchor_count) $$
+ html5ify $ XML.pos_ancestors anchor_section
BlockReferences{..} ->
html5CommonAttrs attrs
{ classes = "references":classes attrs
- , DTC.id = Just $ Ident $ Plain.text def $ XML.pos_ancestors xmlPos
+ , DTC.id = Just $ Ident $ Plain.text def $ XML.pos_ancestors posXML
} $
H.div $$ do
H.table $$
BlockGrades{..} ->
html5CommonAttrs attrs
{ classes = "grades":classes attrs
- , DTC.id = Just $ Ident $ Plain.text def $ XML.pos_ancestors xmlPos
+ , DTC.id = Just $ Ident $ Plain.text def $ 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{..} ->
ParaItems{..} ->
html5CommonAttrs attrs
{ classes = "para":classes attrs
- , DTC.id = id_ xmlPos
+ , DTC.id = id_ posXML
} $
H.div $$
forM_ items $ \item ->
where
id_ = Just . Ident . Plain.text def . XML.pos_ancestors
cls = \case
- ParaPlain{} -> []
- ParaArtwork{..} -> ["artwork", "artwork-"<>type_]
- ParaQuote{..} -> ["quote", "quote-"<>type_]
- ParaComment{} -> []
- ParaOL{} -> ["ol"]
- ParaUL{} -> ["ul"]
- ParaJudgment{} -> ["judgment"]
+ 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
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
PlainCode -> H.code $$ html5ify ls
PlainDel -> H.del $$ html5ify ls
PlainI -> do
- i <- liftStateMarkup $ do
+ i <- liftComposeState $ do
i <- S.gets $ Plain.state_italic . state_plainify
S.modify $ \s ->
s{state_plainify=
return i
H.em ! HA.class_ (if i then "even" else "odd") $$
html5ify ls
- liftStateMarkup $
+ liftComposeState $
S.modify $ \s ->
s{state_plainify=
(state_plainify s){Plain.state_italic=i}}
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."
+ case note_number of
+ Nothing -> mempty
Just num ->
H.a ! HA.class_ "note-ref"
! HA.id ("note-ref."<>attrify num)
html5ify num
PlainQ -> do
H.span ! HA.class_ "q" $$ do
- Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
+ Loqualization l10n <- liftComposeState $ S.gets state_l10n
Plain.l10n_Quote (html5ify $ Tree PlainI ls) l10n
PlainEref{..} ->
H.a ! HA.class_ "eref"
- ! HA.href (attrify href) $$
+ ! HA.href (attrify eref_href) $$
if null ls
- then html5ify $ unURL href
+ then html5ify $ unURL eref_href
else html5ify ls
PlainIref{..} ->
- case anchor of
+ case iref_anchor of
Nothing -> html5ify ls
- Just Anchor{count} ->
+ Just Anchor{..} ->
H.span ! HA.class_ "iref"
- ! HA.id (attrify $ identifyIrefCount term count) $$
+ ! HA.id (attrify $ identifyIrefCount iref_term anchor_count) $$
html5ify ls
- PlainTag{error} -> do
- st <- liftStateMarkup S.get
+ PlainTag{..} -> do
+ st <- liftComposeState S.get
let l10n = Plain.state_l10n $ state_plainify st
- case error of
+ case tag_error of
Nothing ->
H.a ! HA.class_ "tag"
! HA.href (refIdent $ identifyTitle l10n $ Title ls) $$
! HA.id (attrify $ identifyTag "-ambiguous" l10n ls num) $$
html5ify ls
PlainRref{..} -> do
- case error of
+ case rref_error of
Nothing ->
let ref = do
"["::HTML5
H.a ! HA.class_ "reference"
- ! HA.href (refIdent $ identifyReference "" to Nothing)
- ! HA.id (attrify $ identifyReference "" to number) $$
- html5ify to
+ ! HA.href (refIdent $ identifyReference "" rref_to Nothing)
+ ! HA.id (attrify $ identifyReference "" rref_to rref_number) $$
+ html5ify rref_to
"]" in
case toList ls 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
+ refs <- liftComposeState $ S.gets $ Collect.all_reference . state_collect
+ case toList <$> HM.lookup rref_to refs of
+ Just [Reference{reference_about=About{..}}] -> do
forM_ (List.take 1 titles) $ \(Title title) -> do
html5ify $ Tree PlainQ $
case url of
_ -> mempty
_ -> do
H.a ! HA.class_ "reference"
- ! HA.href (refIdent $ identifyReference "" to Nothing)
- ! HA.id (attrify $ identifyReference "" to number) $$
+ ! HA.href (refIdent $ identifyReference "" rref_to Nothing)
+ ! HA.id (attrify $ identifyReference "" rref_to rref_number) $$
html5ify ls
H.span ! HA.class_ "print-only" $$ do
" "::HTML5
Just (ErrorTarget_Unknown num) -> do
"["::HTML5
H.span ! HA.class_ "reference reference-unknown"
- ! HA.id (attrify $ identifyReference "-unknown" to $ Just num) $$
- html5ify to
+ ! HA.id (attrify $ identifyReference "-unknown" rref_to $ Just num) $$
+ html5ify rref_to
"]"
Just (ErrorTarget_Ambiguous num) -> do
case toList ls of
" "::HTML5
"["::HTML5
H.span ! HA.class_ "reference reference-ambiguous"
- !?? mayAttr HA.id (attrify . identifyReference "-ambiguous" to . Just <$> num) $$
- html5ify to
+ !?? mayAttr HA.id (attrify . identifyReference "-ambiguous" rref_to . Just <$> num) $$
+ html5ify rref_to
"]"
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
Just u -> pure $ Tree (PlainEref u) title
instance Html5ify Serie where
html5ify s@Serie{id=id_, name} = do
- Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
+ Loqualization l10n <- liftComposeState $ S.gets state_l10n
case urlSerie s of
Nothing -> do
html5ify name
html5ify id_
Just href -> do
html5ify $
- Tree PlainEref{href} $
+ Tree PlainEref{eref_href=href} $
Seq.fromList
[ tree0 $ PlainText $ unName name
, tree0 $ PlainText $ Plain.l10n_Colon l10n
html5ify = html5ify . Index.plainifyWords
instance Html5ify Alias where
html5ify Alias{..} = do
- st@State{state_collect=Collect.All{..}} <- liftStateMarkup S.get
+ st@State{state_collect=Collect.All{..}} <- liftComposeState S.get
let l10n = Plain.state_l10n $ state_plainify st
case toList <$> HM.lookup title all_section of
Just [_] ->
html5ify url
instance Html5ify Date where
html5ify date = do
- Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
+ Loqualization l10n <- liftComposeState $ S.gets state_l10n
Plain.l10n_Date date l10n
instance Html5ify Reference where
html5ify Reference{..} =
H.tr $$ do
H.td ! HA.class_ "reference-key" $$
html5ify $ tree0 PlainRref
- { number = Nothing
- , locTCT = def
- , to = id
- , error = (<$> error) $ \case
+ { rref_number = Nothing
+ , rref_locTCT = def
+ , rref_to = reference_id
+ , rref_error = (<$> reference_error) $ \case
ErrorAnchor_Ambiguous num -> ErrorTarget_Ambiguous (Just num)
}
H.td ! HA.class_ "reference-content" $$ do
- html5ify about
- rrefs <- liftStateMarkup $ S.gets state_rrefs
- case HM.lookup id rrefs of
+ html5ify reference_about
+ rrefs <- liftComposeState $ S.gets state_rrefs
+ case HM.lookup reference_id rrefs 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) $$
+ ! HA.href (refIdent $ identifyReference "" reference_id $ Just num) $$
case maySection of
Nothing -> "0"::HTML5
- Just Section{xmlPos=posSection} -> html5ify $ XML.pos_ancestors posSection
+ Just Section{section_posXML=posSection} -> html5ify $ XML.pos_ancestors posSection
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
+ sp <- liftComposeState $ S.gets state_plainify
let (t,sp') = Plain.runPlain p sp
html5ify t
- liftStateMarkup $ S.modify $ \s -> s{state_plainify=sp'}
+ liftComposeState $ S.modify $ \s -> s{state_plainify=sp'}
{-
instance Html5ify SVG.Element where
html5ify svg =
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
where
H.tbody $$
H.tr $$ do
H.td ! HA.class_ "section-number" $$
- html5SectionRef $ XML.pos_ancestors xmlPos
+ html5SectionRef $ XML.pos_ancestors section_posXML
H.td ! HA.class_ "section-title" $$
- html5ify $ cleanPlain $ unTitle title
+ html5ify $ cleanPlain $ unTitle section_title
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 <- liftComposeState $ S.gets $ Collect.all_figure . state_collect
let figures =
Map.foldMapWithKey (\ty -> ((ty,) <$>)) $
if null types
else
Map.intersection figuresByType $
Map.fromList [(ty,()) | ty <- types]
- forM_ (Map.toList figures) $ \(xmlPos, (type_, title)) ->
+ 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}}
--- /dev/null
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Hdoc.DTC.Write.HTML5.Base where
+
+import Control.Monad (Monad(..))
+import Data.Char (Char)
+import Data.Default.Class (Default(..))
+import Data.Either (Either(..))
+import Data.Foldable (Foldable(..))
+import Data.Function (($), (.))
+import Data.Functor ((<$>))
+import Data.Functor.Compose (Compose(..))
+import Data.Int (Int)
+import Data.Locale hiding (Index)
+import Data.Map.Strict (Map)
+import Data.Maybe (Maybe(..), maybe)
+import Data.Semigroup (Semigroup(..))
+import Data.String (String, IsString(..))
+import Data.Text (Text)
+import Prelude (mod)
+import Text.Show (Show(..))
+import qualified Control.Category as Cat
+import qualified Control.Monad.Trans.State as S
+import qualified Data.HashMap.Strict as HM
+import qualified Data.HashSet as HS
+import qualified Data.Text.Lazy as TL
+import qualified Data.TreeSeq.Strict as TreeSeq
+import qualified Hjugement as MJ
+import qualified Text.Blaze.Html5 as H
+import qualified Text.Blaze.Internal as H
+
+import Hdoc.DTC.Document as DTC
+import Hdoc.DTC.Write.XML ()
+import qualified Text.Blaze.Internal as B
+-- import Text.Blaze.Utils
+import Control.Monad.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.Write.Plain as Plain
+import qualified Hdoc.XML as XML
+
+-- * Type 'HTML5'
+type HTML5 = ComposeState State B.MarkupM ()
+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
+ }
+
+-- * 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 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
+
+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_
+
+-- * 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
+ l10n_Error_Judgment_Judges_unknown :: FullLocale lang -> msg
+ l10n_Error_Judgment_Judge_unknown :: FullLocale lang -> msg
+ l10n_Error_Judgment_Judge_duplicated :: FullLocale lang -> msg
+ l10n_Error_Judgment_Grades_unknown :: FullLocale lang -> msg
+ l10n_Error_Judgment_Grades_duplicated :: FullLocale lang -> msg
+ l10n_Error_Judgment_Grade_unknown :: FullLocale lang -> msg
+ l10n_Error_Judgment_Choice_duplicated :: 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"
+ l10n_Error_Judgment_Judges_unknown _l10n = "Unknown judges"
+ l10n_Error_Judgment_Judge_unknown _l10n = "Unknown judge"
+ l10n_Error_Judgment_Judge_duplicated _l10n = "Duplicated judge"
+ l10n_Error_Judgment_Grades_unknown _l10n = "Unknown grades"
+ l10n_Error_Judgment_Grades_duplicated _l10n = "Duplicated grades"
+ l10n_Error_Judgment_Grade_unknown _l10n = "Unknown grade"
+ l10n_Error_Judgment_Choice_duplicated _l10n = "Duplicated choice"
+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ë"
+ l10n_Error_Judgment_Judges_unknown _l10n = "Juges inconnu·es"
+ l10n_Error_Judgment_Judge_unknown _l10n = "Juge unconnu·e"
+ l10n_Error_Judgment_Judge_duplicated _l10n = "Juge en double"
+ l10n_Error_Judgment_Grades_unknown _l10n = "Mentions inconnues"
+ l10n_Error_Judgment_Grades_duplicated _l10n = "Mentions en double"
+ l10n_Error_Judgment_Grade_unknown _l10n = "Mention inconnue"
+ l10n_Error_Judgment_Choice_duplicated _l10n = "Choix en double"
+
+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 <- liftComposeState $ 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 =
+ liftComposeState $ 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 <- liftComposeState $ 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 =
+ liftComposeState $ S.modify' $ \s ->
+ s{state_plainify=(state_plainify s){Plain.state_quote=d}}
--- /dev/null
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Hdoc.DTC.Write.HTML5.Error where
+
+import Control.Applicative (Applicative(..))
+import Control.Monad (forM_, mapM_)
+import Data.Either (Either(..))
+import Data.Foldable (Foldable(..))
+import Data.Function (($), (.))
+import Data.Functor ((<$>))
+import Data.Int (Int)
+import Data.Locale hiding (Index)
+import Data.Map.Strict (Map)
+import Data.Maybe (Maybe(..))
+import Data.Ord (Ord(..))
+import Data.Semigroup (Semigroup(..))
+import Data.Sequence (Seq(..))
+import Data.TreeSeq.Strict (tree0)
+import Data.Tuple (fst, snd)
+import Text.Blaze ((!))
+import Text.Show (Show(..))
+import qualified Control.Monad.Trans.State as S
+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.Text.Lazy as TL
+import qualified Text.Blaze.Html5 as H
+import qualified Text.Blaze.Html5.Attributes as HA
+
+import Control.Monad.Utils
+import Hdoc.DTC.Document as DTC
+import Hdoc.DTC.Write.HTML5.Base
+import Hdoc.DTC.Write.HTML5.Ident
+import Hdoc.DTC.Write.XML ()
+import Text.Blaze.Utils
+import qualified Hdoc.DTC.Check as Check
+import qualified Hdoc.DTC.Collect as Collect
+import qualified Hdoc.DTC.Write.Plain as Plain
+import qualified Hdoc.TCT.Cell as TCT
+import qualified Hdoc.XML as XML
+
+instance (Html5ify Plain, Html5ify TCT.Location) => Html5ify Check.Errors where
+ html5ify Check.Errors{..} = do
+ st@State
+ { state_collect = Collect.All{..}
+ , state_l10n = Loqualization (l10n::FullLocale lang)
+ , ..
+ } <- liftComposeState 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)
+ , (l10n_Error_Judgment_Judges_unknown , errorIdent errors_judgment_judges_unknown)
+ , (l10n_Error_Judgment_Grades_unknown , errorIdent errors_judgment_grades_unknown)
+ , (l10n_Error_Judgment_Grades_duplicated, errorIdent errors_judgment_grades_duplicated)
+ , (l10n_Error_Judgment_Judge_unknown , errorName errors_judgment_judge_unknown)
+ , (l10n_Error_Judgment_Judge_duplicated , errorName errors_judgment_judge_duplicated)
+ , (l10n_Error_Judgment_Choice_duplicated, errorTitle errors_judgment_choice_duplicated)
+ , (l10n_Error_Judgment_Grade_unknown , errorName errors_judgment_grade_unknown)
+ ]
+ let numErrors = Nat $ sum $ (<$> errors) $ \(_typ, _descr, errByPosByKey) ->
+ sum $ length . snd <$> errByPosByKey
+ when (numErrors > Nat 0) $ do
+ liftComposeState $ 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 errByPosByKind :: Map TCT.Location{-errPos-}
+ (Seq ( Int{-errKind-}
+ , HTML5{-errKindDescr-}
+ , Plain{-errKey-}
+ , [(TCT.Location{-errPos-}, Ident{-errId-})] )) =
+ Map.unionsWith (<>) $ (<$> errors) $ \(errKind, errKindDescr, errByKey) ->
+ Map.unionsWith (<>) $ (<$> errByKey) $ \(errKey, errByPos) ->
+ Map.singleton (fst $ List.head errByPos) $
+ -- NOTE: sort using the first position of this errKind with this errKey.
+ pure (errKind, errKindDescr, errKey, errByPos)
+ forM_ errByPosByKind $
+ mapM_ $ \(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-location" $$
+ 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)
+ )
+ errorIdent :: HM.HashMap Ident (Seq (TCT.Location, XML.Pos)) -> [(Plain, [(TCT.Location,Ident)])]
+ errorIdent errs =
+ (<$> HM.toList errs) $ \(id, errPositions) ->
+ ( pure $ tree0 $ PlainText $ unIdent id
+ , (\(locTCT, posXML) ->
+ (locTCT, identify $ XML.pos_ancestorsWithFigureNames posXML))
+ <$> toList errPositions
+ )
+ errorName :: HM.HashMap Name (Seq (TCT.Location, XML.Pos)) -> [(Plain, [(TCT.Location,Ident)])]
+ errorName errs =
+ (<$> HM.toList errs) $ \(name, errPositions) ->
+ ( pure $ tree0 $ PlainText $ unName name
+ , (\(locTCT, posXML) ->
+ (locTCT, identify $ XML.pos_ancestorsWithFigureNames posXML))
+ <$> toList errPositions
+ )
+ errorTitle :: HM.HashMap Title (Seq (TCT.Location, XML.Pos)) -> [(Plain, [(TCT.Location,Ident)])]
+ errorTitle errs =
+ (<$> HM.toList errs) $ \(title, errPositions) ->
+ ( unTitle title
+ , (\(locTCT, posXML) ->
+ (locTCT, identify $ XML.pos_ancestorsWithFigureNames posXML))
+ <$> toList errPositions
+ )
instance Identify Nat1 where
identify (Nat1 a) = identify a
instance Identify Anchor where
- identify Anchor{..} = identify section <> "." <> identify count
+ identify Anchor{..} = identify anchor_section <> "." <> identify anchor_count
refIdent :: Ident -> H.AttributeValue
refIdent i = "#"<>attrify i
--- /dev/null
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Hdoc.DTC.Write.HTML5.Judgment where
+
+import Control.Monad (Monad(..), join, forM, forM_)
+import Data.Default.Class (Default(..))
+import Data.Either (Either(..))
+import Data.Eq (Eq(..))
+import Data.Foldable (Foldable(..))
+import Data.Function (($), (.))
+import Data.Functor ((<$>))
+import Data.Int (Int)
+import Data.Locale hiding (Index)
+import Data.Maybe (Maybe(..), maybe, maybeToList, listToMaybe, fromMaybe, isJust)
+import Data.Monoid (Monoid(..))
+import Data.Semigroup (Semigroup(..))
+import Data.String (String)
+import Data.Tuple (snd)
+import Prelude ((*), Fractional(..), Double, toRational, RealFrac(..))
+import Text.Blaze ((!))
+import Text.Show (Show(..))
+import qualified Control.Monad.Trans.State as S
+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.Set as Set
+import qualified Data.Text.Lazy as TL
+import qualified Data.Tree as Tree
+import qualified Hjugement as MJ
+import qualified Prelude (error)
+import qualified Text.Blaze.Html5 as H
+import qualified Text.Blaze.Html5.Attributes as HA
+
+import Hdoc.DTC.Document as DTC
+import Hdoc.DTC.Write.HTML5.Base
+import Hdoc.DTC.Write.HTML5.Ident
+import Hdoc.DTC.Write.XML ()
+import Control.Monad.Utils
+import Text.Blaze.Utils
+import qualified Hdoc.XML as XML
+import qualified Hdoc.DTC.Collect as Collect
+import qualified Hdoc.DTC.Write.Plain as Plain
+
+-- <debug>
+-- import Debug.Trace
+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)
+-- </debug>
+
+instance Html5ify Title => Html5ify Judgment where
+ html5ify Judgment{..} = do
+ liftComposeState $ S.modify' $ \s -> s
+ { state_styles = HS.insert (Left "dtc-judgment.css") $ state_styles s }
+ H.div ! HA.id (attrify $ identify $ XML.pos_ancestors judgment_posXML) $$ do
+ let commentJGC = HM.fromList
+ [ (choice_, HM.fromListWith (<>)
+ [ (opinion_grade, HM.singleton opinion_judge opinion_comment)
+ | Opinion{..} <- choice_opinions ])
+ | choice_@Choice{..} <- judgment_choices ]
+ case judgment_question of
+ Nothing -> mempty
+ Just title -> H.div ! HA.class_ "judgment-question" $$ html5ify title
+ H.dl ! HA.class_ "judgment-choices" $$ do
+ case judgment_opinionsByChoice of
+ Nothing -> do
+ forM_ judgment_choices $ \Choice{..} -> do
+ H.dt ! HA.class_ "choice-title"
+ ! HA.id (attrify $ identify $ XML.pos_ancestors choice_posXML) $$ do
+ html5ify choice_title
+ Just distByJudgeByChoice -> do
+ let meritByChoice@(MJ.MeritByChoice meritC) = MJ.meritByChoice distByJudgeByChoice
+ let ranking = MJ.majorityRanking meritByChoice
+ forM_ ranking $ \(choice_@DTC.Choice{..}, majorityValue) -> do
+ H.dt ! HA.class_ "choice-title"
+ ! HA.id (attrify $ identify $ XML.pos_ancestors choice_posXML) $$ do
+ html5ify choice_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
+instance Html5ify Judges where
+ html5ify Judges{..} =
+ html5CommonAttrs judges_attrs
+ { classes = "judges":classes judges_attrs
+ , DTC.id = Just $ Ident $ Plain.text def $ XML.pos_ancestors judges_posXML
+ } $
+ H.div $$ do
+ mempty
+
+html5MeritComments ::
+ Html5ify Title =>
+ 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 <- liftComposeState $ S.gets state_l10n
+ H.ul ! HA.class_ "merit-comments" $$ do
+ forM_ grades $ \case
+ grade | DTC.Grade{..} <- MJ.unRank grade -> 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 grade_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 ::
+ Html5ify Title =>
+ MJ.MajorityValue (MJ.Ranked Grade) -> Int -> HTML5
+html5MeritHistogram (MJ.MajorityValue majVal) numJudges = do
+ H.div ! HA.class_ "merit-histogram" $$ do
+ forM_ majVal $ \case
+ (grade, count) | DTC.Grade{..} <- MJ.unRank grade -> do
+ let percent :: Double =
+ fromRational $ (toRational $ (ceiling::Double -> Int) $ fromRational $
+ (count / toRational numJudges) * 100 * 1000) / 1000
+ let bcolor = "background-color:"<>attrify grade_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{..} <- liftComposeState $ S.gets state_collect
+ opinionsByChoiceByNodeBySectionByJudgment <-
+ forM (HM.toList all_judgments) $ \(judgment@Judgment{..}, choicesBySection) -> do
+ -- WARNING: only the fields of 'Judgment' used in its 'Hashable' instance
+ -- can safely be used here: 'judgment_judgesId' and 'judgment_gradesId' are ok
+ let judgmentGrades =
+ maybe (Prelude.error $ show judgment_grades) MJ.grades $ -- unknown grades
+ HM.lookup judgment_gradesId all_grades
+ let Judges{..} =
+ fromMaybe (Prelude.error $ show judgment_judges) $ -- unknown judges
+ HM.lookup judgment_judgesId all_judges
+ let defaultGradeByJudge =
+ let defaultGrade =
+ List.head
+ [ g | g <- Set.toList judgmentGrades
+ , grade_isDefault $ MJ.unRank g
+ ] in
+ (<$> judges_byName) $ \js ->
+ let Judge{..} = List.head js in
+ let judgeDefaultGrade = do
+ grade <- join $ listToMaybe <$> HM.lookup judgment_gradesId judge_defaultGrades
+ listToMaybe
+ [ g | g <- Set.toList judgmentGrades
+ , grade_name (MJ.unRank g) == grade
+ ] in
+ defaultGrade`fromMaybe`judgeDefaultGrade
+ opinionsByChoiceByNodeBySection <-
+ forM choicesBySection $ \choicesTree -> do
+ judgmentTree <- forM choicesTree $ \(section_importance, choices) -> do
+ judgmentOpinions <- forM choices $ \choice_@DTC.Choice{..} -> do
+ gradeByJudge <- forM choice_opinions $ \Opinion{..} -> do
+ case listToMaybe
+ [ g | g <- Set.toList judgmentGrades
+ , grade_name (MJ.unRank g) == opinion_grade
+ ] of
+ Just grd -> return (opinion_judge, MJ.Section opinion_importance (Just grd))
+ Nothing -> Prelude.error $ show opinion_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)
+ liftComposeState $ S.modify' $ \st ->
+ st{state_opinions = HM.fromList opinionsByChoiceByNodeBySectionByJudgment}
case n of
BodyBlock b -> xmlify b
BodySection Section{..} ->
- xmlCommonAttrs attrs $
+ xmlCommonAttrs section_attrs $
XML.section $ do
- xmlify title
- forM_ aliases xmlify
+ xmlify section_title
+ forM_ section_aliases xmlify
xmlify ts
instance Xmlify Block where
xmlify = \case
xmlify = \case
Judgment{..} ->
XML.judgment
- ! XA.judges (attrify judges)
- ! XA.grades (attrify grades) $
- xmlify question
- -- TODO: xmlify choices
+ ! XA.judges (attrify judgment_judgesId)
+ ! XA.grades (attrify judgment_gradesId) $
+ xmlify judgment_question
+ -- TODO: xmlify judgment_choices
instance Xmlify ListItem where
xmlify ListItem{..} =
XML.li ! XA.name (attrify name) $ xmlify paras
PlainCode -> XML.code $ xmlify ts
PlainDel -> XML.del $ xmlify ts
PlainI -> XML.i $ xmlify ts
- PlainNote{..} -> XML.note $ xmlify note
+ PlainNote{..} -> XML.note $ xmlify note_paras
PlainQ -> XML.q $ xmlify ts
PlainSpan{..} -> xmlCommonAttrs attrs $ XML.span $ xmlify ts
PlainSC -> XML.sc $ xmlify ts
PlainSup -> XML.sup $ xmlify ts
PlainU -> XML.u $ xmlify ts
PlainEref to -> XML.eref ! XA.to (attrify to) $ xmlify ts
- PlainIref{..} -> XML.iref ! XA.term (attrify $ plainifyWords term) $ xmlify ts
+ PlainIref{..} -> XML.iref ! XA.term (attrify $ plainifyWords iref_term) $ xmlify ts
PlainTag{..} -> XML.tag $ xmlify ts
- PlainRref{..} -> XML.rref ! XA.to (attrify $ unIdent to) $ xmlify ts
+ PlainRref{..} -> XML.rref ! XA.to (attrify rref_to) $ xmlify ts
instance Xmlify About where
xmlify About{..} = do
import Hdoc.TCT.Debug
-- * Type 'Pos'
--- | Relative position
-data Pos
- = Pos
- { pos_line :: {-# UNPACK #-} !LineNum
- , pos_column :: {-# UNPACK #-} !ColNum
+-- | Absolute text file position.
+data Pos = Pos
+ { pos_line :: {-# UNPACK #-} !LineNum
+ , pos_column :: {-# UNPACK #-} !ColNum
} deriving (Eq, Ord)
instance Default Pos where
def = pos1
-- ** Type 'ColNum'
type ColNum = Int
--- * Type 'Span'
-data Span
- = Span
- { span_file :: !FilePath
- , span_begin :: !Pos
- , span_end :: !Pos
- } deriving (Eq, Ord)
-instance Default Span where
- def = Span "" pos1 pos1
-instance Show Span where
- showsPrec _p Span{..} =
- showString span_file .
- showChar '#' . showsPrec 10 span_begin .
- showChar '-' . showsPrec 10 span_end
-
--- * Type 'Location'
-type Location = NonEmpty Span
-
-- * Type 'Cell'
data Cell a
= Cell
cell0 :: a -> Cell a
cell0 = Cell (def :| [])
+-- ** Type 'Span'
+data Span
+ = Span
+ { span_file :: !FilePath
+ , span_begin :: !Pos
+ , span_end :: !Pos
+ } deriving (Eq, Ord)
+instance Default Span where
+ def = Span "" pos1 pos1
+instance Show Span where
+ showsPrec _p Span{..} =
+ showString span_file .
+ showChar '#' . showsPrec 10 span_begin .
+ showChar '-' . showsPrec 10 span_end
+
+-- ** Type 'Location'
+type Location = NonEmpty Span
+
-- * Class 'FromPad'
class FromPad a where
fromPad :: Pos -> a
{-# LANGUAGE ViewPatterns #-}
module Hdoc.TCT.Write.HTML5 where
-import Control.Monad (Monad(..), forM_, mapM_, when, unless)
+import Control.Monad (Monad(..), forM_, mapM_)
import Data.Bool
import Data.Char (Char)
import Data.Default.Class (Default(..))
import qualified Data.Text.Lazy as TL
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
+import qualified Text.Blaze.Internal as Blaze
-- import Hdoc.TCT.Debug
import Hdoc.TCT
import Hdoc.TCT.Utils
+import Control.Monad.Utils
import Text.Blaze.Utils
import qualified Hdoc.TCT.Write.Plain as Plain
! HA.type_ "text/css"
! HA.href "style/tct-html5.css"
let (html5Body, State{}) =
- runStateMarkup def $
+ runComposeState def $
html5ify body
H.body $ do
H.a ! HA.id "line-1" $ return ()
_ -> Nothing
-- * Type 'Html5'
-type Html5 = StateMarkup State ()
+type Html5 = ComposeState State Blaze.MarkupM ()
instance IsString Html5 where
fromString = mapM_ html5ify
instance Html5ify Char where
html5ify = \case
'\n' -> do
- s@State{state_pos=Pos line _col, ..} <- liftStateMarkup S.get
- liftStateMarkup $ S.put s{state_pos=Pos (line + 1) 1}
+ s@State{state_pos=Pos line _col, ..} <- liftComposeState S.get
+ liftComposeState $ S.put s{state_pos=Pos (line + 1) 1}
html5 '\n'
H.a ! HA.id ("line-"<>attrify (line + 1)) $$ return ()
state_indent
c -> do
- liftStateMarkup $ S.modify' $ \s@State{state_pos=Pos line col} ->
+ liftComposeState $ S.modify' $ \s@State{state_pos=Pos line col} ->
s{state_pos=Pos line (col + 1)}
html5 c
instance Html5ify String where
let (h,ts) = TL.span (/='\n') t in
case TL.uncons ts of
Nothing -> do
- liftStateMarkup $ S.modify' $ \s@State{state_pos=Pos line col} ->
+ liftComposeState $ S.modify' $ \s@State{state_pos=Pos line col} ->
s{state_pos=Pos line $ col + int (TL.length h)}
html5 h
Just (_n,ts') -> do
s@State
{ state_pos=old@(Pos lineOld colOld)
, state_indent
- } <- liftStateMarkup S.get
+ } <- liftComposeState S.get
case lineOld`compare`lineNew of
LT -> do
forM_ [lineOld+1..lineNew] $ \lnum -> do
html5 '\n'
H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
- liftStateMarkup $ S.put s{state_pos=Pos lineNew 1}
+ liftComposeState $ S.put s{state_pos=Pos lineNew 1}
state_indent
- Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
+ Pos _lineMid colMid <- liftComposeState $ S.gets state_pos
html5 $ List.replicate (colNew - colMid) ' '
- liftStateMarkup $ S.put s{state_pos=new}
+ liftComposeState $ S.put s{state_pos=new}
EQ | colOld <= colNew -> do
- liftStateMarkup $ S.put s{state_pos=new}
+ liftComposeState $ S.put s{state_pos=new}
html5 $ List.replicate (colNew - colOld) ' '
_ -> error $ "html5ify: non-ascending Pos:"
<> "\n old: " <> show old
h n | n > 6 = H.span ! HA.class_ ("h h"<>attrify n)
h _ = undefined
HeaderDotSlash file -> do
- ext <- liftStateMarkup $ S.gets state_ext_html
+ ext <- liftComposeState $ S.gets state_ext_html
if null ext
then html5ify file
else
html5ify ts
html5HeaderRepeated :: Name -> White -> Name -> White -> TL.Text -> White -> H.AttributeValue -> Html5
html5HeaderRepeated markBegin whmb name whn markEnd whme cl = do
- State{state_indent} <- liftStateMarkup S.get
- liftStateMarkup $ S.modify' $ \s ->
+ State{state_indent} <- liftComposeState S.get
+ liftComposeState $ S.modify' $ \s ->
s{ state_indent = do
state_indent
- Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
+ Pos _lineMid colMid <- liftComposeState $ S.gets state_pos
html5ify $ List.replicate (pos_column bp - colMid) ' '
html5Head markBegin whmb name whn markEnd whme cl
}
r <- html5Header markBegin whmb name whn markEnd whme cl
- liftStateMarkup $ S.modify' $ \s -> s{state_indent}
+ liftComposeState $ S.modify' $ \s -> s{state_indent}
return r
----------------------
NodeText t -> do
- State{state_indent} <- liftStateMarkup S.get
- liftStateMarkup $ S.modify' $ \s ->
+ State{state_indent} <- liftComposeState S.get
+ liftComposeState $ S.modify' $ \s ->
s{ state_indent = do
state_indent
- Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
+ Pos _lineMid colMid <- liftComposeState $ S.gets state_pos
html5ify $ List.replicate (pos_column bp - colMid) ' '
}
r <- html5ify t
- liftStateMarkup $ S.modify' $ \s -> s{state_indent}
+ liftComposeState $ S.modify' $ \s -> s{state_indent}
return r
----------------------
NodePara -> do
- State{state_indent} <- liftStateMarkup S.get
- liftStateMarkup $ S.modify' $ \s ->
+ State{state_indent} <- liftComposeState S.get
+ liftComposeState $ S.modify' $ \s ->
s{ state_indent = do
state_indent
- Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
+ Pos _lineMid colMid <- liftComposeState $ S.gets state_pos
html5ify $ List.replicate (pos_column bp - colMid) ' '
}
r <- html5ify ts
- liftStateMarkup $ S.modify' $ \s -> s{state_indent}
+ liftComposeState $ S.modify' $ \s -> s{state_indent}
return r
----------------------
NodeToken t -> html5ify t <> html5ify ts
p | p == PairSlash
|| p == PairFrenchquote
|| p == PairDoublequote -> do
- State{..} <- liftStateMarkup $ S.get
- liftStateMarkup $ S.modify' $ \s -> s{state_italic = not state_italic}
+ State{..} <- liftComposeState $ S.get
+ liftComposeState $ S.modify' $ \s -> s{state_italic = not state_italic}
r <- H.em ! HA.class_ (if state_italic then "even" else "odd") $$ h
- liftStateMarkup $ S.modify' $ \s -> s{state_italic}
+ liftComposeState $ S.modify' $ \s -> s{state_italic}
return r
_ -> h
instance Html5ify Token where
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hdoc.Utils where
-import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Int (Int)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Sequence (Seq)
import Data.Text (Text)
`hashWithSalt`ts
-}
--- * Monad utilities
-unless :: (Applicative f, Monoid a) => Bool -> f a -> f a
-unless b fa = if b then pure mempty else fa
-{-# INLINABLE unless #-}
-
-when :: (Applicative f, Monoid a) => Bool -> f a -> f a
-when b fa = if b then fa else pure mempty
-{-# INLINABLE when #-}
-
-- * Filesystem utilities
readFile :: FilePath -> IO TL.Text
readFile fp = TL.decodeUtf8 <$> BSL.readFile fp
then return ()
else IO.ioError e
--- | Lazy in the monoidal accumulator.
-foldlMapA :: (Foldable f, Monoid b, Applicative m) => (a -> m b) -> f a -> m b
-foldlMapA f = foldr (liftA2 mappend . f) (pure mempty)
-
--- | Strict in the monoidal accumulator.
--- For monads strict in the left argument of bind ('>>='),
--- this will run in constant space.
-foldlMapM :: (Foldable f, Monoid b, Monad m) => (a -> m b) -> f a -> m b
-foldlMapM f xs = foldr go pure xs mempty
- where
- -- go :: a -> (b -> m b) -> b -> m b
- go x k lb = f x >>= \rb -> let !b = lb`mappend`rb in k b
-
-- * Arithmetical utilities
-- ** Type 'Nat'
newtype Nat = Nat { unNat :: Int }
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+../HLint.hs
\ No newline at end of file
-{-# LANGUAGE OverloadedStrings #-}
+{-# language OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
import Text.Show (Show(..))
import qualified Blaze.ByteString.Builder as BS
import qualified Blaze.ByteString.Builder.Html.Utf8 as BS
-import qualified Control.Monad.Trans.State as S
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.List as List
import qualified Data.Text as Text
-import qualified Data.Text.Lazy as TL
import qualified Data.Text.Encoding as BS
+import qualified Data.Text.Lazy as TL
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Renderer.Utf8 as BS
+import Control.Monad.Utils
+
-- | 'Attribute' in 'Maybe'.
infixl 1 !??
(!??) :: Attributable h => h -> Maybe Attribute -> h
instance MayAttr AttributeValue where
mayAttr a = Just . a
--- * Type 'StateMarkup'
--- | Composing state and markups.
-type StateMarkup st = Compose (S.State st) B.MarkupM
-instance Semigroup (StateMarkup st a) where
+-- * Type 'ComposeState'
+instance Semigroup (ComposeState st B.MarkupM a) where
(<>) = (>>)
-instance Monoid (StateMarkup st ()) where
+instance Monoid (ComposeState st B.MarkupM ()) where
mempty = pure ()
mappend = (<>)
-instance Monad (StateMarkup st) where
+instance Monad (ComposeState st B.MarkupM) where
return = pure
Compose sma >>= a2csmb =
Compose $ sma >>= \ma ->
B.Append _ma (B.Empty csmb) ->
B.Append ma <$> getCompose csmb
_ -> undefined -- NOTE: impossible case, by definition of (>>=) on 'B.MarkupM'.
-{- NOTE: the 'st' may need to use the 'String', so no such instance.
-instance IsString (StateMarkup st ()) where
- fromString = Compose . return . fromString
--}
-
--- | Lift a 'B.MarkupM' constructor to a 'StateMarkup' one.
-($$) :: (B.MarkupM a -> B.MarkupM a) -> StateMarkup st a -> StateMarkup st a
-($$) f m = Compose $ f <$> getCompose m
-infixr 0 $$
-
-liftStateMarkup :: S.State st a -> StateMarkup st a
-liftStateMarkup = Compose . (return <$>)
-
-runStateMarkup :: st -> StateMarkup st a -> (B.MarkupM a, st)
-runStateMarkup st = (`S.runState` st) . getCompose
-
-evalStateMarkup :: st -> StateMarkup st a -> B.MarkupM a
-evalStateMarkup st = (`S.evalState` st) . getCompose
-- | Render some 'Markup' to a 'Builder'.
--
--- /dev/null
+../HLint.hs
\ No newline at end of file
Library
exposed-modules:
+ Control.Monad.Utils
+ Hdoc.DTC.Check.Base
+ Hdoc.DTC.Check.Judgment
Hdoc.DTC.Check
Hdoc.DTC.Collect
Hdoc.DTC.Document
Hdoc.DTC.Read.TCT
Hdoc.DTC.Sym
Hdoc.DTC.Write.HTML5.Ident
+ Hdoc.DTC.Write.HTML5.Base
+ Hdoc.DTC.Write.HTML5.Judgment
+ Hdoc.DTC.Write.HTML5.Error
Hdoc.DTC.Write.HTML5
Hdoc.DTC.Write.Plain
Hdoc.DTC.Write.XML
/*clear:both;*/
margin-top:2ex;
}
- .judgment .question {
+ .judgment:target {
+ background-color:#BFEFFF;
+ }
+ .judgment.judgment-error {
+ border:2px dashed red;
+ }
+ .judgment .judgment-question {
font-weight:bold;
}
.judgment:first-child,
.section-header + .judgment {
margin-top:0;
}
- .judgment dl.choices {
- width:100%;
+ .judgment dl.judgment-choices {
margin:0 0 0 0;
padding:0 0 0 0;
+ width:100%;
}
- .judgment dl.choices > dt.choice-title {
+ .judgment dl.judgment-choices > dt.choice-title {
clear:left;
}
- .judgment dl.choices > dd.choice-merit {
+ .judgment dl.judgment-choices > dt.choice-title:target {
+ background-color:#BFEFFF;
+ }
+ .judgment dl.judgment-choices > dd.choice-merit {
clear:left;
}
- .aside > .judgment dl.choices > dd.choice-merit {
+ .aside > .judgment dl.judgment-choices > dd.choice-merit {
margin-left:0;
}
- .judgment dl.choices > dd.choice-merit:after {
+ .judgment dl.judgment-choices > dd.choice-merit:after {
/* NOTE: clearfix: force an element to self-clear its children */
content:"";
display:table;
clear:both;
}
- .judgment dl.choices > dd + dt {
+ .judgment dl.judgment-choices > dd + dt {
margin-top:2ex;
}
/* .merit-histogram */
sourcephile / git / doclang.git / commitdiff