Search.icl 14.9 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
import Data.Maybe
19
import Data.Maybe.Ord
20
import Data.Tuple
21
from Database.Native import :: Entry{value}
22 23 24
from Text import class Text(concat,indexOf,toLowerCase,split),
	instance Text String, instance + String

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

import Clean.Doc

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

Camil Staps's avatar
Camil Staps committed
36 37 38 39 40 41
:: SearchStrategy
	= SSIdentity
	| SSName String
	| SSUnify Type
	| SSTypeName String
	| SSClassName String
42
	| SSUsing (*CloogleDB -> *CloogleDB) [String]
Camil Staps's avatar
Camil Staps committed
43 44 45 46 47 48 49 50 51 52 53 54
	| 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
55
searchStrategy (SSUsing f ns)  db = filterUsages f ns db
Camil Staps's avatar
Camil Staps committed
56 57
searchStrategy (SSAnd a b)     db = searchStrategy b $ searchStrategy a db

58 59 60 61 62 63 64 65 66 67
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]
68
	, ![(!CloogleEntry, ![Annotation])]
69 70 71
	, !*CloogleDB
	)
search` {unify,name,className,typeName,using,modules,libraries,page,include_builtins,include_core,include_apps} cdb
Camil Staps's avatar
Camil Staps committed
72 73 74 75
# 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
76 77 78 79 80 81 82
# 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
83
// Search strategy
Camil Staps's avatar
Camil Staps committed
84 85 86 87 88 89 90
# 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
91 92
# (alwaysUnique,cdb) = alwaysUniquePredicate cdb
# mbPreppedType = prepare_unification True alwaysUnique allsyns <$> (unify >>= parseType o fromString)
93
# usedsyns = 'Foldable'.concat (fst <$> mbPreppedType)
Camil Staps's avatar
Camil Staps committed
94 95 96
# mbType = snd <$> mbPreppedType
# strat = addStrategy (SSUnify <$> mbType) strat
// Usage search
97
# strat = addStrategy (SSUsing initfilter <$> using) strat
Camil Staps's avatar
Camil Staps committed
98 99
// Search and return results
# cdb = searchStrategy strat cdb
100
# cdb = removeContainedEntries cdb
Camil Staps's avatar
Camil Staps committed
101
# (es,cdb) = getEntries cdb
102 103 104 105 106
= (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
107
| isNothing fe.fe_type = (Nothing, usedsyns, Nothing, db)
108
# (alwaysUnique,db) = alwaysUniquePredicate db
109 110 111 112 113
# (usedsyns,fe_type) = appFst (flip (++) usedsyns) $ prep alwaysUnique $ fromJust fe.fe_type
# tvas = orgsearchtype >>= unify fe_type
| isNothing tvas = (Nothing, usedsyns, Nothing, db)
# tvas = fromJust tvas
# unif = finish_unification usedsyns tvas
114 115
// Required Context
# (ownContext,db) = ownContext fe db
116 117
# (required_context,db) = findContext ownContext fe_type tvas db
= (Just unif,usedsyns,required_context,db)
118
where
119 120
	prep alwaysUnique = prepare_unification False alwaysUnique allsyns

121 122 123
	ownContext :: FunctionEntry *CloogleDB -> *([TypeRestriction], *CloogleDB)
	ownContext fe db
	| isJust fe.fe_generic_vars =
124
		([Derivation (getName fe.fe_loc) (snd $ prep (const False) $ Var v) \\ v <- fromJust fe.fe_generic_vars], db)
125 126 127
	= case fe.fe_class of
		Nothing -> ([], db)
		Just ci -> let ({value=ClassEntry ce},db`) = getIndex ci db in
128
			([Instance (getName ce.ce_loc) (map (snd o prep (const False) o Var) ce.ce_vars)], db`)
129

130 131
	findContext :: [TypeRestriction] Type [TVAssignment] *CloogleDB -> *(Maybe [(String, [LocationResult])], *CloogleDB)
	findContext trs t tvas db
132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150
	# 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)
151 152 153 154 155 156 157 158 159 160 161
		uni = fmap (remove_var_prefixes o norm) o assignAll tvas
		where
			remove_var_prefixes :: !Type -> Type
			remove_var_prefixes (Var v)         = Var (v % (1,size v-1))
			remove_var_prefixes (Cons c ts)     = Cons (c % (1,size c-1)) (map remove_var_prefixes ts)
			remove_var_prefixes (Type t ts)     = Type t (map remove_var_prefixes ts)
			remove_var_prefixes (Func is r c)   = Func (map remove_var_prefixes is) (remove_var_prefixes r) c
			remove_var_prefixes (Uniq t)        = Uniq $ remove_var_prefixes t
			remove_var_prefixes (Forall vs t c) = Forall (map remove_var_prefixes vs) (remove_var_prefixes t) c
			remove_var_prefixes (Arrow mt)      = Arrow $ remove_var_prefixes <$> mt
			remove_var_prefixes (Strict t)      = Strict $ remove_var_prefixes t
162 163 164 165 166 167 168 169 170 171 172 173 174 175

		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)
176

177
makeResult :: !RankSettings !(Maybe Type) !(Map String [TypeDef]) ![TypeDef]
178
	!(!CloogleEntry, ![Annotation]) !*CloogleDB
179 180
	-> *(!Maybe Result, !*CloogleDB)
makeResult rsets orgsearchtype allsyns usedsyns (entry, annots) db
181 182
| entry =: (FunctionEntry _)
	# (FunctionEntry fe) = entry
Camil Staps's avatar
Camil Staps committed
183
	// Parent class
184 185 186 187
	# (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
188
	// Unifier
189
	# (unif,usedsyns,required_context,db) = unifyInformation orgsearchtype allsyns usedsyns fe db
190 191 192 193
	# annots = [RequiredContext required_context,UsedSynonyms (length usedsyns):annots]
	# annots = case unif of
		Just unif -> [Unifier unif:annots]
		Nothing   -> annots
194 195 196 197
	// 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
198
	= (Just $ FunctionResult (
Camil Staps's avatar
Camil Staps committed
199
		{ general
200
		& distance = distance rsets entry annots
Camil Staps's avatar
Camil Staps committed
201
		, documentation = docDescription =<< fe.fe_documentation
Camil Staps's avatar
Camil Staps committed
202
		},
203
		{ kind = fe.fe_kind
204
		, func = fromJust (fe.fe_representation <|> pure (concat $ print False (name,fe)))
Camil Staps's avatar
Camil Staps committed
205 206
		, unifier = toStrUnifier <$> unif
		, required_context = required_context
207
		, cls = cls
Camil Staps's avatar
Camil Staps committed
208 209 210 211 212 213
		, 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
214 215
		, 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
216
		, param_doc = map toString <$> docParams <$> fe.fe_documentation
Camil Staps's avatar
Camil Staps committed
217 218 219
		, generic_var_doc = docVars <$> fe.fe_documentation
		, result_doc = docResults <$> fe.fe_documentation
		, type_doc = concat <$> print False <$> (docType =<< fe.fe_documentation)
220
		, throws_doc = docThrows <$> fe.fe_documentation
221
		}), db)
Camil Staps's avatar
Camil Staps committed
222 223 224 225 226 227 228 229 230 231 232 233 234 235
	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)

236 237
| entry =: (TypeDefEntry _)
	# (TypeDefEntry tde) = entry
Camil Staps's avatar
Camil Staps committed
238
	# (insts,db) = getIndices tde.tde_instances db
239
	# (derivs,db) = getIndices tde.tde_derivations db
Camil Staps's avatar
Camil Staps committed
240
	= (Just $ TypeResult (
Camil Staps's avatar
Camil Staps committed
241 242 243
		{ general
		& documentation = docDescription =<< tde.tde_doc
		},
244
		{ type = concat $ print False tde.tde_typedef
Camil Staps's avatar
Camil Staps committed
245 246 247
		, type_instances = sortBy ((<) `on` fst3)
			[(ie.ie_class, map snd ie.ie_types, map locResult ie.ie_locations)
			\\ {value=InstanceEntry ie} <- insts]
248 249
		, type_derivations = sortBy ((<) `on` fst)
			[(de.de_generic, map locResult de.de_locations) \\ {value=DeriveEntry de} <- derivs]
Camil Staps's avatar
Camil Staps committed
250 251 252
		, type_field_doc          = docFields =<< tde.tde_doc
		, type_constructor_doc    = map ((=<<) docDescription) <$> (docConstructors =<< tde.tde_doc)
		, type_representation_doc = join (docRepresentation =<< tde.tde_doc)
253
		}), db)
Camil Staps's avatar
Camil Staps committed
254

255 256
| entry =: (ModuleEntry _)
	# (ModuleEntry me) = entry
Camil Staps's avatar
Camil Staps committed
257
	= (Just $ ModuleResult (
Camil Staps's avatar
Camil Staps committed
258 259 260
		{ general
		& documentation = docDescription =<< me.me_documentation
		},
Camil Staps's avatar
Camil Staps committed
261
		{ module_is_core = me.me_is_core
262
		}), db)
Camil Staps's avatar
Camil Staps committed
263

264 265
| entry =: (ClassEntry _)
	# (ClassEntry ce) = entry
Camil Staps's avatar
Camil Staps committed
266
	# (ies,db) = getIndices ce.ce_instances db
Camil Staps's avatar
Camil Staps committed
267
	# (mems,db) = getIndices ce.ce_members db
Camil Staps's avatar
Camil Staps committed
268
	= (Just $ ClassResult (
Camil Staps's avatar
Camil Staps committed
269 270 271
		{ general
		& documentation = docDescription =<< ce.ce_documentation
		},
272 273 274
		{ 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
275
		, class_funs = [fromJust fe.fe_representation \\ {value=FunctionEntry fe} <- mems]
276
		, class_fun_doc = Just [printDoc <$> fe.fe_documentation \\ {value=FunctionEntry fe} <- mems]
Camil Staps's avatar
Camil Staps committed
277 278 279
		, class_instances = sortBy ((<) `on` fst)
			[(map snd ie.ie_types, map locResult ie.ie_locations)
				\\ {value=InstanceEntry ie} <- ies]
280
		}), db)
Camil Staps's avatar
Camil Staps committed
281

Camil Staps's avatar
Camil Staps committed
282 283
| entry =: (SyntaxEntry _)
	# (SyntaxEntry se) = entry
Camil Staps's avatar
Camil Staps committed
284
	= (Just $ SyntaxResult (
Camil Staps's avatar
Camil Staps committed
285
		{ general
Camil Staps's avatar
Camil Staps committed
286
		& documentation = Just se.syntax_description
Camil Staps's avatar
Camil Staps committed
287 288 289 290 291 292
		},
		{ 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
293 294 295 296 297 298 299 300 301 302 303

| 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
304 305
| otherwise // InstanceEntry / DeriveEntry cannot be returned
	= (Nothing, db)
306
where
307
	mbLoc = getLocation entry
308
	name = getName $ fromJust mbLoc
309 310 311 312 313 314
	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
315
		, name     = fromMaybe "" (getName <$> mbLoc)
316
		, distance = distance rsets entry annots
Camil Staps's avatar
Camil Staps committed
317 318 319
		, builtin  = case mbLoc of
			Just (Builtin _ _) -> Just True
			_                  -> Nothing
Camil Staps's avatar
Camil Staps committed
320 321 322 323
		, documentation = Nothing // Added after pattern match on Entry type
		, langrep_documentation = case mbLoc of
			Just (Builtin _ d) -> Just d
			_                  -> Nothing
324 325
		}

326 327 328
searchWithSuggestions :: !RankSettings !Request !*CloogleDB -> *([Result], [(Request,[Result])], *CloogleDB)
searchWithSuggestions rsets req db
# (res,db) = search rsets req db
329 330 331 332 333 334 335 336 337 338 339 340 341 342 343
# (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
344
				-> appFst (filter enough) $ mapSt (\r -> appFst (tuple r) o search rsets r o resetDB) reqs db
345 346 347 348 349 350 351 352 353 354 355 356 357 358
				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`
359
				-> appFst (\res -> [(req,res)]) $ search rsets req $ resetDB db
360 361 362 363 364 365 366 367 368 369 370 371 372 373 374
					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
375
		| isJust orgreq.unify = ([], db) // unification search can be slow
376 377
		| fromMaybe DEFAULT_INCLUDE_APPS orgreq.include_apps == DEFAULT_INCLUDE_APPS
			# req = {orgreq & include_apps=Just (not DEFAULT_INCLUDE_APPS)}
378
			# (res,db) = search rsets req $ resetDB db
379 380 381 382 383 384 385 386
			| 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
387 388 389
locResult :: Location -> LocationResult
locResult (Location lib mod filename dcl icl _) = (lib,mod,filename,dcl,icl)

390
isModMatch :: ![String] Location -> Bool
Camil Staps's avatar
Camil Staps committed
391 392
isModMatch mods (Location _ mod _ _ _ _) = isMember mod mods
isModMatch _    (Builtin _ _)            = False
393 394

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