From 18a10742db61a3a96abd04ef98e84dc6aa4ecb0e Mon Sep 17 00:00:00 2001
From: Brandon Chinn <brandonchinn178@gmail.com>
Date: Sun, 10 Sep 2023 22:38:07 -0700
Subject: [PATCH] Warn if operators are using different fixity than those in
 base

---
 src/Ormolu/Fixity.hs            | 17 +++++++++++++++++
 src/Ormolu/Fixity/Internal.hs   |  1 +
 src/Ormolu/Logging.hs           |  8 ++++++++
 src/Ormolu/Printer/Operators.hs | 14 +++++++++++++-
 4 files changed, 39 insertions(+), 1 deletion(-)

diff --git a/src/Ormolu/Fixity.hs b/src/Ormolu/Fixity.hs
index f6ba5260..dbb01f8f 100644
--- a/src/Ormolu/Fixity.hs
+++ b/src/Ormolu/Fixity.hs
@@ -29,6 +29,7 @@ module Ormolu.Fixity
     packageFixityMap',
     moduleFixityMap,
     applyFixityOverrides,
+    getShadowedFixities,
   )
 where
 
@@ -43,6 +44,7 @@ import Data.Set (Set)
 import Data.Set qualified as Set
 import Distribution.ModuleName (ModuleName)
 import Distribution.Types.PackageName (PackageName, mkPackageName, unPackageName)
+import GHC.Types.Name.Reader (RdrName, rdrNameOcc)
 import Language.Haskell.Syntax.ImpExp (ImportListInterpretation (..))
 import Ormolu.Fixity.Imports (FixityImport (..))
 import Ormolu.Fixity.Internal
@@ -181,3 +183,18 @@ memoSet f =
   memo (f . Set.fromAscList . fmap mkPackageName)
     . fmap unPackageName
     . Set.toAscList
+
+-- | Return the fixity information that the given operator's fixity is shadowing.
+--
+-- https://github.com/tweag/ormolu/issues/1060
+getShadowedFixities :: RdrName -> FixityApproximation -> Maybe [FixityInfo]
+getShadowedFixities rdrName fixityApprox =
+  case Map.lookup opName m of
+    Just opInfo
+      | let fixityInfos = NE.map (\(_, _, fixityInfo) -> fixityInfo) opInfo,
+        all ((fixityApprox /=) . fixityInfoToApproximation) fixityInfos ->
+          Just $ NE.toList fixityInfos
+    _ -> Nothing
+  where
+    opName = occOpName (rdrNameOcc rdrName)
+    PackageFixityMap m = packageFixityMap defaultDependencies
diff --git a/src/Ormolu/Fixity/Internal.hs b/src/Ormolu/Fixity/Internal.hs
index 40d69621..0ad34327 100644
--- a/src/Ormolu/Fixity/Internal.hs
+++ b/src/Ormolu/Fixity/Internal.hs
@@ -16,6 +16,7 @@ module Ormolu.Fixity.Internal
     defaultFixityInfo,
     FixityApproximation (..),
     defaultFixityApproximation,
+    fixityInfoToApproximation,
     HackageInfo (..),
     FixityOverrides (..),
     defaultFixityOverrides,
diff --git a/src/Ormolu/Logging.hs b/src/Ormolu/Logging.hs
index 45ffde33..51f42066 100644
--- a/src/Ormolu/Logging.hs
+++ b/src/Ormolu/Logging.hs
@@ -2,6 +2,8 @@ module Ormolu.Logging
   ( initializeLogging,
     logDebug,
     logDebugM,
+    logWarn,
+    logWarnM,
     logError,
     logErrorM,
   )
@@ -62,6 +64,12 @@ logDebugM ::
   m ()
 logDebugM label msg = logDebug label msg $ pure ()
 
+logWarn :: String -> a -> a
+logWarn = logDebug "WARNING"
+
+logWarnM :: (Monad m) => String -> m ()
+logWarnM msg = logWarn msg $ pure ()
+
 logError :: String -> a -> a
 logError = logToStderr . pure . Just
 
diff --git a/src/Ormolu/Printer/Operators.hs b/src/Ormolu/Printer/Operators.hs
index 362a3302..008c7176 100644
--- a/src/Ormolu/Printer/Operators.hs
+++ b/src/Ormolu/Printer/Operators.hs
@@ -15,6 +15,7 @@ import Data.List.NonEmpty qualified as NE
 import GHC.Types.Name.Reader
 import GHC.Types.SrcLoc
 import Ormolu.Fixity
+import Ormolu.Logging
 import Ormolu.Utils
 
 -- | Intermediate representation of operator trees, where a branching is not
@@ -119,7 +120,18 @@ addFixityInfo modFixityMap getOpName (OpBranches exprs ops) =
         mrdrName = getOpName o
         fixityApproximation = case mrdrName of
           Nothing -> defaultFixityApproximation
-          Just rdrName -> inferFixity rdrName modFixityMap
+          Just rdrName ->
+            let fixityApprox = inferFixity rdrName modFixityMap
+                logIfOverridden =
+                  case getShadowedFixities rdrName fixityApprox of
+                    Just infos ->
+                      logWarn . unwords $
+                        [ "Operator is possibly using the wrong fixity.",
+                          "Got: " <> show fixityApprox <> ",",
+                          "Fixities being shadowed: " <> show infos
+                        ]
+                    Nothing -> id
+             in logIfOverridden fixityApprox
 
 -- | Given a 'OpTree' of any shape, produce a flat 'OpTree', where every
 -- node and operator is directly connected to the root.