Hdoc/DTC/Analyze/Collect.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 module Hdoc.DTC.Analyze.Collect where
   4
   5 import Control.Applicative (Applicative(..), liftA2)
   6 import Control.Monad
   7 import Data.Bool
   8 import Data.Default.Class (Default(..))
   9 import Data.Either (Either(..))
  10 import Data.Foldable (Foldable(..), any)
  11 import Data.Function (($), (.))
  12 import Data.Functor ((<$>), (<$))
  13 import Data.Map.Strict (Map)
  14 import Data.Maybe (Maybe(..), fromMaybe)
  15 import Data.Monoid (Monoid(..))
  16 import Data.Semigroup (Semigroup(..))
  17 import Data.Sequence (Seq)
  18 import Data.TreeSeq.Strict (Tree(..))
  19 import Text.Show (Show(..))
  20 import qualified Control.Monad.Trans.Reader as R
  21 import qualified Data.HashMap.Strict as HM
  22 import qualified Data.Map.Strict as Map
  23 import qualified Data.Sequence as Seq
  24 import qualified Data.Text.Lazy as TL
  25 import qualified Data.Tree as Tree
  26 import qualified Data.TreeSeq.Strict as TS
  27 import qualified Data.TreeMap.Strict as TM
  28 import qualified Majority.Judgment as MJ
  29
  30 import qualified Hdoc.TCT.Cell as TCT
  31 import Hdoc.DTC.Document as DTC
  32 import qualified Hdoc.XML as XML
  33
  34 -- * Type 'Reader'
  35 newtype Reader = Reader
  36  { reader_section :: Either Head Section
  37  }
  38 instance Default Reader where
  39         def = Reader
  40          { reader_section = Left def
  41          }
  42
  43 -- * Type 'All'
  44 data All = All
  45  { all_figure    :: HM.HashMap TL.Text (Map XML.Pos (Maybe Title))
  46  , all_grades    :: HM.HashMap Ident (Seq [Grade])
  47  , all_index     :: HM.HashMap XML.Pos Terms
  48  , all_irefs     :: TM.TreeMap Word (Seq (Either Head Section))
  49  , all_judges    :: HM.HashMap Ident (Seq Judges)
  50  , all_judgment  :: HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])]
  51  , all_notes     :: TS.Trees (Seq [Para])
  52  , all_reference :: HM.HashMap Ident (Seq Reference)
  53  , all_rrefs     :: HM.HashMap Ident (Seq ((TCT.Location, XML.Pos), Either Head Section))
  54  , all_section   :: HM.HashMap Title (Seq (Either Head Section))
  55  , all_tag       :: HM.HashMap Title (Seq (TCT.Location, XML.Pos))
  56  } deriving (Show)
  57 instance Default All where
  58         def = All
  59          { all_figure    = def
  60          , all_grades    = def
  61          , all_index     = def
  62          , all_irefs     = TM.empty
  63          , all_judges    = def
  64          , all_judgment  = def
  65          , all_notes     = def
  66          , all_reference = def
  67          , all_rrefs     = def
  68          , all_section   = def
  69          , all_tag       = def
  70          }
  71 instance Semigroup All where
  72         x<>y = All
  73          { all_figure    = hm_union all_figure
  74          , all_grades    = hm_union all_grades
  75          , all_index     = hm_union all_index
  76          , all_irefs     = tm_union all_irefs
  77          , all_judges    = hm_union all_judges
  78          , all_judgment  = hm_union all_judgment
  79          , all_notes     = ts_union (all_notes x) (all_notes y)
  80          , all_reference = hm_union all_reference
  81          , all_rrefs     = hm_union all_rrefs
  82          , all_section   = hm_union all_section
  83          , all_tag       = hm_union all_tag
  84          } where
  85                 hm_union get = HM.unionWith (<>) (get x) (get y)
  86                 tm_union get = TM.union     (<>) (get x) (get y)
  87                 ts_union :: TS.Trees (Seq [Para]) -> TS.Trees (Seq [Para]) -> TS.Trees (Seq [Para])
  88                 ts_union sx sy = lx <> Seq.singleton union <> ry
  89                         where
  90                         filter   = null . TS.subTrees
  91                         union    = TS.tree0 $ join $ TS.unTree <$> (rx <> ly)
  92                         (rx, lx) = Seq.spanr filter sx
  93                         (ly, ry) = Seq.spanl filter sy
  94 instance Monoid All where
  95         mempty  = def
  96         mappend = (<>)
  97 instance Semigroup (R.Reader Reader All) where
  98         (<>) = liftA2 (<>)
  99 instance Monoid (R.Reader Reader All) where
 100         mempty  = pure def
 101         mappend = (<>)
 102
 103 -- * Class 'Collect'
 104 class Collect a where
 105         collect :: a -> R.Reader Reader All
 106 instance Collect Document where
 107         collect Document{..} =
 108                 R.local (\ro -> ro{reader_section = Left head}) $
 109                         return def
 110                          { all_section =
 111                                 HM.fromListWith (<>) $
 112                                 (\t -> (t, pure $ Left head))
 113                                  <$> about_titles (head_about head)
 114                          } <>
 115                         (<$> collect body) (\ro -> ro
 116                          { all_judgment =
 117                                 choicesBySectionByJudgment HM.empty $
 118                                 TS.Tree (choicesByJudgment $ head_judgments head) $
 119                                 choicesByJudgmentBySection body
 120                          })
 121 instance Collect (TS.Trees BodyNode) where
 122         collect = foldMap $ \(TS.Tree b bs) ->
 123                 case b of
 124                  BodyBlock blk ->
 125                         collect blk
 126                  BodySection section@Section{..} ->
 127                         R.local (\ro -> ro{reader_section = Right section}) $
 128                                 ((\all -> all{all_notes = pure $ TS.Tree Seq.empty $ all_notes all}) <$>) $
 129                                 return def
 130                                  { all_section =
 131                                         HM.fromListWith (<>) $
 132                                         (\(Alias t) -> (t, pure $ Right section))
 133                                          <$> (Alias section_title : section_aliases)
 134                                  } <>
 135                                 collect section_title <>
 136                                 collect bs
 137 instance Collect Block where
 138         collect = \case
 139          BlockPara p     -> collect p
 140          BlockBreak{}    -> pure def
 141          BlockToC{}      -> pure def
 142          BlockToF{}      -> pure def
 143          BlockAside{..}  -> foldMap collect blocks
 144          BlockIndex{..}  -> return def{all_index = HM.singleton posXML terms}
 145          BlockFigure{..} ->
 146                 return def
 147                  { all_figure = HM.singleton type_ (Map.singleton posXML mayTitle)
 148                  } <> foldMap collect paras
 149          BlockReferences{..} ->
 150                 return def
 151                  { all_reference=
 152                         HM.fromListWith (<>) $
 153                         (<$> refs) $
 154                         \ref@DTC.Reference{..} -> (reference_id, pure ref)
 155                  } <> foldMap collect refs
 156          BlockGrades{attrs=CommonAttrs{id}, ..} ->
 157                 return def{all_grades = HM.singleton (fromMaybe "" id) $ pure scale}
 158          BlockJudges judges@Judges{judges_attrs=CommonAttrs{id}, ..} ->
 159                 return def{all_judges = HM.singleton (fromMaybe "" id) $ pure judges}
 160 instance Collect Para where
 161         collect = \case
 162          ParaItem item -> collect item
 163          ParaItems{..} -> foldMap collect items
 164 instance Collect ParaItem where
 165         collect = \case
 166          ParaPlain p    -> collect p
 167          ParaArtwork{}  -> return def
 168          ParaQuote{..}  -> foldMap collect paras
 169          ParaComment{}  -> return def
 170          ParaOL items   -> foldMap collect items
 171          ParaUL items   -> foldMap (foldMap collect) items
 172          ParaJudgment{} -> return def
 173 instance Collect ListItem where
 174         collect ListItem{..} = foldMap collect paras
 175 instance Collect Title where
 176         collect (Title t) = collect t
 177 instance Collect Plain where
 178         collect = foldMap collect
 179 instance Collect (Tree PlainNode) where
 180         collect (Tree n ts) =
 181                 case n of
 182                  PlainBreak    -> return def
 183                  PlainText{}   -> return def
 184                  PlainGroup    -> collect ts
 185                  PlainB        -> collect ts
 186                  PlainCode     -> collect ts
 187                  PlainDel      -> collect ts
 188                  PlainI        -> collect ts
 189                  PlainSpan{}   -> collect ts
 190                  PlainSub      -> collect ts
 191                  PlainSup      -> collect ts
 192                  PlainSC       -> collect ts
 193                  PlainU        -> collect ts
 194                  PlainNote{..} ->
 195                         return def
 196                          { all_notes = pure $ TS.tree0 $ pure note_paras
 197                          } <> foldMap collect note_paras
 198                  PlainQ        -> collect ts
 199                  PlainEref{}   -> collect ts
 200                  PlainIref{..} -> do
 201                         Reader{..} <- R.ask
 202                         case pathFromWords iref_term of
 203                          Nothing -> collect ts
 204                          Just path ->
 205                                 return def
 206                                  { all_irefs = TM.singleton path $ pure reader_section
 207                                  } <> collect ts
 208                  PlainTag{..} -> return def
 209                          { all_tag = HM.singleton (Title ts) $ pure (tag_locTCT, tag_posXML) }
 210                  PlainRref{..} -> do
 211                         Reader{..} <- R.ask
 212                         return def
 213                          { all_rrefs = HM.singleton rref_to $ pure ((rref_locTCT, rref_posXML), reader_section)
 214                          } <> collect ts
 215 instance Collect Reference where
 216         collect Reference{..} =
 217                 collect reference_about
 218 instance Collect About where
 219         collect About{..} =
 220                 foldMap collect about_titles
 221
 222
 223 choicesByJudgment :: [Judgment] -> HM.HashMap Judgment (Maybe MJ.Share, [Choice])
 224 choicesByJudgment js =
 225         HM.fromList $ (<$> js) $ \j@Judgment{..} ->
 226                 (j,(judgment_importance, judgment_choices))
 227
 228 choicesByJudgmentBySection :: Body -> TS.Trees (HM.HashMap Judgment (Maybe MJ.Share, [Choice]))
 229 choicesByJudgmentBySection bod = bod >>= \(Tree b bs) ->
 230         case b of
 231          BodyBlock{} -> mempty
 232          BodySection Section{..} ->
 233                 pure $
 234                         let choicesJ = choicesByJudgment section_judgments in
 235                         Tree choicesJ $
 236                                 -- NOTE: if the 'BodySection' has a child which
 237                                 -- is not a 'BodySection' itself, then add "phantom" 'Judgment's
 238                                 -- which will inherit from this 'BodySection'.
 239                                 -- This enables judges to express something on material not in a sub 'BodySection'.
 240                                 let childrenBlocksJudgments =
 241                                         if (`any`bs) $ \case
 242                                                  Tree BodyBlock{} _ -> True
 243                                                  _ -> False
 244                                         then Seq.singleton $ Tree ((Nothing,[]) <$ choicesJ) Seq.empty
 245                                         else Seq.empty in
 246                                 childrenBlocksJudgments <>
 247                                 choicesByJudgmentBySection bs
 248
 249 choicesBySectionByJudgment :: -- TODO: see if this can be done using Reader and collect
 250  HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])] ->
 251  TS.Tree (HM.HashMap Judgment (Maybe MJ.Share, [Choice])) ->
 252  HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])]
 253 choicesBySectionByJudgment inh (TS.Tree selfJ childrenJS) =
 254         HM.unionWith
 255          (\selfS childrenS ->
 256                 (<$> selfS) $ \(Tree.Node choices old) ->
 257                         Tree.Node choices (old<>childrenS))
 258          (selfSJ <> inh)
 259          childrenSJ
 260         where
 261         selfSJ = (\cs -> [Tree.Node cs []]) <$> selfJ
 262         childrenSJ =
 263                 foldl'
 264                  (\accJ childJ ->
 265                         HM.unionWith (<>) accJ $
 266                         choicesBySectionByJudgment
 267                          (([Tree.Node (Nothing,[]) []] <$ selfJ) <> inh)
 268                          childJ
 269                  )
 270                  HM.empty
 271                  childrenJS
 272
 273
 274