488f8c2 · rowtype-yoga/purescript-native

examples/failing/OrphanInstanceFunDepCycle.pursnew file+5

compare with golang

unifiedsplit

@@ -0,0 +1,5 @@

1+-- @shouldFailWith OrphanInstance

2+module Main where

3+import Lib

4+data L

5+instance clr :: C L R

examples/failing/OrphanInstanceFunDepCycle/Lib.pursnew file+4

@@ -0,0 +1,4 @@

1+module Lib where

2+-- covering sets: {{l}, {r}}

3+class C l r | l -> r, r -> l

4+data R

examples/failing/OrphanInstanceNullary.pursnew file+4

@@ -0,0 +1,4 @@

1+-- @shouldFailWith OrphanInstance

2+module Test where

3+import Lib

4+instance c :: C

examples/failing/OrphanInstanceNullary/Lib.pursnew file+2

@@ -0,0 +1,2 @@

1+module Lib where

2+class C

examples/failing/OrphanInstanceWithDetermined.pursnew file+5

@@ -0,0 +1,5 @@

1+-- @shouldFailWith OrphanInstance

2+module Main where

3+import Lib

4+data R

5+instance cflr :: C F L R

examples/failing/OrphanInstanceWithDetermined/Lib.pursnew file+5

@@ -0,0 +1,5 @@

1+module Lib where

2+-- covering sets: {{f, l}}

3+class C f l r | l -> r

4+data F

5+data L

examples/passing/NonOrphanInstanceFunDepExtra.pursnew file+8

@@ -0,0 +1,8 @@

1+-- Both f and l must be known, thus can be in separate modules

2+module Main where

3+import Control.Monad.Eff.Console (log)

4+import Lib

5+data F

6+data R

7+instance cflr :: C F L R

8+main = log "Done"

examples/passing/NonOrphanInstanceFunDepExtra/Lib.pursnew file+4

@@ -0,0 +1,4 @@

1+module Lib where

2+-- covering sets: {{f, l}}

3+class C f l r | l -> r

4+data L

examples/passing/NonOrphanInstanceMulti.pursnew file+7

@@ -0,0 +1,7 @@

1+-- Both l and r must be known, thus can be in separate modules

2+module Main where

3+import Control.Monad.Eff.Console (log)

4+import Lib

5+data L

6+instance clr :: C L R

7+main = log "Done"

examples/passing/NonOrphanInstanceMulti/Lib.pursnew file+4

@@ -0,0 +1,4 @@

1+module Lib where

2+-- covering sets: {{l, r}}

3+class C l r

4+data R

purescript.cabal+5

@@ -40,6 +40,8 @@ extra-source-files: examples/passing/*.purs

40 , examples/passing/ModuleExportQualified/*.purs

41 , examples/passing/ModuleExportSelf/*.purs

42 , examples/passing/NonConflictingExports/*.purs

43+ , examples/passing/NonOrphanInstanceMulti/*.purs

44+ , examples/passing/NonOrphanInstanceFunDepExtra/*.purs

43 , examples/passing/OperatorAliasElsewhere/*.purs

45 , examples/passing/OperatorAliasElsewhere/*.purs

44 , examples/passing/Operators/*.purs

46 , examples/passing/Operators/*.purs

45 , examples/passing/PendingConflictingImports/*.purs

47 , examples/passing/PendingConflictingImports/*.purs

@@ -80,6 +82,9 @@ extra-source-files: examples/passing/*.purs

80 , examples/failing/ImportModule/*.purs

82 , examples/failing/ImportModule/*.purs

81 , examples/failing/InstanceExport/*.purs

83 , examples/failing/InstanceExport/*.purs

82 , examples/failing/OrphanInstance/*.purs

84 , examples/failing/OrphanInstance/*.purs

85+ , examples/failing/OrphanInstanceFunDepCycle/*.purs

86+ , examples/failing/OrphanInstanceWithDetermined/*.purs

87+ , examples/failing/OrphanInstanceNullary/*.purs

83 , examples/warning/*.purs

88 , examples/warning/*.purs

84 , examples/warning/*.js

89 , examples/warning/*.js

85 , examples/warning/UnusedExplicitImportTypeOp/*.purs

90 , examples/warning/UnusedExplicitImportTypeOp/*.purs

src/Language/PureScript/Environment.hs+42−9

@@ -8,11 +8,13 @@ import Data.Aeson.TH

8import qualified Data.Aeson as A

9import qualified Data.Map as M

10import qualified Data.Set as S

11−import Data.Maybe (fromMaybe)

11+import Data.Maybe (fromMaybe, mapMaybe)

12import Data.Text (Text)

13import qualified Data.Text as T

14import Data.List (nub)

15+import Data.Tree (Tree, rootLabel)

15import qualified Data.Graph as G

16import qualified Data.Graph as G

17+import Data.Foldable (toList)

16

18

17import Language.PureScript.Crash

19import Language.PureScript.Crash

18import Language.PureScript.Kinds

20import Language.PureScript.Kinds

@@ -57,6 +59,8 @@ data TypeClassData = TypeClassData

57 -- ^ A set of indexes of type argument that are fully determined by other

59 -- ^ A set of indexes of type argument that are fully determined by other

58 -- arguments via functional dependencies. This can be computed from both

60 -- arguments via functional dependencies. This can be computed from both

59 -- typeClassArguments and typeClassDependencies.

61 -- typeClassArguments and typeClassDependencies.

62+ , typeClassCoveringSets :: S.Set (S.Set Int)

63+ -- ^ A sets of arguments that can be used to infer all other arguments.

60 } deriving Show

64 } deriving Show

61

65

62-- | A functional dependency indicates a relationship between two sets of

66-- | A functional dependency indicates a relationship between two sets of

@@ -75,8 +79,11 @@ initEnvironment :: Environment

75initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses primKinds

79initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses primKinds

76

80

77-- |

81-- |

78−-- A constructor for TypeClassData that computes which type class arguments are fully determined.

82+-- A constructor for TypeClassData that computes which type class arguments are fully determined

83+-- and argument covering sets.

79-- Fully determined means that this argument cannot be used when selecting a type class instance.

84-- Fully determined means that this argument cannot be used when selecting a type class instance.

85+-- A covering set is a minimal collection of arguments that can be used to find an instance and

86+-- therefore determine all other type arguments.

80--

87--

81-- An example of the difference between determined and fully determined would be with the class:

88-- An example of the difference between determined and fully determined would be with the class:

82-- ```class C a b c | a -> b, b -> a, b -> c```

89-- ```class C a b c | a -> b, b -> a, b -> c```

@@ -84,7 +91,8 @@ initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClas

84-- Both `a` and `b` can be used in selecting a type class instance. However, `c` cannot - it is

91-- Both `a` and `b` can be used in selecting a type class instance. However, `c` cannot - it is

85-- fully determined by `a` and `b`.

92-- fully determined by `a` and `b`.

86--

93--

87−-- Define a graph of type class arguments with edges being fundep determiners to determined.

94+-- Define a graph of type class arguments with edges being fundep determiners to determined. Each

95+-- argument also has a self looping edge.

88-- An argument is fully determined if doesn't appear at the start of a path of strongly connected components.

96-- An argument is fully determined if doesn't appear at the start of a path of strongly connected components.

89-- An argument is not fully determined otherwise.

97-- An argument is not fully determined otherwise.

90--

98--

@@ -97,26 +105,51 @@ makeTypeClassData

97 -> [Constraint]

105 -> [Constraint]

98 -> [FunctionalDependency]

106 -> [FunctionalDependency]

99 -> TypeClassData

107 -> TypeClassData

100−makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs

108+makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs coveringSets

101 where

109 where

110+ argumentIndicies = [0 .. length args - 1]

111+

112+ -- each argument determines themselves

113+ identities = (\i -> (i, [i])) <$> argumentIndicies

114+

102 -- list all the edges in the graph: for each fundep an edge exists for each determiner to each determined

115 -- list all the edges in the graph: for each fundep an edge exists for each determiner to each determined

103− contributingDeps = M.fromListWith (++) $ do

116+ contributingDeps = M.fromListWith (++) $ identities ++ do

104 fd <- deps

117 fd <- deps

105 src <- fdDeterminers fd

118 src <- fdDeterminers fd

106 (src, fdDetermined fd) : map (, []) (fdDetermined fd)

119 (src, fdDetermined fd) : map (, []) (fdDetermined fd)

107

120

108− -- here we build a graph of which arguments determine other arguments

121+ -- build a graph of which arguments determine other arguments

109− (depGraph, _, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, nub v)) <$> M.toList contributingDeps)

122+ (depGraph, fromVertex, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, nub v)) <$> M.toList contributingDeps)

110

123

111 -- do there exist any arguments that contribute to `arg` that `arg` doesn't contribute to

124 -- do there exist any arguments that contribute to `arg` that `arg` doesn't contribute to

125+ isFunDepDetermined :: Int -> Bool

112 isFunDepDetermined arg = case fromKey arg of

126 isFunDepDetermined arg = case fromKey arg of

113− Nothing -> False -- not mentioned in fundeps

127+ Nothing -> internalError "Unknown argument index in makeTypeClassData"

114 Just v -> let contributesToVar = G.reachable (G.transposeG depGraph) v

128 Just v -> let contributesToVar = G.reachable (G.transposeG depGraph) v

115 varContributesTo = G.reachable depGraph v

129 varContributesTo = G.reachable depGraph v

116 in any (\r -> not (r `elem` varContributesTo)) contributesToVar

130 in any (\r -> not (r `elem` varContributesTo)) contributesToVar

117

131

118 -- find all the arguments that are determined

132 -- find all the arguments that are determined

133+ determinedArgs :: S.Set Int

119− determinedArgs = S.fromList $ filter isFunDepDetermined [0 .. length args - 1]

134+ determinedArgs = S.fromList $ filter isFunDepDetermined argumentIndicies

135+

136+ argFromVertex :: G.Vertex -> Int

137+ argFromVertex index = let (_, arg, _) = fromVertex index in arg

138+

139+ isVertexDetermined :: G.Vertex -> Bool

140+ isVertexDetermined = isFunDepDetermined . argFromVertex

141+

142+ -- from an scc find the non-determined args

143+ sccNonDetermined :: Tree G.Vertex -> Maybe [Int]

144+ sccNonDetermined tree

145+ -- if any arg in an scc is determined then all of them are

146+ | isVertexDetermined (rootLabel tree) = Nothing

147+ | otherwise = Just (argFromVertex <$> toList tree)

148+

149+ -- find the covering sets

150+ coveringSets :: S.Set (S.Set Int)

151+ coveringSets = let funDepSets = sequence (mapMaybe sccNonDetermined (G.scc depGraph))

152+ in S.fromList (S.fromList <$> funDepSets)

120

153

121-- |

154-- |

122-- The visibility of a name in scope

155-- The visibility of a name in scope

src/Language/PureScript/Errors.hs+1−1

@@ -716,7 +716,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

716 , Box.vcat Box.left (map typeAtomAsBox ts)

717 ]

718 , line "is an orphan instance."

719− , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."

719+ , 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."

720 , line "Consider moving the instance, if possible, or using a newtype wrapper."

721 ]

722 renderSimpleErrorMessage (InvalidNewtype name) =

src/Language/PureScript/TypeChecker.hs+29−13

@@ -18,7 +18,7 @@ import Control.Monad.Supply.Class (MonadSupply)

18import Control.Monad.Writer.Class (MonadWriter(..))

19import Control.Lens ((^..), _1, _2)

20

21−import Data.Foldable (for_, traverse_)

21+import Data.Foldable (for_, traverse_, toList)

22import Data.List (nub, nubBy, (\\), sort, group)

23import Data.Maybe

24import qualified Data.Map as M

@@ -298,7 +298,7 @@ typeCheckAll moduleName _ = traverse go

298 Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration"

299 Just typeClass -> do

300 sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys)

301− checkOrphanInstance dictName className tys

301+ checkOrphanInstance dictName className typeClass tys

302 _ <- traverseTypeInstanceBody checkInstanceMembers body

303 let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)

304 addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict

@@ -324,19 +324,35 @@ typeCheckAll moduleName _ = traverse go

324 | otherwise = firstDuplicate xs

325 firstDuplicate _ = Nothing

326

327− checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> m ()

327+ checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [Type] -> m ()

328− checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'

328+ checkOrphanInstance dictName className@(Qualified (Just mn') _) typeClass tys'

329− | moduleName == mn' || any checkType tys' = return ()

329+ | moduleName == mn' || moduleName `S.member` nonOrphanModules = return ()

330 | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'

331 where

332− checkType :: Type -> Bool

332+ typeModule :: Type -> Maybe ModuleName

333− checkType (TypeVar _) = False

333+ typeModule (TypeVar _) = Nothing

334− checkType (TypeLevelString _) = False

334+ typeModule (TypeLevelString _) = Nothing

335− checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''

335+ typeModule (TypeConstructor (Qualified (Just mn'') _)) = Just mn''

336− checkType (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance"

336+ typeModule (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance"

337− checkType (TypeApp t1 _) = checkType t1

337+ typeModule (TypeApp t1 _) = typeModule t1

338− checkType _ = internalError "Invalid type in instance in checkOrphanInstance"

338+ typeModule _ = internalError "Invalid type in instance in checkOrphanInstance"

339+

340+ modulesByTypeIndex :: M.Map Int (Maybe ModuleName)

341+ modulesByTypeIndex = M.fromList (zip [0 ..] (typeModule <$> tys'))

342+

343+ lookupModule :: Int -> S.Set ModuleName

344+ lookupModule idx = case M.lookup idx modulesByTypeIndex of

345+ Just ms -> S.fromList (toList ms)

346+ Nothing -> internalError "Unknown type index in checkOrphanInstance"

347+

348+ -- If the instance is declared in a module that wouldn't be found based on a covering set

349+ -- then it is considered an orphan - because we'd have a situation in which we expect an

350+ -- instance but can't find it. So a valid module must be applicable across *all* covering

351+ -- sets - therefore we take the intersection of covering set modules.

352+ nonOrphanModules :: S.Set ModuleName

353+ nonOrphanModules = foldl1 S.intersection (foldMap lookupModule `S.map` typeClassCoveringSets typeClass)

354+

339− checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance"

355+ checkOrphanInstance _ _ _ _ = internalError "Unqualified class name in checkOrphanInstance"

340

356

341 -- |

357 -- |

342 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,

358 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,