Put back type search

CloogleDB.dcl

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

CloogleDB.icl

@@ -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

CloogleDBFactory.icl

@@ -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

DB.dcl

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

DB.icl

@@ -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

Search.icl

@@ -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,

TypeTree.dcl

@@ -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

TypeTree.icl

@@ -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]