Hdoc/DTC/Analyze/Index.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 module Hdoc.DTC.Analyze.Index where
   4
   5 -- import Data.Eq (Eq(..))
   6 -- import Text.Show (Show(..))
   7 -- import qualified Control.Monad.Trans.Writer as W
   8 -- import qualified Data.HashMap.Strict as HM
   9 -- import qualified Data.Tree as Tree
  10 -- import qualified Data.TreeSeq.Strict as TS
  11 -- import qualified Hjugement as MJ
  12 import Control.Applicative (Applicative(..))
  13 import Control.Monad (Monad(..))
  14 import Data.Bool
  15 import Data.Char (Char)
  16 import Data.Default.Class (Default(..))
  17 import Data.Either (Either(..))
  18 import Data.Foldable (Foldable(..), concat)
  19 import Data.Function (($), (.), const)
  20 import Data.Functor ((<$>), (<$))
  21 import Data.Functor.Compose (Compose(..))
  22 import Data.Map.Strict (Map)
  23 import Data.Maybe (Maybe(..), maybe)
  24 import Data.Monoid (Monoid(..))
  25 import Data.Semigroup (Semigroup(..))
  26 import Data.Sequence (Seq, (|>))
  27 import Data.Traversable (Traversable(..))
  28 import Data.TreeMap.Strict (TreeMap(..))
  29 import Data.TreeSeq.Strict (Tree(..), tree0)
  30 import qualified Control.Monad.Trans.Reader as R
  31 import qualified Control.Monad.Trans.State as S
  32 import qualified Data.Char as Char
  33 import qualified Data.List as List
  34 import qualified Data.Map.Strict as Map
  35 import qualified Data.Sequence as Seq
  36 import qualified Data.Strict.Maybe as Strict
  37 import qualified Data.Text.Lazy as TL
  38 import qualified Data.TreeMap.Strict as TM
  39
  40 import Hdoc.DTC.Document as DTC
  41 -- import Hdoc.TCT.Cell as TCT
  42 -- import qualified Hdoc.XML as XML
  43
  44 -- * Type 'IrefsByWords'
  45 type IrefsByWords = TM.TreeMap Word (Seq (Either Head Section))
  46
  47 irefsOfTerms :: Terms -> IrefsByWords
  48 irefsOfTerms = TM.fromList const . (>>= f) . concat
  49         where
  50         f [] = []
  51         f ws = maybe [] (\p -> [(p,Seq.empty)]) $ pathFromWords ws
  52
  53 wordify :: TL.Text -> Words
  54 wordify = List.reverse . go []
  55         where
  56         go :: Words -> TL.Text -> Words
  57         go acc t =
  58                 case TL.span Char.isAlphaNum t of
  59                  ("",_) ->
  60                         case TL.span Char.isSpace t of
  61                          ("",_) ->
  62                                 case TL.uncons t of
  63                                  Nothing -> acc
  64                                  Just (c,r) -> go (Word (TL.singleton c) : acc) r
  65                          (_s,r) -> go (Space : acc) r
  66                  (w,r) -> go (Word w : acc) r
  67
  68 plainifyWord :: WordOrSpace -> TL.Text
  69 plainifyWord = \case
  70  Word w -> w
  71  Space  -> " "
  72
  73 plainifyWords :: Words -> TL.Text
  74 plainifyWords = TL.concat . (plainifyWord <$>)
  75
  76 termsByChar :: Terms -> Map Char Terms
  77 termsByChar =
  78         foldr (\aliases acc ->
  79                 case aliases of
  80                  (Word w:_):_ | not (TL.null w) ->
  81                         Map.insertWith (<>)
  82                          (Char.toUpper $ TL.index w 0)
  83                          [aliases] acc
  84                  _ -> acc
  85                 ) Map.empty
  86
  87 -- * Type 'Reader'
  88 data Reader = Reader
  89  { reader_section :: Either Head Section
  90  }
  91 instance Default Reader where
  92         def = Reader
  93          { reader_section = Left def
  94          }
  95
  96 -- * Type 'State'
  97 type State = IrefsByWords
  98
  99 -- * Class 'Indexify'
 100 class Indexify a where
 101         indexify :: a -> Compose (R.Reader Reader) (S.State State) a
 102 instance Indexify Document where
 103         indexify Document{..} =
 104                 Compose $ R.local (\ro -> ro{reader_section = Left head}) $
 105                         getCompose $
 106                         Document
 107                          <$> indexify head
 108                          <*> traverse indexify body
 109 instance Indexify Head where
 110         indexify h@Head{..} = pure h
 111 instance Indexify (Tree BodyNode) where
 112         indexify (Tree n ts) =
 113                 case n of
 114                  BodyBlock b ->
 115                         Tree . BodyBlock
 116                          <$> indexify b
 117                          <*> traverse indexify ts
 118                  BodySection section@Section{..} ->
 119                         Compose $ R.local (\ro -> ro{reader_section = Right section}) $
 120                                 getCompose $
 121                                 Tree . BodySection
 122                                  <$> indexify section
 123                                  <*> traverse indexify ts
 124 instance Indexify Section where
 125         indexify Section{..} =
 126                 Section section_posXML section_attrs
 127                  <$> indexify section_title
 128                  <*> pure section_aliases
 129                  <*> traverse indexify section_judgments
 130 instance Indexify Block where
 131         indexify b = case b of
 132          BlockPara p     -> BlockPara <$> indexify p
 133          BlockBreak{}    -> pure b
 134          BlockToC{}      -> pure b
 135          BlockToF{}      -> pure b
 136          BlockAside{..}  -> BlockAside posXML attrs <$> traverse indexify blocks
 137          BlockIndex{..}  -> pure b
 138          BlockFigure{..} ->
 139                 BlockFigure posXML type_ attrs
 140                  <$> traverse indexify mayTitle
 141                  <*> traverse indexify paras
 142          BlockReferences{..} ->
 143                 BlockReferences posXML attrs
 144                  <$> traverse indexify refs
 145          BlockJudges js -> BlockJudges <$> indexify js
 146          BlockGrades{..} ->
 147                 BlockGrades posXML attrs
 148                  <$> indexify scale
 149 instance Indexify Para where
 150         indexify = \case
 151          ParaItem{..}  -> ParaItem <$> indexify item
 152          ParaItems{..} -> ParaItems posXML attrs <$> traverse indexify items
 153 instance Indexify ParaItem where
 154         indexify = \case
 155          ParaPlain plain -> ParaPlain       <$> indexify plain
 156          ParaOL items    -> ParaOL          <$> traverse indexify items
 157          ParaUL items    -> ParaUL          <$> traverse (traverse indexify) items
 158          ParaQuote{..}   -> ParaQuote type_ <$> traverse indexify paras
 159          p@ParaArtwork{} -> pure p
 160          p@ParaComment{} -> pure p
 161          ParaJudgment j  -> ParaJudgment <$> indexify j
 162 instance Indexify ListItem where
 163         indexify ListItem{..} = ListItem name <$> traverse indexify paras
 164 instance Indexify Plain where
 165         indexify = traverse indexify
 166 instance Indexify (Tree PlainNode) where
 167         indexify (Tree n ts) =
 168                 case n of
 169                  PlainIref{..} ->
 170                         case pathFromWords iref_term of
 171                          Nothing -> Tree n <$> traverse indexify ts
 172                          Just words ->
 173                                 Compose $ R.ask >>= \ro -> getCompose $
 174                                         Tree n
 175                                          <$ Compose (pure (S.modify' $ \state_irefsByWords ->
 176                                                         TM.insert (<>) words (pure $ reader_section ro) $
 177                                                         state_irefsByWords
 178                                                  ))
 179                                          <*> traverse indexify ts
 180                  PlainText txt ->
 181                         -- TODO: introduce PlainGroup only when necessary?
 182                         Tree PlainGroup <$> indexifyWords (wordify txt)
 183                  _ -> Tree n <$> traverse indexify ts
 184 instance Indexify Title where
 185         indexify (Title p) = Title <$> indexify p
 186 instance Indexify About where
 187         indexify About{..} =
 188                 About
 189                  <$> traverse indexify about_titles
 190                  <*> pure about_url
 191                  <*> traverse indexify about_authors
 192                  <*> traverse indexify about_editor
 193                  <*> traverse indexify about_date
 194                  <*> pure about_tags
 195                  <*> pure about_links
 196                  <*> pure about_series
 197                  <*> traverse indexify about_description
 198                  <*> pure about_headers
 199 instance Indexify Entity where
 200         indexify = pure -- TODO: to be coded
 201 instance Indexify Date where
 202         indexify = pure -- TODO: to be coded
 203 instance Indexify Include where
 204         indexify = pure -- TODO: to be coded
 205 instance Indexify Reference where
 206         indexify Reference{..} = do
 207                 Reference
 208                  reference_posXML
 209                  reference_locTCT
 210                  reference_id
 211                  <$> indexify reference_about
 212                 {-
 213                 st@State{state_collect=All{..}, ..} <- S.get
 214                 let targets = HM.lookupDefault Seq.empty reference_id all_reference
 215                 case toList targets of
 216                  [] -> undefined
 217                  [_] -> do
 218                  _ -> do
 219                         let err =
 220                                 HM.insertWith (flip (<>)) reference_id (pure reference_locTCT) $
 221                                 errors_reference_ambiguous state_errors
 222                         S.put st
 223                          { state_errors = state_errors
 224                                  { errors_reference_ambiguous = err }
 225                          }
 226                         about <- indexify reference_about
 227                         return $ Reference
 228                          { reference_error = Just $ ErrorAnchor_Ambiguous $ Nat1 $ length $ err HM.!reference_id
 229                          , reference_about = about
 230                          , .. }
 231                 -}
 232 instance Indexify Judges where
 233         indexify Judges{..} =
 234                 Judges
 235                  judges_locTCT
 236                  judges_posXML
 237                  judges_attrs
 238                  <$> traverse (traverse indexify) judges_byName
 239 instance Indexify [Grade] where
 240         indexify = traverse indexify
 241 instance Indexify Judgment where
 242         indexify Judgment{..} =
 243                 Judgment
 244                  judgment_opinionsByChoice
 245                  judgment_judges
 246                  judgment_grades
 247                  judgment_posXML
 248                  judgment_locTCT
 249                  judgment_judgesId
 250                  judgment_gradesId
 251                  judgment_importance
 252                  <$> traverse indexify judgment_question
 253                  <*> traverse indexify judgment_choices
 254 instance Indexify Choice where
 255         indexify Choice{..} =
 256                 Choice choice_locTCT  choice_posXML
 257                  <$> traverse indexify choice_title
 258                  <*> traverse indexify choice_opinions
 259 instance Indexify Opinion where
 260         indexify Opinion{..} =
 261                 Opinion
 262                  opinion_locTCT
 263                  opinion_posXML
 264                  opinion_judge
 265                  opinion_grade
 266                  opinion_importance
 267                  <$> traverse indexify opinion_comment
 268 instance Indexify Grade where
 269         indexify Grade{..} =
 270                 Grade
 271                  grade_posXML
 272                  grade_name
 273                  grade_color
 274                  grade_isDefault
 275                  <$> traverse indexify grade_title
 276 instance Indexify Judge where
 277         indexify Judge{..} =
 278                 Judge
 279                  judge_locTCT
 280                  judge_posXML
 281                  judge_name
 282                  <$> traverse indexify judge_title
 283                  <*> pure judge_defaultGrades
 284
 285 indexifyWords :: Words -> Compose (R.Reader Reader) (S.State IrefsByWords) Plain
 286 indexifyWords ws =
 287         Compose $ R.ask >>= \case
 288          ro -> pure $ go mempty ws
 289                 where
 290                 go :: Plain -> Words -> S.State IrefsByWords Plain
 291                 go acc inp =
 292                         case inp of
 293                          [] -> return acc
 294                          Space : next ->
 295                                 go (acc |> tree0 (PlainText " ")) next
 296                          Word w : next ->
 297                                 goWords [] inp >>= \case
 298                                  Nothing -> go (acc |> tree0 (PlainText w)) next
 299                                  Just (ls, ns) -> do
 300                                         let iref_term = List.reverse ls
 301                                         let lines = Seq.fromList $ tree0 . PlainText . plainifyWord <$> iref_term
 302                                         go (acc |> Tree PlainIref{iref_term} lines) ns
 303                 goWords ::
 304                  Words -> Words ->
 305                  S.State IrefsByWords (Maybe (Words, Words))
 306                 goWords prev inp = do
 307                         TM.TreeMap irefsByWord <- S.get
 308                         case inp of
 309                          [] -> return Nothing
 310                          curr@Space : next -> goWords (curr:prev) next
 311                          curr@(Word w) : next ->
 312                                 case Map.lookup w irefsByWord of
 313                                  Nothing -> return Nothing
 314                                  Just nod@TM.Node{..} -> do
 315                                         let prev' = curr:prev
 316                                         S.put node_descendants
 317                                         case node_value of
 318                                          Strict.Nothing
 319                                                 | null node_descendants -> return Nothing
 320                                                 | otherwise -> goWords prev' next
 321                                                  <* S.modify' (\rs -> TreeMap $ Map.insert w nod{TM.node_descendants = rs} irefsByWord)
 322                                          Strict.Just irefs ->
 323                                                 goWords prev' next >>= \case
 324                                                  Nothing -> do
 325                                                         S.put $ TM.TreeMap $
 326                                                                 Map.insert w
 327                                                                  nod{TM.node_value = Strict.Just $ reader_section ro Seq.<|irefs}
 328                                                                  irefsByWord
 329                                                         return $ Just (prev', next)
 330                                                  r@Just{} -> do
 331                                                         S.modify' $ \rs ->
 332                                                                 TM.TreeMap $ Map.insert w nod{TM.node_descendants = rs} irefsByWord
 333                                                         return r