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, listToMaybe)
  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 (anchor, ls, ns, rs) ->
  70                                 let iref_term = List.reverse ls in
  71                                 let lines = Seq.fromList $ tree0 . PlainText . plainifyWord <$> iref_term in
  72                                 go (acc |> Tree PlainIref
  73                                  { iref_term
  74                                  , iref_anchor=Just anchor
  75                                  } lines) rs ns
  76         goWords ::
  77          Irefs ->
  78          Words -> Words ->
  79          Maybe (Anchor, Words, Words, Irefs)
  80         goWords m@(TreeMap irefsByWord) prev inp =
  81                 case inp of
  82                  [] -> Nothing
  83                  curr@Space : next -> goWords m (curr:prev) next
  84                  curr@(Word w) : next ->
  85                         case Map.lookup w irefsByWord of
  86                          Nothing -> Nothing
  87                          Just nod@TreeMap.Node{..} ->
  88                                 let prev' = curr:prev in
  89                                 case node_value of
  90                                  Strict.Nothing
  91                                   | null node_descendants -> Nothing
  92                                   | otherwise ->
  93                                         (<$> goWords node_descendants prev' next) $ \(anch, ls, ns, rs) ->
  94                                                 (anch, ls, ns, TreeMap $
  95                                                         Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
  96                                  Strict.Just anchs ->
  97                                         case goWords node_descendants prev' next of
  98                                          Nothing ->
  99                                                 let anch = Anchor
 100                                                          { anchor_count   = maybe def (succNat1 . anchor_count) $ listToMaybe anchs
 101                                                          , anchor_section = section } in
 102                                                 Just (anch, prev', next, TreeMap $
 103                                                         Map.insert w nod{TreeMap.node_value = Strict.Just $ anch:anchs} irefsByWord)
 104                                          Just (anch, ls, ns, rs) ->
 105                                                 Just (anch, ls, ns, TreeMap $
 106                                                         Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
 107
 108 wordify :: TL.Text -> Words
 109 wordify = List.reverse . go []
 110         where
 111         go :: Words -> TL.Text -> Words
 112         go acc t =
 113                 case TL.span Char.isAlphaNum t of
 114                  ("",_) ->
 115                         case TL.span Char.isSpace t of
 116                          ("",_) ->
 117                                 case TL.uncons t of
 118                                  Nothing -> acc
 119                                  Just (c,r) -> go (Word (TL.singleton c) : acc) r
 120                          (_s,r) -> go (Space : acc) r
 121                  (w,r) -> go (Word w : acc) r
 122
 123 plainifyWord :: WordOrSpace -> TL.Text
 124 plainifyWord = \case
 125  Word w -> w
 126  Space  -> " "
 127
 128 plainifyWords :: Words -> TL.Text
 129 plainifyWords = TL.concat . (plainifyWord <$>)
 130
 131 termsByChar :: Terms -> Map Char Terms
 132 termsByChar =
 133         foldr (\aliases acc ->
 134                 case aliases of
 135                  (Word w:_):_ | not (TL.null w) ->
 136                         Map.insertWith (<>)
 137                          (Char.toUpper $ TL.index w 0)
 138                          [aliases] acc
 139                  _ -> acc
 140                 ) Map.empty