git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Qualify all unqualified names in type class declarations
c9ea112Phil Freeman
examples/passing/TypeClasses.purs+8
compare with golang
unifiedsplit
@@ -45,3 +45,11 @@ module TypeClasses2 where
45instance (TypeClasses.Show a) => TypeClasses.Show [a] where
45instance (TypeClasses.Show a) => TypeClasses.Show [a] where
46 show [] = "[]"
46 show [] = "[]"
47 show (x:xs) = TypeClasses.show x ++ ", " ++ TypeClasses.show xs
47 show (x:xs) = TypeClasses.show x ++ ", " ++ TypeClasses.show xs
48+
49+module Main where
50+
51+import Trace
52+import TypeClasses
53+import TypeClasses2
54+
55+main = print (show ["a", "b", "c"])
src/Language/PureScript/TypeChecker.hs+10−4
@@ -84,6 +84,10 @@ addValue moduleName name ty = do
84 env <- getEnv
84 env <- getEnv
85 putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Value) (names env) })
85 putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Value) (names env) })
86
86
87+addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
88+addTypeClassDictionaries entries = do
89+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }
90+
87typeCheckAll :: ModuleName -> [Declaration] -> Check [Declaration]
91typeCheckAll :: ModuleName -> [Declaration] -> Check [Declaration]
88typeCheckAll _ [] = return []
92typeCheckAll _ [] = return []
89typeCheckAll moduleName (d@(DataDeclaration name args dctors) : rest) = do
93typeCheckAll moduleName (d@(DataDeclaration name args dctors) : rest) = do
@@ -198,10 +202,12 @@ typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do
198 constructs (TypeApp ty _) pn = ty `constructs` pn
202 constructs (TypeApp ty _) pn = ty `constructs` pn
199 constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
203 constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
200typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do
204typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do
205+ env <- getEnv
201 ds <- typeCheckAll moduleName rest
206 ds <- typeCheckAll moduleName rest
202− return $ d : ds
207+ return $ qualifyAllUnqualifiedNames moduleName env d : ds
203typeCheckAll moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do
208typeCheckAll moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do
209+ env <- getEnv
204 dictName <- Check . lift $ mkDictionaryValueName moduleName className ty
210 dictName <- Check . lift $ mkDictionaryValueName moduleName className ty
205− ds <- withTypeClassDictionaries [TypeClassDictionaryInScope dictName className ty (Just deps)] $
211+ addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env [TypeClassDictionaryInScope dictName className ty (Just deps)])
206− typeCheckAll moduleName rest
212+ ds <- typeCheckAll moduleName rest
207− return $ d : ds
213+ return $ qualifyAllUnqualifiedNames moduleName env d : ds
src/Language/PureScript/TypeChecker/Types.hs+5−4
@@ -192,7 +192,7 @@ entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName,
192entails moduleName context goal@(className, ty) = do
192entails moduleName context goal@(className, ty) = do
193 env <- getEnv
193 env <- getEnv
194 case go env goal of
194 case go env goal of
195− [] -> throwError $ "No " ++ show className ++ " instance found for " ++ show context
195+ [] -> throwError $ "No " ++ show className ++ " instance found for " ++ prettyPrintType ty
196 (dict : _) -> return dict
196 (dict : _) -> return dict
197 where
197 where
198 go env (className', ty') =
198 go env (className', ty') =
@@ -201,7 +201,7 @@ entails moduleName context goal@(className, ty) = do
201 , qualify moduleName className' == qualify moduleName (tcdClassName tcd)
201 , qualify moduleName className' == qualify moduleName (tcdClassName tcd)
202 , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' (tcdInstanceType tcd)
202 , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' (tcdInstanceType tcd)
203 , args <- solveSubgoals env subst (tcdDependencies tcd) ]
203 , args <- solveSubgoals env subst (tcdDependencies tcd) ]
204− solveSubgoals _ _ Nothing = [Nothing]
204+ solveSubgoals _ _ Nothing = return Nothing
205 solveSubgoals env subst (Just subgoals) = do
205 solveSubgoals env subst (Just subgoals) = do
206 dict <- mapM (go env) (replaceAllTypeVars subst subgoals)
206 dict <- mapM (go env) (replaceAllTypeVars subst subgoals)
207 return $ Just dict
207 return $ Just dict
@@ -213,8 +213,9 @@ typeHeadsAreEqual _ _ String String = Just []
213typeHeadsAreEqual _ _ Number Number = Just []
213typeHeadsAreEqual _ _ Number Number = Just []
214typeHeadsAreEqual _ _ Boolean Boolean = Just []
214typeHeadsAreEqual _ _ Boolean Boolean = Just []
215typeHeadsAreEqual _ _ (Skolem s1) (Skolem s2) | s1 == s2 = Just []
215typeHeadsAreEqual _ _ (Skolem s1) (Skolem s2) | s1 == s2 = Just []
216−typeHeadsAreEqual m e (Array (TypeVar v)) (Array ty) = Just [(v, ty)]
216+typeHeadsAreEqual _ _ (Array (TypeVar v)) (Array ty) = Just [(v, ty)]
217−typeHeadsAreEqual m e (Array ty) (Array (TypeVar v)) = Just [(v, ty)]
217+typeHeadsAreEqual _ _ (Array ty) (Array (TypeVar v)) = Just [(v, ty)]
218+typeHeadsAreEqual m e (Array ty1) (Array ty2) = typeHeadsAreEqual m e ty1 ty2
218typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructorsAreEqual e m c1 c2 = Just []
219typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructorsAreEqual e m c1 c2 = Just []
219typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2
220typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2
220typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1
221typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1