@@ -316,89 +316,111 @@ 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 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) ++ "."
384+ , "For example:"
385+ , prettyPrintDictionaryValue d1
386+ , "and:"
387+ , prettyPrintDictionaryValue d2
388+ ]
389+ -- Choose the simplest DictionaryValues from a list of candidates
390+ -- The reason for this function is as follows:
391+ -- When considering overlapping instances, we don't want to consider the same dictionary
392+ -- to be an overlap of itself when obtained as a superclass of another class.
393+ -- Observing that we probably don't want to select a superclass instance when an instance
394+ -- is available directly, and that there is no way for a superclass instance to actually
395+ -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries
396+ -- obtained as superclass instances if there are simpler instances available.
397+ chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]
398+ chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of
399+ [] -> ds
400+ simple -> simple
401+ isSimpleDictionaryValue SubclassDictionaryValue{} = False
402+ isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds
403+ isSimpleDictionaryValue _ = True
404+ -- |
405+ -- Get the "trace" of a DictionaryValue - that is, remove all SubclassDictionaryValue
406+ -- data constructors
407+ --
408+ dictTrace :: DictionaryValue -> DictionaryValue
409+ dictTrace (DependentDictionaryValue fnName dicts) = DependentDictionaryValue fnName $ map dictTrace dicts
410+ dictTrace (SubclassDictionaryValue dict _ _) = dictTrace dict
411+ dictTrace other = other
412+ -- |
413+ -- Render a DictionaryValue fit for human consumption in error messages
414+ --
415+ prettyPrintDictionaryValue :: DictionaryValue -> String
416+ prettyPrintDictionaryValue = unlines . indented 0
417+ where
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
422+
423+ spaces n = replicate n ' ' ++ "- "
402424
403425 valUndefined :: Expr
404426 valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))