@@ -2,317 +2,103 @@ module Spago.Search.Index where
22
33import Prelude
44
5−import Spago.Search.DocsJson (ChildDeclType(..), ChildIndexEntry(..), DataDeclType, DeclType(..), Declarations(..), IndexEntry(..))
6−import Spago.Search.TypeDecoder (Constraint(..), FunDeps, Kind, QualifiedName(..), Type(..), TypeArgument)
7−import Spago.Search.TypeShape (ShapeChunk, joinForAlls, shapeOfType)
8−
9−import Control.Alt ((<|>))
10−import Data.Array ((!!))
11−import Data.Foldable (foldr)
5+import Spago.Search.Config (config)
6+import Spago.Search.SearchResult (SearchResult)
7+
8+import Control.Promise (Promise, toAffE)
9+import Data.Argonaut.Core (Json)
10+import Data.Argonaut.Decode (decodeJson)
11+import Data.Array as Array
12+import Data.Char as Char
13+import Data.Either (hush)
1214import Data.List (List, (:))
1315import Data.List as List
14−import Data.Maybe (Maybe(..), fromMaybe)
15−import Data.Newtype (class Newtype, unwrap, wrap)
16−import Data.Search.Trie (Trie, alter, entriesUnordered)
17−import Data.String.CodeUnits (stripPrefix, stripSuffix, toCharArray)
18−import Data.String.Common (toLower)
19−import Data.String.Common as String
20−import Data.String.Pattern (Pattern(..))
16+import Data.Map (Map)
17+import Data.Map as Map
18+import Data.Maybe (Maybe(..))
19+import Data.Newtype (class Newtype)
20+import Data.Search.Trie (Trie)
21+import Data.Search.Trie as Trie
22+import Data.String.CodeUnits as String
2123import Data.Tuple (Tuple(..))
24+import Effect (Effect)
25+import Effect.Aff (Aff, try)
2226
23−newtype SearchIndex
24− = SearchIndex { decls :: Trie Char (List SearchResult)
25− , types :: Trie ShapeChunk (List SearchResult)
26− }
27−
28−derive instance newtypeSearchIndex :: Newtype SearchIndex _
29−
30−data ResultInfo
31− = DataResult { typeArguments :: Array TypeArgument
32− , dataDeclType :: DataDeclType }
33− | ExternDataResult { kind :: Kind }
34− | TypeSynonymResult { arguments :: Array TypeArgument
35− , type :: Type }
36− | DataConstructorResult { arguments :: Array Type }
37− | TypeClassMemberResult { type :: Type
38− , typeClass :: QualifiedName
39− , typeClassArguments :: Array String }
40− | TypeClassResult { fundeps :: FunDeps
41− , arguments :: Array TypeArgument
42− , superclasses :: Array Constraint }
43− | ValueResult { type :: Type }
44− | ValueAliasResult
45− | TypeAliasResult
46− | ExternKindResult
47−
48−newtype SearchResult
49− = SearchResult { name :: String
50− , comments :: Maybe String
51− , hashAnchor :: String
52− , moduleName :: String
53− , packageName :: String
54− , sourceSpan :: Maybe { start :: Array Int
55− , end :: Array Int
56− , name :: String
57− }
58− , info :: ResultInfo
59− }
60−
61−derive instance newtypeSearchResult :: Newtype SearchResult _
27+newtype Index
28+ = Index (Map Int (Trie Char (List SearchResult)))
6229
63−mkSearchIndex :: Array Declarations -> SearchIndex
64−mkSearchIndex decls =
65− SearchIndex { decls: trie
66− , types
67− }
68− where
69− trie = foldr insertDeclarations mempty decls
70− types = foldr insertTypes mempty do
71− Tuple _ results <- entriesUnordered trie
72− result <- results
73− case (unwrap result).info of
74− ValueResult dict ->
75− insertTypeResultsFor dict.type result
76− TypeClassMemberResult dict ->
77− -- TODO: fix missing foralls for type class members
78− insertTypeResultsFor dict.type result
79−
80− TypeSynonymResult dict ->
81− insertTypeResultsFor dict.type result
82− _ -> mempty
30+derive instance newtypeIndex :: Newtype Index _
31+derive newtype instance semigroupIndex :: Semigroup Index
32+derive newtype instance monoidIndex :: Monoid Index
8333
84− insertTypeResultsFor ty result =
85− let path = shapeOfType ty in
86− pure $ Tuple path result
34+query
35+ :: Index
36+ -> String
37+ -> Aff { index :: Index, results :: Array SearchResult }
38+query index@(Index mp) input = do
39+ let
40+ path :: List Char
41+ path =
42+ List.fromFoldable $
43+ String.toCharArray $
44+ input
45+
46+ partId :: Int
47+ partId = getPartId path
48+
49+ case Map.lookup partId mp of
50+ Just trie ->
51+ pure { index, results: flatten $ Trie.queryValues path trie }
52+ Nothing -> do
53+
54+
55+ eiPartJson <-
56+ try $ toAffE $ loadIndex_ partId $ config.mkIndexPartLoadPath partId
57+
58+ let
59+ mbNewTrie :: Maybe (Trie Char (List SearchResult))
60+ mbNewTrie = do
61+ json <- hush eiPartJson
62+ results <- hush (decodeJson json) :: Maybe (Array (Tuple String (Array SearchResult)))
63+ pure $ Array.foldr insertResults mempty results
64+
65+ case mbNewTrie of
66+ Just trie -> do
67+ pure { index: Index $ Map.insert partId trie mp
68+ , results: flatten $ Trie.queryValues path trie
69+ }
70+ Nothing -> do
71+ pure { index, results: mempty }
8772
88−insertTypes
89− :: Tuple (List ShapeChunk) SearchResult
90− -> Trie ShapeChunk (List SearchResult)
91− -> Trie ShapeChunk (List SearchResult)
92−insertTypes (Tuple path result) trie =
93− alter path updateResults trie
9473 where
95− updateResults mbOldResults =
96− case mbOldResults of
97− Just oldResults ->
98− Just $ result : oldResults
99− Nothing ->
100− Just $ List.singleton result
74+ flatten = Array.concat <<< Array.fromFoldable <<< map Array.fromFoldable
10175
102−insertDeclarations
103− :: Declarations
76+insertResults
77+ :: Tuple String (Array SearchResult)
10478 -> Trie Char (List SearchResult)
10579 -> Trie Char (List SearchResult)
106−insertDeclarations (Declarations { name, declarations }) trie
107− = foldr (insertIndexEntry name) trie declarations
108−
109−insertIndexEntry
110− :: String
111− -> IndexEntry
112− -> Trie Char (List SearchResult)
113− -> Trie Char (List SearchResult)
114−insertIndexEntry moduleName entry@(IndexEntry { title }) trie
115− = foldr insertSearchResult trie (resultsForEntry moduleName entry)
116−
117−insertSearchResult
118− :: { path :: String
119− , result :: SearchResult
120− }
121− -> Trie Char (List SearchResult)
122− -> Trie Char (List SearchResult)
123−insertSearchResult { path, result } trie =
124− let path' = List.fromFoldable $ toCharArray $ toLower path in
125− alter path' updateResults trie
126− where
127− updateResults mbOldResults =
128− case mbOldResults of
129− Just oldResults ->
130− Just $ result : oldResults
131− Nothing ->
132− Just $ List.singleton result
133−
134−resultsForEntry
135− :: String
136− -> IndexEntry
137− -> List { path :: String
138− , result :: SearchResult
139− }
140−resultsForEntry moduleName indexEntry@(IndexEntry entry) =
141− let { info, title, sourceSpan, comments, children } = entry
142− { name, declLevel } = getLevelAndName info.declType title
143− packageName = extractPackageName sourceSpan.name
144− in case mkInfo declLevel indexEntry of
145− Nothing -> mempty
146− Just info' ->
147− let result = SearchResult { name: title
148− , comments
149− , hashAnchor: declLevelToHashAnchor declLevel
150− , moduleName
151− , sourceSpan: Just sourceSpan
152− , packageName
153− , info: info'
154− }
155− in
156− ( List.singleton $
157− { path: name
158− , result
159− }
160− ) <>
161− ( List.fromFoldable children >>=
162− resultsForChildIndexEntry packageName moduleName result
163− )
164−
165−mkInfo :: DeclLevel -> IndexEntry -> Maybe ResultInfo
166−mkInfo declLevel (IndexEntry { info, title }) =
167− case info.declType of
168−
169− DeclValue ->
170− info.type <#>
171− \ty -> ValueResult { type: ty }
172−
173− DeclData ->
174− make <$> info.typeArguments <*> info.dataDeclType
175− where
176− make typeArguments dataDeclType =
177− DataResult { typeArguments, dataDeclType }
178−
179− DeclExternData ->
180− info.kind <#>
181− \kind -> ExternDataResult { kind }
182−
183− DeclTypeSynonym ->
184− make <$> info.type <*> info.arguments
185− where
186− make ty args = TypeSynonymResult { type: ty, arguments: args }
187−
188− DeclTypeClass ->
189− case info.fundeps, info.arguments, info.superclasses of
190− Just fundeps, Just arguments, Just superclasses ->
191− Just $ TypeClassResult { fundeps, arguments, superclasses }
192− _, _, _ -> Nothing
193−
194− DeclAlias ->
195− case declLevel of
196− TypeLevel -> Just TypeAliasResult
197− ValueLevel -> Just ValueAliasResult
198− _ -> Nothing
199−
200− DeclExternKind ->
201− Just ExternKindResult
202−
203−-- | Level of a declaration, used to determine which URI hash anchor to use in
204−-- | links ("v", "t" or "k").
205−data DeclLevel = ValueLevel | TypeLevel | KindLevel
206−
207−declLevelToHashAnchor :: DeclLevel -> String
208−declLevelToHashAnchor = case _ of
209− ValueLevel -> "v"
210− TypeLevel -> "t"
211− KindLevel -> "k"
212−
213−getLevelAndName
214− :: DeclType
215− -> String
216− -> { declLevel :: DeclLevel
217− , name :: String
218− }
219−getLevelAndName DeclValue name = { name, declLevel: ValueLevel }
220−getLevelAndName DeclData name = { name, declLevel: TypeLevel }
221−getLevelAndName DeclTypeSynonym name = { name, declLevel: TypeLevel }
222−getLevelAndName DeclTypeClass name = { name, declLevel: ValueLevel }
223−-- "declType": "alias" does not specify the level of the declaration.
224−-- But for type aliases, name of the declaration is always wrapped into
225−-- "type (" and ")".
226−getLevelAndName DeclAlias title =
227− fromMaybe (withAnchor ValueLevel title) $
228− (withAnchor ValueLevel <$>
229− (stripPrefix (Pattern "(") >=>
230− stripSuffix (Pattern ")")) title) <|>
231− (withAnchor TypeLevel <$>
232− (stripPrefix (Pattern "type (") >=>
233− stripSuffix (Pattern ")")) title)
80+insertResults (Tuple path newResults) =
81+ Trie.alter pathList insert
23482 where
235− withAnchor declLevel name = { declLevel, name }
236−getLevelAndName DeclExternData name = { name, declLevel: TypeLevel }
237−getLevelAndName DeclExternKind name = { name, declLevel: KindLevel }
83+ pathList = List.fromFoldable $ String.toCharArray path
23884
239−-- | Extract package name from `sourceSpan.name`, which contains path to
240−-- | the source file.
241−extractPackageName :: String -> String
242−extractPackageName name =
243− let chunks = String.split (Pattern "/") name in
244− fromMaybe "<unknown>" $
245− chunks !! 0 >>= \dir ->
246− -- TODO: is it safe to assume that directory name is ".spago"?
247− if dir == ".spago" then
248− chunks !! 1
249− else
250− Just "<local package>"
251−
252−resultsForChildIndexEntry
253− :: String
254− -> String
255− -> SearchResult
256− -> ChildIndexEntry
257− -> List { path :: String, result :: SearchResult }
258−resultsForChildIndexEntry packageName moduleName parentResult
259− child@(ChildIndexEntry { title, info, comments, mbSourceSpan }) =
260− case mkChildInfo parentResult child of
261− Nothing -> mempty
262− Just resultInfo ->
263− { path: title
264− , result: SearchResult { name: title
265− , comments
266− , hashAnchor: "v"
267− , moduleName
268− , sourceSpan: mbSourceSpan
269− , packageName
270− , info: resultInfo
271− }
272− } # List.singleton
273−
274−mkChildInfo :: SearchResult -> ChildIndexEntry -> Maybe ResultInfo
275−mkChildInfo parentResult (ChildIndexEntry { info } ) =
276− case info.declType of
277− ChildDeclDataConstructor ->
278− info.arguments <#>
279− \arguments -> DataConstructorResult { arguments }
280− ChildDeclTypeClassMember ->
281− case (unwrap parentResult).info of
282− TypeClassResult { arguments } ->
283− -- We need to reconstruct a "real" type of a type class member.
284− -- For example, if `unconstrainedType` is the type of `pure`, i.e. `forall a. a -> m a`,
285− -- `restoredType` should be `forall m a. Control.Applicative.Applicative m => a -> m a`.
286− info.type <#>
287− \(unconstrainedType :: Type) ->
288− let
289− -- First, we get a list of nested `forall` quantifiers for `unconstrainedType`
290− -- and a version of `unconstrainedType` without them (`ty`).
291− { ty, binders } = joinForAlls unconstrainedType
292−
293− -- Then we construct a qualified name of the type class.
294− parentClassName =
295− QualifiedName { moduleName: String.split (wrap ".") (unwrap parentResult).moduleName
296− , name: (unwrap parentResult).name }
297−
298− typeClassArguments = arguments <#> unwrap >>> _.name
299−
300− -- We concatenate two lists:
301− -- * list of type parameters of the type class, and
302− -- * list of quantified variables of the unconstrained type
303− allArguments =
304− typeClassArguments <> (List.toUnfoldable binders <#> (_.var))
305−
306− restoredType =
307− foldr (\arg -> compose (\type'' -> ForAll arg type'' Nothing)) identity allArguments $
308− ConstrainedType (Constraint { constraintClass: parentClassName
309− , constraintArgs: typeClassArguments <#> TypeVar
310− }) ty
311−
312− in TypeClassMemberResult
313− { type: restoredType
314− , typeClass: parentClassName
315− , typeClassArguments
316− }
317− _ -> Nothing
318− ChildDeclInstance -> Nothing
85+ insert
86+ :: Maybe (List SearchResult)
87+ -> Maybe (List SearchResult)
88+ insert mbOldResults =
89+ case mbOldResults of
90+ Nothing -> Just $ List.fromFoldable newResults
91+ Just old -> Just $ List.fromFoldable newResults <> old
92+
93+-- | Find in which part of the index this path can be found.
94+getPartId :: List Char -> Int
95+getPartId (a : b : _) =
96+ (Char.toCharCode a + Char.toCharCode b) `mod` config.countOfIndexParts
97+getPartId (a : _) =
98+ Char.toCharCode a `mod` config.countOfIndexParts
99+getPartId _ = 0
100+
101+foreign import loadIndex_
102+ :: Int
103+ -> String
104+ -> Effect (Promise Json)