Prevent the equality sign from “disconnecting” comments

This resolves a class of idempotence issues when the equality sign happens
to be inserted between an element and its comment that follows on the same
line. I had to special-case equality sign for this, because all alternative
approaches (changing comment association logic or trying to find a more
general rule) did not work or fixed this issue yet made other things worse.

There is nothing special about the equality sign per se, but it (always?)
starts definitions which have their own ‘Located’ wrappers and it is those
spans interfere with the logic of comment association (they are detected as
AST elements between the “host” element and its comment) on subsequent
passes. This results in non-idempotent formatting.

The solution is OKish in that it fixes 99% of problems that one will
encounter in practice, but I see how an input can be crafted to show that
there is still an issue with idempotence.

CHANGELOG.md

@@ -13,6 +13,10 @@
 * Fixed an idempotence issue related to different indentation levels in a
   comment series. [Issue 512](https://github.com/tweag/ormolu/issues/512).
 
+* Fixed an idempotence related to comments which may happen to be separated
+  from the elements they are attached to by the equality sign. [Issue
+  340](https://github.com/tweag/ormolu/issues/340).
+
 * Renamed the `--check-idempotency` flag to `--check-idempotence`.
   Apparently only the latter is correct.
 

data/examples/declaration/value/function/awkward-comment-0-out.hs

@@ -0,0 +1,6 @@
+mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a
+mergeErrorReply err1 reply -- XXX where to put it?
+  =
+  case reply of
+    Ok x state err2 -> Ok x state (mergeError err1 err2)
+    Error err2 -> Error (mergeError err1 err2)

data/examples/declaration/value/function/awkward-comment-0.hs

@@ -0,0 +1,5 @@
+mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a
+mergeErrorReply err1 reply -- XXX where to put it?
+    = case reply of
+        Ok x state err2 -> Ok x state (mergeError err1 err2)
+        Error err2      -> Error (mergeError err1 err2)

data/examples/declaration/value/function/awkward-comment-1-out.hs

@@ -0,0 +1,9 @@
+doForeign :: Vars -> [Name] -> [Term] -> Idris LExp
+doForeign x = x
+  where
+    splitArg tm | (_, [_, _, l, r]) <- unApply tm -- pair, two implicits
+      =
+      do
+        let l' = toFDesc l
+        r' <- irTerm (sMN 0 "__foreignCall") vs env r
+        return (l', r')

data/examples/declaration/value/function/awkward-comment-1.hs

@@ -0,0 +1,7 @@
+doForeign :: Vars -> [Name] -> [Term] -> Idris LExp
+doForeign x = x
+  where
+    splitArg tm | (_, [_,_,l,r]) <- unApply tm -- pair, two implicits
+        = do let l' = toFDesc l
+             r' <- irTerm (sMN 0 "__foreignCall") vs env r
+             return (l', r')

default.nix

@@ -107,6 +107,7 @@ in {
       "optics"
       "ormolu"
       "pandoc"
+      "parsec3"
       "pipes"
       "postgrest"
       "purescript"

expected-failures/Agda.txt

@@ -1,3 +1,9 @@
+Formatting is not idempotent:
+  dist/build/Agda/Syntax/Parser/Lexer.hs<rendered>:1597:17
+  before: "         = (check_ac"
+  after:  "         =\n         "
+Please, consider reporting the bug.
+
 Formatting is not idempotent:
   src/full/Agda/Syntax/Internal.hs<rendered>:236:12
   before: "pe Elims = -- | elim"
@@ -9,12 +15,6 @@ Parsing of formatted code failed:
   parse error on input `C.QName'
 Please, consider reporting the bug.
 
-Formatting is not idempotent:
-  src/full/Agda/Termination/CallGraph.hs<rendered>:151:38
-  before: "2, old2) = -- TODO: "
-  after:  "2, old2) =\n        -"
-Please, consider reporting the bug.
-
 Formatting is not idempotent:
   src/full/Agda/TypeChecking/MetaVars.hs<rendered>:1448:16
   before: "ubstCand = -- | a po"

expected-failures/idris.txt

@@ -10,12 +10,6 @@ Formatting is not idempotent:
   after:  "++ showEnv\n         "
 Please, consider reporting the bug.
 
-Formatting is not idempotent:
-  src/Idris/Core/ProofTerm.hs<rendered>:351:19
-  before: "f c e pt = -- @(PT p"
-  after:  "f c e pt =\n  -- @(PT"
-Please, consider reporting the bug.
-
 Formatting is not idempotent:
   src/Idris/Core/TT.hs<rendered>:1963:13
   before: "   text op <> pretty"
@@ -23,29 +17,11 @@ Formatting is not idempotent:
 Please, consider reporting the bug.
 
 Formatting is not idempotent:
-  src/Idris/Core/WHNF.hs<rendered>:105:46
-  before: " n b sc) = -- stk mu"
-  after:  " n b sc) =\n      -- "
-Please, consider reporting the bug.
-
-Formatting is not idempotent:
-  src/Idris/Delaborate.hs<rendered>:627:6
+  src/Idris/Delaborate.hs<rendered>:628:6
   before: "ity\n      -- Issue #"
   after:  "ity\n        -- Issue"
 Please, consider reporting the bug.
 
-Formatting is not idempotent:
-  src/Idris/Elab/Term.hs<rendered>:432:47
-  before: "K\" _ _)) = -- for ch"
-  after:  "K\" _ _)) =\n      -- "
-Please, consider reporting the bug.
-
-Formatting is not idempotent:
-  src/Idris/ModeCommon.hs<rendered>:34:26
-  before: "s toline = -- furthe"
-  after:  "s toline =\n  -- furt"
-Please, consider reporting the bug.
-
 Formatting is not idempotent:
   src/Idris/Options.hs<rendered>:177:17
   before: "timisation = PETrans"
@@ -64,38 +40,8 @@ The GHC parser (in Haddock mode) failed:
   src/Idris/Parser/Expr.hs:75:1
   parse error on input `@'
 
-Formatting is not idempotent:
-  src/Idris/PartialEval.hs<rendered>:281:42
-  before: ": ns) as = -- Droppe"
-  after:  ": ns) as =\n      -- "
-Please, consider reporting the bug.
-
-Formatting is not idempotent:
-  src/Idris/ProofSearch.hs<rendered>:487:20
-  before: "OK ty hs = -- if any"
-  after:  "OK ty hs =\n      -- "
-Please, consider reporting the bug.
-
 Formatting is not idempotent:
   src/Idris/Prover.hs<rendered>:239:10
   before: "      line <> bindin"
   after:  "      line\n        <"
 Please, consider reporting the bug.
-
-Formatting is not idempotent:
-  src/Idris/REPL.hs<rendered>:1270:33
-  before: "ht c) _) = -- consta"
-  after:  "ht c) _) =\n  -- cons"
-Please, consider reporting the bug.
-
-Formatting is not idempotent:
-  src/Idris/Reflection.hs<rendered>:934:27
-  before: "attern _ = -- for al"
-  after:  "attern _ =\n  -- for "
-Please, consider reporting the bug.
-
-Formatting is not idempotent:
-  src/Idris/Transforms.hs<rendered>:26:32
-  before: "s, rhs)) = -- apply "
-  after:  "s, rhs)) =\n      -- "
-Please, consider reporting the bug.

expected-failures/intero.txt

@@ -1,5 +1,5 @@
 Formatting is not idempotent:
-  src/InteractiveUI.hs<rendered>:2635:36
-  before: "Decl d2) = -- A bit "
-  after:  "Decl d2) =\n  -- A bi"
+  src/InteractiveUI.hs<rendered>:3688:33
+  before: "text \"Try\" <+> doWha"
+  after:  "text \"Try\"\n         "
 Please, consider reporting the bug.

src/Ormolu/Printer/Combinators.hs

@@ -51,6 +51,7 @@ module Ormolu.Printer.Combinators
 
     -- ** Literals
     comma,
+    equals,
 
     -- ** Stateful markers
     SpanMark (..),
@@ -275,3 +276,7 @@ brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine)
 -- | Print @,@.
 comma :: R ()
 comma = txt ","
+
+-- | Print @=@. Do not use @'txt' "="@.
+equals :: R ()
+equals = interferingTxt "="

src/Ormolu/Printer/Internal.hs

@@ -14,6 +14,7 @@ module Ormolu.Printer.Internal
 
     -- * Internal functions
     txt,
+    interferingTxt,
     atom,
     space,
     newline,
@@ -186,6 +187,23 @@ runR (R m) sstream cstream anns recDot =
 ----------------------------------------------------------------------------
 -- Internal functions
 
+-- | Type of the thing to output. Influences the primary low-level rendering
+-- function 'spit'.
+data SpitType
+  = -- | Simple opaque text that breaks comment series.
+    SimpleText
+  | -- | Like 'SimpleText', but assume that when this text is inserted it
+    -- will separate an 'Atom' and its pending comments, so insert an extra
+    -- 'newline' in that case to force the pending comments and continue on
+    -- a fresh line.
+    InterferingText
+  | -- | An atom that typically have span information in the AST and can
+    -- have comments attached to it.
+    Atom
+  | -- | Used for rendering comment lines.
+    CommentPart
+  deriving (Show, Eq)
+
 -- | Output a fixed 'Text' fragment. The argument may not contain any line
 -- breaks. 'txt' is used to output all sorts of “fixed” bits of syntax like
 -- keywords and pipes @|@ in functional dependencies.
@@ -197,7 +215,14 @@ txt ::
   -- | 'Text' to output
   Text ->
   R ()
-txt = spit False False
+txt = spit SimpleText
+
+-- |
+interferingTxt ::
+  -- | 'Text' to output
+  Text ->
+  R ()
+interferingTxt = spit InterferingText
 
 -- | Output 'Outputable' fragment of AST. This can be used to output numeric
 -- literals and similar. Everything that doesn't have inner structure but
@@ -206,33 +231,33 @@ atom ::
   Outputable a =>
   a ->
   R ()
-atom = spit True False . T.pack . showOutputable
+atom = spit Atom . T.pack . showOutputable
 
 -- | Low-level non-public helper to define 'txt' and 'atom'.
 spit ::
-  -- | Whether to register the outermost enclosing span
-  Bool ->
-  -- | Used during outputting of pending comments?
-  Bool ->
+  -- | Type of the thing to spit
+  SpitType ->
   -- | 'Text' to output
   Text ->
   R ()
-spit registerSpan printingComments text = do
+spit stype text = do
   requestedDel <- R (gets scRequestedDelimiter)
+  pendingComments <- R (gets scPendingComments)
+  when (stype == InterferingText && not (null pendingComments)) newline
   case requestedDel of
     RequestedNewline -> do
       R . modify $ \sc ->
         sc
           { scRequestedDelimiter = RequestedNothing
           }
-      if printingComments
-        then newlineRaw
-        else newline
+      case stype of
+        CommentPart -> newlineRaw
+        _ -> newline
     _ -> return ()
   R $ do
     i <- asks rcIndent
     c <- gets scColumn
-    outermostEnclosing <- listToMaybe <$> asks rcEnclosingSpans
+    closestEnclosing <- listToMaybe <$> asks rcEnclosingSpans
     let spaces =
           if c < i
             then T.replicate (i - c) " "
@@ -244,16 +269,16 @@ spit registerSpan printingComments text = do
           scColumn = scColumn sc + T.length indentedTxt,
           scThisLineSpans =
             let xs = scThisLineSpans sc
-             in if registerSpan
-                  then case outermostEnclosing of
+             in case stype of
+                  Atom -> case closestEnclosing of
                     Nothing -> xs
                     Just x -> x : xs
-                  else xs,
+                  _ -> xs,
           scRequestedDelimiter = RequestedNothing,
           scSpanMark =
             -- If there are pending comments, do not reset last comment
             -- location.
-            if printingComments || (not . null . scPendingComments) sc
+            if (stype == CommentPart) || (not . null . scPendingComments) sc
               then scSpanMark sc
               else Nothing
         }
@@ -309,7 +334,7 @@ newline = do
                 }
             R m = do
               unless (T.null text) $
-                spit False True text
+                spit CommentPart text
               newlineRaw
          in local modRC m
       R . modify $ \sc ->

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

@@ -67,7 +67,7 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do
           if singleConstRec
             then space
             else breakpoint
-          txt "="
+          equals
           space
           let s =
                 vlayout

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

@@ -43,7 +43,7 @@ p_ruleDecl = \case
     inci $ do
       located lhs p_hsExpr
       space
-      txt "="
+      equals
       inci $ do
         breakpoint
         located rhs p_hsExpr

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

@@ -32,7 +32,7 @@ p_synDecl name fixity HsQTvs {..} t = do
       (p_rdrName name)
       (map (located' p_hsTyVarBndr) hsq_explicit)
   space
-  txt "="
+  equals
   breakpoint
   inci (located t p_hsType)
 p_synDecl _ _ (XLHsQTyVars x) _ = noExtCon x

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

@@ -69,7 +69,7 @@ p_familyResultSigL l =
         breakpoint
         located k p_hsType
       TyVarSig NoExtField bndr -> Just $ do
-        txt "="
+        equals
         breakpoint
         located bndr p_hsTyVarBndr
       XFamilyResultSig x ->
@@ -101,7 +101,7 @@ p_tyFamInstEqn HsIB {hsib_body = FamEqn {..}} = do
         (p_rdrName feqn_tycon)
         (located' p_hsType . typeArgToType <$> feqn_pats)
     space
-    txt "="
+    equals
     breakpoint
     inci (located feqn_rhs p_hsType)
 p_tyFamInstEqn HsIB {hsib_body = XFamEqn x} = noExtCon x

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

@@ -225,14 +225,7 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
         LambdaCase -> True
         _ -> False
   let hasGuards = withGuards grhssGRHSs
-  unless (length grhssGRHSs > 1) $
-    case style of
-      Function _ | hasGuards -> return ()
-      Function _ -> space >> txt "="
-      PatternBind -> space >> txt "="
-      s | isCase s && hasGuards -> return ()
-      _ -> space >> txt "->"
-  let grhssSpan =
+      grhssSpan =
         combineSrcSpans' $
           getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs
       patGrhssSpan =
@@ -261,6 +254,13 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
           unless whereIsEmpty breakpoint
           inci $ located grhssLocalBinds p_hsLocalBinds
   inci' $ do
+    unless (length grhssGRHSs > 1) $
+      case style of
+        Function _ | hasGuards -> return ()
+        Function _ -> space >> inci equals
+        PatternBind -> space >> inci equals
+        s | isCase s && hasGuards -> return ()
+        _ -> space >> txt "->"
     switchLayout [patGrhssSpan] $
       placeHanging placement p_body
     inci p_where
@@ -286,9 +286,9 @@ p_grhs' placer render style (GRHS NoExtField guards body) =
       space
       sitcc (sep (comma >> breakpoint) (sitcc . located' p_stmt) xs)
       space
-      txt $ case style of
-        EqualSign -> "="
-        RightArrow -> "->"
+      inci $ case style of
+        EqualSign -> equals
+        RightArrow -> txt "->"
       placeHanging placement p_body
   where
     placement =
@@ -494,7 +494,7 @@ p_hsLocalBinds = \case
     let p_ipBind (IPBind NoExtField (Left name) expr) = do
           atom name
           space
-          txt "="
+          equals
           breakpoint
           useBraces $ inci $ located expr p_hsExpr
         p_ipBind (IPBind NoExtField (Right _) _) =
@@ -513,7 +513,7 @@ p_hsRecField HsRecField {..} = do
   p_rdrName hsRecFieldLbl
   unless hsRecPun $ do
     space
-    txt "="
+    equals
     let placement =
           if onTheSameLine (getLoc hsRecFieldLbl) (getLoc hsRecFieldArg)
             then exprPlacement (unLoc hsRecFieldArg)
@@ -821,7 +821,7 @@ p_patSynBind PSB {..} = do
             breakpoint
             located psb_def p_pat
           ImplicitBidirectional -> do
-            txt "="
+            equals
             breakpoint
             located psb_def p_pat
           ExplicitBidirectional mgroup -> do
@@ -1006,7 +1006,7 @@ p_pat_hsRecField HsRecField {..} = do
     p_rdrName (rdrNameFieldOcc x)
   unless hsRecPun $ do
     space
-    txt "="
+    equals
     breakpoint
     inci (located hsRecFieldArg p_pat)