Warn when fixities are different from base

README.md

@@ -18,6 +18,8 @@
     * [Regions](#regions)
     * [Exit codes](#exit-codes)
     * [Using as a library](#using-as-a-library)
+* [Troubleshooting](#troubleshooting)
+    * [Operators are being formatted weirdly!](#operators-are-being-formatted-weirdly)
 * [Limitations](#limitations)
 * [Running on Hackage](#running-on-hackage)
 * [Forks and modifications](#forks-and-modifications)
@@ -272,6 +274,23 @@ For these purposes only the top `Ormolu` module should be considered stable.
 It follows [PVP](https://pvp.haskell.org/) starting from the version
 0.5.3.0. Rely on other modules at your own risk.
 
+## Troubleshooting
+
+### Operators are being formatted weirdly!
+
+This can happen when Ormolu doesn't know or can't determine the fixity of an operator.
+
+* If this is a custom operator, see the instructions in the "Language extensions, dependencies, and fixities" section to specify the correct fixities in a `.ormolu` file.
+
+* If this is a third-party operator (e.g. from `base` or some other package from Hackage), Ormolu probably doesn't recognize that the operator is the same as the third-party one.
+
+    Some reasons this might be the case:
+
+    * You might have a custom Prelude that re-exports things from Prelude
+    * You might have `-XNoImplicitPrelude` turned on
+
+    If any of these are true, make sure to specify the reexports correctly in a `.ormolu` file.
+
 ## Limitations
 
 * CPP support is experimental. CPP is virtually impossible to handle

app/Main.hs

@@ -24,6 +24,7 @@ import Options.Applicative
 import Ormolu
 import Ormolu.Diff.Text (diffText, printTextDiff)
 import Ormolu.Fixity
+import Ormolu.Logging
 import Ormolu.Parser (manualExts)
 import Ormolu.Terminal
 import Ormolu.Utils (showOutputable)
@@ -33,12 +34,13 @@ import Paths_ormolu (version)
 import System.Directory
 import System.Exit (ExitCode (..), exitWith)
 import System.FilePath qualified as FP
-import System.IO (hPutStrLn, stderr)
+import System.IO (stderr)
 
 -- | Entry point of the program.
 main :: IO ()
 main = do
   Opts {..} <- execParser optsParserInfo
+  initializeLogging optConfig
   let formatOne' =
         formatOne
           optConfigFileOpts
@@ -82,22 +84,17 @@ formatOne ConfigFileOpts {..} mode reqSourceType rawConfig mpath =
   withPrettyOrmoluExceptions (cfgColorMode rawConfig) $ do
     let getCabalInfoForSourceFile' sourceFile = do
           cabalSearchResult <- getCabalInfoForSourceFile sourceFile
-          let debugEnabled = cfgDebug rawConfig
           case cabalSearchResult of
             CabalNotFound -> do
-              when debugEnabled $
-                hPutStrLn stderr $
-                  "Could not find a .cabal file for " <> sourceFile
+              logDebugM "CABAL FILE" $ "Could not find a .cabal file for " <> sourceFile
               return Nothing
             CabalDidNotMention cabalInfo -> do
-              when debugEnabled $ do
-                relativeCabalFile <-
-                  makeRelativeToCurrentDirectory (ciCabalFilePath cabalInfo)
-                hPutStrLn stderr $
-                  "Found .cabal file "
-                    <> relativeCabalFile
-                    <> ", but it did not mention "
-                    <> sourceFile
+              relativeCabalFile <- makeRelativeToCurrentDirectory (ciCabalFilePath cabalInfo)
+              logDebugM "CABAL FILE" $
+                "Found .cabal file "
+                  <> relativeCabalFile
+                  <> ", but it did not mention "
+                  <> sourceFile
               return (Just cabalInfo)
             CabalFound cabalInfo -> return (Just cabalInfo)
         getDotOrmoluForSourceFile' sourceFile = do
@@ -120,9 +117,7 @@ formatOne ConfigFileOpts {..} mode reqSourceType rawConfig mpath =
             ormoluStdin config >>= TIO.putStr
             return ExitSuccess
           InPlace -> do
-            hPutStrLn
-              stderr
-              "In place editing is not supported when input comes from stdin."
+            logErrorM "In place editing is not supported when input comes from stdin."
             -- 101 is different from all the other exit codes we already use.
             return (ExitFailure 101)
           Check -> do

ormolu.cabal

@@ -47,6 +47,7 @@ library
         Ormolu.Diff.Text
         Ormolu.Exception
         Ormolu.Imports
+        Ormolu.Logging
         Ormolu.Parser
         Ormolu.Parser.CommentStream
         Ormolu.Parser.Pragma
@@ -155,10 +156,11 @@ executable ormolu
 
 test-suite tests
     type:               exitcode-stdio-1.0
-    main-is:            Spec.hs
+    main-is:            Main.hs
     build-tool-depends: hspec-discover:hspec-discover >=2 && <3
     hs-source-dirs:     tests
     other-modules:
+        Spec
         Ormolu.CabalInfoSpec
         Ormolu.Diff.TextSpec
         Ormolu.Fixity.ParserSpec

src/Ormolu.hs

@@ -45,7 +45,6 @@ import Data.Maybe (fromMaybe)
 import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Text qualified as T
-import Debug.Trace
 import GHC.Driver.Errors.Types
 import GHC.Types.Error
 import GHC.Types.SrcLoc
@@ -55,6 +54,7 @@ import Ormolu.Diff.ParseResult
 import Ormolu.Diff.Text
 import Ormolu.Exception
 import Ormolu.Fixity
+import Ormolu.Logging
 import Ormolu.Parser
 import Ormolu.Parser.CommentStream (CommentStream (..))
 import Ormolu.Parser.Result
@@ -88,25 +88,31 @@ ormolu ::
   Text ->
   m Text
 ormolu cfgWithIndices path originalInput = do
+  liftIO $ initializeLogging cfgWithIndices
+
   let totalLines = length (T.lines originalInput)
       cfg = regionIndicesToDeltas totalLines <$> cfgWithIndices
       fixityMap =
         packageFixityMap
           (overapproximatedDependencies cfg) -- memoized on the set of dependencies
-  when (cfgDebug cfg) $ do
-    traceM $ unwords ["*** CONFIG ***", show cfg]
+
+  -- log inputs in debug logs
+  logDebugM "CONFIG" $ show cfg
+
   (warnings, result0) <-
     parseModule' cfg fixityMap OrmoluParsingFailed path originalInput
-  when (cfgDebug cfg) $ do
-    forM_ warnings $ \driverMsg -> do
-      let driverMsgSDoc = formatBulleted $ diagnosticMessage defaultOpts driverMsg
-      traceM $ unwords ["*** WARNING ***", showOutputable driverMsgSDoc]
-    forM_ result0 $ \case
-      ParsedSnippet r -> do
-        let CommentStream comments = prCommentStream r
-        forM_ comments $ \(L loc comment) ->
-          traceM $ unwords ["*** COMMENT ***", showOutputable loc, show comment]
-      _ -> pure ()
+
+  -- log parsing results in debug logs
+  forM_ warnings $ \driverMsg -> do
+    let driverMsgSDoc = formatBulleted $ diagnosticMessage defaultOpts driverMsg
+    logDebugM "WARNING" $ unwords [showOutputable driverMsgSDoc]
+  forM_ result0 $ \case
+    ParsedSnippet r -> do
+      let CommentStream comments = prCommentStream r
+      forM_ comments $ \(L loc comment) ->
+        logDebugM "COMMENT" $ unwords [showOutputable loc, show comment]
+    _ -> pure ()
+
   -- We're forcing 'formattedText' here because otherwise errors (such as
   -- messages about not-yet-supported functionality) will be thrown later
   -- when we try to parse the rendered code back, inside of GHC monad

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

src/Ormolu/Fixity/Internal.hs

@@ -16,6 +16,7 @@ module Ormolu.Fixity.Internal
     defaultFixityInfo,
     FixityApproximation (..),
     defaultFixityApproximation,
+    fixityInfoToApproximation,
     HackageInfo (..),
     FixityOverrides (..),
     defaultFixityOverrides,

src/Ormolu/Logging.hs

@@ -0,0 +1,80 @@
+module Ormolu.Logging
+  ( initializeLogging,
+    logDebug,
+    logDebugM,
+    logWarn,
+    logError,
+    logErrorM,
+  )
+where
+
+import Data.Foldable (traverse_)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Ormolu.Config (Config (..))
+import System.IO (hPutStrLn, stderr)
+import System.IO.Unsafe (unsafePerformIO)
+
+data LoggerConfig = LoggerConfig
+  { debugEnabled :: Bool
+  }
+
+loggerConfig :: IORef LoggerConfig
+loggerConfig = unsafePerformIO $ newIORef (error "Logger not configured yet")
+{-# NOINLINE loggerConfig #-}
+
+initializeLogging :: Config region -> IO ()
+initializeLogging cfg =
+  writeIORef loggerConfig $
+    LoggerConfig
+      { debugEnabled = cfgDebug cfg
+      }
+
+-- | Output a debug log to stderr.
+--
+-- Requires initializeLogging to be called first.
+logDebug ::
+  -- | Some label to prefix the message with
+  String ->
+  -- | The message, ideally on a single line
+  String ->
+  a ->
+  a
+logDebug label msg = logToStderr getMessage
+  where
+    getMessage = do
+      cfg <- readIORef loggerConfig
+      pure $
+        if debugEnabled cfg
+          then
+            Just . unwords $
+              [ "*** " <> label <> " ***",
+                msg
+              ]
+          else Nothing
+
+-- | Output a debug log to stderr.
+--
+-- Requires initializeLogging to be called first.
+logDebugM ::
+  (Monad m) =>
+  -- | Some label to prefix the message with
+  String ->
+  -- | The message, ideally on a single line
+  String ->
+  m ()
+logDebugM label msg = logDebug label msg $ pure ()
+
+logWarn :: String -> a -> a
+logWarn = logDebug "WARNING"
+
+logError :: String -> a -> a
+logError = logToStderr . pure . Just
+
+logErrorM :: (Monad m) => String -> m ()
+logErrorM msg = logError msg $ pure ()
+
+logToStderr :: IO (Maybe String) -> a -> a
+logToStderr getMessage a =
+  unsafePerformIO $ do
+    traverse_ (hPutStrLn stderr) =<< getMessage
+    pure a

src/Ormolu/Printer/Operators.hs

@@ -18,6 +18,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
@@ -125,7 +126,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.

tests/Main.hs

@@ -0,0 +1,11 @@
+module Main where
+
+import Ormolu.Config qualified as Ormolu
+import Ormolu.Logging (initializeLogging)
+import Spec qualified
+import Test.Hspec.Runner
+
+main :: IO ()
+main = do
+  initializeLogging Ormolu.defaultConfig
+  hspec Spec.spec

tests/Spec.hs

@@ -1 +1 @@
-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}

weeder.toml

@@ -1,6 +1,7 @@
 roots = [
   "^Main.main$",
   "^Paths_",
+  "^Spec.main$",
   "^Ormolu.Terminal.QualifiedDo.>>$" # https://github.com/ocharles/weeder/issues/112
 ]
 type-class-roots = true