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