+{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Control.Monad.Utils where
import Data.Bool
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
-import Data.Functor ((<$>))
+import Data.Functor (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
+import qualified Control.Monad.Trans.State.Strict as S
+import qualified Control.Monad.Trans.RWS.Strict as RWS
unless :: (Applicative f, Monoid a) => Bool -> f a -> f a
unless b fa = if b then pure mempty else fa
{-# INLINABLE when #-}
-- * Type 'ComposeState'
--- | Composing state and a monad not affecting the state.
+-- | Composing state and a monadic type not affecting the state.
type ComposeState st = Compose (S.State st)
instance Semigroup (ComposeState st Maybe a) where
(<>) = (>>)
fromString = Compose . return . fromString
-}
+-- * Type 'ComposeRWS'
+-- | Composing reader-writer-state and a monad not affecting it.
+type ComposeRWS r w s = Compose (RWS.RWS r w s)
+instance Monoid w => Semigroup (ComposeRWS r w s Maybe a) where
+ (<>) = (>>)
+instance Monoid w => Monoid (ComposeRWS r w s Maybe ()) where
+ mempty = pure ()
+ mappend = (<>)
+instance Monoid w => Monad (ComposeRWS r w s Maybe) where
+ return = pure
+ Compose sma >>= a2csmb =
+ Compose $ sma >>= \ma ->
+ maybe (return Nothing) getCompose $
+ ma >>= Just . a2csmb
+
-- | Lift a function over 'm' to a 'ComposeState' one.
-($$) :: (m a -> m a) -> ComposeState st m a -> ComposeState st m a
+($$) :: Functor f => (m a -> m b) -> Compose f m a -> Compose f m b
($$) f m = Compose $ f <$> getCompose m
infixr 0 $$
-liftComposeState :: Monad m => S.State st a -> ComposeState st m a
-liftComposeState = Compose . (return <$>)
+composeLift :: (Applicative m, Functor f) => f a -> Compose f m a
+composeLift = Compose . (pure <$>)
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
+localComposeRWS :: (r -> r) -> ComposeRWS r w s m a -> ComposeRWS r w s m a
+localComposeRWS f = Compose . RWS.local f . getCompose
+runComposeRWS :: r -> s -> ComposeRWS r w s m a -> (m a, s, w)
+runComposeRWS r s c = RWS.runRWS (getCompose c) r s
+evalComposeRWS :: r -> s -> ComposeRWS r w s m a -> (m a, w)
+evalComposeRWS r s c = RWS.evalRWS (getCompose c) r s
+
-- * Folding
-- | Lazy in the monoidal accumulator.
foldlMapA :: (Foldable f, Monoid b, Applicative m) => (a -> m b) -> f a -> m b
--- /dev/null
+{-# LANGUAGE FlexibleInstances #-}
+module Hdoc.DTC.Analyze.Check where
+
+import Control.Arrow ((&&&))
+import Data.Default.Class (Default(..))
+import Data.Eq (Eq(..))
+import Data.Foldable (Foldable(..))
+import Data.Function (($))
+import Data.Functor (Functor(..), (<$>))
+import Data.Monoid (Monoid(..))
+import Data.Ord (Ord(..))
+import Data.Semigroup (Semigroup(..))
+import Data.Sequence (Seq)
+import Data.Tuple (fst)
+import Text.Show (Show(..))
+import qualified Data.HashMap.Strict as HM
+
+import Hdoc.DTC.Document
+import Hdoc.DTC.Analyze.Collect
+
+-- ** Type 'Errors'
+data Errors a = Errors
+ { errors_tag_unknown :: HM.HashMap Title a
+ , errors_tag_ambiguous :: HM.HashMap Title a
+ , errors_rref_unknown :: HM.HashMap Ident a
+ , errors_reference_ambiguous :: HM.HashMap Ident a
+ , errors_judgment_judges_unknown :: HM.HashMap Ident a
+ , errors_judgment_grades_unknown :: HM.HashMap Ident a
+ , errors_judgment_grades_duplicated :: HM.HashMap Ident a
+ , errors_judgment_judge_unknown :: HM.HashMap Name a
+ , errors_judgment_judge_duplicated :: HM.HashMap Name a
+ , errors_judgment_grade_unknown :: HM.HashMap Name a
+ , errors_judgment_choice_duplicated :: HM.HashMap Title a
+ } deriving (Eq,Show)
+instance Default (Errors a) 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
+ }
+instance Semigroup a => Semigroup (Errors a) where
+ x<>y = Errors
+ { errors_tag_unknown = hm_union errors_tag_unknown
+ , errors_tag_ambiguous = hm_union errors_tag_ambiguous
+ , errors_rref_unknown = hm_union errors_rref_unknown
+ , errors_reference_ambiguous = hm_union errors_reference_ambiguous
+ , errors_judgment_judges_unknown = hm_union errors_judgment_judges_unknown
+ , errors_judgment_judge_unknown = hm_union errors_judgment_judge_unknown
+ , errors_judgment_judge_duplicated = hm_union errors_judgment_judge_duplicated
+ , errors_judgment_grades_unknown = hm_union errors_judgment_grades_unknown
+ , errors_judgment_grades_duplicated = hm_union errors_judgment_grades_duplicated
+ , errors_judgment_grade_unknown = hm_union errors_judgment_grade_unknown
+ , errors_judgment_choice_duplicated = hm_union errors_judgment_choice_duplicated
+ } where hm_union get = HM.unionWith (<>) (get x) (get y)
+instance Semigroup a => Monoid (Errors a) where
+ mempty = def
+ mappend = (<>)
+instance Functor Errors where
+ fmap f Errors{..} = Errors
+ { errors_tag_unknown = fmap f errors_tag_unknown
+ , errors_tag_ambiguous = fmap f errors_tag_ambiguous
+ , errors_rref_unknown = fmap f errors_rref_unknown
+ , errors_reference_ambiguous = fmap f errors_reference_ambiguous
+ , errors_judgment_judges_unknown = fmap f errors_judgment_judges_unknown
+ , errors_judgment_judge_unknown = fmap f errors_judgment_judge_unknown
+ , errors_judgment_judge_duplicated = fmap f errors_judgment_judge_duplicated
+ , errors_judgment_grades_unknown = fmap f errors_judgment_grades_unknown
+ , errors_judgment_grades_duplicated = fmap f errors_judgment_grades_duplicated
+ , errors_judgment_grade_unknown = fmap f errors_judgment_grade_unknown
+ , errors_judgment_choice_duplicated = fmap f errors_judgment_choice_duplicated
+ }
+
+errors :: All -> Errors (Seq Location)
+errors All{..} =
+ def -- FIXME: Errors
+ { errors_tag_unknown =
+ HM.difference all_tag all_section
+ , errors_tag_ambiguous =
+ HM.intersection all_tag $
+ HM.filter (\x -> length x > 1) all_section
+ , errors_rref_unknown =
+ (fst <$>) <$>
+ HM.difference all_rrefs all_reference
+ , errors_reference_ambiguous =
+ ((&&&) reference_locTCT reference_posXML <$>)
+ <$> HM.filter (\x -> length x > 1) all_reference
+ {-
+ , errors_judgment_judges_unknown =
+ , errors_judgment_judge_unknown =
+ , errors_judgment_judge_duplicated =
+ , errors_judgment_grades_unknown =
+ , errors_judgment_grades_duplicated =
+ , errors_judgment_grade_unknown =
+ , errors_judgment_choice_duplicated =
+ -}
+ }
--- /dev/null
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Hdoc.DTC.Analyze.Collect where
+
+import Control.Applicative (Applicative(..), liftA2)
+import Control.Monad
+import Data.Bool
+import Data.Default.Class (Default(..))
+import Data.Either (Either(..))
+import Data.Foldable (Foldable(..), any)
+import Data.Function (($), (.))
+import Data.Functor ((<$>), (<$))
+import Data.Map.Strict (Map)
+import Data.Maybe (Maybe(..), fromMaybe)
+import Data.Monoid (Monoid(..))
+import Data.Semigroup (Semigroup(..))
+import Data.Sequence (Seq)
+import Data.TreeSeq.Strict (Tree(..))
+import Text.Show (Show(..))
+import qualified Control.Monad.Trans.Reader as R
+import qualified Data.HashMap.Strict as HM
+import qualified Data.Map.Strict as Map
+import qualified Data.Sequence as Seq
+import qualified Data.Text.Lazy as TL
+import qualified Data.Tree as Tree
+import qualified Data.TreeSeq.Strict as TS
+import qualified Data.TreeMap.Strict as TM
+import qualified Majority.Judgment as MJ
+
+import qualified Hdoc.TCT.Cell as TCT
+import Hdoc.DTC.Document as DTC
+import qualified Hdoc.XML as XML
+
+-- * Type 'Reader'
+newtype Reader = Reader
+ { reader_section :: Either Head Section
+ }
+instance Default Reader where
+ def = Reader
+ { reader_section = Left def
+ }
+
+-- * Type 'All'
+data All = All
+ { all_figure :: HM.HashMap TL.Text (Map XML.Pos (Maybe Title))
+ , all_grades :: HM.HashMap Ident (Seq [Grade])
+ , all_index :: HM.HashMap XML.Pos Terms
+ , all_irefs :: TM.TreeMap Word (Seq (Either Head Section))
+ , all_judges :: HM.HashMap Ident (Seq Judges)
+ , all_judgment :: HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])]
+ , all_notes :: TS.Trees (Seq [Para])
+ , all_reference :: HM.HashMap Ident (Seq Reference)
+ , all_rrefs :: HM.HashMap Ident (Seq ((TCT.Location, XML.Pos), Either Head Section))
+ , all_section :: HM.HashMap Title (Seq (Either Head Section))
+ , all_tag :: HM.HashMap Title (Seq (TCT.Location, XML.Pos))
+ } deriving (Show)
+instance Default All where
+ def = All
+ { all_figure = def
+ , all_grades = def
+ , all_index = def
+ , all_irefs = TM.empty
+ , all_judges = def
+ , all_judgment = def
+ , all_notes = def
+ , all_reference = def
+ , all_rrefs = def
+ , all_section = def
+ , all_tag = def
+ }
+instance Semigroup All where
+ x<>y = All
+ { all_figure = hm_union all_figure
+ , all_grades = hm_union all_grades
+ , all_index = hm_union all_index
+ , all_irefs = tm_union all_irefs
+ , all_judges = hm_union all_judges
+ , all_judgment = hm_union all_judgment
+ , all_notes = ts_union (all_notes x) (all_notes y)
+ , all_reference = hm_union all_reference
+ , all_rrefs = hm_union all_rrefs
+ , all_section = hm_union all_section
+ , all_tag = hm_union all_tag
+ } where
+ hm_union get = HM.unionWith (<>) (get x) (get y)
+ tm_union get = TM.union (<>) (get x) (get y)
+ ts_union :: TS.Trees (Seq [Para]) -> TS.Trees (Seq [Para]) -> TS.Trees (Seq [Para])
+ ts_union sx sy = lx <> Seq.singleton union <> ry
+ where
+ filter = null . TS.subTrees
+ union = TS.tree0 $ join $ TS.unTree <$> (rx <> ly)
+ (rx, lx) = Seq.spanr filter sx
+ (ly, ry) = Seq.spanl filter sy
+instance Monoid All where
+ mempty = def
+ mappend = (<>)
+instance Semigroup (R.Reader Reader All) where
+ (<>) = liftA2 (<>)
+instance Monoid (R.Reader Reader All) where
+ mempty = pure def
+ mappend = (<>)
+
+-- * Class 'Collect'
+class Collect a where
+ collect :: a -> R.Reader Reader All
+instance Collect Document where
+ collect Document{..} =
+ R.local (\ro -> ro{reader_section = Left head}) $
+ return def
+ { all_section =
+ HM.fromListWith (<>) $
+ (\t -> (t, pure $ Left head))
+ <$> about_titles (head_about head)
+ } <>
+ (<$> collect body) (\ro -> ro
+ { all_judgment =
+ choicesBySectionByJudgment HM.empty $
+ TS.Tree (choicesByJudgment $ head_judgments head) $
+ choicesByJudgmentBySection body
+ })
+instance Collect (TS.Trees BodyNode) where
+ collect = foldMap $ \(TS.Tree b bs) ->
+ case b of
+ BodyBlock blk ->
+ collect blk
+ BodySection section@Section{..} ->
+ R.local (\ro -> ro{reader_section = Right section}) $
+ ((\all -> all{all_notes = pure $ TS.Tree Seq.empty $ all_notes all}) <$>) $
+ return def
+ { all_section =
+ HM.fromListWith (<>) $
+ (\(Alias t) -> (t, pure $ Right section))
+ <$> (Alias section_title : section_aliases)
+ } <>
+ collect section_title <>
+ collect bs
+instance Collect Block where
+ collect = \case
+ BlockPara p -> collect p
+ BlockBreak{} -> pure def
+ BlockToC{} -> pure def
+ BlockToF{} -> pure def
+ BlockAside{..} -> foldMap collect blocks
+ BlockIndex{..} -> return def{all_index = HM.singleton posXML terms}
+ BlockFigure{..} ->
+ return def
+ { all_figure = HM.singleton type_ (Map.singleton posXML mayTitle)
+ } <> foldMap collect paras
+ BlockReferences{..} ->
+ return def
+ { all_reference=
+ HM.fromListWith (<>) $
+ (<$> refs) $
+ \ref@DTC.Reference{..} -> (reference_id, pure ref)
+ } <> foldMap collect refs
+ BlockGrades{attrs=CommonAttrs{id}, ..} ->
+ return def{all_grades = HM.singleton (fromMaybe "" id) $ pure scale}
+ BlockJudges judges@Judges{judges_attrs=CommonAttrs{id}, ..} ->
+ return def{all_judges = HM.singleton (fromMaybe "" id) $ pure judges}
+instance Collect Para where
+ collect = \case
+ ParaItem item -> collect item
+ ParaItems{..} -> foldMap collect items
+instance Collect ParaItem where
+ collect = \case
+ ParaPlain p -> collect p
+ ParaArtwork{} -> return def
+ ParaQuote{..} -> foldMap collect paras
+ ParaComment{} -> return def
+ ParaOL items -> foldMap collect items
+ ParaUL items -> foldMap (foldMap collect) items
+ ParaJudgment{} -> return def
+instance Collect ListItem where
+ collect ListItem{..} = foldMap collect paras
+instance Collect Title where
+ collect (Title t) = collect t
+instance Collect Plain where
+ collect = foldMap collect
+instance Collect (Tree PlainNode) where
+ collect (Tree n ts) =
+ case n of
+ PlainBreak -> return def
+ PlainText{} -> return def
+ PlainGroup -> collect ts
+ PlainB -> collect ts
+ PlainCode -> collect ts
+ PlainDel -> collect ts
+ PlainI -> collect ts
+ PlainSpan{} -> collect ts
+ PlainSub -> collect ts
+ PlainSup -> collect ts
+ PlainSC -> collect ts
+ PlainU -> collect ts
+ PlainNote{..} ->
+ return def
+ { all_notes = pure $ TS.tree0 $ pure note_paras
+ } <> foldMap collect note_paras
+ PlainQ -> collect ts
+ PlainEref{} -> collect ts
+ PlainIref{..} -> do
+ Reader{..} <- R.ask
+ case pathFromWords iref_term of
+ Nothing -> collect ts
+ Just path ->
+ return def
+ { all_irefs = TM.singleton path $ pure reader_section
+ } <> collect ts
+ PlainTag{..} -> return def
+ { all_tag = HM.singleton (Title ts) $ pure (tag_locTCT, tag_posXML) }
+ PlainRref{..} -> do
+ Reader{..} <- R.ask
+ return def
+ { all_rrefs = HM.singleton rref_to $ pure ((rref_locTCT, rref_posXML), reader_section)
+ } <> collect ts
+instance Collect Reference where
+ collect Reference{..} =
+ collect reference_about
+instance Collect About where
+ collect About{..} =
+ foldMap collect about_titles
+
+
+choicesByJudgment :: [Judgment] -> HM.HashMap Judgment (Maybe MJ.Share, [Choice])
+choicesByJudgment js =
+ HM.fromList $ (<$> js) $ \j@Judgment{..} ->
+ (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{..} ->
+ pure $
+ 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
+ -- which will inherit from this 'BodySection'.
+ -- This enables judges to express something on material not in a sub 'BodySection'.
+ let childrenBlocksJudgments =
+ if (`any`bs) $ \case
+ Tree BodyBlock{} _ -> True
+ _ -> False
+ then Seq.singleton $ Tree ((Nothing,[]) <$ choicesJ) Seq.empty
+ else Seq.empty in
+ childrenBlocksJudgments <>
+ choicesByJudgmentBySection bs
+
+choicesBySectionByJudgment :: -- TODO: see if this can be done using Reader and collect
+ HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])] ->
+ TS.Tree (HM.HashMap Judgment (Maybe MJ.Share, [Choice])) ->
+ HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])]
+choicesBySectionByJudgment inh (TS.Tree selfJ childrenJS) =
+ HM.unionWith
+ (\selfS childrenS ->
+ (<$> selfS) $ \(Tree.Node choices old) ->
+ Tree.Node choices (old<>childrenS))
+ (selfSJ <> inh)
+ childrenSJ
+ where
+ selfSJ = (\cs -> [Tree.Node cs []]) <$> selfJ
+ childrenSJ =
+ foldl'
+ (\accJ childJ ->
+ HM.unionWith (<>) accJ $
+ choicesBySectionByJudgment
+ (([Tree.Node (Nothing,[]) []] <$ selfJ) <> inh)
+ childJ
+ )
+ HM.empty
+ childrenJS
+
+
+
--- /dev/null
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Hdoc.DTC.Analyze.Index where
+
+-- import Data.Eq (Eq(..))
+-- import Text.Show (Show(..))
+-- import qualified Control.Monad.Trans.Writer as W
+-- import qualified Data.HashMap.Strict as HM
+-- import qualified Data.Tree as Tree
+-- import qualified Data.TreeSeq.Strict as TS
+-- import qualified Hjugement as MJ
+import Control.Applicative (Applicative(..))
+import Control.Monad (Monad(..))
+import Data.Bool
+import Data.Char (Char)
+import Data.Default.Class (Default(..))
+import Data.Either (Either(..))
+import Data.Foldable (Foldable(..), concat)
+import Data.Function (($), (.), const)
+import Data.Functor ((<$>), (<$))
+import Data.Functor.Compose (Compose(..))
+import Data.Map.Strict (Map)
+import Data.Maybe (Maybe(..), maybe)
+import Data.Monoid (Monoid(..))
+import Data.Semigroup (Semigroup(..))
+import Data.Sequence (Seq, (|>))
+import Data.Traversable (Traversable(..))
+import Data.TreeMap.Strict (TreeMap(..))
+import Data.TreeSeq.Strict (Tree(..), tree0)
+import qualified Control.Monad.Trans.Reader as R
+import qualified Control.Monad.Trans.State as S
+import qualified Data.Char as Char
+import qualified Data.List as List
+import qualified Data.Map.Strict as Map
+import qualified Data.Sequence as Seq
+import qualified Data.Strict.Maybe as Strict
+import qualified Data.Text.Lazy as TL
+import qualified Data.TreeMap.Strict as TM
+
+import Hdoc.DTC.Document as DTC
+-- import Hdoc.TCT.Cell as TCT
+-- import qualified Hdoc.XML as XML
+
+-- * Type 'IrefsByWords'
+type IrefsByWords = TM.TreeMap Word (Seq (Either Head Section))
+
+irefsOfTerms :: Terms -> IrefsByWords
+irefsOfTerms = TM.fromList const . (>>= f) . concat
+ where
+ f [] = []
+ f ws = maybe [] (\p -> [(p,Seq.empty)]) $ pathFromWords ws
+
+wordify :: TL.Text -> Words
+wordify = List.reverse . go []
+ where
+ go :: Words -> TL.Text -> Words
+ go acc t =
+ case TL.span Char.isAlphaNum t of
+ ("",_) ->
+ case TL.span Char.isSpace t of
+ ("",_) ->
+ case TL.uncons t of
+ Nothing -> acc
+ Just (c,r) -> go (Word (TL.singleton c) : acc) r
+ (_s,r) -> go (Space : acc) r
+ (w,r) -> go (Word w : acc) r
+
+plainifyWord :: WordOrSpace -> TL.Text
+plainifyWord = \case
+ Word w -> w
+ Space -> " "
+
+plainifyWords :: Words -> TL.Text
+plainifyWords = TL.concat . (plainifyWord <$>)
+
+termsByChar :: Terms -> Map Char Terms
+termsByChar =
+ foldr (\aliases acc ->
+ case aliases of
+ (Word w:_):_ | not (TL.null w) ->
+ Map.insertWith (<>)
+ (Char.toUpper $ TL.index w 0)
+ [aliases] acc
+ _ -> acc
+ ) Map.empty
+
+-- * Type 'Reader'
+data Reader = Reader
+ { reader_section :: Either Head Section
+ }
+instance Default Reader where
+ def = Reader
+ { reader_section = Left def
+ }
+
+-- * Type 'State'
+type State = IrefsByWords
+
+-- * Class 'Indexify'
+class Indexify a where
+ indexify :: a -> Compose (R.Reader Reader) (S.State State) a
+instance Indexify Document where
+ indexify Document{..} =
+ Compose $ R.local (\ro -> ro{reader_section = Left head}) $
+ getCompose $
+ Document
+ <$> indexify head
+ <*> traverse indexify body
+instance Indexify Head where
+ indexify h@Head{..} = pure h
+instance Indexify (Tree BodyNode) where
+ indexify (Tree n ts) =
+ case n of
+ BodyBlock b ->
+ Tree . BodyBlock
+ <$> indexify b
+ <*> traverse indexify ts
+ BodySection section@Section{..} ->
+ Compose $ R.local (\ro -> ro{reader_section = Right section}) $
+ getCompose $
+ Tree . BodySection
+ <$> indexify section
+ <*> traverse indexify ts
+instance Indexify Section where
+ indexify Section{..} =
+ Section section_posXML section_attrs
+ <$> indexify section_title
+ <*> pure section_aliases
+ <*> traverse indexify section_judgments
+instance Indexify Block where
+ indexify b = case b of
+ BlockPara p -> BlockPara <$> indexify p
+ BlockBreak{} -> pure b
+ BlockToC{} -> pure b
+ BlockToF{} -> pure b
+ BlockAside{..} -> BlockAside posXML attrs <$> traverse indexify blocks
+ BlockIndex{..} -> pure b
+ BlockFigure{..} ->
+ BlockFigure posXML type_ attrs
+ <$> traverse indexify mayTitle
+ <*> traverse indexify paras
+ BlockReferences{..} ->
+ BlockReferences posXML attrs
+ <$> traverse indexify refs
+ BlockJudges js -> BlockJudges <$> indexify js
+ BlockGrades{..} ->
+ BlockGrades posXML attrs
+ <$> indexify scale
+instance Indexify Para where
+ indexify = \case
+ ParaItem{..} -> ParaItem <$> indexify item
+ ParaItems{..} -> ParaItems posXML attrs <$> traverse indexify items
+instance Indexify ParaItem where
+ indexify = \case
+ ParaPlain plain -> ParaPlain <$> indexify plain
+ ParaOL items -> ParaOL <$> traverse indexify items
+ ParaUL items -> ParaUL <$> traverse (traverse indexify) items
+ ParaQuote{..} -> ParaQuote type_ <$> traverse indexify paras
+ p@ParaArtwork{} -> pure p
+ p@ParaComment{} -> pure p
+ ParaJudgment j -> ParaJudgment <$> indexify j
+instance Indexify ListItem where
+ indexify ListItem{..} = ListItem name <$> traverse indexify paras
+instance Indexify Plain where
+ indexify = traverse indexify
+instance Indexify (Tree PlainNode) where
+ indexify (Tree n ts) =
+ case n of
+ PlainIref{..} ->
+ case pathFromWords iref_term of
+ Nothing -> Tree n <$> traverse indexify ts
+ Just words ->
+ Compose $ R.ask >>= \ro -> getCompose $
+ Tree n
+ <$ Compose (pure (S.modify' $ \state_irefsByWords ->
+ TM.insert (<>) words (pure $ reader_section ro) $
+ state_irefsByWords
+ ))
+ <*> traverse indexify ts
+ PlainText txt ->
+ -- TODO: introduce PlainGroup only when necessary?
+ Tree PlainGroup <$> indexifyWords (wordify txt)
+ _ -> Tree n <$> traverse indexify ts
+instance Indexify Title where
+ indexify (Title p) = Title <$> indexify p
+instance Indexify About where
+ indexify About{..} =
+ About about_headers
+ <$> traverse indexify about_titles
+ <*> pure about_url
+ <*> traverse indexify about_authors
+ <*> traverse indexify about_editor
+ <*> traverse indexify about_date
+ <*> pure about_tags
+ <*> pure about_links
+ <*> pure about_series
+ <*> traverse indexify about_includes
+instance Indexify Entity where
+ indexify = pure -- TODO: to be coded
+instance Indexify Date where
+ indexify = pure -- TODO: to be coded
+instance Indexify Include where
+ indexify = pure -- TODO: to be coded
+instance Indexify Reference where
+ indexify Reference{..} = do
+ Reference
+ reference_posXML
+ reference_locTCT
+ reference_id
+ <$> indexify reference_about
+ {-
+ st@State{state_collect=All{..}, ..} <- S.get
+ let targets = HM.lookupDefault Seq.empty reference_id all_reference
+ case toList targets of
+ [] -> undefined
+ [_] -> do
+ _ -> do
+ let err =
+ 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 <- indexify reference_about
+ return $ Reference
+ { reference_error = Just $ ErrorAnchor_Ambiguous $ Nat1 $ length $ err HM.!reference_id
+ , reference_about = about
+ , .. }
+ -}
+instance Indexify Judges where
+ indexify Judges{..} =
+ Judges
+ judges_locTCT
+ judges_posXML
+ judges_attrs
+ <$> traverse (traverse indexify) judges_byName
+instance Indexify [Grade] where
+ indexify = traverse indexify
+instance Indexify Judgment where
+ indexify Judgment{..} =
+ Judgment
+ judgment_opinionsByChoice
+ judgment_judges
+ judgment_grades
+ judgment_posXML
+ judgment_locTCT
+ judgment_judgesId
+ judgment_gradesId
+ judgment_importance
+ <$> traverse indexify judgment_question
+ <*> traverse indexify judgment_choices
+instance Indexify Choice where
+ indexify Choice{..} =
+ Choice choice_locTCT choice_posXML
+ <$> traverse indexify choice_title
+ <*> traverse indexify choice_opinions
+instance Indexify Opinion where
+ indexify Opinion{..} =
+ Opinion
+ opinion_locTCT
+ opinion_posXML
+ opinion_judge
+ opinion_grade
+ opinion_importance
+ <$> traverse indexify opinion_comment
+instance Indexify Grade where
+ indexify Grade{..} =
+ Grade
+ grade_posXML
+ grade_name
+ grade_color
+ grade_isDefault
+ <$> traverse indexify grade_title
+instance Indexify Judge where
+ indexify Judge{..} =
+ Judge
+ judge_locTCT
+ judge_posXML
+ judge_name
+ <$> traverse indexify judge_title
+ <*> pure judge_defaultGrades
+
+indexifyWords :: Words -> Compose (R.Reader Reader) (S.State IrefsByWords) Plain
+indexifyWords ws =
+ Compose $ R.ask >>= \case
+ ro -> pure $ go mempty ws
+ where
+ go :: Plain -> Words -> S.State IrefsByWords Plain
+ go acc inp =
+ case inp of
+ [] -> return acc
+ Space : next ->
+ go (acc |> tree0 (PlainText " ")) next
+ Word w : next ->
+ goWords [] inp >>= \case
+ Nothing -> go (acc |> tree0 (PlainText w)) next
+ Just (ls, ns) -> do
+ let iref_term = List.reverse ls
+ let lines = Seq.fromList $ tree0 . PlainText . plainifyWord <$> iref_term
+ go (acc |> Tree PlainIref{iref_term} lines) ns
+ goWords ::
+ Words -> Words ->
+ S.State IrefsByWords (Maybe (Words, Words))
+ goWords prev inp = do
+ TM.TreeMap irefsByWord <- S.get
+ case inp of
+ [] -> return Nothing
+ curr@Space : next -> goWords (curr:prev) next
+ curr@(Word w) : next ->
+ case Map.lookup w irefsByWord of
+ Nothing -> return Nothing
+ Just nod@TM.Node{..} -> do
+ let prev' = curr:prev
+ S.put node_descendants
+ case node_value of
+ Strict.Nothing
+ | null node_descendants -> return Nothing
+ | otherwise -> goWords prev' next
+ <* S.modify' (\rs -> TreeMap $ Map.insert w nod{TM.node_descendants = rs} irefsByWord)
+ Strict.Just irefs ->
+ goWords prev' next >>= \case
+ Nothing -> do
+ S.put $ TM.TreeMap $
+ Map.insert w
+ nod{TM.node_value = Strict.Just $ reader_section ro Seq.<|irefs}
+ irefsByWord
+ return $ Just (prev', next)
+ r@Just{} -> do
+ S.modify' $ \rs ->
+ TM.TreeMap $ Map.insert w nod{TM.node_descendants = rs} irefsByWord
+ return r
+++ /dev/null
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hdoc.DTC.Check
- ( {-module Hdoc.DTC.Check
- ,-} module Hdoc.DTC.Check.Base
- -- , module Hdoc.DTC.Check.Judgment
- ) where
-
-import Control.Applicative (Applicative(..))
-import Control.Monad (Monad(..))
-import Data.Bool
-import Data.Default.Class (Default(..))
-import Data.Foldable (Foldable(..))
-import Data.Function (($), (.), const, flip)
-import Data.Functor ((<$>))
-import Data.Maybe (Maybe(..), maybe, listToMaybe)
-import Data.Semigroup (Semigroup(..))
-import Data.Traversable (Traversable(..))
-import Data.TreeSeq.Strict (Tree(..), tree0)
-import Data.Tuple (snd)
-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.List as List
-import qualified Data.Map.Strict as Map
-import qualified Data.Sequence as Seq
-import qualified Data.Strict.Maybe as Strict
-import qualified Data.TreeMap.Strict as TreeMap
-
-import Hdoc.DTC.Document
-import Hdoc.DTC.Index
-import Hdoc.DTC.Collect
-import Hdoc.DTC.Check.Base
-import Hdoc.DTC.Check.Judgment ()
-import qualified Hdoc.XML as XML
-
-instance Check Body where
- check = traverse check
-instance Check (Tree BodyNode) where
- check = \case
- Tree n ts ->
- case n of
- BodySection section@Section{..} -> do
- before@State{state_section} <- S.get
- S.put before{state_section = Just section}
- t <- Tree <$> check n <*> check ts
- S.modify' $ \s -> s{state_section}
- return t
- BodyBlock{} -> tree0 <$> check n
-instance Check BodyNode where
- check = \case
- BodySection s -> BodySection <$> check s
- BodyBlock b -> BodyBlock <$> check b
-instance Check Section where
- check Section{..} =
- 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@BlockBreak{} -> return b
- b@BlockToC{} -> return b
- b@BlockToF{} -> return b
- b@BlockIndex{} -> return b
- BlockAside{..} ->
- BlockAside posXML attrs
- <$> traverse check blocks
- BlockFigure{..} ->
- BlockFigure posXML type_ attrs
- <$> check mayTitle
- <*> traverse check paras
- BlockReferences{..} ->
- BlockReferences posXML attrs
- <$> traverse check refs
- BlockJudges js -> BlockJudges <$> check js
- BlockGrades{..} ->
- BlockGrades posXML attrs
- <$> check scale
-instance Check Para where
- check = \case
- ParaItem{..} -> ParaItem <$> check item
- ParaItems{..} -> ParaItems posXML attrs <$> traverse check items
-instance Check ParaItem where
- check = \case
- ParaPlain plain -> ParaPlain <$> check plain
- ParaOL items -> ParaOL <$> traverse check items
- ParaUL items -> ParaUL <$> traverse (traverse check) items
- ParaQuote{..} -> ParaQuote type_ <$> traverse check paras
- p@ParaArtwork{} -> return p
- p@ParaComment{} -> return p
- ParaJudgment j -> ParaJudgment <$> check j
-instance Check ListItem where
- check ListItem{..} = ListItem name <$> traverse check paras
-instance Check Plain where
- check = traverse check
-instance Check (Tree PlainNode) where
- check (Tree n ts) = do
- st@State{state_collect=All{..}, ..} <- S.get
- case n of
- PlainIref{..}
- | not $ null state_irefs
- , Just words <- pathFromWords iref_term
- , Strict.Just anchors <- TreeMap.lookup words state_irefs -> do
- -- NOTE: Insert new anchor for this index ref.
- 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 (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 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 section_posXML state_section
- S.put st
- { state_note = succNat1 state_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
- { 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 rref_to all_reference
- case toList targets of
- [] -> do
- let err =
- 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
- { 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)
- rref_to [(state_section, Nat1 1)]
- state_rrefs
- S.put st
- { state_rrefs = rrefs }
- 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
- { rref_error = Just $ ErrorTarget_Ambiguous Nothing
- , rref_number = Nothing
- , .. }
- <$> traverse check ts
- 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 (<>)) tag_to (pure tag_locTCT) $
- errors_tag_unknown state_errors
- S.put st
- { state_errors = state_errors
- { errors_tag_unknown = err }
- }
- Tree PlainTag
- { tag_error = Just $ ErrorTarget_Unknown $ Nat1 $ length $ err HM.!tag_to
- , .. }
- <$> traverse check ts
- [_] ->
- Tree PlainTag{tag_error = Nothing, ..}
- <$> traverse check ts
- _ -> do
- let err =
- 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
- { tag_error = Just $ ErrorTarget_Ambiguous $ Just $ Nat1 $ length $ err HM.!tag_to
- , .. }
- <$> traverse check ts
- _ -> Tree n <$> traverse check ts
-instance Check Title where
- check (Title p) = Title <$> check p
-instance Check About where
- check About{..} =
- About headers
- <$> traverse check titles
- <*> pure url
- <*> traverse check authors
- <*> traverse check editor
- <*> traverse check date
- <*> pure tags
- <*> pure links
- <*> pure series
- <*> traverse check includes
-instance Check Entity where
- check = return -- TODO: to be coded
-instance Check Date where
- check = return -- TODO: to be coded
-instance Check Include where
- check = return -- TODO: to be coded
-instance Check Reference where
- check Reference{..} = do
- st@State{state_collect=All{..}, ..} <- S.get
- let targets = HM.lookupDefault Seq.empty reference_id all_reference
- case toList targets of
- [] -> undefined
- [_] -> do
- about <- check reference_about
- return $ Reference
- { reference_error = Nothing
- , reference_about = about
- , .. }
- _ -> do
- let err =
- 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 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
-{-# 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
+++ /dev/null
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Hdoc.DTC.Collect where
-import Control.Applicative (Applicative(..))
-import Control.Monad
-import Data.Bool
-import Data.Default.Class (Default(..))
-import Data.Either (Either(..))
-import Data.Foldable (Foldable(..), any)
-import Data.Function (($))
-import Data.Functor ((<$>), (<$))
-import Data.Map.Strict (Map)
-import Data.Maybe (Maybe(..), fromMaybe)
-import Data.Monoid (Monoid(..))
-import Data.Sequence (Seq)
-import Data.Semigroup (Semigroup(..))
-import Data.TreeSeq.Strict (Tree(..))
-import Text.Show (Show(..))
-import qualified Data.HashMap.Strict as HM
-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 TS
-import qualified Hjugement as MJ
-import qualified Data.Tree as Tree
-
--- import Hdoc.Utils ()
-import Hdoc.DTC.Document as DTC
-import qualified Hdoc.XML as XML
-
--- * Type 'All'
--- | Collect 'Block's by mapping them by their 'XmlPos' or 'Ident'.
-data All = All
- { all_index :: Map XML.Pos Terms
- , 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 Judges
- , all_grades :: HM.HashMap Ident [Grade]
- , all_judgments :: HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])]
- } deriving (Show)
-instance Default All where
- def = All
- { all_index = def
- , all_figure = def
- , all_section = def
- , all_reference = def
- , all_judges = def
- , all_grades = def
- , all_judgments = def
- }
-instance Semigroup All where
- x<>y = All
- { all_index = Map.union (all_index x) (all_index y)
- , all_figure = Map.unionWith (<>) (all_figure x) (all_figure y)
- , all_section = HM.unionWith (<>) (all_section x) (all_section y)
- , all_reference = HM.unionWith (<>) (all_reference x) (all_reference y)
- , all_judges = HM.union (all_judges x) (all_judges y)
- , all_grades = HM.union (all_grades x) (all_grades y)
- , all_judgments = HM.unionWith (<>) (all_judgments x) (all_judgments y)
- }
-instance Monoid All where
- mempty = def
- mappend = (<>)
-
--- * Class 'Collect'
-class Collect a where
- collect :: a -> All
-instance Collect Document where
- collect Document{head=head@Head{about=About{titles}, judgments=js}, body} =
- def{ all_section = HM.fromListWith (<>) $ (\t -> (t, pure $ Left head)) <$> titles } <>
- (foldMap collect body)
- { all_judgments =
- choicesBySectionByJudgment HM.empty $
- 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{..} ->
- 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
- BlockPara _p -> def -- collect p
- BlockBreak{} -> def
- BlockToC{} -> def
- BlockToF{} -> def
- BlockAside{..} -> foldMap collect blocks
- BlockIndex{..} -> def{all_index = Map.singleton posXML terms}
- BlockFigure{..} ->
- def{all_figure=
- Map.singleton type_ (Map.singleton posXML mayTitle)}
- -- <> foldMap collect paras
- BlockReferences{..} ->
- def{all_reference=
- HM.fromListWith (<>) $ (<$> refs) $ \ref@DTC.Reference{..} -> (reference_id, pure ref)
- }
- BlockGrades{attrs=CommonAttrs{id=i}, ..} ->
- def{all_grades = HM.singleton (fromMaybe "" i) scale}
- BlockJudges judges@Judges{judges_attrs=CommonAttrs{id=i}, ..} ->
- def{all_judges = HM.singleton (fromMaybe "" i) judges}
-{-
-instance Collect Judgment where
- collect Judgment{..} = def
- def{all_judgments =
- HM.singleton
- (judges,grades,question)
- (Tree.Node choices [])
- }
- -- <> foldMap collect choices
-instance Collect Para where
- collect = \case
- ParaItem item -> collect item
- ParaItems{..} -> foldMap collect items
-instance Collect ParaItem where
- collect = \case
- ParaPlain{} -> def
- ParaArtwork{} -> def
- ParaQuote{..} -> foldMap collect paras
- ParaComment{} -> def
- ParaOL items -> foldMap collect items
- ParaUL items -> foldMap (foldMap collect) items
- ParaJudgment{} -> def
-instance Collect ListItem where
- collect ListItem{..} = foldMap collect paras
-instance Collect Choice where
- collect Choice{..} =
- foldMap collect title <>
- foldMap collect opinions
-instance Collect Opinion where
- collect Opinion{..} =
- foldMap collect comment
-instance Collect Title where
- collect (Title t) = collect t
-instance Collect Plain where
- collect = foldMap collect
-instance Collect (Tree PlainNode) where
- collect (Tree n ts) =
- case n of
- PlainBreak -> def
- PlainText{} -> def
- PlainGroup -> collect ts
- PlainB -> collect ts
- PlainCode -> collect ts
- PlainDel -> collect ts
- PlainI -> collect ts
- PlainSpan{} -> collect ts
- PlainSub -> collect ts
- PlainSup -> collect ts
- PlainSC -> collect ts
- PlainU -> collect ts
- PlainNote{..} -> foldMap collect note
- PlainQ -> collect ts
- PlainEref{} -> collect ts
- PlainIref{} -> collect ts
- PlainTag{} -> collect ts
- PlainRref{..} -> collect ts
--}
-
-choicesByJudgment :: [Judgment] -> HM.HashMap Judgment (Maybe MJ.Share, [Choice])
-choicesByJudgment js =
- HM.fromList $ (<$> js) $ \j@Judgment{..} ->
- (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{..} ->
- pure $
- 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
- -- which will inherit from this 'BodySection'.
- -- This enables judges to express something on material not in a sub 'BodySection'.
- let childrenBlocksJudgments =
- if (`any`bs) $ \case
- Tree BodyBlock{} _ -> True
- _ -> False
- then Seq.singleton $ Tree ((Nothing,[]) <$ choicesJ) Seq.empty
- else Seq.empty in
- childrenBlocksJudgments <>
- choicesByJudgmentBySection bs
-
-choicesBySectionByJudgment ::
- HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])] ->
- TS.Tree (HM.HashMap Judgment (Maybe MJ.Share, [Choice])) ->
- HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])]
-choicesBySectionByJudgment inh (TS.Tree selfJ childrenJS) =
- HM.unionWith
- (\selfS childrenS ->
- (<$> selfS) $ \(Tree.Node choices old) ->
- Tree.Node choices (old<>childrenS))
- (selfSJ <> inh)
- childrenSJ
- where
- selfSJ = (\cs -> [Tree.Node cs []]) <$> selfJ
- childrenSJ =
- foldl'
- (\accJ childJ ->
- HM.unionWith (<>) accJ $
- choicesBySectionByJudgment
- (([Tree.Node (Nothing,[]) []] <$ selfJ) <> inh)
- childJ
- )
- HM.empty
- childrenJS
import Data.Default.Class (Default(..))
import Data.Default.Instances.Containers ()
import Data.Eq (Eq(..))
+import Control.Monad (Monad(..))
import Data.Foldable (Foldable(..))
import Data.Function (on, ($), (.))
import Data.Hashable (Hashable(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
-import Data.Sequence (Seq(..))
+-- import Data.Sequence (Seq(..))
import Data.String (IsString)
import GHC.Generics (Generic)
import System.FilePath (FilePath)
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
import qualified Data.TreeSeq.Strict as TS
-import qualified Hjugement as MJ
+import qualified Data.TreeMap.Strict as TM
+import qualified Majority.Judgment as MJ
import Hdoc.Utils (Nat(..), Nat1(..), succNat, succNat1)
import Hdoc.XML (Ident(..), URL(..))
-- * Type 'Head'
data Head = Head
- { about :: !About
- , judgments :: ![Judgment]
+ { head_about :: !About
+ , head_judgments :: ![Judgment]
-- [(Judgment, [Tree.Tree (Maybe MJ.Share, [Choice])])]
} deriving (Eq,Show)
instance Default Head where
def = Head
- { about = def
- , judgments = def
+ { head_about = def
+ , head_judgments = def
}
-- ** Type 'About'
data About = About
- { headers :: ![Header]
- , titles :: ![Title]
- , url :: !(Maybe URL)
- , authors :: ![Entity]
- , editor :: !(Maybe Entity)
- , date :: !(Maybe Date)
- , tags :: ![TL.Text]
- , links :: ![Link]
- , series :: ![Serie]
- , includes :: ![Include] -- FIXME: remove?
+ { about_headers :: ![Header]
+ , about_titles :: ![Title]
+ , about_url :: !(Maybe URL)
+ , about_authors :: ![Entity]
+ , about_editor :: !(Maybe Entity)
+ , about_date :: !(Maybe Date)
+ , about_tags :: ![TL.Text]
+ , about_links :: ![Link]
+ , about_series :: ![Serie]
+ , about_includes :: ![Include] -- FIXME: remove?
} deriving (Eq,Show)
instance Default About where
def = About
- { headers = def
- , includes = def
- , titles = def
- , url = def
- , date = def
- , editor = def
- , authors = def
- , tags = def
- , links = def
- , series = def
+ { about_headers = def
+ , about_includes = def
+ , about_titles = def
+ , about_url = def
+ , about_date = def
+ , about_editor = def
+ , about_authors = def
+ , about_tags = def
+ , about_links = def
+ , about_series = def
}
instance Semigroup About where
x <> y = About
- { headers = headers x <> headers y
- , titles = titles x <> titles y
- , url = url (x::About) <> url (y::About)
- , authors = authors x <> authors y
- , editor = editor x <> editor y
- , date = date x <> date y
- , tags = tags x <> tags y
- , links = links x <> links y
- , series = series x <> series y
- , includes = includes x <> includes y
+ { about_headers = about_headers x <> about_headers y
+ , about_titles = about_titles x <> about_titles y
+ , about_url = about_url x <> about_url y
+ , about_authors = about_authors x <> about_authors y
+ , about_editor = about_editor x <> about_editor y
+ , about_date = about_date x <> about_date y
+ , about_tags = about_tags x <> about_tags y
+ , about_links = about_links x <> about_links y
+ , about_series = about_series x <> about_series y
+ , about_includes = about_includes x <> about_includes y
}
-- * Type 'Header'
data Header = Header
- { name :: !TL.Text
- , value :: !Plain
+ { header_name :: !TL.Text
+ , header_value :: !Plain
} deriving (Eq,Show)
-- * Type 'Body'
| PlainSup -- ^ Superscript
| PlainU -- ^ Underlined
| PlainEref { eref_href :: !URL } -- ^ External reference
- | PlainIref { iref_anchor :: !(Maybe Anchor)
- , iref_term :: !Words
+ | PlainIref { iref_term :: !Words
} -- ^ Index reference
- | PlainTag { tag_error :: !(Maybe ErrorTarget)
- , tag_locTCT :: !TCT.Location
+ | PlainTag { tag_locTCT :: !TCT.Location
+ , tag_posXML :: !XML.Pos
} -- ^ Reference
- | PlainRref { rref_error :: !(Maybe ErrorTarget)
- , rref_number :: !(Maybe Nat1)
- , rref_locTCT :: !TCT.Location
+ | PlainRref { rref_locTCT :: !TCT.Location
+ , rref_posXML :: !XML.Pos
, rref_to :: !Ident
} -- ^ Reference reference
| PlainSpan { attrs :: !CommonAttrs } -- ^ Neutral node
-- Leafs
| PlainBreak -- ^ Line break (\n)
| PlainText TL.Text
- | PlainNote { note_number :: !(Maybe Nat1)
- , note_paras :: ![Para]
+ | PlainNote { note_paras :: ![Para]
} -- ^ Footnote
deriving (Eq,Show)
+{-
-- * Type 'ErrorTarget'
data ErrorTarget
= ErrorTarget_Unknown !Nat1
data ErrorAnchor
= ErrorAnchor_Ambiguous !Nat1
deriving (Eq,Show)
+-}
-- * Type 'CommonAttrs'
data CommonAttrs = CommonAttrs
case n of
PlainGroup -> skip
PlainNote{} -> skip
- PlainIref{..} -> pure $ TS.Tree PlainIref{ iref_anchor = Nothing, ..} skip
- PlainRref{..} -> pure $ TS.Tree PlainRref{ rref_error = Nothing
- , rref_number = Nothing
- , rref_locTCT = def
+ PlainIref{..} -> keep
+ PlainRref{..} -> pure $ TS.Tree PlainRref{ rref_locTCT = def
, .. } skip
PlainSpan attrs -> pure $ TS.Tree n' skip
where n' = PlainSpan{attrs = CommonAttrs{ id = Nothing
-- * Type 'Reference'
data Reference = Reference
- { reference_error :: !(Maybe ErrorAnchor)
- , reference_posXML :: !XML.Pos
+ { {-reference_error :: !(Maybe ErrorAnchor)
+ ,-} reference_posXML :: !XML.Pos
, reference_locTCT :: !TCT.Location
, reference_id :: !Ident
, reference_about :: !About
deriving (Eq,Ord,Show,Generic)
instance Hashable WordOrSpace
--- ** Type 'Aliases'
-type Aliases = [Words]
-
-- ** Type 'Terms'
type Terms = [Aliases]
--- * Type 'Count'
-type Count = Int
+-- *** Type 'Aliases'
+type Aliases = [Words]
+
+-- ** Type 'PathWord'
+type PathWord = TM.Path Word
+
+pathFromWords :: Words -> Maybe PathWord
+pathFromWords ws =
+ case ws >>= unSpace of
+ p:ps | not (TL.null p) -> Just (TM.path p ps)
+ _ -> Nothing
+ where
+ unSpace = \case
+ Space -> []
+ Word w -> [w]
+
+-- * Type 'Location'
+type Location = (TCT.Location, XML.Pos)
+++ /dev/null
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hdoc.DTC.Index where
-
-import Control.Category
-import Control.Monad (Monad(..))
-import Data.Bool
-import Data.Char (Char)
-import Data.Default.Class (Default(..))
-import Data.Foldable (Foldable(..), concat)
-import Data.Function (($), const)
-import Data.Functor ((<$>))
-import Data.Map.Strict (Map)
-import Data.Maybe (Maybe(..), maybe, listToMaybe)
-import Data.Monoid (Monoid(..))
-import Data.Semigroup (Semigroup(..))
-import Data.Sequence ((|>))
-import Data.TreeMap.Strict (TreeMap(..))
-import Data.TreeSeq.Strict (Tree(..), tree0)
-import qualified Data.Char as Char
-import qualified Data.List as List
-import qualified Data.Map.Strict as Map
-import qualified Data.Sequence as Seq
-import qualified Data.Strict.Maybe as Strict
-import qualified Data.Text.Lazy as TL
-import qualified Data.TreeMap.Strict as TreeMap
--- import qualified Data.TreeSeq.Strict as TreeSeq
-
-import Hdoc.DTC.Document
-import qualified Hdoc.XML as XML
-
--- * Type 'PathWord'
-type PathWord = TreeMap.Path Word
-
-pathFromWords :: Words -> Maybe PathWord
-pathFromWords ws =
- case ws >>= unSpace of
- p:ps | not (TL.null p) -> Just (TreeMap.path p ps)
- _ -> Nothing
- where
- unSpace = \case
- Space -> []
- Word w -> [w]
-
--- * Type 'Irefs'
-type Irefs = TreeMap Word [Anchor]
-
-irefsOfTerms :: Terms -> Irefs
-irefsOfTerms = TreeMap.fromList const . (>>= f) . concat
- where
- f [] = []
- f ws = maybe [] (\p -> [(p,[])]) $ pathFromWords ws
-
-indexifyWords :: XML.Pos -> Irefs -> Words -> (Irefs, Plain)
-indexifyWords section = go mempty
- where
- go :: Plain -> Irefs -> Words -> (Irefs, Plain)
- go acc irefs inp =
- case inp of
- [] -> (irefs, acc)
- Space : next ->
- go (acc |> tree0 (PlainText " ")) irefs next
- Word w : next ->
- case goWords irefs [] inp of
- Nothing -> go (acc |> tree0 (PlainText w)) irefs next
- 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 ->
- Maybe (Anchor, Words, Words, Irefs)
- goWords m@(TreeMap irefsByWord) prev inp =
- case inp of
- [] -> Nothing
- curr@Space : next -> goWords m (curr:prev) next
- curr@(Word w) : next ->
- case Map.lookup w irefsByWord of
- Nothing -> Nothing
- Just nod@TreeMap.Node{..} ->
- let prev' = curr:prev in
- case node_value of
- Strict.Nothing
- | null node_descendants -> Nothing
- | otherwise ->
- (<$> goWords node_descendants prev' next) $ \(anch, ls, ns, rs) ->
- (anch, ls, ns, TreeMap $
- Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
- Strict.Just anchs ->
- case goWords node_descendants prev' next of
- Nothing ->
- 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) ->
- Just (anch, ls, ns, TreeMap $
- Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
-
-wordify :: TL.Text -> Words
-wordify = List.reverse . go []
- where
- go :: Words -> TL.Text -> Words
- go acc t =
- case TL.span Char.isAlphaNum t of
- ("",_) ->
- case TL.span Char.isSpace t of
- ("",_) ->
- case TL.uncons t of
- Nothing -> acc
- Just (c,r) -> go (Word (TL.singleton c) : acc) r
- (_s,r) -> go (Space : acc) r
- (w,r) -> go (Word w : acc) r
-
-plainifyWord :: WordOrSpace -> TL.Text
-plainifyWord = \case
- Word w -> w
- Space -> " "
-
-plainifyWords :: Words -> TL.Text
-plainifyWords = TL.concat . (plainifyWord <$>)
-
-termsByChar :: Terms -> Map Char Terms
-termsByChar =
- foldr (\aliases acc ->
- case aliases of
- (Word w:_):_ | not (TL.null w) ->
- Map.insertWith (<>)
- (Char.toUpper $ TL.index w 0)
- [aliases] acc
- _ -> acc
- ) Map.empty
import Hdoc.XML
import Hdoc.RNC.Sym as RNC
-import Hdoc.DTC.Index (wordify)
+import qualified Hdoc.DTC.Analyze.Index as Index
import qualified Hdoc.DTC.Document as DTC
import qualified Hdoc.RNC.Write as RNC
import qualified Hdoc.TCT.Cell as TCT
element "para" $
(concat <$>) $
many $
- (wordify <$>) . TL.lines <$> text)
+ (Index.wordify <$>) . TL.lines <$> text)
blockAside =
rule "blockAside" $
element "aside" $
, element "sub" $ Tree DTC.PlainSub <$> plain
, element "sup" $ Tree DTC.PlainSup <$> plain
, element "u" $ Tree DTC.PlainU <$> plain
- , element "note" $ tree0 . DTC.PlainNote Nothing <$> many para
- , element "iref" $ Tree . DTC.PlainIref Nothing . wordify <$> attribute "to" text <*> plain
+ , element "note" $ tree0 . DTC.PlainNote <$> many para
+ , element "iref" $ Tree . DTC.PlainIref . Index.wordify <$> attribute "to" text <*> plain
, element "eref" $ Tree . DTC.PlainEref <$> attribute "to" url <*> plain
- , element "tag" $ Tree . DTC.PlainTag def <$> locationTCT <*> plain
- , element "rref" $ Tree <$> (DTC.PlainRref Nothing Nothing <$> locationTCT <*> to) <*> plain
+ , element "tag" $ Tree <$> (DTC.PlainTag <$> locationTCT <*> positionXML) <*> plain
+ , element "rref" $ Tree <$> (DTC.PlainRref <$> locationTCT <*> positionXML <*> to) <*> plain
]
tag = rule "tag" $ element "tag" text
about =
(foldr ($) def <$>) $
many $ choice
- [ (\a acc -> acc{DTC.titles=a:DTC.titles acc}) <$> title
- , (\a acc -> (acc::DTC.About){DTC.url=Just a}) <$> attribute "url" url
- , (\a acc -> acc{DTC.authors=a:DTC.authors acc}) <$> author
- , (\a acc -> acc{DTC.editor=DTC.editor acc Alt.<|> Just a}) <$> editor
- , (\a acc -> acc{DTC.date=DTC.date acc Alt.<|> Just a}) <$> date
- , (\a acc -> acc{DTC.tags=a:DTC.tags acc}) <$> tag
- , (\a acc -> acc{DTC.links=a:DTC.links acc}) <$> link
- , (\a acc -> acc{DTC.series=a:DTC.series acc}) <$> serie
- , (\a acc -> acc{DTC.headers=a:DTC.headers acc}) <$> header
+ [ (\a acc -> acc{DTC.about_titles = a:DTC.about_titles acc}) <$> title
+ , (\a acc -> acc{DTC.about_url = Just a}) <$> attribute "url" url
+ , (\a acc -> acc{DTC.about_authors = a:DTC.about_authors acc}) <$> author
+ , (\a acc -> acc{DTC.about_editor = DTC.about_editor acc Alt.<|> Just a}) <$> editor
+ , (\a acc -> acc{DTC.about_date = DTC.about_date acc Alt.<|> Just a}) <$> date
+ , (\a acc -> acc{DTC.about_tags = a:DTC.about_tags acc}) <$> tag
+ , (\a acc -> acc{DTC.about_links = a:DTC.about_links acc}) <$> link
+ , (\a acc -> acc{DTC.about_series = a:DTC.about_series acc}) <$> serie
+ , (\a acc -> acc{DTC.about_headers = a:DTC.about_headers acc}) <$> header
]
header =
rule "header" $
<$> title
reference = rule "reference" $
element "reference" $
- DTC.Reference Nothing
+ DTC.Reference
<$> positionXML
<*> locationTCT
<*> id
<||> attribute "judges" ident
<||> attribute "grades" ident
<|?> (def, Just <$> attribute "importance" rationalPositive)
+ -- <|?> (def, Just <$> attribute "importance" (pure 0))
<|?> (def, Just <$> title)
choice_ =
rule "choice" $
<|?> (def, attribute "judge" name)
<|?> (def, attribute "grade" name)
<|?> (def, Just <$> attribute "importance" rationalPositive))
+ -- <|?> (def, Just <$> attribute "importance" (pure 0)))
<*> optional title
judges =
rule "judges" $
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Either (Either(..))
-import Data.Foldable (Foldable(..), concat, any)
-import Data.Function (($), (.), const, on)
-import Data.Functor ((<$>))
+import Data.Foldable (Foldable(..), any, concat, fold)
+import Data.Function (($), (.), const)
+import Data.Functor ((<$>), (<$))
import Data.Functor.Compose (Compose(..))
-import Data.IntMap.Strict (IntMap)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Locale hiding (Index)
-import Data.Maybe (Maybe(..), maybe, mapMaybe, fromJust, maybeToList, listToMaybe)
+import Data.Maybe (Maybe(..), maybe, mapMaybe, maybeToList, listToMaybe, isNothing)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
+import Data.Sequence (Seq)
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.TreeSeq.Strict (Tree(..), tree0)
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 Control.Monad.Trans.Reader as R
+import qualified Control.Monad.Trans.RWS.Strict as RWS
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.Strict.Maybe as Strict
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
-import qualified Data.TreeMap.Strict as TreeMap
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
import qualified Text.Blaze.Internal as H
+import Control.Monad.Utils
import Hdoc.DTC.Document as DTC
+import Hdoc.DTC.Write.HTML5.Base
+import Hdoc.DTC.Write.HTML5.Error ()
import Hdoc.DTC.Write.HTML5.Ident
+import Hdoc.DTC.Write.HTML5.Judgment
import Hdoc.DTC.Write.Plain (Plainify(..))
import Hdoc.DTC.Write.XML ()
import Hdoc.Utils
-import Control.Monad.Utils
import Text.Blaze.Utils
-import qualified Hdoc.DTC.Check as Check
-import qualified Hdoc.DTC.Collect as Collect
-import qualified Hdoc.DTC.Index as Index
+import qualified Hdoc.DTC.Analyze.Check as Analyze
+import qualified Hdoc.DTC.Analyze.Collect as Analyze
+import qualified Hdoc.DTC.Analyze.Index as Index
import qualified Hdoc.DTC.Write.Plain as Plain
import qualified Hdoc.TCT.Cell as TCT
import qualified Hdoc.Utils as FS
import qualified Hdoc.XML as XML
import qualified Paths_hdoc as Hdoc
-import 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
writeHTML5 :: Config -> DTC.Document -> IO Html
writeHTML5 conf@Config{..} doc@DTC.Document{..} = do
+ let all = R.runReader (Analyze.collect doc) def
+ let err = Analyze.errors all
+ let ro = def
+ { reader_l10n = loqualize config_locale
+ , reader_plainify = def{Plain.reader_l10n = loqualize config_locale}
+ , reader_all = all
+ -- , reader_section = body
+ }
+ let st = def
+ { state_errors = debug "errors" $ Nat1 1 <$ err
+ , state_notes = fold $ toList <$> {-debug "all_notes"-} (Analyze.all_notes all)
+ }
+ let (html5Body, _endState, endWriter) =
+ runComposeRWS ro st $ do
+ html5Judgments
+ html5ify err
+ html5DocumentHead head
+ html5ify body
+ html5Head <- writeHTML5Head conf ro endWriter head body
+ return $ do
+ H.docType
+ H.html ! HA.lang (attrify $ countryCode config_locale) $ do
+ html5Head
+ H.body $ do
+ {- NOTE:
+ unless (null state_scripts) $ do
+ -- NOTE: indicate that JavaScript is active.
+ H.script ! HA.type_ "application/javascript" $
+ "document.body.className = \"script\";"
+ -}
+ html5Body
+ {-
let (checkedBody,checkState) =
- let state_collect = Collect.collect doc in
- Check.check body `S.runState` def
- { Check.state_irefs = foldMap Index.irefsOfTerms $ Collect.all_index state_collect
- , Check.state_collect
+ let state_collect = Analyze.collect doc in
+ Analyze.check body `S.runState` def
+ { Analyze.state_irefs = foldMap Index.irefsOfTerms $ Analyze.all_index state_collect
+ , Analyze.state_collect
}
let (html5Body, endState) =
- let Check.State{..} = checkState in
- runComposeState def
+ runComposeRWS def
{ state_collect
+ {-
, state_indexs =
- (<$> Collect.all_index state_collect) $ \terms ->
+ (<$> Analyze.all_index state_collect) $ \terms ->
(terms,) $
TreeMap.intersection const state_irefs $
Index.irefsOfTerms terms
- , state_rrefs
, state_notes
+ -}
+ , state_rrefs
, state_section = body
, state_l10n = loqualize config_locale
- , state_plainify = def{Plain.state_l10n = loqualize config_locale}
+ , state_plainify = def{Plain.reader_l10n = loqualize config_locale}
} $ do
html5Judgments
html5ify state_errors
"document.body.className = \"script\";"
-}
html5Body
-
-writeHTML5Head :: Config -> State -> Head -> IO Html
-writeHTML5Head Config{..} State{..} Head{DTC.about=About{..}} = do
- csss :: Html <-
+ -}
+writeHTML5Head :: Config -> Reader -> Writer -> Head -> Body -> IO Html
+writeHTML5Head Config{..} Reader{..} Writer{..} Head{DTC.head_about=About{..}} body = do
+ csss :: Html <- do
-- unless (any (\DTC.Link{..} -> rel == "stylesheet" && href /= URL "") links) $ do
- (`foldMap` state_styles) $ \case
+ (`foldMap` writer_styles) $ \case
Left css -> do
content <- FS.readFile =<< Hdoc.getDataFileName ("style"</>css)
return $ H.style ! HA.type_ "text/css" $
H.toMarkup content
- Right content ->
- return $ H.style ! HA.type_ "text/css" $
+ Right content -> return $ do
+ H.style ! HA.type_ "text/css" $
-- NOTE: as a special case, H.style wraps its content into an External,
-- so it does not HTML-escape its content.
H.toMarkup content
- {-
- case config_css of
- Left "" -> mempty
- Left css ->
- H.link ! HA.rel "stylesheet"
- ! HA.type_ "text/css"
- ! HA.href (attrify css)
- Right css ->
- H.style ! HA.type_ "text/css" $
- H.toMarkup css
- -}
scripts :: Html <-
- (`foldMap` state_scripts) $ \script -> do
+ (`foldMap` writer_scripts) $ \script -> do
content <- FS.readFile =<< Hdoc.getDataFileName ("style"</>script)
return $ H.script ! HA.type_ "application/javascript" $
H.toMarkup content
- {-
+ {-
if not (any (\DTC.Link{rel} -> rel == "script") links)
then do
else
$ mempty
Right js -> H.script ! HA.type_ "application/javascript"
$ H.toMarkup js
- -}
+ -}
return $
H.head $ do
H.meta ! HA.httpEquiv "Content-Type"
! HA.content "text/html; charset=UTF-8"
- unless (null titles) $ do
+ unless (null about_titles) $ do
H.title $
- H.toMarkup $ Plain.text state_plainify $ List.head titles
- forM_ links $ \Link{..} ->
+ H.toMarkup $ Plain.text reader_plainify $ List.head about_titles
+ forM_ about_links $ \Link{..} ->
case rel of
"stylesheet" | URL "" <- href ->
H.style ! HA.type_ "text/css" $
_ ->
H.link ! HA.rel (attrify rel)
! HA.href (attrify href)
- forM_ url $ \href ->
+ forM_ about_url $ \href ->
H.link ! HA.rel "self"
! HA.href (attrify href)
unless (TL.null config_generator) $ do
H.meta ! HA.name "generator"
! HA.content (attrify config_generator)
- unless (null tags) $
+ unless (null about_tags) $
H.meta ! HA.name "keywords"
- ! HA.content (attrify $ TL.intercalate ", " tags)
+ ! HA.content (attrify $ TL.intercalate ", " about_tags)
let chapters =
- (`mapMaybe` toList state_section) $ \case
+ (`mapMaybe` toList body) $ \case
Tree (BodySection s) _ -> Just s
_ -> Nothing
forM_ chapters $ \Section{..} ->
H.link ! HA.rel "Chapter"
! HA.title (attrify $ plainify section_title)
! HA.href (refIdent $ identify section_posXML)
+ case config_css of
+ Left "" -> mempty
+ Left css ->
+ H.link ! HA.rel "stylesheet"
+ ! HA.type_ "text/css"
+ ! HA.href (attrify css)
+ Right css ->
+ H.style ! HA.type_ "text/css" $
+ H.toMarkup css
csss
scripts
html5DocumentHead :: Head -> HTML5
-html5DocumentHead Head{DTC.about=About{..}, judgments} = do
- st <- liftComposeState S.get
- unless (null authors) $ do
+html5DocumentHead Head{DTC.head_about=About{..}, head_judgments} = do
+ ro <- composeLift RWS.ask
+ unless (null about_authors) $ do
H.div ! HA.class_ "document-head" $$
H.table $$ do
H.tbody $$ do
H.tr $$ do
H.td ! HA.class_ "left" $$ docHeaders
H.td ! HA.class_ "right" $$ docAuthors
- unless (null titles) $ do
+ unless (null about_titles) $ do
H.div ! HA.class_ "title"
! HA.id "document-title." $$ do
- forM_ titles $ \title ->
- H.h1 ! HA.id (attrify $ identifyTitle (Plain.state_l10n $ state_plainify st) title) $$
+ forM_ about_titles $ \title ->
+ H.h1 ! HA.id (attrify $ identifyTitle (Plain.reader_l10n $ reader_plainify ro) title) $$
html5ify title
do -- judgments
- let sectionJudgments = HS.fromList judgments
- let opinsBySectionByJudgment = state_opinions st `HM.intersection` HS.toMap sectionJudgments
- liftComposeState $ S.modify' $ \s ->
+ st <- composeLift RWS.get
+ let sectionJudgments = debug "sectionJudgments" $ HS.fromList head_judgments
+ let opinsBySectionByJudgment = debug "opinsBySectionByJudgment" $ state_opinions st `HM.intersection` HS.toMap sectionJudgments
+ composeLift $ RWS.modify $ \s ->
s{ state_judgments = sectionJudgments
, state_opinions =
-- NOTE: drop current opinions of the judgments of this section
opinsBySectionByJudgment
}
unless (null opinsBySectionByJudgment) $ do
- let choicesJ = Collect.choicesByJudgment judgments
+ let choicesJ = Analyze.choicesByJudgment head_judgments
forM_ (HM.toList opinsBySectionByJudgment) $ \(judgment@Judgment{..},opinsBySection) -> do
H.div ! HA.class_ "judgment section-judgment document-judgment" $$ do
html5ify judgment
docHeaders =
H.table ! HA.class_ "document-headers" $$
H.tbody $$ do
- Loqualization l10n <- liftComposeState $ S.gets state_l10n
- forM_ series $ \s@Serie{id=id_, name} ->
+ Loqualization l10n <- composeLift $ RWS.asks reader_l10n
+ forM_ about_series $ \s@Serie{id=id_, name} ->
header $
case urlSerie s of
Nothing -> do
headerValue $
H.a ! HA.href (attrify href) $$
html5ify id_
- forM_ links $ \Link{..} ->
+ forM_ about_links $ \Link{..} ->
unless (TL.null $ unName name) $
header $ do
headerName $ html5ify name
headerValue $ html5ify $ Tree PlainEref{eref_href=href} plain
- forM_ date $ \d ->
+ forM_ about_date $ \d ->
header $ do
headerName $ l10n_Header_Date l10n
headerValue $ html5ify d
- forM_ url $ \href ->
+ forM_ about_url $ \href ->
header $ do
headerName $ l10n_Header_Address l10n
headerValue $ html5ify $ tree0 $ PlainEref{eref_href=href}
- forM_ headers $ \Header{..} ->
+ forM_ about_headers $ \Header{..} ->
header $ do
- headerName $ html5ify name
- headerValue $ html5ify value
+ headerName $ html5ify header_name
+ headerValue $ html5ify header_value
docAuthors =
H.table ! HA.class_ "document-authors" $$
H.tbody $$ do
- forM_ authors $ \a ->
+ forM_ about_authors $ \a ->
H.tr $$
H.td ! HA.class_ "author" $$
html5ify a
headerName hdr =
H.td ! HA.class_ "header-name" $$ do
hdr
- Loqualization l10n <- liftComposeState $ S.gets state_l10n
+ Loqualization l10n <- composeLift $ RWS.asks reader_l10n
Plain.l10n_Colon l10n
headerValue :: HTML5 -> HTML5
headerValue hdr =
H.li $$
html5ify $ show s
instance Html5ify Body where
- html5ify body = do
- liftComposeState $ S.modify' $ \s -> s{state_section = body}
- mapM_ html5ify body
- case Seq.viewr body of
- _ Seq.:> Tree BodyBlock{} _ -> do
- notes <- liftComposeState $ S.gets state_notes
- maybe mempty html5Notes $
- Map.lookup mempty notes
- _ -> mempty
+ html5ify body =
+ localComposeRWS (\ro -> ro{reader_section = body}) $ go body
+ where
+ go bs =
+ case Seq.viewl bs of
+ Seq.EmptyL ->
+ popNotes >>= html5Notes
+ curr Seq.:< next -> do
+ case curr of
+ Tree BodySection{} _ -> popNotes >>= html5Notes
+ _ -> mempty
+ html5ify curr
+ go next
instance Html5ify (Tree BodyNode) where
- html5ify (Tree b bs) =
+ html5ify (Tree b bs) = do
case b of
BodyBlock blk -> html5ify blk
BodySection Section{..} -> do
- 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 section_posXML
- let (sectionNotes, notes) = Map.updateLookupWithKey (\_ _ -> Nothing) sectionPosPath $ state_notes st
- (,notes) <$> sectionNotes
- case mayNotes of
- Nothing -> mempty
- Just (sectionNotes, state_notes) -> do
- liftComposeState $ S.modify' $ \s -> s{state_notes}
- html5Notes sectionNotes
- 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 section_judgments
- let opinsBySectionByJudgment = state_opinions st `HM.intersection` HS.toMap sectionJudgments
- let dropChildrenBlocksJudgments =
- -- NOTE: drop the "phantom" judgments concerning the 'BodyBlock's
- -- directly children of this 'BodySection'.
- if (`any`bs) $ \case
- Tree BodyBlock{} _ -> True
- _ -> False
- then List.tail
- else Cat.id
- liftComposeState $ S.modify' $ \s ->
- s{ state_judgments = sectionJudgments
- , state_opinions =
- -- NOTE: drop current opinions of the judgments of this section
- HM.unionWith (const $ List.tail . dropChildrenBlocksJudgments)
- (state_opinions s)
- opinsBySectionByJudgment
- }
- unless (null opinsBySectionByJudgment) $ do
- 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 section_judgments
- forM_ (HM.toList opinsBySectionByJudgment) $ \(judgment@Judgment{..},opinsBySection) -> do
- H.div ! HA.class_ "judgment section-judgment" $$ do
- html5ify judgment
- { judgment_opinionsByChoice = listToMaybe opinsBySection
- , judgment_choices = maybe [] snd $ HM.lookup judgment choicesJ
- }
- let mayId =
- case 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"
- !?? mayAttr HA.id mayId $$
- H.tbody $$
- H.tr $$ do
- H.td ! HA.class_ "section-number" $$ do
- html5SectionNumber $ XML.pos_ancestors section_posXML
- H.td ! HA.class_ "section-title" $$ do
- (case List.length $ XML.pos_ancestors section_posXML of
- 0 -> H.h1
- 1 -> H.h2
- 2 -> H.h3
- 3 -> H.h4
- 4 -> H.h5
- 5 -> H.h6
- _ -> H.h6) $$
- html5ify section_title
- forM_ bs html5ify
- do -- judgments
- liftComposeState $ S.modify' $ \s ->
- s{ state_judgments = state_judgments st }
- do -- notes
- notes <- liftComposeState $ S.gets state_notes
- maybe mempty html5Notes $
- Map.lookup (XML.pos_ancestors section_posXML) notes
- liftComposeState $ S.modify' $ \s -> s{state_section = state_section st}
+ localComposeRWS (\ro -> ro{reader_section = bs}) $ do
+ ro@Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask
+ notes <- popNotes
+ html5CommonAttrs section_attrs{classes="section":classes section_attrs, id=Nothing} $ do
+ H.section ! HA.id (attrify $ identify section_posXML) $$ do
+ forM_ section_aliases html5ify
+ st <- composeLift RWS.get
+ do -- judgments
+ let sectionJudgments = debug "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
+ -- directly children of this 'BodySection'.
+ if (`any`bs) $ \case
+ Tree BodyBlock{} _ -> True
+ _ -> False
+ then List.tail
+ else Cat.id
+ composeLift $ RWS.modify $ \s ->
+ s{ state_judgments = sectionJudgments
+ , state_opinions =
+ -- NOTE: drop current opinions of the judgments of this section
+ HM.unionWith (const $ List.tail . dropChildrenBlocksJudgments)
+ (state_opinions s)
+ opinsBySectionByJudgment
+ }
+ unless (null opinsBySectionByJudgment) $ do
+ composeLift $ RWS.tell def
+ { writer_styles = HS.singleton $ Left "dtc-judgment.css" }
+ H.aside ! HA.class_ "aside" $$ do
+ let choicesJ = Analyze.choicesByJudgment section_judgments
+ forM_ (HM.toList opinsBySectionByJudgment) $ \(judgment@Judgment{..},opinsBySection) -> do
+ H.div ! HA.class_ "judgment section-judgment" $$ do
+ html5ify judgment
+ { judgment_opinionsByChoice = listToMaybe opinsBySection
+ , judgment_choices = maybe [] snd $ HM.lookup judgment choicesJ
+ }
+ let mayId =
+ case toList <$> HM.lookup section_title all_section of
+ Just [_] -> Just $ identifyTitle (Plain.reader_l10n $ reader_plainify ro) section_title
+ _ -> Nothing
+ H.table
+ ! HA.class_ "section-header"
+ !?? mayAttr HA.id ({-debugOn "st" (const st)-} mayId) $$
+ H.tbody $$
+ H.tr $$ do
+ H.td ! HA.class_ "section-number" $$ do
+ html5SectionNumber $ XML.pos_ancestors section_posXML
+ H.td ! HA.class_ "section-title" $$ do
+ (case List.length $ XML.pos_ancestors section_posXML of
+ 0 -> H.h1
+ 1 -> H.h2
+ 2 -> H.h3
+ 3 -> H.h4
+ 4 -> H.h5
+ 5 -> H.h6
+ _ -> H.h6) $$
+ html5ify section_title
+ html5ify bs
+ do -- judgments
+ composeLift $ RWS.modify $ \s ->
+ s{ state_judgments = state_judgments st }
+ html5Notes notes
+ {- FIXME
+ do -- notes
+ notes <- composeLift $ S.gets state_notes
+ maybe mempty html5Notes $
+ Map.lookup (XML.pos_ancestors section_posXML) notes
+ -}
instance Html5ify Block where
html5ify = \case
BlockPara para -> html5ify para
! HA.id (attrify $ identify posXML) $$ do
H.span ! HA.class_ "toc-name" $$
H.a ! HA.href (refIdent $ identify posXML) $$ do
- Loqualization l10n <- liftComposeState $ S.gets state_l10n
+ Loqualization l10n <- composeLift $ RWS.asks reader_l10n
Plain.l10n_Table_of_Contents l10n
H.ul $$ do
- State{state_section} <- liftComposeState S.get
- forM_ state_section $ html5ifyToC depth
+ Reader{reader_section} <- composeLift RWS.ask
+ forM_ reader_section $ html5ifyToC depth
BlockToF{..} -> do
H.nav ! HA.class_ "tof"
! HA.id (attrify $ identify posXML) $$
forM_ mayTitle $ \title -> do
H.td ! HA.class_ "figure-colon" $$ do
unless (TL.null type_) $ do
- Loqualization l10n <- liftComposeState $ S.gets state_l10n
+ Loqualization l10n <- composeLift $ RWS.asks reader_l10n
Plain.l10n_Colon l10n
H.td ! HA.class_ "figure-title" $$ do
html5ify title
H.div ! HA.class_ "figure-content" $$ do
html5ify paras
BlockIndex{posXML} -> do
- st@State{..} <- liftComposeState S.get
- liftComposeState $ S.put st
- { state_styles = HS.insert (Left "dtc-index.css") state_styles }
+ st@State{..} <- composeLift RWS.get
+ composeLift $ RWS.tell def
+ { writer_styles = HS.singleton $ Left "dtc-index.css" }
+ {- FIXME
let (allTerms,refsByTerm) = state_indexs Map.!posXML
let chars = Index.termsByChar allTerms
H.div ! HA.class_ "index"
List.sortBy (compare `on` anchor_section . snd) $
(`foldMap` aliases) $ \words ->
fromJust $ do
- path <- Index.pathFromWords words
+ path <- DTC.pathFromWords words
Strict.maybe Nothing (Just . ((words,) <$>) . List.reverse) $
TreeMap.lookup path refsByTerm in
html5CommasDot $
H.a ! HA.class_ "index-iref"
! HA.href (refIdent $ identifyIrefCount term anchor_count) $$
html5ify $ XML.pos_ancestors anchor_section
+ -}
BlockReferences{..} ->
html5CommonAttrs attrs
{ classes = "references":classes attrs
ParaQuote{..} -> H.div $$ do html5ify paras
ParaComment t -> html5ify $ H.Comment (H.String $ TL.unpack t) ()
ParaOL items ->
- H.table $$ do
- H.tbody $$
- forM_ items $ \ListItem{..} -> do
- H.tr $$ do
- H.td ! HA.class_ "name" $$ do
- html5ify name
- "."::HTML5
- H.td ! HA.class_ "value" $$
- html5ify paras
+ H.dl $$ do
+ forM_ items $ \ListItem{..} -> do
+ H.dt ! HA.class_ "name" $$ do
+ html5ify name
+ "."::HTML5
+ H.dd ! HA.class_ "value" $$
+ html5ify paras
ParaUL items ->
H.dl $$ do
forM_ items $ \item -> do
html5ify curr
html5ify next
instance Html5ify (Tree PlainNode)
- where html5ify (Tree n ls) =
+ where html5ify (Tree n ps) =
case n of
PlainBreak -> html5ify H.br
PlainText t -> html5ify t
- PlainGroup -> html5ify ls
- PlainB -> H.strong $$ html5ify ls
- PlainCode -> H.code $$ html5ify ls
- PlainDel -> H.del $$ html5ify ls
+ PlainGroup -> html5ify ps
+ PlainB -> H.strong $$ html5ify ps
+ PlainCode -> H.code $$ html5ify ps
+ PlainDel -> H.del $$ html5ify ps
PlainI -> do
- i <- liftComposeState $ do
- i <- S.gets $ Plain.state_italic . state_plainify
- S.modify $ \s ->
- s{state_plainify=
- (state_plainify s){Plain.state_italic=
- not i}}
- return i
+ i <- composeLift $ RWS.asks reader_italic
H.em ! HA.class_ (if i then "even" else "odd") $$
- html5ify ls
- liftComposeState $
- S.modify $ \s ->
- s{state_plainify=
- (state_plainify s){Plain.state_italic=i}}
+ localComposeRWS (\ro -> ro{reader_italic=not i}) $
+ html5ify ps
PlainSpan{..} ->
html5CommonAttrs attrs $
- H.span $$ html5ify ls
- PlainSub -> H.sub $$ html5ify ls
- PlainSup -> H.sup $$ html5ify ls
- PlainSC -> H.span ! HA.class_ "smallcaps" $$ html5ify ls
- PlainU -> H.span ! HA.class_ "underline" $$ html5ify ls
- PlainNote{..} ->
- case note_number of
- Nothing -> mempty
- Just num ->
- H.a ! HA.class_ "note-ref"
- ! HA.id ("note-ref."<>attrify num)
- ! HA.href ("#note."<>attrify num) $$
- html5ify num
+ H.span $$ html5ify ps
+ PlainSub -> H.sub $$ html5ify ps
+ PlainSup -> H.sup $$ html5ify ps
+ PlainSC -> H.span ! HA.class_ "smallcaps" $$ html5ify ps
+ PlainU -> H.span ! HA.class_ "underline" $$ html5ify ps
+ PlainNote{..} -> do
+ num <- composeLift $ do
+ num <- RWS.gets state_note_num_ref
+ RWS.modify $ \s -> s{state_note_num_ref=succNat1 num}
+ return num
+ H.a ! HA.class_ "note-ref"
+ ! HA.id ("note-ref."<>attrify num)
+ ! HA.href ("#note."<>attrify num) $$
+ html5ify num
PlainQ -> do
H.span ! HA.class_ "q" $$ do
- Loqualization l10n <- liftComposeState $ S.gets state_l10n
- Plain.l10n_Quote (html5ify $ Tree PlainI ls) l10n
+ Loqualization l10n <- composeLift $ RWS.asks reader_l10n
+ Plain.l10n_Quote (html5ify $ Tree PlainI ps) l10n
PlainEref{..} ->
H.a ! HA.class_ "eref"
! HA.href (attrify eref_href) $$
- if null ls
+ if null ps
then html5ify $ unURL eref_href
- else html5ify ls
+ else html5ify ps
PlainIref{..} ->
+ mempty
+ {- FIXME
case iref_anchor of
- Nothing -> html5ify ls
+ Nothing -> html5ify ps
Just Anchor{..} ->
H.span ! HA.class_ "iref"
! HA.id (attrify $ identifyIrefCount iref_term anchor_count) $$
- html5ify ls
+ html5ify ps
+ -}
PlainTag{..} -> do
- st <- liftComposeState S.get
- let l10n = Plain.state_l10n $ state_plainify st
- case tag_error of
- Nothing ->
- H.a ! HA.class_ "tag"
- ! HA.href (refIdent $ identifyTitle l10n $ Title ls) $$
- html5ify ls
- Just (ErrorTarget_Unknown num) ->
+ Reader{..} <- composeLift RWS.ask
+ State{state_errors=errs@Analyze.Errors{..}} <- composeLift RWS.get
+ let l10n = Plain.reader_l10n reader_plainify
+ let tag = Title ps
+ case () of
+ _ | Just num <- HM.lookup tag errors_tag_unknown -> do
+ composeLift $ RWS.modify $ \s -> s
+ { state_errors = errs
+ { Analyze.errors_tag_unknown =
+ HM.adjust succNat1 tag errors_tag_unknown } }
H.span ! HA.class_ "tag tag-unknown"
- ! HA.id (attrify $ identifyTag "-unknown" l10n ls (Just num)) $$
- html5ify ls
- Just (ErrorTarget_Ambiguous num) ->
+ ! HA.id (attrify $ identifyTag "-unknown" l10n tag (Just num)) $$
+ html5ify tag
+ | Just num <- HM.lookup tag errors_tag_ambiguous -> do
+ composeLift $ RWS.modify $ \s -> s
+ { state_errors = errs
+ { Analyze.errors_tag_ambiguous =
+ HM.adjust succNat1 tag errors_tag_ambiguous } }
H.span ! HA.class_ "tag tag-ambiguous"
- ! HA.id (attrify $ identifyTag "-ambiguous" l10n ls num) $$
- html5ify ls
+ ! HA.id (attrify $ identifyTag "-ambiguous" l10n tag (Just num)) $$
+ html5ify tag
+ | otherwise -> do
+ H.a ! HA.class_ "tag"
+ ! HA.href (refIdent $ identifyTitle l10n tag) $$
+ html5ify tag
PlainRref{..} -> do
- case rref_error of
- Nothing ->
- let ref = do
- "["::HTML5
+ Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask
+ State{state_errors=errs@Analyze.Errors{..}, ..} <- composeLift RWS.get
+ case toList $ HM.lookupDefault def rref_to all_reference of
+ [] -> do
+ let num = HM.lookup rref_to errors_rref_unknown
+ composeLift $ RWS.modify $ \s -> s
+ { state_errors = errs
+ { Analyze.errors_rref_unknown =
+ HM.adjust succNat1 rref_to errors_rref_unknown } }
+ "["::HTML5
+ H.span ! HA.class_ "reference reference-unknown"
+ ! HA.id (attrify $ identifyReference "-unknown" rref_to num) $$
+ html5ify rref_to
+ "]"
+ [Reference{..}] -> do
+ let num = HM.lookupDefault (Nat1 1) rref_to state_rrefs
+ composeLift $ RWS.modify $ \s -> s
+ { state_rrefs = HM.insert rref_to (succNat1 num) state_rrefs }
+ let a =
H.a ! HA.class_ "reference"
! HA.href (refIdent $ identifyReference "" rref_to Nothing)
- ! HA.id (attrify $ identifyReference "" rref_to rref_number) $$
- html5ify rref_to
- "]" in
- case toList ls of
+ ! HA.id (attrify $ identifyReference "" rref_to $ Just num)
+ let ref = do
+ "["::HTML5
+ a $$ html5ify rref_to
+ "]"
+ case toList ps of
[] -> ref
[Tree (PlainText "") _] -> do
- refs <- liftComposeState $ S.gets $ Collect.all_reference . state_collect
+ refs <- composeLift $ RWS.asks $ Analyze.all_reference . reader_all
case toList <$> HM.lookup rref_to refs of
Just [Reference{reference_about=About{..}}] -> do
- forM_ (List.take 1 titles) $ \(Title title) -> do
+ forM_ (List.take 1 about_titles) $ \(Title title) -> do
html5ify $ Tree PlainQ $
- case url of
+ case about_url of
Nothing -> title
Just u -> pure $ Tree (PlainEref u) title
" "::HTML5
ref
_ -> mempty
_ -> do
- H.a ! HA.class_ "reference"
- ! HA.href (refIdent $ identifyReference "" rref_to Nothing)
- ! HA.id (attrify $ identifyReference "" rref_to rref_number) $$
- html5ify ls
+ a $$ html5ify ps
H.span ! HA.class_ "print-only" $$ do
" "::HTML5
ref
- Just (ErrorTarget_Unknown num) -> do
- "["::HTML5
- H.span ! HA.class_ "reference reference-unknown"
- ! HA.id (attrify $ identifyReference "-unknown" rref_to $ Just num) $$
- html5ify rref_to
- "]"
- Just (ErrorTarget_Ambiguous num) -> do
- case toList ls of
+ _ -> do
+ case toList ps of
[] -> mempty
[Tree (PlainText "") _] -> mempty
_ -> do
- html5ify ls
+ html5ify ps
" "::HTML5
"["::HTML5
- H.span ! HA.class_ "reference reference-ambiguous"
- !?? mayAttr HA.id (attrify . identifyReference "-ambiguous" rref_to . Just <$> num) $$
+ H.span ! HA.class_ "reference reference-ambiguous" $$
html5ify rref_to
"]"
instance Html5ify [Title] where
html5ify About{..} = do
html5Lines
[ html5CommasDot $ concat $
- [ html5Titles titles
- , html5ify <$> authors
- , html5ify <$> maybeToList date
- , html5ify <$> maybeToList editor
- , html5ify <$> series
+ [ html5Titles about_titles
+ , html5ify <$> about_authors
+ , html5ify <$> maybeToList about_date
+ , html5ify <$> maybeToList about_editor
+ , html5ify <$> about_series
]
- , forM_ url $ \u ->
+ , forM_ about_url $ \u ->
H.span ! HA.class_ "print-only" $$ do
"<"::HTML5
html5ify u
sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
html5Title (Title title) =
html5ify $ Tree PlainQ $
- case url of
+ case about_url of
Nothing -> title
Just u -> pure $ Tree (PlainEref u) title
instance Html5ify Serie where
html5ify s@Serie{id=id_, name} = do
- Loqualization l10n <- liftComposeState $ S.gets state_l10n
+ Loqualization l10n <- composeLift $ RWS.asks reader_l10n
case urlSerie s of
Nothing -> do
html5ify name
html5ify = html5ify . Index.plainifyWords
instance Html5ify Alias where
html5ify Alias{..} = do
- st@State{state_collect=Collect.All{..}} <- liftComposeState S.get
- let l10n = Plain.state_l10n $ state_plainify st
+ ro@Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask
+ let l10n = Plain.reader_l10n $ reader_plainify ro
case toList <$> HM.lookup title all_section of
Just [_] ->
H.a ! HA.class_ "alias"
html5ify url
instance Html5ify Date where
html5ify date = do
- Loqualization l10n <- liftComposeState $ S.gets state_l10n
+ Loqualization l10n <- composeLift $ RWS.asks reader_l10n
Plain.l10n_Date date l10n
instance Html5ify Reference where
- html5ify Reference{..} =
+ html5ify Reference{..} = do
+ Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask
+ State{state_errors=errs@Analyze.Errors{..}, ..} <- composeLift RWS.get
H.tr $$ do
- H.td ! HA.class_ "reference-key" $$
- html5ify $ tree0 PlainRref
- { 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-key" $$ do
+ "["::HTML5
+ case HM.lookup reference_id errors_reference_ambiguous of
+ Nothing ->
+ H.a ! HA.class_ "reference"
+ ! HA.href (refIdent $ identifyReference "" reference_id Nothing)
+ ! HA.id (attrify $ identifyReference "" reference_id Nothing) $$
+ html5ify reference_id
+ Just num -> do
+ composeLift $ RWS.modify $ \s -> s
+ { state_errors = errs
+ { Analyze.errors_reference_ambiguous =
+ HM.insert reference_id (succNat1 num) errors_reference_ambiguous } }
+ H.span ! HA.class_ "reference reference-ambiguous"
+ ! HA.id (attrify $ identifyReference "-ambiguous" reference_id $ Just num) $$
+ html5ify reference_id
+ "]"
H.td ! HA.class_ "reference-content" $$ do
html5ify reference_about
- rrefs <- liftComposeState $ S.gets state_rrefs
- case HM.lookup reference_id rrefs of
+ case HM.lookup reference_id all_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 "" reference_id $ Just num) $$
- case maySection of
- Nothing -> "0"::HTML5
- Just Section{section_posXML=posSection} -> html5ify $ XML.pos_ancestors posSection
+ when (isNothing $ HM.lookup reference_id errors_reference_ambiguous) $
+ H.span ! HA.class_ "reference-rrefs" $$
+ html5CommasDot $
+ (<$> List.zip (toList anchs) [1..]) $ \((_loc, maySection),num) ->
+ H.a ! HA.class_ "reference-rref"
+ ! HA.href (refIdent $ identifyReference "" reference_id $ Just $ Nat1 num) $$
+ case maySection of
+ Left{} -> "0"::HTML5
+ Right Section{section_posXML=posSection} ->
+ html5ify $ XML.pos_ancestors posSection
instance Html5ify XML.Ancestors where
html5ify ancs =
case toList ancs of
Text.pack . show . snd <$> as
instance Html5ify Plain.Plain where
html5ify p = do
- sp <- liftComposeState $ S.gets state_plainify
- let (t,sp') = Plain.runPlain p sp
- html5ify t
- liftComposeState $ S.modify $ \s -> s{state_plainify=sp'}
+ rp <- composeLift $ RWS.asks reader_plainify
+ html5ify $ Plain.runPlain p rp
{-
instance Html5ify SVG.Element where
html5ify svg =
H.a ! HA.href (refIdent $ identify as) $$
html5ify as
-html5Notes :: IntMap [Para] -> HTML5
-html5Notes notes =
- H.aside ! HA.class_ "notes" $$ do
- Compose $ pure H.hr
- H.table $$
- H.tbody $$
- forM_ (IntMap.toList notes) $ \(number,content) ->
- H.tr $$ do
- H.td ! HA.class_ "note-ref" $$ do
- H.a ! HA.class_ "note-number"
- ! HA.id ("note."<>attrify number)
- ! HA.href ("#note."<>attrify number) $$ do
- html5ify number
- ". "::HTML5
- H.a ! HA.href ("#note-ref."<>attrify number) $$ do
- "↑"
- H.td $$
- html5ify content
+popNotes :: ComposeRWS Reader Writer State H.MarkupM (Seq [Para])
+popNotes = do
+ st <- composeLift RWS.get
+ case {-debug "state_notes" $-} state_notes st of
+ [] -> return mempty
+ curr:next -> do
+ composeLift $ RWS.modify $ \s -> s{state_notes=next}
+ return curr
+
+html5Notes :: Seq [Para] -> HTML5
+html5Notes notes = do
+ unless (null notes) $ do
+ H.aside ! HA.class_ "notes" $$ do
+ Compose $ pure H.hr
+ H.table $$
+ H.tbody $$
+ forM_ notes $ \content -> do
+ num <- composeLift $ do
+ n <- RWS.gets state_note_num_content
+ RWS.modify $ \s -> s{state_note_num_content=succNat1 n}
+ return n
+ H.tr $$ do
+ H.td ! HA.class_ "note-ref" $$ do
+ H.a ! HA.class_ "note-number"
+ ! HA.id ("note."<>attrify num)
+ ! HA.href ("#note."<>attrify num) $$ do
+ html5ify num
+ ". "::HTML5
+ H.a ! HA.href ("#note-ref."<>attrify num) $$ do
+ "↑"
+ H.td $$
+ html5ify content
html5ifyToC :: Maybe DTC.Nat -> Tree BodyNode -> HTML5
html5ifyToC depth (Tree b bs) =
html5ifyToF :: [TL.Text] -> HTML5
html5ifyToF types = do
- figuresByType <- liftComposeState $ S.gets $ Collect.all_figure . state_collect
+ figuresByType <- composeLift $ RWS.asks $ Analyze.all_figure . reader_all
let figures =
- Map.foldMapWithKey (\ty -> ((ty,) <$>)) $
+ Map.unions $
+ ((\(ty,ts) -> (ty,) <$> ts) <$>) $
+ HM.toList $
if null types
then figuresByType
else
- Map.intersection figuresByType $
- Map.fromList [(ty,()) | ty <- types]
+ HM.intersection figuresByType $
+ HM.fromList [(ty,()) | ty <- types]
forM_ (Map.toList figures) $ \(posXML, (type_, title)) ->
H.tr $$ do
H.td ! HA.class_ "figure-number" $$
-- 'Attrify'
instance Attrify Plain.Plain where
- attrify p = attrify t
- where (t,_) = Plain.runPlain p def
+ attrify p = attrify $ Plain.runPlain p def
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hdoc.DTC.Write.HTML5.Base where
+-- import qualified Control.Monad.Trans.State.Strict as S
import Control.Monad (Monad(..))
+import Data.Bool
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 ((<$>), (<$))
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.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
+import Data.Sequence (Seq)
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 Control.Monad.Trans.RWS.Strict as RWS
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 Majority.Judgment 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 qualified Hdoc.DTC.Check as Check
+-- import qualified Hdoc.DTC.Collect as Collect
+-- import qualified Hdoc.DTC.Index as Index
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 Hdoc.DTC.Document as DTC
+import Hdoc.DTC.Write.XML ()
+import Hdoc.TCT.Cell as TCT
+import qualified Hdoc.DTC.Analyze.Check as Analyze
+import qualified Hdoc.DTC.Analyze.Collect as Analyze
+import qualified Hdoc.DTC.Analyze.Index as Analyze
import qualified Hdoc.DTC.Write.Plain as Plain
import qualified Hdoc.XML as XML
+import qualified Text.Blaze.Internal as B
-- * Type 'HTML5'
-type HTML5 = ComposeState State B.MarkupM ()
+type HTML5 = ComposeRWS Reader Writer State B.MarkupM ()
instance IsString HTML5 where
fromString = html5ify
instance Default Config where
def = Config
{ config_css = Right "style/dtc-html5.css"
- , config_js = Right "style/dtc-html5.js"
+ , config_js = Right "" -- "style/dtc-html5.js"
, config_locale = LocaleIn @'[EN] en_US
, config_generator = "https://hackage.haskell.org/package/hdoc"
}
+-- ** Type 'Reader'
+data Reader = Reader
+ { reader_l10n :: Loqualization (L10n HTML5)
+ , reader_plainify :: Plain.Reader
+ , reader_italic :: Bool
+ , reader_all :: Analyze.All
+ , reader_section :: TreeSeq.Trees BodyNode
+ }
+instance Default Reader where
+ def = Reader
+ { reader_l10n = Loqualization EN_US
+ , reader_plainify = def
+ , reader_italic = False
+ , reader_all = def
+ , reader_section = def
+ }
+
+-- ** Type 'Writer'
+data Writer = Writer
+ { writer_scripts :: HS.HashSet FilePath
+ , writer_styles :: HS.HashSet (Either FilePath TL.Text)
+ }
+instance Default Writer where
+ def = Writer
+ { writer_scripts = def
+ , writer_styles = def
+ }
+instance Semigroup Writer where
+ x <> y = Writer
+ { writer_scripts = HS.union (writer_scripts x) (writer_scripts y)
+ , writer_styles = HS.union (writer_styles x) (writer_styles y)
+ }
+instance Monoid Writer where
+ mempty = def
+ mappend = (<>)
+
-- ** Type 'State'
data State = State
+ { state_section :: TreeSeq.Trees BodyNode
+ , state_errors :: Analyze.Errors Nat1
+ , state_rrefs :: HM.HashMap Ident Nat1
+ , state_notes :: [Seq [Para]]
+ , state_note_num_ref :: Nat1
+ , state_note_num_content :: Nat1
+ , state_judgments :: HS.HashSet Judgment
+ , state_opinions :: HM.HashMap Judgment [MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade)]
+ }deriving (Show)
+ {-
-- 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)]
+ -- , state_notes :: Check.NotesBySection
-- 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)
+ -- , state_indexs :: Map XML.Pos (Terms, Index.Irefs) -- TODO: could be a list
}
+ -}
instance Default State where
+ def = State
+ { state_section = def
+ , state_errors = def
+ , state_rrefs = def
+ , state_notes = def
+ , state_note_num_ref = def
+ , state_note_num_content = def
+ , state_judgments = HS.empty
+ , state_opinions = def
+ }
+ {-
def = State
{ state_styles = HS.fromList [Left "dtc-html5.css"]
, state_scripts = def
- , state_section = def
, state_collect = def
- , state_indexs = def
+ -- , state_indexs = def
, state_rrefs = def
- , state_notes = 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
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
+ depth <- composeLift $ RWS.asks $ Plain.reader_quote . reader_plainify
let (o,c) :: (HTML5, HTML5) =
case unNat depth `mod` 3 of
0 -> ("“","”")
1 -> ("« "," »")
_ -> ("‟","„")
o
- setDepth $ succNat depth
- msg
- setDepth $ depth
+ localComposeRWS (\ro -> ro
+ {reader_plainify = (reader_plainify ro)
+ {Plain.reader_quote = succNat depth}}) $
+ msg
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
+ depth <- composeLift $ RWS.asks $ Plain.reader_quote . reader_plainify
let (o,c) :: (HTML5, HTML5) =
case unNat depth `mod` 3 of
0 -> ("« "," »")
1 -> ("“","”")
_ -> ("‟","„")
o
- setDepth $ succNat depth
- msg
- setDepth $ depth
+ localComposeRWS (\ro -> ro
+ {reader_plainify = (reader_plainify ro)
+ {Plain.reader_quote = succNat depth}}) $
+ msg
c
- where
- setDepth d =
- liftComposeState $ S.modify' $ \s ->
- s{state_plainify=(state_plainify s){Plain.state_quote=d}}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
import Control.Applicative (Applicative(..))
import Control.Monad (forM_, mapM_)
+import Data.Default.Class (Default(..))
import Data.Either (Either(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Tuple (fst, snd)
import Text.Blaze ((!))
import Text.Show (Show(..))
-import qualified Control.Monad.Trans.State as S
+import qualified Control.Monad.Trans.RWS.Strict as RWS
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.List as List
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.Analyze.Check as Analyze
+import qualified Hdoc.DTC.Analyze.Collect as Analyze
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)
+instance (Html5ify Plain, Html5ify TCT.Location) => Html5ify (Analyze.Errors (Seq Location)) where
+ html5ify Analyze.Errors{..} = do
+ st@Reader
+ { reader_all = Analyze.All{..}
+ , reader_l10n = Loqualization (l10n::FullLocale lang)
, ..
- } <- liftComposeState S.get
+ } <- composeLift RWS.ask
let errors :: [ ( Int{-errKind-}
, HTML5{-errKindDescr-}
, [(Plain{-errTypeKey-}, [(TCT.Location{-errPos-}, Ident{-errId-})])]
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 $
+ composeLift $ RWS.tell def
+ { writer_styles = HS.fromList
+ [ Left "dtc-errors.css"
+ , Right $
-- NOTE: Implement a CSS-powered show/hide logic, using :target
"\n@media screen {" <>
"\n\t.error-filter:target .errors-list > li {display:none;}" <>
<>" {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.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
+ errorTag :: Reader -> Ident -> HM.HashMap Title (Seq (TCT.Location, XML.Pos)) -> [(Plain, [(TCT.Location,Ident)])]
+ errorTag Reader{reader_plainify=Plain.Reader{reader_l10n}} suffix errs =
+ (<$> HM.toList errs) $ \(tag, errPositions) ->
+ ( unTitle tag
, List.zipWith
- (\num -> (,identifyTag suffix state_l10n tag (Just $ Nat1 num)))
+ (\num (locTCT, _posXML) -> (locTCT, identifyTag suffix reader_l10n tag (Just $ Nat1 num)))
[1::Int ..] (toList errPositions)
)
- errorReference :: Ident -> HM.HashMap Ident (Seq TCT.Location) -> [(Plain, [(TCT.Location,Ident)])]
+ errorReference :: Ident -> HM.HashMap Ident (Seq (TCT.Location, XML.Pos)) -> [(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)))
+ (\num (locTCT, _posXML) -> (locTCT, identifyReference suffix id (Just $ Nat1 num)))
[1::Int ..] (toList errPositions)
)
errorIdent :: HM.HashMap Ident (Seq (TCT.Location, XML.Pos)) -> [(Plain, [(TCT.Location,Ident)])]
import Hdoc.Utils ()
import Hdoc.DTC.Document as DTC
-import qualified Hdoc.DTC.Index as Index
+import Hdoc.DTC.Analyze.Index (plainifyWords)
import qualified Hdoc.DTC.Write.Plain as Plain
import qualified Hdoc.XML as XML
identifyIref :: Words -> Ident
identifyIref term =
"iref"
- <> "." <> identify (Index.plainifyWords term)
+ <> "." <> identify (plainifyWords term)
identifyIrefCount :: Words -> Nat1 -> Ident
identifyIrefCount term count =
"iref"
- <> "." <> identify (Index.plainifyWords term)
+ <> "." <> identify (plainifyWords term)
<> "." <> identify count
-identifyTag :: Ident -> Loqualization (Plain.L10n Plain.Plain) -> Plain -> Maybe Nat1 -> Ident
-identifyTag suffix state_l10n to count =
+identifyTag :: Ident -> Loqualization (Plain.L10n Plain.Plain) -> Title -> Maybe Nat1 -> Ident
+identifyTag suffix state_l10n tag count =
"tag" <> suffix
- <> "." <> identifyPlain state_l10n to
+ <> "." <> identifyTitle state_l10n tag
<> maybe "" (("."<>) . identify) count
identifyReference :: Ident -> Ident -> Maybe Nat1 -> Ident
Tree n ts -> return $ Tree n $ cleanPlain ts
identifyPlain :: Loqualization (Plain.L10n Plain.Plain) -> Plain -> Ident
-identifyPlain state_l10n =
+identifyPlain reader_l10n =
escapeIdent .
- Plain.text def{Plain.state_l10n}
+ Plain.text def{Plain.reader_l10n}
identifyTitle :: Loqualization (Plain.L10n Plain.Plain) -> Title -> Ident
identifyTitle state_l10n = identifyPlain state_l10n . unTitle
import Prelude ((*), Fractional(..), Double, toRational, RealFrac(..))
import Text.Blaze ((!))
import Text.Show (Show(..))
-import qualified Control.Monad.Trans.State as S
+import qualified Control.Monad.Trans.RWS.Strict as RWS
import qualified Data.Char as Char
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
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 Majority.Judgment as MJ
import qualified Prelude (error)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
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.Analyze.Collect as Analyze
import qualified Hdoc.DTC.Write.Plain as Plain
-- <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 }
+ composeLift $ RWS.tell def
+ { writer_styles = HS.singleton $ Left "dtc-judgment.css" }
H.div ! HA.id (attrify $ identify $ XML.pos_ancestors judgment_posXML) $$ do
let commentJGC = HM.fromList
[ (choice_, HM.fromListWith (<>)
! HA.id (attrify $ identify $ XML.pos_ancestors choice_posXML) $$ do
html5ify choice_title
H.dd ! HA.class_ "choice-merit" $$ do
+ let merit = meritC HM.!choice_
let distByJudge = distByJudgeByChoice HM.!choice_
let numJudges = HM.size distByJudge
- html5MeritHistogram majorityValue numJudges
- let grades = Map.keys $ MJ.unMerit $ meritC HM.!choice_
+ html5MeritHistogram merit numJudges
+ let grades = Map.keys $ MJ.unMerit $ merit
let commentJG = HM.lookup choice_ commentJGC
html5MeritComments distByJudge grades commentJG
instance Html5ify Judges where
Maybe (HM.HashMap Name (HM.HashMap Name (Maybe Title))) ->
HTML5
html5MeritComments distJ grades commentJG = do
- Loqualization l10n <- liftComposeState $ S.gets state_l10n
+ Loqualization l10n <- composeLift $ RWS.asks reader_l10n
H.ul ! HA.class_ "merit-comments" $$ do
forM_ grades $ \case
grade | DTC.Grade{..} <- MJ.unRank grade -> do
html5MeritHistogram ::
Html5ify Title =>
- MJ.MajorityValue (MJ.Ranked Grade) -> Int -> HTML5
-html5MeritHistogram (MJ.MajorityValue majVal) numJudges = do
+ MJ.Merit (MJ.Ranked Grade) -> Int -> HTML5
+html5MeritHistogram (MJ.Merit merit) numJudges = do
H.div ! HA.class_ "merit-histogram" $$ do
- forM_ majVal $ \case
- (grade, count) | DTC.Grade{..} <- MJ.unRank grade -> do
+ forM_ (Map.toList merit) $ \case
+ (grade, share) | DTC.Grade{..} <- MJ.unRank grade -> do
let percent :: Double =
fromRational $ (toRational $ (ceiling::Double -> Int) $ fromRational $
- (count / toRational numJudges) * 100 * 1000) / 1000
+ (share / 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 ""
html5Judgments :: HTML5
html5Judgments = do
- Collect.All{..} <- liftComposeState $ S.gets state_collect
+ Analyze.All{..} <- composeLift $ RWS.asks reader_all
opinionsByChoiceByNodeBySectionByJudgment <-
- forM (HM.toList all_judgments) $ \(judgment@Judgment{..}, choicesBySection) -> do
+ forM (HM.toList all_judgment) $ \(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
+ listToMaybe $ toList $
+ HM.lookupDefault def judgment_gradesId all_grades
let Judges{..} =
fromMaybe (Prelude.error $ show judgment_judges) $ -- unknown judges
- HM.lookup judgment_judgesId all_judges
+ listToMaybe $ toList $
+ HM.lookupDefault def judgment_judgesId all_judges
let defaultGradeByJudge =
let defaultGrade =
List.head
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:
+ -- this will match perfectly with the 'html5ify' traversal:
-- 'BodySection' by 'BodySection'.
return (judgment, join $ toList <$> opinionsByChoiceByNodeBySection)
- liftComposeState $ S.modify' $ \st ->
+ composeLift $ RWS.modify $ \st ->
st{state_opinions = HM.fromList opinionsByChoiceByNodeBySectionByJudgment}
import Control.Applicative (Applicative(..), liftA2)
import Control.Category
import Control.Monad
-import Data.Bool
import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..), concat)
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Data.TreeSeq.Strict (Tree(..))
-import Data.Tuple (fst, snd)
+import Data.Tuple (snd)
import Data.String (String, IsString(..))
import Prelude (mod)
import Text.Show (Show(..))
-import qualified Control.Monad.Trans.State as S
+import qualified Control.Monad.Trans.Reader as R
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Hdoc.XML as XML
-- * Type 'Plain'
-type Plain = S.State State TLB.Builder
+type Plain = R.Reader Reader TLB.Builder
-runPlain :: Plain -> State -> (TL.Text, State)
-runPlain p s =
- let (b,s') = S.runState p s in
- (TLB.toLazyText b, s')
+runPlain :: Plain -> Reader -> TL.Text
+runPlain p ro = TLB.toLazyText $ R.runReader p ro
-text :: Plainify a => State -> a -> TL.Text
-text st a = fst $ runPlain (plainify a) st
+text :: Plainify a => Reader -> a -> TL.Text
+text ro a = runPlain (plainify a) ro
instance IsString Plain where
fromString = return . fromString
mempty = return ""
mappend = (<>)
--- ** Type 'State'
-data State = State -- TODO: could be a Reader
- { state_l10n :: Loqualization (L10n Plain)
- , state_italic :: Bool
- , state_quote :: Nat
+-- ** Type 'Reader'
+data Reader = Reader -- TODO: could be a Reader
+ { reader_l10n :: Loqualization (L10n Plain)
+ , reader_quote :: Nat
}
-instance Default State where
- def = State
- { state_l10n = Loqualization EN_US
- , state_italic = False
- , state_quote = Nat 0
+instance Default Reader where
+ def = Reader
+ { reader_l10n = Loqualization EN_US
+ , reader_quote = Nat 0
}
-- * Class 'Plainify'
PlainCode -> "`"<>plainify ls<>"`"
PlainDel -> "-"<>plainify ls<>"-"
PlainI -> "/"<>plainify ls<>"/"
- PlainNote{..} -> "" -- TODO: to be coded, with a switch on/off in State
+ PlainNote{..} -> "" -- TODO: to be coded, with a switch on/off in Reader
PlainQ -> do
- State{state_l10n=Loqualization loc} <- S.get
+ Reader{reader_l10n=Loqualization loc} <- R.ask
l10n_Quote (plainify ls) loc
PlainSC -> plainify ls
PlainSpan{..} -> plainify ls
l10n_Colon loc = plainify (l10n_Colon loc::TL.Text)
l10n_Table_of_Contents loc = plainify (l10n_Table_of_Contents loc::TL.Text)
l10n_Quote msg _loc = do
- depth <- S.gets state_quote
+ depth <- R.asks reader_quote
let (o,c) =
case unNat depth `mod` 3 of
0 -> ("« "," »")
1 -> ("“","”")
_ -> ("‟","„")
- S.modify' $ \s -> s{state_quote=succNat depth}
- m <- msg
- S.modify' $ \s -> s{state_quote=depth}
+ m <- R.local (\ro -> ro{reader_quote=succNat depth}) msg
return $ o <> m <> c
l10n_Date date loc = plainify (l10n_Date date loc::TL.Text)
instance L10n Plain EN where
l10n_Colon loc = plainify (l10n_Colon loc::TL.Text)
l10n_Table_of_Contents loc = plainify (l10n_Table_of_Contents loc::TL.Text)
l10n_Quote msg _loc = do
- depth <- S.gets state_quote
+ depth <- R.asks reader_quote
let (o,c) =
case unNat depth `mod` 3 of
0 -> ("“","”")
1 -> ("« "," »")
_ -> ("‟","„")
- S.modify' $ \s -> s{state_quote=succNat depth}
- m <- msg
- S.modify' $ \s -> s{state_quote=depth}
+ m <- R.local (\s -> s{reader_quote=succNat depth}) msg
return $ o <> m <> c
l10n_Date date loc = plainify (l10n_Date date loc::TL.Text)
import qualified Text.Blaze.Internal as B
import Data.Locale
-import Hdoc.DTC.Index (plainifyWords)
+import Hdoc.DTC.Analyze.Index (plainifyWords)
import Hdoc.DTC.Document as DTC
writeXML :: Locales ls => LocaleIn ls -> Document -> XML
xmlify = B.toMarkup
instance Xmlify Head where
xmlify Head{..} =
- xmlify about
+ xmlify head_about
instance Xmlify (Tree BodyNode) where
xmlify (Tree n ts) =
case n of
instance Xmlify About where
xmlify About{..} = do
XML.about
- !?? mayAttr XA.url url
+ !?? mayAttr XA.url about_url
$ do
- xmlify titles
- xmlify authors
- xmlify editor
- xmlify date
- forM_ tags $ XML.tag . xmlify
- xmlify links
- xmlify includes
+ xmlify about_titles
+ xmlify about_authors
+ xmlify about_editor
+ xmlify about_date
+ forM_ about_tags $ XML.tag . xmlify
+ xmlify about_links
+ xmlify about_includes
instance Xmlify Include where
xmlify Include{..} =
XML.include True
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Hdoc.TCT.Write.HTML5 where
-import Control.Monad (Monad(..), forM_, mapM_)
+import Control.Monad (Monad(..), forM_, mapM_, join)
import Data.Bool
import Data.Char (Char)
import Data.Default.Class (Default(..))
import Text.Blaze ((!))
import Text.Blaze.Html (Html)
import Text.Show (Show(..))
-import qualified Control.Monad.Trans.State as S
+import qualified Control.Monad.Trans.RWS.Strict as RWS
import qualified Data.List as List
import qualified Data.Sequence as Seq
import qualified Data.Text.Lazy as TL
H.link ! HA.rel "stylesheet"
! HA.type_ "text/css"
! HA.href "style/tct-html5.css"
- let (html5Body, State{}) =
- runComposeState def $
+ let (html5Body, State{}, ()) =
+ runComposeRWS def def $
html5ify body
H.body $ do
H.a ! HA.id "line-1" $ return ()
_ -> Nothing
-- * Type 'Html5'
-type Html5 = ComposeState State Blaze.MarkupM ()
+type Html5 = ComposeRWS Reader Writer State Blaze.MarkupM ()
instance IsString Html5 where
fromString = mapM_ html5ify
html5 :: H.ToMarkup a => a -> Html5
html5 = Compose . return . H.toMarkup
+-- ** Type 'Reader'
+data Reader = Reader
+ { reader_indent :: Html5
+ , reader_italic :: Bool
+ , reader_ext_html :: String
+ } -- deriving (Eq, Show)
+instance Default Reader where
+ def = Reader
+ { reader_indent = ""
+ , reader_italic = False
+ , reader_ext_html = ".html"
+ }
+
+-- ** Type 'Writer'
+type Writer = ()
+
-- ** Type 'State'
-data State
- = State
- { state_pos :: Pos
- , state_indent :: Html5
- , state_italic :: Bool
- , state_ext_html :: String
+newtype State = State
+ { state_pos :: Pos
} -- deriving (Eq, Show)
instance Default State where
def = State
- { state_pos = pos1
- , state_indent = ""
- , state_italic = False
- , state_ext_html = ".html"
+ { state_pos = pos1
}
--- instance Pretty State
-- * Class 'Html5ify'
class Html5ify a where
instance Html5ify Char where
html5ify = \case
'\n' -> do
- s@State{state_pos=Pos line _col, ..} <- liftComposeState S.get
- liftComposeState $ S.put s{state_pos=Pos (line + 1) 1}
+ st@State{state_pos=Pos line _col, ..} <- composeLift RWS.get
+ composeLift $ RWS.put st{state_pos=Pos (line + 1) 1}
html5 '\n'
H.a ! HA.id ("line-"<>attrify (line + 1)) $$ return ()
- state_indent
+ join $ composeLift $ RWS.asks reader_indent
c -> do
- liftComposeState $ S.modify' $ \s@State{state_pos=Pos line col} ->
+ composeLift $ RWS.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
- liftComposeState $ S.modify' $ \s@State{state_pos=Pos line col} ->
+ composeLift $ RWS.modify $ \s@State{state_pos=Pos line col} ->
s{state_pos=Pos line $ col + int (TL.length h)}
html5 h
Just (_n,ts') -> do
html5ify ts'
instance Html5ify Pos where
html5ify new@(Pos lineNew colNew) = do
- s@State
- { state_pos=old@(Pos lineOld colOld)
- , state_indent
- } <- liftComposeState S.get
+ Reader{reader_indent} <- composeLift RWS.ask
+ st@State{state_pos=old@(Pos lineOld colOld)} <- composeLift RWS.get
case lineOld`compare`lineNew of
LT -> do
forM_ [lineOld+1..lineNew] $ \lnum -> do
html5 '\n'
H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
- liftComposeState $ S.put s{state_pos=Pos lineNew 1}
- state_indent
- Pos _lineMid colMid <- liftComposeState $ S.gets state_pos
+ composeLift $ RWS.put st{state_pos=Pos lineNew 1}
+ reader_indent
+ Pos _lineMid colMid <- composeLift $ RWS.gets state_pos
html5 $ List.replicate (colNew - colMid) ' '
- liftComposeState $ S.put s{state_pos=new}
+ composeLift $ RWS.put st{state_pos=new}
EQ | colOld <= colNew -> do
- liftComposeState $ S.put s{state_pos=new}
+ composeLift $ RWS.put st{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 <- liftComposeState $ S.gets state_ext_html
+ ext <- composeLift $ RWS.asks reader_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} <- liftComposeState S.get
- liftComposeState $ S.modify' $ \s ->
- s{ state_indent = do
- state_indent
- Pos _lineMid colMid <- liftComposeState $ S.gets state_pos
+ localComposeRWS (\ro ->
+ ro{ reader_indent = do
+ reader_indent ro
+ Pos _lineMid colMid <- composeLift $ RWS.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
- liftComposeState $ S.modify' $ \s -> s{state_indent}
- return r
+ }) $
+ html5Header markBegin whmb name whn markEnd whme cl
----------------------
NodeText t -> do
- State{state_indent} <- liftComposeState S.get
- liftComposeState $ S.modify' $ \s ->
- s{ state_indent = do
- state_indent
- Pos _lineMid colMid <- liftComposeState $ S.gets state_pos
+ localComposeRWS (\ro ->
+ ro{ reader_indent = do
+ reader_indent ro
+ Pos _lineMid colMid <- composeLift $ RWS.gets state_pos
html5ify $ List.replicate (pos_column bp - colMid) ' '
- }
- r <- html5ify t
- liftComposeState $ S.modify' $ \s -> s{state_indent}
- return r
+ }) $
+ html5ify t
----------------------
NodePara -> do
- State{state_indent} <- liftComposeState S.get
- liftComposeState $ S.modify' $ \s ->
- s{ state_indent = do
- state_indent
- Pos _lineMid colMid <- liftComposeState $ S.gets state_pos
+ localComposeRWS (\ro ->
+ ro{ reader_indent = do
+ reader_indent ro
+ Pos _lineMid colMid <- composeLift $ RWS.gets state_pos
html5ify $ List.replicate (pos_column bp - colMid) ' '
- }
- r <- html5ify ts
- liftComposeState $ S.modify' $ \s -> s{state_indent}
- return r
+ }) $
+ html5ify ts
----------------------
NodeToken t -> html5ify t <> html5ify ts
----------------------
p | p == PairSlash
|| p == PairFrenchquote
|| p == PairDoublequote -> do
- 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
- liftComposeState $ S.modify' $ \s -> s{state_italic}
- return r
+ Reader{reader_italic} <- composeLift RWS.ask
+ localComposeRWS (\ro -> ro{reader_italic = not reader_italic}) $
+ H.em ! HA.class_ (if reader_italic then "even" else "odd") $$ h
_ -> h
instance Html5ify Token where
html5ify tok =
import Data.Functor ((<$>))
import Data.Hashable (Hashable(..))
import Data.Int (Int)
+import Data.NonNull (NonNull(..), toNullable)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
def = def:|[]
instance Hashable a => Hashable (Seq a) where
hashWithSalt s = hashWithSalt s . toList
+instance Hashable a => Hashable (NonNull a) where
+ hashWithSalt s = hashWithSalt s . toNullable
instance Default (HM.HashMap k a) where
def = HM.empty
instance Default (HS.HashSet a) where
B.Append ma <$> getCompose csmb
_ -> undefined -- NOTE: impossible case, by definition of (>>=) on 'B.MarkupM'.
+-- * Type 'ComposeRWS'
+instance Monoid w => Semigroup (ComposeRWS r w s B.MarkupM a) where
+ (<>) = (>>)
+instance Monoid w => Monoid (ComposeRWS r w s B.MarkupM ()) where
+ mempty = pure ()
+ mappend = (<>)
+instance Monoid w => Monad (ComposeRWS r w s B.MarkupM) where
+ return = pure
+ Compose sma >>= a2csmb =
+ Compose $ sma >>= \ma ->
+ case ma >>= B.Empty . a2csmb of
+ B.Append _ma (B.Empty csmb) ->
+ B.Append ma <$> getCompose csmb
+ _ -> undefined -- NOTE: impossible case, by definition of (>>=) on 'B.MarkupM'.
+
-- | Render some 'Markup' to a 'Builder'.
--
-- An 'IndentTag' is queried on each tag
style/dtc-errors.css
style/dtc-errors.js
style/dtc-html5.css
+ style/dtc-html5.js
style/dtc-index.css
style/dtc-judgment.css
style/dtc-table.css
Library
exposed-modules:
Control.Monad.Utils
- Hdoc.DTC.Check.Base
- Hdoc.DTC.Check.Judgment
- Hdoc.DTC.Check
- Hdoc.DTC.Collect
+ Hdoc.DTC.Analyze.Collect
+ Hdoc.DTC.Analyze.Index
+ Hdoc.DTC.Analyze.Check
Hdoc.DTC.Document
- Hdoc.DTC.Index
Hdoc.DTC.Read.TCT
Hdoc.DTC.Sym
Hdoc.DTC.Write.HTML5.Ident
, localization >= 1.0.1
, symantic-cli >= 0.0.0
, megaparsec >= 6.3
- -- , mono-traversable >= 1.0
+ , mono-traversable >= 1.0
, strict >= 0.3
-- , svg-builder >= 0.1
, text >= 1.2
-resolver: lts-10.5
+resolver: lts-12.8
packages:
- '.'
-- location: '../treemap'
+- location: '../haskell-treemap'
extra-dep: true
-- location: '../treeseq'
+- location: '../haskell-treeseq'
extra-dep: true
-- location: '../localization'
+- location: '../haskell-localization'
extra-dep: true
-- location: '../symantic-cli'
+- location: '../haskell-symantic/symantic-cli'
extra-dep: true
-- location: '../symantic-document'
+- location: '../haskell-symantic/symantic-document'
extra-dep: true
- location: '../hjugement'
extra-dep: true
extra-deps:
- monad-classes-0.3.2.2
-- peano-0.1.0.1
.errors-list a:active {
color:blue;
background-color:inherit !important;
+ display:block;
}
.errors-list a:hover {
color:black !important;
display:inline-box;
text-decoration-line:underline;
text-decoration-color:#C4451D;
- text-decoration-style:wavy;
+ text-decoration-style:solid;
}
.tag-ambiguous {
display:inline-box;
text-decoration-line:underline overline;
text-decoration-color:#C4451D;
- text-decoration-style:wavy;
+ text-decoration-style:double;
}
/* .rref */
.reference {
sourcephile / git / doclang.git / commitdiff