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.Foldable (Foldable(..), concat)
  10 import Data.Function (($), (.))
  11 import Data.Functor ((<$>))
  12 import Data.Map.Strict (Map)
  13 import Data.Maybe (Maybe(..), fromMaybe, maybe)
  14 import Data.Monoid (Monoid(..))
  15 import Data.Semigroup (Semigroup(..))
  16 import Data.Sequence (Seq)
  17 import Data.TreeSeq.Strict (Tree(..))
  18 import Text.Show (Show(..))
  19 import qualified Control.Monad.Trans.Reader as R
  20 import qualified Data.HashMap.Strict as HM
  21 import qualified Data.Map.Strict as Map
  22 import qualified Data.Sequence as Seq
  23 import qualified Data.Text.Lazy as TL
  24 import qualified Data.TreeSeq.Strict as TS
  25 import qualified Data.TreeMap.Strict as TM
  26
  27 import qualified Hdoc.TCT.Cell as TCT
  28 import Hdoc.DTC.Document as DTC
  29 import qualified Hdoc.XML as XML
  30
  31 -- * Type 'Reader'
  32 newtype Reader = Reader
  33  { reader_section :: Section
  34  }
  35 instance Default Reader where
  36         def = Reader
  37          { reader_section = def
  38          }
  39
  40 -- * Type 'All'
  41 data All = All
  42  { all_figure     :: HM.HashMap TL.Text (Map XML.Pos (Maybe Title))
  43  , all_grades     :: HM.HashMap Ident (Seq [Grade])
  44  , all_irefs      :: TM.TreeMap Word (Seq Section)
  45  , all_judges     :: HM.HashMap Ident (Seq Judges)
  46  , all_judgesRef  :: HM.HashMap Ident (Seq ((TCT.Location, XML.Pos), Section))
  47  , all_notes      :: TS.Trees (Seq [Para])
  48  , all_reference  :: HM.HashMap Ident (Seq Reference)
  49  , all_ref        :: HM.HashMap Ident (Seq ((TCT.Location, XML.Pos), Section))
  50  , all_section    :: HM.HashMap Ident (Seq Section)
  51  , all_at         :: HM.HashMap Ident (Seq ((TCT.Location, XML.Pos), Section))
  52  , all_tag        :: HM.HashMap Ident (Seq ((TCT.Location, XML.Pos), Section))
  53  } deriving (Show)
  54 instance Default All where
  55         def = All
  56          { all_figure    = def
  57          , all_grades    = def
  58          , all_irefs     = def
  59          , all_judges    = def
  60          , all_judgesRef = def
  61          , all_notes     = def
  62          , all_reference = def
  63          , all_ref       = def
  64          , all_section   = def
  65          , all_at        = def
  66          , all_tag       = def
  67          }
  68 instance Semigroup All where
  69         x<>y = All
  70          { all_figure    = hm_union all_figure
  71          , all_grades    = hm_union all_grades
  72          , all_irefs     = tm_union all_irefs
  73          , all_judges    = hm_union all_judges
  74          , all_judgesRef = hm_union all_judgesRef
  75          , all_notes     = ts_union (all_notes x) (all_notes y)
  76          , all_reference = hm_union all_reference
  77          , all_ref       = hm_union all_ref
  78          , all_section   = hm_union all_section
  79          , all_at        = hm_union all_at
  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                 foldMap collect document_head <>
 106                 collect document_body
 107                 -- R.local (\ro -> ro{reader_section = head_section head}) $
 108                         {- FIXME: see whether to handle that or not
 109                         return def
 110                          { all_section =
 111                                 HM.fromListWith (<>) $
 112                                 (\t -> (t, pure $ Left head))
 113                                  <$> about_titles (head_about head)
 114                          } <>
 115                         -}
 116 instance Collect Head where
 117         collect Head{..} =
 118                 collect $ Seq.singleton $
 119                         TS.Tree (BodySection head_section) head_body
 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 = section}) $
 127                                 ((\all -> all{all_notes = pure $ TS.Tree Seq.empty $ all_notes all}) <$>) $
 128                                 return def
 129                                  { all_section =
 130                                         let titles = (<$> about_titles section_about) $ \section_title ->
 131                                                 Alias
 132                                                  { alias_attrs = section_attrs
 133                                                  , alias_title = section_title
 134                                                  } in
 135                                         HM.fromListWith (<>) $ concat $
 136                                         (\Alias{..} -> maybe [] (pure . (, pure section)) $ attrs_id alias_attrs)
 137                                          <$> (titles <> about_aliases section_about)
 138                                  } <>
 139                                 foldMap collect (about_titles section_about) <>
 140                                 collect bs
 141 instance Collect Block where
 142         collect = \case
 143          BlockPara p     -> collect p
 144          BlockBreak{}    -> pure def
 145          BlockToC{}      -> pure def
 146          BlockToF{}      -> pure def
 147          BlockAside{..}  -> foldMap collect blocks
 148          BlockIndex{..}  -> pure def
 149          BlockFigure{..} ->
 150                 return def
 151                  { all_figure = HM.singleton type_ (Map.singleton posXML mayTitle)
 152                  } <> foldMap collect paras
 153          BlockReferences{..} ->
 154                 return def
 155                  { all_reference=
 156                         HM.fromListWith (<>) $
 157                         (<$> refs) $
 158                         \ref@DTC.Reference{..} -> (reference_id, pure ref)
 159                  } <> foldMap collect refs
 160          BlockGrades{attrs, ..} ->
 161                 return def{all_grades = HM.singleton (fromMaybe "" $ attrs_id attrs) $ pure scale}
 162          BlockJudges judges@Judges{judges_attrs, ..} ->
 163                 return def{all_judges = HM.singleton (fromMaybe "" $ attrs_id judges_attrs) $ pure judges}
 164 instance Collect Para where
 165         collect = \case
 166          ParaItem item -> collect item
 167          ParaItems{..} -> foldMap collect items
 168 instance Collect ParaItem where
 169         collect = \case
 170          ParaPlain p    -> collect p
 171          ParaArtwork{}  -> return def
 172          ParaQuote{..}  -> foldMap collect paras
 173          ParaComment{}  -> return def
 174          ParaOL items   -> foldMap collect items
 175          ParaUL items   -> foldMap (foldMap collect) items
 176          ParaJudgment j -> collect j
 177 instance Collect Judgment where
 178         collect Judgment{..} = do
 179                 Reader{..} <- R.ask
 180                 return def{all_judgesRef = HM.singleton judgment_judgesId $ pure ((judgment_locTCT, judgment_posXML), reader_section) }
 181 instance Collect ListItem where
 182         collect ListItem{..} = foldMap collect paras
 183 instance Collect Title where
 184         collect (Title t) = collect t
 185 instance Collect Plain where
 186         collect = foldMap collect
 187 instance Collect (Tree PlainNode) where
 188         collect (Tree n ts) =
 189                 case n of
 190                  PlainBreak    -> return def
 191                  PlainText{}   -> return def
 192                  PlainGroup    -> collect ts
 193                  PlainB        -> collect ts
 194                  PlainCode     -> collect ts
 195                  PlainDel      -> collect ts
 196                  PlainI        -> collect ts
 197                  PlainSpan{}   -> collect ts
 198                  PlainSub      -> collect ts
 199                  PlainSup      -> collect ts
 200                  PlainSC       -> collect ts
 201                  PlainU        -> collect ts
 202                  PlainNote{..} ->
 203                         return def
 204                          { all_notes = pure $ TS.tree0 $ pure note_paras
 205                          } <> foldMap collect note_paras
 206                  PlainQ        -> collect ts
 207                  PlainEref{}   -> collect ts
 208                  PlainIref{..} -> do
 209                         Reader{..} <- R.ask
 210                         case pathFromWords iref_term of
 211                          Nothing -> collect ts
 212                          Just path ->
 213                                 return def
 214                                  { all_irefs = TM.singleton path $ pure reader_section
 215                                  } <> collect ts
 216                  PlainAt{..}
 217                   | at_back -> return def
 218                   | otherwise -> do
 219                         Reader{..} <- R.ask
 220                         return def
 221                          { all_at = HM.singleton at_ident $ pure ((at_locTCT, at_posXML), reader_section) }
 222                  PlainTag{..}
 223                   | tag_back -> return def
 224                   | otherwise -> do
 225                         Reader{..} <- R.ask
 226                         return def
 227                          { all_tag = HM.singleton tag_ident $ pure ((tag_locTCT, tag_posXML), reader_section) }
 228                  PlainRef{..} -> do
 229                         Reader{..} <- R.ask
 230                         return def
 231                          { all_ref = HM.singleton ref_ident $ pure ((ref_locTCT, ref_posXML), reader_section)
 232                          } <> collect ts
 233 instance Collect Reference where
 234         collect Reference{..} =
 235                 collect reference_about
 236 instance Collect About where
 237         collect About{..} =
 238                 foldMap collect about_titles <>
 239                 foldMap collect about_description