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