Search.icl 14 KB
Newer Older
1
implementation module Cloogle.Search
2 3 4 5 6 7 8 9 10 11 12 13

import StdArray
import StdBool
from StdFunc import const, id, flip, o
import StdList
import StdOrdList
import StdString
import StdTuple

import Control.Applicative
import Control.Monad
import qualified Data.Foldable as Foldable
Camil Staps's avatar
Camil Staps committed
14
from Data.Func import $, on, `on`, instance Functor ((->) r), mapSt
15 16
import Data.Functor
import Data.List
17
import qualified Data.Map as M
18 19
import Data.Maybe
import Data.Tuple
20
from Database.Native import :: Entry{value}
21 22 23
from Text import class Text(concat,indexOf,toLowerCase,split),
	instance Text String, instance + String

24 25 26 27 28 29 30 31 32
import Clean.Types
import Clean.Types.Parse
import Clean.Types.Unify
import Clean.Types.Util

import Clean.Doc

import Cloogle.API
import Cloogle.DB
33
import Cloogle.Search.Rank
34

Camil Staps's avatar
Camil Staps committed
35 36 37 38 39 40
:: SearchStrategy
	= SSIdentity
	| SSName String
	| SSUnify Type
	| SSTypeName String
	| SSClassName String
41
	| SSUsing (*CloogleDB -> *CloogleDB) [String]
Camil Staps's avatar
Camil Staps committed
42 43 44 45 46 47 48 49 50 51 52 53
	| SSAnd SearchStrategy SearchStrategy

addStrategy :: (Maybe SearchStrategy) SearchStrategy -> SearchStrategy
addStrategy Nothing  strat = strat
addStrategy (Just s) strat = SSAnd strat s

searchStrategy :: !SearchStrategy !*CloogleDB -> *CloogleDB
searchStrategy SSIdentity      db = db
searchStrategy (SSName n)      db = filterName n db
searchStrategy (SSUnify t)     db = filterUnifying t db
searchStrategy (SSTypeName  n) db = filterDB (\ce->ce=:(TypeDefEntry _))  $ filterExactName n db
searchStrategy (SSClassName n) db = filterDB (\ce->ce=:(ClassEntry _)) $ filterExactName n db
54
searchStrategy (SSUsing f ns)  db = filterUsages f ns db
Camil Staps's avatar
Camil Staps committed
55 56
searchStrategy (SSAnd a b)     db = searchStrategy b $ searchStrategy a db

57 58 59 60 61 62 63 64 65 66
search :: !RankSettings !Request !*CloogleDB -> *([Result], *CloogleDB)
search rsets req cdb
# (mbType,allsyns,usedsyns,entries,cdb) = search` req cdb
# (es,cdb) = mapSt (makeResult rsets mbType allsyns usedsyns) entries cdb
= (sort $ catMaybes es, cdb)

search` :: !Request !*CloogleDB ->
	*(!Maybe Type
	, !(Map String [TypeDef])
	, ![TypeDef]
67
	, ![(!CloogleEntry, ![Annotation])]
68 69 70
	, !*CloogleDB
	)
search` {unify,name,className,typeName,using,modules,libraries,page,include_builtins,include_core,include_apps} cdb
Camil Staps's avatar
Camil Staps committed
71 72 73 74
# include_builtins = fromMaybe DEFAULT_INCLUDE_BUILTINS include_builtins
# include_core = fromMaybe DEFAULT_INCLUDE_CORE include_core
# include_apps = fromMaybe DEFAULT_INCLUDE_APPS include_apps
// Initial filters
75 76 77 78 79 80 81
# initfilter =
	if include_core id excludeCore o
	if include_apps id excludeApps o
	(case libraries of Just ls -> filterLibraries ls; Nothing -> id) o
	(case modules   of Just ms -> filterModules   ms; Nothing -> id) o
	if include_builtins includeBuiltins excludeBuiltins
# cdb = initfilter cdb
Camil Staps's avatar
Camil Staps committed
82
// Search strategy
Camil Staps's avatar
Camil Staps committed
83 84 85 86 87 88 89
# strat = SSIdentity
// Name search
# strat = addStrategy (SSName <$> name) strat
# strat = addStrategy (SSTypeName <$> typeName) strat
# strat = addStrategy (SSClassName <$> className) strat
// Unification search
# (allsyns,cdb) = allTypeSynonyms cdb
90 91
# (alwaysUnique,cdb) = alwaysUniquePredicate cdb
# mbPreppedType = prepare_unification True alwaysUnique allsyns <$> (unify >>= parseType o fromString)
92
# usedsyns = 'Foldable'.concat (fst <$> mbPreppedType)
Camil Staps's avatar
Camil Staps committed
93 94 95
# mbType = snd <$> mbPreppedType
# strat = addStrategy (SSUnify <$> mbType) strat
// Usage search
96
# strat = addStrategy (SSUsing initfilter <$> using) strat
Camil Staps's avatar
Camil Staps committed
97 98
// Search and return results
# cdb = searchStrategy strat cdb
99
# cdb = removeContainedEntries cdb
Camil Staps's avatar
Camil Staps committed
100
# (es,cdb) = getEntries cdb
101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159
= (mbType,allsyns,usedsyns,es,cdb)

unifyInformation :: !(Maybe Type) !(Map String [TypeDef]) ![TypeDef] !FunctionEntry !*CloogleDB
	-> *(!Maybe Unifier, ![TypeDef], !Maybe [(!String, ![LocationResult])], !*CloogleDB)
unifyInformation orgsearchtype allsyns usedsyns fe db
# (alwaysUnique,db) = alwaysUniquePredicate db
# fe_type = prepare_unification False alwaysUnique allsyns <$> fe.fe_type
# usedsyns = case fe_type of Nothing -> usedsyns; Just (syns,_) -> syns ++ usedsyns
# unif = fe_type >>= \(_,type) -> finish_unification usedsyns <$> (orgsearchtype >>= unify type)
// Required Context
# (ownContext,db) = ownContext fe db
# (required_context,db) = fromMaybe (tuple Nothing) (liftA2 (findContext ownContext) fe.fe_type unif) db
= (unif,usedsyns,required_context,db)
where
	ownContext :: FunctionEntry *CloogleDB -> *([TypeRestriction], *CloogleDB)
	ownContext fe db
	| isJust fe.fe_generic_vars =
		([Derivation (getName fe.fe_loc) (Var v) \\ v <- fromJust fe.fe_generic_vars], db)
	= case fe.fe_class of
		Nothing -> ([], db)
		Just ci -> let ({value=ClassEntry ce},db`) = getIndex ci db in
			([Instance (getName ce.ce_loc) (map Var ce.ce_vars)], db`)

	findContext :: [TypeRestriction] Type Unifier *CloogleDB -> *(Maybe [(String, [LocationResult])], *CloogleDB)
	findContext trs t unif db
	# trs = removeDup (concatMap applyUnifToTR (getTC t ++ trs))
	= appFst Just $
		mapSt (\tr -> appFst (tuple (concat $ print False tr) o map locResult) o findLocations tr) trs db
	where
		getTC :: Type -> TypeContext
		getTC (Func _ _ tc)   = tc
		getTC (Forall _ _ tc) = tc
		getTC _               = []

		applyUnifToTR :: TypeRestriction -> [TypeRestriction]
		applyUnifToTR (Instance c ts) = maybeToList $ Instance c <$> mapM uni ts
		applyUnifToTR (Derivation g t)
		| any isFunc subts = [Derivation g (Arrow Nothing):derivs]
		| otherwise        = derivs
		where
			subts = [st \\ ut <- maybeToList (uni t), st <- subtypes ut]
			derivs = [Derivation g (Type st []) \\ Type st _ <- subts]

		uni :: (Type -> Maybe Type)
		uni = fmap norm o assignAll (map fromUnifyingAssignment unif.assignments)

		norm :: (Type -> Type)
		norm = snd o resolve_synonyms allsyns

		findLocations :: TypeRestriction *CloogleDB -> *([Location], *CloogleDB)
		findLocations (Instance c ts) db
		# (ies,db) = getInstances c db
		= (removeDup $ flatten
			[ ie.ie_locations \\ ie <- ies
			| and [norm t1 generalises t2 \\ t1 <- map fst ie.ie_types & t2 <- ts]], db)
		findLocations (Derivation g t) db
		# (des,db) = getDerivations g db
		= (removeDup $ flatten
			[de.de_locations \\ de <- des | norm de.de_type generalises t], db)
160

161
makeResult :: !RankSettings !(Maybe Type) !(Map String [TypeDef]) ![TypeDef]
162
	!(!CloogleEntry, ![Annotation]) !*CloogleDB
163 164
	-> *(!Maybe Result, !*CloogleDB)
makeResult rsets orgsearchtype allsyns usedsyns (entry, annots) db
165 166
| entry =: (FunctionEntry _)
	# (FunctionEntry fe) = entry
Camil Staps's avatar
Camil Staps committed
167
	// Parent class
168 169 170 171
	# (cls,db) = case fe.fe_class of
		Nothing -> (Nothing, db)
		Just i  -> case getIndex i db of
			({value=ClassEntry ce}, db) -> (Just {cls_name=getName ce.ce_loc, cls_vars=ce.ce_vars}, db)
Camil Staps's avatar
Camil Staps committed
172
	// Unifier
173
	# (unif,usedsyns,required_context,db) = unifyInformation orgsearchtype allsyns usedsyns fe db
174 175 176 177
	# annots = [RequiredContext required_context,UsedSynonyms (length usedsyns):annots]
	# annots = case unif of
		Just unif -> [Unifier unif:annots]
		Nothing   -> annots
178 179 180 181
	// Derivations
	# (derivs,db) = case fe.fe_derivations of
		Nothing -> (Nothing, db)
		Just ds -> appFst Just $ getIndices ds db
Camil Staps's avatar
Camil Staps committed
182
	= (Just $ FunctionResult (
Camil Staps's avatar
Camil Staps committed
183
		{ general
184
		& distance = distance rsets entry annots
Camil Staps's avatar
Camil Staps committed
185
		, documentation = docDescription =<< fe.fe_documentation
Camil Staps's avatar
Camil Staps committed
186
		},
187
		{ kind = fe.fe_kind
188
		, func = fromJust (fe.fe_representation <|> pure (concat $ print False (name,fe)))
Camil Staps's avatar
Camil Staps committed
189 190
		, unifier = toStrUnifier <$> unif
		, required_context = required_context
191
		, cls = cls
Camil Staps's avatar
Camil Staps committed
192 193 194 195 196 197
		, constructor_of = case fe.fe_kind of
			Constructor -> let (Just (Func _ r _)) = fe.fe_type in Just $ concat $ print False r
			_           -> Nothing
		, recordfield_of = case fe.fe_kind of
			RecordField -> let (Just (Func [t:_] _ _)) = fe.fe_type in Just $ concat $ print False t
			_           -> Nothing
198 199
		, generic_derivations = sortBy ((<) `on` fst) <$>
			map (\{value=DeriveEntry de} -> (de.de_type_representation, map locResult de.de_locations)) <$> derivs
Camil Staps's avatar
Camil Staps committed
200
		, param_doc = map toString <$> docParams <$> fe.fe_documentation
Camil Staps's avatar
Camil Staps committed
201 202 203
		, generic_var_doc = docVars <$> fe.fe_documentation
		, result_doc = docResults <$> fe.fe_documentation
		, type_doc = concat <$> print False <$> (docType =<< fe.fe_documentation)
204
		, throws_doc = docThrows <$> fe.fe_documentation
205
		}), db)
Camil Staps's avatar
Camil Staps committed
206 207 208 209 210 211 212 213 214 215 216 217 218 219
	with
		toStrUnifier :: Unifier -> StrUnifier
		toStrUnifier unif =
			{ StrUnifier
			| left_to_right = map toStr [a \\ LeftToRight a <- unif.assignments]
			, right_to_left = map toStr [a \\ RightToLeft a <- unif.assignments]
			, used_synonyms = [
				( concat $ [td.td_name," ":intersperse " " $ print False td.td_args]
				, concat $ print False s)
				\\ td=:{td_rhs=TDRSynonym s} <- unif.Unifier.used_synonyms]
			}
		where
			toStr (var, type) = (var, concat $ print False type)

220 221
| entry =: (TypeDefEntry _)
	# (TypeDefEntry tde) = entry
Camil Staps's avatar
Camil Staps committed
222
	# (insts,db) = getIndices tde.tde_instances db
223
	# (derivs,db) = getIndices tde.tde_derivations db
Camil Staps's avatar
Camil Staps committed
224
	= (Just $ TypeResult (
Camil Staps's avatar
Camil Staps committed
225 226 227
		{ general
		& documentation = docDescription =<< tde.tde_doc
		},
228
		{ type = concat $ print False tde.tde_typedef
Camil Staps's avatar
Camil Staps committed
229 230 231
		, type_instances = sortBy ((<) `on` fst3)
			[(ie.ie_class, map snd ie.ie_types, map locResult ie.ie_locations)
			\\ {value=InstanceEntry ie} <- insts]
232 233
		, type_derivations = sortBy ((<) `on` fst)
			[(de.de_generic, map locResult de.de_locations) \\ {value=DeriveEntry de} <- derivs]
Camil Staps's avatar
Camil Staps committed
234 235 236
		, type_field_doc          = docFields =<< tde.tde_doc
		, type_constructor_doc    = map ((=<<) docDescription) <$> (docConstructors =<< tde.tde_doc)
		, type_representation_doc = join (docRepresentation =<< tde.tde_doc)
237
		}), db)
Camil Staps's avatar
Camil Staps committed
238

239 240
| entry =: (ModuleEntry _)
	# (ModuleEntry me) = entry
Camil Staps's avatar
Camil Staps committed
241
	= (Just $ ModuleResult (
Camil Staps's avatar
Camil Staps committed
242 243 244
		{ general
		& documentation = docDescription =<< me.me_documentation
		},
Camil Staps's avatar
Camil Staps committed
245
		{ module_is_core = me.me_is_core
246
		}), db)
Camil Staps's avatar
Camil Staps committed
247

248 249
| entry =: (ClassEntry _)
	# (ClassEntry ce) = entry
Camil Staps's avatar
Camil Staps committed
250
	# (ies,db) = getIndices ce.ce_instances db
Camil Staps's avatar
Camil Staps committed
251
	# (mems,db) = getIndices ce.ce_members db
Camil Staps's avatar
Camil Staps committed
252
	= (Just $ ClassResult (
Camil Staps's avatar
Camil Staps committed
253 254 255
		{ general
		& documentation = docDescription =<< ce.ce_documentation
		},
256 257 258
		{ class_name = name
		, class_heading = foldl ((+) o (flip (+) " ")) name ce.ce_vars +
			if (isEmpty ce.ce_context) "" " | " + concat (print False ce.ce_context)
Camil Staps's avatar
Camil Staps committed
259
		, class_funs = [fromJust fe.fe_representation \\ {value=FunctionEntry fe} <- mems]
260
		, class_fun_doc = Just [printDoc <$> fe.fe_documentation \\ {value=FunctionEntry fe} <- mems]
Camil Staps's avatar
Camil Staps committed
261 262 263
		, class_instances = sortBy ((<) `on` fst)
			[(map snd ie.ie_types, map locResult ie.ie_locations)
				\\ {value=InstanceEntry ie} <- ies]
264
		}), db)
Camil Staps's avatar
Camil Staps committed
265

Camil Staps's avatar
Camil Staps committed
266 267
| entry =: (SyntaxEntry _)
	# (SyntaxEntry se) = entry
Camil Staps's avatar
Camil Staps committed
268
	= (Just $ SyntaxResult (
Camil Staps's avatar
Camil Staps committed
269
		{ general
Camil Staps's avatar
Camil Staps committed
270
		& documentation = Just se.syntax_description
Camil Staps's avatar
Camil Staps committed
271 272 273 274 275 276
		},
		{ SyntaxResultExtras
		| syntax_title    = se.SyntaxEntry.syntax_title
		, syntax_code     = se.SyntaxEntry.syntax_code
		, syntax_examples = se.SyntaxEntry.syntax_examples
		}), db)
Camil Staps's avatar
Camil Staps committed
277 278 279 280 281 282 283 284 285 286 287

| entry =: (ABCInstructionEntry _)
	# (ABCInstructionEntry aie) = entry
	= (Just $ ABCInstructionResult (
		{ general
		& documentation = Just aie.aie_description
		},
		{ abc_instruction = aie.aie_instruction
		, abc_arguments   = aie.aie_arguments
		}), db)

Camil Staps's avatar
Camil Staps committed
288 289
| otherwise // InstanceEntry / DeriveEntry cannot be returned
	= (Nothing, db)
290
where
291
	mbLoc = getLocation entry
292
	name = getName $ fromJust mbLoc
293 294 295 296 297 298
	general =
		{ library  = fromMaybe "" (getLibrary =<< mbLoc)
		, modul    = fromMaybe "" (getModule =<< mbLoc)
		, filename = fromMaybe "" (getFilename =<< mbLoc)
		, dcl_line = getDclLine =<< mbLoc
		, icl_line = getIclLine =<< mbLoc
Camil Staps's avatar
Camil Staps committed
299
		, name     = fromMaybe "" (getName <$> mbLoc)
300
		, distance = distance rsets entry annots
Camil Staps's avatar
Camil Staps committed
301 302 303
		, builtin  = case mbLoc of
			Just (Builtin _ _) -> Just True
			_                  -> Nothing
Camil Staps's avatar
Camil Staps committed
304 305 306 307
		, documentation = Nothing // Added after pattern match on Entry type
		, langrep_documentation = case mbLoc of
			Just (Builtin _ d) -> Just d
			_                  -> Nothing
308 309
		}

310 311 312
searchWithSuggestions :: !RankSettings !Request !*CloogleDB -> *([Result], [(Request,[Result])], *CloogleDB)
searchWithSuggestions rsets req db
# (res,db) = search rsets req db
313 314 315 316 317 318 319 320 321 322 323 324 325 326 327
# (suggs,db) = suggestions req res db
= (res,suggs,db)
where
	suggestions :: !Request ![Result] !*CloogleDB -> *([(Request, [Result])], *CloogleDB)
	suggestions {page=Just n} _ db | n > 0 = ([], db)
	suggestions orgreq orgresults db
	# (swapped, db)     = swap db
	# (capitalized, db) = capitalize db
	# (withapps, db)    = addapps db
	= (flatten [swapped, capitalized, withapps], db)
	where
		orgtype = orgreq.unify >>= parseType o fromString

		swap db = case orgtype of
			Just (Func is r cc) | length is < 3
328
				-> appFst (filter enough) $ mapSt (\r -> appFst (tuple r) o search rsets r o resetDB) reqs db
329 330 331 332 333 334 335 336 337 338 339 340 341 342
				with
					reqs = [{orgreq & unify=Just $ concat $ print False $ Func is` r cc}
						\\ is` <- permutations is | is` <> is]
			_ -> ([], db)
		where
			enough :: (Request, [Result]) -> Bool
			enough (_, res) = enough` (length orgresults) res
			where
				enough` 0 _      = True
				enough` _ []     = False
				enough` n [_:xs] = enough` (n-1) xs

		capitalize db = case t` of
			Just t` | fromJust orgtype <> t`
343
				-> appFst (\res -> [(req,res)]) $ search rsets req $ resetDB db
344 345 346 347 348 349 350 351 352 353 354 355 356 357 358
					with req = {orgreq & unify=Just $ concat $ print False t`}
			_                 -> ([], db)
		where
			t` = assignAll
				[ ("int",     Type "Int" [])
				, ("bool",    Type "Bool" [])
				, ("char",    Type "Char" [])
				, ("real",    Type "Real" [])
				, ("file",    Type "File" [])
				, ("string",  Type "String" [])
				, ("dynamic", Type "Dynamic" [])
				, ("world",   Uniq (Type "World" []))
				] =<< orgtype

		addapps db
359
		| isJust orgreq.unify = ([], db) // unification search can be slow
360 361
		| fromMaybe DEFAULT_INCLUDE_APPS orgreq.include_apps == DEFAULT_INCLUDE_APPS
			# req = {orgreq & include_apps=Just (not DEFAULT_INCLUDE_APPS)}
362
			# (res,db) = search rsets req $ resetDB db
363 364 365 366 367 368 369 370
			| isEmpty res = ([], db)
			| isEmpty orgresults = ([(req,res)], db)
			# orghddistance = (fromJust (getBasicResult (hd orgresults))).distance
			| all (\r -> (fromJust (getBasicResult r)).distance < orghddistance) $ take 3 res
				= ([(req,res)], db)
				= ([], db)
		| otherwise = ([], db)

Camil Staps's avatar
Camil Staps committed
371 372 373
locResult :: Location -> LocationResult
locResult (Location lib mod filename dcl icl _) = (lib,mod,filename,dcl,icl)

374
isModMatch :: ![String] Location -> Bool
Camil Staps's avatar
Camil Staps committed
375 376
isModMatch mods (Location _ mod _ _ _ _) = isMember mod mods
isModMatch _    (Builtin _ _)            = False
377 378

isLibMatch :: ![String] Location -> Bool
379
isLibMatch libs (Location lib _ _ _ _ _) = isMember lib libs
Camil Staps's avatar
Camil Staps committed
380
isLibMatch _    (Builtin _ _)            = True