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