[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Include diagnostic reason in -fdiagnostics-as-json

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Tue Nov 19 11:58:39 UTC 2024


Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
831aab22 by sheaf at 2024-11-18T21:22:36-05:00
Include diagnostic reason in -fdiagnostics-as-json

This commit ensures that the -fdiagnostics-as-json output includes the
diagnostic reason. This allows the full error message produced by GHC
to be re-constructed from the JSON output.

Fixes #25403

- - - - -
3e5bfdd3 by Ben Gamari at 2024-11-18T21:23:12-05:00
rts: Introduce printIPE

This is a convenience utility for use in GDB.

- - - - -
bc6992df by Sjoerd Visscher at 2024-11-19T06:58:07-05:00
Don't store boot locations in finder cache

Partially reverts commit fff55592a7b

Amends add(Home)ModuleToFinder so that locations for boot files are not stored in the finder cache.

Removes InstalledModule field from InstalledFound constructor since it's the same as the key that was searched for.

- - - - -
41bf1d8a by Sjoerd Visscher at 2024-11-19T06:58:07-05:00
Concentrate boot extension logic in Finder

With new mkHomeModLocation that takes an extra HscSource to add boot extensions if required.

- - - - -
0f4079d1 by ARATA Mizuki at 2024-11-19T06:58:13-05:00
Better documentation for floating-point min/max and SIMD primitives

See #25350 for floating-point min/max

Co-authored-by: sheaf <sam.derbyshire at gmail.com>

- - - - -


23 changed files:

- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Driver/Phases.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Unit/Module/Env.hs
- compiler/GHC/Unit/Module/Location.hs
- compiler/GHC/Unit/Module/Warnings.hs
- compiler/GHC/Unit/Types.hs
- + docs/users_guide/diagnostics-as-json-schema-1_1.json
- docs/users_guide/using.rst
- rts/IPE.c
- rts/include/rts/IPE.h
- testsuite/tests/driver/all.T
- testsuite/tests/driver/json.stderr
- testsuite/tests/driver/json_warn.hs
- testsuite/tests/driver/json_warn.stderr


Changes:

=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -1095,10 +1095,18 @@ primop   DoubleLeOp "<=##"   Compare   Double# -> Double# -> Int#
 
 primop   DoubleMinOp   "minDouble#"      GenPrimOp
    Double# -> Double# -> Double#
+   {Return the minimum of the arguments.
+   When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@)
+   or one of the arguments is not-a-number (NaN),
+   it is unspecified which one is returned.}
    with commutable = True
 
 primop   DoubleMaxOp   "maxDouble#"      GenPrimOp
    Double# -> Double# -> Double#
+   {Return the maximum of the arguments.
+   When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@)
+   or one of the arguments is not-a-number (NaN),
+   it is unspecified which one is returned.}
    with commutable = True
 
 primop   DoubleAddOp   "+##"   GenPrimOp
@@ -1269,10 +1277,18 @@ primop   FloatLeOp  "leFloat#"   Compare   Float# -> Float# -> Int#
 
 primop   FloatMinOp   "minFloat#"      GenPrimOp
    Float# -> Float# -> Float#
+   {Return the minimum of the arguments.
+   When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@)
+   or one of the arguments is not-a-number (NaN),
+   it is unspecified which one is returned.}
    with commutable = True
 
 primop   FloatMaxOp   "maxFloat#"      GenPrimOp
    Float# -> Float# -> Float#
+   {Return the maximum of the arguments.
+   When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@)
+   or one of the arguments is not-a-number (NaN),
+   it is unspecified which one is returned.}
    with commutable = True
 
 primop   FloatAddOp   "plusFloat#"      GenPrimOp
@@ -4109,12 +4125,13 @@ primop VecPackOp "pack#" GenPrimOp
 
 primop VecUnpackOp "unpack#" GenPrimOp
    VECTOR -> VECTUPLE
-   { Unpack the elements of a vector into an unboxed tuple. #}
+   { Unpack the elements of a vector into an unboxed tuple. }
    with vector = ALL_VECTOR_TYPES
 
 primop VecInsertOp "insert#" GenPrimOp
    VECTOR -> SCALAR -> Int# -> VECTOR
-   { Insert a scalar at the given position in a vector. }
+   { Insert a scalar at the given position in a vector.
+     The position must be a compile-time constant. }
    with effect = CanFail
         vector = ALL_VECTOR_TYPES
 
@@ -4160,40 +4177,43 @@ primop VecNegOp "negate#" GenPrimOp
 
 primop VecIndexByteArrayOp "indexArray#" GenPrimOp
    ByteArray# -> Int# -> VECTOR
-   { Read a vector from specified index of immutable array. }
+   { Read a vector from the specified index of an immutable array.
+     The index is counted in units of SIMD vectors (not scalar elements). }
    with effect = CanFail
         vector = ALL_VECTOR_TYPES
 
 primop VecReadByteArrayOp "readArray#" GenPrimOp
    MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #)
-   { Read a vector from specified index of mutable array. }
+   { Read a vector from the specified index of a mutable array.
+     The index is counted in units of SIMD vectors (not scalar elements). }
    with effect = ReadWriteEffect
         can_fail_warning = YesWarnCanFail
         vector = ALL_VECTOR_TYPES
 
 primop VecWriteByteArrayOp "writeArray#" GenPrimOp
    MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s
-   { Write a vector to specified index of mutable array. }
+   { Write a vector to the specified index of a mutable array.
+     The index is counted in units of SIMD vectors (not scalar elements). }
    with effect = ReadWriteEffect
         can_fail_warning = YesWarnCanFail
         vector = ALL_VECTOR_TYPES
 
 primop VecIndexOffAddrOp "indexOffAddr#" GenPrimOp
    Addr# -> Int# -> VECTOR
-   { Reads vector; offset in bytes. }
+   { Reads vector; offset in units of SIMD vectors (not scalar elements). }
    with effect = CanFail
         vector = ALL_VECTOR_TYPES
 
 primop VecReadOffAddrOp "readOffAddr#" GenPrimOp
    Addr# -> Int# -> State# s -> (# State# s, VECTOR #)
-   { Reads vector; offset in bytes. }
+   { Reads vector; offset in units of SIMD vectors (not scalar elements). }
    with effect = ReadWriteEffect
         can_fail_warning = YesWarnCanFail
         vector = ALL_VECTOR_TYPES
 
 primop VecWriteOffAddrOp "writeOffAddr#" GenPrimOp
    Addr# -> Int# -> VECTOR -> State# s -> State# s
-   { Write vector; offset in bytes. }
+   { Write vector; offset in units of SIMD vectors (not scalar elements). }
    with effect = ReadWriteEffect
         can_fail_warning = YesWarnCanFail
         vector = ALL_VECTOR_TYPES
@@ -4263,7 +4283,7 @@ primop   VecFNMSub   "fnmsub#" GenPrimOp
 primop VecShuffleOp "shuffle#" GenPrimOp
   VECTOR -> VECTOR -> INTVECTUPLE -> VECTOR
   {Shuffle elements of the concatenation of the input two vectors
-  into the result vector.}
+  into the result vector. The indices must be compile-time constants.}
    with vector = ALL_VECTOR_TYPES
 
 primop VecMinOp "min#" GenPrimOp


=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -781,7 +781,7 @@ summariseRequirement pn mod_name = do
     let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
 
     let fc = hsc_FC hsc_env
-    mod <- liftIO $ addHomeModuleToFinder fc home_unit (notBoot mod_name) location
+    mod <- liftIO $ addHomeModuleToFinder fc home_unit mod_name location HsigFile
 
     extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
 
@@ -854,17 +854,14 @@ hsModuleToModSummary home_keys pn hsc_src modname
     -- To add insult to injury, we don't even actually use
     -- these filenames to figure out where the hi files go.
     -- A travesty!
-    let location0 = mkHomeModLocation2 fopts modname
+    let location = mkHomeModLocation fopts modname
                              (unsafeEncodeUtf $ unpackFS unit_fs </>
                               moduleNameSlashes modname)
-                              (case hsc_src of
+                             (case hsc_src of
                                 HsigFile   -> os "hsig"
                                 HsBootFile -> os "hs-boot"
                                 HsSrcFile  -> os "hs")
-    -- DANGEROUS: bootifying can POISON the module finder cache
-    let location = case hsc_src of
-                        HsBootFile -> addBootSuffixLocnOut location0
-                        _ -> location0
+                             hsc_src
     -- This duplicates a pile of logic in GHC.Driver.Make
     hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
     hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
@@ -893,7 +890,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
     this_mod <- liftIO $ do
       let home_unit = hsc_home_unit hsc_env
       let fc        = hsc_FC hsc_env
-      addHomeModuleToFinder fc home_unit (GWIB modname (hscSourceToIsBoot hsc_src)) location
+      addHomeModuleToFinder fc home_unit modname location hsc_src
     let ms = ModSummary {
             ms_mod = this_mod,
             ms_hsc_src = hsc_src,


=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -2123,38 +2123,23 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
             <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf
 
         let fopts = initFinderOpts (hsc_dflags hsc_env)
-            src_path = unsafeEncodeUtf src_fn
+            (basename, extension) = splitExtension src_fn
 
-            is_boot = case takeExtension src_fn of
-              ".hs-boot" -> IsBoot
-              ".lhs-boot" -> IsBoot
-              _ -> NotBoot
-
-            (path_without_boot, hsc_src)
-              | isHaskellSigFilename src_fn = (src_path, HsigFile)
-              | IsBoot <- is_boot = (removeBootSuffix src_path, HsBootFile)
-              | otherwise = (src_path, HsSrcFile)
-
-            -- Make a ModLocation for the Finder, who only has one entry for
-            -- each @ModuleName@, and therefore needs to use the locations for
-            -- the non-boot files.
-            location_without_boot =
-              mkHomeModLocation fopts pi_mod_name path_without_boot
+            hsc_src
+              | isHaskellSigSuffix (drop 1 extension) = HsigFile
+              | isHaskellBootSuffix (drop 1 extension) = HsBootFile
+              | otherwise = HsSrcFile
 
             -- Make a ModLocation for this file, adding the @-boot@ suffix to
             -- all paths if the original was a boot file.
-            location
-              | IsBoot <- is_boot
-              = addBootSuffixLocn location_without_boot
-              | otherwise
-              = location_without_boot
+            location = mkHomeModLocation fopts pi_mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf extension) hsc_src
 
         -- Tell the Finder cache where it is, so that subsequent calls
         -- to findModule will find it, even if it's not on any search path
         mod <- liftIO $ do
           let home_unit = hsc_home_unit hsc_env
           let fc        = hsc_FC hsc_env
-          addHomeModuleToFinder fc home_unit (GWIB pi_mod_name is_boot) location
+          addHomeModuleToFinder fc home_unit pi_mod_name location hsc_src
 
         liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
             { nms_src_fn = src_fn
@@ -2184,14 +2169,10 @@ checkSummaryHash
            -- and it was likely flushed in depanal. This is not technically
            -- needed when we're called from sumariseModule but it shouldn't
            -- hurt.
-           -- Also, only add to finder cache for non-boot modules as the finder cache
-           -- makes sure to add a boot suffix for boot files.
-           _ <- do
-              let fc = hsc_FC hsc_env
-                  gwib = GWIB (ms_mod old_summary) (isBootSummary old_summary)
-              case ms_hsc_src old_summary of
-                HsSrcFile -> addModuleToFinder fc gwib location
-                _ -> return ()
+           let fc      = hsc_FC hsc_env
+               mod     = ms_mod old_summary
+               hsc_src = ms_hsc_src old_summary
+           addModuleToFinder fc mod location hsc_src
 
            hi_timestamp <- modificationTimeIfExists (ml_hi_file location)
            hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
@@ -2243,7 +2224,7 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p
     find_it :: IO SummariseResult
 
     find_it = do
-        found <- findImportedModule hsc_env wanted_mod mb_pkg
+        found <- findImportedModuleWithIsBoot hsc_env wanted_mod is_boot mb_pkg
         case found of
              Found location mod
                 | isJust (ml_hs_file location) ->
@@ -2261,10 +2242,7 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p
     just_found location mod = do
                 -- Adjust location to point to the hs-boot source file,
                 -- hi file, object file, when is_boot says so
-        let location' = case is_boot of
-              IsBoot -> addBootSuffixLocn location
-              NotBoot -> location
-            src_fn = expectJust "summarise2" (ml_hs_file location')
+        let src_fn = expectJust "summarise2" (ml_hs_file location)
 
                 -- Check that it exists
                 -- It might have been deleted since the Finder last found it
@@ -2274,7 +2252,7 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p
           -- .hs-boot file doesn't exist.
           Nothing -> return NotThere
           Just h  -> do
-            fresult <- new_summary_cache_check location' mod src_fn h
+            fresult <- new_summary_cache_check location mod src_fn h
             return $ case fresult of
               Left err -> FoundHomeWithError (moduleUnitId mod, err)
               Right ms -> FoundHome ms


=====================================
compiler/GHC/Driver/MakeFile.hs
=====================================
@@ -292,12 +292,12 @@ findDependency  :: HscEnv
 findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do
   -- Find the module; this will be fast because
   -- we've done it once during downsweep
-  r <- findImportedModule hsc_env imp pkg
+  r <- findImportedModuleWithIsBoot hsc_env imp is_boot pkg
   case r of
     Found loc _
         -- Home package: just depend on the .hi or hi-boot file
         | isJust (ml_hs_file loc) || include_pkg_deps
-        -> return (Just (unsafeDecodeUtf $ addBootSuffix_maybe is_boot (ml_hi_file_ospath loc)))
+        -> return (Just (unsafeDecodeUtf $ ml_hi_file_ospath loc))
 
         -- Not in this package: we don't need a dependency
         | otherwise


=====================================
compiler/GHC/Driver/Phases.hs
=====================================
@@ -23,6 +23,7 @@ module GHC.Driver.Phases (
    isDynLibSuffix,
    isHaskellUserSrcSuffix,
    isHaskellSigSuffix,
+   isHaskellBootSuffix,
    isSourceSuffix,
 
    isHaskellishTarget,
@@ -234,7 +235,7 @@ phaseInputExt Js                  = "js"
 phaseInputExt StopLn              = "o"
 
 haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes,
-    js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes
+    js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes, haskellish_boot_suffixes
  :: [String]
 -- When a file with an extension in the haskellish_src_suffixes group is
 -- loaded in --make mode, its imports will be loaded too.
@@ -247,7 +248,8 @@ js_suffixes                  = [ "js" ]
 
 -- Will not be deleted as temp files:
 haskellish_user_src_suffixes =
-  haskellish_sig_suffixes ++ [ "hs", "lhs", "hs-boot", "lhs-boot" ]
+  haskellish_sig_suffixes ++ haskellish_boot_suffixes ++ [ "hs", "lhs" ]
+haskellish_boot_suffixes     = [ "hs-boot", "lhs-boot" ]
 haskellish_sig_suffixes      = [ "hsig", "lhsig" ]
 backpackish_suffixes         = [ "bkp" ]
 
@@ -265,11 +267,12 @@ dynlib_suffixes platform = case platformOS platform of
   _         -> ["so"]
 
 isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix,
-    isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix
+    isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix, isHaskellBootSuffix
  :: String -> Bool
 isHaskellishSuffix     s = s `elem` haskellish_suffixes
 isBackpackishSuffix    s = s `elem` backpackish_suffixes
 isHaskellSigSuffix     s = s `elem` haskellish_sig_suffixes
+isHaskellBootSuffix    s = s `elem` haskellish_boot_suffixes
 isHaskellSrcSuffix     s = s `elem` haskellish_src_suffixes
 isCishSuffix           s = s `elem` cish_suffixes
 isJsSuffix             s = s `elem` js_suffixes


=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -734,7 +734,7 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
   mod <- do
     let home_unit = hsc_home_unit hsc_env
     let fc        = hsc_FC hsc_env
-    addHomeModuleToFinder fc home_unit (GWIB mod_name (hscSourceToIsBoot src_flavour)) location
+    addHomeModuleToFinder fc home_unit mod_name location src_flavour
 
   -- Make the ModSummary to hand to hscMain
   let
@@ -777,24 +777,18 @@ mkOneShotModLocation :: PipeEnv -> DynFlags -> HscSource -> ModuleName -> IO Mod
 mkOneShotModLocation pipe_env dflags src_flavour mod_name = do
     let PipeEnv{ src_basename=basename,
              src_suffix=suff } = pipe_env
-    let location1 = mkHomeModLocation2 fopts mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf suff)
-
-    -- Boot-ify it if necessary
-    let location2
-          | HsBootFile <- src_flavour = addBootSuffixLocnOut location1
-          | otherwise                 = location1
-
+    let location1 = mkHomeModLocation fopts mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf suff) src_flavour
 
     -- Take -ohi into account if present
     -- This can't be done in mkHomeModuleLocation because
     -- it only applies to the module being compiles
     let ohi = outputHi dflags
-        location3 | Just fn <- ohi = location2{ ml_hi_file_ospath = unsafeEncodeUtf  fn }
-                  | otherwise      = location2
+        location2 | Just fn <- ohi = location1{ ml_hi_file_ospath = unsafeEncodeUtf fn }
+                  | otherwise      = location1
 
     let dynohi = dynOutputHi dflags
-        location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file_ospath = unsafeEncodeUtf fn }
-                  | otherwise         = location3
+        location3 | Just fn <- dynohi = location2{ ml_dyn_hi_file_ospath = unsafeEncodeUtf fn }
+                  | otherwise         = location2
 
     -- Take -o into account if present
     -- Very like -ohi, but we must *only* do this if we aren't linking
@@ -807,11 +801,11 @@ mkOneShotModLocation pipe_env dflags src_flavour mod_name = do
         location5 | Just ofile <- expl_o_file
                   , let dyn_ofile = fromMaybe (ofile -<.> dynObjectSuf_ dflags) expl_dyn_o_file
                   , isNoLink (ghcLink dflags)
-                  = location4 { ml_obj_file_ospath = unsafeEncodeUtf ofile
+                  = location3 { ml_obj_file_ospath = unsafeEncodeUtf ofile
                               , ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }
                   | Just dyn_ofile <- expl_dyn_o_file
-                  = location4 { ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }
-                  | otherwise = location4
+                  = location3 { ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }
+                  | otherwise = location3
     return location5
     where
       fopts = initFinderOpts dflags


=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -896,9 +896,9 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
       else do
           let fopts = initFinderOpts dflags
           -- Look for the file
-          mb_found <- liftIO (findExactModule fc fopts other_fopts unit_state mhome_unit mod)
+          mb_found <- liftIO (findExactModule fc fopts other_fopts unit_state mhome_unit mod hi_boot_file)
           case mb_found of
-              InstalledFound (addBootSuffixLocn_maybe hi_boot_file -> loc) mod -> do
+              InstalledFound loc -> do
                   -- See Note [Home module load error]
                   case mhome_unit of
                     Just home_unit


=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -2713,7 +2713,7 @@ doShuffleOp ty (v1:v2:idxs) res
         -> emitAssign (CmmLocal res) (CmmMachOp (mo is) [v1,v2])
         | otherwise
         -> pprPanic "doShuffleOp" $
-             vcat [ text "shuffle indices must be literals, 0 <= i <" <+> ppr len ]
+             vcat [ text "shuffle indices must be literals, 0 <= i <" <+> ppr (2 * len) ]
   | otherwise
   = pprPanic "doShuffleOp" $
         vcat [ text "non-vector argument type:" <+> ppr ty ]


=====================================
compiler/GHC/Types/Error.hs
=====================================
@@ -100,19 +100,23 @@ import GHC.Types.SrcLoc as SrcLoc
 import GHC.Types.Hint
 import GHC.Data.FastString (unpackFS)
 import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
+
+import GHC.Types.Hint.Ppr () -- Outputable instance
+import GHC.Unit.Module.Warnings (WarningCategory(..))
+
 import GHC.Utils.Json
 import GHC.Utils.Panic
-import GHC.Unit.Module.Warnings (WarningCategory)
+
+import GHC.Version (cProjectVersion)
 import Data.Bifunctor
 import Data.Foldable    ( fold, toList )
 import Data.List.NonEmpty ( NonEmpty (..) )
 import qualified Data.List.NonEmpty as NE
 import Data.List ( intercalate )
+import Data.Maybe ( maybeToList )
 import Data.Typeable ( Typeable )
 import Numeric.Natural ( Natural )
 import Text.Printf ( printf )
-import GHC.Version (cProjectVersion)
-import GHC.Types.Hint.Ppr () -- Outputtable instance
 
 {- Note [Messages]
 ~~~~~~~~~~~~~~~~~~
@@ -393,10 +397,8 @@ newtype ResolvedDiagnosticReason
 pattern WarningWithFlag :: WarningFlag -> DiagnosticReason
 pattern WarningWithFlag w = WarningWithFlags (w :| [])
 
-{-
-Note [Warnings controlled by multiple flags]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
+{- Note [Warnings controlled by multiple flags]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Diagnostics that started life as flag-controlled warnings have a
 'diagnosticReason' of 'WarningWithFlags', giving the flags that control the
 warning. Usually there is only one flag, but in a few cases multiple flags
@@ -563,11 +565,11 @@ instance ToJson DiagnosticCode where
 {- Note [Diagnostic Message JSON Schema]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The below instance of ToJson must conform to the JSON schema
-specified in docs/users_guide/diagnostics-as-json-schema-1_0.json.
+specified in docs/users_guide/diagnostics-as-json-schema-1_1.json.
 When the schema is altered, please bump the version.
 If the content is altered in a backwards compatible way,
 update the minor version (e.g. 1.3 ~> 1.4).
-If the content is breaking, update the major version (e.g. 1.3 ~> 2.3).
+If the content is breaking, update the major version (e.g. 1.3 ~> 2.0).
 When updating the schema, replace the above file and name it appropriately with
 the version appended, and change the documentation of the -fdiagnostics-as-json
 flag to reflect the new schema.
@@ -576,25 +578,41 @@ https://json-schema.org
 -}
 
 schemaVersion :: String
-schemaVersion = "1.0"
+schemaVersion = "1.1"
 -- See Note [Diagnostic Message JSON Schema] before editing!
 instance Diagnostic e => ToJson (MsgEnvelope e) where
-  json m = JSObject [
+  json m = JSObject $ [
     ("version", JSString schemaVersion),
     ("ghcVersion", JSString $ "ghc-" ++ cProjectVersion),
     ("span", json $ errMsgSpan m),
     ("severity", json $ errMsgSeverity m),
     ("code", maybe JSNull json (diagnosticCode diag)),
     ("message", JSArray $ map renderToJSString diagMsg),
-    ("hints", JSArray $ map (renderToJSString . ppr) (diagnosticHints diag) )
-    ]
-    where diag = errMsgDiagnostic m
-          opts = defaultDiagnosticOpts @e
-          style = mkErrStyle (errMsgContext m)
-          ctx = defaultSDocContext {sdocStyle = style }
-          diagMsg = filter (not . isEmpty ctx) (unDecorated (diagnosticMessage (opts) diag))
-          renderToJSString :: SDoc -> JsonDoc
-          renderToJSString = JSString . (renderWithContext ctx)
+    ("hints", JSArray $ map (renderToJSString . ppr) (diagnosticHints diag) ) ]
+    ++ [ ("reason", reasonJson)
+       | reasonJson <- maybeToList $ usefulReasonJson_maybe (errMsgReason m) ]
+    where
+      diag = errMsgDiagnostic m
+      opts = defaultDiagnosticOpts @e
+      style = mkErrStyle (errMsgContext m)
+      ctx = defaultSDocContext {sdocStyle = style }
+      diagMsg = filter (not . isEmpty ctx) (unDecorated (diagnosticMessage (opts) diag))
+      renderToJSString :: SDoc -> JsonDoc
+      renderToJSString = JSString . (renderWithContext ctx)
+
+      usefulReasonJson_maybe :: ResolvedDiagnosticReason -> Maybe JsonDoc
+      usefulReasonJson_maybe (ResolvedDiagnosticReason rea) =
+        case rea of
+          WarningWithoutFlag -> Nothing
+          ErrorWithoutFlag   -> Nothing
+          WarningWithFlags flags ->
+            Just $ JSObject
+              [ ("flags", JSArray $ map (JSString . NE.head . warnFlagNames) (NE.toList flags))
+              ]
+          WarningWithCategory (WarningCategory cat) ->
+            Just $ JSObject
+              [ ("category", JSString $ unpackFS cat)
+              ]
 
 instance Show (MsgEnvelope DiagnosticMessage) where
     show = showMsgEnvelope


=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -15,6 +15,7 @@ module GHC.Unit.Finder (
     FinderCache(..),
     initFinderCache,
     findImportedModule,
+    findImportedModuleWithIsBoot,
     findPluginModule,
     findExactModule,
     findHomeModule,
@@ -55,6 +56,7 @@ import GHC.Utils.Panic
 
 import GHC.Linker.Types
 import GHC.Types.PkgQual
+import GHC.Types.SourceFile
 
 import GHC.Fingerprint
 import Data.IORef
@@ -103,28 +105,28 @@ InstalledNotFound.
 
 initFinderCache :: IO FinderCache
 initFinderCache = do
-  mod_cache <- newIORef emptyInstalledModuleWithIsBootEnv
+  mod_cache <- newIORef emptyInstalledModuleEnv
   file_cache <- newIORef M.empty
   let flushFinderCaches :: UnitEnv -> IO ()
       flushFinderCaches ue = do
-        atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleWithIsBootEnv is_ext fm, ())
+        atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
         atomicModifyIORef' file_cache $ \_ -> (M.empty, ())
        where
-        is_ext mod _ = not (isUnitEnvInstalledModule ue (gwib_mod mod))
+        is_ext mod _ = not (isUnitEnvInstalledModule ue mod)
 
-      addToFinderCache :: InstalledModuleWithIsBoot -> InstalledFindResult -> IO ()
+      addToFinderCache :: InstalledModule -> InstalledFindResult -> IO ()
       addToFinderCache key val =
         atomicModifyIORef' mod_cache $ \c ->
-          case (lookupInstalledModuleWithIsBootEnv c key, val) of
+          case (lookupInstalledModuleEnv c key, val) of
             -- Don't overwrite an InstalledFound with an InstalledNotFound
             -- See [Note Monotonic addToFinderCache]
             (Just InstalledFound{}, InstalledNotFound{}) -> (c, ())
-            _ -> (extendInstalledModuleWithIsBootEnv c key val, ())
+            _ -> (extendInstalledModuleEnv c key val, ())
 
-      lookupFinderCache :: InstalledModuleWithIsBoot -> IO (Maybe InstalledFindResult)
+      lookupFinderCache :: InstalledModule -> IO (Maybe InstalledFindResult)
       lookupFinderCache key = do
          c <- readIORef mod_cache
-         return $! lookupInstalledModuleWithIsBootEnv c key
+         return $! lookupInstalledModuleEnv c key
 
       lookupFileCache :: FilePath -> IO Fingerprint
       lookupFileCache key = do
@@ -156,6 +158,13 @@ findImportedModule hsc_env mod pkg_qual =
   in do
     findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual
 
+findImportedModuleWithIsBoot :: HscEnv -> ModuleName -> IsBootInterface -> PkgQual -> IO FindResult
+findImportedModuleWithIsBoot hsc_env mod is_boot pkg_qual = do
+  res <- findImportedModule hsc_env mod pkg_qual
+  case (res, is_boot) of
+    (Found loc mod, IsBoot) -> return (Found (addBootSuffixLocn loc) mod)
+    _ -> return res
+
 findImportedModuleNoHsc
   :: FinderCache
   -> FinderOpts
@@ -228,15 +237,19 @@ findPluginModule fc fopts units Nothing mod_name =
 -- reading the interface for a module mentioned by another interface,
 -- for example (a "system import").
 
-findExactModule :: FinderCache -> FinderOpts ->  UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IO InstalledFindResult
-findExactModule fc fopts other_fopts unit_state mhome_unit mod = do
-  case mhome_unit of
+findExactModule :: FinderCache -> FinderOpts ->  UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult
+findExactModule fc fopts other_fopts unit_state mhome_unit mod is_boot = do
+  res <- case mhome_unit of
     Just home_unit
      | isHomeInstalledModule home_unit mod
         -> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod)
      | Just home_fopts <- unitEnv_lookup_maybe (moduleUnit mod) other_fopts
         -> findInstalledHomeModule fc home_fopts (moduleUnit mod) (moduleName mod)
     _ -> findPackageModule fc unit_state fopts mod
+  case (res, is_boot) of
+    (InstalledFound loc, IsBoot) -> return (InstalledFound (addBootSuffixLocn loc))
+    _ -> return res
+
 
 -- -----------------------------------------------------------------------------
 -- Helpers
@@ -274,7 +287,7 @@ orIfNotFound this or_this = do
 homeSearchCache :: FinderCache -> UnitId -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult
 homeSearchCache fc home_unit mod_name do_this = do
   let mod = mkModule home_unit mod_name
-  modLocationCache fc (notBoot mod) do_this
+  modLocationCache fc mod do_this
 
 findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
 findExposedPackageModule fc fopts units mod_name mb_pkg =
@@ -296,7 +309,7 @@ findLookupResult fc fopts r = case r of
         -- with just the location of the thing that was
         -- instantiated; you probably also need all of the
         -- implicit locations from the instances
-        InstalledFound loc   _ -> return (Found loc m)
+        InstalledFound loc     -> return (Found loc m)
         InstalledNoPackage   _ -> return (NoPackage (moduleUnit m))
         InstalledNotFound fp _ -> return (NotFound{ fr_paths = fmap unsafeDecodeUtf fp, fr_pkg = Just (moduleUnit m)
                                          , fr_pkgs_hidden = []
@@ -331,7 +344,7 @@ findLookupResult fc fopts r = case r of
                        , fr_unusables = []
                        , fr_suggestions = suggest' })
 
-modLocationCache :: FinderCache -> InstalledModuleWithIsBoot -> IO InstalledFindResult -> IO InstalledFindResult
+modLocationCache :: FinderCache -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult
 modLocationCache fc mod do_this = do
   m <- lookupFinderCache fc mod
   case m of
@@ -341,17 +354,19 @@ modLocationCache fc mod do_this = do
         addToFinderCache fc mod result
         return result
 
-addModuleToFinder :: FinderCache -> ModuleWithIsBoot -> ModLocation -> IO ()
-addModuleToFinder fc mod loc = do
-  let imod = fmap toUnitId <$> mod
-  addToFinderCache fc imod (InstalledFound loc (gwib_mod imod))
+addModuleToFinder :: FinderCache -> Module -> ModLocation -> HscSource -> IO ()
+addModuleToFinder fc mod loc src_flavour = do
+  let imod = toUnitId <$> mod
+  unless (src_flavour == HsBootFile) $
+    addToFinderCache fc imod (InstalledFound loc)
 
 -- This returns a module because it's more convenient for users
-addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleNameWithIsBoot -> ModLocation -> IO Module
-addHomeModuleToFinder fc home_unit mod_name loc = do
-  let mod = mkHomeInstalledModule home_unit <$> mod_name
-  addToFinderCache fc mod (InstalledFound loc (gwib_mod mod))
-  return (mkHomeModule home_unit (gwib_mod mod_name))
+addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> HscSource -> IO Module
+addHomeModuleToFinder fc home_unit mod_name loc src_flavour = do
+  let mod = mkHomeInstalledModule home_unit mod_name
+  unless (src_flavour == HsBootFile) $
+    addToFinderCache fc mod (InstalledFound loc)
+  return (mkHomeModule home_unit mod_name)
 
 -- -----------------------------------------------------------------------------
 --      The internal workers
@@ -361,7 +376,7 @@ findHomeModule fc fopts  home_unit mod_name = do
   let uid       = homeUnitAsUnit home_unit
   r <- findInstalledHomeModule fc fopts (homeUnitId home_unit) mod_name
   return $ case r of
-    InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)
+    InstalledFound loc -> Found loc (mkHomeModule home_unit mod_name)
     InstalledNoPackage _ -> NoPackage uid -- impossible
     InstalledNotFound fps _ -> NotFound {
         fr_paths = fmap unsafeDecodeUtf fps,
@@ -386,7 +401,7 @@ findHomePackageModule fc fopts  home_unit mod_name = do
   let uid       = RealUnit (Definite home_unit)
   r <- findInstalledHomeModule fc fopts home_unit mod_name
   return $ case r of
-    InstalledFound loc _ -> Found loc (mkModule uid mod_name)
+    InstalledFound loc -> Found loc (mkModule uid mod_name)
     InstalledNoPackage _ -> NoPackage uid -- impossible
     InstalledNotFound fps _ -> NotFound {
         fr_paths = fmap unsafeDecodeUtf fps,
@@ -456,7 +471,7 @@ findInstalledHomeModule fc fopts home_unit mod_name = do
    -- This is important only when compiling the base package (where GHC.Prim
    -- is a home module).
    if mod `installedModuleEq` gHC_PRIM
-         then return (InstalledFound (error "GHC.Prim ModLocation") mod)
+         then return (InstalledFound (error "GHC.Prim ModLocation"))
          else searchPathExts search_dirs mod exts
 
 -- | Prepend the working directory to the search path.
@@ -485,11 +500,11 @@ findPackageModule_ :: FinderCache -> FinderOpts -> InstalledModule -> UnitInfo -
 findPackageModule_ fc fopts mod pkg_conf = do
   massertPpr (moduleUnit mod == unitId pkg_conf)
              (ppr (moduleUnit mod) <+> ppr (unitId pkg_conf))
-  modLocationCache fc (notBoot mod) $
+  modLocationCache fc mod $
 
     -- special case for GHC.Prim; we won't find it in the filesystem.
     if mod `installedModuleEq` gHC_PRIM
-          then return (InstalledFound (error "GHC.Prim ModLocation") mod)
+          then return (InstalledFound (error "GHC.Prim ModLocation"))
           else
 
     let
@@ -513,7 +528,7 @@ findPackageModule_ fc fopts mod pkg_conf = do
             -- don't bother looking for it.
             let basename = unsafeEncodeUtf $ moduleNameSlashes (moduleName mod)
                 loc = mk_hi_loc one basename
-            in return $ InstalledFound loc mod
+            in return $ InstalledFound loc
       _otherwise ->
             searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]
 
@@ -547,7 +562,7 @@ searchPathExts paths mod exts = search to_search
     search ((file, loc) : rest) = do
       b <- doesFileExist file
       if b
-        then return $ InstalledFound loc mod
+        then return $ InstalledFound loc
         else search rest
 
 mkHomeModLocationSearched :: FinderOpts -> ModuleName -> FileExt
@@ -589,10 +604,12 @@ mkHomeModLocationSearched fopts mod suff path basename =
 -- ext
 --      The filename extension of the source file (usually "hs" or "lhs").
 
-mkHomeModLocation :: FinderOpts -> ModuleName -> OsPath -> ModLocation
-mkHomeModLocation dflags mod src_filename =
-   let (basename,extension) = OsPath.splitExtension src_filename
-   in mkHomeModLocation2 dflags mod basename extension
+mkHomeModLocation :: FinderOpts -> ModuleName -> OsPath -> FileExt -> HscSource -> ModLocation
+mkHomeModLocation dflags mod src_basename ext hsc_src =
+   let loc = mkHomeModLocation2 dflags mod src_basename ext
+   in case hsc_src of
+     HsBootFile -> addBootSuffixLocnOut loc
+     _ -> loc
 
 mkHomeModLocation2 :: FinderOpts
                    -> ModuleName


=====================================
compiler/GHC/Unit/Finder/Types.hs
=====================================
@@ -30,9 +30,9 @@ data FinderCache = FinderCache { flushFinderCaches :: UnitEnv -> IO ()
                                -- ^ remove all the home modules from the cache; package modules are
                                -- assumed to not move around during a session; also flush the file hash
                                -- cache.
-                               , addToFinderCache  :: InstalledModuleWithIsBoot -> InstalledFindResult -> IO ()
+                               , addToFinderCache  :: InstalledModule -> InstalledFindResult -> IO ()
                                -- ^ Add a found location to the cache for the module.
-                               , lookupFinderCache :: InstalledModuleWithIsBoot -> IO (Maybe InstalledFindResult)
+                               , lookupFinderCache :: InstalledModule -> IO (Maybe InstalledFindResult)
                                -- ^ Look for a location in the cache.
                                , lookupFileCache   :: FilePath -> IO Fingerprint
                                -- ^ Look for the hash of a file in the cache. This should add it to the
@@ -40,7 +40,7 @@ data FinderCache = FinderCache { flushFinderCaches :: UnitEnv -> IO ()
                                }
 
 data InstalledFindResult
-  = InstalledFound ModLocation InstalledModule
+  = InstalledFound ModLocation
   | InstalledNoPackage UnitId
   | InstalledNotFound [OsPath] (Maybe UnitId)
 


=====================================
compiler/GHC/Unit/Module/Env.hs
=====================================
@@ -33,17 +33,6 @@ module GHC.Unit.Module.Env
    , mergeInstalledModuleEnv
    , plusInstalledModuleEnv
    , installedModuleEnvElts
-
-     -- * InstalledModuleWithIsBootEnv
-   , InstalledModuleWithIsBootEnv
-   , emptyInstalledModuleWithIsBootEnv
-   , lookupInstalledModuleWithIsBootEnv
-   , extendInstalledModuleWithIsBootEnv
-   , filterInstalledModuleWithIsBootEnv
-   , delInstalledModuleWithIsBootEnv
-   , mergeInstalledModuleWithIsBootEnv
-   , plusInstalledModuleWithIsBootEnv
-   , installedModuleWithIsBootEnvElts
    )
 where
 
@@ -294,56 +283,3 @@ plusInstalledModuleEnv :: (elt -> elt -> elt)
 plusInstalledModuleEnv f (InstalledModuleEnv xm) (InstalledModuleEnv ym) =
   InstalledModuleEnv $ Map.unionWith f xm ym
 
-
-
---------------------------------------------------------------------
--- InstalledModuleWithIsBootEnv
---------------------------------------------------------------------
-
--- | A map keyed off of 'InstalledModuleWithIsBoot'
-newtype InstalledModuleWithIsBootEnv elt = InstalledModuleWithIsBootEnv (Map InstalledModuleWithIsBoot elt)
-
-instance Outputable elt => Outputable (InstalledModuleWithIsBootEnv elt) where
-  ppr (InstalledModuleWithIsBootEnv env) = ppr env
-
-
-emptyInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a
-emptyInstalledModuleWithIsBootEnv = InstalledModuleWithIsBootEnv Map.empty
-
-lookupInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBoot -> Maybe a
-lookupInstalledModuleWithIsBootEnv (InstalledModuleWithIsBootEnv e) m = Map.lookup m e
-
-extendInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBoot -> a -> InstalledModuleWithIsBootEnv a
-extendInstalledModuleWithIsBootEnv (InstalledModuleWithIsBootEnv e) m x = InstalledModuleWithIsBootEnv (Map.insert m x e)
-
-filterInstalledModuleWithIsBootEnv :: (InstalledModuleWithIsBoot -> a -> Bool) -> InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBootEnv a
-filterInstalledModuleWithIsBootEnv f (InstalledModuleWithIsBootEnv e) =
-  InstalledModuleWithIsBootEnv (Map.filterWithKey f e)
-
-delInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBoot -> InstalledModuleWithIsBootEnv a
-delInstalledModuleWithIsBootEnv (InstalledModuleWithIsBootEnv e) m = InstalledModuleWithIsBootEnv (Map.delete m e)
-
-installedModuleWithIsBootEnvElts :: InstalledModuleWithIsBootEnv a -> [(InstalledModuleWithIsBoot, a)]
-installedModuleWithIsBootEnvElts (InstalledModuleWithIsBootEnv e) = Map.assocs e
-
-mergeInstalledModuleWithIsBootEnv
-  :: (elta -> eltb -> Maybe eltc)
-  -> (InstalledModuleWithIsBootEnv elta -> InstalledModuleWithIsBootEnv eltc)  -- map X
-  -> (InstalledModuleWithIsBootEnv eltb -> InstalledModuleWithIsBootEnv eltc) -- map Y
-  -> InstalledModuleWithIsBootEnv elta
-  -> InstalledModuleWithIsBootEnv eltb
-  -> InstalledModuleWithIsBootEnv eltc
-mergeInstalledModuleWithIsBootEnv f g h (InstalledModuleWithIsBootEnv xm) (InstalledModuleWithIsBootEnv ym)
-  = InstalledModuleWithIsBootEnv $ Map.mergeWithKey
-      (\_ x y -> (x `f` y))
-      (coerce g)
-      (coerce h)
-      xm ym
-
-plusInstalledModuleWithIsBootEnv :: (elt -> elt -> elt)
-  -> InstalledModuleWithIsBootEnv elt
-  -> InstalledModuleWithIsBootEnv elt
-  -> InstalledModuleWithIsBootEnv elt
-plusInstalledModuleWithIsBootEnv f (InstalledModuleWithIsBootEnv xm) (InstalledModuleWithIsBootEnv ym) =
-  InstalledModuleWithIsBootEnv $ Map.unionWith f xm ym
-


=====================================
compiler/GHC/Unit/Module/Location.hs
=====================================
@@ -13,8 +13,6 @@ module GHC.Unit.Module.Location
     )
    , pattern ModLocation
    , addBootSuffix
-   , addBootSuffix_maybe
-   , addBootSuffixLocn_maybe
    , addBootSuffixLocn
    , addBootSuffixLocnOut
    , removeBootSuffix
@@ -25,7 +23,6 @@ where
 import GHC.Prelude
 
 import GHC.Data.OsPath
-import GHC.Unit.Types
 import GHC.Types.SrcLoc
 import GHC.Utils.Outputable
 import GHC.Data.FastString (mkFastString)
@@ -99,26 +96,10 @@ removeBootSuffix pathWithBootSuffix =
     Just path -> path
     Nothing -> error "removeBootSuffix: no -boot suffix"
 
--- | Add the @-boot@ suffix if the @Bool@ argument is @True@
-addBootSuffix_maybe :: IsBootInterface -> OsPath -> OsPath
-addBootSuffix_maybe is_boot path = case is_boot of
-  IsBoot -> addBootSuffix path
-  NotBoot -> path
-
-addBootSuffixLocn_maybe :: IsBootInterface -> ModLocation -> ModLocation
-addBootSuffixLocn_maybe is_boot locn = case is_boot of
-  IsBoot -> addBootSuffixLocn locn
-  _ -> locn
-
 -- | Add the @-boot@ suffix to all file paths associated with the module
 addBootSuffixLocn :: ModLocation -> ModLocation
 addBootSuffixLocn locn
-  = locn { ml_hs_file_ospath = fmap addBootSuffix (ml_hs_file_ospath locn)
-         , ml_hi_file_ospath  = addBootSuffix (ml_hi_file_ospath locn)
-         , ml_dyn_hi_file_ospath = addBootSuffix (ml_dyn_hi_file_ospath locn)
-         , ml_obj_file_ospath = addBootSuffix (ml_obj_file_ospath locn)
-         , ml_dyn_obj_file_ospath = addBootSuffix (ml_dyn_obj_file_ospath locn)
-         , ml_hie_file_ospath = addBootSuffix (ml_hie_file_ospath locn) }
+  = addBootSuffixLocnOut locn { ml_hs_file_ospath = fmap addBootSuffix (ml_hs_file_ospath locn) }
 
 -- | Add the @-boot@ suffix to all output file paths associated with the
 -- module, not including the input file itself


=====================================
compiler/GHC/Unit/Module/Warnings.hs
=====================================
@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -130,7 +131,8 @@ fromWarningCategory wc = InWarningCategory noAnn NoSourceText (noLocA wc)
 
 -- See Note [Warning categories]
 newtype WarningCategory = WarningCategory FastString
-  deriving (Binary, Data, Eq, Outputable, Show, Uniquable, NFData)
+  deriving stock Data
+  deriving newtype (Binary, Eq, Outputable, Show, Uniquable, NFData)
 
 mkWarningCategory :: FastString -> WarningCategory
 mkWarningCategory = WarningCategory


=====================================
compiler/GHC/Unit/Types.hs
=====================================
@@ -84,8 +84,6 @@ module GHC.Unit.Types
    , GenWithIsBoot (..)
    , ModuleNameWithIsBoot
    , ModuleWithIsBoot
-   , InstalledModuleWithIsBoot
-   , notBoot
    )
 where
 
@@ -720,8 +718,6 @@ type ModuleNameWithIsBoot = GenWithIsBoot ModuleName
 
 type ModuleWithIsBoot = GenWithIsBoot Module
 
-type InstalledModuleWithIsBoot = GenWithIsBoot InstalledModule
-
 instance Binary a => Binary (GenWithIsBoot a) where
   put_ bh (GWIB { gwib_mod, gwib_isBoot }) = do
     put_ bh gwib_mod
@@ -735,6 +731,3 @@ instance Outputable a => Outputable (GenWithIsBoot a) where
   ppr (GWIB  { gwib_mod, gwib_isBoot }) = hsep $ ppr gwib_mod : case gwib_isBoot of
     IsBoot -> [ text "{-# SOURCE #-}" ]
     NotBoot -> []
-
-notBoot :: mod -> GenWithIsBoot mod
-notBoot gwib_mod = GWIB {gwib_mod, gwib_isBoot = NotBoot}


=====================================
docs/users_guide/diagnostics-as-json-schema-1_1.json
=====================================
@@ -0,0 +1,134 @@
+{
+  "$schema": "https://json-schema.org/draft/2020-12/schema",
+  "title": "JSON Diagnostic Schema",
+  "description": "A Schema for specifying GHC diagnostics output as JSON",
+  "type": "object",
+  "properties": {
+    "version": {
+      "description": "The current JSON schema version this object conforms to",
+      "type": "string"
+    },
+    "ghcVersion": {
+      "description": "The GHC version",
+      "type": "string"
+    },
+    "span": {
+      "$ref": "#/$defs/span"
+    },
+    "severity": {
+      "description": "The diagnostic severity",
+      "type": "string",
+      "enum": [
+        "Warning",
+        "Error"
+      ]
+    },
+    "code": {
+      "description": "The diagnostic code (if it exists)",
+      "type": [
+        "integer",
+        "null"
+      ]
+    },
+    "message": {
+      "description": "The string output of the diagnostic message by GHC",
+      "type": "array",
+      "items": {
+        "type": "string"
+      }
+    },
+    "hints": {
+      "description": "The suggested fixes",
+      "type": "array",
+      "items": {
+        "type": "string"
+      }
+    },
+    "reason" : {
+      "description": "The GHC flag that was responsible for the emission of the diagnostic message",
+      "oneOf": [
+        {
+          "type": "object",
+          "description": "The diagnostic message was controlled by one or more GHC flags",
+          "properties": {
+            "flags": {
+              "type": "array",
+              "items": {
+                "description": "The name of a GHC flag controlling the diagnostic message",
+                "type": "string"
+              },
+              "minItems": 1
+            }
+          },
+          "required": ["flags"]
+        },
+        {
+          "type": "object",
+          "description": "The diagnostic message was controlled by a GHC diagnostic message category",
+          "properties": {
+            "category": {
+              "description": "The name of the GHC diagnostic message category controlling the diagnostic message",
+              "type": "string"
+            }
+          },
+          "required": ["category"]
+        }
+      ]
+    }
+  },
+  "required": [
+    "version",
+    "ghcVersion",
+    "span",
+    "severity",
+    "code",
+    "message",
+    "hints"
+  ],
+  "additionalProperties": false,
+  "$defs": {
+    "span": {
+      "description": "The span of the diagnostic",
+      "type": "object",
+      "properties": {
+        "file": {
+          "description": "The file in which the diagnostic occurs",
+          "type": "string"
+        },
+        "start": {
+          "description": "The start location of the diagnostic",
+          "$ref": "#/$defs/location"
+        },
+        "end": {
+          "description": "The end location of the diagnostic",
+          "$ref": "#/$defs/location"
+        }
+      },
+      "required": [
+        "file",
+        "start",
+        "end"
+      ],
+      "additionalProperties": false
+    },
+    "location": {
+      "description": "A location in a text file",
+      "type": "object",
+      "properties": {
+        "line": {
+          "description": "The line number",
+          "type": "integer"
+        },
+        "column": {
+          "description": "The column number",
+          "type": "integer"
+        }
+      },
+      "required": [
+        "line",
+        "column"
+      ],
+      "additionalProperties": false
+    }
+  }
+}


=====================================
docs/users_guide/using.rst
=====================================
@@ -1424,7 +1424,7 @@ messages and in GHCi:
     a new line.
 
     The structure of the output is described by a `JSON Schema <https://json-schema.org/>`_.
-    The schema can be downloaded :download:`here <diagnostics-as-json-schema-1_0.json>`.
+    The schema can be downloaded :download:`here <diagnostics-as-json-schema-1_1.json>`.
 
 .. ghc-flag:: -fdiagnostics-color=⟨always|auto|never⟩
     :shortdesc: Use colors in error messages


=====================================
rts/IPE.c
=====================================
@@ -277,3 +277,20 @@ void decompressIPEBufferListNodeIfCompressed(IpeBufferListNode *node) {
 
     }
 }
+
+#if defined(DEBUG)
+void printIPE(const StgInfoTable *info) {
+    InfoProvEnt ipe;
+    if (lookupIPE(info, &ipe)) {
+        debugBelch("%p:\n", info);
+        debugBelch("    name:    %s\n", ipe.prov.table_name);
+        debugBelch("    desc:    %" PRIu32 "\n", ipe.prov.closure_desc);
+        debugBelch("    type:    %s\n", ipe.prov.ty_desc);
+        debugBelch("    label:   %s\n", ipe.prov.label);
+        debugBelch("    module:  %s:%s\n", ipe.prov.unit_id, ipe.prov.module);
+        debugBelch("    src loc: %s:%s\n", ipe.prov.src_file, ipe.prov.src_span);
+    } else {
+        debugBelch("%p: no IPE entry\n", info);
+    }
+}
+#endif


=====================================
rts/include/rts/IPE.h
=====================================
@@ -97,3 +97,7 @@ void formatClosureDescIpe(const InfoProvEnt *ipe_buf, char *str_buf);
 
 // Returns true on success, initializes `out`.
 bool lookupIPE(const StgInfoTable *info, InfoProvEnt *out);
+
+#if defined(DEBUG)
+void printIPE(const StgInfoTable *info);
+#endif


=====================================
testsuite/tests/driver/all.T
=====================================
@@ -276,7 +276,7 @@ test('T12955', normal, makefile_test, [])
 test('T12971', [when(opsys('mingw32'), fragile(17945)), ignore_stdout], makefile_test, [])
 test('json_dump', normal, compile_fail, ['-ddump-json'])
 test('json', normalise_version('ghc'), compile_fail, ['-fdiagnostics-as-json'])
-test('json_warn', normalise_version('ghc'), compile, ['-fdiagnostics-as-json -Wunused-matches'])
+test('json_warn', normalise_version('ghc'), compile, ['-fdiagnostics-as-json -Wunused-matches -Wx-partial'])
 test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -ddump-json -Wno-unsupported-llvm-version'])
 test('T16167', [normalise_version('ghc'),req_interp,exit_code(1)], run_command,
      ['{compiler} -x hs -e ":set prog T16167.hs" -ddump-json T16167.hs'])


=====================================
testsuite/tests/driver/json.stderr
=====================================
@@ -1 +1 @@
-{"version":"1.0","ghcVersion":"ghc-9.11.20240329","span":{"file":"json.hs","start":{"line":9,"column":11},"end":{"line":9,"column":21}},"severity":"Error","code":48010,"message":["Empty list of alternatives in case expression"],"hints":["Perhaps you intended to use the `EmptyCase' extension"]}
+{"version":"1.1","ghcVersion":"ghc-9.13.20241113","span":{"file":"json.hs","start":{"line":9,"column":11},"end":{"line":9,"column":21}},"severity":"Error","code":48010,"message":["Empty list of alternatives in case expression"],"hints":["Perhaps you intended to use the `EmptyCase' extension"]}


=====================================
testsuite/tests/driver/json_warn.hs
=====================================
@@ -2,3 +2,6 @@ module Foo where
 
 f :: Int -> Int
 f x = 5
+
+g :: [a] -> a
+g = head


=====================================
testsuite/tests/driver/json_warn.stderr
=====================================
@@ -1 +1,2 @@
-{"version":"1.0","ghcVersion":"ghc-9.9.20230817","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: `x'"],"hints":[]}
+{"version":"1.1","ghcVersion":"ghc-9.13.20241113","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: `x'"],"hints":[],"reason":{"flags":["unused-matches"]}}
+{"version":"1.1","ghcVersion":"ghc-9.13.20241113","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of `head'\n(imported from Prelude, but defined in GHC.Internal.List):\n\"This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use \"Data.List.NonEmpty\".\""],"hints":[],"reason":{"category":"x-partial"}}



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6c5b5d00cee458e81eab03944ce8ace8cbda1441...0f4079d1290ab81a56897f6cca8eaf1328643e49

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6c5b5d00cee458e81eab03944ce8ace8cbda1441...0f4079d1290ab81a56897f6cca8eaf1328643e49
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/20241119/065889d0/attachment-0001.html>


More information about the ghc-commits mailing list