From abaad91f9d58170643f4ce931af1802b003c686f Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sun, 22 Oct 2017 19:10:53 +0100 Subject: [PATCH] Check that instance declarations don't overlap in related modules --- examples/failing/OverlapAcrossModules.purs | 7 ++ .../failing/OverlapAcrossModules/Class.purs | 2 + examples/failing/OverlapAcrossModules/X.purs | 4 + .../passing/ExportedInstanceDeclarations.purs | 24 ++--- examples/passing/MPTCs.purs | 6 +- src/Language/PureScript/TypeChecker.hs | 93 ++++++++++++++++--- src/Language/PureScript/TypeChecker/Monad.hs | 8 ++ tests/support/bower.json | 2 +- 8 files changed, 115 insertions(+), 31 deletions(-) create mode 100644 examples/failing/OverlapAcrossModules.purs create mode 100644 examples/failing/OverlapAcrossModules/Class.purs create mode 100644 examples/failing/OverlapAcrossModules/X.purs diff --git a/examples/failing/OverlapAcrossModules.purs b/examples/failing/OverlapAcrossModules.purs new file mode 100644 index 0000000000..29c87b889c --- /dev/null +++ b/examples/failing/OverlapAcrossModules.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith OverlappingInstances +module OverlapAcrossModules where +import OverlapAcrossModules.Class +import OverlapAcrossModules.X +data Y +instance cxy :: C X Y + diff --git a/examples/failing/OverlapAcrossModules/Class.purs b/examples/failing/OverlapAcrossModules/Class.purs new file mode 100644 index 0000000000..6b4699a9a1 --- /dev/null +++ b/examples/failing/OverlapAcrossModules/Class.purs @@ -0,0 +1,2 @@ +module OverlapAcrossModules.Class where +class C x y diff --git a/examples/failing/OverlapAcrossModules/X.purs b/examples/failing/OverlapAcrossModules/X.purs new file mode 100644 index 0000000000..df3a6b2d13 --- /dev/null +++ b/examples/failing/OverlapAcrossModules/X.purs @@ -0,0 +1,4 @@ +module OverlapAcrossModules.X where +import OverlapAcrossModules.Class +data X +instance cxy :: C X y diff --git a/examples/passing/ExportedInstanceDeclarations.purs b/examples/passing/ExportedInstanceDeclarations.purs index ee3dd922a9..97cd196bf4 100644 --- a/examples/passing/ExportedInstanceDeclarations.purs +++ b/examples/passing/ExportedInstanceDeclarations.purs @@ -22,24 +22,24 @@ class NonexportedClass a where -- There are three places that a nonexported type or type class can occur, -- leading an instance to count as non-exported: +-- * The instance types -- * Constraints -- * The type class itself --- * The instance types --- Case 1: constraints -instance nonExportedFoo :: (NonexportedClass a) => Foo a where - foo = notExported - --- Another instance of case 1: -instance nonExportedFoo2 :: (Foo NonexportedType) => Foo (a -> a) where +-- Case 1: instance types +instance constFoo :: Foo (Const NonexportedType b) where + foo = Const NonexportedType +else +-- Case 2: constraints +instance nonExportedFoo :: (Foo NonexportedType) => Foo (a -> a) where foo = id +else +-- Another instance of case 2: +instance nonExportedFoo2 :: (NonexportedClass a) => Foo a where + foo = notExported --- Case 2: type class +-- Case 3: type class instance nonExportedNonexportedType :: NonexportedClass (Const Int a) where notExported = Const 0 --- Case 3: instance types -instance constFoo :: Foo (Const NonexportedType b) where - foo = Const NonexportedType - main = log "Done" diff --git a/examples/passing/MPTCs.purs b/examples/passing/MPTCs.purs index 195d3dc285..d7587738bd 100644 --- a/examples/passing/MPTCs.purs +++ b/examples/passing/MPTCs.purs @@ -12,10 +12,10 @@ instance nullaryTypeClass :: NullaryTypeClass where class Coerce a b where coerce :: a -> b -instance coerceRefl :: Coerce a a where - coerce a = a - instance coerceShow :: Show a => Coerce a String where coerce = show +else +instance coerceRefl :: Coerce a a where + coerce a = a main = log "Done" diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 9cd3500098..005b5b2bd5 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -334,10 +334,13 @@ typeCheckAll moduleName _ = traverse go Just typeClass -> do checkInstanceArity dictName className typeClass tys sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys) - checkOrphanInstance dictName className typeClass tys + let nonOrphanModules = findNonOrphanModules className typeClass tys + checkOrphanInstance dictName className tys nonOrphanModules + let qualifiedChain = Qualified (Just moduleName) <$> ch + checkOverlappingInstance qualifiedChain dictName className typeClass tys nonOrphanModules _ <- traverseTypeInstanceBody checkInstanceMembers body deps' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps - let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) <$> ch) idx qualifiedDictName [] className tys (Just deps') + let dict = TypeClassDictionaryInScope qualifiedChain idx qualifiedDictName [] className tys (Just deps') addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict return d @@ -365,21 +368,23 @@ typeCheckAll moduleName _ = traverse go | otherwise = firstDuplicate xs firstDuplicate _ = Nothing - checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [Type] -> m () - checkOrphanInstance dictName className@(Qualified (Just mn') _) typeClass tys' - | moduleName `S.member` nonOrphanModules' = return () - | otherwise = throwError . errorMessage $ OrphanInstance dictName className nonOrphanModules' tys' + findNonOrphanModules + :: Qualified (ProperName 'ClassName) + -> TypeClassData + -> [Type] + -> S.Set ModuleName + findNonOrphanModules (Qualified (Just mn') _) typeClass tys' = nonOrphanModules where - nonOrphanModules' :: S.Set ModuleName - nonOrphanModules' = S.insert mn' nonOrphanModules + nonOrphanModules :: S.Set ModuleName + nonOrphanModules = S.insert mn' nonOrphanModules' typeModule :: Type -> Maybe ModuleName typeModule (TypeVar _) = Nothing typeModule (TypeLevelString _) = Nothing typeModule (TypeConstructor (Qualified (Just mn'') _)) = Just mn'' - typeModule (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance" + typeModule (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in findNonOrphanModules" typeModule (TypeApp t1 _) = typeModule t1 - typeModule _ = internalError "Invalid type in instance in checkOrphanInstance" + typeModule _ = internalError "Invalid type in instance in findNonOrphanModules" modulesByTypeIndex :: M.Map Int (Maybe ModuleName) modulesByTypeIndex = M.fromList (zip [0 ..] (typeModule <$> tys')) @@ -387,16 +392,74 @@ typeCheckAll moduleName _ = traverse go lookupModule :: Int -> S.Set ModuleName lookupModule idx = case M.lookup idx modulesByTypeIndex of Just ms -> S.fromList (toList ms) - Nothing -> internalError "Unknown type index in checkOrphanInstance" + Nothing -> internalError "Unknown type index in findNonOrphanModules" -- If the instance is declared in a module that wouldn't be found based on a covering set -- then it is considered an orphan - because we'd have a situation in which we expect an -- instance but can't find it. So a valid module must be applicable across *all* covering -- sets - therefore we take the intersection of covering set modules. - nonOrphanModules :: S.Set ModuleName - nonOrphanModules = foldl1 S.intersection (foldMap lookupModule `S.map` typeClassCoveringSets typeClass) - - checkOrphanInstance _ _ _ _ = internalError "Unqualified class name in checkOrphanInstance" + nonOrphanModules' :: S.Set ModuleName + nonOrphanModules' = foldl1 S.intersection (foldMap lookupModule `S.map` typeClassCoveringSets typeClass) + findNonOrphanModules _ _ _ = internalError "Unqualified class name in findNonOrphanModules" + + -- Check that the instance currently being declared doesn't overlap with any + -- other instance in any module that this instance wouldn't be considered an + -- orphan in. There are overlapping instance situations that won't be caught + -- by this, for example when combining multiparametr type classes with + -- flexible instances: the instances `Cls X y` and `Cls x Y` overlap and + -- could live in different modules but won't be caught here. + checkOverlappingInstance + :: [Qualified Ident] + -> Ident + -> Qualified (ProperName 'ClassName) + -> TypeClassData + -> [Type] + -> S.Set ModuleName + -> m () + checkOverlappingInstance ch dictName className typeClass tys' nonOrphanModules = do + for_ nonOrphanModules $ \m -> do + dicts <- M.toList <$> lookupTypeClassDictionariesForClass (Just m) className + + for_ dicts $ \(ident, dict) -> do + -- ignore instances in the same instance chain + if ch == tcdChain dict || + instancesAreApart (typeClassCoveringSets typeClass) tys' (tcdInstanceTypes dict) + then return () + else throwError . errorMessage $ + OverlappingInstances className + tys' + [ident, Qualified (Just moduleName) dictName] + + instancesAreApart + :: S.Set (S.Set Int) + -> [Type] + -> [Type] + -> Bool + instancesAreApart sets lhs rhs = all (any typesApart . S.toList) (S.toList sets) + where + typesApart :: Int -> Bool + typesApart i = typeHeadsApart (lhs !! i) (rhs !! i) + + -- Note: implementation doesn't need to care about all possible cases: + -- TUnknown, Skolem, etc. + typeHeadsApart :: Type -> Type -> Bool + typeHeadsApart l r | l == r = False + typeHeadsApart (TypeVar _) _ = False + typeHeadsApart _ (TypeVar _) = False + typeHeadsApart (KindedType t1 _) t2 = typeHeadsApart t1 t2 + typeHeadsApart t1 (KindedType t2 _) = typeHeadsApart t1 t2 + typeHeadsApart (TypeApp h1 t1) (TypeApp h2 t2) = typeHeadsApart h1 h2 || typeHeadsApart t1 t2 + typeHeadsApart _ _ = True + + checkOrphanInstance + :: Ident + -> Qualified (ProperName 'ClassName) + -> [Type] + -> S.Set ModuleName + -> m () + checkOrphanInstance dictName className tys' nonOrphanModules + | moduleName `S.member` nonOrphanModules = return () + | otherwise = throwError . errorMessage $ OrphanInstance dictName className nonOrphanModules tys' -- | -- This function adds the argument kinds for a type constructor so that they may appear in the externs file, diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index c8ecc791c2..dcc40cc42f 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -163,6 +163,14 @@ lookupTypeClassDictionaries -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict)) lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get +-- | Lookup type class dictionaries in a module. +lookupTypeClassDictionariesForClass + :: (MonadState CheckState m) + => Maybe ModuleName + -> Qualified (ProperName 'ClassName) + -> m (M.Map (Qualified Ident) NamedDict) +lookupTypeClassDictionariesForClass mn cn = fromMaybe M.empty . M.lookup cn <$> lookupTypeClassDictionaries mn + -- | Temporarily bind a collection of names to local variables bindLocalVariables :: (MonadState CheckState m) diff --git a/tests/support/bower.json b/tests/support/bower.json index 37b855c8b4..9b5b342e07 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -28,7 +28,7 @@ "purescript-partial": "1.2.1", "purescript-prelude": "3.1.0", "purescript-proxy": "2.1.0", - "purescript-psci-support": "3.0.0", + "purescript-psci-support": "purescript/purescript-psci-support#compiler/0.12", "purescript-refs": "3.0.0", "purescript-st": "3.0.0", "purescript-strings": "3.3.0",