@@ -11,8 +11,9 @@ where
1111
1212import Prelude
1313
14−import Docs.Search.TypeDecoder
1514import Docs.Search.Config
15+import Docs.Search.DocsJson
16+import Docs.Search.TypeDecoder
1617
1718import Control.Alt ((<|>))
1819import Data.Array as Array
@@ -183,20 +184,24 @@ data Substitution
183184 | Match String String
184185 | Generalize TypeQuery String
185186 | Substitute String String
186− | MatchConstraints String String
187+ | MatchConstraints (Set String) (Set String)
187188 | MissingConstraint
188189 | ExcessiveConstraint
190+ | RowsMismatch Int Int
191+ | Mismatch
189192
190193derive instance genericSubstitution :: Generic Substitution _
191194
192195instance showSubstitution :: Show Substitution where
193196 show x = genericShow x
194197
195−unify :: TypeQuery -> Type -> Maybe (List Substitution)
198+unify :: TypeQuery -> Type -> List Substitution
196199unify query type_ = go Nil (List.singleton { q: query, t: type_ })
197200 where
198− go :: List Substitution -> List { q :: TypeQuery, t :: Type } -> Maybe (List Substitution)
199− go acc Nil = Just acc
201+ go :: List Substitution -> List { q :: TypeQuery, t :: Type } -> List Substitution
202+ go acc Nil = acc
203+ go acc ({ q, t: ParensInType t } : rest) =
204+ go acc ({ q, t } : rest)
200205
201206 -- * ForAll
202207 go acc ({ q: (QForAll queryBinders q), t:type_1@(ForAll _ _ _) } : rest) =
@@ -218,6 +223,16 @@ unify query type_ = go Nil (List.singleton { q: query, t: type_ })
218223 -- * Names
219224 go acc ({ q: QConst qname, t: TypeConstructor (QualifiedName { name }) } : rest) =
220225 go (Match qname name : acc) rest
226+ go acc ({ q: QConst qname, t } : rest) =
227+ go (Mismatch : acc) rest
228+ go acc ({ q, t: TypeConstructor (QualifiedName { name }) } : rest) =
229+ go (Mismatch : acc) rest
230+
231+ -- type operators can't appear in type queries: this is always a mismatch
232+ go acc ({ q, t: TypeOp (QualifiedName { name }) } : rest) =
233+ go (Mismatch : acc) rest
234+ go acc ({ q, t: BinaryNoParensType _ _ _ } : rest) =
235+ go (Mismatch : acc) rest
221236
222237 -- * Functions
223238 go acc ({ q: QFun q1 q2
@@ -225,17 +240,20 @@ unify query type_ = go Nil (List.singleton { q: query, t: type_ })
225240 (QualifiedName { moduleName: [ "Prim" ]
226241 , name: "Function" })) t1) t2 } : rest) =
227242 go acc ({ q: q1, t: t1 } : { q: q2, t: t2 } : rest)
243+ go acc ({ q: QFun q1 q2, t } : rest) =
244+ go (Mismatch : acc) rest
228245
229246 -- * Constraints
230− go acc ({ q: QConstraint className args q
231− , t: ConstrainedType cnstr t } : rest) =
232− go (MatchConstraints className typeClassName : acc) ({ q, t } : rest)
233− where typeClassName = (unwrap (unwrap cnstr).constraintClass).name
234− go acc ({ q: QConstraint _ _ q
235− , t } : rest) =
247+ go acc ({ q: q@(QConstraint _ _ _)
248+ , t: t@(ConstrainedType _ _) } : rest) =
249+ let qcs = Set.fromFoldable (joinQueryConstraints q).constraints
250+ tcs = Set.fromFoldable (joinConstraints t).constraints
251+ in
252+ -- TODO: use edit distance instead
253+ go (MatchConstraints qcs tcs : acc) rest
254+ go acc ({ q: QConstraint _ _ q, t } : rest) =
236255 go (ExcessiveConstraint : acc) ({ q, t } : rest)
237− go acc ({ q
238− , t: ConstrainedType cnstr t } : rest) =
256+ go acc ({ q, t: ConstrainedType _ t } : rest) =
239257 go (MissingConstraint : acc) ({ q, t } : rest)
240258
241259 -- * Rows
@@ -243,25 +261,45 @@ unify query type_ = go Nil (List.singleton { q: query, t: type_ })
243261 , t: TypeApp (TypeConstructor
244262 (QualifiedName { moduleName: [ "Prim" ]
245263 , name: "Record" })) row } : rest) =
246− let { rows, ty } = joinRows row in
247− if List.length rows == List.length qRows then
264+ let { rows, ty } = joinRows row
265+ qRowsLength = List.length qRows
266+ rowsLength = List.length rows in
267+ if rowsLength == qRowsLength then
248268 let
249269 sortedQRows = List.sortBy (\x y -> compare (fst x) (fst y)) qRows
250270 sortedRows = List.sortBy (\x y -> compare x.row y.row) rows in
251− go acc $
252− (List.zipWith (\(Tuple _ q) { ty: t } -> { q, t }) sortedQRows sortedRows <> rest)
271+ go
272+ -- match row names
273+ (List.zipWith (\(Tuple qRowName _) { row: rowName } ->
274+ Match qRowName rowName) sortedQRows sortedRows <> acc)
275+ -- match row types
276+ (List.zipWith (\(Tuple _ q) { ty: t } ->
277+ { q, t }) sortedQRows sortedRows <> rest)
253278 else
254− Nothing
279+ go (RowsMismatch qRowsLength rowsLength : acc) rest
280+
281+ go acc ({ q: QRow _ } : rest) =
282+ go (Mismatch : acc) rest
255283
256284 -- * Type application
257285 go acc ({ q: QApp q1 q2, t: TypeApp t1 t2 } : rest) =
258286 go acc ({ q: q1, t: t1 } : { q: q2, t: t2 } : rest)
259287
260− go acc _ = Nothing
288+ go acc ({ q, t: TypeLevelString _ } : rest) =
289+ go (Mismatch : acc) rest
290+
291+ go acc ({ q, t: TypeWildcard } : rest) =
292+ go (Mismatch : acc) rest
261293
262−penalty :: TypeQuery -> Type -> Maybe Int
294+ go acc ({ q, t: RCons _ _ _ } : rest) =
295+ go (Mismatch : acc) rest
296+
297+ go acc ({ q, t: REmpty } : rest) =
298+ go (Mismatch : acc) rest
299+
300+penalty :: TypeQuery -> Type -> Int
263301penalty typeQuery ty =
264− unify typeQuery ty <#> \substs ->
302+ let substs = unify typeQuery ty in
265303 typeVarPenalty substs * config.penalties.typeVars +
266304 namesPenalty substs +
267305 mismatchPenalty substs
@@ -293,14 +331,17 @@ typeVarPenalty substs =
293331namesPenalty :: List Substitution -> Int
294332namesPenalty = go 0
295333 where
296− go n Nil = n
297− go n (Match a b : rest)
298− | a == b = go n rest
299− | otherwise = go (n + config.penalties.match) rest
300− go n (MatchConstraints a b : rest)
301− | a == b = go n rest
302− | otherwise = go (n + config.penalties.matchConstraint) rest
303− go n (_ : rest) = go n rest
334+ go p Nil = p
335+ go p (Mismatch : rest) = go (p + config.penalties.mismatch) rest
336+ go p (Match a b : rest)
337+ | a == b = go p rest
338+ | otherwise = go (p + config.penalties.match) rest
339+ go p (MatchConstraints qcs tcs : rest)
340+ = let p' = Set.size (Set.union qcs tcs) -
341+ Set.size (Set.intersection qcs tcs) in
342+ go (p + config.penalties.matchConstraint * p') rest
343+ go p (RowsMismatch n m : rest) = go (config.penalties.rowsMismatch * abs (n - m)) rest
344+ go p (_ : rest) = go p rest
304345
305346-- | Penalty for generalization and instantiation.
306347mismatchPenalty :: List Substitution -> Int
@@ -312,3 +353,12 @@ mismatchPenalty = go 0
312353 go n (ExcessiveConstraint : rest) = go (n + config.penalties.excessiveConstraint) rest
313354 go n (MissingConstraint : rest) = go (n + config.penalties.missingConstraint) rest
314355 go n (_ : rest) = go n rest
356+
357+-- | Only returns a list of type class names (lists of arguments are omitted).
358+joinQueryConstraints :: TypeQuery -> { constraints :: List String
359+ , ty :: TypeQuery }
360+joinQueryConstraints = go Nil
361+ where
362+ go acc (QConstraint name _ query) =
363+ go (name : acc) query
364+ go acc ty = { constraints: List.sort acc, ty }