git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Qualify all unqualified names in type class declarations
commitc9ea112b366432c60a7efc1dc3ea6dea3cda8122 authorPhil Freeman <paf31@cantab.net> dateThu 16 Jan 2014, 21:30 (13 years ago) parentf3d1bb0
3 files changed+23−8
compare with golang
unifiedsplit
examples/passing/TypeClasses.purs+8 src/Language/PureScript/TypeChecker.hs+10−4 src/Language/PureScript/TypeChecker/Types.hs+5−4
examples/passing/TypeClasses.purs+8
@@ -45,3 +45,11 @@ module TypeClasses2 where
4545instance (TypeClasses.Show a) => TypeClasses.Show [a] where
4646 show [] = "[]"
4747 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
8484 env <- getEnv
8585 putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Value) (names env) })
8686
87+addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
88+addTypeClassDictionaries entries = do
89+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }
90+
8791typeCheckAll :: ModuleName -> [Declaration] -> Check [Declaration]
8892typeCheckAll _ [] = return []
8993typeCheckAll moduleName (d@(DataDeclaration name args dctors) : rest) = do
@@ -198,10 +202,12 @@ typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do
198202 constructs (TypeApp ty _) pn = ty `constructs` pn
199203 constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
200204typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do
205+ env <- getEnv
201206 ds <- typeCheckAll moduleName rest
202− return $ d : ds
207+ return $ qualifyAllUnqualifiedNames moduleName env d : ds
203208typeCheckAll moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do
209+ env <- getEnv
204210 dictName <- Check . lift $ mkDictionaryValueName moduleName className ty
205− ds <- withTypeClassDictionaries [TypeClassDictionaryInScope dictName className ty (Just deps)] $
206− typeCheckAll moduleName rest
207− return $ d : ds
211+ addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env [TypeClassDictionaryInScope dictName className ty (Just deps)])
212+ ds <- typeCheckAll moduleName rest
213+ return $ qualifyAllUnqualifiedNames moduleName env d : ds
src/Language/PureScript/TypeChecker/Types.hs+5−4
@@ -192,7 +192,7 @@ entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName,
192192entails moduleName context goal@(className, ty) = do
193193 env <- getEnv
194194 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
196196 (dict : _) -> return dict
197197 where
198198 go env (className', ty') =
@@ -201,7 +201,7 @@ entails moduleName context goal@(className, ty) = do
201201 , qualify moduleName className' == qualify moduleName (tcdClassName tcd)
202202 , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' (tcdInstanceType tcd)
203203 , args <- solveSubgoals env subst (tcdDependencies tcd) ]
204− solveSubgoals _ _ Nothing = [Nothing]
204+ solveSubgoals _ _ Nothing = return Nothing
205205 solveSubgoals env subst (Just subgoals) = do
206206 dict <- mapM (go env) (replaceAllTypeVars subst subgoals)
207207 return $ Just dict
@@ -213,8 +213,9 @@ typeHeadsAreEqual _ _ String String = Just []
213213typeHeadsAreEqual _ _ Number Number = Just []
214214typeHeadsAreEqual _ _ Boolean Boolean = Just []
215215typeHeadsAreEqual _ _ (Skolem s1) (Skolem s2) | s1 == s2 = Just []
216−typeHeadsAreEqual m e (Array (TypeVar v)) (Array ty) = Just [(v, ty)]
217−typeHeadsAreEqual m e (Array ty) (Array (TypeVar v)) = Just [(v, ty)]
216+typeHeadsAreEqual _ _ (Array (TypeVar v)) (Array ty) = 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
218219typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructorsAreEqual e m c1 c2 = Just []
219220typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2
220221typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1