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 ListItem where
 178         collect ListItem{..} = foldMap collect paras
 179 instance Collect Title where
 180         collect (Title t) = collect t
 181 instance Collect Plain where
 182         collect = foldMap collect
 183 instance Collect (Tree PlainNode) where
 184         collect (Tree n ts) =
 185                 case n of
 186                  PlainBreak    -> return def
 187                  PlainText{}   -> return def
 188                  PlainGroup    -> collect ts
 189                  PlainB        -> collect ts
 190                  PlainCode     -> collect ts
 191                  PlainDel      -> collect ts
 192                  PlainI        -> collect ts
 193                  PlainSpan{}   -> collect ts
 194                  PlainSub      -> collect ts
 195                  PlainSup      -> collect ts
 196                  PlainSC       -> collect ts
 197                  PlainU        -> collect ts
 198                  PlainNote{..} ->
 199                         return def
 200                          { all_notes = pure $ TS.tree0 $ pure note_paras
 201                          } <> foldMap collect note_paras
 202                  PlainQ        -> collect ts
 203                  PlainEref{}   -> collect ts
 204                  PlainIref{..} -> do
 205                         Reader{..} <- R.ask
 206                         case pathFromWords iref_term of
 207                          Nothing -> collect ts
 208                          Just path ->
 209                                 return def
 210                                  { all_irefs = TM.singleton path $ pure reader_section
 211                                  } <> collect ts
 212                  PlainAt{..}
 213                   | at_back -> return def
 214                   | otherwise -> do
 215                         Reader{..} <- R.ask
 216                         return def
 217                          { all_at = HM.singleton at_ident $ pure ((at_locTCT, at_posXML), reader_section) }
 218                  PlainTag{..}
 219                   | tag_back -> return def
 220                   | otherwise -> do
 221                         Reader{..} <- R.ask
 222                         return def
 223                          { all_tag = HM.singleton tag_ident $ pure ((tag_locTCT, tag_posXML), reader_section) }
 224                  PlainRef{..} -> do
 225                         Reader{..} <- R.ask
 226                         return def
 227                          { all_ref = HM.singleton ref_ident $ pure ((ref_locTCT, ref_posXML), reader_section)
 228                          } <> collect ts
 229 instance Collect Reference where
 230         collect Reference{..} =
 231                 collect reference_about
 232 instance Collect About where
 233         collect About{..} =
 234                 foldMap collect about_titles <>
 235                 foldMap collect about_description