July 2025 - ghc-commits

[Git][ghc/ghc][master] 9 commits: Reorganise documentation for allocate* functions
by Marge Bot (＠marge-bot) 08 Jul '25

08 Jul '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: a48dcdf3 by Duncan Coutts at 2025-07-07T20:45:18-04:00 Reorganise documentation for allocate* functions Consolodate interface information into the .h file, keeping just implementation details in the .c file. Use Notes stlye in the .h file and refer to notes from the .c file. - - - - - de5b528c by Duncan Coutts at 2025-07-07T20:45:18-04:00 Introduce common utilities for allocating arrays The intention is to share code among the several places that do this already. - - - - - b321319d by Duncan Coutts at 2025-07-07T20:45:18-04:00 Use new array alloc utils in Heap.c The CMM primop can now report heap overflow. - - - - - 1d557ffb by Duncan Coutts at 2025-07-07T20:45:18-04:00 Use new array alloc utils in ThreadLabels.c Replacing a local utility. - - - - - e59a1430 by Duncan Coutts at 2025-07-07T20:45:18-04:00 Use new array alloc utils in Threads.c Replacing local open coded version. - - - - - 482df1c9 by Duncan Coutts at 2025-07-07T20:45:18-04:00 Add exitHeapOverflow helper utility This will be useful with the array alloc functions, since unlike allocate/allocateMaybeFail, they do not come in two versions. So if it's not convenient to propagate failure, then one can use this. - - - - - 4d3ec8f9 by Duncan Coutts at 2025-07-07T20:45:18-04:00 Use new array alloc utils in Weak.c Also add a cpp macro CCS_SYSTEM_OR_NULL which does what it says. The benefit of this is that it allows us to referece CCS_SYSTEM even when we're not in PROFILING mode. That makes abstracting over profiling vs normal mode a lot easier. - - - - - 0c4f2fde by Duncan Coutts at 2025-07-07T20:45:18-04:00 Convert the array alloc primops to use the new array alloc utils - - - - - a3354ad9 by Duncan Coutts at 2025-07-07T20:45:18-04:00 While we're at it, add one missing 'likely' hint To a cmm primops that raises an exception, like the others now do. - - - - - 14 changed files: - + rts/AllocArray.c - + rts/AllocArray.h - rts/Heap.c - rts/PrimOps.cmm - rts/RtsUtils.c - rts/ThreadLabels.c - rts/Threads.c - rts/Weak.c - rts/include/Rts.h - rts/include/rts/prof/CCS.h - rts/include/rts/storage/GC.h - rts/include/rts/storage/Heap.h - rts/rts.cabal - rts/sm/Storage.c Changes: ===================================== rts/AllocArray.c ===================================== @@ -0,0 +1,92 @@ +#include "rts/PosixSource.h" +#include "Rts.h" + +#include "AllocArray.h" + +StgMutArrPtrs *allocateMutArrPtrs (Capability *cap, + StgWord nelements, + CostCentreStack *ccs USED_IF_PROFILING) +{ + /* All sizes in words */ + + /* The card table contains one byte for each 2^MUT_ARR_PTRS_CARD_BITS words + * in the array, making sure we round up, and then rounding up to a whole + * number of words. */ + StgWord cardsize = mutArrPtrsCardTableSize(nelements); /* card table */ + StgWord arrsize = nelements + cardsize; /* +array size */ + StgWord objsize = sizeofW(StgMutArrPtrs) + arrsize; /* +header size */ + StgMutArrPtrs *arr; + arr = (StgMutArrPtrs *)allocateMightFail(cap, objsize); + if (RTS_UNLIKELY(arr == NULL)) return NULL; + TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), arrsize, 0); + + /* No write barrier needed since this is a new allocation. */ + SET_HDR(arr, &stg_MUT_ARR_PTRS_DIRTY_info, ccs); + arr->ptrs = nelements; + arr->size = arrsize; + + /* Initialize the card array. Note that memset needs sizes in bytes. */ + memset(&(arr->payload[nelements]), 0, mutArrPtrsCards(nelements)); + + return arr; +} + +StgSmallMutArrPtrs *allocateSmallMutArrPtrs (Capability *cap, + StgWord nelements, + CostCentreStack *ccs + USED_IF_PROFILING) +{ + /* All sizes in words */ + StgWord arrsize = nelements; /* array size */ + StgWord objsize = sizeofW(StgSmallMutArrPtrs) + arrsize; /* +header size */ + StgSmallMutArrPtrs *arr; + arr = (StgSmallMutArrPtrs *)allocateMightFail(cap, objsize); + if (RTS_UNLIKELY(arr == NULL)) return NULL; + TICK_ALLOC_PRIM(sizeofW(StgSmallMutArrPtrs), arrsize, 0); + + /* No write barrier needed since this is a new allocation. */ + SET_HDR(arr, &stg_SMALL_MUT_ARR_PTRS_DIRTY_info, ccs); + arr->ptrs = nelements; + return arr; +} + +StgArrBytes *allocateArrBytes (Capability *cap, + StgWord arrbytes, + CostCentreStack *ccs USED_IF_PROFILING) +{ + /* All sizes in words */ + StgWord arrwords = ROUNDUP_BYTES_TO_WDS(arrbytes); + StgWord objsize = sizeofW(StgArrBytes) + arrwords; + StgArrBytes *arr; + arr = (StgArrBytes *)allocateMightFail(cap, objsize); + if (RTS_UNLIKELY(arr == NULL)) return NULL; + TICK_ALLOC_PRIM(sizeofW(StgArrBytes), arrwords, 0); + /* No write barrier needed since this is a new allocation. */ + SET_HDR(arr, &stg_ARR_WORDS_info, ccs); + arr->bytes = arrbytes; + return arr; +} + +StgArrBytes *allocateArrBytesPinned (Capability *cap, + StgWord arrbytes, + StgWord alignment, + CostCentreStack *ccs USED_IF_PROFILING) +{ + /* we always supply at least word-aligned memory, so there's no + need to allow extra space for alignment if the requirement is less + than a word. This also prevents mischief with alignment == 0. */ + if (alignment <= sizeof(StgWord)) { alignment = sizeof(StgWord); } + + /* All sizes in words */ + StgWord arrwords = ROUNDUP_BYTES_TO_WDS(arrbytes); + StgWord objsize = sizeofW(StgArrBytes) + arrwords; + StgWord alignoff = sizeof(StgArrBytes); // it's the payload to be aligned + StgArrBytes *arr; + arr = (StgArrBytes *)allocatePinned(cap, objsize, alignment, alignoff); + if (RTS_UNLIKELY(arr == NULL)) return NULL; + TICK_ALLOC_PRIM(sizeofW(StgArrBytes), arrwords, 0); + /* No write barrier needed since this is a new allocation. */ + SET_HDR(arr, &stg_ARR_WORDS_info, ccs); + arr->bytes = arrbytes; + return arr; +} ===================================== rts/AllocArray.h ===================================== @@ -0,0 +1,50 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team 2025 + * + * Prototypes for functions in AllocArray.c + * + * RTS internal utilities for allocating arrays of pointers (StgMutArrPtrs) and + * arrays of bytes (StgArrBytes). + * -------------------------------------------------------------------------*/ + +#pragma once + +#include "Capability.h" + +#include "BeginPrivate.h" + +/* All these allocation functions return NULL on failure. If the context + * allows, then propagatethe failure upwards, e.g. to a CMM primop where a + * heap overflow exception can be thrown. Otherwise, use: + * if (RTS_UNLIKELY(p == NULL)) exitHeapOverflow(); + */ + +/* Allocate a StgMutArrPtrs for a given number of elements. It is allocated in + * the DIRTY state. + */ +StgMutArrPtrs *allocateMutArrPtrs (Capability *cap, + StgWord nelements, + CostCentreStack *ccs); + +/* Allocate a StgSmallMutArrPtrs for a given number of elements. + */ +StgSmallMutArrPtrs *allocateSmallMutArrPtrs (Capability *cap, + StgWord nelements, + CostCentreStack *ccs); + +/* Allocate a StgArrBytes for a given number of bytes. + */ +StgArrBytes *allocateArrBytes (Capability *cap, + StgWord nbytes, + CostCentreStack *ccs); + +/* Allocate a pinned (and optionally aligned) StgArrBytes for a given number + * of bytes. + */ +StgArrBytes *allocateArrBytesPinned (Capability *cap, + StgWord nbytes, + StgWord alignment, + CostCentreStack *ccs); + +#include "EndPrivate.h" ===================================== rts/Heap.c ===================================== @@ -13,6 +13,7 @@ #include "Capability.h" #include "Printer.h" +#include "AllocArray.h" StgWord heap_view_closureSize(StgClosure *closure) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure)); @@ -278,18 +279,14 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) { StgClosure **ptrs = (StgClosure **) stgMallocBytes(sizeof(StgClosure *) * size, "heap_view_closurePtrs"); StgWord nptrs = collect_pointers(closure, ptrs); - size = nptrs + mutArrPtrsCardTableSize(nptrs); - StgMutArrPtrs *arr = - (StgMutArrPtrs *)allocate(cap, sizeofW(StgMutArrPtrs) + size); - TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), nptrs, 0); - SET_HDR(arr, &stg_MUT_ARR_PTRS_FROZEN_CLEAN_info, cap->r.rCCCS); - arr->ptrs = nptrs; - arr->size = size; + StgMutArrPtrs *arr = allocateMutArrPtrs(cap, nptrs, cap->r.rCCCS); + if (RTS_UNLIKELY(arr == NULL)) goto end; + SET_INFO((StgClosure *) arr, &stg_MUT_ARR_PTRS_FROZEN_CLEAN_info); for (StgWord i = 0; i<nptrs; i++) { arr->payload[i] = ptrs[i]; } +end: stgFree(ptrs); - return arr; } ===================================== rts/PrimOps.cmm ===================================== @@ -112,20 +112,14 @@ import CLOSURE stg_sel_0_upd_info; stg_newByteArrayzh ( W_ n ) { - W_ words, payload_words; gcptr p; MAYBE_GC_N(stg_newByteArrayzh, n); - payload_words = ROUNDUP_BYTES_TO_WDS(n); - words = BYTES_TO_WDS(SIZEOF_StgArrBytes) + payload_words; - ("ptr" p) = ccall allocateMightFail(MyCapability() "ptr", words); - if (p == NULL) { + ("ptr" p) = ccall allocateArrBytes(MyCapability() "ptr", n, CCCS); + if (p == NULL) (likely: False) { jump stg_raisezh(ghczminternal_GHCziInternalziIOziException_heapOverflow_closure); } - TICK_ALLOC_PRIM(SIZEOF_StgArrBytes,WDS(payload_words),0); - SET_HDR(p, stg_ARR_WORDS_info, CCCS); - StgArrBytes_bytes(p) = n; return (p); } @@ -134,64 +128,29 @@ stg_newByteArrayzh ( W_ n ) stg_newPinnedByteArrayzh ( W_ n ) { - W_ words, bytes, payload_words; gcptr p; MAYBE_GC_N(stg_newPinnedByteArrayzh, n); - bytes = n; - /* payload_words is what we will tell the profiler we had to allocate */ - payload_words = ROUNDUP_BYTES_TO_WDS(bytes); - /* When we actually allocate memory, we need to allow space for the - header: */ - bytes = bytes + SIZEOF_StgArrBytes; - /* Now we convert to a number of words: */ - words = ROUNDUP_BYTES_TO_WDS(bytes); - - ("ptr" p) = ccall allocatePinned(MyCapability() "ptr", words, BA_ALIGN, SIZEOF_StgArrBytes); - if (p == NULL) { + ("ptr" p) = ccall allocateArrBytesPinned(MyCapability() "ptr", n, + BA_ALIGN, CCCS); + if (p == NULL) (likely: False) { jump stg_raisezh(ghczminternal_GHCziInternalziIOziException_heapOverflow_closure); } - TICK_ALLOC_PRIM(SIZEOF_StgArrBytes,WDS(payload_words),0); - - /* No write barrier needed since this is a new allocation. */ - SET_HDR(p, stg_ARR_WORDS_info, CCCS); - StgArrBytes_bytes(p) = n; return (p); } stg_newAlignedPinnedByteArrayzh ( W_ n, W_ alignment ) { - W_ words, bytes, payload_words; gcptr p; again: MAYBE_GC(again); - /* we always supply at least word-aligned memory, so there's no - need to allow extra space for alignment if the requirement is less - than a word. This also prevents mischief with alignment == 0. */ - if (alignment <= SIZEOF_W) { alignment = SIZEOF_W; } - - bytes = n; - - /* payload_words is what we will tell the profiler we had to allocate */ - payload_words = ROUNDUP_BYTES_TO_WDS(bytes); - - /* When we actually allocate memory, we need to allow space for the - header: */ - bytes = bytes + SIZEOF_StgArrBytes; - /* Now we convert to a number of words: */ - words = ROUNDUP_BYTES_TO_WDS(bytes); - - ("ptr" p) = ccall allocatePinned(MyCapability() "ptr", words, alignment, SIZEOF_StgArrBytes); - if (p == NULL) { + ("ptr" p) = ccall allocateArrBytesPinned(MyCapability() "ptr", n, + alignment, CCCS); + if (p == NULL) (likely: False) { jump stg_raisezh(ghczminternal_GHCziInternalziIOziException_heapOverflow_closure); } - TICK_ALLOC_PRIM(SIZEOF_StgArrBytes,WDS(payload_words),0); - - /* No write barrier needed since this is a new allocation. */ - SET_HDR(p, stg_ARR_WORDS_info, CCCS); - StgArrBytes_bytes(p) = n; return (p); } @@ -399,36 +358,23 @@ stg_casInt64Arrayzh( gcptr arr, W_ ind, I64 old, I64 new ) stg_newArrayzh ( W_ n /* words */, gcptr init ) { - W_ words, size, p; gcptr arr; again: MAYBE_GC(again); - // the mark area contains one byte for each 2^MUT_ARR_PTRS_CARD_BITS words - // in the array, making sure we round up, and then rounding up to a whole - // number of words. - size = n + mutArrPtrsCardWords(n); - words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + size; - ("ptr" arr) = ccall allocateMightFail(MyCapability() "ptr",words); - if (arr == NULL) { + ("ptr" arr) = ccall allocateMutArrPtrs(MyCapability() "ptr", n, CCCS); + if (arr == NULL) (likely: False) { jump stg_raisezh(ghczminternal_GHCziInternalziIOziException_heapOverflow_closure); } - TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0); - - /* No write barrier needed since this is a new allocation. */ - SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, CCCS); - StgMutArrPtrs_ptrs(arr) = n; - StgMutArrPtrs_size(arr) = size; - - /* Ensure that the card array is initialized */ - if (n != 0) { - setCardsValue(arr, 0, n, 0); - } - // Initialise all elements of the array with the value in R2 + // Initialise all elements of the array with the value init + W_ p; p = arr + SIZEOF_StgMutArrPtrs; + // Avoid the shift for `WDS(n)` in the inner loop + W_ limit; + limit = arr + SIZEOF_StgMutArrPtrs + WDS(n); for: - if (p < arr + SIZEOF_StgMutArrPtrs + WDS(n)) (likely: True) { + if (p < limit) (likely: True) { W_[p] = init; p = p + WDS(1); goto for; @@ -522,23 +468,17 @@ stg_casArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new ) stg_newSmallArrayzh ( W_ n /* words */, gcptr init ) { - W_ words, size, p; gcptr arr; again: MAYBE_GC(again); - words = BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + n; - ("ptr" arr) = ccall allocateMightFail(MyCapability() "ptr",words); + ("ptr" arr) = ccall allocateSmallMutArrPtrs(MyCapability() "ptr", n, CCCS); if (arr == NULL) (likely: False) { jump stg_raisezh(ghczminternal_GHCziInternalziIOziException_heapOverflow_closure); } - TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(n), 0); - - /* No write barrier needed since this is a new allocation. */ - SET_HDR(arr, stg_SMALL_MUT_ARR_PTRS_DIRTY_info, CCCS); - StgSmallMutArrPtrs_ptrs(arr) = n; - // Initialise all elements of the array with the value in R2 + // Initialise all elements of the array with the value init + W_ p; p = arr + SIZEOF_StgSmallMutArrPtrs; // Avoid the shift for `WDS(n)` in the inner loop W_ limit; @@ -1148,6 +1088,11 @@ stg_listThreadszh () P_ arr; ("ptr" arr) = ccall listThreads(MyCapability() "ptr"); + + if (arr == NULL) (likely: False) { + jump stg_raisezh(ghczminternal_GHCziInternalziIOziException_heapOverflow_closure); + } + return (arr); } @@ -1414,7 +1359,7 @@ stg_atomicallyzh (P_ stm) old_trec = StgTSO_trec(CurrentTSO); /* Nested transactions are not allowed; raise an exception */ - if (old_trec != NO_TREC) { + if (old_trec != NO_TREC) (likely: False) { jump stg_raisezh(ghczminternal_GHCziInternalziControlziExceptionziBase_nestedAtomically_closure); } @@ -2537,6 +2482,10 @@ for: // Collect pointers. ("ptr" ptrArray) = foreign "C" heap_view_closurePtrs(MyCapability() "ptr", clos "ptr"); + if (ptrArray == NULL) (likely: False) { + jump stg_raisezh(ghczminternal_GHCziInternalziIOziException_heapOverflow_closure); + } + return (info, dat_arr, ptrArray); } ===================================== rts/RtsUtils.c ===================================== @@ -198,6 +198,13 @@ reportHeapOverflow(void) (W_)RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE); } +void +exitHeapOverflow(void) +{ + reportHeapOverflow(); // reportHeapOverflow() doesn't exit (see #2592) + stg_exit(EXIT_HEAPOVERFLOW); +} + /* ----------------------------------------------------------------------------- Sleep for the given period of time. -------------------------------------------------------------------------- */ ===================================== rts/ThreadLabels.c ===================================== @@ -15,6 +15,7 @@ #include "RtsFlags.h" #include "Hash.h" #include "Trace.h" +#include "AllocArray.h" #include <stdlib.h> #include <string.h> @@ -31,25 +32,16 @@ * determined by the ByteArray# length. */ -static StgArrBytes * -allocateArrBytes(Capability *cap, size_t size_in_bytes) -{ - /* round up to a whole number of words */ - uint32_t data_size_in_words = ROUNDUP_BYTES_TO_WDS(size_in_bytes); - uint32_t total_size_in_words = sizeofW(StgArrBytes) + data_size_in_words; - - StgArrBytes *arr = (StgArrBytes *) allocate(cap, total_size_in_words); - SET_ARR_HDR(arr, &stg_ARR_WORDS_info, cap->r.rCCCS, size_in_bytes); - return arr; -} - void setThreadLabel(Capability *cap, StgTSO *tso, char *label) { int len = strlen(label); - StgArrBytes *arr = allocateArrBytes(cap, len); + StgArrBytes *arr = allocateArrBytes(cap, len, cap->r.rCCCS); + // On allocation failure don't perform the effect. It's not convenient to + // propagate failure from here since there are multiple callers in the RTS. + if (RTS_UNLIKELY(arr == NULL)) return; memcpy(&arr->payload, label, len); labelThread(cap, tso, arr); } ===================================== rts/Threads.c ===================================== @@ -25,6 +25,7 @@ #include "Printer.h" #include "sm/Sanity.h" #include "sm/Storage.h" +#include "AllocArray.h" #include <string.h> @@ -879,6 +880,7 @@ loop: return true; } +/* Return NULL on allocation failure */ StgMutArrPtrs *listThreads(Capability *cap) { ACQUIRE_LOCK(&sched_mutex); @@ -892,13 +894,8 @@ StgMutArrPtrs *listThreads(Capability *cap) } // Allocate a suitably-sized array... - const StgWord size = n_threads + mutArrPtrsCardTableSize(n_threads); - StgMutArrPtrs *arr = - (StgMutArrPtrs *)allocate(cap, sizeofW(StgMutArrPtrs) + size); - SET_HDR(arr, &stg_MUT_ARR_PTRS_DIRTY_info, CCS_SYSTEM); - TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), size, 0); - arr->ptrs = n_threads; - arr->size = size; + StgMutArrPtrs *arr = allocateMutArrPtrs(cap, n_threads, cap->r.rCCCS); + if (RTS_UNLIKELY(arr == NULL)) goto end; // Populate it... StgWord i = 0; @@ -913,6 +910,7 @@ StgMutArrPtrs *listThreads(Capability *cap) } } CHECKM(i == n_threads, "listThreads: Found too few threads"); +end: RELEASE_LOCK(&sched_mutex); return arr; } ===================================== rts/Weak.c ===================================== @@ -17,6 +17,7 @@ #include "Prelude.h" #include "ThreadLabels.h" #include "Trace.h" +#include "AllocArray.h" // List of dead weak pointers collected by the last GC static StgWeak *finalizer_list = NULL; @@ -89,8 +90,6 @@ scheduleFinalizers(Capability *cap, StgWeak *list) { StgWeak *w; StgTSO *t; - StgMutArrPtrs *arr; - StgWord size; uint32_t n, i; // n_finalizers is not necessarily zero under non-moving collection @@ -147,13 +146,10 @@ scheduleFinalizers(Capability *cap, StgWeak *list) debugTrace(DEBUG_weak, "weak: batching %d finalizers", n); - size = n + mutArrPtrsCardTableSize(n); - arr = (StgMutArrPtrs *)allocate(cap, sizeofW(StgMutArrPtrs) + size); - TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0); + StgMutArrPtrs *arr = allocateMutArrPtrs(cap, n, CCS_SYSTEM_OR_NULL); + if (RTS_UNLIKELY(arr == NULL)) exitHeapOverflow(); // No write barrier needed here; this array is only going to referred to by this core. - SET_HDR(arr, &stg_MUT_ARR_PTRS_FROZEN_CLEAN_info, CCS_SYSTEM); - arr->ptrs = n; - arr->size = size; + SET_INFO((StgClosure *) arr, &stg_MUT_ARR_PTRS_FROZEN_CLEAN_info); n = 0; for (w = list; w; w = w->link) { @@ -163,6 +159,10 @@ scheduleFinalizers(Capability *cap, StgWeak *list) } } // set all the cards to 1 + StgWord size = n + mutArrPtrsCardTableSize(n); + // TODO: does this need to be a StgMutArrPtrs with a card table? + // If the cards are all 1 and the array is clean, couldn't it + // be a StgSmallMutArrPtrs instead? for (i = n; i < size; i++) { arr->payload[i] = (StgClosure *)(W_)(-1); } ===================================== rts/include/Rts.h ===================================== @@ -291,6 +291,7 @@ DLL_IMPORT_RTS extern char *prog_name; void reportStackOverflow(StgTSO* tso); void reportHeapOverflow(void); +void exitHeapOverflow(void) STG_NORETURN;; void stg_exit(int n) STG_NORETURN; ===================================== rts/include/rts/prof/CCS.h ===================================== @@ -220,9 +220,14 @@ extern CostCentre * RTS_VAR(CC_LIST); // registered CC list #define CCS_ALLOC(ccs, size) (ccs)->mem_alloc += ((size)-sizeofW(StgProfHeader)) #define ENTER_CCS_THUNK(cap,p) cap->r.rCCCS = p->header.prof.ccs +/* Allow using CCS_SYSTEM somewhat consistently with/without profiling mode */ +#define CCS_SYSTEM_OR_NULL CCS_SYSTEM + #else /* !PROFILING */ #define CCS_ALLOC(ccs, amount) doNothing() #define ENTER_CCS_THUNK(cap,p) doNothing() +#define CCS_SYSTEM_OR_NULL NULL + #endif /* PROFILING */ ===================================== rts/include/rts/storage/GC.h ===================================== @@ -170,36 +170,106 @@ void listAllBlocks(ListBlocksCb cb, void *user); /* ----------------------------------------------------------------------------- Generic allocation - StgPtr allocate(Capability *cap, W_ n) - Allocates memory from the nursery in - the current Capability. - - StgPtr allocatePinned(Capability *cap, W_ n, W_ alignment, W_ align_off) - Allocates a chunk of contiguous store - n words long, which is at a fixed - address (won't be moved by GC). The - word at the byte offset 'align_off' - will be aligned to 'alignment', which - must be a power of two. - Returns a pointer to the first word. - Always succeeds. - - NOTE: the GC can't in general handle - pinned objects, so allocatePinned() - can only be used for ByteArrays at the - moment. - - Don't forget to TICK_ALLOC_XXX(...) - after calling allocate or - allocatePinned, for the - benefit of the ticky-ticky profiler. - + See: Note [allocate and allocateMightFail] + Note [allocatePinned] + Note [allocate failure] -------------------------------------------------------------------------- */ StgPtr allocate ( Capability *cap, W_ n ); StgPtr allocateMightFail ( Capability *cap, W_ n ); StgPtr allocatePinned ( Capability *cap, W_ n, W_ alignment, W_ align_off); +/* Note [allocate and allocateMightFail] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + allocate() and allocateMightFail() allocate an area of memory n + *words* large, from the nursery of the supplied Capability, or from + the global block pool if the area requested is larger than + LARGE_OBJECT_THRESHOLD. Memory is not allocated from the current + nursery block, so as not to interfere with Hp/HpLim. + + The address of the allocated memory is returned. + + After allocating, fill in the heap closure header, e.g. + SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, CCCS); + and call TICK_ALLOC_XXX(...) for the benefit of the ticky-ticky + profiler. + + On allocation failure, allocateMightFail() returns NULL whereas + allocate() terminates the RTS. See Note [allocate failure]. You + should prefer allocateMightFail() in cases where you can propagate + the failure up to a context in which you can raise exceptions, e.g. + in primops. + */ + +/* Note [allocatePinned] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + allocatePinned() allocates a chunk of contiguous store n *words* + long, which is at a fixed address (i.e. won't be moved by GC). The + word at the byte offset 'align_off' will be aligned to 'alignment', + which must be a power of two. + + The address of the allocated memory is returned. + + The GC can't in general handle pinned objects, so allocatePinned() + can only be used for ByteArrays / stg_ARR_WORDS at the moment. + + On allocation failure, allocatePinned() returns NULL. + See Note [allocate failure]. + */ + +/* Note [allocate failure] + ~~~~~~~~~~~~~~~~~~~~~~~ + + The allocation functions differ in how they handle failure to + allocate: + + * on failure allocateMightFail() returns NULL + * on failure allocatePinned() returns NULL + * on failure allocate() terminates the RTS (and thus typically + the whole process) + + Each of these functions tries _quite_ hard to avoid allocation + failure however. If the nursery is already full, then another block + is allocated from the global block pool. If we need to get memory + from the OS and that operation fails, or if we would exceed + maxHeapSize then we fail. + + There are two main existing conventions within the RTS for handling + allocation failure. + + 1. Start from a primop that uses one of the MAYBE_GC_* macros to + provide an opportunity to GC. Then buried deeply within C code + called from the primop, use allocate(). + + 2. Start from a primop that uses one of the MAYBE_GC_* macros to + provide an opportunity to GC. Use allocateMightFail() within the + C code called from the primop. If that fails, propagate the + failure up to the primop where it can throw a HeapOverflow + exception. + + Being able to throw an exception is preferable, since it's more + polite, provides better reporting and potentially it can be + caught and handled by the user program. + + An advantage of the first approach is that its simpler to implement. + It does not require any mechanism to propagate failure (and undoing + any effects along the way so the operation can be safely retried + after GC). + + Arguably neither existing convention is ideal. One might imagine + that when failure from allocateMightFail() propagates to the top + level primop, the primop would not throw a HeapOverflow exception + but invoke the GC with a request to make available at least the + required number of words. The GC may be able to succeed, in which + case the original operation can be retried. Or if the GC is unable + to free enough memory then it can throw the HeapOverflow exception. + In practice however, though there is a mechanism (via HpAlloc) to + tell the GC how much memory was needed, this is not used to decide + if we have to fail the allocation, it is just used for error + reporting. + */ + /* memory allocator for executable memory */ typedef void* AdjustorWritable; typedef void* AdjustorExecutable; ===================================== rts/include/rts/storage/Heap.h ===================================== @@ -10,6 +10,7 @@ #include "rts/storage/Closures.h" +/* Returns NULL on allocation failure */ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure); void heap_view_closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs ===================================== rts/rts.cabal ===================================== @@ -400,6 +400,7 @@ library asm-sources: StgCRunAsm.S c-sources: Adjustor.c + AllocArray.c adjustor/AdjustorPool.c ExecPage.c Arena.c ===================================== rts/sm/Storage.c ===================================== @@ -1065,46 +1065,31 @@ accountAllocation(Capability *cap, W_ n) * overwriting closures]. */ -/* ----------------------------------------------------------------------------- - StgPtr allocate (Capability *cap, W_ n) - - Allocates an area of memory n *words* large, from the nursery of - the supplied Capability, or from the global block pool if the area - requested is larger than LARGE_OBJECT_THRESHOLD. Memory is not - allocated from the current nursery block, so as not to interfere - with Hp/HpLim. - - The address of the allocated memory is returned. allocate() never - fails; if it returns, the returned value is a valid address. If - the nursery is already full, then another block is allocated from - the global block pool. If we need to get memory from the OS and - that operation fails, then the whole process will be killed. - -------------------------------------------------------------------------- */ - /* - * Allocate some n words of heap memory; terminating - * on heap overflow + * Allocate some n words of heap memory; terminating on heap overflow. + * + * See Note [allocate and allocateMightFail]. */ StgPtr allocate (Capability *cap, W_ n) { StgPtr p = allocateMightFail(cap, n); - if (p == NULL) { - reportHeapOverflow(); - // heapOverflow() doesn't exit (see #2592), but we aren't + if (RTS_UNLIKELY(p == NULL)) { + // reportHeapOverflow() doesn't exit (see #2592), but we aren't // in a position to do a clean shutdown here: we // either have to allocate the memory or exit now. // Allocating the memory would be bad, because the user // has requested that we not exceed maxHeapSize, so we // just exit. - stg_exit(EXIT_HEAPOVERFLOW); + exitHeapOverflow(); } return p; } /* - * Allocate some n words of heap memory; returning NULL - * on heap overflow + * Allocate some n words of heap memory; returning NULL on heap overflow. + * + * See Note [allocate and allocateMightFail]. */ StgPtr allocateMightFail (Capability *cap, W_ n) @@ -1303,6 +1288,9 @@ start_new_pinned_block(Capability *cap) /* --------------------------------------------------------------------------- Allocate a fixed/pinned object. + See Note [allocatePinned] for the interface. This describes the + implementation. + We allocate small pinned objects into a single block, allocating a new block when the current one overflows. The block is chained onto the large_object_list of generation 0. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5856284b6380f1f5d73622a19ff9fe… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5856284b6380f1f5d73622a19ff9fe… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: users-guide: Reference Wasm FFI section
by Marge Bot (＠marge-bot) 08 Jul '25

08 Jul '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: fe925bd4 by Ben Gamari at 2025-07-07T20:44:30-04:00 users-guide: Reference Wasm FFI section - - - - - 5856284b by Ben Gamari at 2025-07-07T20:44:30-04:00 users-guide: Fix too-short heading warning - - - - - 2 changed files: - docs/users_guide/exts/doandifthenelse.rst - docs/users_guide/exts/ffi.rst Changes: ===================================== docs/users_guide/exts/doandifthenelse.rst ===================================== @@ -1,7 +1,7 @@ .. _doandifthenelse: Do And If Then Else -============ +=================== .. extension:: DoAndIfThenElse :shortdesc: Allow semicolons in ``if`` expressions. ===================================== docs/users_guide/exts/ffi.rst ===================================== @@ -31,6 +31,8 @@ features should be avoided where possible. The FFI libraries are documented in the accompanying library documentation; see for example the :base-ref:`Foreign.` module. +For documentation on FFI with WebAssembly, see the +:ref:`WebAssembly chapter <wasm-jsffi>`. GHC differences to the FFI Chapter ---------------------------------- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0fb24420f4129aaf4e41114b6615d4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0fb24420f4129aaf4e41114b6615d4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] hadrian: Fallback logic for internal interpreter
by Marge Bot (＠marge-bot) 08 Jul '25

08 Jul '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 0fb24420 by Rodrigo Mesquita at 2025-07-07T20:43:49-04:00 hadrian: Fallback logic for internal interpreter When determining whether to build the internal interpreter, the `make` build system had a fallback case for platforms not in the list of explicitly-supported operating systems and architectures. This fallback says we should try to build the internal interpreter if building dynamic GHC programs (if the architecture is unknown). Fixes #24098 - - - - - 5 changed files: - hadrian/src/Oracles/Flag.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Settings/Builders/Cabal.hs - hadrian/src/Settings/Packages.hs - hadrian/src/Settings/Program.hs Changes: ===================================== hadrian/src/Oracles/Flag.hs ===================================== @@ -7,7 +7,6 @@ module Oracles.Flag ( targetRTSLinkerOnlySupportsSharedLibs, targetSupportsThreadedRts, targetSupportsSMP, - ghcWithInterpreter, useLibffiForAdjustors, arSupportsDashL, arSupportsAtFile @@ -146,31 +145,5 @@ targetSupportsSMP = do | goodArch -> return True | otherwise -> return False - --- | When cross compiling, enable for stage0 to get ghci --- support. But when not cross compiling, disable for --- stage0, otherwise we introduce extra dependencies --- like haskeline etc, and mixing stageBoot/stage0 libs --- can cause extra trouble (e.g. #25406) --- --- Also checks whether the target supports GHCi. -ghcWithInterpreter :: Stage -> Action Bool -ghcWithInterpreter stage = do - is_cross <- flag CrossCompiling - goodOs <- anyTargetOs [ OSMinGW32, OSLinux, OSSolaris2 -- TODO "cygwin32"?, - , OSFreeBSD, OSDragonFly, OSNetBSD, OSOpenBSD - , OSDarwin, OSKFreeBSD - , OSWasi ] - goodArch <- (||) <$> - anyTargetArch [ ArchX86, ArchX86_64, ArchPPC - , ArchAArch64, ArchS390X - , ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2 - , ArchRISCV64, ArchLoongArch64 - , ArchWasm32 ] - <*> isArmTarget - -- Maybe this should just be false for cross compilers. But for now - -- I've kept the old behaviour where it will say yes. (See #25939) - return $ goodOs && goodArch && (stage >= Stage1 || is_cross) - useLibffiForAdjustors :: Action Bool useLibffiForAdjustors = queryTargetTarget tgtUseLibffiForAdjustors ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -26,6 +26,7 @@ import Utilities import GHC.Toolchain as Toolchain hiding (HsCpp(HsCpp)) import GHC.Toolchain.Program import GHC.Platform.ArchOS +import Settings.Program (ghcWithInterpreter) -- | Track this file to rebuild generated files whenever it changes. trackGenerateHs :: Expr () ===================================== hadrian/src/Settings/Builders/Cabal.hs ===================================== @@ -11,7 +11,7 @@ import Settings.Builders.Common import qualified Settings.Builders.Common as S import Control.Exception (assert) import qualified Data.Set as Set -import Settings.Program (programContext) +import Settings.Program (programContext, ghcWithInterpreter) import GHC.Toolchain (ccLinkProgram, tgtCCompilerLink) import GHC.Toolchain.Program (prgFlags) ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -11,6 +11,7 @@ import Settings.Builders.Common (wayCcArgs) import GHC.Toolchain.Target import GHC.Platform.ArchOS import Data.Version.Extra +import Settings.Program (ghcWithInterpreter) -- | Package-specific command-line arguments. packageArgs :: Args ===================================== hadrian/src/Settings/Program.hs ===================================== @@ -1,12 +1,17 @@ module Settings.Program ( programContext + , ghcWithInterpreter ) where import Base import Context import Oracles.Flavour +import Oracles.Flag import Packages +import GHC.Platform.ArchOS +import Settings.Builders.Common (anyTargetOs, anyTargetArch, isArmTarget) + -- TODO: there is duplication and inconsistency between this and -- Rules.Program.getProgramContexts. There should only be one way to -- get a context/contexts for a given stage and package. @@ -24,3 +29,33 @@ programContext stage pkg = do notStage0 (Stage0 {}) = False notStage0 _ = True + +-- | When cross compiling, enable for stage0 to get ghci +-- support. But when not cross compiling, disable for +-- stage0, otherwise we introduce extra dependencies +-- like haskeline etc, and mixing stageBoot/stage0 libs +-- can cause extra trouble (e.g. #25406) +-- +-- Also checks whether the target supports GHCi. +ghcWithInterpreter :: Stage -> Action Bool +ghcWithInterpreter stage = do + is_cross <- flag CrossCompiling + goodOs <- anyTargetOs [ OSMinGW32, OSLinux, OSSolaris2 -- TODO "cygwin32"?, + , OSFreeBSD, OSDragonFly, OSNetBSD, OSOpenBSD + , OSDarwin, OSKFreeBSD + , OSWasi ] + goodArch <- (||) <$> + anyTargetArch [ ArchX86, ArchX86_64, ArchPPC + , ArchAArch64, ArchS390X + , ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2 + , ArchRISCV64, ArchLoongArch64 + , ArchWasm32 ] + <*> isArmTarget + -- The explicit support list is essentially a list of platforms for which + -- the RTS linker has support. If the RTS linker is not supported then we + -- fall back on dynamic linking: + dynamicGhcProgs <- askDynGhcPrograms + + -- Maybe this should just be false for cross compilers. But for now + -- I've kept the old behaviour where it will say yes. (See #25939) + return $ ((goodOs && goodArch) || dynamicGhcProgs) && (stage >= Stage1 || is_cross) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0fb24420f4129aaf4e41114b6615d43… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0fb24420f4129aaf4e41114b6615d43… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] haddock: Document instances from other packages
by Marge Bot (＠marge-bot) 08 Jul '25

08 Jul '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: a26243fd by Ryan Hendrickson at 2025-07-07T20:43:07-04:00 haddock: Document instances from other packages When attaching instances to `Interface`s, it isn't enough just to look for instances in the list of `Interface`s being processed. We also need to look in the modules on which they depend, including those outside of this package. Fixes #25147. Fixes #26079. - - - - - 6 changed files: - utils/haddock/CHANGES.md - utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs - utils/haddock/haddock-api/src/Haddock/Types.hs - utils/haddock/haddock-test/src/Test/Haddock/Config.hs - utils/haddock/html-test/ref/Bug1004.html Changes: ===================================== utils/haddock/CHANGES.md ===================================== @@ -1,6 +1,8 @@ ## Changes in 2.32.0 * Add highlighting for inline-code-blocks (sections enclosed in @'s) + * Fix missing documentation for orphan instances from other packages. + * Add incremental mode to support rendering documentation one module at a time. * The flag `--no-compilation` has been added. This flag causes Haddock to avoid ===================================== utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs ===================================== @@ -88,7 +88,10 @@ attachInstances expInfo ifaces instIfaceMap isOneShot = do , fromOrig == Just True || not (null reExp) ] mods_to_load = moduleSetElts mods - mods_visible = mkModuleSet $ map ifaceMod ifaces + -- We need to ensure orphans in modules outside of this package are included. + -- See https://gitlab.haskell.org/ghc/ghc/-/issues/25147 + -- and https://gitlab.haskell.org/ghc/ghc/-/issues/26079 + mods_visible = mkModuleSet $ concatMap (liftA2 (:) ifaceMod ifaceOrphanDeps) ifaces (_msgs, mb_index) <- do hsc_env <- getSession ===================================== utils/haddock/haddock-api/src/Haddock/Interface/Create.hs ===================================== @@ -59,6 +59,7 @@ import GHC.Types.Name.Set import GHC.Types.SafeHaskell import qualified GHC.Types.SrcLoc as SrcLoc import qualified GHC.Types.Unique.Map as UniqMap +import GHC.Unit.Module.Deps (dep_orphs) import GHC.Unit.Module.ModIface import GHC.Unit.State (PackageName (..), UnitState) import GHC.Utils.Outputable (SDocContext) @@ -270,6 +271,7 @@ createInterface1' flags unit_state dflags hie_file mod_iface ifaces inst_ifaces , ifaceVisibleExports = visible_names , ifaceFixMap = fixities , ifaceInstances = instances + , ifaceOrphanDeps = dep_orphs $ mi_deps mod_iface , ifaceOrphanInstances = [] -- Filled in attachInstances , ifaceRnOrphanInstances = [] -- Filled in renameInterfaceRn , ifaceHaddockCoverage = coverage ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -134,6 +134,9 @@ data Interface = Interface -- Names from modules that are entirely re-exported don't count as visible. , ifaceInstances :: [ClsInst] -- ^ Instances exported by the module. + , ifaceOrphanDeps :: [Module] + -- ^ The list of modules to check for orphan instances if this module is + -- imported. , ifaceOrphanInstances :: [DocInstance GhcRn] -- ^ Orphan instances , ifaceRnOrphanInstances :: [DocInstance DocNameI] ===================================== utils/haddock/haddock-test/src/Test/Haddock/Config.hs ===================================== @@ -262,6 +262,7 @@ baseDependencies ghcPath = do pkgs = [ "array" , "base" + , "deepseq" , "ghc-prim" , "process" , "template-haskell" ===================================== utils/haddock/html-test/ref/Bug1004.html ===================================== @@ -833,7 +833,61 @@ ><tr ><td class="src clearfix" > (<a href="#" title="Control.DeepSeq" + >NFData1</a + > f, <a href="#" title="Control.DeepSeq" + >NFData1</a + > g) => <a href="#" title="Control.DeepSeq" + >NFData1</a + > (<a href="#" title="Bug1004" + >Product</a + > f g) <a href="#" class="selflink" + >#</a + ></td + ><td class="doc" + >Since: deepseq-1.4.3.0</td + ></tr + ><tr + ><td colspan="2" + ><details id="i:id:Product:NFData1:8" + ><summary class="hide-when-js-enabled" + >Instance details</summary + >Defined in <a href="#" + >Control.DeepSeq</a + > <div class="subs methods" + >Methods<a href="#" + >liftRnf</a + > :: (a -> ()) -> <a href="#" title="Bug1004" + >Product</a + > f g a -> () <a href="#" class="selflink" + >#</a + ></div + ></details + ></td + ></tr + ><tr + ><td class="src clearfix" + > (</tr ><tr ><td colspan="2" - ><details id="i:id:Product:Alternative:8" + ><details id="i:id:Product:Alternative:9" ><summary class="hide-when-js-enabled" >Instance details</summary ><tr ><td class="src clearfix" > (</tr ><tr ><td colspan="2" - ><details id="i:id:Product:Applicative:9" + ><details id="i:id:Product:Applicative:10" ><summary class="hide-when-js-enabled" >Instance details</summary ><tr ><td class="src clearfix" > (</tr ><tr ><td colspan="2" - ><details id="i:id:Product:Functor:10" + ><details id="i:id:Product:Functor:11" ><summary class="hide-when-js-enabled" >Instance details</summary ><tr ><td class="src clearfix" > (</tr ><tr ><td colspan="2" - ><details id="i:id:Product:Monad:11" + ><details id="i:id:Product:Monad:12" ><summary class="hide-when-js-enabled" >Instance details</summary ><tr ><td class="src clearfix" > (</tr ><tr ><td colspan="2" - ><details id="i:id:Product:MonadPlus:12" + ><details id="i:id:Product:MonadPlus:13" ><summary class="hide-when-js-enabled" >Instance details</summary ><tr ><td class="src clearfix" > (</tr ><tr ><td colspan="2" - ><details id="i:id:Product:MonadFix:13" + ><details id="i:id:Product:MonadFix:14" ><summary class="hide-when-js-enabled" >Instance details</summary ><tr ><td class="src clearfix" > (</tr ><tr ><td colspan="2" - ><details id="i:id:Product:MonadZip:14" + ><details id="i:id:Product:MonadZip:15" ><summary class="hide-when-js-enabled" >Instance details</summary ><tr ><td class="src clearfix" > (</tr ><tr ><td colspan="2" - ><details id="i:id:Product:Foldable:15" + ><details id="i:id:Product:Foldable:16" ><summary class="hide-when-js-enabled" >Instance details</summary ><tr ><td class="src clearfix" > (</tr ><tr ><td colspan="2" - ><details id="i:id:Product:Traversable:16" + ><details id="i:id:Product:Traversable:17" ><summary class="hide-when-js-enabled" >Instance details</summary ><tr ><td class="src clearfix" > (<a href="#" title="Control.DeepSeq" + >NFData</a + > (f a), <a href="#" title="Control.DeepSeq" + >NFData</a + > (g a)) => <a href="#" title="Control.DeepSeq" + >NFData</a + > (<a href="#" title="Bug1004" + >Product</a + > f g a) <a href="#" class="selflink" + >#</a + ></td + ><td class="doc" + >Note: in <code class="inline-code" + >deepseq-1.5.0.0</code + > this instance's superclasses were changed.Since: deepseq-1.4.3.0</td + ></tr + ><tr + ><td colspan="2" + ><details id="i:id:Product:NFData:18" + ><summary class="hide-when-js-enabled" + >Instance details</summary + >Defined in <a href="#" + >Control.DeepSeq</a + > <div class="subs methods" + >Methods<a href="#" + >rnf</a + > :: <a href="#" title="Bug1004" + >Product</a + > f g a -> () <a href="#" class="selflink" + >#</a + ></div + ></details + ></td + ></tr + ><tr + ><td class="src clearfix" + > (</tr ><tr ><td colspan="2" - ><details id="i:id:Product:Monoid:17" + ><details id="i:id:Product:Monoid:19" ><summary class="hide-when-js-enabled" >Instance details</summary ><tr ><td class="src clearfix" > (</tr ><tr ><td colspan="2" - ><details id="i:id:Product:Semigroup:18" + ><details id="i:id:Product:Semigroup:20" ><summary class="hide-when-js-enabled" >Instance details</summary ><tr ><td class="src clearfix" > (</tr ><tr ><td colspan="2" - ><details id="i:id:Product:Eq:19" + ><details id="i:id:Product:Eq:21" ><summary class="hide-when-js-enabled" >Instance details</summary ><tr ><td class="src clearfix" > (</tr ><tr ><td colspan="2" - ><details id="i:id:Product:Ord:20" + ><details id="i:id:Product:Ord:22" ><summary class="hide-when-js-enabled" >Instance details</summary ><tr ><td class="src clearfix" > (</tr ><tr ><td colspan="2" - ><details id="i:id:Product:Data:21" + ><details id="i:id:Product:Data:23" ><summary class="hide-when-js-enabled" >Instance details</summary ><tr ><td class="src clearfix" > <a href="#" title="GHC.Generics" >Generic</a @@ -2308,7 +2420,7 @@ ></tr ><tr ><td colspan="2" - ><details id="i:id:Product:Generic:22" + ><details id="i:id:Product:Generic:24" ><summary class="hide-when-js-enabled" >Instance details</summary ><tr ><td class="src clearfix" > (</tr ><tr ><td colspan="2" - ><details id="i:id:Product:Read:23" + ><details id="i:id:Product:Read:25" ><summary class="hide-when-js-enabled" >Instance details</summary ><tr ><td class="src clearfix" > (</tr ><tr ><td colspan="2" - ><details id="i:id:Product:Show:24" + ><details id="i:id:Product:Show:26" ><summary class="hide-when-js-enabled" >Instance details</summary ><tr ><td class="src clearfix" > type</tr ><tr ><td colspan="2" - ><details id="i:id:Product:Rep1:25" + ><details id="i:id:Product:Rep1:27" ><summary class="hide-when-js-enabled" >Instance details</summary ><tr ><td class="src clearfix" > type</tr ><tr ><td colspan="2" - ><details id="i:id:Product:Rep:26" + ><details id="i:id:Product:Rep:28" ><summary class="hide-when-js-enabled" >Instance details</summary ><p View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a26243fde4680271712a3d774e17f6c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a26243fde4680271712a3d774e17f6c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Consider `PromotedDataCon` in `tyConStupidTheta`
by Marge Bot (＠marge-bot) 08 Jul '25

08 Jul '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 8d33d048 by Berk Özkütük at 2025-07-07T20:42:20-04:00 Consider `PromotedDataCon` in `tyConStupidTheta` Haddock checks data declarations for the stupid theta so as not to pretty-print them as empty contexts. Type data declarations end up as `PromotedDataCon`s by the time Haddock performs this check, causing a panic. This commit extends `tyConStupidTheta` so that it returns an empty list for `PromotedDataCon`s. This decision was guided by the fact that type data declarations never have data type contexts (see (R1) in Note [Type data declarations]). Fixes #25739. - - - - - 3 changed files: - compiler/GHC/Core/TyCon.hs - + utils/haddock/html-test/ref/Bug25739.html - + utils/haddock/html-test/src/Bug25739.hs Changes: ===================================== compiler/GHC/Core/TyCon.hs ===================================== @@ -2709,6 +2709,7 @@ tyConStupidTheta :: TyCon -> [PredType] tyConStupidTheta tc@(TyCon { tyConDetails = details }) | AlgTyCon {algTcStupidTheta = stupid} <- details = stupid | PrimTyCon {} <- details = [] + | PromotedDataCon {} <- details = [] | otherwise = pprPanic "tyConStupidTheta" (ppr tc) -- | Extract the 'TyVar's bound by a vanilla type synonym ===================================== utils/haddock/html-test/ref/Bug25739.html ===================================== @@ -0,0 +1,62 @@ +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><meta name="viewport" content="width=device-width, initial-scale=1" + /><title + >Bug25739</title + ><link href="#" rel="stylesheet" type="text/css" title="Linuwial" + /><link rel="stylesheet" type="text/css" href="#" + /><link rel="stylesheet" type="text/css" href="#" + /><script src="haddock-bundle.min.js" async="async" type="text/javascript" + ></script + ><script type="text/x-mathjax-config" + >MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script + ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-…" type="text/javascript" + ></script + ></head + ><body + ><div id="package-header" + > <ul class="links" id="page-menu" + ><li + ><a href="#" + >Contents</a + ></li + ><li + ><a href="#" + >Index</a + ></li + ></ul + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + >Bug25739</div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + >data <a id="t:Bar" class="def" + >Bar</a + > :: Foo <a href="#" class="selflink" + >#</a + ></div + ></div + ></div + ></body + ></html +> ===================================== utils/haddock/html-test/src/Bug25739.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeData #-} + +module Bug25739 (Bar) where + +type data Foo = Bar View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8d33d048dbe159a045a4c304fa92318… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8d33d048dbe159a045a4c304fa92318… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sol/add-rendered-to-json-diagnostics] Include the rendered message in -fdiagnostics-as-json output
by Simon Hengel (＠sol) 07 Jul '25

07 Jul '25

Simon Hengel pushed to branch wip/sol/add-rendered-to-json-diagnostics at Glasgow Haskell Compiler / GHC Commits: b6faffd9 by Simon Hengel at 2025-07-08T06:17:49+07:00 Include the rendered message in -fdiagnostics-as-json output This implements #26173. - - - - - 8 changed files: - compiler/GHC/Driver/Errors.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Utils/Logger.hs - docs/users_guide/9.14.1-notes.rst - + docs/users_guide/diagnostics-as-json-schema-1_2.json - docs/users_guide/using.rst - testsuite/tests/driver/json.stderr - testsuite/tests/driver/json_warn.stderr Changes: ===================================== compiler/GHC/Driver/Errors.hs ===================================== @@ -10,6 +10,7 @@ import GHC.Prelude import GHC.Types.SrcLoc (SrcSpan) import GHC.Types.SourceError import GHC.Types.Error +import GHC.Utils.Json import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Logger @@ -22,9 +23,22 @@ printMessages logger msg_opts opts = mapM_ printMessage . sortMessages printMessage :: MsgEnvelope a -> IO () printMessage message - | log_diags_as_json = logJsonMsg logger messageClass message + | log_diags_as_json = do + decorated <- decorateDiagnostic logflags messageClass location doc + let + rendered :: String + rendered = renderWithContext (log_default_user_context logflags) decorated + + jsonMessage :: JsonDoc + jsonMessage = jsonDiagnostic rendered message + + logJsonMsg logger messageClass jsonMessage + | otherwise = logMsg logger messageClass location doc where + logflags :: LogFlags + logflags = logFlags logger + doc :: SDoc doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic) ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -73,6 +73,9 @@ module GHC.Types.Error , mkLocMessage , mkLocMessageWarningGroups , getCaretDiagnostic + + , jsonDiagnostic + -- * Queries , isIntrinsicErrorMessage , isExtrinsicErrorMessage @@ -109,7 +112,7 @@ import GHC.Utils.Panic import GHC.Version (cProjectVersion) import Data.Bifunctor -import Data.Foldable ( fold, toList ) +import Data.Foldable import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE import Data.List ( intercalate ) @@ -171,9 +174,6 @@ instance Diagnostic e => Outputable (Messages e) where pprDiagnostic (errMsgDiagnostic envelope) ] -instance (Diagnostic e) => ToJson (Messages e) where - json msgs = JSArray . toList $ json <$> getMessages msgs - {- Note [Discarding Messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -573,7 +573,7 @@ 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_1.json. +specified in docs/users_guide/diagnostics-as-json-schema-1_2.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). @@ -586,15 +586,17 @@ https://json-schema.org -} schemaVersion :: String -schemaVersion = "1.1" +schemaVersion = "1.2" + -- See Note [Diagnostic Message JSON Schema] before editing! -instance Diagnostic e => ToJson (MsgEnvelope e) where - json m = JSObject $ [ +jsonDiagnostic :: forall e. Diagnostic e => String -> MsgEnvelope e -> JsonDoc +jsonDiagnostic rendered m = JSObject $ [ ("version", JSString schemaVersion), ("ghcVersion", JSString $ "ghc-" ++ cProjectVersion), ("span", json $ errMsgSpan m), ("severity", json $ errMsgSeverity m), ("code", maybe JSNull json (diagnosticCode diag)), + ("rendered", JSString rendered), ("message", JSArray $ map renderToJSString diagMsg), ("hints", JSArray $ map (renderToJSString . ppr) (diagnosticHints diag) ) ] ++ [ ("reason", reasonJson) ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -62,6 +62,8 @@ module GHC.Utils.Logger , logJsonMsg , logDumpMsg + , decorateDiagnostic + -- * Dumping , defaultDumpAction , putDumpFile @@ -419,7 +421,7 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg MCInfo -> printErrs msg MCFatal -> printErrs msg MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message - MCDiagnostic _sev _rea _code -> printDiagnostics + MCDiagnostic _sev _rea _code -> decorateDiagnostic logflags msg_class srcSpan msg >>= printErrs where printOut :: SDoc -> IO () printOut = defaultLogActionHPrintDoc logflags False out @@ -430,23 +432,54 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg putStrSDoc :: SDoc -> IO () putStrSDoc = defaultLogActionHPutStrDoc logflags False out +-- This function is used by `defaultLogActionWithHandles` for non-JSON output, +-- and also by `GHC.Driver.Errors.printMessages` to produce the `rendered` +-- message on `-fdiagnostics-as-json`. +-- +-- We would want to eventually consolidate this. However, this is currently +-- not feasible for the following reasons: +-- +-- 1. Some parts of the compiler sidestep `printMessages`, for that reason we +-- can not decorate the message in `printMessages`. +-- +-- 2. GHC uses two different code paths for JSON and non-JSON diagnostics. For +-- that reason we can not decorate the message in `defaultLogActionWithHandles`. +-- +-- See also Note [JSON Error Messages]: +-- +-- `jsonLogAction` should be removed along with -ddump-json +-- +-- Also note that (1) is the reason why some parts of the compiler produce +-- diagnostics that don't respect `-fdiagnostics-as-json`. +-- +-- The plan as I see it is as follows: +-- +-- 1. Refactor all places in the compiler that report diagnostics to go +-- through `GHC.Driver.Errors.printMessages`. +-- +-- (It's easy to find all those places by looking for who creates +-- MCDiagnostic, either directly or via `mkMCDiagnostic` or +-- `errorDiagnostic`.) +-- +-- 2. Get rid of `-ddump-json`, `jsonLogAction` and consolidate message +-- decoration at one place (either `printMessages` or +-- `defaultLogActionWithHandles`) +-- +decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc +decorateDiagnostic logflags msg_class srcSpan msg = addCaret + where -- Pretty print the warning flag, if any (#10752) message :: SDoc message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg - printDiagnostics :: IO () - printDiagnostics = do + addCaret = do caretDiagnostic <- if log_show_caret logflags then getCaretDiagnostic msg_class srcSpan else pure empty - printErrs $ getPprStyle $ \style -> + return $ getPprStyle $ \style -> withPprStyle (setStyleColoured True style) (message $+$ caretDiagnostic $+$ blankLine) - -- careful (#2302): printErrs prints in UTF-8, - -- whereas converting to string first and using - -- hPutStr would just emit the low 8 bits of - -- each unicode char. -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO () @@ -611,8 +644,8 @@ defaultTraceAction logflags title doc x = logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO () logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg -logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO () -logJsonMsg logger mc d = putJsonLogMsg logger (logFlags logger) mc (json d) +logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO () +logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc -- | Dump something logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () ===================================== docs/users_guide/9.14.1-notes.rst ===================================== @@ -143,6 +143,11 @@ Compiler were accessed using the generated record selector functions, marking the fields as covered in coverage reports (:ghc-ticket:`17834`). +- JSON diagnostics produced with (:ghc-flag:`-fdiagnostics-as-json`) now + include the `rendered` diagnostics message, in the exact same format as what + GHC would have produced without -fdiagnostics-as-json (including ANSI escape + sequences). + GHCi ~~~~ ===================================== docs/users_guide/diagnostics-as-json-schema-1_2.json ===================================== @@ -0,0 +1,144 @@ +{ + "$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": { + "oneOf": [ + { "$ref": "#/$defs/span" }, + { "type": "null" } + ] + }, + "severity": { + "description": "The diagnostic severity", + "type": "string", + "enum": [ + "Warning", + "Error" + ] + }, + "code": { + "description": "The diagnostic code (if it exists)", + "type": [ + "integer", + "null" + ] + }, + "rendered": { + "description": "The rendered diagnostics message, in the exact same format as what GHC would have produced without -fdiagnostics-as-json (including ANSI escape sequences)", + "type": "string" + }, + "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"] + } + ] + } + }, + + "$comment": "NOTE: \"rendered\" is not a required field so that the schema is backward compatible with version 1.1. If you bump the schema version to 2.0 the please also add \"rendered\" to the \"required\" fields.", + "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 ===================================== @@ -1428,7 +1428,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_1.json>`. + The schema can be downloaded :download:`here <diagnostics-as-json-schema-1_2.json>`. .. ghc-flag:: -fdiagnostics-color=⟨always|auto|never⟩ :shortdesc: Use colors in error messages ===================================== testsuite/tests/driver/json.stderr ===================================== @@ -1 +1 @@ -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","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 \u2018EmptyCase\u2019 extension"]} +{"rendered":"json.hs:9:11: error: [GHC-48010]\n Empty list of alternatives in case expression\n Suggested fix:\n Perhaps you intended to use the \u2018EmptyCase\u2019 extension\n","version":"1.1","ghcVersion":"ghc-9.13.20250627","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 \u2018EmptyCase\u2019 extension"]} ===================================== testsuite/tests/driver/json_warn.stderr ===================================== @@ -1,2 +1,2 @@ -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}} -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of \u2018head\u2019\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"}} +{"rendered":"json_warn.hs:4:3: warning: [GHC-40910] [-Wunused-matches (in -Wextra)]\n Defined but not used: \u2018x\u2019\n","version":"1.1","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}} +{"rendered":"json_warn.hs:7:5: warning: [GHC-63394] [-Wx-partial (in -Wextended-warnings)]\n In the use of \u2018head\u2019\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\".\"\n","version":"1.1","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of \u2018head\u2019\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/-/commit/b6faffd926261a0aec63185d46374d6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b6faffd926261a0aec63185d46374d6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sol/add-rendered-to-json-diagnostics] Include the rendered message in -fdiagnostics-as-json output
by Simon Hengel (＠sol) 07 Jul '25

07 Jul '25

Simon Hengel pushed to branch wip/sol/add-rendered-to-json-diagnostics at Glasgow Haskell Compiler / GHC Commits: d6d134c2 by Simon Hengel at 2025-07-08T06:16:16+07:00 Include the rendered message in -fdiagnostics-as-json output This implements #26173. - - - - - 8 changed files: - compiler/GHC/Driver/Errors.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Utils/Logger.hs - docs/users_guide/9.14.1-notes.rst - + docs/users_guide/diagnostics-as-json-schema-1_2.json - docs/users_guide/using.rst - testsuite/tests/driver/json.stderr - testsuite/tests/driver/json_warn.stderr Changes: ===================================== compiler/GHC/Driver/Errors.hs ===================================== @@ -10,6 +10,7 @@ import GHC.Prelude import GHC.Types.SrcLoc (SrcSpan) import GHC.Types.SourceError import GHC.Types.Error +import GHC.Utils.Json import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Logger @@ -22,9 +23,22 @@ printMessages logger msg_opts opts = mapM_ printMessage . sortMessages printMessage :: MsgEnvelope a -> IO () printMessage message - | log_diags_as_json = logJsonMsg logger messageClass message + | log_diags_as_json = do + decorated <- decorateDiagnostic logflags messageClass location doc + let + rendered :: String + rendered = renderWithContext (log_default_user_context logflags) decorated + + jsonMessage :: JsonDoc + jsonMessage = jsonDiagnostic rendered message + + logJsonMsg logger messageClass jsonMessage + | otherwise = logMsg logger messageClass location doc where + logflags :: LogFlags + logflags = logFlags logger + doc :: SDoc doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic) ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -73,6 +73,9 @@ module GHC.Types.Error , mkLocMessage , mkLocMessageWarningGroups , getCaretDiagnostic + + , jsonDiagnostic + -- * Queries , isIntrinsicErrorMessage , isExtrinsicErrorMessage @@ -109,7 +112,7 @@ import GHC.Utils.Panic import GHC.Version (cProjectVersion) import Data.Bifunctor -import Data.Foldable ( fold, toList ) +import Data.Foldable import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE import Data.List ( intercalate ) @@ -171,9 +174,6 @@ instance Diagnostic e => Outputable (Messages e) where pprDiagnostic (errMsgDiagnostic envelope) ] -instance (Diagnostic e) => ToJson (Messages e) where - json msgs = JSArray . toList $ json <$> getMessages msgs - {- Note [Discarding Messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -573,7 +573,7 @@ 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_1.json. +specified in docs/users_guide/diagnostics-as-json-schema-1_2.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). @@ -586,15 +586,17 @@ https://json-schema.org -} schemaVersion :: String -schemaVersion = "1.1" +schemaVersion = "1.2" + -- See Note [Diagnostic Message JSON Schema] before editing! -instance Diagnostic e => ToJson (MsgEnvelope e) where - json m = JSObject $ [ +jsonDiagnostic :: forall e. Diagnostic e => String -> MsgEnvelope e -> JsonDoc +jsonDiagnostic rendered m = JSObject $ [ ("version", JSString schemaVersion), ("ghcVersion", JSString $ "ghc-" ++ cProjectVersion), ("span", json $ errMsgSpan m), ("severity", json $ errMsgSeverity m), ("code", maybe JSNull json (diagnosticCode diag)), + ("rendered", JSString rendered), ("message", JSArray $ map renderToJSString diagMsg), ("hints", JSArray $ map (renderToJSString . ppr) (diagnosticHints diag) ) ] ++ [ ("reason", reasonJson) ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -62,6 +62,8 @@ module GHC.Utils.Logger , logJsonMsg , logDumpMsg + , decorateDiagnostic + -- * Dumping , defaultDumpAction , putDumpFile @@ -419,7 +421,7 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg MCInfo -> printErrs msg MCFatal -> printErrs msg MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message - MCDiagnostic _sev _rea _code -> printDiagnostics + MCDiagnostic _sev _rea _code -> decorateDiagnostic logflags msg_class srcSpan msg >>= printErrs where printOut :: SDoc -> IO () printOut = defaultLogActionHPrintDoc logflags False out @@ -430,23 +432,55 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg putStrSDoc :: SDoc -> IO () putStrSDoc = defaultLogActionHPutStrDoc logflags False out +-- This function is used by `defaultLogActionWithHandles` for non-JSON output, +-- and also by `GHC.Driver.Errors.printMessages` to produce the `rendered` +-- message on `-fdiagnostics-as-json`. +-- +-- We would want to eventually consolidate this. However, this is currently +-- not feasible for the following reasons: +-- +-- 1. Some parts of the compiler sidestep `printMessages`, for that reason we +-- can not decorate the message in `printMessages`. +-- +-- 2. GHC uses two different code paths for JSON and non-JSON diagnostics. For +-- that reason we can not decorate the message in +-- `defaultLogActionWithHandles`. +-- +-- See also Note [JSON Error Messages]: +-- +-- `jsonLogAction` should be removed along with -ddump-json +-- +-- Also note that (1) is the reason why some parts of the compiler produce +-- diagnostics that don't respect `-fdiagnostics-as-json`. +-- +-- The plan as I see it is as follows: +-- +-- 1. Refactor all places in the compiler that report diagnostics to go +-- through `GHC.Driver.Errors.printMessages`. +-- +-- (It's easy to find all those places by looking for who creates +-- MCDiagnostic, either directly or via `mkMCDiagnostic` or +-- `errorDiagnostic`.) +-- +-- 2. Get rid of `-ddump-json`, `jsonLogAction` and consolidate message +-- decoration at one place (either `printMessages` or +-- `defaultLogActionWithHandles`) +-- +decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc +decorateDiagnostic logflags msg_class srcSpan msg = addCaret + where -- Pretty print the warning flag, if any (#10752) message :: SDoc message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg - printDiagnostics :: IO () - printDiagnostics = do + addCaret = do caretDiagnostic <- if log_show_caret logflags then getCaretDiagnostic msg_class srcSpan else pure empty - printErrs $ getPprStyle $ \style -> + return $ getPprStyle $ \style -> withPprStyle (setStyleColoured True style) (message $+$ caretDiagnostic $+$ blankLine) - -- careful (#2302): printErrs prints in UTF-8, - -- whereas converting to string first and using - -- hPutStr would just emit the low 8 bits of - -- each unicode char. -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO () @@ -611,8 +645,8 @@ defaultTraceAction logflags title doc x = logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO () logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg -logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO () -logJsonMsg logger mc d = putJsonLogMsg logger (logFlags logger) mc (json d) +logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO () +logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc -- | Dump something logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () ===================================== docs/users_guide/9.14.1-notes.rst ===================================== @@ -143,6 +143,11 @@ Compiler were accessed using the generated record selector functions, marking the fields as covered in coverage reports (:ghc-ticket:`17834`). +- JSON diagnostics produced with (:ghc-flag:`-fdiagnostics-as-json`) now + include the `rendered` diagnostics message, in the exact same format as what + GHC would have produced without -fdiagnostics-as-json (including ANSI escape + sequences). + GHCi ~~~~ ===================================== docs/users_guide/diagnostics-as-json-schema-1_2.json ===================================== @@ -0,0 +1,144 @@ +{ + "$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": { + "oneOf": [ + { "$ref": "#/$defs/span" }, + { "type": "null" } + ] + }, + "severity": { + "description": "The diagnostic severity", + "type": "string", + "enum": [ + "Warning", + "Error" + ] + }, + "code": { + "description": "The diagnostic code (if it exists)", + "type": [ + "integer", + "null" + ] + }, + "rendered": { + "description": "The rendered diagnostics message, in the exact same format as what GHC would have produced without -fdiagnostics-as-json (including ANSI escape sequences)", + "type": "string" + }, + "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"] + } + ] + } + }, + + "$comment": "NOTE: \"rendered\" is not a required field so that the schema is backward compatible with version 1.1. If you bump the schema version to 2.0 the please also add \"rendered\" to the \"required\" fields.", + "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 ===================================== @@ -1428,7 +1428,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_1.json>`. + The schema can be downloaded :download:`here <diagnostics-as-json-schema-1_2.json>`. .. ghc-flag:: -fdiagnostics-color=⟨always|auto|never⟩ :shortdesc: Use colors in error messages ===================================== testsuite/tests/driver/json.stderr ===================================== @@ -1 +1 @@ -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","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 \u2018EmptyCase\u2019 extension"]} +{"rendered":"json.hs:9:11: error: [GHC-48010]\n Empty list of alternatives in case expression\n Suggested fix:\n Perhaps you intended to use the \u2018EmptyCase\u2019 extension\n","version":"1.1","ghcVersion":"ghc-9.13.20250627","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 \u2018EmptyCase\u2019 extension"]} ===================================== testsuite/tests/driver/json_warn.stderr ===================================== @@ -1,2 +1,2 @@ -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}} -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of \u2018head\u2019\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"}} +{"rendered":"json_warn.hs:4:3: warning: [GHC-40910] [-Wunused-matches (in -Wextra)]\n Defined but not used: \u2018x\u2019\n","version":"1.1","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}} +{"rendered":"json_warn.hs:7:5: warning: [GHC-63394] [-Wx-partial (in -Wextended-warnings)]\n In the use of \u2018head\u2019\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\".\"\n","version":"1.1","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of \u2018head\u2019\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/-/commit/d6d134c29ca4219e68cc58066429964… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d6d134c29ca4219e68cc58066429964… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sol/add-rendered-to-json-diagnostics] Include the rendered message in -fdiagnostics-as-json output
by Simon Hengel (＠sol) 07 Jul '25

07 Jul '25

Simon Hengel pushed to branch wip/sol/add-rendered-to-json-diagnostics at Glasgow Haskell Compiler / GHC Commits: 537157a8 by Simon Hengel at 2025-07-08T06:13:32+07:00 Include the rendered message in -fdiagnostics-as-json output This implements #26173. - - - - - 8 changed files: - compiler/GHC/Driver/Errors.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Utils/Logger.hs - docs/users_guide/9.14.1-notes.rst - + docs/users_guide/diagnostics-as-json-schema-1_2.json - docs/users_guide/using.rst - testsuite/tests/driver/json.stderr - testsuite/tests/driver/json_warn.stderr Changes: ===================================== compiler/GHC/Driver/Errors.hs ===================================== @@ -10,6 +10,7 @@ import GHC.Prelude import GHC.Types.SrcLoc (SrcSpan) import GHC.Types.SourceError import GHC.Types.Error +import GHC.Utils.Json import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Logger @@ -22,9 +23,22 @@ printMessages logger msg_opts opts = mapM_ printMessage . sortMessages printMessage :: MsgEnvelope a -> IO () printMessage message - | log_diags_as_json = logJsonMsg logger messageClass message + | log_diags_as_json = do + decorated <- decorateDiagnostic logflags messageClass location doc + let + rendered :: String + rendered = renderWithContext (log_default_user_context logflags) decorated + + jsonMessage :: JsonDoc + jsonMessage = jsonDiagnostic rendered message + + logJsonMsg logger messageClass jsonMessage + | otherwise = logMsg logger messageClass location doc where + logflags :: LogFlags + logflags = logFlags logger + doc :: SDoc doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic) ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -73,6 +73,9 @@ module GHC.Types.Error , mkLocMessage , mkLocMessageWarningGroups , getCaretDiagnostic + + , jsonDiagnostic + -- * Queries , isIntrinsicErrorMessage , isExtrinsicErrorMessage @@ -109,7 +112,7 @@ import GHC.Utils.Panic import GHC.Version (cProjectVersion) import Data.Bifunctor -import Data.Foldable ( fold, toList ) +import Data.Foldable import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE import Data.List ( intercalate ) @@ -171,9 +174,6 @@ instance Diagnostic e => Outputable (Messages e) where pprDiagnostic (errMsgDiagnostic envelope) ] -instance (Diagnostic e) => ToJson (Messages e) where - json msgs = JSArray . toList $ json <$> getMessages msgs - {- Note [Discarding Messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -573,7 +573,7 @@ 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_1.json. +specified in docs/users_guide/diagnostics-as-json-schema-1_2.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). @@ -586,15 +586,17 @@ https://json-schema.org -} schemaVersion :: String -schemaVersion = "1.1" +schemaVersion = "1.2" + -- See Note [Diagnostic Message JSON Schema] before editing! -instance Diagnostic e => ToJson (MsgEnvelope e) where - json m = JSObject $ [ +jsonDiagnostic :: forall e. Diagnostic e => String -> MsgEnvelope e -> JsonDoc +jsonDiagnostic rendered m = JSObject $ [ ("version", JSString schemaVersion), ("ghcVersion", JSString $ "ghc-" ++ cProjectVersion), ("span", json $ errMsgSpan m), ("severity", json $ errMsgSeverity m), ("code", maybe JSNull json (diagnosticCode diag)), + ("rendered", JSString rendered), ("message", JSArray $ map renderToJSString diagMsg), ("hints", JSArray $ map (renderToJSString . ppr) (diagnosticHints diag) ) ] ++ [ ("reason", reasonJson) ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -62,6 +62,8 @@ module GHC.Utils.Logger , logJsonMsg , logDumpMsg + , decorateDiagnostic + -- * Dumping , defaultDumpAction , putDumpFile @@ -419,7 +421,7 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg MCInfo -> printErrs msg MCFatal -> printErrs msg MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message - MCDiagnostic _sev _rea _code -> printDiagnostics + MCDiagnostic _sev _rea _code -> decorateDiagnostic logflags msg_class srcSpan msg >>= printErrs where printOut :: SDoc -> IO () printOut = defaultLogActionHPrintDoc logflags False out @@ -430,23 +432,54 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg putStrSDoc :: SDoc -> IO () putStrSDoc = defaultLogActionHPutStrDoc logflags False out +-- This function is used by `defaultLogActionWithHandles` for non-JSON output, +-- and also by `GHC.Driver.Errors.printMessages` to produce the `rendered` +-- message on `-fdiagnostics-as-json`. +-- +-- We would want to eventually consolidate this. However, this is currently +-- not feasible for the following reasons: +-- +-- 1. Some parts of the compiler sidestep `printMessages`, for that reason we +-- can not decorate the message in `printMessages`. +-- +-- 2. GHC uses two different code paths for JSON and non-JSON diagnostics. For +-- that reason we can decorate the message in `defaultLogActionWithHandles`. +-- +-- See also Note [JSON Error Messages]: +-- +-- `jsonLogAction` should be removed along with -ddump-json +-- +-- Also note that (1) is the reason why some parts of the compiler produce +-- diagnostics that don't respect `-fdiagnostics-as-json`. +-- +-- The plan as I see it is as follows: +-- +-- 1. Refactor all places in the compiler that report diagnostics to go +-- through `GHC.Driver.Errors.printMessages`. +-- +-- (It's easy to find all those places by looking for who creates +-- MCDiagnostic, either directly or via `mkMCDiagnostic` or +-- `errorDiagnostic`.) +-- +-- 2. Get rid of `-ddump-json`, `jsonLogAction` and consolidate message +-- decoration at one place (either `printMessages` or +-- `defaultLogActionWithHandles`) +-- +decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc +decorateDiagnostic logflags msg_class srcSpan msg = addCaret + where -- Pretty print the warning flag, if any (#10752) message :: SDoc message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg - printDiagnostics :: IO () - printDiagnostics = do + addCaret = do caretDiagnostic <- if log_show_caret logflags then getCaretDiagnostic msg_class srcSpan else pure empty - printErrs $ getPprStyle $ \style -> + return $ getPprStyle $ \style -> withPprStyle (setStyleColoured True style) (message $+$ caretDiagnostic $+$ blankLine) - -- careful (#2302): printErrs prints in UTF-8, - -- whereas converting to string first and using - -- hPutStr would just emit the low 8 bits of - -- each unicode char. -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO () @@ -611,8 +644,8 @@ defaultTraceAction logflags title doc x = logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO () logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg -logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO () -logJsonMsg logger mc d = putJsonLogMsg logger (logFlags logger) mc (json d) +logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO () +logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc -- | Dump something logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () ===================================== docs/users_guide/9.14.1-notes.rst ===================================== @@ -143,6 +143,11 @@ Compiler were accessed using the generated record selector functions, marking the fields as covered in coverage reports (:ghc-ticket:`17834`). +- JSON diagnostics produced with (:ghc-flag:`-fdiagnostics-as-json`) now + include the `rendered` diagnostics message, in the exact same format as what + GHC would have produced without -fdiagnostics-as-json (including ANSI escape + sequences). + GHCi ~~~~ ===================================== docs/users_guide/diagnostics-as-json-schema-1_2.json ===================================== @@ -0,0 +1,144 @@ +{ + "$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": { + "oneOf": [ + { "$ref": "#/$defs/span" }, + { "type": "null" } + ] + }, + "severity": { + "description": "The diagnostic severity", + "type": "string", + "enum": [ + "Warning", + "Error" + ] + }, + "code": { + "description": "The diagnostic code (if it exists)", + "type": [ + "integer", + "null" + ] + }, + "rendered": { + "description": "The rendered diagnostics message, in the exact same format as what GHC would have produced without -fdiagnostics-as-json (including ANSI escape sequences)", + "type": "string" + }, + "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"] + } + ] + } + }, + + "$comment": "NOTE: \"rendered\" is not a required field so that the schema is backward compatible with version 1.1. If you bump the schema version to 2.0 the please also add \"rendered\" to the \"required\" fields.", + "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 ===================================== @@ -1428,7 +1428,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_1.json>`. + The schema can be downloaded :download:`here <diagnostics-as-json-schema-1_2.json>`. .. ghc-flag:: -fdiagnostics-color=⟨always|auto|never⟩ :shortdesc: Use colors in error messages ===================================== testsuite/tests/driver/json.stderr ===================================== @@ -1 +1 @@ -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","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 \u2018EmptyCase\u2019 extension"]} +{"rendered":"json.hs:9:11: error: [GHC-48010]\n Empty list of alternatives in case expression\n Suggested fix:\n Perhaps you intended to use the \u2018EmptyCase\u2019 extension\n","version":"1.1","ghcVersion":"ghc-9.13.20250627","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 \u2018EmptyCase\u2019 extension"]} ===================================== testsuite/tests/driver/json_warn.stderr ===================================== @@ -1,2 +1,2 @@ -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}} -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of \u2018head\u2019\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"}} +{"rendered":"json_warn.hs:4:3: warning: [GHC-40910] [-Wunused-matches (in -Wextra)]\n Defined but not used: \u2018x\u2019\n","version":"1.1","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}} +{"rendered":"json_warn.hs:7:5: warning: [GHC-63394] [-Wx-partial (in -Wextended-warnings)]\n In the use of \u2018head\u2019\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\".\"\n","version":"1.1","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of \u2018head\u2019\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/-/commit/537157a8f85761eabc7add9fb952fb7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/537157a8f85761eabc7add9fb952fb7… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sol/add-rendered-to-json-diagnostics] Include the rendered message in -fdiagnostics-as-json output
by Simon Hengel (＠sol) 07 Jul '25

07 Jul '25

Simon Hengel pushed to branch wip/sol/add-rendered-to-json-diagnostics at Glasgow Haskell Compiler / GHC Commits: 10b58800 by Simon Hengel at 2025-07-08T06:09:17+07:00 Include the rendered message in -fdiagnostics-as-json output This implements #26173. - - - - - 8 changed files: - compiler/GHC/Driver/Errors.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Utils/Logger.hs - docs/users_guide/9.14.1-notes.rst - + docs/users_guide/diagnostics-as-json-schema-1_2.json - docs/users_guide/using.rst - testsuite/tests/driver/json.stderr - testsuite/tests/driver/json_warn.stderr Changes: ===================================== compiler/GHC/Driver/Errors.hs ===================================== @@ -10,6 +10,7 @@ import GHC.Prelude import GHC.Types.SrcLoc (SrcSpan) import GHC.Types.SourceError import GHC.Types.Error +import GHC.Utils.Json import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Logger @@ -22,9 +23,22 @@ printMessages logger msg_opts opts = mapM_ printMessage . sortMessages printMessage :: MsgEnvelope a -> IO () printMessage message - | log_diags_as_json = logJsonMsg logger messageClass message + | log_diags_as_json = do + decorated <- decorateDiagnostic logflags messageClass location doc + let + rendered :: String + rendered = renderWithContext (log_default_user_context logflags) decorated + + jsonMessage :: JsonDoc + jsonMessage = jsonDiagnostic rendered message + + logJsonMsg logger messageClass jsonMessage + | otherwise = logMsg logger messageClass location doc where + logflags :: LogFlags + logflags = logFlags logger + doc :: SDoc doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic) ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -73,6 +73,9 @@ module GHC.Types.Error , mkLocMessage , mkLocMessageWarningGroups , getCaretDiagnostic + + , jsonDiagnostic + -- * Queries , isIntrinsicErrorMessage , isExtrinsicErrorMessage @@ -109,7 +112,7 @@ import GHC.Utils.Panic import GHC.Version (cProjectVersion) import Data.Bifunctor -import Data.Foldable ( fold, toList ) +import Data.Foldable import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE import Data.List ( intercalate ) @@ -171,9 +174,6 @@ instance Diagnostic e => Outputable (Messages e) where pprDiagnostic (errMsgDiagnostic envelope) ] -instance (Diagnostic e) => ToJson (Messages e) where - json msgs = JSArray . toList $ json <$> getMessages msgs - {- Note [Discarding Messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -573,7 +573,7 @@ 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_1.json. +specified in docs/users_guide/diagnostics-as-json-schema-1_2.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). @@ -586,15 +586,17 @@ https://json-schema.org -} schemaVersion :: String -schemaVersion = "1.1" +schemaVersion = "1.2" + -- See Note [Diagnostic Message JSON Schema] before editing! -instance Diagnostic e => ToJson (MsgEnvelope e) where - json m = JSObject $ [ +jsonDiagnostic :: forall e. Diagnostic e => String -> MsgEnvelope e -> JsonDoc +jsonDiagnostic rendered m = JSObject $ [ ("version", JSString schemaVersion), ("ghcVersion", JSString $ "ghc-" ++ cProjectVersion), ("span", json $ errMsgSpan m), ("severity", json $ errMsgSeverity m), ("code", maybe JSNull json (diagnosticCode diag)), + ("rendered", JSString rendered), ("message", JSArray $ map renderToJSString diagMsg), ("hints", JSArray $ map (renderToJSString . ppr) (diagnosticHints diag) ) ] ++ [ ("reason", reasonJson) ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -62,6 +62,8 @@ module GHC.Utils.Logger , logJsonMsg , logDumpMsg + , decorateDiagnostic + -- * Dumping , defaultDumpAction , putDumpFile @@ -419,7 +421,7 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg MCInfo -> printErrs msg MCFatal -> printErrs msg MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message - MCDiagnostic _sev _rea _code -> printDiagnostics + MCDiagnostic _sev _rea _code -> decorateDiagnostic logflags msg_class srcSpan msg >>= printErrs where printOut :: SDoc -> IO () printOut = defaultLogActionHPrintDoc logflags False out @@ -430,23 +432,55 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg putStrSDoc :: SDoc -> IO () putStrSDoc = defaultLogActionHPutStrDoc logflags False out +-- This function is used by `defaultLogActionWithHandles` for non-JSON output, +-- and also by `GHC.Driver.Errors.printMessages` to produce the `rendered` +-- message on `-fdiagnostics-as-json`. +-- +-- We would want to eventually consolidate this. However, this is currently +-- not feasible for the following reasons: +-- +-- 1. Some parts of the compiler sidestep `printMessages`, for that reason we +-- can not decorate (`decorateDiagnostic` + `defaultLogActionHPrintDoc`) the +-- message in `printMessages`. +-- +-- 2. GHC uses two different code paths for JSON and non-JSON diagnostics. For +-- that reason we can decorate the message in `defaultLogActionWithHandles`. +-- +-- See also Note [JSON Error Messages]: +-- +-- `jsonLogAction` should be removed along with -ddump-json +-- +-- Also note that (1) is the reason why some parts of the compiler produce +-- diagnostics that don't respect `-fdiagnostics-as-json`. +-- +-- The plan as I see it is as follows: +-- +-- 1. Refactor all places in the compiler that report diagnostics to go +-- through `GHC.Driver.Errors.printMessages`. +-- +-- (It's easy to find all those places by looking for who creates +-- MCDiagnostic, either directly or via `mkMCDiagnostic` or +-- `errorDiagnostic`.) +-- +-- 2. Get rid of `-ddump-json`, `jsonLogAction` and consolidate message +-- decoration at one place (either `printMessages` or +-- `defaultLogActionWithHandles`) +-- +decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc +decorateDiagnostic logflags msg_class srcSpan msg = addCaret + where -- Pretty print the warning flag, if any (#10752) message :: SDoc message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg - printDiagnostics :: IO () - printDiagnostics = do + addCaret = do caretDiagnostic <- if log_show_caret logflags then getCaretDiagnostic msg_class srcSpan else pure empty - printErrs $ getPprStyle $ \style -> + return $ getPprStyle $ \style -> withPprStyle (setStyleColoured True style) (message $+$ caretDiagnostic $+$ blankLine) - -- careful (#2302): printErrs prints in UTF-8, - -- whereas converting to string first and using - -- hPutStr would just emit the low 8 bits of - -- each unicode char. -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO () @@ -611,8 +645,8 @@ defaultTraceAction logflags title doc x = logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO () logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg -logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO () -logJsonMsg logger mc d = putJsonLogMsg logger (logFlags logger) mc (json d) +logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO () +logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc -- | Dump something logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () ===================================== docs/users_guide/9.14.1-notes.rst ===================================== @@ -143,6 +143,11 @@ Compiler were accessed using the generated record selector functions, marking the fields as covered in coverage reports (:ghc-ticket:`17834`). +- JSON diagnostics produced with (:ghc-flag:`-fdiagnostics-as-json`) now + include the `rendered` diagnostics message, in the exact same format as what + GHC would have produced without -fdiagnostics-as-json (including ANSI escape + sequences). + GHCi ~~~~ ===================================== docs/users_guide/diagnostics-as-json-schema-1_2.json ===================================== @@ -0,0 +1,144 @@ +{ + "$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": { + "oneOf": [ + { "$ref": "#/$defs/span" }, + { "type": "null" } + ] + }, + "severity": { + "description": "The diagnostic severity", + "type": "string", + "enum": [ + "Warning", + "Error" + ] + }, + "code": { + "description": "The diagnostic code (if it exists)", + "type": [ + "integer", + "null" + ] + }, + "rendered": { + "description": "The rendered diagnostics message, in the exact same format as what GHC would have produced without -fdiagnostics-as-json (including ANSI escape sequences)", + "type": "string" + }, + "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"] + } + ] + } + }, + + "$comment": "NOTE: \"rendered\" is not a required field so that the schema is backward compatible with version 1.1. If you bump the schema version to 2.0 the please also add \"rendered\" to the \"required\" fields.", + "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 ===================================== @@ -1428,7 +1428,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_1.json>`. + The schema can be downloaded :download:`here <diagnostics-as-json-schema-1_2.json>`. .. ghc-flag:: -fdiagnostics-color=⟨always|auto|never⟩ :shortdesc: Use colors in error messages ===================================== testsuite/tests/driver/json.stderr ===================================== @@ -1 +1 @@ -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","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 \u2018EmptyCase\u2019 extension"]} +{"rendered":"json.hs:9:11: error: [GHC-48010]\n Empty list of alternatives in case expression\n Suggested fix:\n Perhaps you intended to use the \u2018EmptyCase\u2019 extension\n","version":"1.1","ghcVersion":"ghc-9.13.20250627","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 \u2018EmptyCase\u2019 extension"]} ===================================== testsuite/tests/driver/json_warn.stderr ===================================== @@ -1,2 +1,2 @@ -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}} -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of \u2018head\u2019\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"}} +{"rendered":"json_warn.hs:4:3: warning: [GHC-40910] [-Wunused-matches (in -Wextra)]\n Defined but not used: \u2018x\u2019\n","version":"1.1","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}} +{"rendered":"json_warn.hs:7:5: warning: [GHC-63394] [-Wx-partial (in -Wextended-warnings)]\n In the use of \u2018head\u2019\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\".\"\n","version":"1.1","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of \u2018head\u2019\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/-/commit/10b58800f936e05fb8510ec10108809… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/10b58800f936e05fb8510ec10108809… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sol/add-rendered-to-json-diagnostics] Include the rendered message in -fdiagnostics-as-json output
by Simon Hengel (＠sol) 07 Jul '25

07 Jul '25

Simon Hengel pushed to branch wip/sol/add-rendered-to-json-diagnostics at Glasgow Haskell Compiler / GHC Commits: b8af31c5 by Simon Hengel at 2025-07-08T06:03:17+07:00 Include the rendered message in -fdiagnostics-as-json output This implements #26173. - - - - - 8 changed files: - compiler/GHC/Driver/Errors.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Utils/Logger.hs - docs/users_guide/9.14.1-notes.rst - + docs/users_guide/diagnostics-as-json-schema-1_2.json - docs/users_guide/using.rst - testsuite/tests/driver/json.stderr - testsuite/tests/driver/json_warn.stderr Changes: ===================================== compiler/GHC/Driver/Errors.hs ===================================== @@ -10,6 +10,7 @@ import GHC.Prelude import GHC.Types.SrcLoc (SrcSpan) import GHC.Types.SourceError import GHC.Types.Error +import GHC.Utils.Json import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Logger @@ -22,9 +23,22 @@ printMessages logger msg_opts opts = mapM_ printMessage . sortMessages printMessage :: MsgEnvelope a -> IO () printMessage message - | log_diags_as_json = logJsonMsg logger messageClass message + | log_diags_as_json = do + decorated <- decorateDiagnostic logflags messageClass location doc + let + rendered :: String + rendered = renderWithContext (log_default_user_context logflags) decorated + + jsonMessage :: JsonDoc + jsonMessage = jsonDiagnostic rendered message + + logJsonMsg logger messageClass jsonMessage + | otherwise = logMsg logger messageClass location doc where + logflags :: LogFlags + logflags = logFlags logger + doc :: SDoc doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic) ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -73,6 +73,9 @@ module GHC.Types.Error , mkLocMessage , mkLocMessageWarningGroups , getCaretDiagnostic + + , jsonDiagnostic + -- * Queries , isIntrinsicErrorMessage , isExtrinsicErrorMessage @@ -109,7 +112,7 @@ import GHC.Utils.Panic import GHC.Version (cProjectVersion) import Data.Bifunctor -import Data.Foldable ( fold, toList ) +import Data.Foldable import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE import Data.List ( intercalate ) @@ -171,9 +174,6 @@ instance Diagnostic e => Outputable (Messages e) where pprDiagnostic (errMsgDiagnostic envelope) ] -instance (Diagnostic e) => ToJson (Messages e) where - json msgs = JSArray . toList $ json <$> getMessages msgs - {- Note [Discarding Messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -573,7 +573,7 @@ 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_1.json. +specified in docs/users_guide/diagnostics-as-json-schema-1_2.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). @@ -586,15 +586,17 @@ https://json-schema.org -} schemaVersion :: String -schemaVersion = "1.1" +schemaVersion = "1.2" + -- See Note [Diagnostic Message JSON Schema] before editing! -instance Diagnostic e => ToJson (MsgEnvelope e) where - json m = JSObject $ [ +jsonDiagnostic :: forall e. Diagnostic e => String -> MsgEnvelope e -> JsonDoc +jsonDiagnostic rendered m = JSObject $ [ ("version", JSString schemaVersion), ("ghcVersion", JSString $ "ghc-" ++ cProjectVersion), ("span", json $ errMsgSpan m), ("severity", json $ errMsgSeverity m), ("code", maybe JSNull json (diagnosticCode diag)), + ("rendered", JSString rendered), ("message", JSArray $ map renderToJSString diagMsg), ("hints", JSArray $ map (renderToJSString . ppr) (diagnosticHints diag) ) ] ++ [ ("reason", reasonJson) ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -62,6 +62,8 @@ module GHC.Utils.Logger , logJsonMsg , logDumpMsg + , decorateDiagnostic + -- * Dumping , defaultDumpAction , putDumpFile @@ -419,7 +421,7 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg MCInfo -> printErrs msg MCFatal -> printErrs msg MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message - MCDiagnostic _sev _rea _code -> printDiagnostics + MCDiagnostic _sev _rea _code -> decorateDiagnostic logflags msg_class srcSpan msg >>= printErrs where printOut :: SDoc -> IO () printOut = defaultLogActionHPrintDoc logflags False out @@ -430,23 +432,55 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg putStrSDoc :: SDoc -> IO () putStrSDoc = defaultLogActionHPutStrDoc logflags False out +-- This function is used by `defaultLogActionWithHandles` for non-JSON output, +-- and also by `GHC.Driver.Errors.printMessages` to produce the `rendered` +-- message on `-fdiagnostics-as-json`. +-- +-- We would want to eventually consolidate this. However, this is currently +-- not feasible for the following reasons: +-- +-- 1. Some parts of the compiler sidestep `printMessages`, for that reason we +-- can not decorate (`decorateDiagnostic` + `defaultLogActionHPrintDoc`) the +-- message in `printMessages`. +-- +-- 2. GHC uses two different code paths for JSON and non-JSON diagnostics. For +-- that reason we can decorate the message in `defaultLogActionWithHandles`. +-- +-- See also Note [JSON Error Messages]: +-- +-- `jsonLogAction` should be removed along with -ddump-json +-- +-- Also note that (1) is the reason why some parts of the compiler produce +-- diagnostics that don't respect `-fdiagnostics-as-json`. +-- +-- The plan as I see it is as follows: +-- +-- 1. Refactor all places in the compiler that report diagnostics to go +-- through `GHC.Driver.Errors.printMessages`. +-- +-- (It's easy to find all those places by looking for who creates +-- MCDiagnostic, either directly or via `mkMCDiagnostic` or +-- `errorDiagnostic`.) +-- +-- 2. Get rid of `-ddump-json`, `jsonLogAction` and consolidate message +-- decoration at one place (either `printMessages` or +-- `defaultLogActionWithHandles`) +-- +decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc +decorateDiagnostic logflags msg_class srcSpan msg = addCaret + where -- Pretty print the warning flag, if any (#10752) message :: SDoc message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg - printDiagnostics :: IO () - printDiagnostics = do + addCaret = do caretDiagnostic <- if log_show_caret logflags then getCaretDiagnostic msg_class srcSpan else pure empty - printErrs $ getPprStyle $ \style -> + return $ getPprStyle $ \style -> withPprStyle (setStyleColoured True style) (message $+$ caretDiagnostic $+$ blankLine) - -- careful (#2302): printErrs prints in UTF-8, - -- whereas converting to string first and using - -- hPutStr would just emit the low 8 bits of - -- each unicode char. -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO () @@ -482,6 +516,8 @@ defaultLogActionHPutStrDoc logflags asciiSpace h d -- -ddump-json is being deprecated, `jsonLogAction` has been added in, but -- it should be removed along with -ddump-json. Similarly, the guard in -- `defaultLogAction` should be removed. This cleanup is tracked in #24113. +-- +-- -- | Default action for 'dumpAction' hook defaultDumpAction :: DumpCache -> LogAction -> DumpAction @@ -611,8 +647,8 @@ defaultTraceAction logflags title doc x = logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO () logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg -logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO () -logJsonMsg logger mc d = putJsonLogMsg logger (logFlags logger) mc (json d) +logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO () +logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc -- | Dump something logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () ===================================== docs/users_guide/9.14.1-notes.rst ===================================== @@ -143,6 +143,11 @@ Compiler were accessed using the generated record selector functions, marking the fields as covered in coverage reports (:ghc-ticket:`17834`). +- JSON diagnostics produced with (:ghc-flag:`-fdiagnostics-as-json`) now + include the `rendered` diagnostics message, in the exact same format as what + GHC would have produced without -fdiagnostics-as-json (including ANSI escape + sequences). + GHCi ~~~~ ===================================== docs/users_guide/diagnostics-as-json-schema-1_2.json ===================================== @@ -0,0 +1,144 @@ +{ + "$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": { + "oneOf": [ + { "$ref": "#/$defs/span" }, + { "type": "null" } + ] + }, + "severity": { + "description": "The diagnostic severity", + "type": "string", + "enum": [ + "Warning", + "Error" + ] + }, + "code": { + "description": "The diagnostic code (if it exists)", + "type": [ + "integer", + "null" + ] + }, + "rendered": { + "description": "The rendered diagnostics message, in the exact same format as what GHC would have produced without -fdiagnostics-as-json (including ANSI escape sequences)", + "type": "string" + }, + "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"] + } + ] + } + }, + + "$comment": "NOTE: \"rendered\" is not a required field so that the schema is backward compatible with version 1.1. If you bump the schema version to 2.0 the please also add \"rendered\" to the \"required\" fields.", + "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 ===================================== @@ -1428,7 +1428,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_1.json>`. + The schema can be downloaded :download:`here <diagnostics-as-json-schema-1_2.json>`. .. ghc-flag:: -fdiagnostics-color=⟨always|auto|never⟩ :shortdesc: Use colors in error messages ===================================== testsuite/tests/driver/json.stderr ===================================== @@ -1 +1 @@ -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","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 \u2018EmptyCase\u2019 extension"]} +{"rendered":"json.hs:9:11: error: [GHC-48010]\n Empty list of alternatives in case expression\n Suggested fix:\n Perhaps you intended to use the \u2018EmptyCase\u2019 extension\n","version":"1.1","ghcVersion":"ghc-9.13.20250627","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 \u2018EmptyCase\u2019 extension"]} ===================================== testsuite/tests/driver/json_warn.stderr ===================================== @@ -1,2 +1,2 @@ -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}} -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of \u2018head\u2019\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"}} +{"rendered":"json_warn.hs:4:3: warning: [GHC-40910] [-Wunused-matches (in -Wextra)]\n Defined but not used: \u2018x\u2019\n","version":"1.1","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}} +{"rendered":"json_warn.hs:7:5: warning: [GHC-63394] [-Wx-partial (in -Wextended-warnings)]\n In the use of \u2018head\u2019\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\".\"\n","version":"1.1","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of \u2018head\u2019\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/-/commit/b8af31c548c157b0dafa3b235ba92a8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b8af31c548c157b0dafa3b235ba92a8… You're receiving this email because of your account on gitlab.haskell.org.

1 0