c334a04 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Merge pull request #1173 from puffnfresh/perf/dictionary-lookup

c334a04Phil Freeman11 years ago

src/Language/PureScript/TypeChecker.hs+6−10

compare with golang

unifiedsplit

@@ -88,10 +88,9 @@ addTypeClass moduleName pn args implies ds =

88 toPair (PositionedDeclaration _ _ d) = toPair d

89 toPair _ = error "Invalid declaration in TypeClassDeclaration"

91−addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()

91+addTypeClassDictionaries :: Maybe ModuleName -> M.Map (Qualified Ident) TypeClassDictionaryInScope -> Check ()

92−addTypeClassDictionaries entries =

92+addTypeClassDictionaries mn entries =

93− let mentries = M.fromListWith (M.union) [ (mn, M.singleton (canonicalizeDictionary entry) entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ]

94− in modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.union) (typeClassDictionaries . checkEnv $ st) mentries } }

93+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.insertWith M.union mn entries (typeClassDictionaries . checkEnv $ st) } }

96checkDuplicateTypeArguments :: [String] -> Check ()

95checkDuplicateTypeArguments :: [String] -> Check ()

97checkDuplicateTypeArguments args = for_ firstDup $ \dup ->

96checkDuplicateTypeArguments args = for_ firstDup $ \dup ->

@@ -224,11 +223,7 @@ typeCheckAll mainModuleName moduleName exps = go

224 return $ d : ds

223 return $ d : ds

225 go (d@(ImportDeclaration importedModule _ _) : rest) = do

224 go (d@(ImportDeclaration importedModule _ _) : rest) = do

226 instances <- lookupTypeClassDictionaries $ Just importedModule

225 instances <- lookupTypeClassDictionaries $ Just importedModule

227− addTypeClassDictionaries [ tcd { tcdName = Qualified (Just moduleName) ident, tcdType = TCDAlias (canonicalizeDictionary tcd) }

226+ addTypeClassDictionaries (Just moduleName) instances

228− | tcd <- instances

229− , tcdExported tcd

230− , let (Qualified _ ident) = tcdName tcd

231− ]

232 ds <- go rest

227 ds <- go rest

233 return $ d : ds

228 return $ d : ds

234 go (d@(TypeClassDeclaration pn args implies tys) : rest) = do

229 go (d@(TypeClassDeclaration pn args implies tys) : rest) = do

@@ -247,7 +242,8 @@ typeCheckAll mainModuleName moduleName exps = go

247 goInstance d dictName deps className tys rest = do

242 goInstance d dictName deps className tys rest = do

248 mapM_ (checkTypeClassInstance moduleName) tys

243 mapM_ (checkTypeClassInstance moduleName) tys

249 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

244 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

250− addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported]

245+ let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported

246+ addTypeClassDictionaries (Just moduleName) $ M.singleton (canonicalizeDictionary dict) dict

251 ds <- go rest

247 ds <- go rest

252 return $ d : ds

248 return $ d : ds

253

249

src/Language/PureScript/TypeChecker/Entailment.hs+7−6

@@ -48,8 +48,11 @@ newtype Work = Work Integer deriving (Show, Eq, Ord, Num)

48-- return a type class dictionary reference.

49--

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

52 where

53+ byClassName :: M.Map (Qualified ProperName) [TypeClassDictionaryInScope]

54+ byClassName = M.fromListWith (++) $ (\tcd -> (tcdClassName tcd, [tcd])) <$> sortedNubBy canonicalizeDictionary dictsInScope

55+

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

66 where

69 where

@@ -73,9 +76,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary dicts

73 where

76 where

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

src/Language/PureScript/TypeChecker/Monad.hs+2−2

@@ -84,8 +84,8 @@ getTypeClassDictionaries = fmap M.elems . typeClassDictionaries . checkEnv <$> g

84-- |

85-- Lookup type class dictionaries in a module.

86--

87−lookupTypeClassDictionaries :: (Functor m, MonadState CheckState m) => Maybe ModuleName -> m [TypeClassDictionaryInScope]

87+lookupTypeClassDictionaries :: (Functor m, MonadState CheckState m) => Maybe ModuleName -> m (M.Map (Qualified Ident) TypeClassDictionaryInScope)

88−lookupTypeClassDictionaries mn = maybe [] M.elems . M.lookup mn . typeClassDictionaries . checkEnv <$> get

88+lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get

90-- |

91-- Temporarily bind a collection of names to local variables