@@ -48,8 +48,11 @@ newtype Work = Work Integer deriving (Show, Eq, Ord, Num)
48-- return a type class dictionary reference.
48-- return a type class dictionary reference.
50entails :: Environment -> ModuleName -> M.Map (Maybe ModuleName) [TypeClassDictionaryInScope] -> Constraint -> Bool -> Check Expr
50entails :: Environment -> ModuleName -> M.Map (Maybe ModuleName) [TypeClassDictionaryInScope] -> Constraint -> Bool -> Check Expr
51−entails env moduleName context = solve (sortedNubBy canonicalizeDictionary dictsInScope)
51+entails env moduleName context = solve
53+ byClassName :: M.Map (Qualified ProperName) [TypeClassDictionaryInScope]
54+ byClassName = M.fromListWith (++) $ (\tcd -> (tcdClassName tcd, [tcd])) <$> sortedNubBy canonicalizeDictionary dictsInScope
53 sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]
56 sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]
54 sortedNubBy f vs = M.elems (M.fromList (map (f &&& id) vs))
57 sortedNubBy f vs = M.elems (M.fromList (map (f &&& id) vs))
@@ -59,8 +62,8 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary dicts
59 findDicts :: Maybe ModuleName -> [TypeClassDictionaryInScope]
62 findDicts :: Maybe ModuleName -> [TypeClassDictionaryInScope]
60 findDicts = fromMaybe [] . flip M.lookup context
63 findDicts = fromMaybe [] . flip M.lookup context
62− solve :: [TypeClassDictionaryInScope] -> Constraint -> Bool -> Check Expr
65+ solve :: Constraint -> Bool -> Check Expr
63− solve context' (className, tys) trySuperclasses = do
66+ solve (className, tys) trySuperclasses = do
64 let dicts = flip evalStateT (Work 0) $ go trySuperclasses className tys
67 let dicts = flip evalStateT (Work 0) $ go trySuperclasses className tys
65 checkOverlaps dicts
68 checkOverlaps dicts
@@ -73,9 +76,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary dicts
74 directInstances :: StateT Work [] DictionaryValue
77 directInstances :: StateT Work [] DictionaryValue
75 directInstances = do
78 directInstances = do
76− tcd <- lift context'
79+ tcd <- lift . fromMaybe [] $ M.lookup className' byClassName
77− -- Make sure the type class name matches the one we are trying to satisfy
78− guard $ className' == tcdClassName tcd
79 -- Make sure the type unifies with the type in the type instance definition
80 -- Make sure the type unifies with the type in the type instance definition
80 subst <- lift . maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
81 subst <- lift . maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
81 -- Solve any necessary subgoals
82 -- Solve any necessary subgoals