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 import qualified Hdoc.XML as XML
  34
  35 -- * Type 'PathWord'
  36 type PathWord = TreeMap.Path Word
  37
  38 pathFromWords :: Words -> Maybe PathWord
  39 pathFromWords ws =
  40         case ws >>= unSpace of
  41          p:ps | not (TL.null p) -> Just (TreeMap.path p ps)
  42          _ -> Nothing
  43         where
  44         unSpace = \case
  45          Space  -> []
  46          Word w -> [w]
  47
  48 -- * Type 'Irefs'
  49 type Irefs = TreeMap Word [Anchor]
  50
  51 irefsOfTerms :: Terms -> Irefs
  52 irefsOfTerms = TreeMap.fromList const . (>>= f) . concat
  53         where
  54         f [] = []
  55         f ws = maybe [] (\p -> [(p,[])]) $ pathFromWords ws
  56
  57 indexifyWords :: XML.Pos -> Irefs -> Words -> (Irefs, Plain)
  58 indexifyWords section = go mempty
  59         where
  60         go :: Plain -> Irefs -> Words -> (Irefs, Plain)
  61         go acc irefs inp =
  62                 case inp of
  63                  [] -> (irefs, acc)
  64                  Space : next ->
  65                         go (acc |> tree0 (PlainText " ")) irefs next
  66                  Word w : next ->
  67                         case goWords irefs [] inp of
  68                          Nothing -> go (acc |> tree0 (PlainText w)) irefs next
  69                          Just (anch, ls, ns, rs) ->
  70                                 let term = List.reverse ls in
  71                                 let lines = Seq.fromList $ tree0 . PlainText . plainifyWord <$> term in
  72                                 go (acc |> Tree PlainIref{term, anchor=Just anch} lines) rs ns
  73         goWords ::
  74          Irefs ->
  75          Words -> Words ->
  76          Maybe (Anchor, Words, Words, Irefs)
  77         goWords m@(TreeMap irefsByWord) prev inp =
  78                 case inp of
  79                  [] -> Nothing
  80                  curr@Space : next -> goWords m (curr:prev) next
  81                  curr@(Word w) : next ->
  82                         case Map.lookup w irefsByWord of
  83                          Nothing -> Nothing
  84                          Just nod@TreeMap.Node{..} ->
  85                                 let prev' = curr:prev in
  86                                 case node_value of
  87                                  Strict.Nothing
  88                                   | null node_descendants -> Nothing
  89                                   | otherwise ->
  90                                         (<$> goWords node_descendants prev' next) $ \(anch, ls, ns, rs) ->
  91                                                 (anch, ls, ns, TreeMap $
  92                                                         Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
  93                                  Strict.Just anchs ->
  94                                         case goWords node_descendants prev' next of
  95                                          Nothing ->
  96                                                 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c in
  97                                                 let anch  = Anchor{count, section} in
  98                                                 Just (anch, prev', next, TreeMap $
  99                                                         Map.insert w nod{TreeMap.node_value = Strict.Just $ anch:anchs} irefsByWord)
 100                                          Just (anch, ls, ns, rs) ->
 101                                                 Just (anch, ls, ns, TreeMap $
 102                                                         Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
 103
 104 wordify :: TL.Text -> Words
 105 wordify = List.reverse . go []
 106         where
 107         go :: Words -> TL.Text -> Words
 108         go acc t =
 109                 case TL.span Char.isAlphaNum t of
 110                  ("",_) ->
 111                         case TL.span Char.isSpace t of
 112                          ("",_) ->
 113                                 case TL.uncons t of
 114                                  Nothing -> acc
 115                                  Just (c,r) -> go (Word (TL.singleton c) : acc) r
 116                          (_s,r) -> go (Space : acc) r
 117                  (w,r) -> go (Word w : acc) r
 118
 119 plainifyWord :: WordOrSpace -> TL.Text
 120 plainifyWord = \case
 121  Word w -> w
 122  Space  -> " "
 123
 124 plainifyWords :: Words -> TL.Text
 125 plainifyWords = TL.concat . (plainifyWord <$>)
 126
 127 termsByChar :: Terms -> Map Char Terms
 128 termsByChar =
 129         foldr (\aliases acc ->
 130                 case aliases of
 131                  (Word w:_):_ | not (TL.null w) ->
 132                         Map.insertWith (<>)
 133                          (Char.toUpper $ TL.index w 0)
 134                          [aliases] acc
 135                  _ -> acc
 136                 ) Map.empty