Merge pull request purescript#1140 from purescript/warn-on-class-operator

garyb · garyb · commit 58acfae19ff7 · 2015-06-06T18:02:39.000+01:00
Warn about declaring operators in classes
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -119,6 +119,7 @@ data SimpleErrorMessage
   | TransitiveExportError DeclarationRef [DeclarationRef]
   | ShadowedName Ident
   | WildcardInferredType Type
+  | ClassOperator ProperName Ident
   deriving (Show)
 
 -- |
@@ -226,6 +227,7 @@ errorCode em = case unwrapErrorMessage em of
   (TransitiveExportError _ _)   -> "TransitiveExportError"
   (ShadowedName _)              -> "ShadowedName"
   (WildcardInferredType _)      -> "WildcardInferredType"
+  (ClassOperator _ _)           -> "ClassOperator"
 
 -- |
 -- A stack trace for an error
@@ -543,6 +545,11 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag
               : map (line . prettyPrintExport) ys
     goSimple (ShadowedName nm) =
       line $ "Name '" ++ show nm ++ "' was shadowed."
+    goSimple (ClassOperator className opName) =
+      paras [ line $ "Class '" ++ show className ++ "' declares operator " ++ show opName ++ "."
+            , indent $ line $ "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"
+            , indent $ line $ show opName ++ " = someMember"
+            ]
     goSimple (WildcardInferredType ty) =
       line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty
     go (NotYetDefined names err) =
diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs
@@ -51,11 +51,20 @@ lint (Module _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ li
 
   lintDeclaration :: Declaration -> m ()
   lintDeclaration d =
-    let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend def stepE stepB def def
+    let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend stepD stepE stepB def def
     in tell (f d)
     where
     def s _ = (s, mempty)
 
+    stepD :: S.Set Ident -> Declaration -> (S.Set Ident, MultipleErrors)
+    stepD s (TypeClassDeclaration name _ _ decls) = (s, foldr go mempty decls)
+      where
+      go :: Declaration -> MultipleErrors -> MultipleErrors
+      go (PositionedDeclaration _ _ d') errs = go d' errs
+      go (TypeDeclaration op@(Op _) _) errs = errorMessage (ClassOperator name op) <> errs
+      go _ errs = errs
+    stepD s _ = (s, mempty)
+
     stepE :: S.Set Ident -> Expr -> (S.Set Ident, MultipleErrors)
     stepE s (Abs (Left name) _) = bind s name
     stepE s (Let ds' _) =
