@@ -307,10 +307,10 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
307307 filterModule _ = False
308308
309309 solve context' (className, tys) trySuperclasses =
310− case go className tys of
310+ case chooseSimplestDictionaries (go className tys) of
311311 [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
312− (dict : _) -> return (dictionaryValueToValue dict)
313− --_ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
312+ [dict] -> return (dictionaryValueToValue dict)
313+ _ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
314314 where
315315 go className' tys' =
316316 -- Look for regular type instances
@@ -326,8 +326,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
326326 -- Look for implementations via superclasses
327327 [ SubclassDictionaryValue suDict index
328328 | trySuperclasses
329− , tcd <- context'
330− , let (_, _, implies) = fromMaybe (error "Type class was not defined") $ M.lookup (tcdClassName tcd) (typeClasses env)
329+ , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)
331330 -- Try each superclass
332331 , (index, (superclass, suTyArgs)) <- zip [0..] implies
333332 -- Make sure the type class name matches the superclass name
@@ -335,7 +334,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
335334 -- Make sure the types unify with the types in the superclass implication
336335 , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
337336 -- Finally, satisfy the subclass constraint
338− , suDict <- go (tcdClassName tcd) (map (applySubst subst) (tcdInstanceTypes tcd)) ]
337+ , suDict <- go subclassName (map (applySubst subst . TypeVar) args) ]
339338
340339 -- Create dictionaries for subgoals which still need to be solved by calling go recursively
341340 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
@@ -371,6 +370,20 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
371370 where
372371 replace t@(TypeVar v) = fromMaybe t $ lookup v subst
373372 replace other = other
373+ -- Choose the simplest DictionaryValues from a list of candidates
374+ -- The reason for this function is as follows:
375+ -- When considering overlapping instances, we don't want to consider the same dictionary
376+ -- to be an overlap of itself when obtained as a superclass of another class.
377+ -- Observing that we probably don't want to select a superclass instance when an instance
378+ -- is available directly, and that there is no way for a superclass instance to actually
379+ -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries
380+ -- obtained as superclass instances if there are simpler instances available.
381+ chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]
382+ chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of
383+ [] -> ds
384+ simple -> simple
385+ isSimpleDictionaryValue SubclassDictionaryValue{} = False
386+ isSimpleDictionaryValue _ = True
374387
375388-- |
376389-- Check all values in a list pairwise match a predicate