a23d2a0 · rowtype-yoga/purescript-native

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

compare with golang

unifiedsplit

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

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

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

363 --

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)))

365 -- |

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

367 --

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

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

107

108 exportToPs (TypeInstanceRef ident) = do

109 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

111 let constraintsText = case fromMaybe [] deps of

112 [] -> ""

113 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 {

49 -- |

50 -- Available type class dictionaries

51 --

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))

53 -- |

54 -- Type classes

55 --

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

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

88 toPair (PositionedDeclaration _ _ d) = toPair d

89 toPair _ = error "Invalid declaration in TypeClassDeclaration"

90

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

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

92addTypeClassDictionaries mn entries =

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

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

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

94

95

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

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

96checkDuplicateTypeArguments args = for_ firstDup $ \dup ->

97checkDuplicateTypeArguments args = for_ firstDup $ \dup ->

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

243 mapM_ (checkTypeClassInstance moduleName) tys

244 mapM_ (checkTypeClassInstance moduleName) tys

244 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

245 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

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

246 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

247 ds <- go rest

248 ds <- go rest

248 return $ d : ds

249 return $ d : ds

249

250

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

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

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

48-- return a type class dictionary reference.

49--

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

51entails env moduleName context = solve

52 where

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

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

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

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

55

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]

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

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

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

64

58

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

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

66 solve (className, tys) trySuperclasses = do

60 solve (className, tys) trySuperclasses = do

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

76 where

70 where

77 directInstances :: StateT Work [] DictionaryValue

71 directInstances :: StateT Work [] DictionaryValue

78 directInstances = do

72 directInstances = do

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

73+ tcd <- lift $ forClassName className'

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

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

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

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

82 -- Solve any necessary subgoals

76 -- 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

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

70withTypeClassDictionaries entries action = do

71 orig <- get

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

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.union) (typeClassDictionaries . checkEnv $ st) mentries } }

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

74 a <- action

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

76 return a

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

78-- |

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

80--

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

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

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

82+getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

83

84-- |

85-- Lookup type class dictionaries in a module.

86--

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))

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

89

90-- |