Verified Commit 196fee32 authored by Camil Staps's avatar Camil Staps 🚀

Add support for symbolic ranking (cloogle-org#215)

parent 3ba4b669
......@@ -50,9 +50,9 @@ import Cloogle.API
instance == AnnotationKey
where
== NGramDistance NGramDistance = True
== UnifierSize UnifierSize = True
== _ _ = False
== NGramDistance k = k=:NGramDistance
== UnifierSize k = k=:UnifierSize
== ExactResult k = k=:ExactResult
derive gLexOrd AnnotationKey
instance < AnnotationKey where < a b = (a =?= b) === LT
......
......@@ -4,9 +4,14 @@ definition module Cloogle.Search
* Search functions for the Cloogle system
*/
from Clean.Types import :: TypeDef, :: Type, :: Unifier
from Database.Native import :: NativeDB
from Cloogle.API import :: Request, :: Result
from Cloogle.DB import :: CloogleDB, :: AnnotationKey, :: CloogleEntry
from Data.Map import :: Map
from Data.Maybe import :: Maybe
from Cloogle.API import :: Request, :: Result, :: LocationResult
from Cloogle.DB import :: CloogleDB, :: AnnotationKey, :: CloogleEntry, :: FunctionEntry
from Cloogle.Search.Rank import :: RankSettings
/**
* Cloogle setting: whether to include language builtins if the Request has
......@@ -29,10 +34,21 @@ DEFAULT_INCLUDE_APPS :== False
/**
* Search for a request in the type database
*/
search :: !Request !*CloogleDB -> *([Result], *CloogleDB)
search :: !RankSettings !Request !*CloogleDB -> *([Result], *CloogleDB)
search` :: !Request !*CloogleDB ->
*(!Maybe Type
, !(Map String [TypeDef])
, ![TypeDef]
, ![(!CloogleEntry, !Map AnnotationKey Int)]
, !*CloogleDB
)
unifyInformation :: !(Maybe Type) !(Map String [TypeDef]) ![TypeDef] !FunctionEntry !*CloogleDB
-> *(!Maybe Unifier, ![TypeDef], !Maybe [(!String, ![LocationResult])], !*CloogleDB)
/**
* Search for a request, and also make suggestions for similar requests with
* better results.
*/
searchWithSuggestions :: !Request !*CloogleDB -> *([Result], [(Request,[Result])], *CloogleDB)
searchWithSuggestions :: !RankSettings !Request !*CloogleDB -> *([Result], [(Request,[Result])], *CloogleDB)
......@@ -30,6 +30,7 @@ import Clean.Doc
import Cloogle.API
import Cloogle.DB
import Cloogle.Search.Rank
:: SearchStrategy
= SSIdentity
......@@ -53,8 +54,20 @@ searchStrategy (SSClassName n) db = filterDB (\ce->ce=:(ClassEntry _)) $ filterE
searchStrategy (SSUsing f ns) db = filterUsages f ns db
searchStrategy (SSAnd a b) db = searchStrategy b $ searchStrategy a db
search :: !Request !*CloogleDB -> *([Result], *CloogleDB)
search {unify,name,className,typeName,using,modules,libraries,page,include_builtins,include_core,include_apps} cdb
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]
, ![(!CloogleEntry, !Map AnnotationKey Int)]
, !*CloogleDB
)
search` {unify,name,className,typeName,using,modules,libraries,page,include_builtins,include_core,include_apps} cdb
# include_builtins = fromMaybe DEFAULT_INCLUDE_BUILTINS include_builtins
# include_core = fromMaybe DEFAULT_INCLUDE_CORE include_core
# include_apps = fromMaybe DEFAULT_INCLUDE_APPS include_apps
......@@ -76,7 +89,7 @@ search {unify,name,className,typeName,using,modules,libraries,page,include_built
# (allsyns,cdb) = allTypeSynonyms cdb
# (alwaysUnique,cdb) = alwaysUniquePredicate cdb
# mbPreppedType = prepare_unification True alwaysUnique allsyns <$> (unify >>= parseType o fromString)
# usedSynonyms = 'Foldable'.concat (fst <$> mbPreppedType)
# usedsyns = 'Foldable'.concat (fst <$> mbPreppedType)
# mbType = snd <$> mbPreppedType
# strat = addStrategy (SSUnify <$> mbType) strat
// Usage search
......@@ -85,13 +98,70 @@ search {unify,name,className,typeName,using,modules,libraries,page,include_built
# cdb = searchStrategy strat cdb
# cdb = removeContainedEntries cdb
# (es,cdb) = getEntries cdb
# (es,cdb) = mapSt (makeResult mbType allsyns usedSynonyms) es cdb
= (sort $ catMaybes es, cdb)
= (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)
makeResult :: (Maybe Type) (Map String [TypeDef]) [TypeDef]
(CloogleEntry, Map AnnotationKey Int) *CloogleDB
-> *(Maybe Result, *CloogleDB)
makeResult orgsearchtype allsyns usedsyns (entry, annots) db
makeResult :: !RankSettings !(Maybe Type) !(Map String [TypeDef]) ![TypeDef]
!(!CloogleEntry, !Map AnnotationKey Int) !*CloogleDB
-> *(!Maybe Result, !*CloogleDB)
makeResult rsets orgsearchtype allsyns usedsyns (entry, annots) db
| entry =: (FunctionEntry _)
# (FunctionEntry fe) = entry
// Parent class
......@@ -100,24 +170,14 @@ makeResult orgsearchtype allsyns usedsyns (entry, annots) 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)
// Unifier
# (alwaysUnique,db) = alwaysUniquePredicate db
# unif = prepare_unification False alwaysUnique allsyns <$> fe.fe_type >>= \(syns,type) ->
finish_unification (syns ++ 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) = unifyInformation orgsearchtype allsyns usedsyns fe db
// Derivations
# (derivs,db) = case fe.fe_derivations of
Nothing -> (Nothing, db)
Just ds -> appFst Just $ getIndices ds db
= (Just $ FunctionResult (
{ general
& distance = kindPenalty fe.fe_kind $ general.distance + sum
[ fromMaybe 0 $ contextPenalty <$> required_context
, fromMaybe 0 $ 'M'.get UnifierSize annots
, length usedsyns
]
& distance = distance rsets entry annots (Just {tri_used_synonyms=usedsyns,tri_required_context=required_context})
, documentation = docDescription =<< fe.fe_documentation
},
{ kind = fe.fe_kind
......@@ -153,64 +213,6 @@ makeResult orgsearchtype allsyns usedsyns (entry, annots) db
where
toStr (var, type) = (var, concat $ print False type)
kindPenalty :: FunctionKind Int -> Int
kindPenalty k d = toInt $ penalty * toReal d
where
penalty = case k of
RecordField -> further 0.2
Constructor -> further 0.1
_ -> 1.0
further s = if (d < 0) (1.0 - s) (1.0 + s)
contextPenalty :: [(String, [LocationResult])] -> Int
contextPenalty required_context = length [0 \\ (_,[]) <- required_context]
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)
| entry =: (TypeDefEntry _)
# (TypeDefEntry tde) = entry
# (insts,db) = getIndices tde.tde_instances db
......@@ -291,7 +293,7 @@ where
, dcl_line = getDclLine =<< mbLoc
, icl_line = getIclLine =<< mbLoc
, name = fromMaybe "" (getName <$> mbLoc)
, distance = distance
, distance = distance rsets entry annots Nothing
, builtin = case mbLoc of
Just (Builtin _ _) -> Just True
_ -> Nothing
......@@ -300,13 +302,10 @@ where
Just (Builtin _ d) -> Just d
_ -> Nothing
}
distance =
fromMaybe 0 ('M'.get NGramDistance annots) -
1000 * fromMaybe 0 ('M'.get ExactResult annots)
searchWithSuggestions :: !Request !*CloogleDB -> *([Result], [(Request,[Result])], *CloogleDB)
searchWithSuggestions req db
# (res,db) = search req db
searchWithSuggestions :: !RankSettings !Request !*CloogleDB -> *([Result], [(Request,[Result])], *CloogleDB)
searchWithSuggestions rsets req db
# (res,db) = search rsets req db
# (suggs,db) = suggestions req res db
= (res,suggs,db)
where
......@@ -322,7 +321,7 @@ where
swap db = case orgtype of
Just (Func is r cc) | length is < 3
-> appFst (filter enough) $ mapSt (\r -> appFst (tuple r) o search r o resetDB) reqs db
-> appFst (filter enough) $ mapSt (\r -> appFst (tuple r) o search rsets r o resetDB) reqs db
with
reqs = [{orgreq & unify=Just $ concat $ print False $ Func is` r cc}
\\ is` <- permutations is | is` <> is]
......@@ -337,7 +336,7 @@ where
capitalize db = case t` of
Just t` | fromJust orgtype <> t`
-> appFst (\res -> [(req,res)]) $ search req $ resetDB db
-> appFst (\res -> [(req,res)]) $ search rsets req $ resetDB db
with req = {orgreq & unify=Just $ concat $ print False t`}
_ -> ([], db)
where
......@@ -356,7 +355,7 @@ where
| isJust orgreq.unify = ([], db) // unification search can be slow
| fromMaybe DEFAULT_INCLUDE_APPS orgreq.include_apps == DEFAULT_INCLUDE_APPS
# req = {orgreq & include_apps=Just (not DEFAULT_INCLUDE_APPS)}
# (res,db) = search req $ resetDB db
# (res,db) = search rsets req $ resetDB db
| isEmpty res = ([], db)
| isEmpty orgresults = ([(req,res)], db)
# orghddistance = (fromJust (getBasicResult (hd orgresults))).distance
......
definition module Cloogle.Search.Rank
from Clean.Types import :: TypeDef
from Data.Map import :: Map
from Data.Maybe import :: Maybe
from Cloogle.API import :: Request, :: LocationResult, :: FunctionKind
from Cloogle.DB import :: AnnotationKey, :: CloogleEntry, :: CloogleDB
:: TypeRankInfo =
{ tri_required_context :: !Maybe [(String, [LocationResult])]
, tri_used_synonyms :: ![TypeDef]
}
/**
* A rank is computed as the weighted sum of various metrics. The coefficients
* are given by this record.
*/
:: RankSettings =
{ rs_ngram_distance :: !Real //* n-gram distance
, rs_exact_result :: !Real //* results with an exact match
, rs_record_field :: !Real //* record fields
, rs_constructor :: !Real //* constructors
, rs_unifier_size :: !Real //* large unifiers
, rs_used_synonyms :: !Real //* the number of synonyms required
, rs_resolved_context :: !Real //* class contexts with known instances
, rs_unresolved_context :: !Real //* class contexts without known instances
}
/**
* This record is the same as {{`RankSettings`}}, but the members are
* interpreted as the values rather than the weights.
*/
:: RankInformation :== RankSettings
distance :: !RankSettings !CloogleEntry !(Map AnnotationKey Int) !(Maybe TypeRankInfo) -> Int
symbolicDistance :: !CloogleEntry !(Map AnnotationKey Int) !(Maybe TypeRankInfo) -> RankInformation
:: RankConstraint
= LT !UniqueResultIdentifier !UniqueResultIdentifier //* arg1 should have lower distance than arg2
/**
* @representation module name and name of element
*/
:: UniqueResultIdentifier :== (!String, !String)
/**
* Generate Z3 constraints based on a set of constraints on the order of
* results for queries.
*/
rankConstraints :: ![(Request, RankConstraint)] !*CloogleDB -> *([String], *CloogleDB)
implementation module Cloogle.Search.Rank
import StdBool
import StdInt
import StdList
import StdMisc
import StdReal
import StdString
import Clean.Types
from Data.Func import $
import Data.Functor
from Data.List import foldr1
import qualified Data.Map as M
import Data.Maybe
import Data.Tuple
import Text
import Cloogle.API
import Cloogle.DB
import Cloogle.Search
distance :: !RankSettings !CloogleEntry !(Map AnnotationKey Int) !(Maybe TypeRankInfo) -> Int
distance settings entry annots tri = let info = symbolicDistance entry annots tri in toInt $
settings.rs_ngram_distance * info.rs_ngram_distance +
settings.rs_exact_result * info.rs_exact_result +
settings.rs_record_field * info.rs_record_field +
settings.rs_constructor * info.rs_constructor +
settings.rs_unifier_size * info.rs_unifier_size +
settings.rs_used_synonyms * info.rs_used_synonyms +
settings.rs_resolved_context * info.rs_resolved_context +
settings.rs_unresolved_context * info.rs_unresolved_context
symbolicDistance :: !CloogleEntry !(Map AnnotationKey Int) !(Maybe TypeRankInfo) -> RankInformation
symbolicDistance entry annots tri =
{ rs_ngram_distance = fromMaybe 0.0 $ toReal <$> 'M'.get NGramDistance annots
, rs_exact_result = fromMaybe 0.0 $ toReal <$> 'M'.get ExactResult annots
, rs_record_field = case entry of FunctionEntry {fe_kind=k=:RecordField} -> 1.0; _ -> 0.0
, rs_constructor = case entry of FunctionEntry {fe_kind=k=:Constructor} -> 1.0; _ -> 0.0
, rs_unifier_size = fromMaybe 0.0 $ toReal <$> 'M'.get UnifierSize annots
, rs_used_synonyms = case tri of Nothing -> 0.0; Just tri -> toReal $ length tri.tri_used_synonyms
, rs_resolved_context = resolved_context
, rs_unresolved_context = unresolved_context
}
where
(resolved_context,unresolved_context) = case tri of
Just {tri_required_context=Just rc}
-> let (res,unres) = context_sizes 0 0 rc in (toReal res,toReal unres)
-> (0.0,0.0)
where
context_sizes :: !Int !Int ![(String,[LocationResult])] -> (!Int, !Int)
context_sizes res unres [(_,locs):rest]
| locs=:[] = context_sizes res (unres+1) rest
| otherwise = context_sizes (res+1) unres rest
context_sizes res unres [] = (res,unres)
match :: !UniqueResultIdentifier !CloogleEntry -> Bool
match (mod,name) ce = case getLocation ce of
Just (Location _ cemod _ _ _ cename) -> mod == cemod && name == cename
Just (Builtin cename _) -> mod == "_builtin" && name == cename
_ -> abort "error in match of UniqueResultIdentifier\n"
rankConstraints :: ![(Request, RankConstraint)] !*CloogleDB -> *([String], *CloogleDB)
rankConstraints constraints db
# (constraints,db) = findConstraints constraints db
= (default ++ constraints,db)
where
default =
[ "(declare-const rs_ngram_distance Real)"
, "(declare-const rs_exact_result Real)"
, "(declare-const rs_record_field Real)"
, "(declare-const rs_constructor Real)"
, "(declare-const rs_unifier_size Real)"
, "(declare-const rs_used_synonyms Real)"
, "(declare-const rs_resolved_context Real)"
, "(declare-const rs_unresolved_context Real)"
]
findConstraints :: ![(Request, RankConstraint)] !*CloogleDB -> *([String], *CloogleDB)
findConstraints [(req,LT urid1 urid2):rest] cdb
# (orgsearchtype,allsyns,usedsyns,entries,cdb) = search` req cdb
# (e1,annots1) = case filter (\(e,_) -> match urid1 e) entries of
[e1:[]] -> e1
[] -> abort "no match for URID 1\n"
_ -> abort "too many matches for URID 1\n"
# (e2,annots2) = case filter (\(e,_) -> match urid2 e) entries of
[e2:[]] -> e2
[] -> abort "no match for URID 2\n"
_ -> abort "too many matches for URID 2\n"
# (ri1,cdb) = case e1 of
FunctionEntry fe
# (unif,usedsyns,required_context,cdb) = unifyInformation orgsearchtype allsyns usedsyns fe cdb
-> (symbolicDistance e1 annots1 (Just {tri_used_synonyms=usedsyns,tri_required_context=required_context}), cdb)
_ -> (symbolicDistance e1 annots1 Nothing, cdb)
# (ri2,cdb) = case e2 of
FunctionEntry fe
# (unif,usedsyns,required_context,cdb) = unifyInformation orgsearchtype allsyns usedsyns fe cdb
-> (symbolicDistance e2 annots2 (Just {tri_used_synonyms=usedsyns,tri_required_context=required_context}), cdb)
_ -> (symbolicDistance e2 annots2 Nothing, cdb)
# this = "(assert (< (" +++ formula ri1 +++ ") (" +++ formula ri2 +++ ")))"
# cdb = resetDB cdb
# (rest,cdb) = findConstraints rest cdb
= ([this:rest],cdb)
where
formula :: !RankInformation -> String
formula ri = sum
[ "* rs_ngram_distance " <+ ri.rs_ngram_distance
, "* rs_exact_result " <+ ri.rs_exact_result
, "* rs_record_field " <+ ri.rs_record_field
, "* rs_constructor " <+ ri.rs_constructor
, "* rs_unifier_size " <+ ri.rs_unifier_size
, "* rs_used_synonyms " <+ ri.rs_used_synonyms
, "* rs_resolved_context " <+ ri.rs_resolved_context
, "* rs_unresolved_context " <+ ri.rs_unresolved_context
]
where
sum :: [String] -> String
sum [t] = t
sum [t:ts]
# s = sum ts
= "+ (" +++ t +++ ") (" +++ s +++ ")"
findConstraints [] cdb = ([],cdb)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment