git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Fix type class instances scope issue
544123fPhil Freeman
examples/failing/TypeClasses2.pursnew file+15
compare with golang
unifiedsplit
@@ -0,0 +1,15 @@
1+module TC1 where
2+
3+class Show a where
4+ show :: a -> String
5+
6+module TC2 where
7+
8+instance TC1.Show String where
9+ show s = s
10+
11+module TC3 where
12+
13+import TC1
14+
15+test = show "testing"
examples/passing/TypeClasses.purs+4
@@ -42,7 +42,11 @@ test5 = Just 1 >>= \n -> ret (n + 1)
42
42
43module TypeClasses2 where
43module TypeClasses2 where
44
44
45+import TypeClasses
46+
45instance (TypeClasses.Show a) => TypeClasses.Show [a] where
47instance (TypeClasses.Show a) => TypeClasses.Show [a] where
46 show [] = "[]"
48 show [] = "[]"
47 show (x:xs) = TypeClasses.show x ++ ", " ++ TypeClasses.show xs
49 show (x:xs) = TypeClasses.show x ++ ", " ++ TypeClasses.show xs
48
50
51+test6 = show ["testing"]
52+
purescript.cabal+1−1
@@ -1,5 +1,5 @@
1name: purescript
1name: purescript
2−version: 0.2.15.2
2+version: 0.3.0
3cabal-version: >=1.8
3cabal-version: >=1.8
4build-type: Simple
4build-type: Simple
5license: MIT
5license: MIT
src/Language/PureScript/TypeChecker.hs+45−34
@@ -166,41 +166,51 @@ typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do
166 Just idents' -> do
166 Just idents' -> do
167 shadowIdents (lefts idents') env
167 shadowIdents (lefts idents') env
168 shadowTypes (rights idents') env
168 shadowTypes (rights idents') env
169+ shadowTypeClassInstances env
169 ds <- typeCheckAll currentModule rest
170 ds <- typeCheckAll currentModule rest
170 return $ d : ds
171 return $ d : ds
172+ where
171− where errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)
173+ errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)
172− filterModule = filter ((== moduleName) . fst) . M.keys
174+ filterModule = filter ((== moduleName) . fst) . M.keys
173− moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))
175+ moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))
174− shadowIdents idents' env =
176+ shadowIdents idents' env =
175− forM_ idents' $ \ident -> do
177+ forM_ idents' $ \ident -> do
176− case (moduleName, ident) `M.lookup` names env of
178+ case (moduleName, ident) `M.lookup` names env of
177− Just (_, Alias _ _) -> return ()
179+ Just (_, Alias _ _) -> return ()
178− Just (pt, _) -> do
180+ Just (pt, _) -> do
179− guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env
181+ guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env
180− modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })
182+ modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })
181− Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")
183+ Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")
182− shadowTypes pns env =
184+ shadowTypes pns env =
183− forM_ pns $ \pn -> do
185+ forM_ pns $ \pn -> do
184− case (moduleName, pn) `M.lookup` types env of
186+ case (moduleName, pn) `M.lookup` types env of
185− Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")
187+ Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")
186− Just (_, DataAlias _ _) -> return ()
188+ Just (_, DataAlias _ _) -> return ()
187− Just (k, _) -> do
189+ Just (k, _) -> do
188− guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env
190+ guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env
189− modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })
191+ modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })
190− let keys = map (snd . fst) . filter (\(_, (fn, _)) -> fn `constructs` pn) . M.toList . dataConstructors $ env
192+ let keys = map (snd . fst) . filter (\(_, (fn, _)) -> fn `constructs` pn) . M.toList . dataConstructors $ env
191− forM_ keys $ \dctor -> do
193+ forM_ keys $ \dctor -> do
192− case (moduleName, dctor) `M.lookup` dataConstructors env of
194+ case (moduleName, dctor) `M.lookup` dataConstructors env of
193− Just (_, Alias _ _) -> return ()
195+ Just (_, Alias _ _) -> return ()
194− Just (ctorTy, _) -> do
196+ Just (ctorTy, _) -> do
195− guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env
197+ guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env
196− modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) (ctorTy, Alias moduleName (Ident (runProperName dctor))) (dataConstructors e) })
198+ modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) (ctorTy, Alias moduleName (Ident (runProperName dctor))) (dataConstructors e) })
197− Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined")
199+ Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined")
200+ shadowTypeClassInstances env = do
201+ let instances = filter (\tcd ->
202+ let Qualified (Just mn) _ = tcdName tcd in
203+ moduleName == mn && tcdType tcd == TCDRegular
204+ ) (typeClassDictionaries env)
205+ forM_ instances $ \tcd -> do
206+ let (Qualified _ ident) = tcdName tcd
207+ addTypeClassDictionaries [tcd { tcdName = (Qualified (Just currentModule) ident), tcdType = TCDAlias (tcdName tcd) }]
198− constructs (TypeConstructor (Qualified (Just mn) pn')) pn
208+ constructs (TypeConstructor (Qualified (Just mn) pn')) pn
199− = mn == moduleName && pn' == pn
209+ = mn == moduleName && pn' == pn
200− constructs (ForAll _ ty) pn = ty `constructs` pn
210+ constructs (ForAll _ ty) pn = ty `constructs` pn
201− constructs (Function _ ty) pn = ty `constructs` pn
211+ constructs (Function _ ty) pn = ty `constructs` pn
202− constructs (TypeApp ty _) pn = ty `constructs` pn
212+ constructs (TypeApp ty _) pn = ty `constructs` pn
203− constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
213+ constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
204typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do
214typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do
205 env <- getEnv
215 env <- getEnv
206 ds <- typeCheckAll moduleName rest
216 ds <- typeCheckAll moduleName rest
@@ -208,6 +218,7 @@ typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do
208typeCheckAll moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do
218typeCheckAll moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do
209 env <- getEnv
219 env <- getEnv
210 dictName <- Check . lift $ mkDictionaryValueName moduleName className ty
220 dictName <- Check . lift $ mkDictionaryValueName moduleName className ty
211− addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env [TypeClassDictionaryInScope dictName className ty (Just deps)])
221+ addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env
222+ [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className ty (Just deps) TCDRegular])
212 ds <- typeCheckAll moduleName rest
223 ds <- typeCheckAll moduleName rest
213 return $ qualifyAllUnqualifiedNames moduleName env d : ds
224 return $ qualifyAllUnqualifiedNames moduleName env d : ds
src/Language/PureScript/TypeChecker/Monad.hs+8−3
@@ -33,6 +33,7 @@ import Control.Applicative
33import Control.Monad.State
33import Control.Monad.State
34import Control.Monad.Error
34import Control.Monad.Error
35import Control.Monad.Reader
35import Control.Monad.Reader
36+import Control.Arrow ((***))
36
37
37import qualified Data.Map as M
38import qualified Data.Map as M
38
39
@@ -241,6 +242,10 @@ fresh = unknown . Unknown <$> fresh'
241qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d
242qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d
242qualifyAllUnqualifiedNames mn env = everywhere (mkT go)
243qualifyAllUnqualifiedNames mn env = everywhere (mkT go)
243 where
244 where
244− go :: Qualified ProperName -> Qualified ProperName
245+ go :: Type -> Type
246+ go (TypeConstructor nm) = TypeConstructor $ qualify' nm
247+ go (SaturatedTypeSynonym nm args) = SaturatedTypeSynonym (qualify' nm) args
248+ go (ConstrainedType constraints ty) = ConstrainedType (map (qualify' *** id) constraints) ty
249+ go other = other
245− go qual = let (mn', pn') = canonicalizeType mn env qual
250+ qualify' qual = let (mn', pn') = canonicalizeType mn env qual
246− in Qualified (Just mn') pn'
251+ in Qualified (Just mn') pn'
src/Language/PureScript/TypeChecker/Types.hs+13−5
@@ -196,17 +196,22 @@ entails moduleName context goal@(className, ty) = do
196 (dict : _) -> return dict
196 (dict : _) -> return dict
197 where
197 where
198 go env (className', ty') =
198 go env (className', ty') =
199− [ mkDictionary (tcdName tcd) args
199+ [ mkDictionary (canonicalizeDictionary tcd) args
200 | tcd <- context
200 | tcd <- context
201+ , filterModule tcd
201− , qualify moduleName className' == qualify moduleName (tcdClassName tcd)
202+ , typeConstructorsAreEqual env moduleName className' (tcdClassName tcd)
202 , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' (tcdInstanceType tcd)
203 , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' (tcdInstanceType tcd)
203 , args <- solveSubgoals env subst (tcdDependencies tcd) ]
204 , args <- solveSubgoals env subst (tcdDependencies tcd) ]
204 solveSubgoals _ _ Nothing = return Nothing
205 solveSubgoals _ _ Nothing = return Nothing
205 solveSubgoals env subst (Just subgoals) = do
206 solveSubgoals env subst (Just subgoals) = do
206 dict <- mapM (go env) (replaceAllTypeVars subst subgoals)
207 dict <- mapM (go env) (replaceAllTypeVars subst subgoals)
207 return $ Just dict
208 return $ Just dict
208− mkDictionary fnName Nothing = Var (Qualified Nothing fnName)
209+ mkDictionary fnName args = maybe id (flip App) args $ (Var fnName)
209− mkDictionary fnName (Just args) = App (Var (Qualified Nothing fnName)) args
210+ filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True
211+ filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
212+ filterModule _ = False
213+ canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm
214+ canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm
210
215
211typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
216typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
212typeHeadsAreEqual _ _ String String = Just []
217typeHeadsAreEqual _ _ String String = Just []
@@ -647,7 +652,10 @@ check' val (ConstrainedType constraints ty) = do
647 dictNames <- flip mapM constraints $ \(Qualified _ (ProperName className), _) -> do
652 dictNames <- flip mapM constraints $ \(Qualified _ (ProperName className), _) -> do
648 n <- liftCheck freshDictionaryName
653 n <- liftCheck freshDictionaryName
649 return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
654 return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
650− val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) -> TypeClassDictionaryInScope name className instanceTy Nothing) dictNames (qualifyAllUnqualifiedNames moduleName env constraints)) $ check val ty
655+ val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
656+ TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)
657+ (qualifyAllUnqualifiedNames moduleName env constraints)) $
658+ check val ty
651 return $ Abs dictNames val'
659 return $ Abs dictNames val'
652check' val u@(TUnknown _) = do
660check' val u@(TUnknown _) = do
653 val'@(TypedValue _ _ ty) <- infer val
661 val'@(TypedValue _ _ ty) <- infer val
src/Language/PureScript/Values.hs+6−1
@@ -75,11 +75,16 @@ data Value
75 | Do [DoNotationElement]
75 | Do [DoNotationElement]
76 | TypeClassDictionary (Qualified ProperName, Type) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)
76 | TypeClassDictionary (Qualified ProperName, Type) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)
77
77
78+data TypeClassDictionaryType
79+ = TCDRegular
80+ | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)
81+
78data TypeClassDictionaryInScope
82data TypeClassDictionaryInScope
79− = TypeClassDictionaryInScope { tcdName :: Ident
83+ = TypeClassDictionaryInScope { tcdName :: Qualified Ident
80 , tcdClassName :: Qualified ProperName
84 , tcdClassName :: Qualified ProperName
81 , tcdInstanceType :: Type
85 , tcdInstanceType :: Type
82 , tcdDependencies :: Maybe [(Qualified ProperName, Type)]
86 , tcdDependencies :: Maybe [(Qualified ProperName, Type)]
87+ , tcdType :: TypeClassDictionaryType
83 } deriving (Show, Data, Typeable)
88 } deriving (Show, Data, Typeable)
84
89
85data DoNotationElement
90data DoNotationElement