[Git][ghc/ghc][wip/amg/module-cycle-error] 2 commits: Use structured errors for a Backpack instantiation error
sheaf (@sheaf)
gitlab at gitlab.haskell.org
Wed Jul 3 08:01:54 UTC 2024
sheaf pushed to branch wip/amg/module-cycle-error at Glasgow Haskell Compiler / GHC
Commits:
d6c5f91c by sheaf at 2024-07-03T10:01:44+02:00
Use structured errors for a Backpack instantiation error
- - - - -
6b139380 by sheaf at 2024-07-03T10:01:44+02:00
Move mkFileSrcSpan to GHC.Unit.Module.Location
- - - - -
8 changed files:
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/Driver/Errors/Types.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Unit/Module/Location.hs
- testsuite/tests/diagnostic-codes/codes.stdout
Changes:
=====================================
compiler/GHC/Driver/Errors/Ppr.hs
=====================================
@@ -264,7 +264,10 @@ instance Diagnostic DriverMessage where
ppr_ms :: ModSummary -> SDoc
ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>
(parens (text (msHsFilePath ms)))
-
+ DriverInstantiationNodeInDependencyGeneration node ->
+ mkSimpleDecorated $
+ vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:"
+ , nest 2 $ ppr node ]
diagnosticReason = \case
DriverUnknownMessage m
@@ -332,6 +335,8 @@ instance Diagnostic DriverMessage where
-> WarningWithFlag Opt_WarnDeprecatedFlags
DriverModuleGraphCycle {}
-> ErrorWithoutFlag
+ DriverInstantiationNodeInDependencyGeneration {}
+ -> ErrorWithoutFlag
diagnosticHints = \case
DriverUnknownMessage m
@@ -401,5 +406,7 @@ instance Diagnostic DriverMessage where
-> noHints
DriverModuleGraphCycle {}
-> noHints
+ DriverInstantiationNodeInDependencyGeneration {}
+ -> noHints
diagnosticCode = constructorCode
=====================================
compiler/GHC/Driver/Errors/Types.hs
=====================================
@@ -385,7 +385,7 @@ data DriverMessage where
DriverDeprecatedFlag :: String -> String -> DriverMessage
- {- | DriverModuleGraphCycle is an error that occurs if the module graph
+ {-| DriverModuleGraphCycle is an error that occurs if the module graph
contains cyclic imports.
Test cases:
@@ -397,6 +397,11 @@ data DriverMessage where
-}
DriverModuleGraphCycle :: [ModuleGraphNode] -> DriverMessage
+ {- | DriverInstantiationNodeInDependencyGeneration is an error that occurs
+ if the module graph used for dependency generation contains
+ Backpack 'InstantiationNode's. -}
+ DriverInstantiationNodeInDependencyGeneration :: InstantiatedUnit -> DriverMessage
+
deriving instance Generic DriverMessage
data DriverMessageOpts =
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1265,7 +1265,7 @@ upsweep n_jobs hsc_env hmi_cache diag_wrapper mHscMessage old_hpt build_plan = d
-- of the upsweep.
case cycle of
Just mss -> do
- cyclicModuleErr mss
+ throwOneError $ cyclicModuleErr mss
Nothing -> do
let success_flag = successIf (all isJust res)
return (success_flag, completed)
@@ -2386,16 +2386,15 @@ multiRootsErr summs@(summ1:_)
mod = ms_mod summ1
files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
-cyclicModuleErr :: [ModuleGraphNode] -> IO a
+cyclicModuleErr :: [ModuleGraphNode] -> MsgEnvelope GhcMessage
-- From a strongly connected component we find
-- a single cycle to report
cyclicModuleErr mss
= assert (not (null mss)) $
case findCycle graph of
Nothing -> pprPanic "Unexpected non-cycle" (ppr mss)
- Just path -> throwOneError $ mkPlainErrorMsgEnvelope src_span
- $ GhcDriverMessage
- $ DriverModuleGraphCycle path
+ Just path -> mkPlainErrorMsgEnvelope src_span $
+ GhcDriverMessage $ DriverModuleGraphCycle path
where
src_span = maybe noSrcSpan (mkFileSrcSpan . ms_location) (moduleGraphNodeModSum (head path))
where
@@ -2409,13 +2408,6 @@ cyclicModuleErr mss
| ms <- mss
]
-mkFileSrcSpan :: ModLocation -> SrcSpan
-mkFileSrcSpan mod_loc
- = case ml_hs_file mod_loc of
- Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
- Nothing -> interactiveSrcSpan -- Presumably
-
-
cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe logger tmpfs dflags =
if gopt Opt_KeepTmpFiles dflags
=====================================
compiler/GHC/Driver/MakeFile.hs
=====================================
@@ -19,7 +19,6 @@ import qualified GHC
import GHC.Driver.Make
import GHC.Driver.Monad
import GHC.Driver.DynFlags
-import GHC.Driver.Ppr
import GHC.Utils.Misc
import GHC.Driver.Env
import GHC.Driver.Errors.Types
@@ -213,14 +212,14 @@ processDeps :: DynFlags
processDeps _ _ _ _ _ (CyclicSCC nodes)
= -- There shouldn't be any cycles; report them
- cyclicModuleErr nodes
+ throwOneError $ cyclicModuleErr nodes
-processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode _uid node))
+processDeps _ _ _ _ _ (AcyclicSCC (InstantiationNode _uid node))
= -- There shouldn't be any backpack instantiations; report them as well
- throwGhcExceptionIO $ ProgramError $
- showSDoc dflags $
- vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:"
- , nest 2 $ ppr node ]
+ throwOneError $
+ mkPlainErrorMsgEnvelope noSrcSpan $
+ GhcDriverMessage $ DriverInstantiationNodeInDependencyGeneration node
+
processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return ()
processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ node))
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -64,7 +64,6 @@ import GHC.Builtin.Names
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types
-import GHC.Data.FastString
import GHC.Data.Maybe ( expectJust )
import GHC.Data.OrdList
import GHC.Data.SizedSeq ( sizeSS )
@@ -289,12 +288,6 @@ deSugar hsc_env
; return (msgs, Just mod_guts)
}}}}
-mkFileSrcSpan :: ModLocation -> SrcSpan
-mkFileSrcSpan mod_loc
- = case ml_hs_file mod_loc of
- Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
- Nothing -> interactiveSrcSpan -- Presumably
-
dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
dsImpSpecs imp_specs
= do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -321,6 +321,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "DriverUnrecognisedFlag" = 93741
GhcDiagnosticCode "DriverDeprecatedFlag" = 53692
GhcDiagnosticCode "DriverModuleGraphCycle" = 92213
+ GhcDiagnosticCode "DriverInstantiationNodeInDependencyGeneration" = 74284
-- Constraint solver diagnostic codes
GhcDiagnosticCode "BadTelescope" = 97739
=====================================
compiler/GHC/Unit/Module/Location.hs
=====================================
@@ -18,6 +18,7 @@ module GHC.Unit.Module.Location
, addBootSuffixLocn
, addBootSuffixLocnOut
, removeBootSuffix
+ , mkFileSrcSpan
)
where
@@ -25,7 +26,9 @@ import GHC.Prelude
import GHC.Data.OsPath
import GHC.Unit.Types
+import GHC.Types.SrcLoc
import GHC.Utils.Outputable
+import GHC.Data.FastString (mkFastString)
import qualified System.OsString as OsString
@@ -128,6 +131,13 @@ addBootSuffixLocnOut locn
, ml_hie_file_ospath = addBootSuffix (ml_hie_file_ospath locn)
}
+-- | Compute a 'SrcSpan' from a 'ModLocation'.
+mkFileSrcSpan :: ModLocation -> SrcSpan
+mkFileSrcSpan mod_loc
+ = case ml_hs_file mod_loc of
+ Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
+ Nothing -> interactiveSrcSpan -- Presumably
+
-- ----------------------------------------------------------------------------
-- Helpers for backwards compatibility
-- ----------------------------------------------------------------------------
=====================================
testsuite/tests/diagnostic-codes/codes.stdout
=====================================
@@ -41,6 +41,7 @@
[GHC-19971] is untested (constructor = DriverBackpackModuleNotFound)
[GHC-37141] is untested (constructor = DriverCannotLoadInterfaceFile)
[GHC-29747] is untested (constructor = DriverMissingSafeHaskellMode)
+[GHC-74284] is untested (constructor = DriverInstantiationNodeInDependencyGeneration)
[GHC-06200] is untested (constructor = BlockedEquality)
[GHC-81325] is untested (constructor = ExpectingMoreArguments)
[GHC-78125] is untested (constructor = AmbiguityPreventsSolvingCt)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7500a74cf3dac8a0479016fc19f5d2729a5c868d...6b139380c39494c8418f4b1e88dbdc89f9bca75f
--
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7500a74cf3dac8a0479016fc19f5d2729a5c868d...6b139380c39494c8418f4b1e88dbdc89f9bca75f
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240703/82fee483/attachment-0001.html>
More information about the ghc-commits
mailing list