Make Ormolu print debug info about operator fixity inference

CHANGELOG.md

@@ -10,6 +10,9 @@
 * Respect newlines in data declarations in more cases. [Issue
   1077](https://github.com/tweag/ormolu/issues/1077) and [issue
   947](https://github.com/tweag/ormolu/issues/947).
+* The `-d / --debug` command line option now makes Ormolu print out debug
+  information regarding operator fixity inference. [Issue
+  1060](https://github.com/tweag/ormolu/issues/1060).
 
 ## Ormolu 0.7.3.0
 

src/Ormolu.hs

@@ -112,7 +112,7 @@ ormolu cfgWithIndices path originalInput = do
   -- when we try to parse the rendered code back, inside of GHC monad
   -- wrapper which will lead to error messages presenting the exceptions as
   -- GHC bugs.
-  let !formattedText = printSnippets result0
+  let !formattedText = printSnippets (cfgDebug cfg) result0
   when (not (cfgUnsafe cfg) || cfgCheckIdempotence cfg) $ do
     -- Parse the result of pretty-printing again and make sure that AST
     -- is the same as AST of original snippet module span positions.
@@ -138,7 +138,7 @@ ormolu cfgWithIndices path originalInput = do
     -- Try re-formatting the formatted result to check if we get exactly
     -- the same output.
     when (cfgCheckIdempotence cfg) . liftIO $
-      let reformattedText = printSnippets result1
+      let reformattedText = printSnippets (cfgDebug cfg) result1
        in case diffText formattedText reformattedText path of
             Nothing -> return ()
             Just diff -> throwIO (OrmoluNonIdempotentOutput diff)

src/Ormolu/Fixity/Internal.hs

@@ -42,6 +42,7 @@ import Data.String (IsString (..))
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as T
+import Debug.Trace (trace)
 import Distribution.ModuleName (ModuleName)
 import Distribution.Types.PackageName
 import GHC.Data.FastString (fs_sbs)
@@ -256,24 +257,62 @@ data FixityQualification
   deriving stock (Eq, Show)
 
 -- | Get a 'FixityApproximation' of an operator.
-inferFixity :: RdrName -> ModuleFixityMap -> FixityApproximation
-inferFixity rdrName (ModuleFixityMap m) =
-  case Map.lookup opName m of
-    Nothing -> defaultFixityApproximation
-    Just (Given fixityInfo) ->
-      fixityInfoToApproximation fixityInfo
-    Just (FromModuleImports xs) ->
-      let isMatching (provenance, _fixityInfo) =
-            case provenance of
-              UnqualifiedAndQualified mn ->
-                maybe True (== mn) moduleName
-              OnlyQualified mn ->
-                maybe False (== mn) moduleName
-       in fromMaybe defaultFixityApproximation
-            . foldMap (Just . fixityInfoToApproximation . snd)
-            $ NE.filter isMatching xs
+inferFixity ::
+  -- | Whether to print debug info regarding fixity inference
+  Bool ->
+  -- | Operator name
+  RdrName ->
+  -- | Module fixity map
+  ModuleFixityMap ->
+  -- | The resulting fixity approximation
+  FixityApproximation
+inferFixity debug rdrName (ModuleFixityMap m) =
+  if debug
+    then
+      trace
+        (renderFixityJustification opName moduleName m result)
+        result
+    else result
   where
+    result =
+      case Map.lookup opName m of
+        Nothing -> defaultFixityApproximation
+        Just (Given fixityInfo) ->
+          fixityInfoToApproximation fixityInfo
+        Just (FromModuleImports xs) ->
+          let isMatching (provenance, _fixityInfo) =
+                case provenance of
+                  UnqualifiedAndQualified mn ->
+                    maybe True (== mn) moduleName
+                  OnlyQualified mn ->
+                    maybe False (== mn) moduleName
+           in fromMaybe defaultFixityApproximation
+                . foldMap (Just . fixityInfoToApproximation . snd)
+                $ NE.filter isMatching xs
     opName = occOpName (rdrNameOcc rdrName)
     moduleName = case rdrName of
       Qual x _ -> Just (ghcModuleNameToCabal x)
       _ -> Nothing
+
+-- | Render a human-readable account of why a certain 'FixityApproximation'
+-- was chosen for an operator.
+renderFixityJustification ::
+  -- | Operator name
+  OpName ->
+  -- | Qualification of the operator name
+  Maybe ModuleName ->
+  -- | Module fixity map
+  Map OpName FixityProvenance ->
+  -- | The chosen fixity approximation
+  FixityApproximation ->
+  String
+renderFixityJustification opName mqualification m approximation =
+  concat
+    [ "FIXITY analysis of ",
+      show opName,
+      case mqualification of
+        Nothing -> ""
+        Just mn -> " qualified in " ++ show mn,
+      "\n  Provenance: " ++ show (Map.lookup opName m),
+      "\n  Inferred: " ++ show approximation
+    ]

src/Ormolu/Printer.hs

@@ -17,11 +17,13 @@ import Ormolu.Processing.Common
 
 -- | Render several source snippets.
 printSnippets ::
+  -- | Whether to print out debug information during printing
+  Bool ->
   -- | Result of parsing
   [SourceSnippet] ->
   -- | Resulting rendition
   Text
-printSnippets = T.concat . fmap printSnippet
+printSnippets debug = T.concat . fmap printSnippet
   where
     printSnippet = \case
       ParsedSnippet ParseResult {..} ->
@@ -37,4 +39,5 @@ printSnippets = T.concat . fmap printSnippet
             prSourceType
             prExtensions
             prModuleFixityMap
+            debug
       RawSnippet r -> r

src/Ormolu/Printer/Combinators.hs

@@ -24,6 +24,7 @@ module Ormolu.Printer.Combinators
     inciIf,
     askSourceType,
     askModuleFixityMap,
+    askDebug,
     located,
     encloseLocated,
     located',

src/Ormolu/Printer/Internal.hs

@@ -18,6 +18,7 @@ module Ormolu.Printer.Internal
     newline,
     askSourceType,
     askModuleFixityMap,
+    askDebug,
     inci,
     sitcc,
     Layout (..),
@@ -100,7 +101,9 @@ data RC = RC
     -- | Whether the source is a signature or a regular module
     rcSourceType :: SourceType,
     -- | Module fixity map
-    rcModuleFixityMap :: ModuleFixityMap
+    rcModuleFixityMap :: ModuleFixityMap,
+    -- | Whether to print out debug information during printing
+    rcDebug :: !Bool
   }
 
 -- | State context of 'R'.
@@ -171,8 +174,9 @@ runR ::
   -- | Module fixity map
   ModuleFixityMap ->
   -- | Resulting rendition
+  Bool ->
   Text
-runR (R m) sstream cstream sourceType extensions moduleFixityMap =
+runR (R m) sstream cstream sourceType extensions moduleFixityMap debug =
   TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc
   where
     rc =
@@ -183,7 +187,8 @@ runR (R m) sstream cstream sourceType extensions moduleFixityMap =
           rcCanUseBraces = False,
           rcExtensions = extensions,
           rcSourceType = sourceType,
-          rcModuleFixityMap = moduleFixityMap
+          rcModuleFixityMap = moduleFixityMap,
+          rcDebug = debug
         }
     sc =
       SC
@@ -384,6 +389,11 @@ askSourceType = R (asks rcSourceType)
 askModuleFixityMap :: R ModuleFixityMap
 askModuleFixityMap = R (asks rcModuleFixityMap)
 
+-- | Retrieve whether we should print out certain debug information while
+-- printing.
+askDebug :: R Bool
+askDebug = R (asks rcDebug)
+
 inciBy :: Int -> R () -> R ()
 inciBy step (R m) = R (local modRC m)
   where

src/Ormolu/Printer/Meat/Declaration/Value.hs

@@ -348,10 +348,11 @@ p_hsCmd' isApp s = \case
       inci (sequence_ (intersperse breakpoint (located' (p_hsCmdTop N) <$> cmds)))
   HsCmdArrForm _ form Infix _ [left, right] -> do
     modFixityMap <- askModuleFixityMap
+    debug <- askDebug
     let opTree = BinaryOpBranches (cmdOpTree left) form (cmdOpTree right)
     p_cmdOpTree
       s
-      (reassociateOpTree (getOpName . unLoc) modFixityMap opTree)
+      (reassociateOpTree debug (getOpName . unLoc) modFixityMap opTree)
   HsCmdArrForm _ _ Infix _ _ -> notImplemented "HsCmdArrForm"
   HsCmdApp _ cmd expr -> do
     located cmd (p_hsCmd' Applicand s)
@@ -679,10 +680,11 @@ p_hsExpr' isApp s = \case
       located (hswc_body a) p_hsType
   OpApp _ x op y -> do
     modFixityMap <- askModuleFixityMap
+    debug <- askDebug
     let opTree = BinaryOpBranches (exprOpTree x) op (exprOpTree y)
     p_exprOpTree
       s
-      (reassociateOpTree (getOpName . unLoc) modFixityMap opTree)
+      (reassociateOpTree debug (getOpName . unLoc) modFixityMap opTree)
   NegApp _ e _ -> do
     negativeLiterals <- isExtensionEnabled NegativeLiterals
     let isLiteral = case unLoc e of

src/Ormolu/Printer/Meat/Type.hs

@@ -110,9 +110,10 @@ p_hsType' multilineArgs = \case
       sep (space >> txt "|" >> breakpoint) (sitcc . located' p_hsType) xs
   HsOpTy _ _ x op y -> do
     modFixityMap <- askModuleFixityMap
+    debug <- askDebug
     let opTree = BinaryOpBranches (tyOpTree x) op (tyOpTree y)
     p_tyOpTree
-      (reassociateOpTree (Just . unLoc) modFixityMap opTree)
+      (reassociateOpTree debug (Just . unLoc) modFixityMap opTree)
   HsParTy _ t ->
     parens N (located t p_hsType)
   HsIParamTy _ n t -> sitcc $ do

src/Ormolu/Printer/Operators.hs

@@ -90,6 +90,8 @@ opTreeLoc (OpBranches exprs _) =
 -- Users are expected to first construct an initial 'OpTree', then
 -- re-associate it using this function before printing.
 reassociateOpTree ::
+  -- | Whether to print debug info regarding fixity inference
+  Bool ->
   -- | How to get name of an operator
   (op -> Maybe RdrName) ->
   -- | Fixity Map
@@ -98,14 +100,16 @@ reassociateOpTree ::
   OpTree ty op ->
   -- | Re-associated 'OpTree', with added context and info around operators
   OpTree ty (OpInfo op)
-reassociateOpTree getOpName modFixityMap =
+reassociateOpTree debug getOpName modFixityMap =
   reassociateFlatOpTree
     . makeFlatOpTree
-    . addFixityInfo modFixityMap getOpName
+    . addFixityInfo debug modFixityMap getOpName
 
 -- | Wrap every operator of the tree with 'OpInfo' to carry the information
 -- about its fixity (extracted from the specified fixity map).
 addFixityInfo ::
+  -- | Whether to print debug info regarding fixity inference
+  Bool ->
   -- | Fixity map for operators
   ModuleFixityMap ->
   -- | How to get the name of an operator
@@ -114,18 +118,18 @@ addFixityInfo ::
   OpTree ty op ->
   -- | 'OpTree', with fixity info wrapped around each operator
   OpTree ty (OpInfo op)
-addFixityInfo _ _ (OpNode n) = OpNode n
-addFixityInfo modFixityMap getOpName (OpBranches exprs ops) =
+addFixityInfo _ _ _ (OpNode n) = OpNode n
+addFixityInfo debug modFixityMap getOpName (OpBranches exprs ops) =
   OpBranches
-    (addFixityInfo modFixityMap getOpName <$> exprs)
+    (addFixityInfo debug modFixityMap getOpName <$> exprs)
     (toOpInfo <$> ops)
   where
     toOpInfo o = OpInfo o mrdrName fixityApproximation
       where
         mrdrName = getOpName o
         fixityApproximation = case mrdrName of
           Nothing -> defaultFixityApproximation
-          Just rdrName -> inferFixity rdrName modFixityMap
+          Just rdrName -> inferFixity debug rdrName modFixityMap
 
 -- | Given a 'OpTree' of any shape, produce a flat 'OpTree', where every
 -- node and operator is directly connected to the root.