Hdoc/DTC/Collect.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 module Hdoc.DTC.Collect where
   4 import Control.Applicative (Applicative(..))
   5 import Control.Monad
   6 import Data.Bool
   7 import Data.Default.Class (Default(..))
   8 import Data.Either (Either(..))
   9 import Data.Foldable (Foldable(..), any)
  10 import Data.Function (($))
  11 import Data.Functor ((<$>), (<$))
  12 import Data.Map.Strict (Map)
  13 import Data.Maybe (Maybe(..), fromMaybe)
  14 import Data.Monoid (Monoid(..))
  15 import Data.Sequence (Seq)
  16 import Data.Semigroup (Semigroup(..))
  17 import Data.TreeSeq.Strict (Tree(..))
  18 import Text.Show (Show(..))
  19 import qualified Data.HashMap.Strict as HM
  20 import qualified Data.Map.Strict as Map
  21 import qualified Data.Sequence as Seq
  22 import qualified Data.Text.Lazy as TL
  23 import qualified Data.TreeSeq.Strict as TreeSeq
  24 import qualified Hjugement as MJ
  25 import qualified Data.Tree as Tree
  26
  27 -- import Hdoc.Utils ()
  28 import Hdoc.DTC.Document as DTC
  29
  30 -- * Type 'All'
  31 -- | Collect 'Block's by mapping them by their 'XmlPos' or 'Ident'.
  32 data All = All
  33  { all_index     :: Map XmlPos Terms
  34  , all_figure    :: Map TL.Text (Map XmlPos (Maybe Title))
  35  , all_reference :: HM.HashMap Ident (Seq Reference)
  36  , all_section   :: HM.HashMap Title (Seq (Either Head Section))
  37  , all_judges    :: HM.HashMap Ident [Judge]
  38  , all_grades    :: HM.HashMap Ident [Grade]
  39  , all_judgments :: HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])]
  40  } deriving (Show)
  41 instance Default All where
  42         def = All
  43          { all_index     = def
  44          , all_figure    = def
  45          , all_section   = def
  46          , all_reference = def
  47          , all_judges    = def
  48          , all_grades    = def
  49          , all_judgments = def
  50          }
  51 instance Semigroup All where
  52         x<>y = All
  53          { all_index     = Map.union (all_index x) (all_index y)
  54          , all_figure    = Map.unionWith (<>) (all_figure x) (all_figure y)
  55          , all_section   = HM.unionWith (<>) (all_section x) (all_section y)
  56          , all_reference = HM.unionWith (<>) (all_reference x) (all_reference y)
  57          , all_judges    = HM.union (all_judges x) (all_judges y)
  58          , all_grades    = HM.union (all_grades x) (all_grades y)
  59          , all_judgments = HM.unionWith (<>) (all_judgments x) (all_judgments y)
  60          }
  61 instance Monoid All where
  62         mempty  = def
  63         mappend = (<>)
  64
  65 -- * Class 'Collect'
  66 class Collect a where
  67         collect :: a -> All
  68 instance Collect Document where
  69         collect Document{head=head@Head{about=About{titles}, judgments=js}, body} =
  70                 def{ all_section = HM.fromListWith (<>) $ (\t -> (t, pure $ Left head)) <$> titles } <>
  71                 (foldMap collect body)
  72                  { all_judgments =
  73                         choicesBySectionByJudgment HM.empty $
  74                         TreeSeq.Tree (choicesByJudgment js) $
  75                         choicesByJudgmentBySection body
  76                  }
  77 instance Collect (Tree BodyNode) where
  78         collect (Tree n ts) =
  79                 case n of
  80                  BodyBlock b -> collect b
  81                  BodySection s@Section{title, aliases} ->
  82                         def{ all_section = HM.fromListWith (<>) $ (\(Alias t) -> (t, pure $ Right s)) <$> (Alias title : aliases) } <>
  83                         foldMap collect ts
  84 instance Collect DTC.Block where
  85         collect = \case
  86          BlockPara _p    -> def -- collect p
  87          BlockBreak{}    -> def
  88          BlockToC{}      -> def
  89          BlockToF{}      -> def
  90          BlockAside{..}  -> foldMap collect blocks
  91          BlockIndex{..}  -> def{all_index = Map.singleton xmlPos terms}
  92          BlockFigure{..} ->
  93                 def{all_figure=
  94                         Map.singleton type_ (Map.singleton xmlPos mayTitle)}
  95                 -- <> foldMap collect paras
  96          BlockReferences{..} ->
  97                 def{all_reference=
  98                         HM.fromListWith (<>) $ (<$> refs) $ \ref@DTC.Reference{id} -> (id, pure ref)
  99                  }
 100          BlockGrades{attrs=CommonAttrs{id=i}, ..} ->
 101                 def{all_grades = HM.singleton (fromMaybe "" i) scale}
 102          BlockJudges{attrs=CommonAttrs{id=i}, ..} ->
 103                 def{all_judges = HM.singleton (fromMaybe "" i) jury}
 104 {-
 105 instance Collect Judgment where
 106         collect Judgment{..} = def
 107                 def{all_judgments =
 108                         HM.singleton
 109                          (judges,grades,question)
 110                          (Tree.Node choices [])
 111                  }
 112                 -- <> foldMap collect choices
 113 instance Collect Para where
 114         collect = \case
 115          ParaItem item -> collect item
 116          ParaItems{..} -> foldMap collect items
 117 instance Collect ParaItem where
 118         collect = \case
 119          ParaPlain{}    -> def
 120          ParaArtwork{}  -> def
 121          ParaQuote{..}  -> foldMap collect paras
 122          ParaComment{}  -> def
 123          ParaOL items   -> foldMap collect items
 124          ParaUL items   -> foldMap (foldMap collect) items
 125          ParaJudgment{} -> def
 126 instance Collect ListItem where
 127         collect ListItem{..} = foldMap collect paras
 128 instance Collect Choice where
 129         collect Choice{..} =
 130                 foldMap collect title <>
 131                 foldMap collect opinions
 132 instance Collect Opinion where
 133         collect Opinion{..} =
 134                 foldMap collect comment
 135 instance Collect Title where
 136         collect (Title t) = collect t
 137 instance Collect Plain where
 138         collect = foldMap collect
 139 instance Collect (Tree PlainNode) where
 140         collect (Tree n ts) =
 141                 case n of
 142                  PlainBreak    -> def
 143                  PlainText{}   -> def
 144                  PlainGroup    -> collect ts
 145                  PlainB        -> collect ts
 146                  PlainCode     -> collect ts
 147                  PlainDel      -> collect ts
 148                  PlainI        -> collect ts
 149                  PlainSpan{}   -> collect ts
 150                  PlainSub      -> collect ts
 151                  PlainSup      -> collect ts
 152                  PlainSC       -> collect ts
 153                  PlainU        -> collect ts
 154                  PlainNote{..} -> foldMap collect note
 155                  PlainQ        -> collect ts
 156                  PlainEref{}   -> collect ts
 157                  PlainIref{}   -> collect ts
 158                  PlainTag{}    -> collect ts
 159                  PlainRref{..} -> collect ts
 160 -}
 161
 162 choicesByJudgment :: [Judgment] -> HM.HashMap Judgment (Maybe MJ.Share, [Choice])
 163 choicesByJudgment js =
 164         HM.fromList $ (<$> js) $ \j@Judgment{..} ->
 165                 (j,(importance, choices))
 166 choicesByJudgmentBySection :: Body -> TreeSeq.Trees (HM.HashMap Judgment (Maybe MJ.Share, [Choice]))
 167 choicesByJudgmentBySection bod = bod >>= \(Tree b bs) ->
 168         case b of
 169          BodyBlock{} -> mempty
 170          BodySection Section{judgments} ->
 171                 pure $
 172                         let choicesJ = choicesByJudgment judgments in
 173                         Tree choicesJ $
 174                                 -- NOTE: if the 'BodySection' has a child which
 175                                 -- is not a 'BodySection' itself, then add "phantom" 'Judgment's
 176                                 -- which will inherit from this 'BodySection'.
 177                                 -- This enables judges to express something on material not in a sub 'BodySection'.
 178                                 let childrenBlocksJudgments =
 179                                         if (`any`bs) $ \case
 180                                                  Tree BodyBlock{} _ -> True
 181                                                  _ -> False
 182                                         then Seq.singleton $ Tree ((Nothing,[]) <$ choicesJ) Seq.empty
 183                                         else Seq.empty in
 184                                 childrenBlocksJudgments <>
 185                                 choicesByJudgmentBySection bs
 186 choicesBySectionByJudgment ::
 187  HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])] ->
 188  TreeSeq.Tree (HM.HashMap Judgment (Maybe MJ.Share, [Choice])) ->
 189  HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])]
 190 choicesBySectionByJudgment inh (TreeSeq.Tree selfJ childrenJS) =
 191         HM.unionWith
 192          (\selfS childrenS ->
 193                 (<$> selfS) $ \(Tree.Node choices old) ->
 194                         Tree.Node choices (old<>childrenS))
 195          (selfSJ <> inh)
 196          childrenSJ
 197         where
 198         selfSJ = (\cs -> [Tree.Node cs []]) <$> selfJ
 199         childrenSJ =
 200                 foldl'
 201                  (\accJ childJ ->
 202                         HM.unionWith (<>) accJ $
 203                         choicesBySectionByJudgment
 204                          (([Tree.Node (Nothing,[]) []] <$ selfJ) <> inh)
 205                          childJ
 206                  )
 207                  HM.empty
 208                  childrenJS