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