Commit 524e88d5 authored by Camil Staps's avatar Camil Staps
Browse files

Put back type search

parent 4c096b3d
......@@ -17,13 +17,15 @@ from Cloogle import :: FunctionKind, :: SyntaxExample, :: CleanLangReportLocatio
from Doc import :: FunctionDoc, :: TypeDoc, :: ClassDoc, :: ModuleDoc
from DB import :: DB, :: Entry, :: Index
from NGramIndex import :: NGramIndex
from TypeTree import :: TypeTree
/**
* A storage for function types, class definitions, type definitions, etc.
*/
:: *CloogleDB =
{ db :: *DB CloogleEntry AnnotationKey Annotation
, name_ngrams :: NGramIndex Index
{ db :: !*DB CloogleEntry AnnotationKey Annotation
, name_ngrams :: !NGramIndex Index
, types :: !TypeTree Index
, module_index :: !Map Location Index
}
......@@ -206,7 +208,9 @@ getIndex :: !Index !*CloogleDB -> *(Entry CloogleEntry AnnotationKey Annotation,
filterDB :: (CloogleEntry -> Bool) !*CloogleDB -> *CloogleDB
filterLocations :: (Location -> Bool) !*CloogleDB -> *CloogleDB
filterName :: !String !*CloogleDB -> *CloogleDB
filterUnifying :: !Type !*CloogleDB -> *CloogleDB
allModules :: !*CloogleDB -> *([ModuleEntry], *CloogleDB)
allTypeDefs :: !*CloogleDB -> *([TypeDefEntry], *CloogleDB)
getEntries :: !*CloogleDB -> *([(CloogleEntry, Map AnnotationKey Annotation)], *CloogleDB)
......@@ -229,10 +229,11 @@ syncDB :: !Int !*CloogleDB -> *CloogleDB
syncDB _ db = db
saveDB :: *CloogleDB *File -> *(*CloogleDB, *File)
saveDB wrapper=:{db,module_index,name_ngrams} f
saveDB wrapper=:{db,module_index,name_ngrams,types} f
# (db,f) = 'DB'.saveDB db f
# f = write module_index f
# f = write name_ngrams f
# f = write types f
= ({wrapper & db=db}, f)
where
write :: a *File -> *File | JSONEncode{|*|} a
......@@ -246,10 +247,13 @@ openDB f
| not ok = (Nothing, f)
# ((ok,name_ngrams),f) = appFst isJustU $ read f
| not ok = (Nothing, f)
# ((ok,types),f) = appFst isJustU $ read f
| not ok = (Nothing, f)
= (Just
{ db=fromJust db
, module_index=fromJust module_index
, name_ngrams=fromJust name_ngrams
, types=fromJust types
}
, f
)
......@@ -282,13 +286,25 @@ filterName s wrap=:{db,name_ngrams}
# db = 'DB'.searchIndices indices db
= {wrap & db=db}
where
indices = [(i,MatchingNGrams,NGrams n) \\ (i,n) <- 'NGrams'.search s name_ngrams]
indices = [(i,[(MatchingNGrams,NGrams n)]) \\ (i,n) <- 'NGrams'.search s name_ngrams]
filterUnifying :: !Type !*CloogleDB -> *CloogleDB
filterUnifying t wrap=:{db,types}
# db = 'DB'.searchIndices idxs db
= {wrap & db=db}
where
idxs = [(idx,[]) \\ idx <- sort $ findUnifying t types]
allModules :: !*CloogleDB -> *([ModuleEntry], *CloogleDB)
allModules wrap=:{db,module_index}
# (mods,db) = getIndices (elems module_index) db
= ([me \\ {value=ModuleEntry me} <- mods], {wrap & db=db})
allTypeDefs :: !*CloogleDB -> *([TypeDefEntry], *CloogleDB)
allTypeDefs wrap=:{db}
# (es,db) = 'DB'.allEntries db
= ([tde \\ TypeDefEntry tde <- es], {wrap & db=db})
getEntries :: !*CloogleDB -> *([(CloogleEntry, Map AnnotationKey Annotation)], *CloogleDB)
getEntries wrap=:{db}
# (es,db) = 'DB'.getEntries db
......
......@@ -65,6 +65,7 @@ from DB import :: DB, :: Index(..), newDB, instance == Index
import qualified DB
import qualified CloogleDB as CDB
from NGramIndex import :: NGramIndex, newNGramIndex, index
from TypeTree import :: TypeTree, instance zero (TypeTree v), addType
from CloogleDB import
:: CloogleDB{..}, :: Annotation, :: AnnotationKey,
:: Location(Location,NoLocation),
......@@ -113,10 +114,14 @@ finaliseDb tdb
# db = newDB entries
# (names,db) = collectNames db
# name_ngrams = foldr (uncurry index) (newNGramIndex 3 True) names
= { db = db
, module_index = 'M'.newMap
, name_ngrams = name_ngrams
}
=
{ db = db
, module_index = 'M'.newMap
, name_ngrams = name_ngrams
, types = foldr (uncurry addType) zero
[(snd $ 'T'.prepare_unification False (map 'CDB'.getTypeDef typedefs) $ 'T'.removeTypeContexts t,i)
\\ (i,FunctionEntry fe) <- entridxs, Just t <- [fe.fe_type <|> (docType =<< fe.fe_documentation)]]
}
where
collectNames = 'DB'.scan (\i v ivs -> case 'CDB'.getLocation v of
Nothing -> ivs
......@@ -124,7 +129,7 @@ where
entries =
[FunctionEntry fun \\ funs <- tdb.temp_functions, fun <- funs] ++
[TypeDefEntry td \\ tds <- tdb.temp_types, td <- tds] ++
map TypeDefEntry typedefs ++
[ModuleEntry mod \\ mod <- tdb.temp_modules] ++
[ClassEntry cls \\ clss <- tdb.temp_classes, (cls,funs) <- clss] ++
[FunctionEntry
......@@ -136,8 +141,10 @@ where
_ -> False
}
\\ clss <- tdb.temp_classes, (cls,funs) <- clss, (fname,fun) <- funs]
entridxs = zip2 (indexList entries) entries
idxhd f = hd [Index idx \\ (idx,e) <- entridxs | f e]
entridxs = zip2 [Index i \\ i <- [0..]] entries
idxhd f = hd [idx \\ (idx,e) <- entridxs | f e]
typedefs = [td \\ tds <- tdb.temp_types, td <- tds]
// Exclude Root Library Aux Base module
findModules :: ![String] !String !'CDB'.Library !a !String !*World
......
......@@ -42,6 +42,6 @@ getEntries :: *(DB v ak a) -> *([(v, Map ak a)], *DB v ak a)
mapInPlace :: (v -> v) *(DB v ak a) -> *(DB v ak a)
scan :: (Index v t -> t) t *(DB v ak a) -> *(t, *(DB v ak a))
search :: (v -> (Bool, [(ak, a)])) *(DB v ak a) -> *DB v ak a | ==, < ak
searchIndices :: ![(!Index, !ak, !a)] !*(DB v ak a) -> *DB v ak a | ==, < ak
searchIndices :: ![(!Index, ![(!ak, !a)])] !*(DB v ak a) -> *DB v ak a | ==, < ak
getIndex :: !Index !*(DB v ak a) -> *(!Entry v ak a, !*(DB v ak a))
getIndices :: ![Index] !*(DB v ak a) -> *(![Entry v ak a], !*(DB v ak a))
......@@ -26,16 +26,15 @@ saveDB :: *(DB v ak a) *File -> *(*DB v ak a, *File) | JSONEncode{|*|} v
saveDB (DB db) f
# (s,db) = usize db
# f = f <<< toString s <<< "\n"
# (db,f) = loop 0 db f
# (db,f) = loop 0 (s-1) db f
= (DB db, f)
where
loop :: !Int !*{!Entry v ak a} !*File -> *(*{!Entry v ak a}, !*File) | JSONEncode{|*|} v
loop i es f
# (s,es) = usize es
| i >= s = (es,f)
loop :: !Int !Int !*{!Entry v ak a} !*File -> *(*{!Entry v ak a}, !*File) | JSONEncode{|*|} v
loop i s es f
| i > s = (es,f)
# (e,es) = es![i]
# f = f <<< toJSON e.value <<< '\n'
= loop (i+1) es f
= loop (i+1) s es f
openDB :: !*File -> *(!Maybe (*DB v ak a), !*File) | JSONDecode{|*|} v
openDB f
......@@ -126,22 +125,22 @@ where
, annotations=foldr (uncurry put) e.annotations annotations
}}
searchIndices :: ![(!Index, !ak, !a)] !*(DB v ak a) -> *DB v ak a | ==, < ak
searchIndices :: ![(!Index, ![(!ak, !a)])] !*(DB v ak a) -> *DB v ak a | ==, < ak
searchIndices idxs (DB db)
# (s,db) = usize db
# db = upd 0 (s-1) idxs db
= (DB db)
where
upd :: !Int !Int ![(!Index, !ak, !a)] !*{!Entry v ak a} -> *{!Entry v ak a} | ==, < ak
upd :: !Int !Int ![(!Index, ![(!ak, !a)])] !*{!Entry v ak a} -> *{!Entry v ak a} | ==, < ak
upd i s _ es
| i == s = es
| i > s = es
upd i s [] es
# (e,es) = es![i]
= upd (i+1) s [] {es & [i]={e & included=False}}
upd i s allidxs=:[match=:(Index idx,k,v):idxs] es
upd i s allidxs=:[match=:(Index idx,annots):idxs] es
# (e,es) = es![i]
# e & included = e.included && include
# e & annotations = if e.included (put k v e.annotations) e.annotations
# e & annotations = if e.included (foldr (uncurry put) e.annotations annots) e.annotations
= upd (i+1) s (if include idxs allidxs) {es & [i]=e}
where
include = i == idx
......
......@@ -48,23 +48,44 @@ search {unify,name,className,typeName,modules,libraries,page,include_builtins,in
# cdb = case name <|> typeName <|> className of
Nothing -> cdb
Just name -> filterName name cdb
# (typedefs,cdb) = appFst (map getTypeDef) $ allTypeDefs cdb
# mbPreppedType = prepare_unification True typedefs <$> (unify >>= parseType o fromString)
# usedSynonyms = 'Foldable'.concat (fst <$> mbPreppedType)
# mbType = snd <$> mbPreppedType
# cdb = case mbType of
Nothing -> cdb
Just t -> filterUnifying t cdb
# (es,cdb) = getEntries cdb
# (es,cdb) = mapSt makeResult es cdb
# (es,cdb) = mapSt (makeResult mbType typedefs usedSynonyms) es cdb
= (sort es, cdb)
makeResult :: (CloogleEntry, Map AnnotationKey Annotation) *CloogleDB -> *(Result, *CloogleDB)
makeResult (entry, annots) db
makeResult :: (Maybe Type) [TypeDef] [TypeDef]
(CloogleEntry, Map AnnotationKey Annotation) *CloogleDB
-> *(Result, *CloogleDB)
makeResult orgsearchtype tdes usedsyns (entry, annots) db
| entry =: (FunctionEntry _)
# (FunctionEntry fe) = entry
// Parent class
# (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)
= (FunctionResult (general,
// Unifier
# unif = prepare_unification False tdes <$> fe.fe_type >>= \(syns,type) ->
finish_unification (syns ++ usedsyns) <$>
(orgsearchtype >>= unify type)
# required_context = Nothing // TODO
= (FunctionResult (
{ general
& distance = toInt $ kindPenalty fe.fe_kind * toReal (general.distance + sum
[ fromMaybe 0 $ contextPenalty <$> required_context
, fromMaybe 0 $ unifierPenalty <$> unif
])
},
{ kind = fe.fe_kind
, func = fromJust (fe.fe_representation <|> pure (concat $ print False (name,fe)))
, unifier = Nothing // TODO
, required_context = Nothing // TODO
, unifier = toStrUnifier <$> unif
, required_context = required_context
, cls = cls
, constructor_of = Nothing // TODO
, recordfield_of = Nothing // TODO
......@@ -74,6 +95,44 @@ makeResult (entry, annots) db
, result_doc = Nothing // TODO
, type_doc = Nothing // TODO
}), db)
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)
kindPenalty :: FunctionKind -> Real
kindPenalty RecordField = 1.2
kindPenalty Constructor = 1.1
kindPenalty _ = 1.0
contextPenalty :: [(String, [LocationResult])] -> Int
contextPenalty required_context = length [0 \\ (_,[]) <- required_context]
unifierPenalty :: Unifier -> Int
unifierPenalty unif = length unif.Unifier.used_synonyms + toInt (sum
[typeComplexity t \\ (_,t) <- allTvas unif | not (isVar t)])
where
allTvas :: Unifier -> [TVAssignment]
allTvas unif = map fromUnifyingAssignment unif.assignments
typeComplexity :: Type -> Real
typeComplexity (Type _ ts) = 1.2 * foldr ((+) o typeComplexity) 1.0 ts
typeComplexity (Func is r _) = 2.0 * foldr ((+) o typeComplexity) 1.0 [r:is]
typeComplexity (Var _) = 1.0
typeComplexity (Cons _ ts) = 1.2 * foldr ((+) o typeComplexity) 1.0 ts
typeComplexity (Uniq t) = 3.0 + typeComplexity t
typeComplexity (Forall _ t _) = 3.0 + typeComplexity t
typeComplexity (Arrow (Just t)) = 5.0 + typeComplexity t
typeComplexity (Arrow Nothing) = 5.0
| entry =: (TypeDefEntry _)
# (TypeDefEntry tde) = entry
= (TypeResult (general,
......
......@@ -8,17 +8,15 @@ from Text.JSON import generic JSONEncode, generic JSONDecode, :: JSONNode
from TypeDef import :: Type
from CloogleDB import :: Location
:: TypeTree v
:: TypeTree
instance zero TypeTree
instance zero (TypeTree v)
derive JSONEncode TypeTree
derive JSONDecode TypeTree
typeTreeNodes :: TypeTree -> Int
typeTreeSize :: TypeTree -> Int
typeTreeDepth :: TypeTree -> Int
addType :: !Location !Type !TypeTree -> TypeTree
findUnifyingLocations :: !Type !TypeTree -> [Location]
typeTreeToGraphviz :: TypeTree -> Digraph
typeTreeNodes :: (TypeTree v) -> Int
typeTreeSize :: (TypeTree v) -> Int
typeTreeDepth :: (TypeTree v) -> Int
addType :: !Type !v !(TypeTree v) -> TypeTree v
findUnifying :: !Type !(TypeTree v) -> [v]
typeTreeToGraphviz :: (TypeTree v) -> Digraph
......@@ -21,53 +21,53 @@ import TypeUtil
import CloogleDB
:: TypeTree = Node Type [Location] [TypeTree]
:: TypeTree v = Node Type [v] [TypeTree v]
instance zero TypeTree where zero = Node (Var "ra") [] []
instance zero (TypeTree v) where zero = Node (Var "ra") [] []
instance < TypeTree where < (Node a _ _) (Node b _ _) = a < b
instance < (TypeTree v) where < (Node a _ _) (Node b _ _) = a < b
derive gLexOrd Type, Maybe, TypeRestriction
instance < Type where < t u = (t =?= u) =: LT
derive JSONEncode TypeTree, Type, TypeRestriction, Location
derive JSONDecode TypeTree, Type, TypeRestriction, Location
typeTreeNodes :: TypeTree -> Int
typeTreeNodes :: (TypeTree v) -> Int
typeTreeNodes (Node _ _ cs) = 1 + sum (map typeTreeNodes cs)
typeTreeSize :: TypeTree -> Int
typeTreeSize :: (TypeTree v) -> Int
typeTreeSize (Node _ vs cs) = length vs + sum (map typeTreeSize cs)
typeTreeDepth :: TypeTree -> Int
typeTreeDepth :: (TypeTree v) -> Int
typeTreeDepth (Node _ _ cs) = maxList [0:map ((+) 1 o typeTreeDepth) cs]
addType :: !Location !Type !TypeTree -> TypeTree
addType loc t tree=:(Node n locs children)
addType :: !Type !v !(TypeTree v) -> TypeTree v
addType t v tree=:(Node n vs children)
| t generalises n
| n generalises t = trace_n (t <+ " equivalent to " <+ n) Node n [loc:locs] children
| otherwise = trace_n (t <+ " generalises " <+ n) Node t [loc] [tree]
| n generalises t = trace_n (t <+ " equivalent to " <+ n) Node n [v:vs] children
| otherwise = trace_n (t <+ " generalises " <+ n) Node t [v] [tree]
// A type may end up in different places when there are multiple types that
// generalise it. We sort on the matching types here to avoid that as much as
// is easily possible, because we want the tree to be as small as possible.
| otherwise = case appFst sort $ partition (\(Node t` _ _) -> t` generalises t) children of
([],_) -> trace_n (t <+ " added to " <+ n) Node n locs [Node t [loc] yes:no]
([],_) -> trace_n (t <+ " added to " <+ n) Node n vs [Node t [v] yes:no]
with (yes,no) = partition (\(Node c _ _) -> t generalises c) children
([g:gs],rest) -> Node n locs ([addType loc t g:gs] ++ rest)
([g:gs],rest) -> Node n vs ([addType t v g:gs] ++ rest)
findUnifyingLocations :: !Type !TypeTree -> [Location]
findUnifyingLocations t tree=:(Node n ls cs) = case unify t n of
Nothing -> []
findUnifying :: !Type !(TypeTree v) -> [v]
findUnifying t tree=:(Node n ls cs) = case unify t n of
Nothing -> trace_n ("NO\t" +++ toString n) []
Just tvas -> //if (not (isEmpty cs) && isGeneralisingUnifier tvas)
//(allLocs tree) // TODO this fails for A.a: a, which incorrectly generalises 'a' and returns all types
(ls ++ concatMap (findUnifyingLocations t) cs)
//(allValues tree) // TODO this fails for A.a: a, which incorrectly generalises 'a' and returns all types
trace_n ("YES\t" +++ toString n) (ls ++ concatMap (findUnifying t) cs)
allTypes :: TypeTree -> [(Type,[Location],[TypeTree])]
allTypes :: (TypeTree v) -> [(Type,[v],[TypeTree v])]
allTypes (Node t vs cs) = [(t,vs,cs):concatMap allTypes cs]
allLocs :: TypeTree -> [Location]
allLocs (Node _ ls cs) = ls ++ concatMap allLocs cs
allValues :: (TypeTree v) -> [v]
allValues (Node _ ls cs) = ls ++ concatMap allValues cs
typeTreeToGraphviz :: TypeTree -> Digraph
typeTreeToGraphviz :: (TypeTree v) -> Digraph
typeTreeToGraphviz tree = Digraph
"Type tree"
[GAttRankDir RDLR]
......
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