@@ -1,3 +1,4 @@
1+-- | `TypeQuery` is a representation of a user-provided type.
12module Docs.Search.TypeQuery
23 ( TypeQuery(..)
34 , Substitution(..)
@@ -11,24 +12,21 @@ where
1112
1213import Prelude
1314
14−import Docs.Search.Config
15−import Docs.Search.DocsJson
16−import Docs.Search.TypeDecoder
15+import Docs.Search.Config (config)
16+import Docs.Search.Extra (foldl1, foldr1)
17+import Docs.Search.TypeDecoder (QualifiedName(..), Type(..), joinConstraints, joinRows)
1718
1819import Control.Alt ((<|>))
1920import Data.Array as Array
2021import Data.Either (Either)
21−import Data.Foldable (foldl)
2222import Data.Generic.Rep (class Generic)
2323import Data.Generic.Rep.Show (genericShow)
2424import Data.List (List(..), many, some, (:))
2525import Data.List as List
26−import Data.List.NonEmpty (NonEmptyList, cons', uncons)
26+import Data.List.NonEmpty (NonEmptyList)
2727import Data.List.NonEmpty as NonEmptyList
2828import Data.Map (Map)
2929import Data.Map as Map
30−import Data.Maybe (Maybe(..))
31−import Data.Newtype (unwrap)
3230import Data.Ord (abs)
3331import Data.Set (Set)
3432import Data.Set as Set
@@ -93,25 +91,12 @@ typeQueryParser = fix \typeQuery ->
9391
9492 constrained =
9593 QConstraint <$> (upperCaseIdent <* skipSpaces) <*>
96− (sepEndBy ((QVar <$> ident) <|> parens) (many space) <* string "=>" <* skipSpaces) <*>
94+ (sepEndBy ((QVar <$> ident) <|> parens)
95+ (many space) <* string "=>" <* skipSpaces) <*>
9796 typeQuery
9897 in
9998 try constrained <|> funs
10099
101−foldl1 :: forall a. (a -> a -> a) -> NonEmptyList a -> a
102−foldl1 f as =
103− case uncons as of
104− { head, tail } -> foldl f head tail
105−
106−foldr1 :: forall a. (a -> a -> a) -> NonEmptyList a -> a
107−foldr1 f = go List.Nil
108− where
109− go acc x = case uncons x of
110− { head, tail } -> case List.uncons tail of
111− Nothing -> List.foldl (flip f) head acc
112− Just { head: head1, tail: tail1 } ->
113− go (head : acc) (cons' head1 tail1)
114−
115100any :: Parser TypeQuery
116101any = do
117102 QVar <$> lowerCaseIdent
@@ -188,7 +173,12 @@ data Substitution
188173 | MissingConstraint
189174 | ExcessiveConstraint
190175 | RowsMismatch Int Int
191− | Mismatch
176+ | Mismatch TypeQuery Type
177+ -- ^ Type and type query significantly differ.
178+ | TypeMismatch Type
179+ -- ^ A query of size 1 corresponds to some type.
180+ | QueryMismatch TypeQuery
181+ -- ^ A type of size 1 corresponds to some query.
192182
193183derive instance genericSubstitution :: Generic Substitution _
194184
@@ -204,14 +194,24 @@ unify query type_ = go Nil (List.singleton { q: query, t: type_ })
204194 go acc ({ q, t } : rest)
205195
206196 -- * ForAll
207− go acc ({ q: (QForAll queryBinders q), t:type_1@(ForAll _ _ _) } : rest) =
208− let { binders, ty } = joinForAlls type_1 in
209− go acc ({ q, t: ty } : rest)
210197 go acc ({ q, t: ForAll _ t _ } : rest) =
211198 go acc ({ q, t } : rest)
212− go acc ({ q: (QForAll queryBinders q), t } : rest) =
199+ go acc ({ q: (QForAll _ q), t } : rest) =
213200 go acc ({ q, t } : rest)
214201
202+ -- * Constraints
203+ go acc ({ q: q@(QConstraint _ _ _)
204+ , t: t@(ConstrainedType _ _) } : rest) =
205+ let qcs = Set.fromFoldable (joinQueryConstraints q).constraints
206+ tcs = Set.fromFoldable (joinConstraints t).constraints
207+ in
208+ -- TODO: use edit distance instead
209+ go (MatchConstraints qcs tcs : acc) rest
210+ go acc ({ q: QConstraint _ _ q, t } : rest) =
211+ go (ExcessiveConstraint : acc) ({ q, t } : rest)
212+ go acc ({ q, t: ConstrainedType _ t } : rest) =
213+ go (MissingConstraint : acc) ({ q, t } : rest)
214+
215215 -- * Type variables
216216 go acc ({ q: QVar q, t: TypeVar v } : rest) =
217217 go (Substitute q v : acc) rest
@@ -224,15 +224,15 @@ unify query type_ = go Nil (List.singleton { q: query, t: type_ })
224224 go acc ({ q: QConst qname, t: TypeConstructor (QualifiedName { name }) } : rest) =
225225 go (Match qname name : acc) rest
226226 go acc ({ q: QConst qname, t } : rest) =
227− go (Mismatch : acc) rest
227+ go (TypeMismatch t : acc) rest
228228 go acc ({ q, t: TypeConstructor (QualifiedName { name }) } : rest) =
229− go (Mismatch : acc) rest
229+ go (QueryMismatch q : acc) rest
230230
231231 -- type operators can't appear in type queries: this is always a mismatch
232232 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
233+ go (QueryMismatch q : acc) rest
234+ go acc ({ q, t: t@(BinaryNoParensType _ _ _) } : rest) =
235+ go (Mismatch q t : acc) rest
236236
237237 -- * Functions
238238 go acc ({ q: QFun q1 q2
@@ -240,21 +240,8 @@ unify query type_ = go Nil (List.singleton { q: query, t: type_ })
240240 (QualifiedName { moduleName: [ "Prim" ]
241241 , name: "Function" })) t1) t2 } : rest) =
242242 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
245−
246− -- * Constraints
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) =
255− go (ExcessiveConstraint : acc) ({ q, t } : rest)
256− go acc ({ q, t: ConstrainedType _ t } : rest) =
257− go (MissingConstraint : acc) ({ q, t } : rest)
243+ go acc ({ q: q@(QFun q1 q2), t } : rest) =
244+ go (Mismatch q t : acc) rest
258245
259246 -- * Rows
260247 go acc ({ q: QApp (QConst "Record") (QRow qRows)
@@ -278,24 +265,24 @@ unify query type_ = go Nil (List.singleton { q: query, t: type_ })
278265 else
279266 go (RowsMismatch qRowsLength rowsLength : acc) rest
280267
281− go acc ({ q: QRow _ } : rest) =
282− go (Mismatch : acc) rest
268+ go acc ({ q: q@(QRow _), t } : rest) =
269+ go (Mismatch q t : acc) rest
283270
284271 -- * Type application
285272 go acc ({ q: QApp q1 q2, t: TypeApp t1 t2 } : rest) =
286273 go acc ({ q: q1, t: t1 } : { q: q2, t: t2 } : rest)
287274
288275 go acc ({ q, t: TypeLevelString _ } : rest) =
289− go (Mismatch : acc) rest
276+ go (QueryMismatch q : acc) rest
290277
291278 go acc ({ q, t: TypeWildcard } : rest) =
292− go (Mismatch : acc) rest
279+ go (QueryMismatch q : acc) rest
293280
294− go acc ({ q, t: RCons _ _ _ } : rest) =
295− go (Mismatch : acc) rest
281+ go acc ({ q, t: t@(RCons _ _ _) } : rest) =
282+ go (Mismatch q t : acc) rest
296283
297284 go acc ({ q, t: REmpty } : rest) =
298− go (Mismatch : acc) rest
285+ go (QueryMismatch q : acc) rest
299286
300287penalty :: TypeQuery -> Type -> Int
301288penalty typeQuery ty =
@@ -332,7 +319,6 @@ namesPenalty :: List Substitution -> Int
332319namesPenalty = go 0
333320 where
334321 go p Nil = p
335− go p (Mismatch : rest) = go (p + config.penalties.mismatch) rest
336322 go p (Match a b : rest)
337323 | a == b = go p rest
338324 | otherwise = go (p + config.penalties.match) rest
@@ -348,10 +334,15 @@ mismatchPenalty :: List Substitution -> Int
348334mismatchPenalty = go 0
349335 where
350336 go n Nil = n
351− go n (Instantiate _ _ : rest) = go (n + config.penalties.instantiate) rest
352− go n (Generalize _ _ : rest) = go (n + config.penalties.generalize) rest
337+ go n (Instantiate q t : rest) = go (n + typeSize t *
338+ config.penalties.instantiate) rest
339+ go n (Generalize q t : rest) = go (n + typeQuerySize q *
340+ config.penalties.generalize) rest
353341 go n (ExcessiveConstraint : rest) = go (n + config.penalties.excessiveConstraint) rest
354342 go n (MissingConstraint : rest) = go (n + config.penalties.missingConstraint) rest
343+ go n (Mismatch q t : rest) = go (n + typeQuerySize q + typeSize t) rest
344+ go n (TypeMismatch t : rest) = go (n + typeSize t) rest
345+ go n (QueryMismatch q : rest) = go (n + typeQuerySize q) rest
355346 go n (_ : rest) = go n rest
356347
357348-- | Only returns a list of type class names (lists of arguments are omitted).
@@ -362,3 +353,55 @@ joinQueryConstraints = go Nil
362353 go acc (QConstraint name _ query) =
363354 go (name : acc) query
364355 go acc ty = { constraints: List.sort acc, ty }
356+
357+typeQuerySize :: TypeQuery -> Int
358+typeQuerySize = go 0 <<< List.singleton
359+ where
360+ go n Nil = n
361+ go n (QVar _ : rest) =
362+ go (n + 1) rest
363+ go n (QConst _ : rest) =
364+ go (n + 1) rest
365+ go n (QFun q1 q2 : rest) =
366+ go (n + 1) (q1 : q2 : rest)
367+ go n (QApp q1 q2 : rest) =
368+ go (n + 1) (q1 : q2 : rest)
369+ go n (QForAll _ q : rest) =
370+ go (n + 1) (q : rest)
371+ go n (QConstraint _ _ q : rest) =
372+ go (n + 1) (q : rest)
373+ go n (QRow qs : rest) =
374+ go n ((qs <#> snd) <> rest)
375+
376+typeSize :: Type -> Int
377+typeSize = go 0 <<< List.singleton
378+ where
379+ go n Nil = n
380+ go n (TypeVar _ : rest) =
381+ go (n + 1) rest
382+ go n (TypeLevelString _ : rest) =
383+ go (n + 1) rest
384+ go n (TypeWildcard : rest) =
385+ go (n + 1) rest
386+ go n (TypeConstructor _ : rest) =
387+ go (n + 1) rest
388+ go n (TypeOp _ : rest) =
389+ go (n + 1) rest
390+ go n (TypeApp (TypeApp (TypeConstructor
391+ (QualifiedName { moduleName: [ "Prim" ]
392+ , name: "Function" })) t1) t2 : rest) =
393+ go (n + 1) (t1 : t2 : rest)
394+ go n (TypeApp q1 q2 : rest) =
395+ go (n + 1) (q1 : q2 : rest)
396+ go n (ForAll _ t _ : rest) =
397+ go (n + 1) (t : rest)
398+ go n (ConstrainedType _ t : rest) =
399+ go (n + 1) (t : rest)
400+ go n (RCons _ t1 t2 : rest) =
401+ go (n + 1) (t1 : t2 : rest)
402+ go n (REmpty : rest) =
403+ go (n + 1) rest
404+ go n (BinaryNoParensType op t1 t2 : rest) =
405+ go (n + 1) (t1 : t2 : rest)
406+ go n (ParensInType t : rest) =
407+ go n (t : rest)