]> Git — Sourcephile - doclang.git/blob - Hdoc/DTC/Index.hs
Add error support in HTML5.
[doclang.git] / 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