summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Hs/Decls.hs77
-rw-r--r--compiler/GHC/Rename/Source.hs17
-rw-r--r--compiler/deSugar/DsMeta.hs13
-rw-r--r--docs/users_guide/8.12.1-notes.rst18
-rw-r--r--testsuite/tests/th/T17608.hs20
-rw-r--r--testsuite/tests/th/T17608.stderr36
-rw-r--r--testsuite/tests/th/all.T1
m---------utils/haddock0
8 files changed, 151 insertions, 31 deletions
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 4f5164d7e7..c2e517f901 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 6796aa6b41..f36a556224 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 943f180dae..1af0b11f9f 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 5cd7131fac..8f2c26041e 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 0000000000..9d41f658d5
--- /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 0000000000..1073c5030b
--- /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 bcaf5fbd1b..1e0eb38218 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
View Lorry Controller Status