Hdoc/DTC/Index.hs

   1 {-# LANGUAGE DuplicateRecordFields #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Hdoc.DTC.Index where
   7
   8 import Control.Category
   9 import Control.Monad (Monad(..))
  10 import Data.Bool
  11 import Data.Char (Char)
  12 import Data.Default.Class (Default(..))
  13 import Data.Foldable (Foldable(..), concat)
  14 import Data.Function (($), const)
  15 import Data.Functor ((<$>))
  16 import Data.Map.Strict (Map)
  17 import Data.Maybe (Maybe(..), maybe)
  18 import Data.Monoid (Monoid(..))
  19 import Data.Semigroup (Semigroup(..))
  20 import Data.Sequence ((|>))
  21 import Data.TreeMap.Strict (TreeMap(..))
  22 import Data.TreeSeq.Strict (Tree(..), tree0)
  23 import qualified Data.Char as Char
  24 import qualified Data.List as List
  25 import qualified Data.Map.Strict as Map
  26 import qualified Data.Sequence as Seq
  27 import qualified Data.Strict.Maybe as Strict
  28 import qualified Data.Text.Lazy as TL
  29 import qualified Data.TreeMap.Strict as TreeMap
  30 -- import qualified Data.TreeSeq.Strict as TreeSeq
  31
  32 import Hdoc.DTC.Document
  33
  34 -- * Type 'PathWord'
  35 type PathWord = TreeMap.Path Word
  36
  37 pathFromWords :: Words -> Maybe PathWord
  38 pathFromWords ws =
  39         case ws >>= unSpace of
  40          p:ps | not (TL.null p) -> Just (TreeMap.path p ps)
  41          _ -> Nothing
  42         where
  43         unSpace = \case
  44          Space  -> []
  45          Word w -> [w]
  46
  47 -- * Type 'Irefs'
  48 type Irefs = TreeMap Word [Anchor]
  49
  50 irefsOfTerms :: Terms -> Irefs
  51 irefsOfTerms = TreeMap.fromList const . (>>= f) . concat
  52         where
  53         f [] = []
  54         f ws = maybe [] (\p -> [(p,[])]) $ pathFromWords ws
  55
  56 indexifyWords :: XmlPos -> Irefs -> Words -> (Irefs, Plain)
  57 indexifyWords section = go mempty
  58         where
  59         go :: Plain -> Irefs -> Words -> (Irefs, Plain)
  60         go acc irefs inp =
  61                 case inp of
  62                  [] -> (irefs, acc)
  63                  Space : next ->
  64                         go (acc |> tree0 (PlainText " ")) irefs next
  65                  Word w : next ->
  66                         case goWords irefs [] inp of
  67                          Nothing -> go (acc |> tree0 (PlainText w)) irefs next
  68                          Just (anch, ls, ns, rs) ->
  69                                 let term = List.reverse ls in
  70                                 let lines = Seq.fromList $ tree0 . PlainText . plainifyWord <$> term in
  71                                 go (acc |> Tree PlainIref{term, anchor=Just anch} lines) rs ns
  72         goWords ::
  73          Irefs ->
  74          Words -> Words ->
  75          Maybe (Anchor, Words, Words, Irefs)
  76         goWords m@(TreeMap irefsByWord) prev inp =
  77                 case inp of
  78                  [] -> Nothing
  79                  curr@Space : next -> goWords m (curr:prev) next
  80                  curr@(Word w) : next ->
  81                         case Map.lookup w irefsByWord of
  82                          Nothing -> Nothing
  83                          Just nod@TreeMap.Node{..} ->
  84                                 let prev' = curr:prev in
  85                                 case node_value of
  86                                  Strict.Nothing
  87                                   | null node_descendants -> Nothing
  88                                   | otherwise ->
  89                                         (<$> goWords node_descendants prev' next) $ \(anch, ls, ns, rs) ->
  90                                                 (anch, ls, ns, TreeMap $
  91                                                         Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
  92                                  Strict.Just anchs ->
  93                                         case goWords node_descendants prev' next of
  94                                          Nothing ->
  95                                                 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c in
  96                                                 let anch  = Anchor{count, section} in
  97                                                 Just (anch, prev', next, TreeMap $
  98                                                         Map.insert w nod{TreeMap.node_value = Strict.Just $ anch:anchs} irefsByWord)
  99                                          Just (anch, ls, ns, rs) ->
 100                                                 Just (anch, ls, ns, TreeMap $
 101                                                         Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
 102
 103 wordify :: TL.Text -> Words
 104 wordify = List.reverse . go []
 105         where
 106         go :: Words -> TL.Text -> Words
 107         go acc t =
 108                 case TL.span Char.isAlphaNum t of
 109                  ("",_) ->
 110                         case TL.span Char.isSpace t of
 111                          ("",_) ->
 112                                 case TL.uncons t of
 113                                  Nothing -> acc
 114                                  Just (c,r) -> go (Word (TL.singleton c) : acc) r
 115                          (_s,r) -> go (Space : acc) r
 116                  (w,r) -> go (Word w : acc) r
 117
 118 plainifyWord :: WordOrSpace -> TL.Text
 119 plainifyWord = \case
 120  Word w -> w
 121  Space  -> " "
 122
 123 plainifyWords :: Words -> TL.Text
 124 plainifyWords = TL.concat . (plainifyWord <$>)
 125
 126 termsByChar :: Terms -> Map Char Terms
 127 termsByChar =
 128         foldr (\aliases acc ->
 129                 case aliases of
 130                  (Word w:_):_ | not (TL.null w) ->
 131                         Map.insertWith (<>)
 132                          (Char.toUpper $ TL.index w 0)
 133                          [aliases] acc
 134                  _ -> acc
 135                 ) Map.empty