a23d2a0 · rowtype-yoga/purescript-native

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

Index type-class dictionaries by class names

Allows more straight forward passing around of dictionaries - no need to convert between a Map and a [] to convert back into a Map. benchmarking unpatched time 14.24 s (12.74 s .. 15.41 s) 0.999 R² (0.996 R² .. 1.000 R²) mean 13.60 s (13.33 s .. 13.77 s) std dev 261.2 ms (0.0 s .. 300.7 ms) variance introduced by outliers: 19% (moderately inflated) benchmarking patched time 9.689 s (8.745 s .. 10.88 s) 0.998 R² (0.994 R² .. 1.000 R²) mean 10.02 s (9.873 s .. 10.14 s) std dev 201.7 ms (0.0 s .. 217.1 ms) variance introduced by outliers: 19% (moderately inflated)

commita23d2a000f0b5465baafb85e2428435839ae54b7 authorBrian McKenna <brian@brianmckenna.org> dateWed 17 Jun 2015, 11:21 (11 years ago) parentc334a04

6 files changed+18−23

compare with golang

unifiedsplit

src/Language/PureScript/AST/Declarations.hs+1−1 src/Language/PureScript/CodeGen/Externs.hs+1−1 src/Language/PureScript/Environment.hs+1−1 src/Language/PureScript/TypeChecker.hs+4−3 src/Language/PureScript/TypeChecker/Entailment.hs+6−12 src/Language/PureScript/TypeChecker/Monad.hs+5−5

src/Language/PureScript/AST/Declarations.hs+1−1

@@ -361,7 +361,7 @@ data Expr

361361 -- at superclass implementations when searching for a dictionary, the type class name and

362362 -- instance type, and the type class dictionaries in scope.

363363 --

364− | TypeClassDictionary Bool Constraint (M.Map (Maybe ModuleName) [TypeClassDictionaryInScope])

364+ | TypeClassDictionary Bool Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

365365 -- |

366366 -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.

367367 --

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

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

107107

108108 exportToPs (TypeInstanceRef ident) = do

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

110− fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find (\tcd -> tcdName tcd == Qualified (Just moduleName) ident && tcdType tcd == TCDRegular) . maybe [] M.elems . M.lookup (Just moduleName) $ typeClassDictionaries env

110+ fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find (\tcd -> tcdName tcd == Qualified (Just moduleName) ident && tcdType tcd == TCDRegular) . maybe [] (M.elems >=> M.elems) . M.lookup (Just moduleName) $ typeClassDictionaries env

111111 let constraintsText = case fromMaybe [] deps of

112112 [] -> ""

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

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

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

4949 -- |

5050 -- Available type class dictionaries

5151 --

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

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

5353 -- |

5454 -- Type classes

5555 --

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

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

8888 toPair (PositionedDeclaration _ _ d) = toPair d

8989 toPair _ = error "Invalid declaration in TypeClassDeclaration"

9090

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

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

9292addTypeClassDictionaries mn entries =

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

93+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } }

94+ where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st)

9495

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

9697checkDuplicateTypeArguments args = for_ firstDup $ \dup ->

@@ -243,7 +244,7 @@ typeCheckAll mainModuleName moduleName exps = go

243244 mapM_ (checkTypeClassInstance moduleName) tys

244245 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

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

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

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

247248 ds <- go rest

248249 return $ d : ds

249250

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

@@ -47,20 +47,14 @@ newtype Work = Work Integer deriving (Show, Eq, Ord, Num)

4747-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

4848-- return a type class dictionary reference.

4949--

50−entails :: Environment -> ModuleName -> M.Map (Maybe ModuleName) [TypeClassDictionaryInScope] -> Constraint -> Bool -> Check Expr

50+entails :: Environment -> ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint -> Bool -> Check Expr

5151entails env moduleName context = solve

5252 where

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

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

53+ forClassName :: Qualified ProperName -> [TypeClassDictionaryInScope]

54+ forClassName cn = findDicts cn Nothing ++ findDicts cn (Just moduleName)

5555

56− sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]

57− sortedNubBy f vs = M.elems (M.fromList (map (f &&& id) vs))

58−

59− dictsInScope :: [TypeClassDictionaryInScope]

60− dictsInScope = findDicts Nothing ++ findDicts (Just moduleName)

61−

62− findDicts :: Maybe ModuleName -> [TypeClassDictionaryInScope]

63− findDicts = fromMaybe [] . flip M.lookup context

56+ findDicts :: Qualified ProperName -> Maybe ModuleName -> [TypeClassDictionaryInScope]

57+ findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context

6458

6559 solve :: Constraint -> Bool -> Check Expr

6660 solve (className, tys) trySuperclasses = do

@@ -76,7 +70,7 @@ entails env moduleName context = solve

7670 where

7771 directInstances :: StateT Work [] DictionaryValue

7872 directInstances = do

79− tcd <- lift . fromMaybe [] $ M.lookup className' byClassName

73+ tcd <- lift $ forClassName className'

8074 -- Make sure the type unifies with the type in the type instance definition

8175 subst <- lift . maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)

8276 -- Solve any necessary subgoals

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

@@ -69,8 +69,8 @@ withScopedTypeVars mn ks = bindTypes (M.fromList (map (\(name, k) -> (Qualified

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

7070withTypeClassDictionaries entries action = do

7171 orig <- get

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

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

72+ let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (canonicalizeDictionary entry) entry)) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _, tcdClassName = className } <- entries ]

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

7474 a <- action

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

7676 return a

@@ -78,13 +78,13 @@ withTypeClassDictionaries entries action = do

7878-- |

7979-- Get the currently available map of type class dictionaries

8080--

81−getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m (M.Map (Maybe ModuleName) [TypeClassDictionaryInScope])

82−getTypeClassDictionaries = fmap M.elems . typeClassDictionaries . checkEnv <$> get

81+getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

82+getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

8383

8484-- |

8585-- Lookup type class dictionaries in a module.

8686--

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

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

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

8989

9090-- |