@@ -316,89 +316,111 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
316 filterModule _ = False
316 filterModule _ = False
318 solve context' (className, tys) trySuperclasses =
318 solve context' (className, tys) trySuperclasses =
320− dicts = go trySuperclasses className tys
319+ checkOverlaps $ go trySuperclasses className tys
321− in case sortedNubBy dictTrace (chooseSimplestDictionaries dicts) of
322− [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
323− [_] -> return $ dictionaryValueToValue $ head dicts
324− _ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
326− go trySuperclasses' className' tys' =
321+ go trySuperclasses' className' tys' =
327− -- Look for regular type instances
322+ -- Look for regular type instances
328− [ mkDictionary (canonicalizeDictionary tcd) args
323+ [ mkDictionary (canonicalizeDictionary tcd) args
329− | tcd <- context'
324+ | tcd <- context'
330− -- Make sure the type class name matches the one we are trying to satisfy
325+ -- Make sure the type class name matches the one we are trying to satisfy
331− , className' == tcdClassName tcd
326+ , className' == tcdClassName tcd
332− -- Make sure the type unifies with the type in the type instance definition
327+ -- Make sure the type unifies with the type in the type instance definition
333− , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
328+ , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
334− -- Solve any necessary subgoals
329+ -- Solve any necessary subgoals
335− , args <- solveSubgoals subst (tcdDependencies tcd) ] ++
330+ , args <- solveSubgoals subst (tcdDependencies tcd) ] ++
337− -- Look for implementations via superclasses
332+ -- Look for implementations via superclasses
338− [ SubclassDictionaryValue suDict superclass index
333+ [ SubclassDictionaryValue suDict superclass index
339− | trySuperclasses'
334+ | trySuperclasses'
340− , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)
335+ , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)
341− -- Try each superclass
336+ -- Try each superclass
342− , (index, (superclass, suTyArgs)) <- zip [0..] implies
337+ , (index, (superclass, suTyArgs)) <- zip [0..] implies
343− -- Make sure the type class name matches the superclass name
338+ -- Make sure the type class name matches the superclass name
344− , className' == superclass
339+ , className' == superclass
345− -- Make sure the types unify with the types in the superclass implication
340+ -- Make sure the types unify with the types in the superclass implication
346− , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
341+ , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
347− -- Finally, satisfy the subclass constraint
342+ -- Finally, satisfy the subclass constraint
348− , args' <- maybeToList $ mapM (flip lookup subst) args
343+ , args' <- maybeToList $ mapM (flip lookup subst) args
349− , suDict <- go True subclassName args' ]
344+ , suDict <- go True subclassName args' ]
351− -- Create dictionaries for subgoals which still need to be solved by calling go recursively
346+ -- Create dictionaries for subgoals which still need to be solved by calling go recursively
352− -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
347+ -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
353− -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
348+ -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
354− solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]
349+ solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]
355− solveSubgoals _ Nothing = return Nothing
350+ solveSubgoals _ Nothing = return Nothing
356− solveSubgoals subst (Just subgoals) = do
351+ solveSubgoals subst (Just subgoals) = do
357− dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals
352+ dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals
358− return $ Just dict
353+ return $ Just dict
359− -- Make a dictionary from subgoal dictionaries by applying the correct function
354+ -- Make a dictionary from subgoal dictionaries by applying the correct function
360− mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
355+ mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
361− mkDictionary fnName Nothing = LocalDictionaryValue fnName
356+ mkDictionary fnName Nothing = LocalDictionaryValue fnName
362− mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
357+ mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
363− mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
358+ mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
364− -- Turn a DictionaryValue into a Expr
359+ -- Turn a DictionaryValue into a Expr
365− dictionaryValueToValue :: DictionaryValue -> Expr
360+ dictionaryValueToValue :: DictionaryValue -> Expr
366− dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
361+ dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
367− dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) valUndefined
362+ dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) valUndefined
368− dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
363+ dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
369− dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =
364+ dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =
370− App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index)
365+ App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index)
371− (dictionaryValueToValue dict))
366+ (dictionaryValueToValue dict))
372− valUndefined
367+ valUndefined
373− -- Ensure that a substitution is valid
368+ -- Ensure that a substitution is valid
374− verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
369+ verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
375− verifySubstitution subst = do
370+ verifySubstitution subst = do
376− let grps = groupBy ((==) `on` fst) subst
371+ let grps = groupBy ((==) `on` fst) subst
377− guard (all (pairwise (unifiesWith env) . map snd) grps)
372+ guard (all (pairwise (unifiesWith env) . map snd) grps)
378− return $ map head grps
373+ return $ map head grps
375+ -- Check for overlapping instances
377+ checkOverlaps :: [DictionaryValue] -> Check Expr
378+ checkOverlaps dicts =
379+ case sortedNubBy dictTrace (chooseSimplestDictionaries dicts) of
380+ [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
381+ [_] -> return $ dictionaryValueToValue $ head dicts
382+ (d1 : d2 : _) -> throwError . strMsg $ unlines
383+ [ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintType tys) ++ "."
385+ , prettyPrintDictionaryValue d1
387+ , prettyPrintDictionaryValue d2
379− -- Choose the simplest DictionaryValues from a list of candidates
389+ -- Choose the simplest DictionaryValues from a list of candidates
380− -- The reason for this function is as follows:
390+ -- The reason for this function is as follows:
381− -- When considering overlapping instances, we don't want to consider the same dictionary
391+ -- When considering overlapping instances, we don't want to consider the same dictionary
382− -- to be an overlap of itself when obtained as a superclass of another class.
392+ -- to be an overlap of itself when obtained as a superclass of another class.
383− -- Observing that we probably don't want to select a superclass instance when an instance
393+ -- Observing that we probably don't want to select a superclass instance when an instance
384− -- is available directly, and that there is no way for a superclass instance to actually
394+ -- is available directly, and that there is no way for a superclass instance to actually
385− -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries
395+ -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries
386− -- obtained as superclass instances if there are simpler instances available.
396+ -- obtained as superclass instances if there are simpler instances available.
387− chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]
397+ chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]
388− chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of
398+ chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of
389− [] -> ds
399+ [] -> ds
390− simple -> simple
400+ simple -> simple
391− isSimpleDictionaryValue SubclassDictionaryValue{} = False
401+ isSimpleDictionaryValue SubclassDictionaryValue{} = False
392− isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds
402+ isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds
393− isSimpleDictionaryValue _ = True
403+ isSimpleDictionaryValue _ = True
395− -- Get the "trace" of a DictionaryValue - that is, remove all SubclassDictionaryValue
405+ -- Get the "trace" of a DictionaryValue - that is, remove all SubclassDictionaryValue
396− -- data constructors
406+ -- data constructors
398− dictTrace :: DictionaryValue -> DictionaryValue
408+ dictTrace :: DictionaryValue -> DictionaryValue
399− dictTrace (DependentDictionaryValue fnName dicts) = DependentDictionaryValue fnName $ map dictTrace dicts
409+ dictTrace (DependentDictionaryValue fnName dicts) = DependentDictionaryValue fnName $ map dictTrace dicts
400− dictTrace (SubclassDictionaryValue dict _ _) = dictTrace dict
410+ dictTrace (SubclassDictionaryValue dict _ _) = dictTrace dict
401− dictTrace other = other
411+ dictTrace other = other
413+ -- Render a DictionaryValue fit for human consumption in error messages
415+ prettyPrintDictionaryValue :: DictionaryValue -> String
416+ prettyPrintDictionaryValue = unlines . indented 0
418+ indented n (LocalDictionaryValue _) = [spaces n ++ "Dictionary in scope"]
419+ indented n (GlobalDictionaryValue nm) = [spaces n ++ show nm]
420+ indented n (DependentDictionaryValue nm args) = (spaces n ++ show nm ++ " via") : concatMap (indented (n + 2)) args
421+ indented n (SubclassDictionaryValue sup nm _) = (spaces n ++ show nm ++ " via superclass") : indented (n + 2) sup
423+ spaces n = replicate n ' ' ++ "- "
403 valUndefined :: Expr
425 valUndefined :: Expr
404 valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))
426 valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))