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 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 [Judge]
  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                         TreeSeq.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{title, aliases} ->
  83                         def{ all_section = HM.fromListWith (<>) $ (\(Alias t) -> (t, pure $ Right s)) <$> (Alias title : aliases) } <>
  84                         foldMap collect ts
  85 instance Collect DTC.Block where
  86         collect = \case
  87          BlockPara _p    -> def -- collect p
  88          BlockBreak{}    -> def
  89          BlockToC{}      -> def
  90          BlockToF{}      -> def
  91          BlockAside{..}  -> foldMap collect blocks
  92          BlockIndex{..}  -> def{all_index = Map.singleton xmlPos terms}
  93          BlockFigure{..} ->
  94                 def{all_figure=
  95                         Map.singleton type_ (Map.singleton xmlPos mayTitle)}
  96                 -- <> foldMap collect paras
  97          BlockReferences{..} ->
  98                 def{all_reference=
  99                         HM.fromListWith (<>) $ (<$> refs) $ \ref@DTC.Reference{id} -> (id, pure ref)
 100                  }
 101          BlockGrades{attrs=CommonAttrs{id=i}, ..} ->
 102                 def{all_grades = HM.singleton (fromMaybe "" i) scale}
 103          BlockJudges{attrs=CommonAttrs{id=i}, ..} ->
 104                 def{all_judges = HM.singleton (fromMaybe "" i) jury}
 105 {-
 106 instance Collect Judgment where
 107         collect Judgment{..} = def
 108                 def{all_judgments =
 109                         HM.singleton
 110                          (judges,grades,question)
 111                          (Tree.Node choices [])
 112                  }
 113                 -- <> foldMap collect choices
 114 instance Collect Para where
 115         collect = \case
 116          ParaItem item -> collect item
 117          ParaItems{..} -> foldMap collect items
 118 instance Collect ParaItem where
 119         collect = \case
 120          ParaPlain{}    -> def
 121          ParaArtwork{}  -> def
 122          ParaQuote{..}  -> foldMap collect paras
 123          ParaComment{}  -> def
 124          ParaOL items   -> foldMap collect items
 125          ParaUL items   -> foldMap (foldMap collect) items
 126          ParaJudgment{} -> def
 127 instance Collect ListItem where
 128         collect ListItem{..} = foldMap collect paras
 129 instance Collect Choice where
 130         collect Choice{..} =
 131                 foldMap collect title <>
 132                 foldMap collect opinions
 133 instance Collect Opinion where
 134         collect Opinion{..} =
 135                 foldMap collect comment
 136 instance Collect Title where
 137         collect (Title t) = collect t
 138 instance Collect Plain where
 139         collect = foldMap collect
 140 instance Collect (Tree PlainNode) where
 141         collect (Tree n ts) =
 142                 case n of
 143                  PlainBreak    -> def
 144                  PlainText{}   -> def
 145                  PlainGroup    -> collect ts
 146                  PlainB        -> collect ts
 147                  PlainCode     -> collect ts
 148                  PlainDel      -> collect ts
 149                  PlainI        -> collect ts
 150                  PlainSpan{}   -> collect ts
 151                  PlainSub      -> collect ts
 152                  PlainSup      -> collect ts
 153                  PlainSC       -> collect ts
 154                  PlainU        -> collect ts
 155                  PlainNote{..} -> foldMap collect note
 156                  PlainQ        -> collect ts
 157                  PlainEref{}   -> collect ts
 158                  PlainIref{}   -> collect ts
 159                  PlainTag{}    -> collect ts
 160                  PlainRref{..} -> collect ts
 161 -}
 162
 163 choicesByJudgment :: [Judgment] -> HM.HashMap Judgment (Maybe MJ.Share, [Choice])
 164 choicesByJudgment js =
 165         HM.fromList $ (<$> js) $ \j@Judgment{..} ->
 166                 (j,(importance, choices))
 167 choicesByJudgmentBySection :: Body -> TreeSeq.Trees (HM.HashMap Judgment (Maybe MJ.Share, [Choice]))
 168 choicesByJudgmentBySection bod = bod >>= \(Tree b bs) ->
 169         case b of
 170          BodyBlock{} -> mempty
 171          BodySection Section{judgments} ->
 172                 pure $
 173                         let choicesJ = choicesByJudgment judgments in
 174                         Tree choicesJ $
 175                                 -- NOTE: if the 'BodySection' has a child which
 176                                 -- is not a 'BodySection' itself, then add "phantom" 'Judgment's
 177                                 -- which will inherit from this 'BodySection'.
 178                                 -- This enables judges to express something on material not in a sub 'BodySection'.
 179                                 let childrenBlocksJudgments =
 180                                         if (`any`bs) $ \case
 181                                                  Tree BodyBlock{} _ -> True
 182                                                  _ -> False
 183                                         then Seq.singleton $ Tree ((Nothing,[]) <$ choicesJ) Seq.empty
 184                                         else Seq.empty in
 185                                 childrenBlocksJudgments <>
 186                                 choicesByJudgmentBySection bs
 187 choicesBySectionByJudgment ::
 188  HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])] ->
 189  TreeSeq.Tree (HM.HashMap Judgment (Maybe MJ.Share, [Choice])) ->
 190  HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])]
 191 choicesBySectionByJudgment inh (TreeSeq.Tree selfJ childrenJS) =
 192         HM.unionWith
 193          (\selfS childrenS ->
 194                 (<$> selfS) $ \(Tree.Node choices old) ->
 195                         Tree.Node choices (old<>childrenS))
 196          (selfSJ <> inh)
 197          childrenSJ
 198         where
 199         selfSJ = (\cs -> [Tree.Node cs []]) <$> selfJ
 200         childrenSJ =
 201                 foldl'
 202                  (\accJ childJ ->
 203                         HM.unionWith (<>) accJ $
 204                         choicesBySectionByJudgment
 205                          (([Tree.Node (Nothing,[]) []] <$ selfJ) <> inh)
 206                          childJ
 207                  )
 208                  HM.empty
 209                  childrenJS