Merge pull request purescript#1161 from puffnfresh/perf/entails-filtermodule

paf31 · paf31 · commit 2021aa012f17 · 2015-06-11T14:06:59.000-07:00
Remove poor performing entails.filterModule
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
@@ -17,6 +17,7 @@
 module Language.PureScript.AST.Declarations where
 
 import qualified Data.Data as D
+import qualified Data.Map as M
 
 import Language.PureScript.AST.Binders
 import Language.PureScript.AST.Operators
@@ -360,7 +361,7 @@ data Expr
   -- at superclass implementations when searching for a dictionary, the type class name and
   -- instance type, and the type class dictionaries in scope.
   --
-  | TypeClassDictionary Bool Constraint [TypeClassDictionaryInScope]
+  | TypeClassDictionary Bool Constraint (M.Map (Maybe ModuleName) [TypeClassDictionaryInScope])
   -- |
   -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.
   --
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -21,7 +21,7 @@ module Language.PureScript.TypeChecker.Entailment (
 
 import Data.Function (on)
 import Data.List
-import Data.Maybe (maybeToList)
+import Data.Maybe (fromMaybe, maybeToList)
 import Data.Foldable (foldMap)
 import qualified Data.Map as M
 
@@ -47,17 +47,17 @@ newtype Work = Work Integer deriving (Show, Eq, Ord, Num)
 -- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
 -- return a type class dictionary reference.
 --
-entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> Constraint -> Bool -> Check Expr
-entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))
+entails :: Environment -> ModuleName -> M.Map (Maybe ModuleName) [TypeClassDictionaryInScope] -> Constraint -> Bool -> Check Expr
+entails env moduleName context = solve (sortedNubBy canonicalizeDictionary dictsInScope)
   where
     sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]
     sortedNubBy f vs = M.elems (M.fromList (map (f &&& id) vs))
 
-    -- Filter out type dictionaries which are in scope in the current module
-    filterModule :: TypeClassDictionaryInScope -> Bool
-    filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True
-    filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
-    filterModule _ = False
+    dictsInScope :: [TypeClassDictionaryInScope]
+    dictsInScope = findDicts Nothing ++ findDicts (Just moduleName)
+
+    findDicts :: Maybe ModuleName -> [TypeClassDictionaryInScope]
+    findDicts = fromMaybe [] . flip M.lookup context
 
     solve :: [TypeClassDictionaryInScope] -> Constraint -> Bool -> Check Expr
     solve context' (className, tys) trySuperclasses = do
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -76,10 +76,10 @@ withTypeClassDictionaries entries action = do
   return a
 
 -- |
--- Get the currently available list of type class dictionaries
+-- Get the currently available map of type class dictionaries
 --
-getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [TypeClassDictionaryInScope]
-getTypeClassDictionaries = (>>= M.elems) . M.elems . typeClassDictionaries . checkEnv <$> get
+getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m (M.Map (Maybe ModuleName) [TypeClassDictionaryInScope])
+getTypeClassDictionaries = fmap M.elems . typeClassDictionaries . checkEnv <$> get
 
 -- |
 -- Lookup type class dictionaries in a module.
