Improve hs-boot binds error (#19781)

2 files changed, 25 insertions, 10 deletions

diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index a37f88bc83..0dcd51637b 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -18,7 +18,7 @@ they may be affected by renaming (which isn't fully worked out yet).
 
 module GHC.Rename.Bind (
    -- Renaming top-level bindings
-   rnTopBindsLHS, rnTopBindsBoot, rnValBindsRHS,
+   rnTopBindsLHS, rnTopBindsLHSBoot, rnTopBindsBoot, rnValBindsRHS,
 
    -- Renaming local bindings
    rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
@@ -187,13 +187,24 @@ rnTopBindsLHS :: MiniFixityEnv
 rnTopBindsLHS fix_env binds
   = rnValBindsLHS (topRecNameMaker fix_env) binds
 
+-- Ensure that a hs-boot file has no top-level bindings.
+rnTopBindsLHSBoot :: MiniFixityEnv
+                  -> HsValBinds GhcPs
+                  -> RnM (HsValBindsLR GhcRn GhcPs)
+rnTopBindsLHSBoot fix_env binds
+  = do  { topBinds <- rnTopBindsLHS fix_env binds
+        ; case topBinds of
+            ValBinds x mbinds sigs ->
+              do  { mapM_ bindInHsBootFileErr mbinds
+                  ; pure (ValBinds x emptyBag sigs) }
+            _ -> pprPanic "rnTopBindsLHSBoot" (ppr topBinds) }
+
 rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs
                -> RnM (HsValBinds GhcRn, DefUses)
 -- A hs-boot file has no bindings.
 -- Return a single HsBindGroup with empty binds and renamed signatures
-rnTopBindsBoot bound_names (ValBinds _ mbinds sigs)
-  = do  { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
-        ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs
+rnTopBindsBoot bound_names (ValBinds _ _ sigs)
+  = do  { (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs
         ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) }
 rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b)
 
@@ -1322,10 +1333,10 @@ defaultSigErr sig = vcat [ hang (text "Unexpected default signature:")
                               2 (ppr sig)
                          , text "Use DefaultSignatures to enable default signatures" ]
 
-bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc
-bindsInHsBootFile mbinds
-  = hang (text "Bindings in hs-boot files are not allowed")
-       2 (ppr mbinds)
+bindInHsBootFileErr :: LHsBindLR GhcRn GhcPs -> RnM ()
+bindInHsBootFileErr (L loc _)
+  = addErrAt (locA loc) $
+      vcat [ text "Bindings in hs-boot files are not allowed" ]
 
 nonStdGuardErr :: (Outputable body,
                    Anno (Stmt GhcRn body) ~ SrcSpanAnnA)
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 8de0c4a34f..1b54b53716 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -140,7 +140,12 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
    -- (D2) Rename the left-hand sides of the value bindings.
    --     This depends on everything from (B) being in scope.
    --     It uses the fixity env from (A) to bind fixities for view patterns.
-   new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
+
+   -- We need to throw an error on such value bindings when in a boot file.
+   is_boot <- tcIsHsBootOrSig ;
+   new_lhs <- if is_boot
+    then rnTopBindsLHSBoot local_fix_env val_decls
+    else rnTopBindsLHS     local_fix_env val_decls ;
 
    -- Bind the LHSes (and their fixities) in the global rdr environment
    let { id_bndrs = collectHsIdBinders CollNoDictBinders new_lhs } ;
@@ -168,7 +173,6 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
    -- (F) Rename Value declarations right-hand sides
    traceRn "Start rnmono" empty ;
    let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
-   is_boot <- tcIsHsBootOrSig ;
    (rn_val_decls, bind_dus) <- if is_boot
     -- For an hs-boot, use tc_bndrs (which collects how we're renamed
     -- signatures), since val_bndr_set is empty (there are no x = ...