Add reproduction case for failing quasiquoting when using JS backend (#2199)

* Add reproduction case for failing quasiquoting when using JS backend

- The JS backend is failing with ghc-9.8.2 due to missing "nodejs" executable
  and "ghci" package.
- Uncommenting the code in "modules" of "test/js-template-haskell/default.nix"
  will fix the nodejs issue.
- Unsure how to fix the "ghci" issue.

* Remove unnecesary base constraint

* GHC JS backend fixes

* Workarounds for ghc 9.10

* Disable c-ffi test for js backend

* Disable broken tests

* Add .profiled and .dwarft checks

* Add .profiled and .dwarft checks

* Exclude test for musl on aarch64

---------

Co-authored-by: Samuel Evans-Powell <mail@sevanspowell.net>

Author: hamishmack

builder/comp-builder.nix

@@ -418,7 +418,8 @@ let
 
     nativeBuildInputs =
       [ghc buildPackages.removeReferencesTo]
-      ++ executableToolDepends;
+      ++ executableToolDepends
+      ++ (lib.optional stdenv.hostPlatform.isGhcjs buildPackages.nodejs);
 
     outputs = ["out"]
       ++ (lib.optional keepConfigFiles "configFiles")

builder/hspkg-builder.nix

@@ -31,11 +31,13 @@ let
 
   cabalFile = if package-description-override == null || bundledSrc != null then null else package-description-override;
 
-  defaultSetupSrc = if stdenv.hostPlatform.isGhcjs then ./Setup.ghcjs.hs else ./Setup.hs;
+  # New GHC JS backend run emcc itself without the need for custom Setup.hs
+  oldGhcjs = stdenv.hostPlatform.isGhcjs && builtins.compareVersions ghc.version "9.10" < 0;
+  defaultSetupSrc = if oldGhcjs then ./Setup.ghcjs.hs else ./Setup.hs;
 
   setup = if package.buildType == "Simple"
     then
-      if stdenv.targetPlatform.isGhcjs # TODO probably should be hostPlatform, but only HsColour used to build ghc will change (updating will require rebuilding all the ghcjs versions)
+      if oldGhcjs
         then
           buildPackages.haskell-nix.nix-tools-unchecked.exes.default-setup-ghcjs // { exeName = "default-setup-ghcjs"; }
         else

lib/check.nix

@@ -1,5 +1,5 @@
 { stdenv, lib, haskellLib, buildPackages }:
-drv:
+let self = drv:
 
 let
   component = drv.config;
@@ -28,6 +28,8 @@ in stdenv.mkDerivation ((
 
   passthru = {
     inherit (drv) identifier config configFiles executableToolDepends cleanSrc env exeName;
+    profiled = self drv.profiled;
+    dwarf = self drv.dwarf;
   };
 
   inherit (drv) meta LANG LC_ALL buildInputs;
@@ -62,4 +64,5 @@ in stdenv.mkDerivation ((
   inherit (component) preCheck postCheck;
 }
 // lib.optionalAttrs (drv ? LOCALE_ARCHIVE) { inherit (drv) LOCALE_ARCHIVE; }
-)
+);
+in self

modules/component-driver.nix

@@ -24,7 +24,7 @@ in
 
   options.reinstallableLibGhc = lib.mkOption {
     type = lib.types.bool;
-    default = true;
+    default = !pkgs.stdenv.hostPlatform.isGhcjs;
     description = "Is lib:ghc reinstallable?";
   };
   options.setup-depends = lib.mkOption {

overlays/ghc-packages.nix

@@ -73,7 +73,7 @@ let
       iserv        = "utils/iserv";
     } // final.lib.optionalAttrs ((!final.stdenv.hostPlatform.isGhcjs || builtins.compareVersions ghcVersion "9.6" < 0) && builtins.compareVersions ghcVersion "9.8" < 0) {
       libiserv     = "libraries/libiserv";
-    } // final.lib.optionalAttrs (!final.stdenv.hostPlatform.isGhcjs) {
+    } // final.lib.optionalAttrs (!final.stdenv.hostPlatform.isGhcjs || builtins.compareVersions ghcVersion "9" > 0) {
       ghc          = "compiler";
       ghc-boot     = "libraries/ghc-boot";
     } // (

test/default.nix

@@ -221,6 +221,7 @@ let
     cabal-project-nix-path = callTest ./cabal-project-nix-path {};
     plugin = callTest ./plugin {};
     supported-languages = callTest ./supported-langauges {};
+    js-template-haskell = callTest ./js-template-haskell {};
     unit = unitTests;
   };
 

test/js-template-haskell/default.nix

@@ -0,0 +1,26 @@
+# Test building TH code that needs DLLs when cross compiling for windows
+{ stdenv, lib, project', haskellLib, recurseIntoAttrs, testSrc, compiler-nix-name, ... }:
+
+with lib;
+
+let
+  project = project' {
+    inherit compiler-nix-name;
+    src = testSrc "js-template-haskell";
+  };
+
+  packages = project.hsPkgs;
+
+in recurseIntoAttrs {
+  ifdInputs = {
+    inherit (project) plan-nix;
+  };
+
+  meta.disabled = stdenv.buildPlatform != stdenv.hostPlatform && stdenv.hostPlatform.isAarch64;
+
+  build = packages.js-template-haskell.components.library;
+  check = packages.js-template-haskell.checks.test;
+} // optionalAttrs (!stdenv.hostPlatform.isGhcjs) {
+  build-profiled = packages.js-template-haskell.components.library.profiled;
+  check-profiled = packages.js-template-haskell.checks.test.profiled;
+}

test/js-template-haskell/js-template-haskell.cabal

@@ -0,0 +1,24 @@
+cabal-version:      3.0
+name:               js-template-haskell
+version:            0.1.0.0
+category:           Repro
+build-type:         Simple
+
+common warnings
+    ghc-options: -Wall
+
+library
+    import:           warnings
+    exposed-modules:  MyLib
+    build-depends:    base
+                    , uri-bytestring
+    hs-source-dirs:   src
+    default-language: Haskell2010
+
+test-suite test
+  type: exitcode-stdio-1.0
+  main-is: test/Main.hs
+  build-depends: base, js-template-haskell
+  if arch(javascript) && impl(ghc >=9.10.1)
+    ghc-options: -ddisable-js-c-sources
+

test/js-template-haskell/src/MyLib.hs

@@ -0,0 +1,9 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module MyLib (someUri) where
+
+import URI.ByteString.QQ
+
+someUri :: String
+someUri = show [uri|https://www.example.com/|]
+

test/js-template-haskell/test/Main.hs

@@ -0,0 +1,17 @@
+module Main where
+
+import Control.Monad (unless)
+import System.Exit (exitFailure)
+
+import MyLib (someUri)
+
+expected, actual :: String
+expected = "URI {uriScheme = Scheme {schemeBS = \"https\"}, uriAuthority = Just (Authority {authorityUserInfo = Nothing, authorityHost = Host {hostBS = \"www.example.com\"}, authorityPort = Nothing}), uriPath = \"/\", uriQuery = Query {queryPairs = []}, uriFragment = Nothing}"
+actual = someUri
+
+main :: IO ()
+main =
+  unless (expected == actual) $ do
+    putStrLn $ "Unexpected TH result : " <> actual
+    exitFailure
+