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