9345919 · rowtype-yoga/purescript-native

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

Merge pull request #415 from purescript/faster-instances

An attempt at a faster instance lookup implementation

commit9345919b0771febea0c011a2d09d3e563b309f63 authorPhil Freeman <paf31@cantab.net> dateWed 14 May 2014, 09:42 (12 years ago) parentf55353b b3741cd

4 files changed+11−8

compare with golang

unifiedsplit

src/Language/PureScript/CodeGen/Externs.hs+1−1 src/Language/PureScript/Environment.hs+2−2 src/Language/PureScript/TypeChecker.hs+4−3 src/Language/PureScript/TypeChecker/Monad.hs+4−2

src/Language/PureScript/CodeGen/Externs.hs+1−1

@@ -85,7 +85,7 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite

8585

8686 exportToPs (TypeInstanceRef ident) = do

8787 let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =

88− fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ typeClassDictionaries env

88+ fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ M.elems $ typeClassDictionaries env

8989 let constraintsText = case fromMaybe [] deps of

9090 [] -> ""

9191 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "

src/Language/PureScript/Environment.hs+2−2

@@ -49,7 +49,7 @@ data Environment = Environment {

4949 -- |

5050 -- Available type class dictionaries

5151 --

52− , typeClassDictionaries :: [TypeClassDictionaryInScope]

52+ , typeClassDictionaries :: M.Map (Qualified Ident, Maybe ModuleName) TypeClassDictionaryInScope

5353 -- |

5454 -- Type classes

5555 --

@@ -60,7 +60,7 @@ data Environment = Environment {

6060-- The initial environment with no values and only the default javascript types defined

6161--

6262initEnvironment :: Environment

63−initEnvironment = Environment M.empty primTypes M.empty M.empty [] M.empty

63+initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty M.empty

6464

6565-- |

6666-- The type of a foreign import

src/Language/PureScript/TypeChecker.hs+4−3

@@ -84,7 +84,8 @@ addTypeClass moduleName pn args implies ds =

8484

8585addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()

8686addTypeClassDictionaries entries =

87− modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }

87+ let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ]

88+ in modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }

8889

8990checkTypeClassInstance :: ModuleName -> Type -> Check ()

9091checkTypeClassInstance _ (TypeVar _) = return ()

@@ -182,8 +183,8 @@ typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = d

182183 guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env

183184 return $ d : ds

184185typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _) : rest) = do

185− env <- getEnv

186− let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in moduleName == mn) (typeClassDictionaries env)

186+ tcds <- getTypeClassDictionaries

187+ let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in moduleName == mn) tcds

187188 addTypeClassDictionaries [ tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (canonicalizeDictionary tcd) }

188189 | tcd <- instances

189190 , let (Qualified _ ident) = tcdName tcd

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

@@ -21,6 +21,7 @@ module Language.PureScript.TypeChecker.Monad where

2121import Language.PureScript.Types

2222import Language.PureScript.Kinds

2323import Language.PureScript.Names

24+import Language.PureScript.Declarations (canonicalizeDictionary)

2425import Language.PureScript.Environment

2526import Language.PureScript.TypeClassDictionaries

2627import Language.PureScript.Options

@@ -63,7 +64,8 @@ bindTypes newNames action = do

6364withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a

6465withTypeClassDictionaries entries action = do

6566 orig <- get

66− modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }

67+ let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ]

68+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }

6769 a <- action

6870 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }

6971 return a

@@ -72,7 +74,7 @@ withTypeClassDictionaries entries action = do

7274-- Get the currently available list of type class dictionaries

7375--

7476getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [TypeClassDictionaryInScope]

75−getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

77+getTypeClassDictionaries = M.elems . typeClassDictionaries . checkEnv <$> get

7678

7779-- |

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