Update orphan instance check to use covering sets

LiamGoodacre · LiamGoodacre · commit 26b73d679aaa · 2017-01-02T00:38:14.000Z
diff --git a/examples/failing/OrphanInstanceFunDepCycle.purs b/examples/failing/OrphanInstanceFunDepCycle.purs
@@ -0,0 +1,5 @@
+-- @shouldFailWith OrphanInstance
+module Main where
+import Lib
+data L
+instance clr :: C L R
diff --git a/examples/failing/OrphanInstanceFunDepCycle/Lib.purs b/examples/failing/OrphanInstanceFunDepCycle/Lib.purs
@@ -0,0 +1,4 @@
+module Lib where
+-- covering sets: {{l}, {r}}
+class C l r | l -> r, r -> l
+data R
diff --git a/examples/failing/OrphanInstanceNullary.purs b/examples/failing/OrphanInstanceNullary.purs
@@ -0,0 +1,4 @@
+-- @shouldFailWith OrphanInstance
+module Test where
+import Lib
+instance c :: C
diff --git a/examples/failing/OrphanInstanceNullary/Lib.purs b/examples/failing/OrphanInstanceNullary/Lib.purs
@@ -0,0 +1,2 @@
+module Lib where
+class C
diff --git a/examples/failing/OrphanInstanceWithDetermined.purs b/examples/failing/OrphanInstanceWithDetermined.purs
@@ -0,0 +1,5 @@
+-- @shouldFailWith OrphanInstance
+module Main where
+import Lib
+data R
+instance cflr :: C F L R
diff --git a/examples/failing/OrphanInstanceWithDetermined/Lib.purs b/examples/failing/OrphanInstanceWithDetermined/Lib.purs
@@ -0,0 +1,5 @@
+module Lib where
+-- covering sets: {{f, l}}
+class C f l r | l -> r
+data F
+data L
diff --git a/examples/passing/NonOrphanInstanceFunDepExtra.purs b/examples/passing/NonOrphanInstanceFunDepExtra.purs
@@ -0,0 +1,8 @@
+-- Both f and l must be known, thus can be in separate modules
+module Main where
+import Control.Monad.Eff.Console (log)
+import Lib
+data F
+data R
+instance cflr :: C F L R
+main = log "Done"
diff --git a/examples/passing/NonOrphanInstanceFunDepExtra/Lib.purs b/examples/passing/NonOrphanInstanceFunDepExtra/Lib.purs
@@ -0,0 +1,4 @@
+module Lib where
+-- covering sets: {{f, l}}
+class C f l r | l -> r
+data L
diff --git a/examples/passing/NonOrphanInstanceMulti.purs b/examples/passing/NonOrphanInstanceMulti.purs
@@ -0,0 +1,7 @@
+-- Both l and r must be known, thus can be in separate modules
+module Main where
+import Control.Monad.Eff.Console (log)
+import Lib
+data L
+instance clr :: C L R
+main = log "Done"
diff --git a/examples/passing/NonOrphanInstanceMulti/Lib.purs b/examples/passing/NonOrphanInstanceMulti/Lib.purs
@@ -0,0 +1,4 @@
+module Lib where
+-- covering sets: {{l, r}}
+class C l r
+data R
diff --git a/purescript.cabal b/purescript.cabal
@@ -40,6 +40,8 @@ extra-source-files: examples/passing/*.purs
                   , examples/passing/ModuleExportQualified/*.purs
                   , examples/passing/ModuleExportSelf/*.purs
                   , examples/passing/NonConflictingExports/*.purs
+                  , examples/passing/NonOrphanInstanceMulti/*.purs
+                  , examples/passing/NonOrphanInstanceFunDepExtra/*.purs
                   , examples/passing/OperatorAliasElsewhere/*.purs
                   , examples/passing/Operators/*.purs
                   , examples/passing/PendingConflictingImports/*.purs
@@ -80,6 +82,9 @@ extra-source-files: examples/passing/*.purs
                   , examples/failing/ImportModule/*.purs
                   , examples/failing/InstanceExport/*.purs
                   , examples/failing/OrphanInstance/*.purs
+                  , examples/failing/OrphanInstanceFunDepCycle/*.purs
+                  , examples/failing/OrphanInstanceWithDetermined/*.purs
+                  , examples/failing/OrphanInstanceNullary/*.purs
                   , examples/warning/*.purs
                   , examples/warning/*.js
                   , examples/warning/UnusedExplicitImportTypeOp/*.purs
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
@@ -8,11 +8,13 @@ import Data.Aeson.TH
 import qualified Data.Aeson as A
 import qualified Data.Map as M
 import qualified Data.Set as S
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.List (nub)
+import Data.Tree (Tree, rootLabel)
 import qualified Data.Graph as G
+import Data.Foldable (toList)
 
 import Language.PureScript.Crash
 import Language.PureScript.Kinds
@@ -57,6 +59,8 @@ data TypeClassData = TypeClassData
   -- ^ A set of indexes of type argument that are fully determined by other
   -- arguments via functional dependencies. This can be computed from both
   -- typeClassArguments and typeClassDependencies.
+  , typeClassCoveringSets :: S.Set (S.Set Int)
+  -- ^ A sets of arguments that can be used to infer all other arguments.
   } deriving Show
 
 -- | A functional dependency indicates a relationship between two sets of
@@ -75,16 +79,20 @@ initEnvironment :: Environment
 initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses primKinds
 
 -- |
--- A constructor for TypeClassData that computes which type class arguments are fully determined.
+-- A constructor for TypeClassData that computes which type class arguments are fully determined
+-- and argument covering sets.
 -- Fully determined means that this argument cannot be used when selecting a type class instance.
+-- A covering set is a minimal collection of arguments that can be used to find an instance and
+-- therefore determine all other type arguments.
 --
 -- An example of the difference between determined and fully determined would be with the class:
 -- ```class C a b c | a -> b, b -> a, b -> c```
 -- In this case, `a` must differ when `b` differs, and vice versa - each is determined by the other.
 -- Both `a` and `b` can be used in selecting a type class instance. However, `c` cannot - it is
 -- fully determined by `a` and `b`.
 --
--- Define a graph of type class arguments with edges being fundep determiners to determined.
+-- Define a graph of type class arguments with edges being fundep determiners to determined. Each
+-- argument also has a self looping edge.
 -- An argument is fully determined if doesn't appear at the start of a path of strongly connected components.
 -- An argument is not fully determined otherwise.
 --
@@ -97,26 +105,51 @@ makeTypeClassData
   -> [Constraint]
   -> [FunctionalDependency]
   -> TypeClassData
-makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs
+makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs coveringSets
   where
+    argumentIndicies = [0 .. length args - 1]
+
+    -- each argument determines themselves
+    identities = (\i -> (i, [i])) <$> argumentIndicies
+
     -- list all the edges in the graph: for each fundep an edge exists for each determiner to each determined
-    contributingDeps = M.fromListWith (++) $ do
+    contributingDeps = M.fromListWith (++) $ identities ++ do
       fd <- deps
       src <- fdDeterminers fd
       (src, fdDetermined fd) : map (, []) (fdDetermined fd)
 
-    -- here we build a graph of which arguments determine other arguments
-    (depGraph, _, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, nub v)) <$> M.toList contributingDeps)
+    -- build a graph of which arguments determine other arguments
+    (depGraph, fromVertex, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, nub v)) <$> M.toList contributingDeps)
 
     -- do there exist any arguments that contribute to `arg` that `arg` doesn't contribute to
+    isFunDepDetermined :: Int -> Bool
     isFunDepDetermined arg = case fromKey arg of
-      Nothing -> False -- not mentioned in fundeps
+      Nothing -> internalError "Unknown argument index in makeTypeClassData"
       Just v -> let contributesToVar = G.reachable (G.transposeG depGraph) v
                     varContributesTo = G.reachable depGraph v
                 in any (\r -> not (r `elem` varContributesTo)) contributesToVar
 
     -- find all the arguments that are determined
-    determinedArgs = S.fromList $ filter isFunDepDetermined [0 .. length args - 1]
+    determinedArgs :: S.Set Int
+    determinedArgs = S.fromList $ filter isFunDepDetermined argumentIndicies
+
+    argFromVertex :: G.Vertex -> Int
+    argFromVertex index = let (_, arg, _) = fromVertex index in arg
+
+    isVertexDetermined :: G.Vertex -> Bool
+    isVertexDetermined = isFunDepDetermined . argFromVertex
+
+    -- from an scc find the non-determined args
+    sccNonDetermined :: Tree G.Vertex -> Maybe [Int]
+    sccNonDetermined tree
+      -- if any arg in an scc is determined then all of them are
+      | isVertexDetermined (rootLabel tree) = Nothing
+      | otherwise = Just (argFromVertex <$> toList tree)
+
+    -- find the covering sets
+    coveringSets :: S.Set (S.Set Int)
+    coveringSets = let funDepSets = sequence (mapMaybe sccNonDetermined (G.scc depGraph))
+                   in S.fromList (S.fromList <$> funDepSets)
 
 -- |
 -- The visibility of a name in scope
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -716,7 +716,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
                 , Box.vcat Box.left (map typeAtomAsBox ts)
                 ]
             , line "is an orphan instance."
-            , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."
+            , line "An orphan instance is one which is defined in a module that is unrelated to either the class or the collection of data types that the instance is defined for."
             , line "Consider moving the instance, if possible, or using a newtype wrapper."
             ]
     renderSimpleErrorMessage (InvalidNewtype name) =
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
@@ -18,7 +18,7 @@ import Control.Monad.Supply.Class (MonadSupply)
 import Control.Monad.Writer.Class (MonadWriter(..))
 import Control.Lens ((^..), _1, _2)
 
-import Data.Foldable (for_, traverse_)
+import Data.Foldable (for_, traverse_, toList)
 import Data.List (nub, nubBy, (\\), sort, group)
 import Data.Maybe
 import qualified Data.Map as M
@@ -298,7 +298,7 @@ typeCheckAll moduleName _ = traverse go
       Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration"
       Just typeClass -> do
         sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys)
-        checkOrphanInstance dictName className tys
+        checkOrphanInstance dictName className typeClass tys
         _ <- traverseTypeInstanceBody checkInstanceMembers body
         let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)
         addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict
@@ -324,19 +324,35 @@ typeCheckAll moduleName _ = traverse go
       | otherwise = firstDuplicate xs
     firstDuplicate _ = Nothing
 
-  checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> m ()
-  checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'
-    | moduleName == mn' || any checkType tys' = return ()
+  checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [Type] -> m ()
+  checkOrphanInstance dictName className@(Qualified (Just mn') _) typeClass tys'
+    | moduleName == mn' || moduleName `S.member` nonOrphanModules = return ()
     | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'
     where
-    checkType :: Type -> Bool
-    checkType (TypeVar _) = False
-    checkType (TypeLevelString _) = False
-    checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''
-    checkType (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance"
-    checkType (TypeApp t1 _) = checkType t1
-    checkType _ = internalError "Invalid type in instance in checkOrphanInstance"
-  checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance"
+    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 (TypeApp t1 _) = typeModule t1
+    typeModule _ = internalError "Invalid type in instance in checkOrphanInstance"
+
+    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"
+
+    -- 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"
 
   -- |
   -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
