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