Handle local fixity declarations in DsMeta properly

`DsMeta.rep_sig` used to skip over `FixSig` entirely, which had the
effect of causing local fixity declarations to be dropped when quoted
in Template Haskell. But there is no good reason for this state of
affairs, as the code in `DsMeta.repFixD` (which handles top-level
fixity declarations) handles local fixity declarations just fine.
This patch factors out the necessary parts of `repFixD` so that they
can be used in `rep_sig` as well.

There was one minor complication: the fixity signatures for class
methods in each `HsGroup` were stored both in `FixSig`s _and_ the
list of `LFixitySig`s for top-level fixity signatures, so I needed
to take action to prevent fixity signatures for class methods being
converted to `Dec`s twice. I tweaked `RnSource.add` to avoid putting
these fixity signatures in two places and added
`Note [Top-level fixity signatures in an HsGroup]` in `GHC.Hs.Decls`
to explain the new design.

Fixes #17608. Bumps the Haddock submodule.

8 files changed, 151 insertions, 31 deletions

diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 4f5164d..c2e517f 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -84,7 +84,8 @@ module GHC.Hs.Decls (
   resultVariableName,
 
   -- * Grouping
-  HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls
+  HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls,
+  hsGroupTopLevelFixitySigs,
 
     ) where
 
@@ -167,18 +168,49 @@ type instance XDocD       (GhcPass _) = NoExtField
 type instance XRoleAnnotD (GhcPass _) = NoExtField
 type instance XXHsDecl    (GhcPass _) = NoExtCon
 
--- NB: all top-level fixity decls are contained EITHER
--- EITHER SigDs
--- OR     in the ClassDecls in TyClDs
---
--- The former covers
---      a) data constructors
---      b) class methods (but they can be also done in the
---              signatures of class decls)
---      c) imported functions (that have an IfacSig)
---      d) top level decls
---
--- The latter is for class methods only
+{-
+Note [Top-level fixity signatures in an HsGroup]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+An `HsGroup p` stores every top-level fixity declarations in one of two places:
+
+1. hs_fixds :: [LFixitySig p]
+
+   This stores fixity signatures for top-level declarations (e.g., functions,
+   data constructors, classes, type families, etc.) as well as fixity
+   signatures for class methods written outside of the class, as in this
+   example:
+
+     infixl 4 `m1`
+     class C1 a where
+       m1 :: a -> a -> a
+
+2. hs_tyclds :: [TyClGroup p]
+
+   Each type class can be found in a TyClDecl inside a TyClGroup, and that
+   TyClDecl stores the fixity signatures for its methods written inside of the
+   class, as in this example:
+
+     class C2 a where
+       infixl 4 `m2`
+       m2 :: a -> a -> a
+
+The story for fixity signatures for class methods is made slightly complicated
+by the fact that they can appear both inside and outside of the class itself,
+and both forms of fixity signatures are considered top-level. This matters
+in `GHC.Rename.Source.rnSrcDecls`, which must create a fixity environment out
+of all top-level fixity signatures before doing anything else. Therefore,
+`rnSrcDecls` must be aware of both (1) and (2) above. The
+`hsGroupTopLevelFixitySigs` function is responsible for collecting this
+information from an `HsGroup`.
+
+One might wonder why we even bother separating top-level fixity signatures
+into two places at all. That is, why not just take the fixity signatures
+from `hs_tyclds` and put them into `hs_fixds` so that they are all in one
+location? This ends up causing problems for `DsMeta.repTopDs`, which translates
+each fixity signature in `hs_fixds` and `hs_tyclds` into a Template Haskell
+`Dec`. If there are any duplicate signatures between the two fields, this will
+result in an error (#17608).
+-}
 
 -- | Haskell Group
 --
@@ -199,8 +231,10 @@ data HsGroup p
         hs_derivds :: [LDerivDecl p],
 
         hs_fixds  :: [LFixitySig p],
-                -- Snaffled out of both top-level fixity signatures,
-                -- and those in class declarations
+                -- A list of fixity signatures defined for top-level
+                -- declarations and class methods (defined outside of the class
+                -- itself).
+                -- See Note [Top-level fixity signatures in an HsGroup]
 
         hs_defds  :: [LDefaultDecl p],
         hs_fords  :: [LForeignDecl p],
@@ -232,6 +266,19 @@ emptyGroup = HsGroup { hs_ext = noExtField,
                        hs_splcds = [],
                        hs_docs = [] }
 
+-- | The fixity signatures for each top-level declaration and class method
+-- in an 'HsGroup'.
+-- See Note [Top-level fixity signatures in an HsGroup]
+hsGroupTopLevelFixitySigs :: HsGroup (GhcPass p) -> [LFixitySig (GhcPass p)]
+hsGroupTopLevelFixitySigs (HsGroup{ hs_fixds = fixds, hs_tyclds = tyclds }) =
+    fixds ++ cls_fixds
+  where
+    cls_fixds = [ L loc sig
+                | L _ ClassDecl{tcdSigs = sigs} <- tyClGroupTyClDecls tyclds
+                , L loc (FixSig _ sig) <- sigs
+                ]
+hsGroupTopLevelFixitySigs (XHsGroup nec) = noExtCon nec
+
 appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p)
              -> HsGroup (GhcPass p)
 appendGroups
diff --git a/compiler/GHC/Rename/Source.hs b/compiler/GHC/Rename/Source.hs
index 6796aa6..f36a556 100644
--- a/compiler/GHC/Rename/Source.hs
+++ b/compiler/GHC/Rename/Source.hs
@@ -104,10 +104,10 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
                             hs_ruleds  = rule_decls,
                             hs_docs    = docs })
  = do {
-   -- (A) Process the fixity declarations, creating a mapping from
-   --     FastStrings to FixItems.
-   --     Also checks for duplicates.
-   local_fix_env <- makeMiniFixityEnv fix_decls ;
+   -- (A) Process the top-level fixity declarations, creating a mapping from
+   --     FastStrings to FixItems. Also checks for duplicates.
+   --     See Note [Top-level fixity signatures in an HsGroup] in GHC.Hs.Decls
+   local_fix_env <- makeMiniFixityEnv $ hsGroupTopLevelFixitySigs group ;
 
    -- (B) Bring top level binders (and their fixities) into scope,
    --     *except* for the value bindings, which get done in step (D)
@@ -2301,13 +2301,8 @@ add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds
                      -- relevant to the larger base of users.
                      -- See #12146 for discussion.
 
--- Class declarations: pull out the fixity signatures to the top
-add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds
-  | isClassDecl d
-  = let fsigs = [ L l f
-                | L l (FixSig _ f) <- tcdSigs d ] in
-    addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
-  | otherwise
+-- Class declarations: added to the TyClGroup
+add gp@(HsGroup {hs_tyclds = ts}) l (TyClD _ d) ds
   = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
 
 -- Signatures: fixity sigs go a different place than all others
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 943f180..1af0b11 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -285,7 +285,7 @@ repTopDs group@(HsGroup { hs_valds   = valds
                      ; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds)
                      ; inst_ds  <- mapM repInstD instds
                      ; deriv_ds <- mapM repStandaloneDerivD derivds
-                     ; fix_ds   <- mapM repFixD fixds
+                     ; fix_ds   <- mapM repLFixD fixds
                      ; _        <- mapM no_default_decl defds
                      ; for_ds   <- mapM repForD fords
                      ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)
@@ -796,8 +796,11 @@ repSafety PlayRisky = rep2_nw unsafeName []
 repSafety PlayInterruptible = rep2_nw interruptibleName []
 repSafety PlaySafe = rep2_nw safeName []
 
-repFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
-repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))
+repLFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
+repLFixD (L loc fix_sig) = rep_fix_d loc fix_sig
+
+rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
+rep_fix_d loc (FixitySig _ names (Fixity _ prec dir))
   = do { MkC prec' <- coreIntLit prec
        ; let rep_fn = case dir of
                         InfixL -> infixLDName
@@ -808,7 +811,7 @@ repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))
                    ; dec <- rep2 rep_fn [prec', name']
                    ; return (loc,dec) }
        ; mapM do_one names }
-repFixD (L _ (XFixitySig nec)) = noExtCon nec
+rep_fix_d _ (XFixitySig nec) = noExtCon nec
 
 repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
 repRuleD (L loc (HsRule { rd_name = n
@@ -1003,7 +1006,7 @@ rep_sig (L loc (ClassOpSig _ is_deflt nms ty))
   | is_deflt     = mapM (rep_ty_sig defaultSigDName loc ty) nms
   | otherwise    = mapM (rep_ty_sig sigDName loc ty) nms
 rep_sig d@(L _ (IdSig {}))           = pprPanic "rep_sig IdSig" (ppr d)
-rep_sig (L _   (FixSig {}))          = return [] -- fixity sigs at top level
+rep_sig (L loc (FixSig _ fix_sig))   = rep_fix_d loc fix_sig
 rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc
 rep_sig (L loc (SpecSig _ nm tys ispec))
   = concatMapM (\t -> rep_specialise nm t ispec loc) tys
diff --git a/docs/users_guide/8.12.1-notes.rst b/docs/users_guide/8.12.1-notes.rst
index 5cd7131..8f2c260 100644
--- a/docs/users_guide/8.12.1-notes.rst
+++ b/docs/users_guide/8.12.1-notes.rst
@@ -42,6 +42,10 @@ Template Haskell
    forms have now been generalised in terms of a minimal interface necessary for the
    implementation rather than the overapproximation of the ``Q`` monad.
 
+ - Template Haskell quotes now handle fixity declarations in ``let`` and
+   ``where`` bindings properly. Previously, such fixity declarations would
+   be dropped when quoted due to a Template Haskell bug.
+
 ``ghc-prim`` library
 ~~~~~~~~~~~~~~~~~~~~
 
@@ -56,6 +60,20 @@ Template Haskell
                      => ([Word8] -> a) -> ModGuts
                      -> CoreM (ModuleEnv [a], NameEnv [a])
 
+ - The meaning of the ``hs_fixds`` field of ``HsGroup`` has changed slightly.
+   It now only contains fixity signatures defined for top-level declarations
+   and class methods defined *outside* of the class itself. Previously,
+   ``hs_fixds`` would also contain fixity signatures for class methods defined
+   *inside* the class, such as the fixity signature for ``m`` in the following
+   example: ::
+
+     class C a where
+       infixl 4 `m`
+       m :: a -> a -> a
+
+   If you wish to attain the previous behavior of ``hs_fixds``, use the new
+   ``hsGroupTopLevelFixitySigs`` function, which collects all top-level fixity
+   signatures, including those for class methods defined inside classes.
 
 ``base`` library
 ~~~~~~~~~~~~~~~~
diff --git a/testsuite/tests/th/T17608.hs b/testsuite/tests/th/T17608.hs
new file mode 100644
index 0000000..9d41f65
--- /dev/null
+++ b/testsuite/tests/th/T17608.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T17608 where
+
+$([d| infixl 4 `f`
+      f :: Bool
+      f = let infixl 4 `h`
+              h :: () -> Bool -> Bool
+              h _ _ = True in
+          h () (g () ())
+        where
+        infixl 4 `g`
+        g :: () -> () -> Bool
+        g _ _ = True
+
+      infixl 4 `n`
+      class C a where
+        infixl 4 `m`
+        m :: a -> a -> a
+        n :: a -> a -> a
+    |])
diff --git a/testsuite/tests/th/T17608.stderr b/testsuite/tests/th/T17608.stderr
new file mode 100644
index 0000000..1073c50
--- /dev/null
+++ b/testsuite/tests/th/T17608.stderr
@@ -0,0 +1,36 @@
+T17608.hs:(4,2)-(20,7): Splicing declarations
+    [d| infixl 4 `n`
+        infixl 4 `f`
+        
+        f :: Bool
+        f = let
+              infixl 4 `h`
+              h :: () -> Bool -> Bool
+              h _ _ = True
+            in h () (g () ())
+          where
+              infixl 4 `g`
+              g :: () -> () -> Bool
+              g _ _ = True
+        
+        class C a where
+          infixl 4 `m`
+          m :: a -> a -> a
+          n :: a -> a -> a |]
+  ======>
+    infixl 4 `f`
+    f :: Bool
+    f = let
+          infixl 4 `h`
+          h :: () -> Bool -> Bool
+          h _ _ = True
+        in (h ()) ((g ()) ())
+      where
+          infixl 4 `g`
+          g :: () -> () -> Bool
+          g _ _ = True
+    infixl 4 `n`
+    class C a where
+      infixl 4 `m`
+      m :: a -> a -> a
+      n :: a -> a -> a
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index bcaf5fb..1e0eb38 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -495,5 +495,6 @@ test('T17379a', normal, compile_fail, [''])
 test('T17379b', normal, compile_fail, [''])
 test('T17461', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T17511', normal, compile, [''])
+test('T17608', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('TH_PprStar', normal, compile, ['-v0 -dsuppress-uniques'])
 test('TH_StringLift', normal, compile, [''])
diff --git a/utils/haddock b/utils/haddock
-Subproject c67c24fc90e8217c3d2139e99e92889e1df180f
+Subproject e2c0a757f5aae215d89e464a7e45f9777c27c8f