@@ -290,52 +290,53 @@ data DictionaryValue
290290-- return a type class dictionary reference.
291291--
292292entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Check Value
293−entails env moduleName context goal@(className, tys) = do
294− case go goal of
295− [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
296− [dict] -> return (dictionaryValueToValue dict)
297− _ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
293+entails env moduleName context = solve (nubBy ((==) `on` canonicalizeDictionary) (filter filterModule context))
298294 where
299− go (className', tys') =
300− [ mkDictionary (canonicalizeDictionary tcd) args
301− | tcd <- nubBy ((==) `on` canonicalizeDictionary) context
302− -- Choose type class dictionaries in scope in the current module
303− , filterModule tcd
304− -- Make sure the type class name matches the one we are trying to satisfy
305− , className' == tcdClassName tcd
306− -- Make sure the type unifies with the type in the type instance definition
307− , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
308− -- Solve any necessary subgoals
309− , args <- solveSubgoals subst (tcdDependencies tcd) ]
310− -- Create dictionaries for subgoals which still need to be solved by calling go recursively
311− -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
312− -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
313− solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]
314− solveSubgoals _ Nothing = return Nothing
315− solveSubgoals subst (Just subgoals) = do
316− dict <- mapM (go . second (map (replaceAllTypeVars subst))) subgoals
317− return $ Just dict
318− -- Make a dictionary from subgoal dictionaries by applying the correct function
319− mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
320− mkDictionary fnName Nothing = LocalDictionaryValue fnName
321− mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
322− mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
323− -- Turn a DictionaryValue into a Value
324− dictionaryValueToValue :: DictionaryValue -> Value
325− dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
326− dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral [])
327− dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
328− -- Filter out type dictionaries which are in scope in the current module
329− filterModule :: TypeClassDictionaryInScope -> Bool
330− filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True
331− filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
332− filterModule _ = False
333− -- Ensure that a substitution is valid
334− verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
335− verifySubstitution subst = do
336− let grps = groupBy ((==) `on` fst) subst
337− guard (all (pairwise (unifiesWith env) . map snd) grps)
338− return $ map head grps
295+ -- Filter out type dictionaries which are in scope in the current module
296+ filterModule :: TypeClassDictionaryInScope -> Bool
297+ filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True
298+ filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
299+ filterModule _ = False
300+
301+ solve context' goal@(className, tys) =
302+ case go goal of
303+ [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
304+ [dict] -> return (dictionaryValueToValue dict)
305+ _ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
306+ where
307+ go (className', tys') =
308+ [ mkDictionary (canonicalizeDictionary tcd) args
309+ | tcd <- context'
310+ -- Make sure the type class name matches the one we are trying to satisfy
311+ , className' == tcdClassName tcd
312+ -- Make sure the type unifies with the type in the type instance definition
313+ , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
314+ -- Solve any necessary subgoals
315+ , args <- solveSubgoals subst (tcdDependencies tcd) ]
316+ -- Create dictionaries for subgoals which still need to be solved by calling go recursively
317+ -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
318+ -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
319+ solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]
320+ solveSubgoals _ Nothing = return Nothing
321+ solveSubgoals subst (Just subgoals) = do
322+ dict <- mapM (go . second (map (replaceAllTypeVars subst))) subgoals
323+ return $ Just dict
324+ -- Make a dictionary from subgoal dictionaries by applying the correct function
325+ mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
326+ mkDictionary fnName Nothing = LocalDictionaryValue fnName
327+ mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
328+ mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
329+ -- Turn a DictionaryValue into a Value
330+ dictionaryValueToValue :: DictionaryValue -> Value
331+ dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
332+ dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral [])
333+ dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
334+ -- Ensure that a substitution is valid
335+ verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
336+ verifySubstitution subst = do
337+ let grps = groupBy ((==) `on` fst) subst
338+ guard (all (pairwise (unifiesWith env) . map snd) grps)
339+ return $ map head grps
339340
340341-- |
341342-- Check all values in a list pairwise match a predicate