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_pageRef    :: HM.HashMap PathPage (Seq ((TCT.Location, XML.Pos), Section))
  51  , all_section    :: HM.HashMap Ident (Seq Section)
  52  , all_at         :: HM.HashMap Ident (Seq ((TCT.Location, XML.Pos), Section))
  53  , all_tag        :: HM.HashMap Ident (Seq ((TCT.Location, XML.Pos), Section))
  54  } deriving (Show)
  55 instance Default All where
  56         def = All
  57          { all_figure    = def
  58          , all_grades    = def
  59          , all_irefs     = def
  60          , all_judges    = def
  61          , all_judgesRef = def
  62          , all_notes     = def
  63          , all_reference = def
  64          , all_ref       = def
  65          , all_pageRef   = def
  66          , all_section   = def
  67          , all_at        = def
  68          , all_tag       = def
  69          }
  70 instance Semigroup All where
  71         x<>y = All
  72          { all_figure    = hm_union all_figure
  73          , all_grades    = hm_union all_grades
  74          , all_irefs     = tm_union all_irefs
  75          , all_judges    = hm_union all_judges
  76          , all_judgesRef = hm_union all_judgesRef
  77          , all_notes     = ts_union (all_notes x) (all_notes y)
  78          , all_reference = hm_union all_reference
  79          , all_ref       = hm_union all_ref
  80          , all_pageRef   = hm_union all_pageRef
  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                 foldMap collect document_head <>
 109                 collect document_body
 110                 -- R.local (\ro -> ro{reader_section = head_section head}) $
 111                         {- FIXME: see whether to handle that or not
 112                         return def
 113                          { all_section =
 114                                 HM.fromListWith (<>) $
 115                                 (\t -> (t, pure $ Left head))
 116                                  <$> about_titles (head_about head)
 117                          } <>
 118                         -}
 119 instance Collect Head where
 120         collect Head{..} =
 121                 collect $ Seq.singleton $
 122                         TS.Tree (BodySection head_section) head_body
 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 = section}) $
 130                                 ((\all -> all{all_notes = pure $ TS.Tree Seq.empty $ all_notes all}) <$>) $
 131                                 return def
 132                                  { all_section =
 133                                         let titles = (<$> about_titles section_about) $ \section_title ->
 134                                                 Alias
 135                                                  { alias_attrs = section_attrs
 136                                                  , alias_title = section_title
 137                                                  } in
 138                                         HM.fromListWith (<>) $ concat $
 139                                         (\Alias{..} -> maybe [] (pure . (, pure section)) $ attrs_id alias_attrs)
 140                                          <$> (titles <> about_aliases section_about)
 141                                  } <>
 142                                 foldMap collect (about_titles section_about) <>
 143                                 collect bs
 144 instance Collect Block where
 145         collect = \case
 146          BlockPara p     -> collect p
 147          BlockBreak{}    -> pure def
 148          BlockToC{}      -> pure def
 149          BlockToF{}      -> pure def
 150          BlockAside{..}  -> foldMap collect blocks
 151          BlockIndex{..}  -> pure def
 152          BlockFigure{..} ->
 153                 return def
 154                  { all_figure = HM.singleton type_ (Map.singleton posXML mayTitle)
 155                  } <> foldMap collect paras
 156          BlockReferences{..} ->
 157                 return def
 158                  { all_reference=
 159                         HM.fromListWith (<>) $
 160                         (<$> refs) $
 161                         \ref@DTC.Reference{..} -> (reference_id, pure ref)
 162                  } <> foldMap collect refs
 163          BlockGrades{attrs, ..} ->
 164                 return def{all_grades = HM.singleton (fromMaybe "" $ attrs_id attrs) $ pure scale}
 165          BlockJudges judges@Judges{judges_attrs, ..} ->
 166                 return def{all_judges = HM.singleton (fromMaybe "" $ attrs_id judges_attrs) $ pure judges}
 167 instance Collect Para where
 168         collect = \case
 169          ParaItem item -> collect item
 170          ParaItems{..} -> foldMap collect items
 171 instance Collect ParaItem where
 172         collect = \case
 173          ParaPlain p    -> collect p
 174          ParaArtwork{}  -> return def
 175          ParaQuote{..}  -> foldMap collect paras
 176          ParaComment{}  -> return def
 177          ParaOL items   -> foldMap collect items
 178          ParaUL items   -> foldMap (foldMap collect) items
 179          ParaJudgment j -> collect j
 180 instance Collect Judgment where
 181         collect Judgment{..} = do
 182                 Reader{..} <- R.ask
 183                 return def{all_judgesRef = HM.singleton judgment_judgesId $ pure ((judgment_locTCT, judgment_posXML), reader_section) }
 184 instance Collect ListItem where
 185         collect ListItem{..} = foldMap collect paras
 186 instance Collect Title where
 187         collect (Title t) = collect t
 188 instance Collect Plain where
 189         collect = foldMap collect
 190 instance Collect (Tree PlainNode) where
 191         collect (Tree n ts) =
 192                 case n of
 193                  PlainBreak    -> return def
 194                  PlainText{}   -> return def
 195                  PlainGroup    -> collect ts
 196                  PlainB        -> collect ts
 197                  PlainCode     -> collect ts
 198                  PlainDel      -> collect ts
 199                  PlainI        -> collect ts
 200                  PlainSpan{}   -> collect ts
 201                  PlainSub      -> collect ts
 202                  PlainSup      -> collect ts
 203                  PlainSC       -> collect ts
 204                  PlainU        -> collect ts
 205                  PlainNote{..} ->
 206                         return def
 207                          { all_notes = pure $ TS.tree0 $ pure note_paras
 208                          } <> foldMap collect note_paras
 209                  PlainQ        -> collect ts
 210                  PlainEref{}   -> collect ts
 211                  PlainIref{..} -> do
 212                         Reader{..} <- R.ask
 213                         case pathFromWords iref_term of
 214                          Nothing -> collect ts
 215                          Just path ->
 216                                 return def
 217                                  { all_irefs = TM.singleton path $ pure reader_section
 218                                  } <> collect ts
 219                  PlainAt{..}
 220                   | at_back -> return def
 221                   | otherwise -> do
 222                         Reader{..} <- R.ask
 223                         return def
 224                          { all_at = HM.singleton at_ident $ pure ((at_locTCT, at_posXML), reader_section) }
 225                  PlainTag{..}
 226                   | tag_back -> return def
 227                   | otherwise -> do
 228                         Reader{..} <- R.ask
 229                         return def
 230                          { all_tag = HM.singleton tag_ident $ pure ((tag_locTCT, tag_posXML), reader_section) }
 231                  PlainRef{..} -> do
 232                         Reader{..} <- R.ask
 233                         return def
 234                          { all_ref = HM.singleton ref_ident $ pure ((ref_locTCT, ref_posXML), reader_section)
 235                          } <> collect ts
 236                  PlainPageRef{..} -> do
 237                         Reader{..} <- R.ask
 238                         return def
 239                          { all_pageRef = HM.singleton pageRef_path $ pure ((pageRef_locTCT, pageRef_posXML), reader_section)
 240                          } <> collect ts
 241 instance Collect Reference where
 242         collect Reference{..} =
 243                 collect reference_about
 244 instance Collect About where
 245         collect About{..} =
 246                 foldMap collect about_titles <>
 247                 foldMap collect about_description