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 about_headers
 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_includes
 198 instance Indexify Entity where
 199         indexify = pure -- TODO: to be coded
 200 instance Indexify Date where
 201         indexify = pure -- TODO: to be coded
 202 instance Indexify Include where
 203         indexify = pure -- TODO: to be coded
 204 instance Indexify Reference where
 205         indexify Reference{..} = do
 206                 Reference
 207                  reference_posXML
 208                  reference_locTCT
 209                  reference_id
 210                  <$> indexify reference_about
 211                 {-
 212                 st@State{state_collect=All{..}, ..} <- S.get
 213                 let targets = HM.lookupDefault Seq.empty reference_id all_reference
 214                 case toList targets of
 215                  [] -> undefined
 216                  [_] -> do
 217                  _ -> do
 218                         let err =
 219                                 HM.insertWith (flip (<>)) reference_id (pure reference_locTCT) $
 220                                 errors_reference_ambiguous state_errors
 221                         S.put st
 222                          { state_errors = state_errors
 223                                  { errors_reference_ambiguous = err }
 224                          }
 225                         about <- indexify reference_about
 226                         return $ Reference
 227                          { reference_error = Just $ ErrorAnchor_Ambiguous $ Nat1 $ length $ err HM.!reference_id
 228                          , reference_about = about
 229                          , .. }
 230                 -}
 231 instance Indexify Judges where
 232         indexify Judges{..} =
 233                 Judges
 234                  judges_locTCT
 235                  judges_posXML
 236                  judges_attrs
 237                  <$> traverse (traverse indexify) judges_byName
 238 instance Indexify [Grade] where
 239         indexify = traverse indexify
 240 instance Indexify Judgment where
 241         indexify Judgment{..} =
 242                 Judgment
 243                  judgment_opinionsByChoice
 244                  judgment_judges
 245                  judgment_grades
 246                  judgment_posXML
 247                  judgment_locTCT
 248                  judgment_judgesId
 249                  judgment_gradesId
 250                  judgment_importance
 251                  <$> traverse indexify judgment_question
 252                  <*> traverse indexify judgment_choices
 253 instance Indexify Choice where
 254         indexify Choice{..} =
 255                 Choice choice_locTCT  choice_posXML
 256                  <$> traverse indexify choice_title
 257                  <*> traverse indexify choice_opinions
 258 instance Indexify Opinion where
 259         indexify Opinion{..} =
 260                 Opinion
 261                  opinion_locTCT
 262                  opinion_posXML
 263                  opinion_judge
 264                  opinion_grade
 265                  opinion_importance
 266                  <$> traverse indexify opinion_comment
 267 instance Indexify Grade where
 268         indexify Grade{..} =
 269                 Grade
 270                  grade_posXML
 271                  grade_name
 272                  grade_color
 273                  grade_isDefault
 274                  <$> traverse indexify grade_title
 275 instance Indexify Judge where
 276         indexify Judge{..} =
 277                 Judge
 278                  judge_locTCT
 279                  judge_posXML
 280                  judge_name
 281                  <$> traverse indexify judge_title
 282                  <*> pure judge_defaultGrades
 283
 284 indexifyWords :: Words -> Compose (R.Reader Reader) (S.State IrefsByWords) Plain
 285 indexifyWords ws =
 286         Compose $ R.ask >>= \case
 287          ro -> pure $ go mempty ws
 288                 where
 289                 go :: Plain -> Words -> S.State IrefsByWords Plain
 290                 go acc inp =
 291                         case inp of
 292                          [] -> return acc
 293                          Space : next ->
 294                                 go (acc |> tree0 (PlainText " ")) next
 295                          Word w : next ->
 296                                 goWords [] inp >>= \case
 297                                  Nothing -> go (acc |> tree0 (PlainText w)) next
 298                                  Just (ls, ns) -> do
 299                                         let iref_term = List.reverse ls
 300                                         let lines = Seq.fromList $ tree0 . PlainText . plainifyWord <$> iref_term
 301                                         go (acc |> Tree PlainIref{iref_term} lines) ns
 302                 goWords ::
 303                  Words -> Words ->
 304                  S.State IrefsByWords (Maybe (Words, Words))
 305                 goWords prev inp = do
 306                         TM.TreeMap irefsByWord <- S.get
 307                         case inp of
 308                          [] -> return Nothing
 309                          curr@Space : next -> goWords (curr:prev) next
 310                          curr@(Word w) : next ->
 311                                 case Map.lookup w irefsByWord of
 312                                  Nothing -> return Nothing
 313                                  Just nod@TM.Node{..} -> do
 314                                         let prev' = curr:prev
 315                                         S.put node_descendants
 316                                         case node_value of
 317                                          Strict.Nothing
 318                                                 | null node_descendants -> return Nothing
 319                                                 | otherwise -> goWords prev' next
 320                                                  <* S.modify' (\rs -> TreeMap $ Map.insert w nod{TM.node_descendants = rs} irefsByWord)
 321                                          Strict.Just irefs ->
 322                                                 goWords prev' next >>= \case
 323                                                  Nothing -> do
 324                                                         S.put $ TM.TreeMap $
 325                                                                 Map.insert w
 326                                                                  nod{TM.node_value = Strict.Just $ reader_section ro Seq.<|irefs}
 327                                                                  irefsByWord
 328                                                         return $ Just (prev', next)
 329                                                  r@Just{} -> do
 330                                                         S.modify' $ \rs ->
 331                                                                 TM.TreeMap $ Map.insert w nod{TM.node_descendants = rs} irefsByWord
 332                                                         return r