@@ -307,10 +307,10 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
307 filterModule _ = False
307 filterModule _ = False
309 solve context' (className, tys) trySuperclasses =
309 solve context' (className, tys) trySuperclasses =
310− case go className tys of
310+ case chooseSimplestDictionaries (go className tys) of
311 [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
311 [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
312− (dict : _) -> return (dictionaryValueToValue dict)
312+ [dict] -> return (dictionaryValueToValue dict)
313− --_ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
313+ _ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
315 go className' tys' =
315 go className' tys' =
316 -- Look for regular type instances
316 -- Look for regular type instances
@@ -326,8 +326,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
326 -- Look for implementations via superclasses
326 -- Look for implementations via superclasses
327 [ SubclassDictionaryValue suDict index
327 [ SubclassDictionaryValue suDict index
328 | trySuperclasses
328 | trySuperclasses
329− , tcd <- context'
329+ , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)
330− , let (_, _, implies) = fromMaybe (error "Type class was not defined") $ M.lookup (tcdClassName tcd) (typeClasses env)
331 -- Try each superclass
330 -- Try each superclass
332 , (index, (superclass, suTyArgs)) <- zip [0..] implies
331 , (index, (superclass, suTyArgs)) <- zip [0..] implies
333 -- Make sure the type class name matches the superclass name
332 -- Make sure the type class name matches the superclass name
@@ -335,7 +334,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
335 -- Make sure the types unify with the types in the superclass implication
334 -- Make sure the types unify with the types in the superclass implication
336 , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
335 , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
337 -- Finally, satisfy the subclass constraint
336 -- Finally, satisfy the subclass constraint
338− , suDict <- go (tcdClassName tcd) (map (applySubst subst) (tcdInstanceTypes tcd)) ]
337+ , suDict <- go subclassName (map (applySubst subst . TypeVar) args) ]
340 -- Create dictionaries for subgoals which still need to be solved by calling go recursively
339 -- Create dictionaries for subgoals which still need to be solved by calling go recursively
341 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
340 -- 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
372 replace t@(TypeVar v) = fromMaybe t $ lookup v subst
371 replace t@(TypeVar v) = fromMaybe t $ lookup v subst
373 replace other = other
372 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
385+ isSimpleDictionaryValue SubclassDictionaryValue{} = False
386+ isSimpleDictionaryValue _ = True
376-- Check all values in a list pairwise match a predicate
389-- Check all values in a list pairwise match a predicate