purescript · LiamGoodacre · Apr 13, 2018 · Oct 22, 2017 · paf31 · Oct 22, 2017
diff --git a/examples/failing/OverlapAcrossModules.purs 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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,38 +368,98 @@ 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'))
 
     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
@@ -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
@@ -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",
Original file line number	Diff line number	Diff line change
		@@ -0,0 +1,2 @@
		module OverlapAcrossModules.Class where
		class C x y