[Git][ghc/ghc][wip/26296] ci: Teach ci.sh to fetch FreeBSD artifacts from ghcup unofficial bindists and...
by Zubin (＠wz1000) 18 Aug '25
by Zubin (＠wz1000) 18 Aug '25
18 Aug '25
Zubin pushed to branch wip/26296 at Glasgow Haskell Compiler / GHC
Commits:
95b47966 by Zubin Duggal at 2025-08-18T12:43:33+05:30
ci: Teach ci.sh to fetch FreeBSD artifacts from ghcup unofficial bindists and bootstrap compiler on FreeBSD to 9.10.1
Fixes #26296
- - - - -
3 changed files:
- .gitlab/ci.sh
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
Changes:
=====================================
.gitlab/ci.sh
=====================================
@@ -96,7 +96,9 @@ Environment variables determining bootstrap toolchain (Linux):
Environment variables determining bootstrap toolchain (non-Linux):
- GHC_VERSION Which GHC version to fetch for bootstrapping.
+ FETCH_GHC_VERSION Which GHC version to fetch for bootstrapping.
+ This should not be set if GHC is already provisioned, i.e. in the
+ docker image for linux platforms and via nix for darwin platforms
CABAL_INSTALL_VERSION
Cabal-install version to fetch for bootstrapping.
EOF
@@ -197,9 +199,6 @@ function set_toolchain_paths() {
CABAL="$toolchain/bin/cabal$exe"
HAPPY="$toolchain/bin/happy$exe"
ALEX="$toolchain/bin/alex$exe"
- if [ "$(uname)" = "FreeBSD" ]; then
- GHC=/usr/local/bin/ghc
- fi
;;
nix)
if [[ ! -f toolchain.sh ]]; then
@@ -275,29 +274,50 @@ function setup() {
}
function fetch_ghc() {
+ local should_fetch=false
+
if [ ! -e "$GHC" ]; then
- local v="$GHC_VERSION"
- if [[ -z "$v" ]]; then
- fail "neither GHC nor GHC_VERSION are not set"
+ if [ -z "${FETCH_GHC_VERSION:-}" ]; then
+ fail "GHC not found at '$GHC' and FETCH_GHC_VERSION is not set"
+ fi
+ should_fetch=true
+ elif [ -n "${FETCH_GHC_VERSION:-}" ]; then
+ local current_version
+ if current_version=$($GHC --numeric-version 2>/dev/null); then
+ if [ "$current_version" != "$FETCH_GHC_VERSION" ]; then
+ info "GHC version mismatch: found $current_version, expected $FETCH_GHC_VERSION"
+ should_fetch=true
fi
+ fi
+ fi
+
+ if [ "$should_fetch" = true ]; then
+ local v="$FETCH_GHC_VERSION"
start_section fetch-ghc "Fetch GHC"
- url="https://downloads.haskell.org/~ghc/${GHC_VERSION}/ghc-${GHC_VERSION}-${boot…"
+ case "$(uname)" in
+ FreeBSD)
+ url="https://downloads.haskell.org/ghcup/unofficial-bindists/ghc/${FETCH_GHC_VER…"
+ ;;
+ *)
+ url="https://downloads.haskell.org/~ghc/${FETCH_GHC_VERSION}/ghc-${FETCH_GHC_VER…"
+ ;;
+ esac
info "Fetching GHC binary distribution from $url..."
curl "$url" > ghc.tar.xz || fail "failed to fetch GHC binary distribution"
$TAR -xJf ghc.tar.xz || fail "failed to extract GHC binary distribution"
case "$(uname)" in
MSYS_*|MINGW*)
- cp -r ghc-${GHC_VERSION}*/* "$toolchain"
+ cp -r ghc-${FETCH_GHC_VERSION}*/* "$toolchain"
;;
*)
- pushd ghc-${GHC_VERSION}*
+ pushd ghc-${FETCH_GHC_VERSION}*
./configure --prefix="$toolchain"
"$MAKE" install
popd
;;
esac
- rm -Rf "ghc-${GHC_VERSION}" ghc.tar.xz
+ rm -Rf "ghc-${FETCH_GHC_VERSION}" ghc.tar.xz
end_section fetch-ghc
fi
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -446,7 +446,7 @@ opsysVariables _ FreeBSD14 = mconcat
-- Prefer to use the system's clang-based toolchain and not gcc
, "CC" =: "cc"
, "CXX" =: "c++"
- , "GHC_VERSION" =: "9.6.4"
+ , "FETCH_GHC_VERSION" =: "9.10.1"
, "CABAL_INSTALL_VERSION" =: "3.10.3.0"
]
opsysVariables arch (Linux distro) = distroVariables arch distro
@@ -478,7 +478,7 @@ opsysVariables _ (Windows {}) = mconcat
, "LANG" =: "en_US.UTF-8"
, "CABAL_INSTALL_VERSION" =: "3.10.2.0"
, "HADRIAN_ARGS" =: "--docs=no-sphinx-pdfs"
- , "GHC_VERSION" =: "9.10.1"
+ , "FETCH_GHC_VERSION" =: "9.10.1"
]
opsysVariables _ _ = mempty
=====================================
.gitlab/jobs.yaml
=====================================
@@ -1467,7 +1467,7 @@
"CC": "cc",
"CONFIGURE_ARGS": "--with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib --with-system-libffi --with-ffi-includes=/usr/local/include --with-ffi-libraries=/usr/local/lib --with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --enable-strict-ghc-toolchain-check",
"CXX": "c++",
- "GHC_VERSION": "9.6.4",
+ "FETCH_GHC_VERSION": "9.10.1",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"RUNTEST_ARGS": "",
"TEST_ENV": "x86_64-freebsd14-validate",
@@ -3698,7 +3698,7 @@
"BUILD_FLAVOUR": "validate",
"CABAL_INSTALL_VERSION": "3.10.2.0",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "GHC_VERSION": "9.10.1",
+ "FETCH_GHC_VERSION": "9.10.1",
"HADRIAN_ARGS": "--docs=no-sphinx-pdfs",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"LANG": "en_US.UTF-8",
@@ -3761,7 +3761,7 @@
"BUILD_FLAVOUR": "validate",
"CABAL_INSTALL_VERSION": "3.10.2.0",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "GHC_VERSION": "9.10.1",
+ "FETCH_GHC_VERSION": "9.10.1",
"HADRIAN_ARGS": "--docs=no-sphinx-pdfs",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"LANG": "en_US.UTF-8",
@@ -4355,7 +4355,7 @@
"CC": "cc",
"CONFIGURE_ARGS": "--with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib --with-system-libffi --with-ffi-includes=/usr/local/include --with-ffi-libraries=/usr/local/lib --with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --enable-strict-ghc-toolchain-check",
"CXX": "c++",
- "GHC_VERSION": "9.6.4",
+ "FETCH_GHC_VERSION": "9.10.1",
"IGNORE_PERF_FAILURES": "all",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"RUNTEST_ARGS": "",
@@ -5579,7 +5579,7 @@
"BUILD_FLAVOUR": "release",
"CABAL_INSTALL_VERSION": "3.10.2.0",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "GHC_VERSION": "9.10.1",
+ "FETCH_GHC_VERSION": "9.10.1",
"HADRIAN_ARGS": "--docs=no-sphinx-pdfs",
"IGNORE_PERF_FAILURES": "all",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
@@ -5643,7 +5643,7 @@
"BUILD_FLAVOUR": "release",
"CABAL_INSTALL_VERSION": "3.10.2.0",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "GHC_VERSION": "9.10.1",
+ "FETCH_GHC_VERSION": "9.10.1",
"HADRIAN_ARGS": "--docs=no-sphinx-pdfs",
"IGNORE_PERF_FAILURES": "all",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
@@ -5782,7 +5782,7 @@
"CC": "cc",
"CONFIGURE_ARGS": "--with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib --with-system-libffi --with-ffi-includes=/usr/local/include --with-ffi-libraries=/usr/local/lib --with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --enable-strict-ghc-toolchain-check",
"CXX": "c++",
- "GHC_VERSION": "9.6.4",
+ "FETCH_GHC_VERSION": "9.10.1",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"RUNTEST_ARGS": "",
"TEST_ENV": "x86_64-freebsd14-validate"
@@ -7982,7 +7982,7 @@
"BUILD_FLAVOUR": "validate",
"CABAL_INSTALL_VERSION": "3.10.2.0",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "GHC_VERSION": "9.10.1",
+ "FETCH_GHC_VERSION": "9.10.1",
"HADRIAN_ARGS": "--docs=no-sphinx-pdfs",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"LANG": "en_US.UTF-8",
@@ -8044,7 +8044,7 @@
"BUILD_FLAVOUR": "validate",
"CABAL_INSTALL_VERSION": "3.10.2.0",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "GHC_VERSION": "9.10.1",
+ "FETCH_GHC_VERSION": "9.10.1",
"HADRIAN_ARGS": "--docs=no-sphinx-pdfs",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"LANG": "en_US.UTF-8",
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/95b479662a76f08a1391012492cb471…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/95b479662a76f08a1391012492cb471…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/26296] ci: Teach ci.sh to fetch FreeBSD artifacts from ghcup unofficial bindists and...
by Zubin (＠wz1000) 18 Aug '25
by Zubin (＠wz1000) 18 Aug '25
18 Aug '25
Zubin pushed to branch wip/26296 at Glasgow Haskell Compiler / GHC
Commits:
4a8771b4 by Zubin Duggal at 2025-08-18T12:41:15+05:30
ci: Teach ci.sh to fetch FreeBSD artifacts from ghcup unofficial bindists and bootstrap compiler on FreeBSD to 9.10.1
Fixes #26296
- - - - -
3 changed files:
- .gitlab/ci.sh
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
Changes:
=====================================
.gitlab/ci.sh
=====================================
@@ -96,7 +96,7 @@ Environment variables determining bootstrap toolchain (Linux):
Environment variables determining bootstrap toolchain (non-Linux):
- GHC_VERSION Which GHC version to fetch for bootstrapping.
+ FETCH_GHC_VERSION Which GHC version to fetch for bootstrapping.
CABAL_INSTALL_VERSION
Cabal-install version to fetch for bootstrapping.
EOF
@@ -197,9 +197,6 @@ function set_toolchain_paths() {
CABAL="$toolchain/bin/cabal$exe"
HAPPY="$toolchain/bin/happy$exe"
ALEX="$toolchain/bin/alex$exe"
- if [ "$(uname)" = "FreeBSD" ]; then
- GHC=/usr/local/bin/ghc
- fi
;;
nix)
if [[ ! -f toolchain.sh ]]; then
@@ -275,29 +272,50 @@ function setup() {
}
function fetch_ghc() {
+ local should_fetch=false
+
if [ ! -e "$GHC" ]; then
- local v="$GHC_VERSION"
- if [[ -z "$v" ]]; then
- fail "neither GHC nor GHC_VERSION are not set"
+ if [ -z "${FETCH_GHC_VERSION:-}" ]; then
+ fail "GHC not found at '$GHC' and FETCH_GHC_VERSION is not set"
+ fi
+ should_fetch=true
+ elif [ -n "${FETCH_GHC_VERSION:-}" ]; then
+ local current_version
+ if current_version=$($GHC --numeric-version 2>/dev/null); then
+ if [ "$current_version" != "$FETCH_GHC_VERSION" ]; then
+ info "GHC version mismatch: found $current_version, expected $FETCH_GHC_VERSION"
+ should_fetch=true
fi
+ fi
+ fi
+
+ if [ "$should_fetch" = true ]; then
+ local v="$FETCH_GHC_VERSION"
start_section fetch-ghc "Fetch GHC"
- url="https://downloads.haskell.org/~ghc/${GHC_VERSION}/ghc-${GHC_VERSION}-${boot…"
+ case "$(uname)" in
+ FreeBSD)
+ url="https://downloads.haskell.org/ghcup/unofficial-bindists/ghc/${FETCH_GHC_VER…"
+ ;;
+ *)
+ url="https://downloads.haskell.org/~ghc/${FETCH_GHC_VERSION}/ghc-${FETCH_GHC_VER…"
+ ;;
+ esac
info "Fetching GHC binary distribution from $url..."
curl "$url" > ghc.tar.xz || fail "failed to fetch GHC binary distribution"
$TAR -xJf ghc.tar.xz || fail "failed to extract GHC binary distribution"
case "$(uname)" in
MSYS_*|MINGW*)
- cp -r ghc-${GHC_VERSION}*/* "$toolchain"
+ cp -r ghc-${FETCH_GHC_VERSION}*/* "$toolchain"
;;
*)
- pushd ghc-${GHC_VERSION}*
+ pushd ghc-${FETCH_GHC_VERSION}*
./configure --prefix="$toolchain"
"$MAKE" install
popd
;;
esac
- rm -Rf "ghc-${GHC_VERSION}" ghc.tar.xz
+ rm -Rf "ghc-${FETCH_GHC_VERSION}" ghc.tar.xz
end_section fetch-ghc
fi
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -446,7 +446,7 @@ opsysVariables _ FreeBSD14 = mconcat
-- Prefer to use the system's clang-based toolchain and not gcc
, "CC" =: "cc"
, "CXX" =: "c++"
- , "GHC_VERSION" =: "9.6.4"
+ , "FETCH_GHC_VERSION" =: "9.10.1"
, "CABAL_INSTALL_VERSION" =: "3.10.3.0"
]
opsysVariables arch (Linux distro) = distroVariables arch distro
@@ -478,7 +478,7 @@ opsysVariables _ (Windows {}) = mconcat
, "LANG" =: "en_US.UTF-8"
, "CABAL_INSTALL_VERSION" =: "3.10.2.0"
, "HADRIAN_ARGS" =: "--docs=no-sphinx-pdfs"
- , "GHC_VERSION" =: "9.10.1"
+ , "FETCH_GHC_VERSION" =: "9.10.1"
]
opsysVariables _ _ = mempty
=====================================
.gitlab/jobs.yaml
=====================================
@@ -1467,7 +1467,7 @@
"CC": "cc",
"CONFIGURE_ARGS": "--with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib --with-system-libffi --with-ffi-includes=/usr/local/include --with-ffi-libraries=/usr/local/lib --with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --enable-strict-ghc-toolchain-check",
"CXX": "c++",
- "GHC_VERSION": "9.6.4",
+ "FETCH_GHC_VERSION": "9.10.1",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"RUNTEST_ARGS": "",
"TEST_ENV": "x86_64-freebsd14-validate",
@@ -3698,7 +3698,7 @@
"BUILD_FLAVOUR": "validate",
"CABAL_INSTALL_VERSION": "3.10.2.0",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "GHC_VERSION": "9.10.1",
+ "FETCH_GHC_VERSION": "9.10.1",
"HADRIAN_ARGS": "--docs=no-sphinx-pdfs",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"LANG": "en_US.UTF-8",
@@ -3761,7 +3761,7 @@
"BUILD_FLAVOUR": "validate",
"CABAL_INSTALL_VERSION": "3.10.2.0",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "GHC_VERSION": "9.10.1",
+ "FETCH_GHC_VERSION": "9.10.1",
"HADRIAN_ARGS": "--docs=no-sphinx-pdfs",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"LANG": "en_US.UTF-8",
@@ -4355,7 +4355,7 @@
"CC": "cc",
"CONFIGURE_ARGS": "--with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib --with-system-libffi --with-ffi-includes=/usr/local/include --with-ffi-libraries=/usr/local/lib --with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --enable-strict-ghc-toolchain-check",
"CXX": "c++",
- "GHC_VERSION": "9.6.4",
+ "FETCH_GHC_VERSION": "9.10.1",
"IGNORE_PERF_FAILURES": "all",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"RUNTEST_ARGS": "",
@@ -5579,7 +5579,7 @@
"BUILD_FLAVOUR": "release",
"CABAL_INSTALL_VERSION": "3.10.2.0",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "GHC_VERSION": "9.10.1",
+ "FETCH_GHC_VERSION": "9.10.1",
"HADRIAN_ARGS": "--docs=no-sphinx-pdfs",
"IGNORE_PERF_FAILURES": "all",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
@@ -5643,7 +5643,7 @@
"BUILD_FLAVOUR": "release",
"CABAL_INSTALL_VERSION": "3.10.2.0",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "GHC_VERSION": "9.10.1",
+ "FETCH_GHC_VERSION": "9.10.1",
"HADRIAN_ARGS": "--docs=no-sphinx-pdfs",
"IGNORE_PERF_FAILURES": "all",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
@@ -5782,7 +5782,7 @@
"CC": "cc",
"CONFIGURE_ARGS": "--with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib --with-system-libffi --with-ffi-includes=/usr/local/include --with-ffi-libraries=/usr/local/lib --with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --enable-strict-ghc-toolchain-check",
"CXX": "c++",
- "GHC_VERSION": "9.6.4",
+ "FETCH_GHC_VERSION": "9.10.1",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"RUNTEST_ARGS": "",
"TEST_ENV": "x86_64-freebsd14-validate"
@@ -7982,7 +7982,7 @@
"BUILD_FLAVOUR": "validate",
"CABAL_INSTALL_VERSION": "3.10.2.0",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "GHC_VERSION": "9.10.1",
+ "FETCH_GHC_VERSION": "9.10.1",
"HADRIAN_ARGS": "--docs=no-sphinx-pdfs",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"LANG": "en_US.UTF-8",
@@ -8044,7 +8044,7 @@
"BUILD_FLAVOUR": "validate",
"CABAL_INSTALL_VERSION": "3.10.2.0",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "GHC_VERSION": "9.10.1",
+ "FETCH_GHC_VERSION": "9.10.1",
"HADRIAN_ARGS": "--docs=no-sphinx-pdfs",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"LANG": "en_US.UTF-8",
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4a8771b43031073276664a3344de9fe…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4a8771b43031073276664a3344de9fe…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26217] 3 commits: ghc-internal: Split out GHC.Internal.TH.Monad from .Syntax
by Teo Camarasu (＠teo) 17 Aug '25
by Teo Camarasu (＠teo) 17 Aug '25
17 Aug '25
Teo Camarasu pushed to branch wip/T26217 at Glasgow Haskell Compiler / GHC
Commits:
840aeea0 by Teo Camarasu at 2025-08-17T23:30:11+01:00
ghc-internal: Split out GHC.Internal.TH.Monad from .Syntax
Split the Quasi/Q, etc definition out of GHC.Internal.TH.Syntax
into its own module.
We do this for a few reasons:
- it enables future refactors to speed up compilation of these modules.
- it reduces the size of this very large module.
- it clarifies which modules in the GHC tree depend on the TH monads (Q/Quasi, etc) and
which just care about the syntax tree.
A step towards addressing: #26217
- - - - -
9ddc10aa by Teo Camarasu at 2025-08-17T23:30:13+01:00
ghc-internal: Move Data instance for TH.Syntax to Data.Data
This means that Data.Data no longer blocks building TH.Syntax, which
allows greater parallelism in our builds.
Previously TH.Syntax was a bottleneck when compiling ghc-internal. Now
it is less of a bottle-neck and is also slightly quicker to
compile (since it no longer contains these instances) at the cost of
making Data.Data slightly more expensive to compile.
TH.Lift which depends on TH.Syntax can also compile quicker and no
longer blocks ghc-internal finishing to compile.
Resolves #26217
- - - - -
c2a0e9e2 by Teo Camarasu at 2025-08-17T23:30:13+01:00
compiler: delete unused names in Builtins.Names.TH
returnQ and bindQ are no longer used in the compiler.
There was also a very old comment that referred to them that I have modernized
- - - - -
23 changed files:
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Gen/Splice.hs-boot
- compiler/GHC/Tc/Types/TH.hs
- libraries/base/src/Data/Array/Byte.hs
- libraries/base/src/Data/Fixed.hs
- + libraries/ghc-boot-th/GHC/Boot/TH/Monad.hs
- libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
- libraries/ghc-boot-th/ghc-boot-th.cabal.in
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Data/Data.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- + libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/TH.hs
- libraries/template-haskell/Language/Haskell/TH/Quote.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
Changes:
=====================================
compiler/GHC/Builtin/Names/TH.hs
=====================================
@@ -30,7 +30,7 @@ templateHaskellNames :: [Name]
-- Should stay in sync with the import list of GHC.HsToCore.Quote
templateHaskellNames = [
- returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,
+ sequenceQName, newNameName, liftName, liftTypedName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameG_fldName,
mkNameLName,
mkNameSName, mkNameQName,
@@ -181,26 +181,30 @@ templateHaskellNames = [
-- Quasiquoting
quasiQuoterTyConName, quoteDecName, quoteTypeName, quoteExpName, quotePatName]
-thSyn, thLib, qqLib, liftLib :: Module
+thSyn, thMonad, thLib, qqLib, liftLib :: Module
thSyn = mkTHModule (fsLit "GHC.Internal.TH.Syntax")
+thMonad = mkTHModule (fsLit "GHC.Internal.TH.Monad")
thLib = mkTHModule (fsLit "GHC.Internal.TH.Lib")
qqLib = mkTHModule (fsLit "GHC.Internal.TH.Quote")
liftLib = mkTHModule (fsLit "GHC.Internal.TH.Lift")
+
mkTHModule :: FastString -> Module
mkTHModule m = mkModule ghcInternalUnit (mkModuleNameFS m)
-libFun, libTc, thFun, thTc, thCls, thCon, liftFun :: FastString -> Unique -> Name
+libFun, libTc, thFun, thTc, thCon, liftFun, thMonadTc, thMonadCls, thMonadFun :: FastString -> Unique -> Name
libFun = mk_known_key_name varName thLib
libTc = mk_known_key_name tcName thLib
thFun = mk_known_key_name varName thSyn
thTc = mk_known_key_name tcName thSyn
-thCls = mk_known_key_name clsName thSyn
thCon = mk_known_key_name dataName thSyn
liftFun = mk_known_key_name varName liftLib
+thMonadTc = mk_known_key_name tcName thMonad
+thMonadCls = mk_known_key_name clsName thMonad
+thMonadFun = mk_known_key_name varName thMonad
-thFld :: FastString -> FastString -> Unique -> Name
-thFld con = mk_known_key_name (fieldName con) thSyn
+thMonadFld :: FastString -> FastString -> Unique -> Name
+thMonadFld con = mk_known_key_name (fieldName con) thSyn
qqFld :: FastString -> Unique -> Name
qqFld = mk_known_key_name (fieldName (fsLit "QuasiQuoter")) qqLib
@@ -210,14 +214,14 @@ liftClassName :: Name
liftClassName = mk_known_key_name clsName liftLib (fsLit "Lift") liftClassKey
quoteClassName :: Name
-quoteClassName = thCls (fsLit "Quote") quoteClassKey
+quoteClassName = thMonadCls (fsLit "Quote") quoteClassKey
qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
matchTyConName, clauseTyConName, funDepTyConName, predTyConName,
codeTyConName, injAnnTyConName, overlapTyConName, decsTyConName,
modNameTyConName, quasiQuoterTyConName :: Name
-qTyConName = thTc (fsLit "Q") qTyConKey
+qTyConName = thMonadTc (fsLit "Q") qTyConKey
nameTyConName = thTc (fsLit "Name") nameTyConKey
fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
patTyConName = thTc (fsLit "Pat") patTyConKey
@@ -230,20 +234,18 @@ matchTyConName = thTc (fsLit "Match") matchTyConKey
clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
predTyConName = thTc (fsLit "Pred") predTyConKey
-codeTyConName = thTc (fsLit "Code") codeTyConKey
+codeTyConName = thMonadTc (fsLit "Code") codeTyConKey
injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey
overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey
modNameTyConName = thTc (fsLit "ModName") modNameTyConKey
quasiQuoterTyConName = mk_known_key_name tcName qqLib (fsLit "QuasiQuoter") quasiQuoterTyConKey
-returnQName, bindQName, sequenceQName, newNameName, liftName,
+sequenceQName, newNameName, liftName,
mkNameName, mkNameG_vName, mkNameG_fldName, mkNameG_dName, mkNameG_tcName,
mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName,
unsafeCodeCoerceName, liftTypedName, mkModNameName, mkNameQName :: Name
-returnQName = thFun (fsLit "returnQ") returnQIdKey
-bindQName = thFun (fsLit "bindQ") bindQIdKey
-sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
-newNameName = thFun (fsLit "newName") newNameIdKey
+sequenceQName = thMonadFun (fsLit "sequenceQ") sequenceQIdKey
+newNameName = thMonadFun (fsLit "newName") newNameIdKey
mkNameName = thFun (fsLit "mkName") mkNameIdKey
mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey
mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
@@ -253,9 +255,9 @@ mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey
mkNameQName = thFun (fsLit "mkNameQ") mkNameQIdKey
mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey
mkModNameName = thFun (fsLit "mkModName") mkModNameIdKey
-unTypeName = thFld (fsLit "TExp") (fsLit "unType") unTypeIdKey
-unTypeCodeName = thFun (fsLit "unTypeCode") unTypeCodeIdKey
-unsafeCodeCoerceName = thFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey
+unTypeName = thMonadFld (fsLit "TExp") (fsLit "unType") unTypeIdKey
+unTypeCodeName = thMonadFun (fsLit "unTypeCode") unTypeCodeIdKey
+unsafeCodeCoerceName = thMonadFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey
liftName = liftFun (fsLit "lift") liftIdKey
liftStringName = liftFun (fsLit "liftString") liftStringIdKey
liftTypedName = liftFun (fsLit "liftTyped") liftTypedIdKey
@@ -808,12 +810,10 @@ dataNamespaceSpecifierDataConKey = mkPreludeDataConUnique 215
-- IdUniques available: 200-499
-- If you want to change this, make sure you check in GHC.Builtin.Names
-returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
+sequenceQIdKey, liftIdKey, newNameIdKey,
mkNameIdKey, mkNameG_vIdKey, mkNameG_fldIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey,
unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey, mkNameQIdKey :: Unique
-returnQIdKey = mkPreludeMiscIdUnique 200
-bindQIdKey = mkPreludeMiscIdUnique 201
sequenceQIdKey = mkPreludeMiscIdUnique 202
liftIdKey = mkPreludeMiscIdUnique 203
newNameIdKey = mkPreludeMiscIdUnique 204
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -68,7 +68,7 @@ import GHC.Tc.Utils.TcType (TcType, TcTyVar)
import {-# SOURCE #-} GHC.Tc.Types.LclEnv (TcLclEnv)
import GHCi.RemoteTypes ( ForeignRef )
-import qualified GHC.Boot.TH.Syntax as TH (Q)
+import qualified GHC.Boot.TH.Monad as TH (Q)
-- libraries:
import Data.Data hiding (Fixity(..))
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -245,14 +245,14 @@ first generate a polymorphic definition and then just apply the wrapper at the e
[| \x -> x |]
====>
- gensym (unpackString "x"#) `bindQ` \ x1::String ->
- lam (pvar x1) (var x1)
+ newName (unpackString "x"#) >>= \ x1::Name ->
+ lamE (varP x1) (varE x1)
[| \x -> $(f [| x |]) |]
====>
- gensym (unpackString "x"#) `bindQ` \ x1::String ->
- lam (pvar x1) (f (var x1))
+ newName (unpackString "x"#) >>= \ x1::Name ->
+ lamE (varP x1) (f (varE x1))
-}
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -68,7 +68,7 @@ import {-# SOURCE #-} GHC.Tc.Gen.Splice
import GHC.Tc.Zonk.Type
import GHCi.RemoteTypes ( ForeignRef )
-import qualified GHC.Boot.TH.Syntax as TH (Q)
+import qualified GHC.Boot.TH.Monad as TH (Q)
import qualified GHC.LanguageExtensions as LangExt
import qualified Data.Set as Set
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -144,6 +144,7 @@ import qualified GHC.LanguageExtensions as LangExt
-- THSyntax gives access to internal functions and data types
import qualified GHC.Boot.TH.Syntax as TH
+import qualified GHC.Boot.TH.Monad as TH
import qualified GHC.Boot.TH.Ppr as TH
#if defined(HAVE_INTERNAL_INTERPRETER)
=====================================
compiler/GHC/Tc/Gen/Splice.hs-boot
=====================================
@@ -12,6 +12,7 @@ import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc )
import GHC.Hs ( HsQuote, HsExpr, LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers, HsUntypedSpliceResult, HsTypedSpliceResult, HsTypedSplice )
import qualified GHC.Boot.TH.Syntax as TH
+import qualified GHC.Boot.TH.Monad as TH
tcTypedSplice :: HsTypedSpliceResult
-> HsTypedSplice GhcRn
=====================================
compiler/GHC/Tc/Types/TH.hs
=====================================
@@ -18,7 +18,7 @@ module GHC.Tc.Types.TH (
import GHC.Prelude
import GHCi.RemoteTypes
-import qualified GHC.Boot.TH.Syntax as TH
+import qualified GHC.Boot.TH.Monad as TH
import GHC.Tc.Types.Evidence
import GHC.Utils.Outputable
import GHC.Tc.Types.TcRef
=====================================
libraries/base/src/Data/Array/Byte.hs
=====================================
@@ -32,6 +32,7 @@ import GHC.Internal.Show (intToDigit)
import GHC.Internal.ST (ST(..), runST)
import GHC.Internal.Word (Word8(..))
import GHC.Internal.TH.Syntax
+import GHC.Internal.TH.Monad
import GHC.Internal.TH.Lift
import GHC.Internal.ForeignPtr
import Prelude
=====================================
libraries/base/src/Data/Fixed.hs
=====================================
@@ -91,7 +91,7 @@ import GHC.Internal.TypeLits (KnownNat, natVal)
import GHC.Internal.Read
import GHC.Internal.Text.ParserCombinators.ReadPrec
import GHC.Internal.Text.Read.Lex
-import qualified GHC.Internal.TH.Syntax as TH
+import qualified GHC.Internal.TH.Monad as TH
import qualified GHC.Internal.TH.Lift as TH
import Data.Typeable
import Prelude
=====================================
libraries/ghc-boot-th/GHC/Boot/TH/Monad.hs
=====================================
@@ -0,0 +1,6 @@
+{-# LANGUAGE Safe #-}
+{-# OPTIONS_HADDOCK not-home #-}
+module GHC.Boot.TH.Monad
+ (module GHC.Internal.TH.Monad) where
+
+import GHC.Internal.TH.Monad
=====================================
libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
=====================================
@@ -1,4 +1,3 @@
-{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE LambdaCase #-}
-- | contains a prettyprinter for the
-- Template Haskell datatypes
=====================================
libraries/ghc-boot-th/ghc-boot-th.cabal.in
=====================================
@@ -60,9 +60,11 @@ Library
exposed-modules:
GHC.Boot.TH.Lib
GHC.Boot.TH.Syntax
+ GHC.Boot.TH.Monad
other-modules:
GHC.Internal.TH.Lib
GHC.Internal.TH.Syntax
+ GHC.Internal.TH.Monad
GHC.Internal.ForeignSrcLang
GHC.Internal.LanguageExtensions
GHC.Internal.Lexeme
@@ -74,4 +76,5 @@ Library
GHC.Boot.TH.Lib,
GHC.Boot.TH.Lift,
GHC.Boot.TH.Quote,
- GHC.Boot.TH.Syntax
+ GHC.Boot.TH.Syntax,
+ GHC.Boot.TH.Monad
=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -298,6 +298,7 @@ Library
GHC.Internal.TH.Lib
GHC.Internal.TH.Lift
GHC.Internal.TH.Quote
+ GHC.Internal.TH.Monad
GHC.Internal.TopHandler
GHC.Internal.TypeError
GHC.Internal.TypeLits
=====================================
libraries/ghc-internal/src/GHC/Internal/Data/Data.hs
=====================================
@@ -143,6 +143,7 @@ import GHC.Internal.Arr -- So we can give Data instance for Array
import qualified GHC.Internal.Generics as Generics (Fixity(..))
import GHC.Internal.Generics hiding (Fixity(..))
-- So we can give Data instance for U1, V1, ...
+import qualified GHC.Internal.TH.Syntax as TH
------------------------------------------------------------------------------
--
@@ -1353,3 +1354,63 @@ deriving instance Data DecidedStrictness
-- | @since base-4.12.0.0
deriving instance Data a => Data (Down a)
+
+----------------------------------------------------------------------------
+-- Data instances for GHC.Internal.TH.Syntax
+
+deriving instance Data TH.AnnLookup
+deriving instance Data TH.AnnTarget
+deriving instance Data TH.Bang
+deriving instance Data TH.BndrVis
+deriving instance Data TH.Body
+deriving instance Data TH.Bytes
+deriving instance Data TH.Callconv
+deriving instance Data TH.Clause
+deriving instance Data TH.Con
+deriving instance Data TH.Dec
+deriving instance Data TH.DecidedStrictness
+deriving instance Data TH.DerivClause
+deriving instance Data TH.DerivStrategy
+deriving instance Data TH.DocLoc
+deriving instance Data TH.Exp
+deriving instance Data TH.FamilyResultSig
+deriving instance Data TH.Fixity
+deriving instance Data TH.FixityDirection
+deriving instance Data TH.Foreign
+deriving instance Data TH.FunDep
+deriving instance Data TH.Guard
+deriving instance Data TH.Info
+deriving instance Data TH.InjectivityAnn
+deriving instance Data TH.Inline
+deriving instance Data TH.Lit
+deriving instance Data TH.Loc
+deriving instance Data TH.Match
+deriving instance Data TH.ModName
+deriving instance Data TH.Module
+deriving instance Data TH.ModuleInfo
+deriving instance Data TH.Name
+deriving instance Data TH.NameFlavour
+deriving instance Data TH.NameSpace
+deriving instance Data TH.NamespaceSpecifier
+deriving instance Data TH.OccName
+deriving instance Data TH.Overlap
+deriving instance Data TH.Pat
+deriving instance Data TH.PatSynArgs
+deriving instance Data TH.PatSynDir
+deriving instance Data TH.Phases
+deriving instance Data TH.PkgName
+deriving instance Data TH.Pragma
+deriving instance Data TH.Range
+deriving instance Data TH.Role
+deriving instance Data TH.RuleBndr
+deriving instance Data TH.RuleMatch
+deriving instance Data TH.Safety
+deriving instance Data TH.SourceStrictness
+deriving instance Data TH.SourceUnpackedness
+deriving instance Data TH.Specificity
+deriving instance Data TH.Stmt
+deriving instance Data TH.TyLit
+deriving instance Data TH.TySynEqn
+deriving instance Data TH.Type
+deriving instance Data TH.TypeFamilyHead
+deriving instance Data flag => Data (TH.TyVarBndr flag)
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
=====================================
@@ -21,6 +21,7 @@
module GHC.Internal.TH.Lib where
import GHC.Internal.TH.Syntax hiding (Role, InjectivityAnn)
+import GHC.Internal.TH.Monad
import qualified GHC.Internal.TH.Syntax as TH
#ifdef BOOTSTRAP_TH
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
=====================================
@@ -30,6 +30,7 @@ module GHC.Internal.TH.Lift
where
import GHC.Internal.TH.Syntax
+import GHC.Internal.TH.Monad
import qualified GHC.Internal.TH.Lib as Lib (litE) -- See wrinkle (W4) of Note [Tracking dependencies on primitives]
import GHC.Internal.Data.Either
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
=====================================
@@ -0,0 +1,971 @@
+{-# OPTIONS_HADDOCK not-home #-} -- we want users to import Language.Haskell.TH.Syntax instead
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs#-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE UnboxedSums #-}
+
+-- | This module is used internally in GHC's integration with Template Haskell
+-- and defines the Monads of Template Haskell, and associated definitions.
+--
+-- This is not a part of the public API, and as such, there are no API
+-- guarantees for this module from version to version.
+--
+-- Import "Language.Haskell.TH" or "Language.Haskell.TH.Syntax" instead!
+module GHC.Internal.TH.Monad
+ ( module GHC.Internal.TH.Monad
+ ) where
+
+#ifdef BOOTSTRAP_TH
+import Prelude
+import Data.Data hiding (Fixity(..))
+import Data.IORef
+import System.IO.Unsafe ( unsafePerformIO )
+import Control.Monad.IO.Class (MonadIO (..))
+import Control.Monad.Fix (MonadFix (..))
+import Control.Exception (BlockedIndefinitelyOnMVar (..), catch, throwIO)
+import Control.Exception.Base (FixIOException (..))
+import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar)
+import System.IO ( hPutStrLn, stderr )
+import qualified Data.Kind as Kind (Type)
+import GHC.IO.Unsafe ( unsafeDupableInterleaveIO )
+import GHC.Types (TYPE, RuntimeRep(..))
+#else
+import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence)
+import GHC.Internal.Data.Data hiding (Fixity(..))
+import GHC.Internal.Data.Traversable
+import GHC.Internal.IORef
+import GHC.Internal.System.IO
+import GHC.Internal.Data.Foldable
+import GHC.Internal.Data.Typeable
+import GHC.Internal.Control.Monad.IO.Class
+import GHC.Internal.Control.Monad.Fail
+import GHC.Internal.Control.Monad.Fix
+import GHC.Internal.Control.Exception
+import GHC.Internal.Num
+import GHC.Internal.IO.Unsafe
+import GHC.Internal.MVar
+import GHC.Internal.IO.Exception
+import qualified GHC.Internal.Types as Kind (Type)
+#endif
+import GHC.Internal.ForeignSrcLang
+import GHC.Internal.LanguageExtensions
+import GHC.Internal.TH.Syntax
+
+-----------------------------------------------------
+--
+-- The Quasi class
+--
+-----------------------------------------------------
+
+class (MonadIO m, MonadFail m) => Quasi m where
+ -- | Fresh names. See 'newName'.
+ qNewName :: String -> m Name
+
+ ------- Error reporting and recovery -------
+ -- | Report an error (True) or warning (False)
+ -- ...but carry on; use 'fail' to stop. See 'report'.
+ qReport :: Bool -> String -> m ()
+
+ -- | See 'recover'.
+ qRecover :: m a -- ^ the error handler
+ -> m a -- ^ action which may fail
+ -> m a -- ^ Recover from the monadic 'fail'
+
+ ------- Inspect the type-checker's environment -------
+ -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
+ qLookupName :: Bool -> String -> m (Maybe Name)
+ -- | See 'reify'.
+ qReify :: Name -> m Info
+ -- | See 'reifyFixity'.
+ qReifyFixity :: Name -> m (Maybe Fixity)
+ -- | See 'reifyType'.
+ qReifyType :: Name -> m Type
+ -- | Is (n tys) an instance? Returns list of matching instance Decs (with
+ -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
+ qReifyInstances :: Name -> [Type] -> m [Dec]
+ -- | See 'reifyRoles'.
+ qReifyRoles :: Name -> m [Role]
+ -- | See 'reifyAnnotations'.
+ qReifyAnnotations :: Data a => AnnLookup -> m [a]
+ -- | See 'reifyModule'.
+ qReifyModule :: Module -> m ModuleInfo
+ -- | See 'reifyConStrictness'.
+ qReifyConStrictness :: Name -> m [DecidedStrictness]
+
+ -- | See 'location'.
+ qLocation :: m Loc
+
+ -- | Input/output (dangerous). See 'runIO'.
+ qRunIO :: IO a -> m a
+ qRunIO = liftIO
+ -- | See 'getPackageRoot'.
+ qGetPackageRoot :: m FilePath
+
+ -- | See 'addDependentFile'.
+ qAddDependentFile :: FilePath -> m ()
+
+ -- | See 'addTempFile'.
+ qAddTempFile :: String -> m FilePath
+
+ -- | See 'addTopDecls'.
+ qAddTopDecls :: [Dec] -> m ()
+
+ -- | See 'addForeignFilePath'.
+ qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
+
+ -- | See 'addModFinalizer'.
+ qAddModFinalizer :: Q () -> m ()
+
+ -- | See 'addCorePlugin'.
+ qAddCorePlugin :: String -> m ()
+
+ -- | See 'getQ'.
+ qGetQ :: Typeable a => m (Maybe a)
+
+ -- | See 'putQ'.
+ qPutQ :: Typeable a => a -> m ()
+
+ -- | See 'isExtEnabled'.
+ qIsExtEnabled :: Extension -> m Bool
+ -- | See 'extsEnabled'.
+ qExtsEnabled :: m [Extension]
+
+ -- | See 'putDoc'.
+ qPutDoc :: DocLoc -> String -> m ()
+ -- | See 'getDoc'.
+ qGetDoc :: DocLoc -> m (Maybe String)
+
+-----------------------------------------------------
+-- The IO instance of Quasi
+-----------------------------------------------------
+
+-- | This instance is used only when running a Q
+-- computation in the IO monad, usually just to
+-- print the result. There is no interesting
+-- type environment, so reification isn't going to
+-- work.
+instance Quasi IO where
+ qNewName = newNameIO
+
+ qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
+ qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
+
+ qLookupName _ _ = badIO "lookupName"
+ qReify _ = badIO "reify"
+ qReifyFixity _ = badIO "reifyFixity"
+ qReifyType _ = badIO "reifyFixity"
+ qReifyInstances _ _ = badIO "reifyInstances"
+ qReifyRoles _ = badIO "reifyRoles"
+ qReifyAnnotations _ = badIO "reifyAnnotations"
+ qReifyModule _ = badIO "reifyModule"
+ qReifyConStrictness _ = badIO "reifyConStrictness"
+ qLocation = badIO "currentLocation"
+ qRecover _ _ = badIO "recover" -- Maybe we could fix this?
+ qGetPackageRoot = badIO "getProjectRoot"
+ qAddDependentFile _ = badIO "addDependentFile"
+ qAddTempFile _ = badIO "addTempFile"
+ qAddTopDecls _ = badIO "addTopDecls"
+ qAddForeignFilePath _ _ = badIO "addForeignFilePath"
+ qAddModFinalizer _ = badIO "addModFinalizer"
+ qAddCorePlugin _ = badIO "addCorePlugin"
+ qGetQ = badIO "getQ"
+ qPutQ _ = badIO "putQ"
+ qIsExtEnabled _ = badIO "isExtEnabled"
+ qExtsEnabled = badIO "extsEnabled"
+ qPutDoc _ _ = badIO "putDoc"
+ qGetDoc _ = badIO "getDoc"
+
+instance Quote IO where
+ newName = newNameIO
+
+newNameIO :: String -> IO Name
+newNameIO s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x))
+ ; pure (mkNameU s n) }
+
+badIO :: String -> IO a
+badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad")
+ ; fail "Template Haskell failure" }
+
+-- Global variable to generate unique symbols
+counter :: IORef Uniq
+{-# NOINLINE counter #-}
+counter = unsafePerformIO (newIORef 0)
+
+
+-----------------------------------------------------
+--
+-- The Q monad
+--
+-----------------------------------------------------
+
+-- | In short, 'Q' provides the 'Quasi' operations in one neat monad for the
+-- user.
+--
+-- The longer story, is that 'Q' wraps an arbitrary 'Quasi'-able monad.
+-- The perceptive reader notices that 'Quasi' has only two instances, 'Q'
+-- itself and 'IO', neither of which have concrete implementations.'Q' plays
+-- the trick of [dependency
+-- inversion](https://en.wikipedia.org/wiki/Dependency_inversion_principle),
+-- providing an abstract interface for the user which is later concretely
+-- fufilled by an concrete 'Quasi' instance, internal to GHC.
+newtype Q a = Q { unQ :: forall m. Quasi m => m a }
+
+-- | \"Runs\" the 'Q' monad. Normal users of Template Haskell
+-- should not need this function, as the splice brackets @$( ... )@
+-- are the usual way of running a 'Q' computation.
+--
+-- This function is primarily used in GHC internals, and for debugging
+-- splices by running them in 'IO'.
+--
+-- Note that many functions in 'Q', such as 'reify' and other compiler
+-- queries, are not supported when running 'Q' in 'IO'; these operations
+-- simply fail at runtime. Indeed, the only operations guaranteed to succeed
+-- are 'newName', 'runIO', 'reportError' and 'reportWarning'.
+runQ :: Quasi m => Q a -> m a
+runQ (Q m) = m
+
+instance Monad Q where
+ Q m >>= k = Q (m >>= \x -> unQ (k x))
+ (>>) = (*>)
+
+instance MonadFail Q where
+ fail s = report True s >> Q (fail "Q monad failure")
+
+instance Functor Q where
+ fmap f (Q x) = Q (fmap f x)
+
+instance Applicative Q where
+ pure x = Q (pure x)
+ Q f <*> Q x = Q (f <*> x)
+ Q m *> Q n = Q (m *> n)
+
+-- | @since 2.17.0.0
+instance Semigroup a => Semigroup (Q a) where
+ (<>) = liftA2 (<>)
+
+-- | @since 2.17.0.0
+instance Monoid a => Monoid (Q a) where
+ mempty = pure mempty
+
+-- | If the function passed to 'mfix' inspects its argument,
+-- the resulting action will throw a 'FixIOException'.
+--
+-- @since 2.17.0.0
+instance MonadFix Q where
+ -- We use the same blackholing approach as in fixIO.
+ -- See Note [Blackholing in fixIO] in System.IO in base.
+ mfix k = do
+ m <- runIO newEmptyMVar
+ ans <- runIO (unsafeDupableInterleaveIO
+ (readMVar m `catch` \BlockedIndefinitelyOnMVar ->
+ throwIO FixIOException))
+ result <- k ans
+ runIO (putMVar m result)
+ return result
+
+
+-----------------------------------------------------
+--
+-- The Quote class
+--
+-----------------------------------------------------
+
+
+
+-- | The 'Quote' class implements the minimal interface which is necessary for
+-- desugaring quotations.
+--
+-- * The @Monad m@ superclass is needed to stitch together the different
+-- AST fragments.
+-- * 'newName' is used when desugaring binding structures such as lambdas
+-- to generate fresh names.
+--
+-- Therefore the type of an untyped quotation in GHC is `Quote m => m Exp`
+--
+-- For many years the type of a quotation was fixed to be `Q Exp` but by
+-- more precisely specifying the minimal interface it enables the `Exp` to
+-- be extracted purely from the quotation without interacting with `Q`.
+class Monad m => Quote m where
+ {- |
+ Generate a fresh name, which cannot be captured.
+
+ For example, this:
+
+ @f = $(do
+ nm1 <- newName \"x\"
+ let nm2 = 'mkName' \"x\"
+ return ('LamE' ['VarP' nm1] (LamE [VarP nm2] ('VarE' nm1)))
+ )@
+
+ will produce the splice
+
+ >f = \x0 -> \x -> x0
+
+ In particular, the occurrence @VarE nm1@ refers to the binding @VarP nm1@,
+ and is not captured by the binding @VarP nm2@.
+
+ Although names generated by @newName@ cannot /be captured/, they can
+ /capture/ other names. For example, this:
+
+ >g = $(do
+ > nm1 <- newName "x"
+ > let nm2 = mkName "x"
+ > return (LamE [VarP nm2] (LamE [VarP nm1] (VarE nm2)))
+ > )
+
+ will produce the splice
+
+ >g = \x -> \x0 -> x0
+
+ since the occurrence @VarE nm2@ is captured by the innermost binding
+ of @x@, namely @VarP nm1@.
+ -}
+ newName :: String -> m Name
+
+instance Quote Q where
+ newName s = Q (qNewName s)
+
+-----------------------------------------------------
+--
+-- The TExp type
+--
+-----------------------------------------------------
+
+type TExp :: TYPE r -> Kind.Type
+type role TExp nominal -- See Note [Role of TExp]
+newtype TExp a = TExp
+ { unType :: Exp -- ^ Underlying untyped Template Haskell expression
+ }
+-- ^ Typed wrapper around an 'Exp'.
+--
+-- This is the typed representation of terms produced by typed quotes.
+--
+-- Representation-polymorphic since /template-haskell-2.16.0.0/.
+
+-- | Discard the type annotation and produce a plain Template Haskell
+-- expression
+--
+-- Representation-polymorphic since /template-haskell-2.16.0.0/.
+unTypeQ :: forall (r :: RuntimeRep) (a :: TYPE r) m . Quote m => m (TExp a) -> m Exp
+unTypeQ m = do { TExp e <- m
+ ; return e }
+
+-- | Annotate the Template Haskell expression with a type
+--
+-- This is unsafe because GHC cannot check for you that the expression
+-- really does have the type you claim it has.
+--
+-- Representation-polymorphic since /template-haskell-2.16.0.0/.
+unsafeTExpCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m .
+ Quote m => m Exp -> m (TExp a)
+unsafeTExpCoerce m = do { e <- m
+ ; return (TExp e) }
+
+{- Note [Role of TExp]
+~~~~~~~~~~~~~~~~~~~~~~
+TExp's argument must have a nominal role, not phantom as would
+be inferred (#8459). Consider
+
+ e :: Code Q Age
+ e = [|| MkAge 3 ||]
+
+ foo = $(coerce e) + 4::Int
+
+The splice will evaluate to (MkAge 3) and you can't add that to
+4::Int. So you can't coerce a (Code Q Age) to a (Code Q Int). -}
+
+-- Code constructor
+#if __GLASGOW_HASKELL__ >= 909
+type Code :: (Kind.Type -> Kind.Type) -> forall r. TYPE r -> Kind.Type
+ -- See Note [Foralls to the right in Code]
+#else
+type Code :: (Kind.Type -> Kind.Type) -> TYPE r -> Kind.Type
+#endif
+type role Code representational nominal -- See Note [Role of TExp]
+newtype Code m a = Code
+ { examineCode :: m (TExp a) -- ^ Underlying monadic value
+ }
+-- ^ Represents an expression which has type @a@, built in monadic context @m@. Built on top of 'TExp', typed
+-- expressions allow for type-safe splicing via:
+--
+-- - typed quotes, written as @[|| ... ||]@ where @...@ is an expression; if
+-- that expression has type @a@, then the quotation has type
+-- @Quote m => Code m a@
+--
+-- - typed splices inside of typed quotes, written as @$$(...)@ where @...@
+-- is an arbitrary expression of type @Quote m => Code m a@
+--
+-- Traditional expression quotes and splices let us construct ill-typed
+-- expressions:
+--
+-- >>> fmap ppr $ runQ (unTypeCode [| True == $( [| "foo" |] ) |])
+-- GHC.Internal.Types.True GHC.Internal.Classes.== "foo"
+-- >>> GHC.Internal.Types.True GHC.Internal.Classes.== "foo"
+-- <interactive> error:
+-- • Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
+-- • In the second argument of ‘(==)’, namely ‘"foo"’
+-- In the expression: True == "foo"
+-- In an equation for ‘it’: it = True == "foo"
+--
+-- With typed expressions, the type error occurs when /constructing/ the
+-- Template Haskell expression:
+--
+-- >>> fmap ppr $ runQ (unTypeCode [|| True == $$( [|| "foo" ||] ) ||])
+-- <interactive> error:
+-- • Couldn't match type ‘[Char]’ with ‘Bool’
+-- Expected type: Code Q Bool
+-- Actual type: Code Q [Char]
+-- • In the Template Haskell quotation [|| "foo" ||]
+-- In the expression: [|| "foo" ||]
+-- In the Template Haskell splice $$([|| "foo" ||])
+
+
+{- Note [Foralls to the right in Code]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Code has the following type signature:
+ type Code :: (Kind.Type -> Kind.Type) -> forall r. TYPE r -> Kind.Type
+
+This allows us to write
+ data T (f :: forall r . (TYPE r) -> Type) = MkT (f Int) (f Int#)
+
+ tcodeq :: T (Code Q)
+ tcodeq = MkT [||5||] [||5#||]
+
+If we used the slightly more straightforward signature
+ type Code :: foral r. (Kind.Type -> Kind.Type) -> TYPE r -> Kind.Type
+
+then the example above would become ill-typed. (See #23592 for some discussion.)
+-}
+
+-- | Unsafely convert an untyped code representation into a typed code
+-- representation.
+unsafeCodeCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m .
+ Quote m => m Exp -> Code m a
+unsafeCodeCoerce m = Code (unsafeTExpCoerce m)
+
+-- | Lift a monadic action producing code into the typed 'Code'
+-- representation
+liftCode :: forall (r :: RuntimeRep) (a :: TYPE r) m . m (TExp a) -> Code m a
+liftCode = Code
+
+-- | Extract the untyped representation from the typed representation
+unTypeCode :: forall (r :: RuntimeRep) (a :: TYPE r) m . Quote m
+ => Code m a -> m Exp
+unTypeCode = unTypeQ . examineCode
+
+-- | Modify the ambient monad used during code generation. For example, you
+-- can use `hoistCode` to handle a state effect:
+-- @
+-- handleState :: Code (StateT Int Q) a -> Code Q a
+-- handleState = hoistCode (flip runState 0)
+-- @
+hoistCode :: forall m n (r :: RuntimeRep) (a :: TYPE r) . Monad m
+ => (forall x . m x -> n x) -> Code m a -> Code n a
+hoistCode f (Code a) = Code (f a)
+
+
+-- | Variant of '(>>=)' which allows effectful computations to be injected
+-- into code generation.
+bindCode :: forall m a (r :: RuntimeRep) (b :: TYPE r) . Monad m
+ => m a -> (a -> Code m b) -> Code m b
+bindCode q k = liftCode (q >>= examineCode . k)
+
+-- | Variant of '(>>)' which allows effectful computations to be injected
+-- into code generation.
+bindCode_ :: forall m a (r :: RuntimeRep) (b :: TYPE r) . Monad m
+ => m a -> Code m b -> Code m b
+bindCode_ q c = liftCode ( q >> examineCode c)
+
+-- | A useful combinator for embedding monadic actions into 'Code'
+-- @
+-- myCode :: ... => Code m a
+-- myCode = joinCode $ do
+-- x <- someSideEffect
+-- return (makeCodeWith x)
+-- @
+joinCode :: forall m (r :: RuntimeRep) (a :: TYPE r) . Monad m
+ => m (Code m a) -> Code m a
+joinCode = flip bindCode id
+
+----------------------------------------------------
+-- Packaged versions for the programmer, hiding the Quasi-ness
+
+
+-- | Report an error (True) or warning (False),
+-- but carry on; use 'fail' to stop.
+report :: Bool -> String -> Q ()
+report b s = Q (qReport b s)
+{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6
+
+-- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'.
+reportError :: String -> Q ()
+reportError = report True
+
+-- | Report a warning to the user, and carry on.
+reportWarning :: String -> Q ()
+reportWarning = report False
+
+-- | Recover from errors raised by 'reportError' or 'fail'.
+recover :: Q a -- ^ handler to invoke on failure
+ -> Q a -- ^ computation to run
+ -> Q a
+recover (Q r) (Q m) = Q (qRecover r m)
+
+-- We don't export lookupName; the Bool isn't a great API
+-- Instead we export lookupTypeName, lookupValueName
+lookupName :: Bool -> String -> Q (Maybe Name)
+lookupName ns s = Q (qLookupName ns s)
+
+-- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
+lookupTypeName :: String -> Q (Maybe Name)
+lookupTypeName s = Q (qLookupName True s)
+
+-- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
+lookupValueName :: String -> Q (Maybe Name)
+lookupValueName s = Q (qLookupName False s)
+
+{-
+Note [Name lookup]
+~~~~~~~~~~~~~~~~~~
+-}
+{- $namelookup #namelookup#
+The functions 'lookupTypeName' and 'lookupValueName' provide
+a way to query the current splice's context for what names
+are in scope. The function 'lookupTypeName' queries the type
+namespace, whereas 'lookupValueName' queries the value namespace,
+but the functions are otherwise identical.
+
+A call @lookupValueName s@ will check if there is a value
+with name @s@ in scope at the current splice's location. If
+there is, the @Name@ of this value is returned;
+if not, then @Nothing@ is returned.
+
+The returned name cannot be \"captured\".
+For example:
+
+> f = "global"
+> g = $( do
+> Just nm <- lookupValueName "f"
+> [| let f = "local" in $( varE nm ) |]
+
+In this case, @g = \"global\"@; the call to @lookupValueName@
+returned the global @f@, and this name was /not/ captured by
+the local definition of @f@.
+
+The lookup is performed in the context of the /top-level/ splice
+being run. For example:
+
+> f = "global"
+> g = $( [| let f = "local" in
+> $(do
+> Just nm <- lookupValueName "f"
+> varE nm
+> ) |] )
+
+Again in this example, @g = \"global\"@, because the call to
+@lookupValueName@ queries the context of the outer-most @$(...)@.
+
+Operators should be queried without any surrounding parentheses, like so:
+
+> lookupValueName "+"
+
+Qualified names are also supported, like so:
+
+> lookupValueName "Prelude.+"
+> lookupValueName "Prelude.map"
+
+-}
+
+
+{- | 'reify' looks up information about the 'Name'. It will fail with
+a compile error if the 'Name' is not visible. A 'Name' is visible if it is
+imported or defined in a prior top-level declaration group. See the
+documentation for 'newDeclarationGroup' for more details.
+
+It is sometimes useful to construct the argument name using 'lookupTypeName' or 'lookupValueName'
+to ensure that we are reifying from the right namespace. For instance, in this context:
+
+> data D = D
+
+which @D@ does @reify (mkName \"D\")@ return information about? (Answer: @D@-the-type, but don't rely on it.)
+To ensure we get information about @D@-the-value, use 'lookupValueName':
+
+> do
+> Just nm <- lookupValueName "D"
+> reify nm
+
+and to get information about @D@-the-type, use 'lookupTypeName'.
+-}
+reify :: Name -> Q Info
+reify v = Q (qReify v)
+
+{- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For
+example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then
+@reifyFixity 'foo@ would return @'Just' ('Fixity' 7 'InfixR')@. If the function
+@bar@ does not have a fixity declaration, then @reifyFixity 'bar@ returns
+'Nothing', so you may assume @bar@ has 'defaultFixity'.
+-}
+reifyFixity :: Name -> Q (Maybe Fixity)
+reifyFixity nm = Q (qReifyFixity nm)
+
+{- | @reifyType nm@ attempts to find the type or kind of @nm@. For example,
+@reifyType 'not@ returns @Bool -> Bool@, and
+@reifyType ''Bool@ returns @Type@.
+This works even if there's no explicit signature and the type or kind is inferred.
+-}
+reifyType :: Name -> Q Type
+reifyType nm = Q (qReifyType nm)
+
+{- | Template Haskell is capable of reifying information about types and
+terms defined in previous declaration groups. Top-level declaration splices break up
+declaration groups.
+
+For an example, consider this code block. We define a datatype @X@ and
+then try to call 'reify' on the datatype.
+
+@
+module Check where
+
+data X = X
+ deriving Eq
+
+$(do
+ info <- reify ''X
+ runIO $ print info
+ )
+@
+
+This code fails to compile, noting that @X@ is not available for reification at the site of 'reify'. We can fix this by creating a new declaration group using an empty top-level splice:
+
+@
+data X = X
+ deriving Eq
+
+$(pure [])
+
+$(do
+ info <- reify ''X
+ runIO $ print info
+ )
+@
+
+We provide 'newDeclarationGroup' as a means of documenting this behavior
+and providing a name for the pattern.
+
+Since top level splices infer the presence of the @$( ... )@ brackets, we can also write:
+
+@
+data X = X
+ deriving Eq
+
+newDeclarationGroup
+
+$(do
+ info <- reify ''X
+ runIO $ print info
+ )
+@
+
+-}
+newDeclarationGroup :: Q [Dec]
+newDeclarationGroup = pure []
+
+{- | @reifyInstances nm tys@ returns a list of all visible instances (see below for "visible")
+of @nm tys@. That is,
+if @nm@ is the name of a type class, then all instances of this class at the types @tys@
+are returned. Alternatively, if @nm@ is the name of a data family or type family,
+all instances of this family at the types @tys@ are returned.
+
+Note that this is a \"shallow\" test; the declarations returned merely have
+instance heads which unify with @nm tys@, they need not actually be satisfiable.
+
+ - @reifyInstances ''Eq [ 'TupleT' 2 \``AppT`\` 'ConT' ''A \``AppT`\` 'ConT' ''B ]@ contains
+ the @instance (Eq a, Eq b) => Eq (a, b)@ regardless of whether @A@ and
+ @B@ themselves implement 'Eq'
+
+ - @reifyInstances ''Show [ 'VarT' ('mkName' "a") ]@ produces every available
+ instance of 'Show'
+
+There is one edge case: @reifyInstances ''Typeable tys@ currently always
+produces an empty list (no matter what @tys@ are given).
+
+In principle, the *visible* instances are
+* all instances defined in a prior top-level declaration group
+ (see docs on @newDeclarationGroup@), or
+* all instances defined in any module transitively imported by the
+ module being compiled
+
+However, actually searching all modules transitively below the one being
+compiled is unreasonably expensive, so @reifyInstances@ will report only the
+instance for modules that GHC has had some cause to visit during this
+compilation. This is a shortcoming: @reifyInstances@ might fail to report
+instances for a type that is otherwise unusued, or instances defined in a
+different component. You can work around this shortcoming by explicitly importing the modules
+whose instances you want to be visible. GHC issue <https://gitlab.haskell.org/ghc/ghc/-/issues/20529#note_388980 #20529>
+has some discussion around this.
+
+-}
+reifyInstances :: Name -> [Type] -> Q [InstanceDec]
+reifyInstances cls tys = Q (qReifyInstances cls tys)
+
+{- | @reifyRoles nm@ returns the list of roles associated with the parameters
+(both visible and invisible) of
+the tycon @nm@. Fails if @nm@ cannot be found or is not a tycon.
+The returned list should never contain 'InferR'.
+
+An invisible parameter to a tycon is often a kind parameter. For example, if
+we have
+
+@
+type Proxy :: forall k. k -> Type
+data Proxy a = MkProxy
+@
+
+and @reifyRoles Proxy@, we will get @['NominalR', 'PhantomR']@. The 'NominalR' is
+the role of the invisible @k@ parameter. Kind parameters are always nominal.
+-}
+reifyRoles :: Name -> Q [Role]
+reifyRoles nm = Q (qReifyRoles nm)
+
+-- | @reifyAnnotations target@ returns the list of annotations
+-- associated with @target@. Only the annotations that are
+-- appropriately typed is returned. So if you have @Int@ and @String@
+-- annotations for the same target, you have to call this function twice.
+reifyAnnotations :: Data a => AnnLookup -> Q [a]
+reifyAnnotations an = Q (qReifyAnnotations an)
+
+-- | @reifyModule mod@ looks up information about module @mod@. To
+-- look up the current module, call this function with the return
+-- value of 'Language.Haskell.TH.Lib.thisModule'.
+reifyModule :: Module -> Q ModuleInfo
+reifyModule m = Q (qReifyModule m)
+
+-- | @reifyConStrictness nm@ looks up the strictness information for the fields
+-- of the constructor with the name @nm@. Note that the strictness information
+-- that 'reifyConStrictness' returns may not correspond to what is written in
+-- the source code. For example, in the following data declaration:
+--
+-- @
+-- data Pair a = Pair a a
+-- @
+--
+-- 'reifyConStrictness' would return @['DecidedLazy', DecidedLazy]@ under most
+-- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the
+-- @-XStrictData@ language extension was enabled.
+reifyConStrictness :: Name -> Q [DecidedStrictness]
+reifyConStrictness n = Q (qReifyConStrictness n)
+
+-- | Is the list of instances returned by 'reifyInstances' nonempty?
+--
+-- If you're confused by an instance not being visible despite being
+-- defined in the same module and above the splice in question, see the
+-- docs for 'newDeclarationGroup' for a possible explanation.
+isInstance :: Name -> [Type] -> Q Bool
+isInstance nm tys = do { decs <- reifyInstances nm tys
+ ; return (not (null decs)) }
+
+-- | The location at which this computation is spliced.
+location :: Q Loc
+location = Q qLocation
+
+-- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad.
+-- Take care: you are guaranteed the ordering of calls to 'runIO' within
+-- a single 'Q' computation, but not about the order in which splices are run.
+--
+-- Note: for various murky reasons, stdout and stderr handles are not
+-- necessarily flushed when the compiler finishes running, so you should
+-- flush them yourself.
+runIO :: IO a -> Q a
+runIO m = Q (qRunIO m)
+
+-- | Get the package root for the current package which is being compiled.
+-- This can be set explicitly with the -package-root flag but is normally
+-- just the current working directory.
+--
+-- The motivation for this flag is to provide a principled means to remove the
+-- assumption from splices that they will be executed in the directory where the
+-- cabal file resides. Projects such as haskell-language-server can't and don't
+-- change directory when compiling files but instead set the -package-root flag
+-- appropriately.
+getPackageRoot :: Q FilePath
+getPackageRoot = Q qGetPackageRoot
+
+
+
+-- | Record external files that runIO is using (dependent upon).
+-- The compiler can then recognize that it should re-compile the Haskell file
+-- when an external file changes.
+--
+-- Expects an absolute file path.
+--
+-- Notes:
+--
+-- * ghc -M does not know about these dependencies - it does not execute TH.
+--
+-- * The dependency is based on file content, not a modification time
+addDependentFile :: FilePath -> Q ()
+addDependentFile fp = Q (qAddDependentFile fp)
+
+-- | Obtain a temporary file path with the given suffix. The compiler will
+-- delete this file after compilation.
+addTempFile :: String -> Q FilePath
+addTempFile suffix = Q (qAddTempFile suffix)
+
+-- | Add additional top-level declarations. The added declarations will be type
+-- checked along with the current declaration group.
+addTopDecls :: [Dec] -> Q ()
+addTopDecls ds = Q (qAddTopDecls ds)
+
+
+-- | Emit a foreign file which will be compiled and linked to the object for
+-- the current module. Currently only languages that can be compiled with
+-- the C compiler are supported, and the flags passed as part of -optc will
+-- be also applied to the C compiler invocation that will compile them.
+--
+-- Note that for non-C languages (for example C++) @extern "C"@ directives
+-- must be used to get symbols that we can access from Haskell.
+--
+-- To get better errors, it is recommended to use #line pragmas when
+-- emitting C files, e.g.
+--
+-- > {-# LANGUAGE CPP #-}
+-- > ...
+-- > addForeignSource LangC $ unlines
+-- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__
+-- > , ...
+-- > ]
+addForeignSource :: ForeignSrcLang -> String -> Q ()
+addForeignSource lang src = do
+ let suffix = case lang of
+ LangC -> "c"
+ LangCxx -> "cpp"
+ LangObjc -> "m"
+ LangObjcxx -> "mm"
+ LangAsm -> "s"
+ LangJs -> "js"
+ RawObject -> "a"
+ path <- addTempFile suffix
+ runIO $ writeFile path src
+ addForeignFilePath lang path
+
+-- | Same as 'addForeignSource', but expects to receive a path pointing to the
+-- foreign file instead of a 'String' of its contents. Consider using this in
+-- conjunction with 'addTempFile'.
+--
+-- This is a good alternative to 'addForeignSource' when you are trying to
+-- directly link in an object file.
+addForeignFilePath :: ForeignSrcLang -> FilePath -> Q ()
+addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp)
+
+-- | Add a finalizer that will run in the Q monad after the current module has
+-- been type checked. This only makes sense when run within a top-level splice.
+--
+-- The finalizer is given the local type environment at the splice point. Thus
+-- 'reify' is able to find the local definitions when executed inside the
+-- finalizer.
+addModFinalizer :: Q () -> Q ()
+addModFinalizer act = Q (qAddModFinalizer (unQ act))
+
+-- | Adds a core plugin to the compilation pipeline.
+--
+-- @addCorePlugin m@ has almost the same effect as passing @-fplugin=m@ to ghc
+-- in the command line. The major difference is that the plugin module @m@
+-- must not belong to the current package. When TH executes, it is too late
+-- to tell the compiler that we needed to compile first a plugin module in the
+-- current package.
+addCorePlugin :: String -> Q ()
+addCorePlugin plugin = Q (qAddCorePlugin plugin)
+
+-- | Get state from the 'Q' monad. Note that the state is local to the
+-- Haskell module in which the Template Haskell expression is executed.
+getQ :: Typeable a => Q (Maybe a)
+getQ = Q qGetQ
+
+-- | Replace the state in the 'Q' monad. Note that the state is local to the
+-- Haskell module in which the Template Haskell expression is executed.
+putQ :: Typeable a => a -> Q ()
+putQ x = Q (qPutQ x)
+
+-- | Determine whether the given language extension is enabled in the 'Q' monad.
+isExtEnabled :: Extension -> Q Bool
+isExtEnabled ext = Q (qIsExtEnabled ext)
+
+-- | List all enabled language extensions.
+extsEnabled :: Q [Extension]
+extsEnabled = Q qExtsEnabled
+
+-- | Add Haddock documentation to the specified location. This will overwrite
+-- any documentation at the location if it already exists. This will reify the
+-- specified name, so it must be in scope when you call it. If you want to add
+-- documentation to something that you are currently splicing, you can use
+-- 'addModFinalizer' e.g.
+--
+-- > do
+-- > let nm = mkName "x"
+-- > addModFinalizer $ putDoc (DeclDoc nm) "Hello"
+-- > [d| $(varP nm) = 42 |]
+--
+-- The helper functions 'withDecDoc' and 'withDecsDoc' will do this for you, as
+-- will the 'funD_doc' and other @_doc@ combinators.
+-- You most likely want to have the @-haddock@ flag turned on when using this.
+-- Adding documentation to anything outside of the current module will cause an
+-- error.
+putDoc :: DocLoc -> String -> Q ()
+putDoc t s = Q (qPutDoc t s)
+
+-- | Retrieves the Haddock documentation at the specified location, if one
+-- exists.
+-- It can be used to read documentation on things defined outside of the current
+-- module, provided that those modules were compiled with the @-haddock@ flag.
+getDoc :: DocLoc -> Q (Maybe String)
+getDoc n = Q (qGetDoc n)
+
+instance MonadIO Q where
+ liftIO = runIO
+
+instance Quasi Q where
+ qNewName = newName
+ qReport = report
+ qRecover = recover
+ qReify = reify
+ qReifyFixity = reifyFixity
+ qReifyType = reifyType
+ qReifyInstances = reifyInstances
+ qReifyRoles = reifyRoles
+ qReifyAnnotations = reifyAnnotations
+ qReifyModule = reifyModule
+ qReifyConStrictness = reifyConStrictness
+ qLookupName = lookupName
+ qLocation = location
+ qGetPackageRoot = getPackageRoot
+ qAddDependentFile = addDependentFile
+ qAddTempFile = addTempFile
+ qAddTopDecls = addTopDecls
+ qAddForeignFilePath = addForeignFilePath
+ qAddModFinalizer = addModFinalizer
+ qAddCorePlugin = addCorePlugin
+ qGetQ = getQ
+ qPutQ = putQ
+ qIsExtEnabled = isExtEnabled
+ qExtsEnabled = extsEnabled
+ qPutDoc = putDoc
+ qGetDoc = getDoc
+
+
+----------------------------------------------------
+-- The following operations are used solely in GHC.HsToCore.Quote when
+-- desugaring brackets. They are not necessary for the user, who can use
+-- ordinary return and (>>=) etc
+
+-- | This function is only used in 'GHC.HsToCore.Quote' when desugaring
+-- brackets. This is not necessary for the user, who can use the ordinary
+-- 'return' and '(>>=)' operations.
+sequenceQ :: forall m . Monad m => forall a . [m a] -> m [a]
+sequenceQ = sequence
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
=====================================
@@ -20,6 +20,7 @@ module GHC.Internal.TH.Quote(
) where
import GHC.Internal.TH.Syntax
+import GHC.Internal.TH.Monad
import GHC.Internal.Base hiding (Type)
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
=====================================
@@ -1,14 +1,20 @@
{-# OPTIONS_HADDOCK not-home #-} -- we want users to import Language.Haskell.TH.Syntax instead
-{-# LANGUAGE CPP, DeriveDataTypeable,
- DeriveGeneric, FlexibleInstances, DefaultSignatures,
- RankNTypes, RoleAnnotations, ScopedTypeVariables,
- MagicHash, KindSignatures, PolyKinds, TypeApplications, DataKinds,
- GADTs, UnboxedTuples, UnboxedSums, TypeOperators,
- Trustworthy, DeriveFunctor, DeriveTraversable,
- BangPatterns, RecordWildCards, ImplicitParams #-}
-
-{-# LANGUAGE TemplateHaskellQuotes #-}
-{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+#ifdef BOOTSTRAP_TH
+{-# LANGUAGE Trustworthy #-}
+#else
+{-# LANGUAGE Safe #-}
+#endif
+{-# LANGUAGE UnboxedTuples #-}
-- | This module is used internally in GHC's integration with Template Haskell
-- and defines the abstract syntax of Template Haskell.
@@ -26,971 +32,37 @@ module GHC.Internal.TH.Syntax
#ifdef BOOTSTRAP_TH
import Prelude
-import Data.Data hiding (Fixity(..))
-import Data.IORef
import System.IO.Unsafe ( unsafePerformIO )
-import Control.Monad.IO.Class (MonadIO (..))
-import Control.Monad.Fix (MonadFix (..))
-import Control.Exception (BlockedIndefinitelyOnMVar (..), catch, throwIO)
-import Control.Exception.Base (FixIOException (..))
-import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar)
-import System.IO ( hPutStrLn, stderr )
import Data.Char ( isAlpha, isAlphaNum, isUpper )
import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Word
-import qualified Data.Kind as Kind (Type)
import Foreign.ForeignPtr
import Foreign.C.String
import Foreign.C.Types
-import GHC.IO.Unsafe ( unsafeDupableInterleaveIO )
import GHC.Ptr ( Ptr, plusPtr )
import GHC.Generics ( Generic )
-import GHC.Types (TYPE, RuntimeRep(..))
#else
import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence)
-import GHC.Internal.Data.Data hiding (Fixity(..))
import GHC.Internal.Data.NonEmpty (NonEmpty(..))
import GHC.Internal.Data.Traversable
import GHC.Internal.Word
import GHC.Internal.Generics (Generic)
-import GHC.Internal.IORef
-import GHC.Internal.System.IO
import GHC.Internal.Show
import GHC.Internal.Integer
import GHC.Internal.Real
import GHC.Internal.Data.Foldable
import GHC.Internal.Foreign.Ptr
import GHC.Internal.ForeignPtr
-import GHC.Internal.Data.Typeable
-import GHC.Internal.Control.Monad.IO.Class
import GHC.Internal.Foreign.C.Types
import GHC.Internal.Foreign.C.String
-import GHC.Internal.Control.Monad.Fail
-import GHC.Internal.Control.Monad.Fix
-import GHC.Internal.Control.Exception
import GHC.Internal.Num
import GHC.Internal.IO.Unsafe
import GHC.Internal.List (dropWhile, break, replicate, reverse, last)
-import GHC.Internal.MVar
-import GHC.Internal.IO.Exception
import GHC.Internal.Unicode
-import qualified GHC.Internal.Types as Kind (Type)
#endif
import GHC.Internal.ForeignSrcLang
import GHC.Internal.LanguageExtensions
------------------------------------------------------
---
--- The Quasi class
---
------------------------------------------------------
-
-class (MonadIO m, MonadFail m) => Quasi m where
- -- | Fresh names. See 'newName'.
- qNewName :: String -> m Name
-
- ------- Error reporting and recovery -------
- -- | Report an error (True) or warning (False)
- -- ...but carry on; use 'fail' to stop. See 'report'.
- qReport :: Bool -> String -> m ()
-
- -- | See 'recover'.
- qRecover :: m a -- ^ the error handler
- -> m a -- ^ action which may fail
- -> m a -- ^ Recover from the monadic 'fail'
-
- ------- Inspect the type-checker's environment -------
- -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
- qLookupName :: Bool -> String -> m (Maybe Name)
- -- | See 'reify'.
- qReify :: Name -> m Info
- -- | See 'reifyFixity'.
- qReifyFixity :: Name -> m (Maybe Fixity)
- -- | See 'reifyType'.
- qReifyType :: Name -> m Type
- -- | Is (n tys) an instance? Returns list of matching instance Decs (with
- -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
- qReifyInstances :: Name -> [Type] -> m [Dec]
- -- | See 'reifyRoles'.
- qReifyRoles :: Name -> m [Role]
- -- | See 'reifyAnnotations'.
- qReifyAnnotations :: Data a => AnnLookup -> m [a]
- -- | See 'reifyModule'.
- qReifyModule :: Module -> m ModuleInfo
- -- | See 'reifyConStrictness'.
- qReifyConStrictness :: Name -> m [DecidedStrictness]
-
- -- | See 'location'.
- qLocation :: m Loc
-
- -- | Input/output (dangerous). See 'runIO'.
- qRunIO :: IO a -> m a
- qRunIO = liftIO
- -- | See 'getPackageRoot'.
- qGetPackageRoot :: m FilePath
-
- -- | See 'addDependentFile'.
- qAddDependentFile :: FilePath -> m ()
-
- -- | See 'addTempFile'.
- qAddTempFile :: String -> m FilePath
-
- -- | See 'addTopDecls'.
- qAddTopDecls :: [Dec] -> m ()
-
- -- | See 'addForeignFilePath'.
- qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
-
- -- | See 'addModFinalizer'.
- qAddModFinalizer :: Q () -> m ()
-
- -- | See 'addCorePlugin'.
- qAddCorePlugin :: String -> m ()
-
- -- | See 'getQ'.
- qGetQ :: Typeable a => m (Maybe a)
-
- -- | See 'putQ'.
- qPutQ :: Typeable a => a -> m ()
-
- -- | See 'isExtEnabled'.
- qIsExtEnabled :: Extension -> m Bool
- -- | See 'extsEnabled'.
- qExtsEnabled :: m [Extension]
-
- -- | See 'putDoc'.
- qPutDoc :: DocLoc -> String -> m ()
- -- | See 'getDoc'.
- qGetDoc :: DocLoc -> m (Maybe String)
-
------------------------------------------------------
--- The IO instance of Quasi
------------------------------------------------------
-
--- | This instance is used only when running a Q
--- computation in the IO monad, usually just to
--- print the result. There is no interesting
--- type environment, so reification isn't going to
--- work.
-instance Quasi IO where
- qNewName = newNameIO
-
- qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
- qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
-
- qLookupName _ _ = badIO "lookupName"
- qReify _ = badIO "reify"
- qReifyFixity _ = badIO "reifyFixity"
- qReifyType _ = badIO "reifyFixity"
- qReifyInstances _ _ = badIO "reifyInstances"
- qReifyRoles _ = badIO "reifyRoles"
- qReifyAnnotations _ = badIO "reifyAnnotations"
- qReifyModule _ = badIO "reifyModule"
- qReifyConStrictness _ = badIO "reifyConStrictness"
- qLocation = badIO "currentLocation"
- qRecover _ _ = badIO "recover" -- Maybe we could fix this?
- qGetPackageRoot = badIO "getProjectRoot"
- qAddDependentFile _ = badIO "addDependentFile"
- qAddTempFile _ = badIO "addTempFile"
- qAddTopDecls _ = badIO "addTopDecls"
- qAddForeignFilePath _ _ = badIO "addForeignFilePath"
- qAddModFinalizer _ = badIO "addModFinalizer"
- qAddCorePlugin _ = badIO "addCorePlugin"
- qGetQ = badIO "getQ"
- qPutQ _ = badIO "putQ"
- qIsExtEnabled _ = badIO "isExtEnabled"
- qExtsEnabled = badIO "extsEnabled"
- qPutDoc _ _ = badIO "putDoc"
- qGetDoc _ = badIO "getDoc"
-
-instance Quote IO where
- newName = newNameIO
-
-newNameIO :: String -> IO Name
-newNameIO s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x))
- ; pure (mkNameU s n) }
-
-badIO :: String -> IO a
-badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad")
- ; fail "Template Haskell failure" }
-
--- Global variable to generate unique symbols
-counter :: IORef Uniq
-{-# NOINLINE counter #-}
-counter = unsafePerformIO (newIORef 0)
-
-
------------------------------------------------------
---
--- The Q monad
---
------------------------------------------------------
-
--- | In short, 'Q' provides the 'Quasi' operations in one neat monad for the
--- user.
---
--- The longer story, is that 'Q' wraps an arbitrary 'Quasi'-able monad.
--- The perceptive reader notices that 'Quasi' has only two instances, 'Q'
--- itself and 'IO', neither of which have concrete implementations.'Q' plays
--- the trick of [dependency
--- inversion](https://en.wikipedia.org/wiki/Dependency_inversion_principle),
--- providing an abstract interface for the user which is later concretely
--- fufilled by an concrete 'Quasi' instance, internal to GHC.
-newtype Q a = Q { unQ :: forall m. Quasi m => m a }
-
--- | \"Runs\" the 'Q' monad. Normal users of Template Haskell
--- should not need this function, as the splice brackets @$( ... )@
--- are the usual way of running a 'Q' computation.
---
--- This function is primarily used in GHC internals, and for debugging
--- splices by running them in 'IO'.
---
--- Note that many functions in 'Q', such as 'reify' and other compiler
--- queries, are not supported when running 'Q' in 'IO'; these operations
--- simply fail at runtime. Indeed, the only operations guaranteed to succeed
--- are 'newName', 'runIO', 'reportError' and 'reportWarning'.
-runQ :: Quasi m => Q a -> m a
-runQ (Q m) = m
-
-instance Monad Q where
- Q m >>= k = Q (m >>= \x -> unQ (k x))
- (>>) = (*>)
-
-instance MonadFail Q where
- fail s = report True s >> Q (fail "Q monad failure")
-
-instance Functor Q where
- fmap f (Q x) = Q (fmap f x)
-
-instance Applicative Q where
- pure x = Q (pure x)
- Q f <*> Q x = Q (f <*> x)
- Q m *> Q n = Q (m *> n)
-
--- | @since 2.17.0.0
-instance Semigroup a => Semigroup (Q a) where
- (<>) = liftA2 (<>)
-
--- | @since 2.17.0.0
-instance Monoid a => Monoid (Q a) where
- mempty = pure mempty
-
--- | If the function passed to 'mfix' inspects its argument,
--- the resulting action will throw a 'FixIOException'.
---
--- @since 2.17.0.0
-instance MonadFix Q where
- -- We use the same blackholing approach as in fixIO.
- -- See Note [Blackholing in fixIO] in System.IO in base.
- mfix k = do
- m <- runIO newEmptyMVar
- ans <- runIO (unsafeDupableInterleaveIO
- (readMVar m `catch` \BlockedIndefinitelyOnMVar ->
- throwIO FixIOException))
- result <- k ans
- runIO (putMVar m result)
- return result
-
-
------------------------------------------------------
---
--- The Quote class
---
------------------------------------------------------
-
-
-
--- | The 'Quote' class implements the minimal interface which is necessary for
--- desugaring quotations.
---
--- * The @Monad m@ superclass is needed to stitch together the different
--- AST fragments.
--- * 'newName' is used when desugaring binding structures such as lambdas
--- to generate fresh names.
---
--- Therefore the type of an untyped quotation in GHC is `Quote m => m Exp`
---
--- For many years the type of a quotation was fixed to be `Q Exp` but by
--- more precisely specifying the minimal interface it enables the `Exp` to
--- be extracted purely from the quotation without interacting with `Q`.
-class Monad m => Quote m where
- {- |
- Generate a fresh name, which cannot be captured.
-
- For example, this:
-
- @f = $(do
- nm1 <- newName \"x\"
- let nm2 = 'mkName' \"x\"
- return ('LamE' ['VarP' nm1] (LamE [VarP nm2] ('VarE' nm1)))
- )@
-
- will produce the splice
-
- >f = \x0 -> \x -> x0
-
- In particular, the occurrence @VarE nm1@ refers to the binding @VarP nm1@,
- and is not captured by the binding @VarP nm2@.
-
- Although names generated by @newName@ cannot /be captured/, they can
- /capture/ other names. For example, this:
-
- >g = $(do
- > nm1 <- newName "x"
- > let nm2 = mkName "x"
- > return (LamE [VarP nm2] (LamE [VarP nm1] (VarE nm2)))
- > )
-
- will produce the splice
-
- >g = \x -> \x0 -> x0
-
- since the occurrence @VarE nm2@ is captured by the innermost binding
- of @x@, namely @VarP nm1@.
- -}
- newName :: String -> m Name
-
-instance Quote Q where
- newName s = Q (qNewName s)
-
------------------------------------------------------
---
--- The TExp type
---
------------------------------------------------------
-
-type TExp :: TYPE r -> Kind.Type
-type role TExp nominal -- See Note [Role of TExp]
-newtype TExp a = TExp
- { unType :: Exp -- ^ Underlying untyped Template Haskell expression
- }
--- ^ Typed wrapper around an 'Exp'.
---
--- This is the typed representation of terms produced by typed quotes.
---
--- Representation-polymorphic since /template-haskell-2.16.0.0/.
-
--- | Discard the type annotation and produce a plain Template Haskell
--- expression
---
--- Representation-polymorphic since /template-haskell-2.16.0.0/.
-unTypeQ :: forall (r :: RuntimeRep) (a :: TYPE r) m . Quote m => m (TExp a) -> m Exp
-unTypeQ m = do { TExp e <- m
- ; return e }
-
--- | Annotate the Template Haskell expression with a type
---
--- This is unsafe because GHC cannot check for you that the expression
--- really does have the type you claim it has.
---
--- Representation-polymorphic since /template-haskell-2.16.0.0/.
-unsafeTExpCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m .
- Quote m => m Exp -> m (TExp a)
-unsafeTExpCoerce m = do { e <- m
- ; return (TExp e) }
-
-{- Note [Role of TExp]
-~~~~~~~~~~~~~~~~~~~~~~
-TExp's argument must have a nominal role, not phantom as would
-be inferred (#8459). Consider
-
- e :: Code Q Age
- e = [|| MkAge 3 ||]
-
- foo = $(coerce e) + 4::Int
-
-The splice will evaluate to (MkAge 3) and you can't add that to
-4::Int. So you can't coerce a (Code Q Age) to a (Code Q Int). -}
-
--- Code constructor
-#if __GLASGOW_HASKELL__ >= 909
-type Code :: (Kind.Type -> Kind.Type) -> forall r. TYPE r -> Kind.Type
- -- See Note [Foralls to the right in Code]
-#else
-type Code :: (Kind.Type -> Kind.Type) -> TYPE r -> Kind.Type
-#endif
-type role Code representational nominal -- See Note [Role of TExp]
-newtype Code m a = Code
- { examineCode :: m (TExp a) -- ^ Underlying monadic value
- }
--- ^ Represents an expression which has type @a@, built in monadic context @m@. Built on top of 'TExp', typed
--- expressions allow for type-safe splicing via:
---
--- - typed quotes, written as @[|| ... ||]@ where @...@ is an expression; if
--- that expression has type @a@, then the quotation has type
--- @Quote m => Code m a@
---
--- - typed splices inside of typed quotes, written as @$$(...)@ where @...@
--- is an arbitrary expression of type @Quote m => Code m a@
---
--- Traditional expression quotes and splices let us construct ill-typed
--- expressions:
---
--- >>> fmap ppr $ runQ (unTypeCode [| True == $( [| "foo" |] ) |])
--- GHC.Internal.Types.True GHC.Internal.Classes.== "foo"
--- >>> GHC.Internal.Types.True GHC.Internal.Classes.== "foo"
--- <interactive> error:
--- • Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
--- • In the second argument of ‘(==)’, namely ‘"foo"’
--- In the expression: True == "foo"
--- In an equation for ‘it’: it = True == "foo"
---
--- With typed expressions, the type error occurs when /constructing/ the
--- Template Haskell expression:
---
--- >>> fmap ppr $ runQ (unTypeCode [|| True == $$( [|| "foo" ||] ) ||])
--- <interactive> error:
--- • Couldn't match type ‘[Char]’ with ‘Bool’
--- Expected type: Code Q Bool
--- Actual type: Code Q [Char]
--- • In the Template Haskell quotation [|| "foo" ||]
--- In the expression: [|| "foo" ||]
--- In the Template Haskell splice $$([|| "foo" ||])
-
-
-{- Note [Foralls to the right in Code]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Code has the following type signature:
- type Code :: (Kind.Type -> Kind.Type) -> forall r. TYPE r -> Kind.Type
-
-This allows us to write
- data T (f :: forall r . (TYPE r) -> Type) = MkT (f Int) (f Int#)
-
- tcodeq :: T (Code Q)
- tcodeq = MkT [||5||] [||5#||]
-
-If we used the slightly more straightforward signature
- type Code :: foral r. (Kind.Type -> Kind.Type) -> TYPE r -> Kind.Type
-
-then the example above would become ill-typed. (See #23592 for some discussion.)
--}
-
--- | Unsafely convert an untyped code representation into a typed code
--- representation.
-unsafeCodeCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m .
- Quote m => m Exp -> Code m a
-unsafeCodeCoerce m = Code (unsafeTExpCoerce m)
-
--- | Lift a monadic action producing code into the typed 'Code'
--- representation
-liftCode :: forall (r :: RuntimeRep) (a :: TYPE r) m . m (TExp a) -> Code m a
-liftCode = Code
-
--- | Extract the untyped representation from the typed representation
-unTypeCode :: forall (r :: RuntimeRep) (a :: TYPE r) m . Quote m
- => Code m a -> m Exp
-unTypeCode = unTypeQ . examineCode
-
--- | Modify the ambient monad used during code generation. For example, you
--- can use `hoistCode` to handle a state effect:
--- @
--- handleState :: Code (StateT Int Q) a -> Code Q a
--- handleState = hoistCode (flip runState 0)
--- @
-hoistCode :: forall m n (r :: RuntimeRep) (a :: TYPE r) . Monad m
- => (forall x . m x -> n x) -> Code m a -> Code n a
-hoistCode f (Code a) = Code (f a)
-
-
--- | Variant of '(>>=)' which allows effectful computations to be injected
--- into code generation.
-bindCode :: forall m a (r :: RuntimeRep) (b :: TYPE r) . Monad m
- => m a -> (a -> Code m b) -> Code m b
-bindCode q k = liftCode (q >>= examineCode . k)
-
--- | Variant of '(>>)' which allows effectful computations to be injected
--- into code generation.
-bindCode_ :: forall m a (r :: RuntimeRep) (b :: TYPE r) . Monad m
- => m a -> Code m b -> Code m b
-bindCode_ q c = liftCode ( q >> examineCode c)
-
--- | A useful combinator for embedding monadic actions into 'Code'
--- @
--- myCode :: ... => Code m a
--- myCode = joinCode $ do
--- x <- someSideEffect
--- return (makeCodeWith x)
--- @
-joinCode :: forall m (r :: RuntimeRep) (a :: TYPE r) . Monad m
- => m (Code m a) -> Code m a
-joinCode = flip bindCode id
-
-----------------------------------------------------
--- Packaged versions for the programmer, hiding the Quasi-ness
-
-
--- | Report an error (True) or warning (False),
--- but carry on; use 'fail' to stop.
-report :: Bool -> String -> Q ()
-report b s = Q (qReport b s)
-{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6
-
--- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'.
-reportError :: String -> Q ()
-reportError = report True
-
--- | Report a warning to the user, and carry on.
-reportWarning :: String -> Q ()
-reportWarning = report False
-
--- | Recover from errors raised by 'reportError' or 'fail'.
-recover :: Q a -- ^ handler to invoke on failure
- -> Q a -- ^ computation to run
- -> Q a
-recover (Q r) (Q m) = Q (qRecover r m)
-
--- We don't export lookupName; the Bool isn't a great API
--- Instead we export lookupTypeName, lookupValueName
-lookupName :: Bool -> String -> Q (Maybe Name)
-lookupName ns s = Q (qLookupName ns s)
-
--- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
-lookupTypeName :: String -> Q (Maybe Name)
-lookupTypeName s = Q (qLookupName True s)
-
--- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
-lookupValueName :: String -> Q (Maybe Name)
-lookupValueName s = Q (qLookupName False s)
-
-{-
-Note [Name lookup]
-~~~~~~~~~~~~~~~~~~
--}
-{- $namelookup #namelookup#
-The functions 'lookupTypeName' and 'lookupValueName' provide
-a way to query the current splice's context for what names
-are in scope. The function 'lookupTypeName' queries the type
-namespace, whereas 'lookupValueName' queries the value namespace,
-but the functions are otherwise identical.
-
-A call @lookupValueName s@ will check if there is a value
-with name @s@ in scope at the current splice's location. If
-there is, the @Name@ of this value is returned;
-if not, then @Nothing@ is returned.
-
-The returned name cannot be \"captured\".
-For example:
-
-> f = "global"
-> g = $( do
-> Just nm <- lookupValueName "f"
-> [| let f = "local" in $( varE nm ) |]
-
-In this case, @g = \"global\"@; the call to @lookupValueName@
-returned the global @f@, and this name was /not/ captured by
-the local definition of @f@.
-
-The lookup is performed in the context of the /top-level/ splice
-being run. For example:
-
-> f = "global"
-> g = $( [| let f = "local" in
-> $(do
-> Just nm <- lookupValueName "f"
-> varE nm
-> ) |] )
-
-Again in this example, @g = \"global\"@, because the call to
-@lookupValueName@ queries the context of the outer-most @$(...)@.
-
-Operators should be queried without any surrounding parentheses, like so:
-
-> lookupValueName "+"
-
-Qualified names are also supported, like so:
-
-> lookupValueName "Prelude.+"
-> lookupValueName "Prelude.map"
-
--}
-
-
-{- | 'reify' looks up information about the 'Name'. It will fail with
-a compile error if the 'Name' is not visible. A 'Name' is visible if it is
-imported or defined in a prior top-level declaration group. See the
-documentation for 'newDeclarationGroup' for more details.
-
-It is sometimes useful to construct the argument name using 'lookupTypeName' or 'lookupValueName'
-to ensure that we are reifying from the right namespace. For instance, in this context:
-
-> data D = D
-
-which @D@ does @reify (mkName \"D\")@ return information about? (Answer: @D@-the-type, but don't rely on it.)
-To ensure we get information about @D@-the-value, use 'lookupValueName':
-
-> do
-> Just nm <- lookupValueName "D"
-> reify nm
-
-and to get information about @D@-the-type, use 'lookupTypeName'.
--}
-reify :: Name -> Q Info
-reify v = Q (qReify v)
-
-{- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For
-example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then
-@reifyFixity 'foo@ would return @'Just' ('Fixity' 7 'InfixR')@. If the function
-@bar@ does not have a fixity declaration, then @reifyFixity 'bar@ returns
-'Nothing', so you may assume @bar@ has 'defaultFixity'.
--}
-reifyFixity :: Name -> Q (Maybe Fixity)
-reifyFixity nm = Q (qReifyFixity nm)
-
-{- | @reifyType nm@ attempts to find the type or kind of @nm@. For example,
-@reifyType 'not@ returns @Bool -> Bool@, and
-@reifyType ''Bool@ returns @Type@.
-This works even if there's no explicit signature and the type or kind is inferred.
--}
-reifyType :: Name -> Q Type
-reifyType nm = Q (qReifyType nm)
-
-{- | Template Haskell is capable of reifying information about types and
-terms defined in previous declaration groups. Top-level declaration splices break up
-declaration groups.
-
-For an example, consider this code block. We define a datatype @X@ and
-then try to call 'reify' on the datatype.
-
-@
-module Check where
-
-data X = X
- deriving Eq
-
-$(do
- info <- reify ''X
- runIO $ print info
- )
-@
-
-This code fails to compile, noting that @X@ is not available for reification at the site of 'reify'. We can fix this by creating a new declaration group using an empty top-level splice:
-
-@
-data X = X
- deriving Eq
-
-$(pure [])
-
-$(do
- info <- reify ''X
- runIO $ print info
- )
-@
-
-We provide 'newDeclarationGroup' as a means of documenting this behavior
-and providing a name for the pattern.
-
-Since top level splices infer the presence of the @$( ... )@ brackets, we can also write:
-
-@
-data X = X
- deriving Eq
-
-newDeclarationGroup
-
-$(do
- info <- reify ''X
- runIO $ print info
- )
-@
-
--}
-newDeclarationGroup :: Q [Dec]
-newDeclarationGroup = pure []
-
-{- | @reifyInstances nm tys@ returns a list of all visible instances (see below for "visible")
-of @nm tys@. That is,
-if @nm@ is the name of a type class, then all instances of this class at the types @tys@
-are returned. Alternatively, if @nm@ is the name of a data family or type family,
-all instances of this family at the types @tys@ are returned.
-
-Note that this is a \"shallow\" test; the declarations returned merely have
-instance heads which unify with @nm tys@, they need not actually be satisfiable.
-
- - @reifyInstances ''Eq [ 'TupleT' 2 \``AppT`\` 'ConT' ''A \``AppT`\` 'ConT' ''B ]@ contains
- the @instance (Eq a, Eq b) => Eq (a, b)@ regardless of whether @A@ and
- @B@ themselves implement 'Eq'
-
- - @reifyInstances ''Show [ 'VarT' ('mkName' "a") ]@ produces every available
- instance of 'Show'
-
-There is one edge case: @reifyInstances ''Typeable tys@ currently always
-produces an empty list (no matter what @tys@ are given).
-
-In principle, the *visible* instances are
-* all instances defined in a prior top-level declaration group
- (see docs on @newDeclarationGroup@), or
-* all instances defined in any module transitively imported by the
- module being compiled
-
-However, actually searching all modules transitively below the one being
-compiled is unreasonably expensive, so @reifyInstances@ will report only the
-instance for modules that GHC has had some cause to visit during this
-compilation. This is a shortcoming: @reifyInstances@ might fail to report
-instances for a type that is otherwise unusued, or instances defined in a
-different component. You can work around this shortcoming by explicitly importing the modules
-whose instances you want to be visible. GHC issue <https://gitlab.haskell.org/ghc/ghc/-/issues/20529#note_388980 #20529>
-has some discussion around this.
-
--}
-reifyInstances :: Name -> [Type] -> Q [InstanceDec]
-reifyInstances cls tys = Q (qReifyInstances cls tys)
-
-{- | @reifyRoles nm@ returns the list of roles associated with the parameters
-(both visible and invisible) of
-the tycon @nm@. Fails if @nm@ cannot be found or is not a tycon.
-The returned list should never contain 'InferR'.
-
-An invisible parameter to a tycon is often a kind parameter. For example, if
-we have
-
-@
-type Proxy :: forall k. k -> Type
-data Proxy a = MkProxy
-@
-
-and @reifyRoles Proxy@, we will get @['NominalR', 'PhantomR']@. The 'NominalR' is
-the role of the invisible @k@ parameter. Kind parameters are always nominal.
--}
-reifyRoles :: Name -> Q [Role]
-reifyRoles nm = Q (qReifyRoles nm)
-
--- | @reifyAnnotations target@ returns the list of annotations
--- associated with @target@. Only the annotations that are
--- appropriately typed is returned. So if you have @Int@ and @String@
--- annotations for the same target, you have to call this function twice.
-reifyAnnotations :: Data a => AnnLookup -> Q [a]
-reifyAnnotations an = Q (qReifyAnnotations an)
-
--- | @reifyModule mod@ looks up information about module @mod@. To
--- look up the current module, call this function with the return
--- value of 'Language.Haskell.TH.Lib.thisModule'.
-reifyModule :: Module -> Q ModuleInfo
-reifyModule m = Q (qReifyModule m)
-
--- | @reifyConStrictness nm@ looks up the strictness information for the fields
--- of the constructor with the name @nm@. Note that the strictness information
--- that 'reifyConStrictness' returns may not correspond to what is written in
--- the source code. For example, in the following data declaration:
---
--- @
--- data Pair a = Pair a a
--- @
---
--- 'reifyConStrictness' would return @['DecidedLazy', DecidedLazy]@ under most
--- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the
--- @-XStrictData@ language extension was enabled.
-reifyConStrictness :: Name -> Q [DecidedStrictness]
-reifyConStrictness n = Q (qReifyConStrictness n)
-
--- | Is the list of instances returned by 'reifyInstances' nonempty?
---
--- If you're confused by an instance not being visible despite being
--- defined in the same module and above the splice in question, see the
--- docs for 'newDeclarationGroup' for a possible explanation.
-isInstance :: Name -> [Type] -> Q Bool
-isInstance nm tys = do { decs <- reifyInstances nm tys
- ; return (not (null decs)) }
-
--- | The location at which this computation is spliced.
-location :: Q Loc
-location = Q qLocation
-
--- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad.
--- Take care: you are guaranteed the ordering of calls to 'runIO' within
--- a single 'Q' computation, but not about the order in which splices are run.
---
--- Note: for various murky reasons, stdout and stderr handles are not
--- necessarily flushed when the compiler finishes running, so you should
--- flush them yourself.
-runIO :: IO a -> Q a
-runIO m = Q (qRunIO m)
-
--- | Get the package root for the current package which is being compiled.
--- This can be set explicitly with the -package-root flag but is normally
--- just the current working directory.
---
--- The motivation for this flag is to provide a principled means to remove the
--- assumption from splices that they will be executed in the directory where the
--- cabal file resides. Projects such as haskell-language-server can't and don't
--- change directory when compiling files but instead set the -package-root flag
--- appropriately.
-getPackageRoot :: Q FilePath
-getPackageRoot = Q qGetPackageRoot
-
-
-
--- | Record external files that runIO is using (dependent upon).
--- The compiler can then recognize that it should re-compile the Haskell file
--- when an external file changes.
---
--- Expects an absolute file path.
---
--- Notes:
---
--- * ghc -M does not know about these dependencies - it does not execute TH.
---
--- * The dependency is based on file content, not a modification time
-addDependentFile :: FilePath -> Q ()
-addDependentFile fp = Q (qAddDependentFile fp)
-
--- | Obtain a temporary file path with the given suffix. The compiler will
--- delete this file after compilation.
-addTempFile :: String -> Q FilePath
-addTempFile suffix = Q (qAddTempFile suffix)
-
--- | Add additional top-level declarations. The added declarations will be type
--- checked along with the current declaration group.
-addTopDecls :: [Dec] -> Q ()
-addTopDecls ds = Q (qAddTopDecls ds)
-
-
--- | Emit a foreign file which will be compiled and linked to the object for
--- the current module. Currently only languages that can be compiled with
--- the C compiler are supported, and the flags passed as part of -optc will
--- be also applied to the C compiler invocation that will compile them.
---
--- Note that for non-C languages (for example C++) @extern "C"@ directives
--- must be used to get symbols that we can access from Haskell.
---
--- To get better errors, it is recommended to use #line pragmas when
--- emitting C files, e.g.
---
--- > {-# LANGUAGE CPP #-}
--- > ...
--- > addForeignSource LangC $ unlines
--- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__
--- > , ...
--- > ]
-addForeignSource :: ForeignSrcLang -> String -> Q ()
-addForeignSource lang src = do
- let suffix = case lang of
- LangC -> "c"
- LangCxx -> "cpp"
- LangObjc -> "m"
- LangObjcxx -> "mm"
- LangAsm -> "s"
- LangJs -> "js"
- RawObject -> "a"
- path <- addTempFile suffix
- runIO $ writeFile path src
- addForeignFilePath lang path
-
--- | Same as 'addForeignSource', but expects to receive a path pointing to the
--- foreign file instead of a 'String' of its contents. Consider using this in
--- conjunction with 'addTempFile'.
---
--- This is a good alternative to 'addForeignSource' when you are trying to
--- directly link in an object file.
-addForeignFilePath :: ForeignSrcLang -> FilePath -> Q ()
-addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp)
-
--- | Add a finalizer that will run in the Q monad after the current module has
--- been type checked. This only makes sense when run within a top-level splice.
---
--- The finalizer is given the local type environment at the splice point. Thus
--- 'reify' is able to find the local definitions when executed inside the
--- finalizer.
-addModFinalizer :: Q () -> Q ()
-addModFinalizer act = Q (qAddModFinalizer (unQ act))
-
--- | Adds a core plugin to the compilation pipeline.
---
--- @addCorePlugin m@ has almost the same effect as passing @-fplugin=m@ to ghc
--- in the command line. The major difference is that the plugin module @m@
--- must not belong to the current package. When TH executes, it is too late
--- to tell the compiler that we needed to compile first a plugin module in the
--- current package.
-addCorePlugin :: String -> Q ()
-addCorePlugin plugin = Q (qAddCorePlugin plugin)
-
--- | Get state from the 'Q' monad. Note that the state is local to the
--- Haskell module in which the Template Haskell expression is executed.
-getQ :: Typeable a => Q (Maybe a)
-getQ = Q qGetQ
-
--- | Replace the state in the 'Q' monad. Note that the state is local to the
--- Haskell module in which the Template Haskell expression is executed.
-putQ :: Typeable a => a -> Q ()
-putQ x = Q (qPutQ x)
-
--- | Determine whether the given language extension is enabled in the 'Q' monad.
-isExtEnabled :: Extension -> Q Bool
-isExtEnabled ext = Q (qIsExtEnabled ext)
-
--- | List all enabled language extensions.
-extsEnabled :: Q [Extension]
-extsEnabled = Q qExtsEnabled
-
--- | Add Haddock documentation to the specified location. This will overwrite
--- any documentation at the location if it already exists. This will reify the
--- specified name, so it must be in scope when you call it. If you want to add
--- documentation to something that you are currently splicing, you can use
--- 'addModFinalizer' e.g.
---
--- > do
--- > let nm = mkName "x"
--- > addModFinalizer $ putDoc (DeclDoc nm) "Hello"
--- > [d| $(varP nm) = 42 |]
---
--- The helper functions 'withDecDoc' and 'withDecsDoc' will do this for you, as
--- will the 'funD_doc' and other @_doc@ combinators.
--- You most likely want to have the @-haddock@ flag turned on when using this.
--- Adding documentation to anything outside of the current module will cause an
--- error.
-putDoc :: DocLoc -> String -> Q ()
-putDoc t s = Q (qPutDoc t s)
-
--- | Retrieves the Haddock documentation at the specified location, if one
--- exists.
--- It can be used to read documentation on things defined outside of the current
--- module, provided that those modules were compiled with the @-haddock@ flag.
-getDoc :: DocLoc -> Q (Maybe String)
-getDoc n = Q (qGetDoc n)
-
-instance MonadIO Q where
- liftIO = runIO
-
-instance Quasi Q where
- qNewName = newName
- qReport = report
- qRecover = recover
- qReify = reify
- qReifyFixity = reifyFixity
- qReifyType = reifyType
- qReifyInstances = reifyInstances
- qReifyRoles = reifyRoles
- qReifyAnnotations = reifyAnnotations
- qReifyModule = reifyModule
- qReifyConStrictness = reifyConStrictness
- qLookupName = lookupName
- qLocation = location
- qGetPackageRoot = getPackageRoot
- qAddDependentFile = addDependentFile
- qAddTempFile = addTempFile
- qAddTopDecls = addTopDecls
- qAddForeignFilePath = addForeignFilePath
- qAddModFinalizer = addModFinalizer
- qAddCorePlugin = addCorePlugin
- qGetQ = getQ
- qPutQ = putQ
- qIsExtEnabled = isExtEnabled
- qExtsEnabled = extsEnabled
- qPutDoc = putDoc
- qGetDoc = getDoc
-
-
-----------------------------------------------------
--- The following operations are used solely in GHC.HsToCore.Quote when
--- desugaring brackets. They are not necessary for the user, who can use
--- ordinary return and (>>=) etc
-
--- | This function is only used in 'GHC.HsToCore.Quote' when desugaring
--- brackets. This is not necessary for the user, who can use the ordinary
--- 'return' and '(>>=)' operations.
-sequenceQ :: forall m . Monad m => forall a . [m a] -> m [a]
-sequenceQ = sequence
-
oneName, manyName :: Name
-- | Synonym for @''GHC.Internal.Types.One'@, from @ghc-internal@.
oneName = mkNameG DataName "ghc-internal" "GHC.Internal.Types" "One"
@@ -1004,19 +76,19 @@ manyName = mkNameG DataName "ghc-internal" "GHC.Internal.Types" "Many"
-- | The name of a module.
newtype ModName = ModName String -- Module name
- deriving (Show,Eq,Ord,Data,Generic)
+ deriving (Show,Eq,Ord,Generic)
-- | The name of a package.
newtype PkgName = PkgName String -- package name
- deriving (Show,Eq,Ord,Data,Generic)
+ deriving (Show,Eq,Ord,Generic)
-- | Obtained from 'reifyModule' and 'Language.Haskell.TH.Lib.thisModule'.
data Module = Module PkgName ModName -- package qualified module name
- deriving (Show,Eq,Ord,Data,Generic)
+ deriving (Show,Eq,Ord,Generic)
-- | An "Occurence Name".
newtype OccName = OccName String
- deriving (Show,Eq,Ord,Data,Generic)
+ deriving (Show,Eq,Ord,Generic)
-- | Smart constructor for 'ModName'
mkModName :: String -> ModName
@@ -1132,7 +204,7 @@ Names constructed using @newName@ and @mkName@ may be used in bindings
(such as @let x = ...@ or @\x -> ...@), but names constructed using
@lookupValueName@, @lookupTypeName@, @'f@, @''T@ may not.
-}
-data Name = Name OccName NameFlavour deriving (Data, Eq, Generic)
+data Name = Name OccName NameFlavour deriving (Eq, Generic)
instance Ord Name where
-- check if unique is different before looking at strings
@@ -1148,7 +220,7 @@ data NameFlavour
-- An original name (occurrences only, not binders)
-- Need the namespace too to be sure which
-- thing we are naming
- deriving ( Data, Eq, Ord, Show, Generic )
+ deriving ( Eq, Ord, Show, Generic )
data NameSpace = VarName -- ^ Variables
| DataName -- ^ Data constructors
@@ -1162,7 +234,7 @@ data NameSpace = VarName -- ^ Variables
-- of the datatype (regardless of whether this constructor has this field).
-- - For a field of a pattern synonym, this is the name of the pattern synonym.
}
- deriving( Eq, Ord, Show, Data, Generic )
+ deriving( Eq, Ord, Show, Generic )
-- | @Uniq@ is used by GHC to distinguish names from each other.
type Uniq = Integer
@@ -1464,7 +536,7 @@ data Loc
, loc_module :: String
, loc_start :: CharPos
, loc_end :: CharPos }
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
type CharPos = (Int, Int) -- ^ Line and character position
@@ -1547,13 +619,13 @@ data Info
| TyVarI -- Scoped type variable
Name
Type -- What it is bound to
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | Obtained from 'reifyModule' in the 'Q' Monad.
data ModuleInfo =
-- | Contains the import list of the module.
ModuleInfo [Module]
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
{- |
In 'ClassOpI' and 'DataConI', name of the parent class or type
@@ -1591,11 +663,11 @@ type InstanceDec = Dec
-- | Fixity, as specified in a @infix[lr] n@ declaration.
data Fixity = Fixity Int FixityDirection
- deriving( Eq, Ord, Show, Data, Generic )
+ deriving( Eq, Ord, Show, Generic )
-- | The associativity of an operator, as in an @infix@ declaration.
data FixityDirection = InfixL | InfixR | InfixN
- deriving( Eq, Ord, Show, Data, Generic )
+ deriving( Eq, Ord, Show, Generic )
-- | Highest allowed operator precedence for 'Fixity' constructor (answer: 9)
maxPrecedence :: Int
@@ -1628,7 +700,7 @@ data Lit = CharL Char -- ^ @\'c\'@
| StringPrimL [Word8] -- ^ @"string"#@. A primitive C-style string, type 'Addr#'
| BytesPrimL Bytes -- ^ Some raw bytes, type 'Addr#':
| CharPrimL Char -- ^ @\'c\'#@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- We could add Int, Float, Double etc, as we do in HsLit,
-- but that could complicate the
@@ -1650,7 +722,7 @@ data Bytes = Bytes
-- , bytesInitialized :: Bool -- ^ False: only use `bytesSize` to allocate
-- -- an uninitialized region
}
- deriving (Data,Generic)
+ deriving (Generic)
-- We can't derive Show instance for Bytes because we don't want to show the
-- pointer value but the actual bytes (similarly to what ByteString does). See
@@ -1717,14 +789,14 @@ data Pat
| TypeP Type -- ^ @{ type p }@
| InvisP Type -- ^ @{ @p }@
| OrP (NonEmpty Pat) -- ^ @{ p1; p2 }@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A (field name, pattern) pair. See 'RecP'.
type FieldPat = (Name,Pat)
-- | A @case@-alternative
data Match = Match Pat Body [Dec] -- ^ @case e of { pat -> body where decs }@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A clause consists of patterns, guards, a body expression, and a list of
-- declarations under a @where@. Clauses are seen in equations for function
@@ -1732,7 +804,7 @@ data Match = Match Pat Body [Dec] -- ^ @case e of { pat -> body where decs }@
-- etc.
data Clause = Clause [Pat] Body [Dec]
-- ^ @f { p1 p2 = body where decs }@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A Haskell expression.
data Exp
@@ -1827,7 +899,7 @@ data Exp
| ForallE [TyVarBndr Specificity] Exp -- ^ @forall \<vars\>. \<expr\>@
| ForallVisE [TyVarBndr ()] Exp -- ^ @forall \<vars\> -> \<expr\>@
| ConstrainedE [Exp] Exp -- ^ @\<ctxt\> => \<expr\>@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A (field name, expression) pair. See 'RecConE' and 'RecUpdE'.
type FieldExp = (Name,Exp)
@@ -1841,13 +913,13 @@ data Body
-- | e3 = e4 }
-- where ds@
| NormalB Exp -- ^ @f p { = e } where ds@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A single guard.
data Guard
= NormalG Exp -- ^ @f x { | odd x } = x@
| PatG [Stmt] -- ^ @f x { | Just y <- x, Just z <- y } = z@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A single statement, as in @do@-notation.
data Stmt
@@ -1856,14 +928,14 @@ data Stmt
| NoBindS Exp -- ^ @e@
| ParS [[Stmt]] -- ^ @x <- e1 | s2, s3 | s4@ (in 'CompE')
| RecS [Stmt] -- ^ @rec { s1; s2 }@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A list/enum range expression.
data Range = FromR Exp -- ^ @[n ..]@
| FromThenR Exp Exp -- ^ @[n, m ..]@
| FromToR Exp Exp -- ^ @[n .. m]@
| FromThenToR Exp Exp Exp -- ^ @[n, m .. k]@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A single declaration.
data Dec
@@ -1950,7 +1022,7 @@ data Dec
--
-- Implicit parameter binding declaration. Can only be used in let
-- and where clauses which consist entirely of implicit bindings.
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A way to specify a namespace to look in when GHC needs to find
-- a name's source
@@ -1962,7 +1034,7 @@ data NamespaceSpecifier
-- or type variable
| DataNamespaceSpecifier -- ^ Name should be a term-level entity, such as a
-- function, data constructor, or pattern synonym
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | Varieties of allowed instance overlap.
data Overlap = Overlappable -- ^ May be overlapped by more specific instances
@@ -1971,12 +1043,12 @@ data Overlap = Overlappable -- ^ May be overlapped by more specific instances
| Incoherent -- ^ Both 'Overlapping' and 'Overlappable', and
-- pick an arbitrary one if multiple choices are
-- available.
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A single @deriving@ clause at the end of a datatype declaration.
data DerivClause = DerivClause (Maybe DerivStrategy) Cxt
-- ^ @{ deriving stock (Eq, Ord) }@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | What the user explicitly requests when deriving an instance with
-- @-XDerivingStrategies@.
@@ -1984,7 +1056,7 @@ data DerivStrategy = StockStrategy -- ^ @deriving {stock} C@
| AnyclassStrategy -- ^ @deriving {anyclass} C@, @-XDeriveAnyClass@
| NewtypeStrategy -- ^ @deriving {newtype} C@, @-XGeneralizedNewtypeDeriving@
| ViaStrategy Type -- ^ @deriving C {via T}@, @-XDerivingVia@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A pattern synonym's type. Note that a pattern synonym's /fully/
-- specified type has a peculiar shape coming with two forall
@@ -2040,7 +1112,7 @@ type PatSynType = Type
-- between @type family@ and @where@.
data TypeFamilyHead =
TypeFamilyHead Name [TyVarBndr BndrVis] FamilyResultSig (Maybe InjectivityAnn)
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | One equation of a type family instance or closed type family. The
-- arguments are the left-hand-side type and the right-hand-side result.
@@ -2060,28 +1132,28 @@ data TypeFamilyHead =
-- ('VarT' a)
-- @
data TySynEqn = TySynEqn (Maybe [TyVarBndr ()]) Type Type
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | [Functional dependency](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/functio…
-- syntax, as in a class declaration.
data FunDep = FunDep [Name] [Name] -- ^ @class C a b {| a -> b}@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A @foreign@ declaration.
data Foreign = ImportF Callconv Safety String Name Type
-- ^ @foreign import callconv safety "foreign_name" haskellName :: type@
| ExportF Callconv String Name Type
-- ^ @foreign export callconv "foreign_name" haskellName :: type@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- keep Callconv in sync with module ForeignCall in ghc/compiler/GHC/Types/ForeignCall.hs
-- | A calling convention identifier, as in a 'Foreign' declaration.
data Callconv = CCall | StdCall | CApi | Prim | JavaScript
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A safety level, as in a 'Foreign' declaration.
data Safety = Unsafe | Safe | Interruptible
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
data Pragma = InlineP Name Inline RuleMatch Phases
-- ^ @{ {\-\# [inline] [rule match] [phases] [phases] name #-} }@. See
@@ -2106,7 +1178,7 @@ data Pragma = InlineP Name Inline RuleMatch Phases
-- ^ @{ {\-\# COMPLETE C_1, ..., C_i [ :: T ] \#-} }@
| SCCP Name (Maybe String)
-- ^ @{ {\-\# SCC fun "optional_name" \#-} }@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | An inline pragma.
data Inline = NoInline
@@ -2115,7 +1187,7 @@ data Inline = NoInline
-- ^ @{ {\-\# INLINE ... #-} }@
| Inlinable
-- ^ @{ {\-\# INLINABLE ... #-} }@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | A @CONLIKE@ modifier, as in one of the various inline pragmas, or lack
-- thereof ('FunLike').
@@ -2123,7 +1195,7 @@ data RuleMatch = ConLike
-- ^ @{ {\-\# CONLIKE [inline] ... #-} }@
| FunLike
-- ^ @{ {\-\# [inline] ... #-} }@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | Phase control syntax.
data Phases = AllPhases
@@ -2132,14 +1204,14 @@ data Phases = AllPhases
-- ^ @[n]@
| BeforePhase Int
-- ^ @[~n]@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | A binder found in the @forall@ of a @RULES@ pragma.
data RuleBndr = RuleVar Name
-- ^ @forall {a} ... .@
| TypedRuleVar Name Type
-- ^ @forall {(a :: t)} ... .@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | The target of an @ANN@ pragma
data AnnTarget = ModuleAnnotation
@@ -2148,7 +1220,7 @@ data AnnTarget = ModuleAnnotation
-- ^ @{\-\# ANN type {name} ... #-}@
| ValueAnnotation Name
-- ^ @{\-\# ANN {name} ... #-}@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | A context, as found on the left side of a @=>@ in a type.
type Cxt = [Pred] -- ^ @(Eq a, Ord b)@
@@ -2166,7 +1238,7 @@ data SourceUnpackedness
= NoSourceUnpackedness -- ^ @C a@
| SourceNoUnpack -- ^ @C { {\-\# NOUNPACK \#-\} } a@
| SourceUnpack -- ^ @C { {\-\# UNPACK \#-\} } a@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | 'SourceStrictness' corresponds to strictness annotations found in the source code.
--
@@ -2175,7 +1247,7 @@ data SourceUnpackedness
data SourceStrictness = NoSourceStrictness -- ^ @C a@
| SourceLazy -- ^ @C {~}a@
| SourceStrict -- ^ @C {!}a@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | Unlike 'SourceStrictness' and 'SourceUnpackedness', 'DecidedStrictness'
-- refers to the strictness annotations that the compiler chooses for a data constructor
@@ -2188,7 +1260,7 @@ data SourceStrictness = NoSourceStrictness -- ^ @C a@
data DecidedStrictness = DecidedLazy -- ^ Field inferred to not have a bang.
| DecidedStrict -- ^ Field inferred to have a bang.
| DecidedUnpack -- ^ Field inferred to be unpacked.
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | A data constructor.
--
@@ -2253,7 +1325,7 @@ data Con =
-- Invariant: the list must be non-empty.
[VarBangType] -- ^ The constructor arguments
Type -- ^ See Note [GADT return type]
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- Note [GADT return type]
-- ~~~~~~~~~~~~~~~~~~~~~~~
@@ -2285,7 +1357,7 @@ data Con =
-- | Strictness information in a data constructor's argument.
data Bang = Bang SourceUnpackedness SourceStrictness
-- ^ @C { {\-\# UNPACK \#-\} !}a@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | A type with a strictness annotation, as in data constructors. See 'Con'.
type BangType = (Bang, Type)
@@ -2309,14 +1381,14 @@ data PatSynDir
= Unidir -- ^ @pattern P x {<-} p@
| ImplBidir -- ^ @pattern P x {=} p@
| ExplBidir [Clause] -- ^ @pattern P x {<-} p where P x = e@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A pattern synonym's argument type.
data PatSynArgs
= PrefixPatSyn [Name] -- ^ @pattern P {x y z} = p@
| InfixPatSyn Name Name -- ^ @pattern {x P y} = p@
| RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A Haskell type.
data Type = ForallT [TyVarBndr Specificity] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> => \<type\>@
@@ -2355,12 +1427,12 @@ data Type = ForallT [TyVarBndr Specificity] Cxt Type -- ^ @forall \<vars\>. \<ct
| LitT TyLit -- ^ @0@, @1@, @2@, etc.
| WildCardT -- ^ @_@
| ImplicitParamT String Type -- ^ @?x :: t@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | The specificity of a type variable in a @forall ...@.
data Specificity = SpecifiedSpec -- ^ @a@
| InferredSpec -- ^ @{a}@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | The @flag@ type parameter is instantiated to one of the following types:
--
@@ -2370,40 +1442,40 @@ data Specificity = SpecifiedSpec -- ^ @a@
--
data TyVarBndr flag = PlainTV Name flag -- ^ @a@
| KindedTV Name flag Kind -- ^ @(a :: k)@
- deriving( Show, Eq, Ord, Data, Generic, Functor, Foldable, Traversable )
+ deriving( Show, Eq, Ord, Generic, Functor, Foldable, Traversable )
-- | Visibility of a type variable. See [Inferred vs. specified type variables](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/type_app….
data BndrVis = BndrReq -- ^ @a@
| BndrInvis -- ^ @\@a@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | Type family result signature
data FamilyResultSig = NoSig -- ^ no signature
| KindSig Kind -- ^ @k@
| TyVarSig (TyVarBndr ()) -- ^ @= r, = (r :: k)@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | Injectivity annotation as in an [injective type family](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/type_famili…
data InjectivityAnn = InjectivityAnn Name [Name]
- deriving ( Show, Eq, Ord, Data, Generic )
+ deriving ( Show, Eq, Ord, Generic )
-- | Type-level literals.
data TyLit = NumTyLit Integer -- ^ @2@
| StrTyLit String -- ^ @\"Hello\"@
| CharTyLit Char -- ^ @\'C\'@, @since 4.16.0.0
- deriving ( Show, Eq, Ord, Data, Generic )
+ deriving ( Show, Eq, Ord, Generic )
-- | Role annotations
data Role = NominalR -- ^ @nominal@
| RepresentationalR -- ^ @representational@
| PhantomR -- ^ @phantom@
| InferR -- ^ @_@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | Annotation target for reifyAnnotations
data AnnLookup = AnnLookupModule Module
| AnnLookupName Name
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | To avoid duplication between kinds and types, they
-- are defined to be the same. Naturally, you would never
@@ -2454,7 +1526,7 @@ data DocLoc
| ArgDoc Name Int -- ^ At a specific argument of a function, indexed by its
-- position.
| InstDoc Type -- ^ At a class or family instance.
- deriving ( Show, Eq, Ord, Data, Generic )
+ deriving ( Show, Eq, Ord, Generic )
-----------------------------------------------------
-- Internal helper functions
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -63,6 +63,7 @@ import Foreign
import GHC.Generics
import GHC.Stack.CCS
import qualified GHC.Boot.TH.Syntax as TH
+import qualified GHC.Boot.TH.Monad as TH
import System.Exit
import System.IO
import System.IO.Error
=====================================
libraries/ghci/GHCi/TH.hs
=====================================
@@ -114,6 +114,7 @@ import qualified Data.Map as M
import Data.Maybe
import GHC.Desugar (AnnotationWrapper(..))
import qualified GHC.Boot.TH.Syntax as TH
+import qualified GHC.Boot.TH.Monad as TH
import Unsafe.Coerce
-- | Create a new instance of 'QState'
=====================================
libraries/template-haskell/Language/Haskell/TH/Quote.hs
=====================================
@@ -22,7 +22,7 @@ module Language.Haskell.TH.Quote
, dataToQa, dataToExpQ, dataToPatQ
) where
-import GHC.Boot.TH.Syntax
+import GHC.Boot.TH.Monad
import GHC.Boot.TH.Quote
import Language.Haskell.TH.Syntax (dataToQa, dataToExpQ, dataToPatQ)
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -200,6 +200,7 @@ where
import GHC.Boot.TH.Lift
import GHC.Boot.TH.Syntax
+import GHC.Boot.TH.Monad
import System.FilePath
import Data.Data hiding (Fixity(..))
import Data.List.NonEmpty (NonEmpty(..))
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/63b5b30d1efb0fed2c48a152052f0b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/63b5b30d1efb0fed2c48a152052f0b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26217] 2 commits: ghc-internal: Move Data instance for TH.Syntax to Data.Data
by Teo Camarasu (＠teo) 17 Aug '25
by Teo Camarasu (＠teo) 17 Aug '25
17 Aug '25
Teo Camarasu pushed to branch wip/T26217 at Glasgow Haskell Compiler / GHC
Commits:
fc20efb3 by Teo Camarasu at 2025-08-17T22:53:32+01:00
ghc-internal: Move Data instance for TH.Syntax to Data.Data
This means that Data.Data no longer blocks building TH.Syntax, which
allows greater parallelism in our builds.
Previously TH.Syntax was a bottleneck when compiling ghc-internal. Now
it is less of a bottle-neck and is also slightly quicker to
compile (since it no longer contains these instances) at the cost of
making Data.Data slightly more expensive to compile.
TH.Lift which depends on TH.Syntax can also compile quicker and no
longer blocks ghc-internal finishing to compile.
Resolves #26217
- - - - -
63b5b30d by Teo Camarasu at 2025-08-17T22:53:32+01:00
compiler: delete unused names in Builtins.Names.TH
returnQ and bindQ are no longer used in the compiler.
There was also a very old comment that referred to them that I have modernized
- - - - -
4 changed files:
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/HsToCore/Quote.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Data.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
Changes:
=====================================
compiler/GHC/Builtin/Names/TH.hs
=====================================
@@ -30,7 +30,7 @@ templateHaskellNames :: [Name]
-- Should stay in sync with the import list of GHC.HsToCore.Quote
templateHaskellNames = [
- returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,
+ sequenceQName, newNameName, liftName, liftTypedName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameG_fldName,
mkNameLName,
mkNameSName, mkNameQName,
@@ -240,12 +240,10 @@ overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey
modNameTyConName = thTc (fsLit "ModName") modNameTyConKey
quasiQuoterTyConName = mk_known_key_name tcName qqLib (fsLit "QuasiQuoter") quasiQuoterTyConKey
-returnQName, bindQName, sequenceQName, newNameName, liftName,
+sequenceQName, newNameName, liftName,
mkNameName, mkNameG_vName, mkNameG_fldName, mkNameG_dName, mkNameG_tcName,
mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName,
unsafeCodeCoerceName, liftTypedName, mkModNameName, mkNameQName :: Name
-returnQName = thFun (fsLit "returnQ") returnQIdKey
-bindQName = thFun (fsLit "bindQ") bindQIdKey
sequenceQName = thMonadFun (fsLit "sequenceQ") sequenceQIdKey
newNameName = thMonadFun (fsLit "newName") newNameIdKey
mkNameName = thFun (fsLit "mkName") mkNameIdKey
@@ -812,12 +810,10 @@ dataNamespaceSpecifierDataConKey = mkPreludeDataConUnique 215
-- IdUniques available: 200-499
-- If you want to change this, make sure you check in GHC.Builtin.Names
-returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
+sequenceQIdKey, liftIdKey, newNameIdKey,
mkNameIdKey, mkNameG_vIdKey, mkNameG_fldIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey,
unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey, mkNameQIdKey :: Unique
-returnQIdKey = mkPreludeMiscIdUnique 200
-bindQIdKey = mkPreludeMiscIdUnique 201
sequenceQIdKey = mkPreludeMiscIdUnique 202
liftIdKey = mkPreludeMiscIdUnique 203
newNameIdKey = mkPreludeMiscIdUnique 204
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -245,14 +245,14 @@ first generate a polymorphic definition and then just apply the wrapper at the e
[| \x -> x |]
====>
- gensym (unpackString "x"#) `bindQ` \ x1::String ->
- lam (pvar x1) (var x1)
+ newName (unpackString "x"#) >>= \ x1::Name ->
+ lamE (varP x1) (varE x1)
[| \x -> $(f [| x |]) |]
====>
- gensym (unpackString "x"#) `bindQ` \ x1::String ->
- lam (pvar x1) (f (var x1))
+ newName (unpackString "x"#) >>= \ x1::Name ->
+ lamE (varP x1) (f (varE x1))
-}
=====================================
libraries/ghc-internal/src/GHC/Internal/Data/Data.hs
=====================================
@@ -143,6 +143,7 @@ import GHC.Internal.Arr -- So we can give Data instance for Array
import qualified GHC.Internal.Generics as Generics (Fixity(..))
import GHC.Internal.Generics hiding (Fixity(..))
-- So we can give Data instance for U1, V1, ...
+import qualified GHC.Internal.TH.Syntax as TH
------------------------------------------------------------------------------
--
@@ -1353,3 +1354,63 @@ deriving instance Data DecidedStrictness
-- | @since base-4.12.0.0
deriving instance Data a => Data (Down a)
+
+----------------------------------------------------------------------------
+-- Data instances for GHC.Internal.TH.Syntax
+
+deriving instance Data TH.AnnLookup
+deriving instance Data TH.AnnTarget
+deriving instance Data TH.Bang
+deriving instance Data TH.BndrVis
+deriving instance Data TH.Body
+deriving instance Data TH.Bytes
+deriving instance Data TH.Callconv
+deriving instance Data TH.Clause
+deriving instance Data TH.Con
+deriving instance Data TH.Dec
+deriving instance Data TH.DecidedStrictness
+deriving instance Data TH.DerivClause
+deriving instance Data TH.DerivStrategy
+deriving instance Data TH.DocLoc
+deriving instance Data TH.Exp
+deriving instance Data TH.FamilyResultSig
+deriving instance Data TH.Fixity
+deriving instance Data TH.FixityDirection
+deriving instance Data TH.Foreign
+deriving instance Data TH.FunDep
+deriving instance Data TH.Guard
+deriving instance Data TH.Info
+deriving instance Data TH.InjectivityAnn
+deriving instance Data TH.Inline
+deriving instance Data TH.Lit
+deriving instance Data TH.Loc
+deriving instance Data TH.Match
+deriving instance Data TH.ModName
+deriving instance Data TH.Module
+deriving instance Data TH.ModuleInfo
+deriving instance Data TH.Name
+deriving instance Data TH.NameFlavour
+deriving instance Data TH.NameSpace
+deriving instance Data TH.NamespaceSpecifier
+deriving instance Data TH.OccName
+deriving instance Data TH.Overlap
+deriving instance Data TH.Pat
+deriving instance Data TH.PatSynArgs
+deriving instance Data TH.PatSynDir
+deriving instance Data TH.Phases
+deriving instance Data TH.PkgName
+deriving instance Data TH.Pragma
+deriving instance Data TH.Range
+deriving instance Data TH.Role
+deriving instance Data TH.RuleBndr
+deriving instance Data TH.RuleMatch
+deriving instance Data TH.Safety
+deriving instance Data TH.SourceStrictness
+deriving instance Data TH.SourceUnpackedness
+deriving instance Data TH.Specificity
+deriving instance Data TH.Stmt
+deriving instance Data TH.TyLit
+deriving instance Data TH.TySynEqn
+deriving instance Data TH.Type
+deriving instance Data TH.TypeFamilyHead
+deriving instance Data flag => Data (TH.TyVarBndr flag)
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
=====================================
@@ -1,14 +1,16 @@
{-# OPTIONS_HADDOCK not-home #-} -- we want users to import Language.Haskell.TH.Syntax instead
-{-# LANGUAGE CPP, DeriveDataTypeable,
- DeriveGeneric, FlexibleInstances, DefaultSignatures,
- RankNTypes, RoleAnnotations, ScopedTypeVariables,
- MagicHash, KindSignatures, PolyKinds, TypeApplications, DataKinds,
- GADTs, UnboxedTuples, UnboxedSums, TypeOperators,
- Trustworthy, DeriveFunctor, DeriveTraversable,
- BangPatterns, RecordWildCards, ImplicitParams #-}
-
-{-# LANGUAGE TemplateHaskellQuotes #-}
-{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE Safe #-}
+{-# LANGUAGE UnboxedTuples #-}
-- | This module is used internally in GHC's integration with Template Haskell
-- and defines the abstract syntax of Template Haskell.
@@ -26,7 +28,6 @@ module GHC.Internal.TH.Syntax
#ifdef BOOTSTRAP_TH
import Prelude
-import Data.Data hiding (Fixity(..))
import System.IO.Unsafe ( unsafePerformIO )
import Data.Char ( isAlpha, isAlphaNum, isUpper )
import Data.List.NonEmpty ( NonEmpty(..) )
@@ -38,7 +39,6 @@ import GHC.Ptr ( Ptr, plusPtr )
import GHC.Generics ( Generic )
#else
import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence)
-import GHC.Internal.Data.Data hiding (Fixity(..))
import GHC.Internal.Data.NonEmpty (NonEmpty(..))
import GHC.Internal.Data.Traversable
import GHC.Internal.Word
@@ -72,19 +72,19 @@ manyName = mkNameG DataName "ghc-internal" "GHC.Internal.Types" "Many"
-- | The name of a module.
newtype ModName = ModName String -- Module name
- deriving (Show,Eq,Ord,Data,Generic)
+ deriving (Show,Eq,Ord,Generic)
-- | The name of a package.
newtype PkgName = PkgName String -- package name
- deriving (Show,Eq,Ord,Data,Generic)
+ deriving (Show,Eq,Ord,Generic)
-- | Obtained from 'reifyModule' and 'Language.Haskell.TH.Lib.thisModule'.
data Module = Module PkgName ModName -- package qualified module name
- deriving (Show,Eq,Ord,Data,Generic)
+ deriving (Show,Eq,Ord,Generic)
-- | An "Occurence Name".
newtype OccName = OccName String
- deriving (Show,Eq,Ord,Data,Generic)
+ deriving (Show,Eq,Ord,Generic)
-- | Smart constructor for 'ModName'
mkModName :: String -> ModName
@@ -200,7 +200,7 @@ Names constructed using @newName@ and @mkName@ may be used in bindings
(such as @let x = ...@ or @\x -> ...@), but names constructed using
@lookupValueName@, @lookupTypeName@, @'f@, @''T@ may not.
-}
-data Name = Name OccName NameFlavour deriving (Data, Eq, Generic)
+data Name = Name OccName NameFlavour deriving (Eq, Generic)
instance Ord Name where
-- check if unique is different before looking at strings
@@ -216,7 +216,7 @@ data NameFlavour
-- An original name (occurrences only, not binders)
-- Need the namespace too to be sure which
-- thing we are naming
- deriving ( Data, Eq, Ord, Show, Generic )
+ deriving ( Eq, Ord, Show, Generic )
data NameSpace = VarName -- ^ Variables
| DataName -- ^ Data constructors
@@ -230,7 +230,7 @@ data NameSpace = VarName -- ^ Variables
-- of the datatype (regardless of whether this constructor has this field).
-- - For a field of a pattern synonym, this is the name of the pattern synonym.
}
- deriving( Eq, Ord, Show, Data, Generic )
+ deriving( Eq, Ord, Show, Generic )
-- | @Uniq@ is used by GHC to distinguish names from each other.
type Uniq = Integer
@@ -532,7 +532,7 @@ data Loc
, loc_module :: String
, loc_start :: CharPos
, loc_end :: CharPos }
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
type CharPos = (Int, Int) -- ^ Line and character position
@@ -615,13 +615,13 @@ data Info
| TyVarI -- Scoped type variable
Name
Type -- What it is bound to
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | Obtained from 'reifyModule' in the 'Q' Monad.
data ModuleInfo =
-- | Contains the import list of the module.
ModuleInfo [Module]
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
{- |
In 'ClassOpI' and 'DataConI', name of the parent class or type
@@ -659,11 +659,11 @@ type InstanceDec = Dec
-- | Fixity, as specified in a @infix[lr] n@ declaration.
data Fixity = Fixity Int FixityDirection
- deriving( Eq, Ord, Show, Data, Generic )
+ deriving( Eq, Ord, Show, Generic )
-- | The associativity of an operator, as in an @infix@ declaration.
data FixityDirection = InfixL | InfixR | InfixN
- deriving( Eq, Ord, Show, Data, Generic )
+ deriving( Eq, Ord, Show, Generic )
-- | Highest allowed operator precedence for 'Fixity' constructor (answer: 9)
maxPrecedence :: Int
@@ -696,7 +696,7 @@ data Lit = CharL Char -- ^ @\'c\'@
| StringPrimL [Word8] -- ^ @"string"#@. A primitive C-style string, type 'Addr#'
| BytesPrimL Bytes -- ^ Some raw bytes, type 'Addr#':
| CharPrimL Char -- ^ @\'c\'#@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- We could add Int, Float, Double etc, as we do in HsLit,
-- but that could complicate the
@@ -718,7 +718,7 @@ data Bytes = Bytes
-- , bytesInitialized :: Bool -- ^ False: only use `bytesSize` to allocate
-- -- an uninitialized region
}
- deriving (Data,Generic)
+ deriving (Generic)
-- We can't derive Show instance for Bytes because we don't want to show the
-- pointer value but the actual bytes (similarly to what ByteString does). See
@@ -785,14 +785,14 @@ data Pat
| TypeP Type -- ^ @{ type p }@
| InvisP Type -- ^ @{ @p }@
| OrP (NonEmpty Pat) -- ^ @{ p1; p2 }@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A (field name, pattern) pair. See 'RecP'.
type FieldPat = (Name,Pat)
-- | A @case@-alternative
data Match = Match Pat Body [Dec] -- ^ @case e of { pat -> body where decs }@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A clause consists of patterns, guards, a body expression, and a list of
-- declarations under a @where@. Clauses are seen in equations for function
@@ -800,7 +800,7 @@ data Match = Match Pat Body [Dec] -- ^ @case e of { pat -> body where decs }@
-- etc.
data Clause = Clause [Pat] Body [Dec]
-- ^ @f { p1 p2 = body where decs }@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A Haskell expression.
data Exp
@@ -895,7 +895,7 @@ data Exp
| ForallE [TyVarBndr Specificity] Exp -- ^ @forall \<vars\>. \<expr\>@
| ForallVisE [TyVarBndr ()] Exp -- ^ @forall \<vars\> -> \<expr\>@
| ConstrainedE [Exp] Exp -- ^ @\<ctxt\> => \<expr\>@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A (field name, expression) pair. See 'RecConE' and 'RecUpdE'.
type FieldExp = (Name,Exp)
@@ -909,13 +909,13 @@ data Body
-- | e3 = e4 }
-- where ds@
| NormalB Exp -- ^ @f p { = e } where ds@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A single guard.
data Guard
= NormalG Exp -- ^ @f x { | odd x } = x@
| PatG [Stmt] -- ^ @f x { | Just y <- x, Just z <- y } = z@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A single statement, as in @do@-notation.
data Stmt
@@ -924,14 +924,14 @@ data Stmt
| NoBindS Exp -- ^ @e@
| ParS [[Stmt]] -- ^ @x <- e1 | s2, s3 | s4@ (in 'CompE')
| RecS [Stmt] -- ^ @rec { s1; s2 }@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A list/enum range expression.
data Range = FromR Exp -- ^ @[n ..]@
| FromThenR Exp Exp -- ^ @[n, m ..]@
| FromToR Exp Exp -- ^ @[n .. m]@
| FromThenToR Exp Exp Exp -- ^ @[n, m .. k]@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A single declaration.
data Dec
@@ -1018,7 +1018,7 @@ data Dec
--
-- Implicit parameter binding declaration. Can only be used in let
-- and where clauses which consist entirely of implicit bindings.
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A way to specify a namespace to look in when GHC needs to find
-- a name's source
@@ -1030,7 +1030,7 @@ data NamespaceSpecifier
-- or type variable
| DataNamespaceSpecifier -- ^ Name should be a term-level entity, such as a
-- function, data constructor, or pattern synonym
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | Varieties of allowed instance overlap.
data Overlap = Overlappable -- ^ May be overlapped by more specific instances
@@ -1039,12 +1039,12 @@ data Overlap = Overlappable -- ^ May be overlapped by more specific instances
| Incoherent -- ^ Both 'Overlapping' and 'Overlappable', and
-- pick an arbitrary one if multiple choices are
-- available.
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A single @deriving@ clause at the end of a datatype declaration.
data DerivClause = DerivClause (Maybe DerivStrategy) Cxt
-- ^ @{ deriving stock (Eq, Ord) }@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | What the user explicitly requests when deriving an instance with
-- @-XDerivingStrategies@.
@@ -1052,7 +1052,7 @@ data DerivStrategy = StockStrategy -- ^ @deriving {stock} C@
| AnyclassStrategy -- ^ @deriving {anyclass} C@, @-XDeriveAnyClass@
| NewtypeStrategy -- ^ @deriving {newtype} C@, @-XGeneralizedNewtypeDeriving@
| ViaStrategy Type -- ^ @deriving C {via T}@, @-XDerivingVia@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A pattern synonym's type. Note that a pattern synonym's /fully/
-- specified type has a peculiar shape coming with two forall
@@ -1108,7 +1108,7 @@ type PatSynType = Type
-- between @type family@ and @where@.
data TypeFamilyHead =
TypeFamilyHead Name [TyVarBndr BndrVis] FamilyResultSig (Maybe InjectivityAnn)
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | One equation of a type family instance or closed type family. The
-- arguments are the left-hand-side type and the right-hand-side result.
@@ -1128,28 +1128,28 @@ data TypeFamilyHead =
-- ('VarT' a)
-- @
data TySynEqn = TySynEqn (Maybe [TyVarBndr ()]) Type Type
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | [Functional dependency](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/functio…
-- syntax, as in a class declaration.
data FunDep = FunDep [Name] [Name] -- ^ @class C a b {| a -> b}@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A @foreign@ declaration.
data Foreign = ImportF Callconv Safety String Name Type
-- ^ @foreign import callconv safety "foreign_name" haskellName :: type@
| ExportF Callconv String Name Type
-- ^ @foreign export callconv "foreign_name" haskellName :: type@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- keep Callconv in sync with module ForeignCall in ghc/compiler/GHC/Types/ForeignCall.hs
-- | A calling convention identifier, as in a 'Foreign' declaration.
data Callconv = CCall | StdCall | CApi | Prim | JavaScript
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A safety level, as in a 'Foreign' declaration.
data Safety = Unsafe | Safe | Interruptible
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
data Pragma = InlineP Name Inline RuleMatch Phases
-- ^ @{ {\-\# [inline] [rule match] [phases] [phases] name #-} }@. See
@@ -1174,7 +1174,7 @@ data Pragma = InlineP Name Inline RuleMatch Phases
-- ^ @{ {\-\# COMPLETE C_1, ..., C_i [ :: T ] \#-} }@
| SCCP Name (Maybe String)
-- ^ @{ {\-\# SCC fun "optional_name" \#-} }@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | An inline pragma.
data Inline = NoInline
@@ -1183,7 +1183,7 @@ data Inline = NoInline
-- ^ @{ {\-\# INLINE ... #-} }@
| Inlinable
-- ^ @{ {\-\# INLINABLE ... #-} }@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | A @CONLIKE@ modifier, as in one of the various inline pragmas, or lack
-- thereof ('FunLike').
@@ -1191,7 +1191,7 @@ data RuleMatch = ConLike
-- ^ @{ {\-\# CONLIKE [inline] ... #-} }@
| FunLike
-- ^ @{ {\-\# [inline] ... #-} }@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | Phase control syntax.
data Phases = AllPhases
@@ -1200,14 +1200,14 @@ data Phases = AllPhases
-- ^ @[n]@
| BeforePhase Int
-- ^ @[~n]@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | A binder found in the @forall@ of a @RULES@ pragma.
data RuleBndr = RuleVar Name
-- ^ @forall {a} ... .@
| TypedRuleVar Name Type
-- ^ @forall {(a :: t)} ... .@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | The target of an @ANN@ pragma
data AnnTarget = ModuleAnnotation
@@ -1216,7 +1216,7 @@ data AnnTarget = ModuleAnnotation
-- ^ @{\-\# ANN type {name} ... #-}@
| ValueAnnotation Name
-- ^ @{\-\# ANN {name} ... #-}@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | A context, as found on the left side of a @=>@ in a type.
type Cxt = [Pred] -- ^ @(Eq a, Ord b)@
@@ -1234,7 +1234,7 @@ data SourceUnpackedness
= NoSourceUnpackedness -- ^ @C a@
| SourceNoUnpack -- ^ @C { {\-\# NOUNPACK \#-\} } a@
| SourceUnpack -- ^ @C { {\-\# UNPACK \#-\} } a@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | 'SourceStrictness' corresponds to strictness annotations found in the source code.
--
@@ -1243,7 +1243,7 @@ data SourceUnpackedness
data SourceStrictness = NoSourceStrictness -- ^ @C a@
| SourceLazy -- ^ @C {~}a@
| SourceStrict -- ^ @C {!}a@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | Unlike 'SourceStrictness' and 'SourceUnpackedness', 'DecidedStrictness'
-- refers to the strictness annotations that the compiler chooses for a data constructor
@@ -1256,7 +1256,7 @@ data SourceStrictness = NoSourceStrictness -- ^ @C a@
data DecidedStrictness = DecidedLazy -- ^ Field inferred to not have a bang.
| DecidedStrict -- ^ Field inferred to have a bang.
| DecidedUnpack -- ^ Field inferred to be unpacked.
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | A data constructor.
--
@@ -1321,7 +1321,7 @@ data Con =
-- Invariant: the list must be non-empty.
[VarBangType] -- ^ The constructor arguments
Type -- ^ See Note [GADT return type]
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- Note [GADT return type]
-- ~~~~~~~~~~~~~~~~~~~~~~~
@@ -1353,7 +1353,7 @@ data Con =
-- | Strictness information in a data constructor's argument.
data Bang = Bang SourceUnpackedness SourceStrictness
-- ^ @C { {\-\# UNPACK \#-\} !}a@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | A type with a strictness annotation, as in data constructors. See 'Con'.
type BangType = (Bang, Type)
@@ -1377,14 +1377,14 @@ data PatSynDir
= Unidir -- ^ @pattern P x {<-} p@
| ImplBidir -- ^ @pattern P x {=} p@
| ExplBidir [Clause] -- ^ @pattern P x {<-} p where P x = e@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A pattern synonym's argument type.
data PatSynArgs
= PrefixPatSyn [Name] -- ^ @pattern P {x y z} = p@
| InfixPatSyn Name Name -- ^ @pattern {x P y} = p@
| RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A Haskell type.
data Type = ForallT [TyVarBndr Specificity] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> => \<type\>@
@@ -1423,12 +1423,12 @@ data Type = ForallT [TyVarBndr Specificity] Cxt Type -- ^ @forall \<vars\>. \<ct
| LitT TyLit -- ^ @0@, @1@, @2@, etc.
| WildCardT -- ^ @_@
| ImplicitParamT String Type -- ^ @?x :: t@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | The specificity of a type variable in a @forall ...@.
data Specificity = SpecifiedSpec -- ^ @a@
| InferredSpec -- ^ @{a}@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | The @flag@ type parameter is instantiated to one of the following types:
--
@@ -1438,40 +1438,40 @@ data Specificity = SpecifiedSpec -- ^ @a@
--
data TyVarBndr flag = PlainTV Name flag -- ^ @a@
| KindedTV Name flag Kind -- ^ @(a :: k)@
- deriving( Show, Eq, Ord, Data, Generic, Functor, Foldable, Traversable )
+ deriving( Show, Eq, Ord, Generic, Functor, Foldable, Traversable )
-- | Visibility of a type variable. See [Inferred vs. specified type variables](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/type_app….
data BndrVis = BndrReq -- ^ @a@
| BndrInvis -- ^ @\@a@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | Type family result signature
data FamilyResultSig = NoSig -- ^ no signature
| KindSig Kind -- ^ @k@
| TyVarSig (TyVarBndr ()) -- ^ @= r, = (r :: k)@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | Injectivity annotation as in an [injective type family](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/type_famili…
data InjectivityAnn = InjectivityAnn Name [Name]
- deriving ( Show, Eq, Ord, Data, Generic )
+ deriving ( Show, Eq, Ord, Generic )
-- | Type-level literals.
data TyLit = NumTyLit Integer -- ^ @2@
| StrTyLit String -- ^ @\"Hello\"@
| CharTyLit Char -- ^ @\'C\'@, @since 4.16.0.0
- deriving ( Show, Eq, Ord, Data, Generic )
+ deriving ( Show, Eq, Ord, Generic )
-- | Role annotations
data Role = NominalR -- ^ @nominal@
| RepresentationalR -- ^ @representational@
| PhantomR -- ^ @phantom@
| InferR -- ^ @_@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | Annotation target for reifyAnnotations
data AnnLookup = AnnLookupModule Module
| AnnLookupName Name
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | To avoid duplication between kinds and types, they
-- are defined to be the same. Naturally, you would never
@@ -1522,7 +1522,7 @@ data DocLoc
| ArgDoc Name Int -- ^ At a specific argument of a function, indexed by its
-- position.
| InstDoc Type -- ^ At a class or family instance.
- deriving ( Show, Eq, Ord, Data, Generic )
+ deriving ( Show, Eq, Ord, Generic )
-----------------------------------------------------
-- Internal helper functions
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e12cc06278f97f1b13ec1dddf5dcd8…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e12cc06278f97f1b13ec1dddf5dcd8…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
17 Aug '25
Bodigrim pushed to branch wip/warning-for-last-and-init at Glasgow Haskell Compiler / GHC
Commits:
86560233 by Andrew Lelechenko at 2025-08-17T19:26:54+01:00
Revert utils
- - - - -
6 changed files:
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
- utils/ghc-pkg/Main.hs
- utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
- utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
Changes:
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -8,6 +8,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -Wno-x-partial #-}
-----------------------------------------------------------------------------
-- |
-- Module : Language.Haskell.GHC.ExactPrint.Transform
@@ -96,7 +97,6 @@ import GHC.Data.FastString
import GHC.Types.SrcLoc
import Data.Data
-import Data.List (unsnoc)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe
@@ -213,9 +213,8 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (AnnSig (EpUniTok dca u) mp md) ns (
where
-- we want DPs for the distance from the end of the ns to the
-- AnnDColon, and to the start of the ty
- rd = case unsnoc ns of
- Nothing -> error "unexpected empty list in 'ns' variable"
- Just (_, L (EpAnn anc' _ _) _) -> epaLocationRealSrcSpan anc'
+ rd = case last ns of
+ L (EpAnn anc' _ _) _ -> epaLocationRealSrcSpan anc'
dca' = case dca of
EpaSpan ss@(RealSrcSpan r _) -> (EpaDelta ss (ss2delta (ss2posEnd rd) r) [])
_ -> dca
@@ -296,7 +295,7 @@ setEntryDP (L (EpAnn (EpaSpan ss@(RealSrcSpan r _)) an cs) a) dp
where
cs'' = setPriorComments cs []
csd = L (EpaDelta ss dp NoComments) c:commentOrigDeltas cs'
- lc = NE.last (L ca c :| cs')
+ lc = last $ (L ca c:cs')
delta = case getLoc lc of
EpaSpan (RealSrcSpan rr _) -> ss2delta (ss2pos rr) r
EpaSpan _ -> (SameLine 0)
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -4,6 +4,7 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -Wno-x-partial #-}
module Utils
-- (
@@ -37,7 +38,7 @@ import GHC.Base (NonEmpty(..))
import GHC.Parser.Lexer (allocateComments)
import Data.Data hiding ( Fixity )
-import Data.List (sortBy, partition, unsnoc)
+import Data.List (sortBy, partition)
import qualified Data.Map.Strict as Map
import Debug.Trace
@@ -734,9 +735,8 @@ ghead info [] = error $ "ghead "++info++" []"
ghead _info (h:_) = h
glast :: String -> [a] -> a
-glast info xs = case unsnoc xs of
- Nothing -> error $ "glast " ++ info ++ " []"
- Just (_, lst) -> lst
+glast info [] = error $ "glast " ++ info ++ " []"
+glast _info h = last h
gtail :: String -> [a] -> [a]
gtail info [] = error $ "gtail " ++ info ++ " []"
=====================================
utils/ghc-pkg/Main.hs
=====================================
@@ -8,7 +8,8 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -Wno-orphans -Wno-x-partial #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -Wno-x-partial #-}
-- Fine if this comes from make/Hadrian or the pre-built base.
#include <ghcplatform.h>
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs
=====================================
@@ -1,6 +1,7 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
module GHC.Toolchain.CheckArm ( findArmIsa ) where
-import Data.List (isInfixOf, unsnoc)
+import Data.List (isInfixOf)
import Data.Maybe (catMaybes)
import Control.Monad.IO.Class
import System.Process
@@ -76,7 +77,8 @@ findArmIsa cc = do
_ -> throwE $ "unexpected output from test program: " ++ out
lastLine :: String -> String
-lastLine = maybe "" snd . unsnoc . lines
+lastLine "" = ""
+lastLine s = last $ lines s
-- | Raspbian unfortunately makes some extremely questionable packaging
-- decisions, configuring gcc to compile for ARMv6 despite the fact that the
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
=====================================
@@ -6,7 +6,7 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -Wwarn=x-partial #-}
+{-# OPTIONS_GHC -Wno-x-partial #-}
-- |
-- Module : Haddock.Backends.Html
@@ -755,7 +755,7 @@ ppHtmlIndex
divAlphabet
<< unordList
( map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $
- [ [c] | c <- initialChars, any (maybe False ((== c) . toUpper . fst) . List.uncons . fst) index
+ [ [c] | c <- initialChars, any ((== c) . toUpper . head . fst) index
]
++ [merged_name]
)
@@ -772,7 +772,7 @@ ppHtmlIndex
writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)
where
html = indexPage True (Just c) index_part
- index_part = [(n, stuff) | (n@(headN : _), stuff) <- this_ix, toUpper headN == c]
+ index_part = [(n, stuff) | (n, stuff) <- this_ix, toUpper (head n) == c]
index :: [(String, Map GHC.Name [(Module, Bool)])]
index = sortBy cmp (Map.toAscList full_index)
=====================================
utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
=====================================
@@ -1,6 +1,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -Wno-x-partial #-}
-- |
-- Module : Documentation.Haddock.Parser
@@ -30,7 +31,7 @@ import Control.Arrow (first)
import Control.Monad
import Data.Char (chr, isAlpha, isSpace, isUpper)
import Data.Functor (($>))
-import Data.List (elemIndex, intercalate, intersperse, unfoldr, unsnoc)
+import Data.List (elemIndex, intercalate, intersperse, unfoldr)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid
import qualified Data.Set as Set
@@ -870,10 +871,10 @@ codeblock =
DocCodeBlock . parseParagraph . dropSpaces
<$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@")
where
- dropSpaces xs = let ys = splitByNl xs in
- case unsnoc ys of
- Nothing -> xs
- Just (_, lastYs) -> case T.uncons lastYs of
+ dropSpaces xs =
+ case splitByNl xs of
+ [] -> xs
+ ys -> case T.uncons (last ys) of
Just (' ', _) -> case mapM dropSpace ys of
Nothing -> xs
Just zs -> T.intercalate "\n" zs
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/86560233759a674264a1e77ec4c260f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/86560233759a674264a1e77ec4c260f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26217] 3 commits: ghc-internal: Split out GHC.Internal.TH.Monad from .Syntax
by Teo Camarasu (＠teo) 17 Aug '25
by Teo Camarasu (＠teo) 17 Aug '25
17 Aug '25
Teo Camarasu pushed to branch wip/T26217 at Glasgow Haskell Compiler / GHC
Commits:
45ef53a4 by Teo Camarasu at 2025-08-17T20:49:32+01:00
ghc-internal: Split out GHC.Internal.TH.Monad from .Syntax
Split the Quasi/Q, etc definition out of GHC.Internal.TH.Syntax
into its own module.
We do this for a few reasons:
- it enables future refactors to speed up compilation of these modules.
- it reduces the size of this very large module.
- it clarifies which modules in the GHC tree depend on the TH monads (Q/Quasi, etc) and
which just care about the syntax tree.
A step towards addressing: #26217
- - - - -
b26b7da5 by Teo Camarasu at 2025-08-17T20:49:33+01:00
ghc-internal: Move Data instance for TH.Syntax to Data.Data
This means that Data.Data no longer blocks building TH.Syntax, which
allows greater parallelism in our builds.
Previously TH.Syntax was a bottleneck when compiling ghc-internal. Now
it is less of a bottle-neck and is also slightly quicker to
compile (since it no longer contains these instances) at the cost of
making Data.Data slightly more expensive to compile.
TH.Lift which depends on TH.Syntax can also compile quicker and no
longer blocks ghc-internal finishing to compile.
Resolves #26217
- - - - -
e12cc062 by Teo Camarasu at 2025-08-17T20:49:33+01:00
compiler: delete unused names in Builtins.Names.TH
returnQ and bindQ are no longer used in the compiler.
There was also a very old comment that referred to them that I have modernized
- - - - -
24 changed files:
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Gen/Splice.hs-boot
- compiler/GHC/Tc/Types/TH.hs
- libraries/base/src/Data/Array/Byte.hs
- libraries/base/src/Data/Fixed.hs
- + libraries/ghc-boot-th/GHC/Boot/TH/Monad.hs
- libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
- libraries/ghc-boot-th/ghc-boot-th.cabal.in
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Data/Data.hs
- libraries/ghc-internal/src/GHC/Internal/Lexeme.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- + libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/TH.hs
- libraries/template-haskell/Language/Haskell/TH/Quote.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
Changes:
=====================================
compiler/GHC/Builtin/Names/TH.hs
=====================================
@@ -30,7 +30,7 @@ templateHaskellNames :: [Name]
-- Should stay in sync with the import list of GHC.HsToCore.Quote
templateHaskellNames = [
- returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,
+ sequenceQName, newNameName, liftName, liftTypedName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameG_fldName,
mkNameLName,
mkNameSName, mkNameQName,
@@ -181,26 +181,30 @@ templateHaskellNames = [
-- Quasiquoting
quasiQuoterTyConName, quoteDecName, quoteTypeName, quoteExpName, quotePatName]
-thSyn, thLib, qqLib, liftLib :: Module
+thSyn, thMonad, thLib, qqLib, liftLib :: Module
thSyn = mkTHModule (fsLit "GHC.Internal.TH.Syntax")
+thMonad = mkTHModule (fsLit "GHC.Internal.TH.Monad")
thLib = mkTHModule (fsLit "GHC.Internal.TH.Lib")
qqLib = mkTHModule (fsLit "GHC.Internal.TH.Quote")
liftLib = mkTHModule (fsLit "GHC.Internal.TH.Lift")
+
mkTHModule :: FastString -> Module
mkTHModule m = mkModule ghcInternalUnit (mkModuleNameFS m)
-libFun, libTc, thFun, thTc, thCls, thCon, liftFun :: FastString -> Unique -> Name
+libFun, libTc, thFun, thTc, thCon, liftFun, thMonadTc, thMonadCls, thMonadFun :: FastString -> Unique -> Name
libFun = mk_known_key_name varName thLib
libTc = mk_known_key_name tcName thLib
thFun = mk_known_key_name varName thSyn
thTc = mk_known_key_name tcName thSyn
-thCls = mk_known_key_name clsName thSyn
thCon = mk_known_key_name dataName thSyn
liftFun = mk_known_key_name varName liftLib
+thMonadTc = mk_known_key_name tcName thMonad
+thMonadCls = mk_known_key_name clsName thMonad
+thMonadFun = mk_known_key_name varName thMonad
-thFld :: FastString -> FastString -> Unique -> Name
-thFld con = mk_known_key_name (fieldName con) thSyn
+thMonadFld :: FastString -> FastString -> Unique -> Name
+thMonadFld con = mk_known_key_name (fieldName con) thSyn
qqFld :: FastString -> Unique -> Name
qqFld = mk_known_key_name (fieldName (fsLit "QuasiQuoter")) qqLib
@@ -210,14 +214,14 @@ liftClassName :: Name
liftClassName = mk_known_key_name clsName liftLib (fsLit "Lift") liftClassKey
quoteClassName :: Name
-quoteClassName = thCls (fsLit "Quote") quoteClassKey
+quoteClassName = thMonadCls (fsLit "Quote") quoteClassKey
qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
matchTyConName, clauseTyConName, funDepTyConName, predTyConName,
codeTyConName, injAnnTyConName, overlapTyConName, decsTyConName,
modNameTyConName, quasiQuoterTyConName :: Name
-qTyConName = thTc (fsLit "Q") qTyConKey
+qTyConName = thMonadTc (fsLit "Q") qTyConKey
nameTyConName = thTc (fsLit "Name") nameTyConKey
fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
patTyConName = thTc (fsLit "Pat") patTyConKey
@@ -230,20 +234,18 @@ matchTyConName = thTc (fsLit "Match") matchTyConKey
clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
predTyConName = thTc (fsLit "Pred") predTyConKey
-codeTyConName = thTc (fsLit "Code") codeTyConKey
+codeTyConName = thMonadTc (fsLit "Code") codeTyConKey
injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey
overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey
modNameTyConName = thTc (fsLit "ModName") modNameTyConKey
quasiQuoterTyConName = mk_known_key_name tcName qqLib (fsLit "QuasiQuoter") quasiQuoterTyConKey
-returnQName, bindQName, sequenceQName, newNameName, liftName,
+sequenceQName, newNameName, liftName,
mkNameName, mkNameG_vName, mkNameG_fldName, mkNameG_dName, mkNameG_tcName,
mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName,
unsafeCodeCoerceName, liftTypedName, mkModNameName, mkNameQName :: Name
-returnQName = thFun (fsLit "returnQ") returnQIdKey
-bindQName = thFun (fsLit "bindQ") bindQIdKey
-sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
-newNameName = thFun (fsLit "newName") newNameIdKey
+sequenceQName = thMonadFun (fsLit "sequenceQ") sequenceQIdKey
+newNameName = thMonadFun (fsLit "newName") newNameIdKey
mkNameName = thFun (fsLit "mkName") mkNameIdKey
mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey
mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
@@ -253,9 +255,9 @@ mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey
mkNameQName = thFun (fsLit "mkNameQ") mkNameQIdKey
mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey
mkModNameName = thFun (fsLit "mkModName") mkModNameIdKey
-unTypeName = thFld (fsLit "TExp") (fsLit "unType") unTypeIdKey
-unTypeCodeName = thFun (fsLit "unTypeCode") unTypeCodeIdKey
-unsafeCodeCoerceName = thFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey
+unTypeName = thMonadFld (fsLit "TExp") (fsLit "unType") unTypeIdKey
+unTypeCodeName = thMonadFun (fsLit "unTypeCode") unTypeCodeIdKey
+unsafeCodeCoerceName = thMonadFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey
liftName = liftFun (fsLit "lift") liftIdKey
liftStringName = liftFun (fsLit "liftString") liftStringIdKey
liftTypedName = liftFun (fsLit "liftTyped") liftTypedIdKey
@@ -808,12 +810,10 @@ dataNamespaceSpecifierDataConKey = mkPreludeDataConUnique 215
-- IdUniques available: 200-499
-- If you want to change this, make sure you check in GHC.Builtin.Names
-returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
+sequenceQIdKey, liftIdKey, newNameIdKey,
mkNameIdKey, mkNameG_vIdKey, mkNameG_fldIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey,
unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey, mkNameQIdKey :: Unique
-returnQIdKey = mkPreludeMiscIdUnique 200
-bindQIdKey = mkPreludeMiscIdUnique 201
sequenceQIdKey = mkPreludeMiscIdUnique 202
liftIdKey = mkPreludeMiscIdUnique 203
newNameIdKey = mkPreludeMiscIdUnique 204
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -68,7 +68,7 @@ import GHC.Tc.Utils.TcType (TcType, TcTyVar)
import {-# SOURCE #-} GHC.Tc.Types.LclEnv (TcLclEnv)
import GHCi.RemoteTypes ( ForeignRef )
-import qualified GHC.Boot.TH.Syntax as TH (Q)
+import qualified GHC.Boot.TH.Monad as TH (Q)
-- libraries:
import Data.Data hiding (Fixity(..))
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -245,14 +245,14 @@ first generate a polymorphic definition and then just apply the wrapper at the e
[| \x -> x |]
====>
- gensym (unpackString "x"#) `bindQ` \ x1::String ->
- lam (pvar x1) (var x1)
+ newName (unpackString "x"#) >>= \ x1::Name ->
+ lamE (varP x1) (varE x1)
[| \x -> $(f [| x |]) |]
====>
- gensym (unpackString "x"#) `bindQ` \ x1::String ->
- lam (pvar x1) (f (var x1))
+ newName (unpackString "x"#) >>= \ x1::Name ->
+ lamE (varP x1) (f (varE x1))
-}
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -68,7 +68,7 @@ import {-# SOURCE #-} GHC.Tc.Gen.Splice
import GHC.Tc.Zonk.Type
import GHCi.RemoteTypes ( ForeignRef )
-import qualified GHC.Boot.TH.Syntax as TH (Q)
+import qualified GHC.Boot.TH.Monad as TH (Q)
import qualified GHC.LanguageExtensions as LangExt
import qualified Data.Set as Set
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -144,6 +144,7 @@ import qualified GHC.LanguageExtensions as LangExt
-- THSyntax gives access to internal functions and data types
import qualified GHC.Boot.TH.Syntax as TH
+import qualified GHC.Boot.TH.Monad as TH
import qualified GHC.Boot.TH.Ppr as TH
#if defined(HAVE_INTERNAL_INTERPRETER)
=====================================
compiler/GHC/Tc/Gen/Splice.hs-boot
=====================================
@@ -12,6 +12,7 @@ import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc )
import GHC.Hs ( HsQuote, HsExpr, LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers, HsUntypedSpliceResult, HsTypedSpliceResult, HsTypedSplice )
import qualified GHC.Boot.TH.Syntax as TH
+import qualified GHC.Boot.TH.Monad as TH
tcTypedSplice :: HsTypedSpliceResult
-> HsTypedSplice GhcRn
=====================================
compiler/GHC/Tc/Types/TH.hs
=====================================
@@ -18,7 +18,7 @@ module GHC.Tc.Types.TH (
import GHC.Prelude
import GHCi.RemoteTypes
-import qualified GHC.Boot.TH.Syntax as TH
+import qualified GHC.Boot.TH.Monad as TH
import GHC.Tc.Types.Evidence
import GHC.Utils.Outputable
import GHC.Tc.Types.TcRef
=====================================
libraries/base/src/Data/Array/Byte.hs
=====================================
@@ -32,6 +32,7 @@ import GHC.Internal.Show (intToDigit)
import GHC.Internal.ST (ST(..), runST)
import GHC.Internal.Word (Word8(..))
import GHC.Internal.TH.Syntax
+import GHC.Internal.TH.Monad
import GHC.Internal.TH.Lift
import GHC.Internal.ForeignPtr
import Prelude
=====================================
libraries/base/src/Data/Fixed.hs
=====================================
@@ -91,7 +91,7 @@ import GHC.Internal.TypeLits (KnownNat, natVal)
import GHC.Internal.Read
import GHC.Internal.Text.ParserCombinators.ReadPrec
import GHC.Internal.Text.Read.Lex
-import qualified GHC.Internal.TH.Syntax as TH
+import qualified GHC.Internal.TH.Monad as TH
import qualified GHC.Internal.TH.Lift as TH
import Data.Typeable
import Prelude
=====================================
libraries/ghc-boot-th/GHC/Boot/TH/Monad.hs
=====================================
@@ -0,0 +1,6 @@
+{-# LANGUAGE Safe #-}
+{-# OPTIONS_HADDOCK not-home #-}
+module GHC.Boot.TH.Monad
+ (module GHC.Internal.TH.Monad) where
+
+import GHC.Internal.TH.Monad
=====================================
libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE Safe #-}
{-# LANGUAGE LambdaCase #-}
-- | contains a prettyprinter for the
-- Template Haskell datatypes
=====================================
libraries/ghc-boot-th/ghc-boot-th.cabal.in
=====================================
@@ -60,9 +60,11 @@ Library
exposed-modules:
GHC.Boot.TH.Lib
GHC.Boot.TH.Syntax
+ GHC.Boot.TH.Monad
other-modules:
GHC.Internal.TH.Lib
GHC.Internal.TH.Syntax
+ GHC.Internal.TH.Monad
GHC.Internal.ForeignSrcLang
GHC.Internal.LanguageExtensions
GHC.Internal.Lexeme
@@ -74,4 +76,5 @@ Library
GHC.Boot.TH.Lib,
GHC.Boot.TH.Lift,
GHC.Boot.TH.Quote,
- GHC.Boot.TH.Syntax
+ GHC.Boot.TH.Syntax,
+ GHC.Boot.TH.Monad
=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -298,6 +298,7 @@ Library
GHC.Internal.TH.Lib
GHC.Internal.TH.Lift
GHC.Internal.TH.Quote
+ GHC.Internal.TH.Monad
GHC.Internal.TopHandler
GHC.Internal.TypeError
GHC.Internal.TypeLits
=====================================
libraries/ghc-internal/src/GHC/Internal/Data/Data.hs
=====================================
@@ -143,6 +143,7 @@ import GHC.Internal.Arr -- So we can give Data instance for Array
import qualified GHC.Internal.Generics as Generics (Fixity(..))
import GHC.Internal.Generics hiding (Fixity(..))
-- So we can give Data instance for U1, V1, ...
+import qualified GHC.Internal.TH.Syntax as TH
------------------------------------------------------------------------------
--
@@ -1353,3 +1354,63 @@ deriving instance Data DecidedStrictness
-- | @since base-4.12.0.0
deriving instance Data a => Data (Down a)
+
+----------------------------------------------------------------------------
+-- Data instances for GHC.Internal.TH.Syntax
+
+deriving instance Data TH.AnnLookup
+deriving instance Data TH.AnnTarget
+deriving instance Data TH.Bang
+deriving instance Data TH.BndrVis
+deriving instance Data TH.Body
+deriving instance Data TH.Bytes
+deriving instance Data TH.Callconv
+deriving instance Data TH.Clause
+deriving instance Data TH.Con
+deriving instance Data TH.Dec
+deriving instance Data TH.DecidedStrictness
+deriving instance Data TH.DerivClause
+deriving instance Data TH.DerivStrategy
+deriving instance Data TH.DocLoc
+deriving instance Data TH.Exp
+deriving instance Data TH.FamilyResultSig
+deriving instance Data TH.Fixity
+deriving instance Data TH.FixityDirection
+deriving instance Data TH.Foreign
+deriving instance Data TH.FunDep
+deriving instance Data TH.Guard
+deriving instance Data TH.Info
+deriving instance Data TH.InjectivityAnn
+deriving instance Data TH.Inline
+deriving instance Data TH.Lit
+deriving instance Data TH.Loc
+deriving instance Data TH.Match
+deriving instance Data TH.ModName
+deriving instance Data TH.Module
+deriving instance Data TH.ModuleInfo
+deriving instance Data TH.Name
+deriving instance Data TH.NameFlavour
+deriving instance Data TH.NameSpace
+deriving instance Data TH.NamespaceSpecifier
+deriving instance Data TH.OccName
+deriving instance Data TH.Overlap
+deriving instance Data TH.Pat
+deriving instance Data TH.PatSynArgs
+deriving instance Data TH.PatSynDir
+deriving instance Data TH.Phases
+deriving instance Data TH.PkgName
+deriving instance Data TH.Pragma
+deriving instance Data TH.Range
+deriving instance Data TH.Role
+deriving instance Data TH.RuleBndr
+deriving instance Data TH.RuleMatch
+deriving instance Data TH.Safety
+deriving instance Data TH.SourceStrictness
+deriving instance Data TH.SourceUnpackedness
+deriving instance Data TH.Specificity
+deriving instance Data TH.Stmt
+deriving instance Data TH.TyLit
+deriving instance Data TH.TySynEqn
+deriving instance Data TH.Type
+deriving instance Data TH.TypeFamilyHead
+deriving instance Data flag => Data (TH.TyVarBndr flag)
=====================================
libraries/ghc-internal/src/GHC/Internal/Lexeme.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
=====================================
@@ -21,6 +21,7 @@
module GHC.Internal.TH.Lib where
import GHC.Internal.TH.Syntax hiding (Role, InjectivityAnn)
+import GHC.Internal.TH.Monad
import qualified GHC.Internal.TH.Syntax as TH
#ifdef BOOTSTRAP_TH
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
=====================================
@@ -30,6 +30,7 @@ module GHC.Internal.TH.Lift
where
import GHC.Internal.TH.Syntax
+import GHC.Internal.TH.Monad
import qualified GHC.Internal.TH.Lib as Lib (litE) -- See wrinkle (W4) of Note [Tracking dependencies on primitives]
import GHC.Internal.Data.Either
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
=====================================
@@ -0,0 +1,971 @@
+{-# OPTIONS_HADDOCK not-home #-} -- we want users to import Language.Haskell.TH.Syntax instead
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs#-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE UnboxedSums #-}
+
+-- | This module is used internally in GHC's integration with Template Haskell
+-- and defines the Monads of Template Haskell, and associated definitions.
+--
+-- This is not a part of the public API, and as such, there are no API
+-- guarantees for this module from version to version.
+--
+-- Import "Language.Haskell.TH" or "Language.Haskell.TH.Syntax" instead!
+module GHC.Internal.TH.Monad
+ ( module GHC.Internal.TH.Monad
+ ) where
+
+#ifdef BOOTSTRAP_TH
+import Prelude
+import Data.Data hiding (Fixity(..))
+import Data.IORef
+import System.IO.Unsafe ( unsafePerformIO )
+import Control.Monad.IO.Class (MonadIO (..))
+import Control.Monad.Fix (MonadFix (..))
+import Control.Exception (BlockedIndefinitelyOnMVar (..), catch, throwIO)
+import Control.Exception.Base (FixIOException (..))
+import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar)
+import System.IO ( hPutStrLn, stderr )
+import qualified Data.Kind as Kind (Type)
+import GHC.IO.Unsafe ( unsafeDupableInterleaveIO )
+import GHC.Types (TYPE, RuntimeRep(..))
+#else
+import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence)
+import GHC.Internal.Data.Data hiding (Fixity(..))
+import GHC.Internal.Data.Traversable
+import GHC.Internal.IORef
+import GHC.Internal.System.IO
+import GHC.Internal.Data.Foldable
+import GHC.Internal.Data.Typeable
+import GHC.Internal.Control.Monad.IO.Class
+import GHC.Internal.Control.Monad.Fail
+import GHC.Internal.Control.Monad.Fix
+import GHC.Internal.Control.Exception
+import GHC.Internal.Num
+import GHC.Internal.IO.Unsafe
+import GHC.Internal.MVar
+import GHC.Internal.IO.Exception
+import qualified GHC.Internal.Types as Kind (Type)
+#endif
+import GHC.Internal.ForeignSrcLang
+import GHC.Internal.LanguageExtensions
+import GHC.Internal.TH.Syntax
+
+-----------------------------------------------------
+--
+-- The Quasi class
+--
+-----------------------------------------------------
+
+class (MonadIO m, MonadFail m) => Quasi m where
+ -- | Fresh names. See 'newName'.
+ qNewName :: String -> m Name
+
+ ------- Error reporting and recovery -------
+ -- | Report an error (True) or warning (False)
+ -- ...but carry on; use 'fail' to stop. See 'report'.
+ qReport :: Bool -> String -> m ()
+
+ -- | See 'recover'.
+ qRecover :: m a -- ^ the error handler
+ -> m a -- ^ action which may fail
+ -> m a -- ^ Recover from the monadic 'fail'
+
+ ------- Inspect the type-checker's environment -------
+ -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
+ qLookupName :: Bool -> String -> m (Maybe Name)
+ -- | See 'reify'.
+ qReify :: Name -> m Info
+ -- | See 'reifyFixity'.
+ qReifyFixity :: Name -> m (Maybe Fixity)
+ -- | See 'reifyType'.
+ qReifyType :: Name -> m Type
+ -- | Is (n tys) an instance? Returns list of matching instance Decs (with
+ -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
+ qReifyInstances :: Name -> [Type] -> m [Dec]
+ -- | See 'reifyRoles'.
+ qReifyRoles :: Name -> m [Role]
+ -- | See 'reifyAnnotations'.
+ qReifyAnnotations :: Data a => AnnLookup -> m [a]
+ -- | See 'reifyModule'.
+ qReifyModule :: Module -> m ModuleInfo
+ -- | See 'reifyConStrictness'.
+ qReifyConStrictness :: Name -> m [DecidedStrictness]
+
+ -- | See 'location'.
+ qLocation :: m Loc
+
+ -- | Input/output (dangerous). See 'runIO'.
+ qRunIO :: IO a -> m a
+ qRunIO = liftIO
+ -- | See 'getPackageRoot'.
+ qGetPackageRoot :: m FilePath
+
+ -- | See 'addDependentFile'.
+ qAddDependentFile :: FilePath -> m ()
+
+ -- | See 'addTempFile'.
+ qAddTempFile :: String -> m FilePath
+
+ -- | See 'addTopDecls'.
+ qAddTopDecls :: [Dec] -> m ()
+
+ -- | See 'addForeignFilePath'.
+ qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
+
+ -- | See 'addModFinalizer'.
+ qAddModFinalizer :: Q () -> m ()
+
+ -- | See 'addCorePlugin'.
+ qAddCorePlugin :: String -> m ()
+
+ -- | See 'getQ'.
+ qGetQ :: Typeable a => m (Maybe a)
+
+ -- | See 'putQ'.
+ qPutQ :: Typeable a => a -> m ()
+
+ -- | See 'isExtEnabled'.
+ qIsExtEnabled :: Extension -> m Bool
+ -- | See 'extsEnabled'.
+ qExtsEnabled :: m [Extension]
+
+ -- | See 'putDoc'.
+ qPutDoc :: DocLoc -> String -> m ()
+ -- | See 'getDoc'.
+ qGetDoc :: DocLoc -> m (Maybe String)
+
+-----------------------------------------------------
+-- The IO instance of Quasi
+-----------------------------------------------------
+
+-- | This instance is used only when running a Q
+-- computation in the IO monad, usually just to
+-- print the result. There is no interesting
+-- type environment, so reification isn't going to
+-- work.
+instance Quasi IO where
+ qNewName = newNameIO
+
+ qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
+ qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
+
+ qLookupName _ _ = badIO "lookupName"
+ qReify _ = badIO "reify"
+ qReifyFixity _ = badIO "reifyFixity"
+ qReifyType _ = badIO "reifyFixity"
+ qReifyInstances _ _ = badIO "reifyInstances"
+ qReifyRoles _ = badIO "reifyRoles"
+ qReifyAnnotations _ = badIO "reifyAnnotations"
+ qReifyModule _ = badIO "reifyModule"
+ qReifyConStrictness _ = badIO "reifyConStrictness"
+ qLocation = badIO "currentLocation"
+ qRecover _ _ = badIO "recover" -- Maybe we could fix this?
+ qGetPackageRoot = badIO "getProjectRoot"
+ qAddDependentFile _ = badIO "addDependentFile"
+ qAddTempFile _ = badIO "addTempFile"
+ qAddTopDecls _ = badIO "addTopDecls"
+ qAddForeignFilePath _ _ = badIO "addForeignFilePath"
+ qAddModFinalizer _ = badIO "addModFinalizer"
+ qAddCorePlugin _ = badIO "addCorePlugin"
+ qGetQ = badIO "getQ"
+ qPutQ _ = badIO "putQ"
+ qIsExtEnabled _ = badIO "isExtEnabled"
+ qExtsEnabled = badIO "extsEnabled"
+ qPutDoc _ _ = badIO "putDoc"
+ qGetDoc _ = badIO "getDoc"
+
+instance Quote IO where
+ newName = newNameIO
+
+newNameIO :: String -> IO Name
+newNameIO s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x))
+ ; pure (mkNameU s n) }
+
+badIO :: String -> IO a
+badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad")
+ ; fail "Template Haskell failure" }
+
+-- Global variable to generate unique symbols
+counter :: IORef Uniq
+{-# NOINLINE counter #-}
+counter = unsafePerformIO (newIORef 0)
+
+
+-----------------------------------------------------
+--
+-- The Q monad
+--
+-----------------------------------------------------
+
+-- | In short, 'Q' provides the 'Quasi' operations in one neat monad for the
+-- user.
+--
+-- The longer story, is that 'Q' wraps an arbitrary 'Quasi'-able monad.
+-- The perceptive reader notices that 'Quasi' has only two instances, 'Q'
+-- itself and 'IO', neither of which have concrete implementations.'Q' plays
+-- the trick of [dependency
+-- inversion](https://en.wikipedia.org/wiki/Dependency_inversion_principle),
+-- providing an abstract interface for the user which is later concretely
+-- fufilled by an concrete 'Quasi' instance, internal to GHC.
+newtype Q a = Q { unQ :: forall m. Quasi m => m a }
+
+-- | \"Runs\" the 'Q' monad. Normal users of Template Haskell
+-- should not need this function, as the splice brackets @$( ... )@
+-- are the usual way of running a 'Q' computation.
+--
+-- This function is primarily used in GHC internals, and for debugging
+-- splices by running them in 'IO'.
+--
+-- Note that many functions in 'Q', such as 'reify' and other compiler
+-- queries, are not supported when running 'Q' in 'IO'; these operations
+-- simply fail at runtime. Indeed, the only operations guaranteed to succeed
+-- are 'newName', 'runIO', 'reportError' and 'reportWarning'.
+runQ :: Quasi m => Q a -> m a
+runQ (Q m) = m
+
+instance Monad Q where
+ Q m >>= k = Q (m >>= \x -> unQ (k x))
+ (>>) = (*>)
+
+instance MonadFail Q where
+ fail s = report True s >> Q (fail "Q monad failure")
+
+instance Functor Q where
+ fmap f (Q x) = Q (fmap f x)
+
+instance Applicative Q where
+ pure x = Q (pure x)
+ Q f <*> Q x = Q (f <*> x)
+ Q m *> Q n = Q (m *> n)
+
+-- | @since 2.17.0.0
+instance Semigroup a => Semigroup (Q a) where
+ (<>) = liftA2 (<>)
+
+-- | @since 2.17.0.0
+instance Monoid a => Monoid (Q a) where
+ mempty = pure mempty
+
+-- | If the function passed to 'mfix' inspects its argument,
+-- the resulting action will throw a 'FixIOException'.
+--
+-- @since 2.17.0.0
+instance MonadFix Q where
+ -- We use the same blackholing approach as in fixIO.
+ -- See Note [Blackholing in fixIO] in System.IO in base.
+ mfix k = do
+ m <- runIO newEmptyMVar
+ ans <- runIO (unsafeDupableInterleaveIO
+ (readMVar m `catch` \BlockedIndefinitelyOnMVar ->
+ throwIO FixIOException))
+ result <- k ans
+ runIO (putMVar m result)
+ return result
+
+
+-----------------------------------------------------
+--
+-- The Quote class
+--
+-----------------------------------------------------
+
+
+
+-- | The 'Quote' class implements the minimal interface which is necessary for
+-- desugaring quotations.
+--
+-- * The @Monad m@ superclass is needed to stitch together the different
+-- AST fragments.
+-- * 'newName' is used when desugaring binding structures such as lambdas
+-- to generate fresh names.
+--
+-- Therefore the type of an untyped quotation in GHC is `Quote m => m Exp`
+--
+-- For many years the type of a quotation was fixed to be `Q Exp` but by
+-- more precisely specifying the minimal interface it enables the `Exp` to
+-- be extracted purely from the quotation without interacting with `Q`.
+class Monad m => Quote m where
+ {- |
+ Generate a fresh name, which cannot be captured.
+
+ For example, this:
+
+ @f = $(do
+ nm1 <- newName \"x\"
+ let nm2 = 'mkName' \"x\"
+ return ('LamE' ['VarP' nm1] (LamE [VarP nm2] ('VarE' nm1)))
+ )@
+
+ will produce the splice
+
+ >f = \x0 -> \x -> x0
+
+ In particular, the occurrence @VarE nm1@ refers to the binding @VarP nm1@,
+ and is not captured by the binding @VarP nm2@.
+
+ Although names generated by @newName@ cannot /be captured/, they can
+ /capture/ other names. For example, this:
+
+ >g = $(do
+ > nm1 <- newName "x"
+ > let nm2 = mkName "x"
+ > return (LamE [VarP nm2] (LamE [VarP nm1] (VarE nm2)))
+ > )
+
+ will produce the splice
+
+ >g = \x -> \x0 -> x0
+
+ since the occurrence @VarE nm2@ is captured by the innermost binding
+ of @x@, namely @VarP nm1@.
+ -}
+ newName :: String -> m Name
+
+instance Quote Q where
+ newName s = Q (qNewName s)
+
+-----------------------------------------------------
+--
+-- The TExp type
+--
+-----------------------------------------------------
+
+type TExp :: TYPE r -> Kind.Type
+type role TExp nominal -- See Note [Role of TExp]
+newtype TExp a = TExp
+ { unType :: Exp -- ^ Underlying untyped Template Haskell expression
+ }
+-- ^ Typed wrapper around an 'Exp'.
+--
+-- This is the typed representation of terms produced by typed quotes.
+--
+-- Representation-polymorphic since /template-haskell-2.16.0.0/.
+
+-- | Discard the type annotation and produce a plain Template Haskell
+-- expression
+--
+-- Representation-polymorphic since /template-haskell-2.16.0.0/.
+unTypeQ :: forall (r :: RuntimeRep) (a :: TYPE r) m . Quote m => m (TExp a) -> m Exp
+unTypeQ m = do { TExp e <- m
+ ; return e }
+
+-- | Annotate the Template Haskell expression with a type
+--
+-- This is unsafe because GHC cannot check for you that the expression
+-- really does have the type you claim it has.
+--
+-- Representation-polymorphic since /template-haskell-2.16.0.0/.
+unsafeTExpCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m .
+ Quote m => m Exp -> m (TExp a)
+unsafeTExpCoerce m = do { e <- m
+ ; return (TExp e) }
+
+{- Note [Role of TExp]
+~~~~~~~~~~~~~~~~~~~~~~
+TExp's argument must have a nominal role, not phantom as would
+be inferred (#8459). Consider
+
+ e :: Code Q Age
+ e = [|| MkAge 3 ||]
+
+ foo = $(coerce e) + 4::Int
+
+The splice will evaluate to (MkAge 3) and you can't add that to
+4::Int. So you can't coerce a (Code Q Age) to a (Code Q Int). -}
+
+-- Code constructor
+#if __GLASGOW_HASKELL__ >= 909
+type Code :: (Kind.Type -> Kind.Type) -> forall r. TYPE r -> Kind.Type
+ -- See Note [Foralls to the right in Code]
+#else
+type Code :: (Kind.Type -> Kind.Type) -> TYPE r -> Kind.Type
+#endif
+type role Code representational nominal -- See Note [Role of TExp]
+newtype Code m a = Code
+ { examineCode :: m (TExp a) -- ^ Underlying monadic value
+ }
+-- ^ Represents an expression which has type @a@, built in monadic context @m@. Built on top of 'TExp', typed
+-- expressions allow for type-safe splicing via:
+--
+-- - typed quotes, written as @[|| ... ||]@ where @...@ is an expression; if
+-- that expression has type @a@, then the quotation has type
+-- @Quote m => Code m a@
+--
+-- - typed splices inside of typed quotes, written as @$$(...)@ where @...@
+-- is an arbitrary expression of type @Quote m => Code m a@
+--
+-- Traditional expression quotes and splices let us construct ill-typed
+-- expressions:
+--
+-- >>> fmap ppr $ runQ (unTypeCode [| True == $( [| "foo" |] ) |])
+-- GHC.Internal.Types.True GHC.Internal.Classes.== "foo"
+-- >>> GHC.Internal.Types.True GHC.Internal.Classes.== "foo"
+-- <interactive> error:
+-- • Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
+-- • In the second argument of ‘(==)’, namely ‘"foo"’
+-- In the expression: True == "foo"
+-- In an equation for ‘it’: it = True == "foo"
+--
+-- With typed expressions, the type error occurs when /constructing/ the
+-- Template Haskell expression:
+--
+-- >>> fmap ppr $ runQ (unTypeCode [|| True == $$( [|| "foo" ||] ) ||])
+-- <interactive> error:
+-- • Couldn't match type ‘[Char]’ with ‘Bool’
+-- Expected type: Code Q Bool
+-- Actual type: Code Q [Char]
+-- • In the Template Haskell quotation [|| "foo" ||]
+-- In the expression: [|| "foo" ||]
+-- In the Template Haskell splice $$([|| "foo" ||])
+
+
+{- Note [Foralls to the right in Code]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Code has the following type signature:
+ type Code :: (Kind.Type -> Kind.Type) -> forall r. TYPE r -> Kind.Type
+
+This allows us to write
+ data T (f :: forall r . (TYPE r) -> Type) = MkT (f Int) (f Int#)
+
+ tcodeq :: T (Code Q)
+ tcodeq = MkT [||5||] [||5#||]
+
+If we used the slightly more straightforward signature
+ type Code :: foral r. (Kind.Type -> Kind.Type) -> TYPE r -> Kind.Type
+
+then the example above would become ill-typed. (See #23592 for some discussion.)
+-}
+
+-- | Unsafely convert an untyped code representation into a typed code
+-- representation.
+unsafeCodeCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m .
+ Quote m => m Exp -> Code m a
+unsafeCodeCoerce m = Code (unsafeTExpCoerce m)
+
+-- | Lift a monadic action producing code into the typed 'Code'
+-- representation
+liftCode :: forall (r :: RuntimeRep) (a :: TYPE r) m . m (TExp a) -> Code m a
+liftCode = Code
+
+-- | Extract the untyped representation from the typed representation
+unTypeCode :: forall (r :: RuntimeRep) (a :: TYPE r) m . Quote m
+ => Code m a -> m Exp
+unTypeCode = unTypeQ . examineCode
+
+-- | Modify the ambient monad used during code generation. For example, you
+-- can use `hoistCode` to handle a state effect:
+-- @
+-- handleState :: Code (StateT Int Q) a -> Code Q a
+-- handleState = hoistCode (flip runState 0)
+-- @
+hoistCode :: forall m n (r :: RuntimeRep) (a :: TYPE r) . Monad m
+ => (forall x . m x -> n x) -> Code m a -> Code n a
+hoistCode f (Code a) = Code (f a)
+
+
+-- | Variant of '(>>=)' which allows effectful computations to be injected
+-- into code generation.
+bindCode :: forall m a (r :: RuntimeRep) (b :: TYPE r) . Monad m
+ => m a -> (a -> Code m b) -> Code m b
+bindCode q k = liftCode (q >>= examineCode . k)
+
+-- | Variant of '(>>)' which allows effectful computations to be injected
+-- into code generation.
+bindCode_ :: forall m a (r :: RuntimeRep) (b :: TYPE r) . Monad m
+ => m a -> Code m b -> Code m b
+bindCode_ q c = liftCode ( q >> examineCode c)
+
+-- | A useful combinator for embedding monadic actions into 'Code'
+-- @
+-- myCode :: ... => Code m a
+-- myCode = joinCode $ do
+-- x <- someSideEffect
+-- return (makeCodeWith x)
+-- @
+joinCode :: forall m (r :: RuntimeRep) (a :: TYPE r) . Monad m
+ => m (Code m a) -> Code m a
+joinCode = flip bindCode id
+
+----------------------------------------------------
+-- Packaged versions for the programmer, hiding the Quasi-ness
+
+
+-- | Report an error (True) or warning (False),
+-- but carry on; use 'fail' to stop.
+report :: Bool -> String -> Q ()
+report b s = Q (qReport b s)
+{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6
+
+-- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'.
+reportError :: String -> Q ()
+reportError = report True
+
+-- | Report a warning to the user, and carry on.
+reportWarning :: String -> Q ()
+reportWarning = report False
+
+-- | Recover from errors raised by 'reportError' or 'fail'.
+recover :: Q a -- ^ handler to invoke on failure
+ -> Q a -- ^ computation to run
+ -> Q a
+recover (Q r) (Q m) = Q (qRecover r m)
+
+-- We don't export lookupName; the Bool isn't a great API
+-- Instead we export lookupTypeName, lookupValueName
+lookupName :: Bool -> String -> Q (Maybe Name)
+lookupName ns s = Q (qLookupName ns s)
+
+-- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
+lookupTypeName :: String -> Q (Maybe Name)
+lookupTypeName s = Q (qLookupName True s)
+
+-- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
+lookupValueName :: String -> Q (Maybe Name)
+lookupValueName s = Q (qLookupName False s)
+
+{-
+Note [Name lookup]
+~~~~~~~~~~~~~~~~~~
+-}
+{- $namelookup #namelookup#
+The functions 'lookupTypeName' and 'lookupValueName' provide
+a way to query the current splice's context for what names
+are in scope. The function 'lookupTypeName' queries the type
+namespace, whereas 'lookupValueName' queries the value namespace,
+but the functions are otherwise identical.
+
+A call @lookupValueName s@ will check if there is a value
+with name @s@ in scope at the current splice's location. If
+there is, the @Name@ of this value is returned;
+if not, then @Nothing@ is returned.
+
+The returned name cannot be \"captured\".
+For example:
+
+> f = "global"
+> g = $( do
+> Just nm <- lookupValueName "f"
+> [| let f = "local" in $( varE nm ) |]
+
+In this case, @g = \"global\"@; the call to @lookupValueName@
+returned the global @f@, and this name was /not/ captured by
+the local definition of @f@.
+
+The lookup is performed in the context of the /top-level/ splice
+being run. For example:
+
+> f = "global"
+> g = $( [| let f = "local" in
+> $(do
+> Just nm <- lookupValueName "f"
+> varE nm
+> ) |] )
+
+Again in this example, @g = \"global\"@, because the call to
+@lookupValueName@ queries the context of the outer-most @$(...)@.
+
+Operators should be queried without any surrounding parentheses, like so:
+
+> lookupValueName "+"
+
+Qualified names are also supported, like so:
+
+> lookupValueName "Prelude.+"
+> lookupValueName "Prelude.map"
+
+-}
+
+
+{- | 'reify' looks up information about the 'Name'. It will fail with
+a compile error if the 'Name' is not visible. A 'Name' is visible if it is
+imported or defined in a prior top-level declaration group. See the
+documentation for 'newDeclarationGroup' for more details.
+
+It is sometimes useful to construct the argument name using 'lookupTypeName' or 'lookupValueName'
+to ensure that we are reifying from the right namespace. For instance, in this context:
+
+> data D = D
+
+which @D@ does @reify (mkName \"D\")@ return information about? (Answer: @D@-the-type, but don't rely on it.)
+To ensure we get information about @D@-the-value, use 'lookupValueName':
+
+> do
+> Just nm <- lookupValueName "D"
+> reify nm
+
+and to get information about @D@-the-type, use 'lookupTypeName'.
+-}
+reify :: Name -> Q Info
+reify v = Q (qReify v)
+
+{- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For
+example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then
+@reifyFixity 'foo@ would return @'Just' ('Fixity' 7 'InfixR')@. If the function
+@bar@ does not have a fixity declaration, then @reifyFixity 'bar@ returns
+'Nothing', so you may assume @bar@ has 'defaultFixity'.
+-}
+reifyFixity :: Name -> Q (Maybe Fixity)
+reifyFixity nm = Q (qReifyFixity nm)
+
+{- | @reifyType nm@ attempts to find the type or kind of @nm@. For example,
+@reifyType 'not@ returns @Bool -> Bool@, and
+@reifyType ''Bool@ returns @Type@.
+This works even if there's no explicit signature and the type or kind is inferred.
+-}
+reifyType :: Name -> Q Type
+reifyType nm = Q (qReifyType nm)
+
+{- | Template Haskell is capable of reifying information about types and
+terms defined in previous declaration groups. Top-level declaration splices break up
+declaration groups.
+
+For an example, consider this code block. We define a datatype @X@ and
+then try to call 'reify' on the datatype.
+
+@
+module Check where
+
+data X = X
+ deriving Eq
+
+$(do
+ info <- reify ''X
+ runIO $ print info
+ )
+@
+
+This code fails to compile, noting that @X@ is not available for reification at the site of 'reify'. We can fix this by creating a new declaration group using an empty top-level splice:
+
+@
+data X = X
+ deriving Eq
+
+$(pure [])
+
+$(do
+ info <- reify ''X
+ runIO $ print info
+ )
+@
+
+We provide 'newDeclarationGroup' as a means of documenting this behavior
+and providing a name for the pattern.
+
+Since top level splices infer the presence of the @$( ... )@ brackets, we can also write:
+
+@
+data X = X
+ deriving Eq
+
+newDeclarationGroup
+
+$(do
+ info <- reify ''X
+ runIO $ print info
+ )
+@
+
+-}
+newDeclarationGroup :: Q [Dec]
+newDeclarationGroup = pure []
+
+{- | @reifyInstances nm tys@ returns a list of all visible instances (see below for "visible")
+of @nm tys@. That is,
+if @nm@ is the name of a type class, then all instances of this class at the types @tys@
+are returned. Alternatively, if @nm@ is the name of a data family or type family,
+all instances of this family at the types @tys@ are returned.
+
+Note that this is a \"shallow\" test; the declarations returned merely have
+instance heads which unify with @nm tys@, they need not actually be satisfiable.
+
+ - @reifyInstances ''Eq [ 'TupleT' 2 \``AppT`\` 'ConT' ''A \``AppT`\` 'ConT' ''B ]@ contains
+ the @instance (Eq a, Eq b) => Eq (a, b)@ regardless of whether @A@ and
+ @B@ themselves implement 'Eq'
+
+ - @reifyInstances ''Show [ 'VarT' ('mkName' "a") ]@ produces every available
+ instance of 'Show'
+
+There is one edge case: @reifyInstances ''Typeable tys@ currently always
+produces an empty list (no matter what @tys@ are given).
+
+In principle, the *visible* instances are
+* all instances defined in a prior top-level declaration group
+ (see docs on @newDeclarationGroup@), or
+* all instances defined in any module transitively imported by the
+ module being compiled
+
+However, actually searching all modules transitively below the one being
+compiled is unreasonably expensive, so @reifyInstances@ will report only the
+instance for modules that GHC has had some cause to visit during this
+compilation. This is a shortcoming: @reifyInstances@ might fail to report
+instances for a type that is otherwise unusued, or instances defined in a
+different component. You can work around this shortcoming by explicitly importing the modules
+whose instances you want to be visible. GHC issue <https://gitlab.haskell.org/ghc/ghc/-/issues/20529#note_388980 #20529>
+has some discussion around this.
+
+-}
+reifyInstances :: Name -> [Type] -> Q [InstanceDec]
+reifyInstances cls tys = Q (qReifyInstances cls tys)
+
+{- | @reifyRoles nm@ returns the list of roles associated with the parameters
+(both visible and invisible) of
+the tycon @nm@. Fails if @nm@ cannot be found or is not a tycon.
+The returned list should never contain 'InferR'.
+
+An invisible parameter to a tycon is often a kind parameter. For example, if
+we have
+
+@
+type Proxy :: forall k. k -> Type
+data Proxy a = MkProxy
+@
+
+and @reifyRoles Proxy@, we will get @['NominalR', 'PhantomR']@. The 'NominalR' is
+the role of the invisible @k@ parameter. Kind parameters are always nominal.
+-}
+reifyRoles :: Name -> Q [Role]
+reifyRoles nm = Q (qReifyRoles nm)
+
+-- | @reifyAnnotations target@ returns the list of annotations
+-- associated with @target@. Only the annotations that are
+-- appropriately typed is returned. So if you have @Int@ and @String@
+-- annotations for the same target, you have to call this function twice.
+reifyAnnotations :: Data a => AnnLookup -> Q [a]
+reifyAnnotations an = Q (qReifyAnnotations an)
+
+-- | @reifyModule mod@ looks up information about module @mod@. To
+-- look up the current module, call this function with the return
+-- value of 'Language.Haskell.TH.Lib.thisModule'.
+reifyModule :: Module -> Q ModuleInfo
+reifyModule m = Q (qReifyModule m)
+
+-- | @reifyConStrictness nm@ looks up the strictness information for the fields
+-- of the constructor with the name @nm@. Note that the strictness information
+-- that 'reifyConStrictness' returns may not correspond to what is written in
+-- the source code. For example, in the following data declaration:
+--
+-- @
+-- data Pair a = Pair a a
+-- @
+--
+-- 'reifyConStrictness' would return @['DecidedLazy', DecidedLazy]@ under most
+-- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the
+-- @-XStrictData@ language extension was enabled.
+reifyConStrictness :: Name -> Q [DecidedStrictness]
+reifyConStrictness n = Q (qReifyConStrictness n)
+
+-- | Is the list of instances returned by 'reifyInstances' nonempty?
+--
+-- If you're confused by an instance not being visible despite being
+-- defined in the same module and above the splice in question, see the
+-- docs for 'newDeclarationGroup' for a possible explanation.
+isInstance :: Name -> [Type] -> Q Bool
+isInstance nm tys = do { decs <- reifyInstances nm tys
+ ; return (not (null decs)) }
+
+-- | The location at which this computation is spliced.
+location :: Q Loc
+location = Q qLocation
+
+-- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad.
+-- Take care: you are guaranteed the ordering of calls to 'runIO' within
+-- a single 'Q' computation, but not about the order in which splices are run.
+--
+-- Note: for various murky reasons, stdout and stderr handles are not
+-- necessarily flushed when the compiler finishes running, so you should
+-- flush them yourself.
+runIO :: IO a -> Q a
+runIO m = Q (qRunIO m)
+
+-- | Get the package root for the current package which is being compiled.
+-- This can be set explicitly with the -package-root flag but is normally
+-- just the current working directory.
+--
+-- The motivation for this flag is to provide a principled means to remove the
+-- assumption from splices that they will be executed in the directory where the
+-- cabal file resides. Projects such as haskell-language-server can't and don't
+-- change directory when compiling files but instead set the -package-root flag
+-- appropriately.
+getPackageRoot :: Q FilePath
+getPackageRoot = Q qGetPackageRoot
+
+
+
+-- | Record external files that runIO is using (dependent upon).
+-- The compiler can then recognize that it should re-compile the Haskell file
+-- when an external file changes.
+--
+-- Expects an absolute file path.
+--
+-- Notes:
+--
+-- * ghc -M does not know about these dependencies - it does not execute TH.
+--
+-- * The dependency is based on file content, not a modification time
+addDependentFile :: FilePath -> Q ()
+addDependentFile fp = Q (qAddDependentFile fp)
+
+-- | Obtain a temporary file path with the given suffix. The compiler will
+-- delete this file after compilation.
+addTempFile :: String -> Q FilePath
+addTempFile suffix = Q (qAddTempFile suffix)
+
+-- | Add additional top-level declarations. The added declarations will be type
+-- checked along with the current declaration group.
+addTopDecls :: [Dec] -> Q ()
+addTopDecls ds = Q (qAddTopDecls ds)
+
+
+-- | Emit a foreign file which will be compiled and linked to the object for
+-- the current module. Currently only languages that can be compiled with
+-- the C compiler are supported, and the flags passed as part of -optc will
+-- be also applied to the C compiler invocation that will compile them.
+--
+-- Note that for non-C languages (for example C++) @extern "C"@ directives
+-- must be used to get symbols that we can access from Haskell.
+--
+-- To get better errors, it is recommended to use #line pragmas when
+-- emitting C files, e.g.
+--
+-- > {-# LANGUAGE CPP #-}
+-- > ...
+-- > addForeignSource LangC $ unlines
+-- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__
+-- > , ...
+-- > ]
+addForeignSource :: ForeignSrcLang -> String -> Q ()
+addForeignSource lang src = do
+ let suffix = case lang of
+ LangC -> "c"
+ LangCxx -> "cpp"
+ LangObjc -> "m"
+ LangObjcxx -> "mm"
+ LangAsm -> "s"
+ LangJs -> "js"
+ RawObject -> "a"
+ path <- addTempFile suffix
+ runIO $ writeFile path src
+ addForeignFilePath lang path
+
+-- | Same as 'addForeignSource', but expects to receive a path pointing to the
+-- foreign file instead of a 'String' of its contents. Consider using this in
+-- conjunction with 'addTempFile'.
+--
+-- This is a good alternative to 'addForeignSource' when you are trying to
+-- directly link in an object file.
+addForeignFilePath :: ForeignSrcLang -> FilePath -> Q ()
+addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp)
+
+-- | Add a finalizer that will run in the Q monad after the current module has
+-- been type checked. This only makes sense when run within a top-level splice.
+--
+-- The finalizer is given the local type environment at the splice point. Thus
+-- 'reify' is able to find the local definitions when executed inside the
+-- finalizer.
+addModFinalizer :: Q () -> Q ()
+addModFinalizer act = Q (qAddModFinalizer (unQ act))
+
+-- | Adds a core plugin to the compilation pipeline.
+--
+-- @addCorePlugin m@ has almost the same effect as passing @-fplugin=m@ to ghc
+-- in the command line. The major difference is that the plugin module @m@
+-- must not belong to the current package. When TH executes, it is too late
+-- to tell the compiler that we needed to compile first a plugin module in the
+-- current package.
+addCorePlugin :: String -> Q ()
+addCorePlugin plugin = Q (qAddCorePlugin plugin)
+
+-- | Get state from the 'Q' monad. Note that the state is local to the
+-- Haskell module in which the Template Haskell expression is executed.
+getQ :: Typeable a => Q (Maybe a)
+getQ = Q qGetQ
+
+-- | Replace the state in the 'Q' monad. Note that the state is local to the
+-- Haskell module in which the Template Haskell expression is executed.
+putQ :: Typeable a => a -> Q ()
+putQ x = Q (qPutQ x)
+
+-- | Determine whether the given language extension is enabled in the 'Q' monad.
+isExtEnabled :: Extension -> Q Bool
+isExtEnabled ext = Q (qIsExtEnabled ext)
+
+-- | List all enabled language extensions.
+extsEnabled :: Q [Extension]
+extsEnabled = Q qExtsEnabled
+
+-- | Add Haddock documentation to the specified location. This will overwrite
+-- any documentation at the location if it already exists. This will reify the
+-- specified name, so it must be in scope when you call it. If you want to add
+-- documentation to something that you are currently splicing, you can use
+-- 'addModFinalizer' e.g.
+--
+-- > do
+-- > let nm = mkName "x"
+-- > addModFinalizer $ putDoc (DeclDoc nm) "Hello"
+-- > [d| $(varP nm) = 42 |]
+--
+-- The helper functions 'withDecDoc' and 'withDecsDoc' will do this for you, as
+-- will the 'funD_doc' and other @_doc@ combinators.
+-- You most likely want to have the @-haddock@ flag turned on when using this.
+-- Adding documentation to anything outside of the current module will cause an
+-- error.
+putDoc :: DocLoc -> String -> Q ()
+putDoc t s = Q (qPutDoc t s)
+
+-- | Retrieves the Haddock documentation at the specified location, if one
+-- exists.
+-- It can be used to read documentation on things defined outside of the current
+-- module, provided that those modules were compiled with the @-haddock@ flag.
+getDoc :: DocLoc -> Q (Maybe String)
+getDoc n = Q (qGetDoc n)
+
+instance MonadIO Q where
+ liftIO = runIO
+
+instance Quasi Q where
+ qNewName = newName
+ qReport = report
+ qRecover = recover
+ qReify = reify
+ qReifyFixity = reifyFixity
+ qReifyType = reifyType
+ qReifyInstances = reifyInstances
+ qReifyRoles = reifyRoles
+ qReifyAnnotations = reifyAnnotations
+ qReifyModule = reifyModule
+ qReifyConStrictness = reifyConStrictness
+ qLookupName = lookupName
+ qLocation = location
+ qGetPackageRoot = getPackageRoot
+ qAddDependentFile = addDependentFile
+ qAddTempFile = addTempFile
+ qAddTopDecls = addTopDecls
+ qAddForeignFilePath = addForeignFilePath
+ qAddModFinalizer = addModFinalizer
+ qAddCorePlugin = addCorePlugin
+ qGetQ = getQ
+ qPutQ = putQ
+ qIsExtEnabled = isExtEnabled
+ qExtsEnabled = extsEnabled
+ qPutDoc = putDoc
+ qGetDoc = getDoc
+
+
+----------------------------------------------------
+-- The following operations are used solely in GHC.HsToCore.Quote when
+-- desugaring brackets. They are not necessary for the user, who can use
+-- ordinary return and (>>=) etc
+
+-- | This function is only used in 'GHC.HsToCore.Quote' when desugaring
+-- brackets. This is not necessary for the user, who can use the ordinary
+-- 'return' and '(>>=)' operations.
+sequenceQ :: forall m . Monad m => forall a . [m a] -> m [a]
+sequenceQ = sequence
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
=====================================
@@ -20,6 +20,7 @@ module GHC.Internal.TH.Quote(
) where
import GHC.Internal.TH.Syntax
+import GHC.Internal.TH.Monad
import GHC.Internal.Base hiding (Type)
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
=====================================
@@ -1,14 +1,16 @@
{-# OPTIONS_HADDOCK not-home #-} -- we want users to import Language.Haskell.TH.Syntax instead
-{-# LANGUAGE CPP, DeriveDataTypeable,
- DeriveGeneric, FlexibleInstances, DefaultSignatures,
- RankNTypes, RoleAnnotations, ScopedTypeVariables,
- MagicHash, KindSignatures, PolyKinds, TypeApplications, DataKinds,
- GADTs, UnboxedTuples, UnboxedSums, TypeOperators,
- Trustworthy, DeriveFunctor, DeriveTraversable,
- BangPatterns, RecordWildCards, ImplicitParams #-}
-
-{-# LANGUAGE TemplateHaskellQuotes #-}
-{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE UnboxedTuples #-}
-- | This module is used internally in GHC's integration with Template Haskell
-- and defines the abstract syntax of Template Haskell.
@@ -26,971 +28,37 @@ module GHC.Internal.TH.Syntax
#ifdef BOOTSTRAP_TH
import Prelude
-import Data.Data hiding (Fixity(..))
-import Data.IORef
import System.IO.Unsafe ( unsafePerformIO )
-import Control.Monad.IO.Class (MonadIO (..))
-import Control.Monad.Fix (MonadFix (..))
-import Control.Exception (BlockedIndefinitelyOnMVar (..), catch, throwIO)
-import Control.Exception.Base (FixIOException (..))
-import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar)
-import System.IO ( hPutStrLn, stderr )
import Data.Char ( isAlpha, isAlphaNum, isUpper )
import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Word
-import qualified Data.Kind as Kind (Type)
import Foreign.ForeignPtr
import Foreign.C.String
import Foreign.C.Types
-import GHC.IO.Unsafe ( unsafeDupableInterleaveIO )
import GHC.Ptr ( Ptr, plusPtr )
import GHC.Generics ( Generic )
-import GHC.Types (TYPE, RuntimeRep(..))
#else
import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence)
-import GHC.Internal.Data.Data hiding (Fixity(..))
import GHC.Internal.Data.NonEmpty (NonEmpty(..))
import GHC.Internal.Data.Traversable
import GHC.Internal.Word
import GHC.Internal.Generics (Generic)
-import GHC.Internal.IORef
-import GHC.Internal.System.IO
import GHC.Internal.Show
import GHC.Internal.Integer
import GHC.Internal.Real
import GHC.Internal.Data.Foldable
import GHC.Internal.Foreign.Ptr
import GHC.Internal.ForeignPtr
-import GHC.Internal.Data.Typeable
-import GHC.Internal.Control.Monad.IO.Class
import GHC.Internal.Foreign.C.Types
import GHC.Internal.Foreign.C.String
-import GHC.Internal.Control.Monad.Fail
-import GHC.Internal.Control.Monad.Fix
-import GHC.Internal.Control.Exception
import GHC.Internal.Num
import GHC.Internal.IO.Unsafe
import GHC.Internal.List (dropWhile, break, replicate, reverse, last)
-import GHC.Internal.MVar
-import GHC.Internal.IO.Exception
import GHC.Internal.Unicode
-import qualified GHC.Internal.Types as Kind (Type)
#endif
import GHC.Internal.ForeignSrcLang
import GHC.Internal.LanguageExtensions
------------------------------------------------------
---
--- The Quasi class
---
------------------------------------------------------
-
-class (MonadIO m, MonadFail m) => Quasi m where
- -- | Fresh names. See 'newName'.
- qNewName :: String -> m Name
-
- ------- Error reporting and recovery -------
- -- | Report an error (True) or warning (False)
- -- ...but carry on; use 'fail' to stop. See 'report'.
- qReport :: Bool -> String -> m ()
-
- -- | See 'recover'.
- qRecover :: m a -- ^ the error handler
- -> m a -- ^ action which may fail
- -> m a -- ^ Recover from the monadic 'fail'
-
- ------- Inspect the type-checker's environment -------
- -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
- qLookupName :: Bool -> String -> m (Maybe Name)
- -- | See 'reify'.
- qReify :: Name -> m Info
- -- | See 'reifyFixity'.
- qReifyFixity :: Name -> m (Maybe Fixity)
- -- | See 'reifyType'.
- qReifyType :: Name -> m Type
- -- | Is (n tys) an instance? Returns list of matching instance Decs (with
- -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
- qReifyInstances :: Name -> [Type] -> m [Dec]
- -- | See 'reifyRoles'.
- qReifyRoles :: Name -> m [Role]
- -- | See 'reifyAnnotations'.
- qReifyAnnotations :: Data a => AnnLookup -> m [a]
- -- | See 'reifyModule'.
- qReifyModule :: Module -> m ModuleInfo
- -- | See 'reifyConStrictness'.
- qReifyConStrictness :: Name -> m [DecidedStrictness]
-
- -- | See 'location'.
- qLocation :: m Loc
-
- -- | Input/output (dangerous). See 'runIO'.
- qRunIO :: IO a -> m a
- qRunIO = liftIO
- -- | See 'getPackageRoot'.
- qGetPackageRoot :: m FilePath
-
- -- | See 'addDependentFile'.
- qAddDependentFile :: FilePath -> m ()
-
- -- | See 'addTempFile'.
- qAddTempFile :: String -> m FilePath
-
- -- | See 'addTopDecls'.
- qAddTopDecls :: [Dec] -> m ()
-
- -- | See 'addForeignFilePath'.
- qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
-
- -- | See 'addModFinalizer'.
- qAddModFinalizer :: Q () -> m ()
-
- -- | See 'addCorePlugin'.
- qAddCorePlugin :: String -> m ()
-
- -- | See 'getQ'.
- qGetQ :: Typeable a => m (Maybe a)
-
- -- | See 'putQ'.
- qPutQ :: Typeable a => a -> m ()
-
- -- | See 'isExtEnabled'.
- qIsExtEnabled :: Extension -> m Bool
- -- | See 'extsEnabled'.
- qExtsEnabled :: m [Extension]
-
- -- | See 'putDoc'.
- qPutDoc :: DocLoc -> String -> m ()
- -- | See 'getDoc'.
- qGetDoc :: DocLoc -> m (Maybe String)
-
------------------------------------------------------
--- The IO instance of Quasi
------------------------------------------------------
-
--- | This instance is used only when running a Q
--- computation in the IO monad, usually just to
--- print the result. There is no interesting
--- type environment, so reification isn't going to
--- work.
-instance Quasi IO where
- qNewName = newNameIO
-
- qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
- qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
-
- qLookupName _ _ = badIO "lookupName"
- qReify _ = badIO "reify"
- qReifyFixity _ = badIO "reifyFixity"
- qReifyType _ = badIO "reifyFixity"
- qReifyInstances _ _ = badIO "reifyInstances"
- qReifyRoles _ = badIO "reifyRoles"
- qReifyAnnotations _ = badIO "reifyAnnotations"
- qReifyModule _ = badIO "reifyModule"
- qReifyConStrictness _ = badIO "reifyConStrictness"
- qLocation = badIO "currentLocation"
- qRecover _ _ = badIO "recover" -- Maybe we could fix this?
- qGetPackageRoot = badIO "getProjectRoot"
- qAddDependentFile _ = badIO "addDependentFile"
- qAddTempFile _ = badIO "addTempFile"
- qAddTopDecls _ = badIO "addTopDecls"
- qAddForeignFilePath _ _ = badIO "addForeignFilePath"
- qAddModFinalizer _ = badIO "addModFinalizer"
- qAddCorePlugin _ = badIO "addCorePlugin"
- qGetQ = badIO "getQ"
- qPutQ _ = badIO "putQ"
- qIsExtEnabled _ = badIO "isExtEnabled"
- qExtsEnabled = badIO "extsEnabled"
- qPutDoc _ _ = badIO "putDoc"
- qGetDoc _ = badIO "getDoc"
-
-instance Quote IO where
- newName = newNameIO
-
-newNameIO :: String -> IO Name
-newNameIO s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x))
- ; pure (mkNameU s n) }
-
-badIO :: String -> IO a
-badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad")
- ; fail "Template Haskell failure" }
-
--- Global variable to generate unique symbols
-counter :: IORef Uniq
-{-# NOINLINE counter #-}
-counter = unsafePerformIO (newIORef 0)
-
-
------------------------------------------------------
---
--- The Q monad
---
------------------------------------------------------
-
--- | In short, 'Q' provides the 'Quasi' operations in one neat monad for the
--- user.
---
--- The longer story, is that 'Q' wraps an arbitrary 'Quasi'-able monad.
--- The perceptive reader notices that 'Quasi' has only two instances, 'Q'
--- itself and 'IO', neither of which have concrete implementations.'Q' plays
--- the trick of [dependency
--- inversion](https://en.wikipedia.org/wiki/Dependency_inversion_principle),
--- providing an abstract interface for the user which is later concretely
--- fufilled by an concrete 'Quasi' instance, internal to GHC.
-newtype Q a = Q { unQ :: forall m. Quasi m => m a }
-
--- | \"Runs\" the 'Q' monad. Normal users of Template Haskell
--- should not need this function, as the splice brackets @$( ... )@
--- are the usual way of running a 'Q' computation.
---
--- This function is primarily used in GHC internals, and for debugging
--- splices by running them in 'IO'.
---
--- Note that many functions in 'Q', such as 'reify' and other compiler
--- queries, are not supported when running 'Q' in 'IO'; these operations
--- simply fail at runtime. Indeed, the only operations guaranteed to succeed
--- are 'newName', 'runIO', 'reportError' and 'reportWarning'.
-runQ :: Quasi m => Q a -> m a
-runQ (Q m) = m
-
-instance Monad Q where
- Q m >>= k = Q (m >>= \x -> unQ (k x))
- (>>) = (*>)
-
-instance MonadFail Q where
- fail s = report True s >> Q (fail "Q monad failure")
-
-instance Functor Q where
- fmap f (Q x) = Q (fmap f x)
-
-instance Applicative Q where
- pure x = Q (pure x)
- Q f <*> Q x = Q (f <*> x)
- Q m *> Q n = Q (m *> n)
-
--- | @since 2.17.0.0
-instance Semigroup a => Semigroup (Q a) where
- (<>) = liftA2 (<>)
-
--- | @since 2.17.0.0
-instance Monoid a => Monoid (Q a) where
- mempty = pure mempty
-
--- | If the function passed to 'mfix' inspects its argument,
--- the resulting action will throw a 'FixIOException'.
---
--- @since 2.17.0.0
-instance MonadFix Q where
- -- We use the same blackholing approach as in fixIO.
- -- See Note [Blackholing in fixIO] in System.IO in base.
- mfix k = do
- m <- runIO newEmptyMVar
- ans <- runIO (unsafeDupableInterleaveIO
- (readMVar m `catch` \BlockedIndefinitelyOnMVar ->
- throwIO FixIOException))
- result <- k ans
- runIO (putMVar m result)
- return result
-
-
------------------------------------------------------
---
--- The Quote class
---
------------------------------------------------------
-
-
-
--- | The 'Quote' class implements the minimal interface which is necessary for
--- desugaring quotations.
---
--- * The @Monad m@ superclass is needed to stitch together the different
--- AST fragments.
--- * 'newName' is used when desugaring binding structures such as lambdas
--- to generate fresh names.
---
--- Therefore the type of an untyped quotation in GHC is `Quote m => m Exp`
---
--- For many years the type of a quotation was fixed to be `Q Exp` but by
--- more precisely specifying the minimal interface it enables the `Exp` to
--- be extracted purely from the quotation without interacting with `Q`.
-class Monad m => Quote m where
- {- |
- Generate a fresh name, which cannot be captured.
-
- For example, this:
-
- @f = $(do
- nm1 <- newName \"x\"
- let nm2 = 'mkName' \"x\"
- return ('LamE' ['VarP' nm1] (LamE [VarP nm2] ('VarE' nm1)))
- )@
-
- will produce the splice
-
- >f = \x0 -> \x -> x0
-
- In particular, the occurrence @VarE nm1@ refers to the binding @VarP nm1@,
- and is not captured by the binding @VarP nm2@.
-
- Although names generated by @newName@ cannot /be captured/, they can
- /capture/ other names. For example, this:
-
- >g = $(do
- > nm1 <- newName "x"
- > let nm2 = mkName "x"
- > return (LamE [VarP nm2] (LamE [VarP nm1] (VarE nm2)))
- > )
-
- will produce the splice
-
- >g = \x -> \x0 -> x0
-
- since the occurrence @VarE nm2@ is captured by the innermost binding
- of @x@, namely @VarP nm1@.
- -}
- newName :: String -> m Name
-
-instance Quote Q where
- newName s = Q (qNewName s)
-
------------------------------------------------------
---
--- The TExp type
---
------------------------------------------------------
-
-type TExp :: TYPE r -> Kind.Type
-type role TExp nominal -- See Note [Role of TExp]
-newtype TExp a = TExp
- { unType :: Exp -- ^ Underlying untyped Template Haskell expression
- }
--- ^ Typed wrapper around an 'Exp'.
---
--- This is the typed representation of terms produced by typed quotes.
---
--- Representation-polymorphic since /template-haskell-2.16.0.0/.
-
--- | Discard the type annotation and produce a plain Template Haskell
--- expression
---
--- Representation-polymorphic since /template-haskell-2.16.0.0/.
-unTypeQ :: forall (r :: RuntimeRep) (a :: TYPE r) m . Quote m => m (TExp a) -> m Exp
-unTypeQ m = do { TExp e <- m
- ; return e }
-
--- | Annotate the Template Haskell expression with a type
---
--- This is unsafe because GHC cannot check for you that the expression
--- really does have the type you claim it has.
---
--- Representation-polymorphic since /template-haskell-2.16.0.0/.
-unsafeTExpCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m .
- Quote m => m Exp -> m (TExp a)
-unsafeTExpCoerce m = do { e <- m
- ; return (TExp e) }
-
-{- Note [Role of TExp]
-~~~~~~~~~~~~~~~~~~~~~~
-TExp's argument must have a nominal role, not phantom as would
-be inferred (#8459). Consider
-
- e :: Code Q Age
- e = [|| MkAge 3 ||]
-
- foo = $(coerce e) + 4::Int
-
-The splice will evaluate to (MkAge 3) and you can't add that to
-4::Int. So you can't coerce a (Code Q Age) to a (Code Q Int). -}
-
--- Code constructor
-#if __GLASGOW_HASKELL__ >= 909
-type Code :: (Kind.Type -> Kind.Type) -> forall r. TYPE r -> Kind.Type
- -- See Note [Foralls to the right in Code]
-#else
-type Code :: (Kind.Type -> Kind.Type) -> TYPE r -> Kind.Type
-#endif
-type role Code representational nominal -- See Note [Role of TExp]
-newtype Code m a = Code
- { examineCode :: m (TExp a) -- ^ Underlying monadic value
- }
--- ^ Represents an expression which has type @a@, built in monadic context @m@. Built on top of 'TExp', typed
--- expressions allow for type-safe splicing via:
---
--- - typed quotes, written as @[|| ... ||]@ where @...@ is an expression; if
--- that expression has type @a@, then the quotation has type
--- @Quote m => Code m a@
---
--- - typed splices inside of typed quotes, written as @$$(...)@ where @...@
--- is an arbitrary expression of type @Quote m => Code m a@
---
--- Traditional expression quotes and splices let us construct ill-typed
--- expressions:
---
--- >>> fmap ppr $ runQ (unTypeCode [| True == $( [| "foo" |] ) |])
--- GHC.Internal.Types.True GHC.Internal.Classes.== "foo"
--- >>> GHC.Internal.Types.True GHC.Internal.Classes.== "foo"
--- <interactive> error:
--- • Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
--- • In the second argument of ‘(==)’, namely ‘"foo"’
--- In the expression: True == "foo"
--- In an equation for ‘it’: it = True == "foo"
---
--- With typed expressions, the type error occurs when /constructing/ the
--- Template Haskell expression:
---
--- >>> fmap ppr $ runQ (unTypeCode [|| True == $$( [|| "foo" ||] ) ||])
--- <interactive> error:
--- • Couldn't match type ‘[Char]’ with ‘Bool’
--- Expected type: Code Q Bool
--- Actual type: Code Q [Char]
--- • In the Template Haskell quotation [|| "foo" ||]
--- In the expression: [|| "foo" ||]
--- In the Template Haskell splice $$([|| "foo" ||])
-
-
-{- Note [Foralls to the right in Code]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Code has the following type signature:
- type Code :: (Kind.Type -> Kind.Type) -> forall r. TYPE r -> Kind.Type
-
-This allows us to write
- data T (f :: forall r . (TYPE r) -> Type) = MkT (f Int) (f Int#)
-
- tcodeq :: T (Code Q)
- tcodeq = MkT [||5||] [||5#||]
-
-If we used the slightly more straightforward signature
- type Code :: foral r. (Kind.Type -> Kind.Type) -> TYPE r -> Kind.Type
-
-then the example above would become ill-typed. (See #23592 for some discussion.)
--}
-
--- | Unsafely convert an untyped code representation into a typed code
--- representation.
-unsafeCodeCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m .
- Quote m => m Exp -> Code m a
-unsafeCodeCoerce m = Code (unsafeTExpCoerce m)
-
--- | Lift a monadic action producing code into the typed 'Code'
--- representation
-liftCode :: forall (r :: RuntimeRep) (a :: TYPE r) m . m (TExp a) -> Code m a
-liftCode = Code
-
--- | Extract the untyped representation from the typed representation
-unTypeCode :: forall (r :: RuntimeRep) (a :: TYPE r) m . Quote m
- => Code m a -> m Exp
-unTypeCode = unTypeQ . examineCode
-
--- | Modify the ambient monad used during code generation. For example, you
--- can use `hoistCode` to handle a state effect:
--- @
--- handleState :: Code (StateT Int Q) a -> Code Q a
--- handleState = hoistCode (flip runState 0)
--- @
-hoistCode :: forall m n (r :: RuntimeRep) (a :: TYPE r) . Monad m
- => (forall x . m x -> n x) -> Code m a -> Code n a
-hoistCode f (Code a) = Code (f a)
-
-
--- | Variant of '(>>=)' which allows effectful computations to be injected
--- into code generation.
-bindCode :: forall m a (r :: RuntimeRep) (b :: TYPE r) . Monad m
- => m a -> (a -> Code m b) -> Code m b
-bindCode q k = liftCode (q >>= examineCode . k)
-
--- | Variant of '(>>)' which allows effectful computations to be injected
--- into code generation.
-bindCode_ :: forall m a (r :: RuntimeRep) (b :: TYPE r) . Monad m
- => m a -> Code m b -> Code m b
-bindCode_ q c = liftCode ( q >> examineCode c)
-
--- | A useful combinator for embedding monadic actions into 'Code'
--- @
--- myCode :: ... => Code m a
--- myCode = joinCode $ do
--- x <- someSideEffect
--- return (makeCodeWith x)
--- @
-joinCode :: forall m (r :: RuntimeRep) (a :: TYPE r) . Monad m
- => m (Code m a) -> Code m a
-joinCode = flip bindCode id
-
-----------------------------------------------------
--- Packaged versions for the programmer, hiding the Quasi-ness
-
-
--- | Report an error (True) or warning (False),
--- but carry on; use 'fail' to stop.
-report :: Bool -> String -> Q ()
-report b s = Q (qReport b s)
-{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6
-
--- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'.
-reportError :: String -> Q ()
-reportError = report True
-
--- | Report a warning to the user, and carry on.
-reportWarning :: String -> Q ()
-reportWarning = report False
-
--- | Recover from errors raised by 'reportError' or 'fail'.
-recover :: Q a -- ^ handler to invoke on failure
- -> Q a -- ^ computation to run
- -> Q a
-recover (Q r) (Q m) = Q (qRecover r m)
-
--- We don't export lookupName; the Bool isn't a great API
--- Instead we export lookupTypeName, lookupValueName
-lookupName :: Bool -> String -> Q (Maybe Name)
-lookupName ns s = Q (qLookupName ns s)
-
--- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
-lookupTypeName :: String -> Q (Maybe Name)
-lookupTypeName s = Q (qLookupName True s)
-
--- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
-lookupValueName :: String -> Q (Maybe Name)
-lookupValueName s = Q (qLookupName False s)
-
-{-
-Note [Name lookup]
-~~~~~~~~~~~~~~~~~~
--}
-{- $namelookup #namelookup#
-The functions 'lookupTypeName' and 'lookupValueName' provide
-a way to query the current splice's context for what names
-are in scope. The function 'lookupTypeName' queries the type
-namespace, whereas 'lookupValueName' queries the value namespace,
-but the functions are otherwise identical.
-
-A call @lookupValueName s@ will check if there is a value
-with name @s@ in scope at the current splice's location. If
-there is, the @Name@ of this value is returned;
-if not, then @Nothing@ is returned.
-
-The returned name cannot be \"captured\".
-For example:
-
-> f = "global"
-> g = $( do
-> Just nm <- lookupValueName "f"
-> [| let f = "local" in $( varE nm ) |]
-
-In this case, @g = \"global\"@; the call to @lookupValueName@
-returned the global @f@, and this name was /not/ captured by
-the local definition of @f@.
-
-The lookup is performed in the context of the /top-level/ splice
-being run. For example:
-
-> f = "global"
-> g = $( [| let f = "local" in
-> $(do
-> Just nm <- lookupValueName "f"
-> varE nm
-> ) |] )
-
-Again in this example, @g = \"global\"@, because the call to
-@lookupValueName@ queries the context of the outer-most @$(...)@.
-
-Operators should be queried without any surrounding parentheses, like so:
-
-> lookupValueName "+"
-
-Qualified names are also supported, like so:
-
-> lookupValueName "Prelude.+"
-> lookupValueName "Prelude.map"
-
--}
-
-
-{- | 'reify' looks up information about the 'Name'. It will fail with
-a compile error if the 'Name' is not visible. A 'Name' is visible if it is
-imported or defined in a prior top-level declaration group. See the
-documentation for 'newDeclarationGroup' for more details.
-
-It is sometimes useful to construct the argument name using 'lookupTypeName' or 'lookupValueName'
-to ensure that we are reifying from the right namespace. For instance, in this context:
-
-> data D = D
-
-which @D@ does @reify (mkName \"D\")@ return information about? (Answer: @D@-the-type, but don't rely on it.)
-To ensure we get information about @D@-the-value, use 'lookupValueName':
-
-> do
-> Just nm <- lookupValueName "D"
-> reify nm
-
-and to get information about @D@-the-type, use 'lookupTypeName'.
--}
-reify :: Name -> Q Info
-reify v = Q (qReify v)
-
-{- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For
-example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then
-@reifyFixity 'foo@ would return @'Just' ('Fixity' 7 'InfixR')@. If the function
-@bar@ does not have a fixity declaration, then @reifyFixity 'bar@ returns
-'Nothing', so you may assume @bar@ has 'defaultFixity'.
--}
-reifyFixity :: Name -> Q (Maybe Fixity)
-reifyFixity nm = Q (qReifyFixity nm)
-
-{- | @reifyType nm@ attempts to find the type or kind of @nm@. For example,
-@reifyType 'not@ returns @Bool -> Bool@, and
-@reifyType ''Bool@ returns @Type@.
-This works even if there's no explicit signature and the type or kind is inferred.
--}
-reifyType :: Name -> Q Type
-reifyType nm = Q (qReifyType nm)
-
-{- | Template Haskell is capable of reifying information about types and
-terms defined in previous declaration groups. Top-level declaration splices break up
-declaration groups.
-
-For an example, consider this code block. We define a datatype @X@ and
-then try to call 'reify' on the datatype.
-
-@
-module Check where
-
-data X = X
- deriving Eq
-
-$(do
- info <- reify ''X
- runIO $ print info
- )
-@
-
-This code fails to compile, noting that @X@ is not available for reification at the site of 'reify'. We can fix this by creating a new declaration group using an empty top-level splice:
-
-@
-data X = X
- deriving Eq
-
-$(pure [])
-
-$(do
- info <- reify ''X
- runIO $ print info
- )
-@
-
-We provide 'newDeclarationGroup' as a means of documenting this behavior
-and providing a name for the pattern.
-
-Since top level splices infer the presence of the @$( ... )@ brackets, we can also write:
-
-@
-data X = X
- deriving Eq
-
-newDeclarationGroup
-
-$(do
- info <- reify ''X
- runIO $ print info
- )
-@
-
--}
-newDeclarationGroup :: Q [Dec]
-newDeclarationGroup = pure []
-
-{- | @reifyInstances nm tys@ returns a list of all visible instances (see below for "visible")
-of @nm tys@. That is,
-if @nm@ is the name of a type class, then all instances of this class at the types @tys@
-are returned. Alternatively, if @nm@ is the name of a data family or type family,
-all instances of this family at the types @tys@ are returned.
-
-Note that this is a \"shallow\" test; the declarations returned merely have
-instance heads which unify with @nm tys@, they need not actually be satisfiable.
-
- - @reifyInstances ''Eq [ 'TupleT' 2 \``AppT`\` 'ConT' ''A \``AppT`\` 'ConT' ''B ]@ contains
- the @instance (Eq a, Eq b) => Eq (a, b)@ regardless of whether @A@ and
- @B@ themselves implement 'Eq'
-
- - @reifyInstances ''Show [ 'VarT' ('mkName' "a") ]@ produces every available
- instance of 'Show'
-
-There is one edge case: @reifyInstances ''Typeable tys@ currently always
-produces an empty list (no matter what @tys@ are given).
-
-In principle, the *visible* instances are
-* all instances defined in a prior top-level declaration group
- (see docs on @newDeclarationGroup@), or
-* all instances defined in any module transitively imported by the
- module being compiled
-
-However, actually searching all modules transitively below the one being
-compiled is unreasonably expensive, so @reifyInstances@ will report only the
-instance for modules that GHC has had some cause to visit during this
-compilation. This is a shortcoming: @reifyInstances@ might fail to report
-instances for a type that is otherwise unusued, or instances defined in a
-different component. You can work around this shortcoming by explicitly importing the modules
-whose instances you want to be visible. GHC issue <https://gitlab.haskell.org/ghc/ghc/-/issues/20529#note_388980 #20529>
-has some discussion around this.
-
--}
-reifyInstances :: Name -> [Type] -> Q [InstanceDec]
-reifyInstances cls tys = Q (qReifyInstances cls tys)
-
-{- | @reifyRoles nm@ returns the list of roles associated with the parameters
-(both visible and invisible) of
-the tycon @nm@. Fails if @nm@ cannot be found or is not a tycon.
-The returned list should never contain 'InferR'.
-
-An invisible parameter to a tycon is often a kind parameter. For example, if
-we have
-
-@
-type Proxy :: forall k. k -> Type
-data Proxy a = MkProxy
-@
-
-and @reifyRoles Proxy@, we will get @['NominalR', 'PhantomR']@. The 'NominalR' is
-the role of the invisible @k@ parameter. Kind parameters are always nominal.
--}
-reifyRoles :: Name -> Q [Role]
-reifyRoles nm = Q (qReifyRoles nm)
-
--- | @reifyAnnotations target@ returns the list of annotations
--- associated with @target@. Only the annotations that are
--- appropriately typed is returned. So if you have @Int@ and @String@
--- annotations for the same target, you have to call this function twice.
-reifyAnnotations :: Data a => AnnLookup -> Q [a]
-reifyAnnotations an = Q (qReifyAnnotations an)
-
--- | @reifyModule mod@ looks up information about module @mod@. To
--- look up the current module, call this function with the return
--- value of 'Language.Haskell.TH.Lib.thisModule'.
-reifyModule :: Module -> Q ModuleInfo
-reifyModule m = Q (qReifyModule m)
-
--- | @reifyConStrictness nm@ looks up the strictness information for the fields
--- of the constructor with the name @nm@. Note that the strictness information
--- that 'reifyConStrictness' returns may not correspond to what is written in
--- the source code. For example, in the following data declaration:
---
--- @
--- data Pair a = Pair a a
--- @
---
--- 'reifyConStrictness' would return @['DecidedLazy', DecidedLazy]@ under most
--- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the
--- @-XStrictData@ language extension was enabled.
-reifyConStrictness :: Name -> Q [DecidedStrictness]
-reifyConStrictness n = Q (qReifyConStrictness n)
-
--- | Is the list of instances returned by 'reifyInstances' nonempty?
---
--- If you're confused by an instance not being visible despite being
--- defined in the same module and above the splice in question, see the
--- docs for 'newDeclarationGroup' for a possible explanation.
-isInstance :: Name -> [Type] -> Q Bool
-isInstance nm tys = do { decs <- reifyInstances nm tys
- ; return (not (null decs)) }
-
--- | The location at which this computation is spliced.
-location :: Q Loc
-location = Q qLocation
-
--- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad.
--- Take care: you are guaranteed the ordering of calls to 'runIO' within
--- a single 'Q' computation, but not about the order in which splices are run.
---
--- Note: for various murky reasons, stdout and stderr handles are not
--- necessarily flushed when the compiler finishes running, so you should
--- flush them yourself.
-runIO :: IO a -> Q a
-runIO m = Q (qRunIO m)
-
--- | Get the package root for the current package which is being compiled.
--- This can be set explicitly with the -package-root flag but is normally
--- just the current working directory.
---
--- The motivation for this flag is to provide a principled means to remove the
--- assumption from splices that they will be executed in the directory where the
--- cabal file resides. Projects such as haskell-language-server can't and don't
--- change directory when compiling files but instead set the -package-root flag
--- appropriately.
-getPackageRoot :: Q FilePath
-getPackageRoot = Q qGetPackageRoot
-
-
-
--- | Record external files that runIO is using (dependent upon).
--- The compiler can then recognize that it should re-compile the Haskell file
--- when an external file changes.
---
--- Expects an absolute file path.
---
--- Notes:
---
--- * ghc -M does not know about these dependencies - it does not execute TH.
---
--- * The dependency is based on file content, not a modification time
-addDependentFile :: FilePath -> Q ()
-addDependentFile fp = Q (qAddDependentFile fp)
-
--- | Obtain a temporary file path with the given suffix. The compiler will
--- delete this file after compilation.
-addTempFile :: String -> Q FilePath
-addTempFile suffix = Q (qAddTempFile suffix)
-
--- | Add additional top-level declarations. The added declarations will be type
--- checked along with the current declaration group.
-addTopDecls :: [Dec] -> Q ()
-addTopDecls ds = Q (qAddTopDecls ds)
-
-
--- | Emit a foreign file which will be compiled and linked to the object for
--- the current module. Currently only languages that can be compiled with
--- the C compiler are supported, and the flags passed as part of -optc will
--- be also applied to the C compiler invocation that will compile them.
---
--- Note that for non-C languages (for example C++) @extern "C"@ directives
--- must be used to get symbols that we can access from Haskell.
---
--- To get better errors, it is recommended to use #line pragmas when
--- emitting C files, e.g.
---
--- > {-# LANGUAGE CPP #-}
--- > ...
--- > addForeignSource LangC $ unlines
--- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__
--- > , ...
--- > ]
-addForeignSource :: ForeignSrcLang -> String -> Q ()
-addForeignSource lang src = do
- let suffix = case lang of
- LangC -> "c"
- LangCxx -> "cpp"
- LangObjc -> "m"
- LangObjcxx -> "mm"
- LangAsm -> "s"
- LangJs -> "js"
- RawObject -> "a"
- path <- addTempFile suffix
- runIO $ writeFile path src
- addForeignFilePath lang path
-
--- | Same as 'addForeignSource', but expects to receive a path pointing to the
--- foreign file instead of a 'String' of its contents. Consider using this in
--- conjunction with 'addTempFile'.
---
--- This is a good alternative to 'addForeignSource' when you are trying to
--- directly link in an object file.
-addForeignFilePath :: ForeignSrcLang -> FilePath -> Q ()
-addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp)
-
--- | Add a finalizer that will run in the Q monad after the current module has
--- been type checked. This only makes sense when run within a top-level splice.
---
--- The finalizer is given the local type environment at the splice point. Thus
--- 'reify' is able to find the local definitions when executed inside the
--- finalizer.
-addModFinalizer :: Q () -> Q ()
-addModFinalizer act = Q (qAddModFinalizer (unQ act))
-
--- | Adds a core plugin to the compilation pipeline.
---
--- @addCorePlugin m@ has almost the same effect as passing @-fplugin=m@ to ghc
--- in the command line. The major difference is that the plugin module @m@
--- must not belong to the current package. When TH executes, it is too late
--- to tell the compiler that we needed to compile first a plugin module in the
--- current package.
-addCorePlugin :: String -> Q ()
-addCorePlugin plugin = Q (qAddCorePlugin plugin)
-
--- | Get state from the 'Q' monad. Note that the state is local to the
--- Haskell module in which the Template Haskell expression is executed.
-getQ :: Typeable a => Q (Maybe a)
-getQ = Q qGetQ
-
--- | Replace the state in the 'Q' monad. Note that the state is local to the
--- Haskell module in which the Template Haskell expression is executed.
-putQ :: Typeable a => a -> Q ()
-putQ x = Q (qPutQ x)
-
--- | Determine whether the given language extension is enabled in the 'Q' monad.
-isExtEnabled :: Extension -> Q Bool
-isExtEnabled ext = Q (qIsExtEnabled ext)
-
--- | List all enabled language extensions.
-extsEnabled :: Q [Extension]
-extsEnabled = Q qExtsEnabled
-
--- | Add Haddock documentation to the specified location. This will overwrite
--- any documentation at the location if it already exists. This will reify the
--- specified name, so it must be in scope when you call it. If you want to add
--- documentation to something that you are currently splicing, you can use
--- 'addModFinalizer' e.g.
---
--- > do
--- > let nm = mkName "x"
--- > addModFinalizer $ putDoc (DeclDoc nm) "Hello"
--- > [d| $(varP nm) = 42 |]
---
--- The helper functions 'withDecDoc' and 'withDecsDoc' will do this for you, as
--- will the 'funD_doc' and other @_doc@ combinators.
--- You most likely want to have the @-haddock@ flag turned on when using this.
--- Adding documentation to anything outside of the current module will cause an
--- error.
-putDoc :: DocLoc -> String -> Q ()
-putDoc t s = Q (qPutDoc t s)
-
--- | Retrieves the Haddock documentation at the specified location, if one
--- exists.
--- It can be used to read documentation on things defined outside of the current
--- module, provided that those modules were compiled with the @-haddock@ flag.
-getDoc :: DocLoc -> Q (Maybe String)
-getDoc n = Q (qGetDoc n)
-
-instance MonadIO Q where
- liftIO = runIO
-
-instance Quasi Q where
- qNewName = newName
- qReport = report
- qRecover = recover
- qReify = reify
- qReifyFixity = reifyFixity
- qReifyType = reifyType
- qReifyInstances = reifyInstances
- qReifyRoles = reifyRoles
- qReifyAnnotations = reifyAnnotations
- qReifyModule = reifyModule
- qReifyConStrictness = reifyConStrictness
- qLookupName = lookupName
- qLocation = location
- qGetPackageRoot = getPackageRoot
- qAddDependentFile = addDependentFile
- qAddTempFile = addTempFile
- qAddTopDecls = addTopDecls
- qAddForeignFilePath = addForeignFilePath
- qAddModFinalizer = addModFinalizer
- qAddCorePlugin = addCorePlugin
- qGetQ = getQ
- qPutQ = putQ
- qIsExtEnabled = isExtEnabled
- qExtsEnabled = extsEnabled
- qPutDoc = putDoc
- qGetDoc = getDoc
-
-
-----------------------------------------------------
--- The following operations are used solely in GHC.HsToCore.Quote when
--- desugaring brackets. They are not necessary for the user, who can use
--- ordinary return and (>>=) etc
-
--- | This function is only used in 'GHC.HsToCore.Quote' when desugaring
--- brackets. This is not necessary for the user, who can use the ordinary
--- 'return' and '(>>=)' operations.
-sequenceQ :: forall m . Monad m => forall a . [m a] -> m [a]
-sequenceQ = sequence
-
oneName, manyName :: Name
-- | Synonym for @''GHC.Internal.Types.One'@, from @ghc-internal@.
oneName = mkNameG DataName "ghc-internal" "GHC.Internal.Types" "One"
@@ -1004,19 +72,19 @@ manyName = mkNameG DataName "ghc-internal" "GHC.Internal.Types" "Many"
-- | The name of a module.
newtype ModName = ModName String -- Module name
- deriving (Show,Eq,Ord,Data,Generic)
+ deriving (Show,Eq,Ord,Generic)
-- | The name of a package.
newtype PkgName = PkgName String -- package name
- deriving (Show,Eq,Ord,Data,Generic)
+ deriving (Show,Eq,Ord,Generic)
-- | Obtained from 'reifyModule' and 'Language.Haskell.TH.Lib.thisModule'.
data Module = Module PkgName ModName -- package qualified module name
- deriving (Show,Eq,Ord,Data,Generic)
+ deriving (Show,Eq,Ord,Generic)
-- | An "Occurence Name".
newtype OccName = OccName String
- deriving (Show,Eq,Ord,Data,Generic)
+ deriving (Show,Eq,Ord,Generic)
-- | Smart constructor for 'ModName'
mkModName :: String -> ModName
@@ -1132,7 +200,7 @@ Names constructed using @newName@ and @mkName@ may be used in bindings
(such as @let x = ...@ or @\x -> ...@), but names constructed using
@lookupValueName@, @lookupTypeName@, @'f@, @''T@ may not.
-}
-data Name = Name OccName NameFlavour deriving (Data, Eq, Generic)
+data Name = Name OccName NameFlavour deriving (Eq, Generic)
instance Ord Name where
-- check if unique is different before looking at strings
@@ -1148,7 +216,7 @@ data NameFlavour
-- An original name (occurrences only, not binders)
-- Need the namespace too to be sure which
-- thing we are naming
- deriving ( Data, Eq, Ord, Show, Generic )
+ deriving ( Eq, Ord, Show, Generic )
data NameSpace = VarName -- ^ Variables
| DataName -- ^ Data constructors
@@ -1162,7 +230,7 @@ data NameSpace = VarName -- ^ Variables
-- of the datatype (regardless of whether this constructor has this field).
-- - For a field of a pattern synonym, this is the name of the pattern synonym.
}
- deriving( Eq, Ord, Show, Data, Generic )
+ deriving( Eq, Ord, Show, Generic )
-- | @Uniq@ is used by GHC to distinguish names from each other.
type Uniq = Integer
@@ -1464,7 +532,7 @@ data Loc
, loc_module :: String
, loc_start :: CharPos
, loc_end :: CharPos }
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
type CharPos = (Int, Int) -- ^ Line and character position
@@ -1547,13 +615,13 @@ data Info
| TyVarI -- Scoped type variable
Name
Type -- What it is bound to
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | Obtained from 'reifyModule' in the 'Q' Monad.
data ModuleInfo =
-- | Contains the import list of the module.
ModuleInfo [Module]
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
{- |
In 'ClassOpI' and 'DataConI', name of the parent class or type
@@ -1591,11 +659,11 @@ type InstanceDec = Dec
-- | Fixity, as specified in a @infix[lr] n@ declaration.
data Fixity = Fixity Int FixityDirection
- deriving( Eq, Ord, Show, Data, Generic )
+ deriving( Eq, Ord, Show, Generic )
-- | The associativity of an operator, as in an @infix@ declaration.
data FixityDirection = InfixL | InfixR | InfixN
- deriving( Eq, Ord, Show, Data, Generic )
+ deriving( Eq, Ord, Show, Generic )
-- | Highest allowed operator precedence for 'Fixity' constructor (answer: 9)
maxPrecedence :: Int
@@ -1628,7 +696,7 @@ data Lit = CharL Char -- ^ @\'c\'@
| StringPrimL [Word8] -- ^ @"string"#@. A primitive C-style string, type 'Addr#'
| BytesPrimL Bytes -- ^ Some raw bytes, type 'Addr#':
| CharPrimL Char -- ^ @\'c\'#@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- We could add Int, Float, Double etc, as we do in HsLit,
-- but that could complicate the
@@ -1650,7 +718,7 @@ data Bytes = Bytes
-- , bytesInitialized :: Bool -- ^ False: only use `bytesSize` to allocate
-- -- an uninitialized region
}
- deriving (Data,Generic)
+ deriving (Generic)
-- We can't derive Show instance for Bytes because we don't want to show the
-- pointer value but the actual bytes (similarly to what ByteString does). See
@@ -1717,14 +785,14 @@ data Pat
| TypeP Type -- ^ @{ type p }@
| InvisP Type -- ^ @{ @p }@
| OrP (NonEmpty Pat) -- ^ @{ p1; p2 }@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A (field name, pattern) pair. See 'RecP'.
type FieldPat = (Name,Pat)
-- | A @case@-alternative
data Match = Match Pat Body [Dec] -- ^ @case e of { pat -> body where decs }@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A clause consists of patterns, guards, a body expression, and a list of
-- declarations under a @where@. Clauses are seen in equations for function
@@ -1732,7 +800,7 @@ data Match = Match Pat Body [Dec] -- ^ @case e of { pat -> body where decs }@
-- etc.
data Clause = Clause [Pat] Body [Dec]
-- ^ @f { p1 p2 = body where decs }@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A Haskell expression.
data Exp
@@ -1827,7 +895,7 @@ data Exp
| ForallE [TyVarBndr Specificity] Exp -- ^ @forall \<vars\>. \<expr\>@
| ForallVisE [TyVarBndr ()] Exp -- ^ @forall \<vars\> -> \<expr\>@
| ConstrainedE [Exp] Exp -- ^ @\<ctxt\> => \<expr\>@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A (field name, expression) pair. See 'RecConE' and 'RecUpdE'.
type FieldExp = (Name,Exp)
@@ -1841,13 +909,13 @@ data Body
-- | e3 = e4 }
-- where ds@
| NormalB Exp -- ^ @f p { = e } where ds@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A single guard.
data Guard
= NormalG Exp -- ^ @f x { | odd x } = x@
| PatG [Stmt] -- ^ @f x { | Just y <- x, Just z <- y } = z@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A single statement, as in @do@-notation.
data Stmt
@@ -1856,14 +924,14 @@ data Stmt
| NoBindS Exp -- ^ @e@
| ParS [[Stmt]] -- ^ @x <- e1 | s2, s3 | s4@ (in 'CompE')
| RecS [Stmt] -- ^ @rec { s1; s2 }@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A list/enum range expression.
data Range = FromR Exp -- ^ @[n ..]@
| FromThenR Exp Exp -- ^ @[n, m ..]@
| FromToR Exp Exp -- ^ @[n .. m]@
| FromThenToR Exp Exp Exp -- ^ @[n, m .. k]@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A single declaration.
data Dec
@@ -1950,7 +1018,7 @@ data Dec
--
-- Implicit parameter binding declaration. Can only be used in let
-- and where clauses which consist entirely of implicit bindings.
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A way to specify a namespace to look in when GHC needs to find
-- a name's source
@@ -1962,7 +1030,7 @@ data NamespaceSpecifier
-- or type variable
| DataNamespaceSpecifier -- ^ Name should be a term-level entity, such as a
-- function, data constructor, or pattern synonym
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | Varieties of allowed instance overlap.
data Overlap = Overlappable -- ^ May be overlapped by more specific instances
@@ -1971,12 +1039,12 @@ data Overlap = Overlappable -- ^ May be overlapped by more specific instances
| Incoherent -- ^ Both 'Overlapping' and 'Overlappable', and
-- pick an arbitrary one if multiple choices are
-- available.
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A single @deriving@ clause at the end of a datatype declaration.
data DerivClause = DerivClause (Maybe DerivStrategy) Cxt
-- ^ @{ deriving stock (Eq, Ord) }@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | What the user explicitly requests when deriving an instance with
-- @-XDerivingStrategies@.
@@ -1984,7 +1052,7 @@ data DerivStrategy = StockStrategy -- ^ @deriving {stock} C@
| AnyclassStrategy -- ^ @deriving {anyclass} C@, @-XDeriveAnyClass@
| NewtypeStrategy -- ^ @deriving {newtype} C@, @-XGeneralizedNewtypeDeriving@
| ViaStrategy Type -- ^ @deriving C {via T}@, @-XDerivingVia@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A pattern synonym's type. Note that a pattern synonym's /fully/
-- specified type has a peculiar shape coming with two forall
@@ -2040,7 +1108,7 @@ type PatSynType = Type
-- between @type family@ and @where@.
data TypeFamilyHead =
TypeFamilyHead Name [TyVarBndr BndrVis] FamilyResultSig (Maybe InjectivityAnn)
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | One equation of a type family instance or closed type family. The
-- arguments are the left-hand-side type and the right-hand-side result.
@@ -2060,28 +1128,28 @@ data TypeFamilyHead =
-- ('VarT' a)
-- @
data TySynEqn = TySynEqn (Maybe [TyVarBndr ()]) Type Type
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | [Functional dependency](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/functio…
-- syntax, as in a class declaration.
data FunDep = FunDep [Name] [Name] -- ^ @class C a b {| a -> b}@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A @foreign@ declaration.
data Foreign = ImportF Callconv Safety String Name Type
-- ^ @foreign import callconv safety "foreign_name" haskellName :: type@
| ExportF Callconv String Name Type
-- ^ @foreign export callconv "foreign_name" haskellName :: type@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- keep Callconv in sync with module ForeignCall in ghc/compiler/GHC/Types/ForeignCall.hs
-- | A calling convention identifier, as in a 'Foreign' declaration.
data Callconv = CCall | StdCall | CApi | Prim | JavaScript
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A safety level, as in a 'Foreign' declaration.
data Safety = Unsafe | Safe | Interruptible
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
data Pragma = InlineP Name Inline RuleMatch Phases
-- ^ @{ {\-\# [inline] [rule match] [phases] [phases] name #-} }@. See
@@ -2106,7 +1174,7 @@ data Pragma = InlineP Name Inline RuleMatch Phases
-- ^ @{ {\-\# COMPLETE C_1, ..., C_i [ :: T ] \#-} }@
| SCCP Name (Maybe String)
-- ^ @{ {\-\# SCC fun "optional_name" \#-} }@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | An inline pragma.
data Inline = NoInline
@@ -2115,7 +1183,7 @@ data Inline = NoInline
-- ^ @{ {\-\# INLINE ... #-} }@
| Inlinable
-- ^ @{ {\-\# INLINABLE ... #-} }@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | A @CONLIKE@ modifier, as in one of the various inline pragmas, or lack
-- thereof ('FunLike').
@@ -2123,7 +1191,7 @@ data RuleMatch = ConLike
-- ^ @{ {\-\# CONLIKE [inline] ... #-} }@
| FunLike
-- ^ @{ {\-\# [inline] ... #-} }@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | Phase control syntax.
data Phases = AllPhases
@@ -2132,14 +1200,14 @@ data Phases = AllPhases
-- ^ @[n]@
| BeforePhase Int
-- ^ @[~n]@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | A binder found in the @forall@ of a @RULES@ pragma.
data RuleBndr = RuleVar Name
-- ^ @forall {a} ... .@
| TypedRuleVar Name Type
-- ^ @forall {(a :: t)} ... .@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | The target of an @ANN@ pragma
data AnnTarget = ModuleAnnotation
@@ -2148,7 +1216,7 @@ data AnnTarget = ModuleAnnotation
-- ^ @{\-\# ANN type {name} ... #-}@
| ValueAnnotation Name
-- ^ @{\-\# ANN {name} ... #-}@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | A context, as found on the left side of a @=>@ in a type.
type Cxt = [Pred] -- ^ @(Eq a, Ord b)@
@@ -2166,7 +1234,7 @@ data SourceUnpackedness
= NoSourceUnpackedness -- ^ @C a@
| SourceNoUnpack -- ^ @C { {\-\# NOUNPACK \#-\} } a@
| SourceUnpack -- ^ @C { {\-\# UNPACK \#-\} } a@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | 'SourceStrictness' corresponds to strictness annotations found in the source code.
--
@@ -2175,7 +1243,7 @@ data SourceUnpackedness
data SourceStrictness = NoSourceStrictness -- ^ @C a@
| SourceLazy -- ^ @C {~}a@
| SourceStrict -- ^ @C {!}a@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | Unlike 'SourceStrictness' and 'SourceUnpackedness', 'DecidedStrictness'
-- refers to the strictness annotations that the compiler chooses for a data constructor
@@ -2188,7 +1256,7 @@ data SourceStrictness = NoSourceStrictness -- ^ @C a@
data DecidedStrictness = DecidedLazy -- ^ Field inferred to not have a bang.
| DecidedStrict -- ^ Field inferred to have a bang.
| DecidedUnpack -- ^ Field inferred to be unpacked.
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | A data constructor.
--
@@ -2253,7 +1321,7 @@ data Con =
-- Invariant: the list must be non-empty.
[VarBangType] -- ^ The constructor arguments
Type -- ^ See Note [GADT return type]
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- Note [GADT return type]
-- ~~~~~~~~~~~~~~~~~~~~~~~
@@ -2285,7 +1353,7 @@ data Con =
-- | Strictness information in a data constructor's argument.
data Bang = Bang SourceUnpackedness SourceStrictness
-- ^ @C { {\-\# UNPACK \#-\} !}a@
- deriving (Show, Eq, Ord, Data, Generic)
+ deriving (Show, Eq, Ord, Generic)
-- | A type with a strictness annotation, as in data constructors. See 'Con'.
type BangType = (Bang, Type)
@@ -2309,14 +1377,14 @@ data PatSynDir
= Unidir -- ^ @pattern P x {<-} p@
| ImplBidir -- ^ @pattern P x {=} p@
| ExplBidir [Clause] -- ^ @pattern P x {<-} p where P x = e@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A pattern synonym's argument type.
data PatSynArgs
= PrefixPatSyn [Name] -- ^ @pattern P {x y z} = p@
| InfixPatSyn Name Name -- ^ @pattern {x P y} = p@
| RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | A Haskell type.
data Type = ForallT [TyVarBndr Specificity] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> => \<type\>@
@@ -2355,12 +1423,12 @@ data Type = ForallT [TyVarBndr Specificity] Cxt Type -- ^ @forall \<vars\>. \<ct
| LitT TyLit -- ^ @0@, @1@, @2@, etc.
| WildCardT -- ^ @_@
| ImplicitParamT String Type -- ^ @?x :: t@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | The specificity of a type variable in a @forall ...@.
data Specificity = SpecifiedSpec -- ^ @a@
| InferredSpec -- ^ @{a}@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | The @flag@ type parameter is instantiated to one of the following types:
--
@@ -2370,40 +1438,40 @@ data Specificity = SpecifiedSpec -- ^ @a@
--
data TyVarBndr flag = PlainTV Name flag -- ^ @a@
| KindedTV Name flag Kind -- ^ @(a :: k)@
- deriving( Show, Eq, Ord, Data, Generic, Functor, Foldable, Traversable )
+ deriving( Show, Eq, Ord, Generic, Functor, Foldable, Traversable )
-- | Visibility of a type variable. See [Inferred vs. specified type variables](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/type_app….
data BndrVis = BndrReq -- ^ @a@
| BndrInvis -- ^ @\@a@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | Type family result signature
data FamilyResultSig = NoSig -- ^ no signature
| KindSig Kind -- ^ @k@
| TyVarSig (TyVarBndr ()) -- ^ @= r, = (r :: k)@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | Injectivity annotation as in an [injective type family](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/type_famili…
data InjectivityAnn = InjectivityAnn Name [Name]
- deriving ( Show, Eq, Ord, Data, Generic )
+ deriving ( Show, Eq, Ord, Generic )
-- | Type-level literals.
data TyLit = NumTyLit Integer -- ^ @2@
| StrTyLit String -- ^ @\"Hello\"@
| CharTyLit Char -- ^ @\'C\'@, @since 4.16.0.0
- deriving ( Show, Eq, Ord, Data, Generic )
+ deriving ( Show, Eq, Ord, Generic )
-- | Role annotations
data Role = NominalR -- ^ @nominal@
| RepresentationalR -- ^ @representational@
| PhantomR -- ^ @phantom@
| InferR -- ^ @_@
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | Annotation target for reifyAnnotations
data AnnLookup = AnnLookupModule Module
| AnnLookupName Name
- deriving( Show, Eq, Ord, Data, Generic )
+ deriving( Show, Eq, Ord, Generic )
-- | To avoid duplication between kinds and types, they
-- are defined to be the same. Naturally, you would never
@@ -2454,7 +1522,7 @@ data DocLoc
| ArgDoc Name Int -- ^ At a specific argument of a function, indexed by its
-- position.
| InstDoc Type -- ^ At a class or family instance.
- deriving ( Show, Eq, Ord, Data, Generic )
+ deriving ( Show, Eq, Ord, Generic )
-----------------------------------------------------
-- Internal helper functions
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -63,6 +63,7 @@ import Foreign
import GHC.Generics
import GHC.Stack.CCS
import qualified GHC.Boot.TH.Syntax as TH
+import qualified GHC.Boot.TH.Monad as TH
import System.Exit
import System.IO
import System.IO.Error
=====================================
libraries/ghci/GHCi/TH.hs
=====================================
@@ -114,6 +114,7 @@ import qualified Data.Map as M
import Data.Maybe
import GHC.Desugar (AnnotationWrapper(..))
import qualified GHC.Boot.TH.Syntax as TH
+import qualified GHC.Boot.TH.Monad as TH
import Unsafe.Coerce
-- | Create a new instance of 'QState'
=====================================
libraries/template-haskell/Language/Haskell/TH/Quote.hs
=====================================
@@ -22,7 +22,7 @@ module Language.Haskell.TH.Quote
, dataToQa, dataToExpQ, dataToPatQ
) where
-import GHC.Boot.TH.Syntax
+import GHC.Boot.TH.Monad
import GHC.Boot.TH.Quote
import Language.Haskell.TH.Syntax (dataToQa, dataToExpQ, dataToPatQ)
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -200,6 +200,7 @@ where
import GHC.Boot.TH.Lift
import GHC.Boot.TH.Syntax
+import GHC.Boot.TH.Monad
import System.FilePath
import Data.Data hiding (Fixity(..))
import Data.List.NonEmpty (NonEmpty(..))
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8f8b1ebfa910f6f66d656a2c14c7e3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8f8b1ebfa910f6f66d656a2c14c7e3…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Teo Camarasu pushed new branch wip/T26217 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T26217
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/9.10.3-backports] 4 commits: rts: ensure MessageBlackHole.link is always a valid closure
by Zubin (＠wz1000) 17 Aug '25
by Zubin (＠wz1000) 17 Aug '25
17 Aug '25
Zubin pushed to branch wip/9.10.3-backports at Glasgow Haskell Compiler / GHC
Commits:
dea3e5d6 by Teo Camarasu at 2025-08-17T22:31:50+05:30
rts: ensure MessageBlackHole.link is always a valid closure
We turn a MessageBlackHole into an StgInd in wakeBlockingQueue().
Therefore it's important that the link field, which becomes the
indirection field, always points to a valid closure.
It's unclear whether it's currently possible for the previous behaviour
to lead to a crash, but it's good to be consistent about this invariant nonetheless.
Co-authored-by: Andreas Klebinger <klebinger.andreas(a)gmx.at>
(cherry picked from commit a8b2fbae6bcf20bc2f3fe58803096d2a9c5fc43d)
- - - - -
97299e94 by Teo Camarasu at 2025-08-17T22:31:57+05:30
rts: spin if we see a WHITEHOLE in messageBlackHole
When a BLACKHOLE gets cancelled in raiseAsync, we indirect to a THUNK.
GC can then shortcut this, replacing our BLACKHOLE with a fresh THUNK.
This THUNK is not guaranteed to have a valid indirectee field.
If at the same time, a message intended for the previous BLACKHOLE is
processed and concurrently we BLACKHOLE the THUNK, thus temporarily
turning it into a WHITEHOLE, we can get a segfault, since we look at the
undefined indirectee field of the THUNK
The fix is simple: spin if we see a WHITEHOLE, and it will soon be
replaced with a valid BLACKHOLE.
Resolves #26205
(cherry picked from commit 4021181ee0860aca2054883a531f3312361cc701)
- - - - -
2e47cd55 by Reed Mullanix at 2025-08-17T22:33:53+05:30
ghc-internal: Fix naturalAndNot for NB/NS case
When the first argument to `naturalAndNot` is larger than a `Word` and the second is `Word`-sized, `naturalAndNot` will truncate the
result:
```
>>> naturalAndNot ((2 ^ 65) .|. (2 ^ 3)) (2 ^ 3)
0
```
In contrast, `naturalAndNot` does not truncate when both arguments are larger than a `Word`, so this appears to be a bug.
Luckily, the fix is pretty easy: we just need to call `bigNatAndNotWord#` instead of truncating.
Fixes #26230
(cherry picked from commit a766286fe759251eceb304c54ba52841c2a51f86)
- - - - -
1ea64785 by sheaf at 2025-08-17T22:36:18+05:30
RecordCon lookup: don't allow a TyCon
This commit adds extra logic when looking up a record constructor.
If GHC.Rename.Env.lookupOccRnConstr returns a TyCon (as it may, due to
the logic explained in Note [Pattern to type (P2T) conversion]),
we emit an error saying that the data constructor is not in scope.
This avoids the compiler falling over shortly thereafter, in the call to
'lookupConstructorInfo' inside 'GHC.Rename.Env.lookupRecFieldOcc',
because the record constructor would not have been a ConLike.
Fixes #25056
(cherry picked from commit da306610b9e58cfb7cf2530ebeec7ee8ad17183a)
- - - - -
23 changed files:
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Utils/Env.hs
- libraries/base/changelog.md
- libraries/ghc-bignum/changelog.md
- libraries/ghc-bignum/src/GHC/Num/Natural.hs
- rts/Messages.c
- rts/StgMiscClosures.cmm
- rts/Updates.h
- + testsuite/tests/numeric/should_run/T26230.hs
- + testsuite/tests/numeric/should_run/T26230.stdout
- testsuite/tests/numeric/should_run/all.T
- + testsuite/tests/rename/should_fail/T25056.hs
- + testsuite/tests/rename/should_fail/T25056.stderr
- + testsuite/tests/rename/should_fail/T25056a.hs
- + testsuite/tests/rename/should_fail/T25056b.hs
- testsuite/tests/rename/should_fail/all.T
- testsuite/tests/typecheck/should_fail/T23739b.hs
- testsuite/tests/typecheck/should_fail/T23739b.stderr
- + testsuite/tests/typecheck/should_fail/T23739c.hs
- + testsuite/tests/typecheck/should_fail/T23739c.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -436,6 +436,7 @@ lookupConstructorInfo con_name
; case info of
IAmConLike con_info -> return con_info
UnboundGRE -> return ConHasPositionalArgs
+ IAmTyCon {} -> failIllegalTyCon WL_Constructor con_name
_ -> pprPanic "lookupConstructorInfo: not a ConLike" $
vcat [ text "name:" <+> ppr con_name ]
}
@@ -1029,24 +1030,12 @@ lookupOccRn' which_suggest rdr_name
lookupOccRn :: RdrName -> RnM Name
lookupOccRn = lookupOccRn' WL_Anything
--- lookupOccRnConstr looks up an occurrence of a RdrName and displays
--- constructors and pattern synonyms as suggestions if it is not in scope
+-- | Look up an occurrence of a 'RdrName'.
--
--- There is a fallback to the type level, when the first lookup fails.
--- This is required to implement a pat-to-type transformation
--- (See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat)
--- Consider this example:
+-- Displays constructors and pattern synonyms as suggestions if
+-- it is not in scope.
--
--- data VisProxy a where VP :: forall a -> VisProxy a
---
--- f :: VisProxy Int -> ()
--- f (VP Int) = ()
---
--- Here `Int` is actually a type, but it stays on position where
--- we expect a data constructor.
---
--- In all other cases we just use this additional lookup for better
--- error messaging (See Note [Promotion]).
+-- See Note [lookupOccRnConstr]
lookupOccRnConstr :: RdrName -> RnM Name
lookupOccRnConstr rdr_name
= do { mb_gre <- lookupOccRn_maybe rdr_name
@@ -1058,6 +1047,28 @@ lookupOccRnConstr rdr_name
Just gre -> return $ greName gre
Nothing -> reportUnboundName' WL_Constructor rdr_name} }
+{- Note [lookupOccRnConstr]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+lookupOccRnConstr looks up a data constructor or pattern synonym. Simple.
+
+However, there is a fallback to the type level when the lookup fails.
+This is required to implement a pat-to-type transformation
+(See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat)
+
+Consider this example:
+
+ data VisProxy a where VP :: forall a -> VisProxy a
+
+ f :: VisProxy Int -> ()
+ f (VP Int) = ()
+
+Here `Int` is actually a type, but it occurs in a position in which we expect
+a data constructor.
+
+In all other cases we just use this additional lookup for better
+error messaging (See Note [Promotion]).
+-}
+
-- lookupOccRnRecField looks up an occurrence of a RdrName and displays
-- record fields as suggestions if it is not in scope
lookupOccRnRecField :: RdrName -> RnM Name
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -532,9 +532,9 @@ rnExpr (ExplicitSum _ alt arity expr)
= do { (expr', fvs) <- rnLExpr expr
; return (ExplicitSum noExtField alt arity expr', fvs) }
-rnExpr (RecordCon { rcon_con = con_id
+rnExpr (RecordCon { rcon_con = con_rdr
, rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
- = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_id
+ = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_rdr
; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
; (flds', fvss) <- mapAndUnzipM rn_field flds
; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -1161,7 +1161,7 @@ tc_infer_id id_name
AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con
AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps
- (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Anything tc -- TyCon or TcTyCon
+ (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Anything (tyConName tc)
ATyVar name _ -> failIllegalTyVal name
_ -> failWithTc $ TcRnExpectedValueId thing }
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -280,7 +280,7 @@ tcLookupConLike name = do
thing <- tcLookupGlobal name
case thing of
AConLike cl -> return cl
- ATyCon tc -> failIllegalTyCon WL_Constructor tc
+ ATyCon {} -> failIllegalTyCon WL_Constructor name
_ -> wrongThingErr WrongThingConLike (AGlobal thing) name
tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent
@@ -353,19 +353,20 @@ instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
lookupThing = tcLookupGlobal
-- Illegal term-level use of type things
-failIllegalTyCon :: WhatLooking -> TyCon -> TcM a
+failIllegalTyCon :: WhatLooking -> Name -> TcM a
failIllegalTyVal :: Name -> TcM a
(failIllegalTyCon, failIllegalTyVal) = (fail_tycon, fail_tyvar)
where
- fail_tycon what_looking tc = do
+ fail_tycon what_looking tc_nm = do
gre <- getGlobalRdrEnv
- let nm = tyConName tc
- pprov = case lookupGRE_Name gre nm of
+ let mb_gre = lookupGRE_Name gre tc_nm
+ pprov = case mb_gre of
Just gre -> nest 2 (pprNameProvenance gre)
Nothing -> empty
- err | isClassTyCon tc = ClassTE
- | otherwise = TyConTE
- fail_with_msg what_looking dataName nm pprov err
+ err = case greInfo <$> mb_gre of
+ Just (IAmTyCon ClassFlavour) -> ClassTE
+ _ -> TyConTE
+ fail_with_msg what_looking dataName tc_nm pprov err
fail_tyvar nm =
let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm))
=====================================
libraries/base/changelog.md
=====================================
@@ -2,6 +2,7 @@
## 4.20.2 *July 2025*
* Fix incorrect results of `integerPowMod` when the base is 0 and the exponent is negative, and `integerRecipMod` when the modulus is zero ([#26017](https://gitlab.haskell.org/ghc/ghc/-/issues/26017)).
+ * Fix bug where `naturalAndNot` was incorrectly truncating results ([CLC proposal #350](github.com/haskell/core-libraries-committee/issues/350))
## 4.20.1 *Jan 2025*
* Shipped with GHC 9.10.2
=====================================
libraries/ghc-bignum/changelog.md
=====================================
@@ -4,6 +4,7 @@
- Expose backendName
- Add `naturalSetBit[#]` (#21173), `naturalClearBit[#]` (#21175), `naturalComplementBit[#]` (#21181)
+- Fix bug where `naturalAndNot` was incorrectly truncating results (#26230)
## 1.2
=====================================
libraries/ghc-bignum/src/GHC/Num/Natural.hs
=====================================
@@ -488,7 +488,7 @@ naturalAndNot :: Natural -> Natural -> Natural
{-# NOINLINE naturalAndNot #-}
naturalAndNot (NS n) (NS m) = NS (n `and#` not# m)
naturalAndNot (NS n) (NB m) = NS (n `and#` not# (bigNatToWord# m))
-naturalAndNot (NB n) (NS m) = NS (bigNatToWord# n `and#` not# m)
+naturalAndNot (NB n) (NS m) = NB (bigNatAndNotWord# n m)
naturalAndNot (NB n) (NB m) = naturalFromBigNat# (bigNatAndNot n m)
naturalOr :: Natural -> Natural -> Natural
=====================================
rts/Messages.c
=====================================
@@ -180,13 +180,22 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg)
bh_info != &stg_CAF_BLACKHOLE_info &&
bh_info != &__stg_EAGER_BLACKHOLE_info &&
bh_info != &stg_WHITEHOLE_info) {
- // if it is a WHITEHOLE, then a thread is in the process of
- // trying to BLACKHOLE it. But we know that it was once a
- // BLACKHOLE, so there is at least a valid pointer in the
- // payload, so we can carry on.
return 0;
}
+ // If we see a WHITEHOLE then we should wait for it to turn into a BLACKHOLE.
+ // Otherwise we might look at the indirectee and segfault.
+ // See "Exception handling" in Note [Thunks, blackholes, and indirections]
+ // We might be looking at a *fresh* THUNK being WHITEHOLE-d so we can't
+ // guarantee that the indirectee is a valid pointer.
+#if defined(THREADED_RTS)
+ if (bh_info == &stg_WHITEHOLE_info) {
+ while(ACQUIRE_LOAD(&bh->header.info) == &stg_WHITEHOLE_info) {
+ busy_wait_nop();
+ }
+ }
+#endif
+
// The blackhole must indirect to a TSO, a BLOCKING_QUEUE, an IND,
// or a value.
StgClosure *p;
=====================================
rts/StgMiscClosures.cmm
=====================================
@@ -31,6 +31,7 @@ import CLOSURE ENT_VIA_NODE_ctr;
import CLOSURE RtsFlags;
import CLOSURE stg_BLOCKING_QUEUE_CLEAN_info;
import CLOSURE stg_BLOCKING_QUEUE_DIRTY_info;
+import CLOSURE stg_END_TSO_QUEUE_closure;
import CLOSURE stg_IND_info;
import CLOSURE stg_MSG_BLACKHOLE_info;
import CLOSURE stg_TSO_info;
@@ -597,6 +598,9 @@ retry:
MessageBlackHole_tso(msg) = CurrentTSO;
MessageBlackHole_bh(msg) = node;
+ // Ensure that the link field is a valid closure,
+ // since we might turn this into an indirection in wakeBlockingQueue()
+ MessageBlackHole_link(msg) = stg_END_TSO_QUEUE_closure;
SET_HDR(msg, stg_MSG_BLACKHOLE_info, CCS_SYSTEM);
// messageBlackHole has appropriate memory barriers when this object is exposed.
// See Note [Heap memory barriers].
=====================================
rts/Updates.h
=====================================
@@ -333,6 +333,10 @@
* `AP_STACK` closure recording the aborted execution state.
* See `RaiseAsync.c:raiseAsync` for details.
*
+ * This can combine with indirection shortcutting during GC to replace a BLACKHOLE
+ * with a fresh THUNK. We should be very careful here since the THUNK will have an
+ * undefined value in the indirectee field. Looking at the indirectee field can then
+ * lead to a segfault such as #26205.
*
* CAFs
* ----
=====================================
testsuite/tests/numeric/should_run/T26230.hs
=====================================
@@ -0,0 +1,8 @@
+import Data.Bits
+import GHC.Num.Natural
+
+main = do
+ print $ naturalAndNot ((2 ^ 4) .|. (2 ^ 3)) (2 ^ 3)
+ print $ naturalAndNot ((2 ^ 129) .|. (2 ^ 65)) (2 ^ 65)
+ print $ naturalAndNot ((2 ^ 4) .|. (2 ^ 3)) ((2 ^ 65) .|. (2 ^ 3))
+ print $ naturalAndNot ((2 ^ 65) .|. (2 ^ 3)) (2 ^ 3)
=====================================
testsuite/tests/numeric/should_run/T26230.stdout
=====================================
@@ -0,0 +1,4 @@
+16
+680564733841876926926749214863536422912
+16
+36893488147419103232
=====================================
testsuite/tests/numeric/should_run/all.T
=====================================
@@ -83,3 +83,4 @@ test('T22282', normal, compile_and_run, [''])
test('T22671', js_fragile(24259), compile_and_run, [''])
test('foundation', [when(js_arch(), run_timeout_multiplier(2)), js_fragile(24259)], compile_and_run, ['-O -package transformers'])
test('T24066', normal, compile_and_run, [''])
+test('T26230', normal, compile_and_run, [''])
=====================================
testsuite/tests/rename/should_fail/T25056.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE RecordWildCards #-}
+module T25056 where
+
+import T25056b
+
+foo :: T -> ()
+foo (T { unT = x }) = x
=====================================
testsuite/tests/rename/should_fail/T25056.stderr
=====================================
@@ -0,0 +1,5 @@
+T25056.hs:7:10: error: [GHC-01928]
+ • Illegal term-level use of the type constructor ‘T’
+ • imported from ‘T25056b’ at T25056.hs:4:1-14
+ (and originally defined in ‘T25056a’ at T25056a.hs:8:1-14)
+
=====================================
testsuite/tests/rename/should_fail/T25056a.hs
=====================================
@@ -0,0 +1,13 @@
+{-# LANGUAGE PatternSynonyms #-}
+module T25056a
+ ( T
+ , T_(unT)
+ , pattern T
+ ) where
+
+type T = T_ ()
+
+data T_ a = PrivateT { unT_ :: a }
+
+pattern T :: a -> T_ a
+pattern T { unT } <- PrivateT { unT_ = unT }
=====================================
testsuite/tests/rename/should_fail/T25056b.hs
=====================================
@@ -0,0 +1,3 @@
+module T25056b (T, T_(..)) where
+
+import T25056a (T, T_(..))
=====================================
testsuite/tests/rename/should_fail/all.T
=====================================
@@ -222,6 +222,7 @@ test('T23740g', normal, compile_fail, [''])
test('T23740h', normal, compile_fail, [''])
test('T23740i', req_th, compile_fail, [''])
test('T23740j', normal, compile_fail, [''])
+test('T25056', [extra_files(['T25056a.hs', 'T25056b.hs'])], multimod_compile_fail, ['T25056', '-v0'])
test('T23570', [extra_files(['T23570_aux.hs'])], multimod_compile_fail, ['T23570', '-v0'])
test('T23570b', [extra_files(['T23570_aux.hs'])], multimod_compile, ['T23570b', '-v0'])
test('T17594b', req_th, compile_fail, [''])
=====================================
testsuite/tests/typecheck/should_fail/T23739b.hs
=====================================
@@ -8,7 +8,4 @@ g1 :: Int -> Unit
g1 Int = ()
g2 :: Int
-g2 = Int{}
-
-g3 :: Int
-g3 = Int
+g2 = Int
=====================================
testsuite/tests/typecheck/should_fail/T23739b.stderr
=====================================
@@ -6,16 +6,9 @@ T23739b.hs:8:4: error: [GHC-01928]
In an equation for ‘g1’: g1 Int = ()
T23739b.hs:11:6: error: [GHC-01928]
- • Illegal term-level use of the type constructor ‘Int’
- • imported from ‘Prelude’ at T23739b.hs:2:8-14
- (and originally defined in ‘GHC.Types’)
- • In the expression: Int {}
- In an equation for ‘g2’: g2 = Int {}
-
-T23739b.hs:14:6: error: [GHC-01928]
• Illegal term-level use of the type constructor ‘Int’
• imported from ‘Prelude’ at T23739b.hs:2:8-14
(and originally defined in ‘GHC.Types’)
• In the expression: Int
- In an equation for ‘g3’: g3 = Int
+ In an equation for ‘g2’: g2 = Int
=====================================
testsuite/tests/typecheck/should_fail/T23739c.hs
=====================================
@@ -0,0 +1,8 @@
+
+module T23739c where
+
+import Data.Tuple.Experimental
+import GHC.TypeLits
+
+g :: Int
+g = Int{}
=====================================
testsuite/tests/typecheck/should_fail/T23739c.stderr
=====================================
@@ -0,0 +1,7 @@
+T23739c.hs:8:5: error: [GHC-01928]
+ • Illegal term-level use of the type constructor ‘Int’
+ • imported from ‘Prelude’ at T23739c.hs:2:8-14
+ (and originally defined in ‘GHC.Types’)
+ • In the expression: Int {}
+ In an equation for ‘g’: g = Int {}
+
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -730,3 +730,4 @@ test('T23739b', normal, compile_fail, [''])
test('T25325', normal, compile_fail, [''])
test('T25004', normal, compile_fail, [''])
test('T25004k', normal, compile_fail, [''])
+test('T23739c', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d7d323b0fb0805f3ebc10c91a9d858…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d7d323b0fb0805f3ebc10c91a9d858…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Ben Gamari pushed new branch wip/backports-9.14 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/backports-9.14
You're receiving this email because of your account on gitlab.haskell.org.
1
0
17 Aug '25
Cheng Shao pushed new branch wip/unreg-run-opt at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/unreg-run-opt
You're receiving this email because of your account on gitlab.haskell.org.
1
0