gnu: elm-compiler: Update to 0.19.1.

* gnu/packages/patches/elm-compiler-disable-reactor.patch,
gnu/packages/patches/elm-compiler-fix-map-key.patch: Delete files.
* gnu/packages/patches/elm-reactor-static-files.patch: New file.
* gnu/local.mk (dist_patch_DATA): Update accordingly.
* gnu/packages/elm.scm (elm-compiler): Update to 0.19.1.
[origin]<patches>: Remove stale patches. Add new patch.
[arguments]: Use G-expressions. Add #:configure-flags for new patch.
[inputs]: Remove ghc-file-embed. Add ghc-filelock.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>

4 files changed, 279 insertions, 125 deletions

diff --git a/gnu/packages/elm.scm b/gnu/packages/elm.scm
index ca7c61041b..988cc02de1 100644
--- a/gnu/packages/elm.scm
+++ b/gnu/packages/elm.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net>
+;;; Copyright © 2022 Philip McGrath <philip@philipmcgrath.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,18 +25,24 @@
   #:use-module (gnu packages haskell-xyz)
   #:use-module (gnu packages haskell-web)
   #:use-module (guix build-system haskell)
+  #:use-module (guix gexp)
   #:use-module (guix git-download)
   #:use-module ((guix licenses) #:prefix license:)
   #:use-module (guix packages))
 
-;; The full elm build calls out to itself via Template Haskell to
-;; compile the elm reactor web app. elm reactor isn't required to
-;; compile elm applications, so we take this part out of this
-;; bootstrap package.
+;; The `elm` build usually calls out to itself via Template Haskell to compile
+;; the `elm reactor` web app (which depends on additional Elm packages) and
+;; embeds the static files into itself.  The reactor isn't required to compile
+;; Elm applications, so we want to skip it for the bootstrap package, but we
+;; also want to be able to enable it once we can build it.  We patch Elm to
+;; instead look for the files on disk relative to the executable and to have
+;; `elm reactor` exit with a useful error message if they aren't there.
+(define %reactor-root-base
+  "share/elm/reactor-")
 (define-public elm-compiler
   (package
     (name "elm-compiler")
-    (version "0.19.0")
+    (version "0.19.1")
     (source
      (origin
        (method git-fetch)
@@ -44,24 +51,29 @@
              (url "https://github.com/elm/compiler/")
              (commit version)))
        (sha256
-        (base32 "0s93z9vr0vp5w894ghc5s34nsq09sg1msf59zfiba87sid5vgjqy"))
+        (base32 "1rdg3xp3js9xadclk3cdypkscm5wahgsfmm4ldcw3xswzhw6ri8w"))
        (patches
-        (search-patches "elm-compiler-disable-reactor.patch"
-                        "elm-compiler-fix-map-key.patch"))))
+        (search-patches "elm-reactor-static-files.patch"))))
     (build-system haskell-build-system)
     (arguments
-     `(#:phases
-       (modify-phases %standard-phases
-         (add-before 'configure 'update-constraints
-           (lambda _
-             (substitute* "elm.cabal"
-               (("(ansi-terminal|containers|network|http-client|language-glsl)\\s+[^,]+" all dep)
-                dep)))))))
+     (list
+      #:configure-flags
+      #~(list (string-append "--ghc-option=-DGUIX_REACTOR_STATIC_REL_ROOT="
+                             "\"../" #$%reactor-root-base
+                             #$(package-version this-package)
+                             "\""))
+      #:phases
+      #~(modify-phases %standard-phases
+          (add-before 'configure 'update-constraints
+            (lambda _
+              (substitute* "elm.cabal"
+                (("(ansi-terminal|containers|network|http-client|language-glsl)\\s+[^,]+" all dep)
+                 dep)))))))
     (inputs
      (list ghc-ansi-terminal
            ghc-ansi-wl-pprint
            ghc-edit-distance
-           ghc-file-embed
+           ghc-filelock
            ghc-http
            ghc-http-client
            ghc-http-client-tls
diff --git a/gnu/packages/patches/elm-compiler-disable-reactor.patch b/gnu/packages/patches/elm-compiler-disable-reactor.patch
deleted file mode 100644
index 9871b55e8d..0000000000
--- a/gnu/packages/patches/elm-compiler-disable-reactor.patch
+++ /dev/null
@@ -1,71 +0,0 @@
-commit 20d80e2323b565a36751c9455e535d8f73fa32f7
-Author: Robert Vollmert <rob@vllmrt.net>
-Date:   Fri Jun 14 16:05:47 2019 +0200
-
-    disable reactor
-
-diff --git a/elm.cabal b/elm.cabal
-index c75f9689..ece63c46 100644
---- a/elm.cabal
-+++ b/elm.cabal
-@@ -45,9 +45,6 @@ Executable elm
-         builder/src
-         ui/terminal/src
- 
--    other-extensions:
--        TemplateHaskell
--
-     Main-Is:
-         Main.hs
- 
-@@ -56,8 +53,6 @@ Executable elm
-         Develop
-         Develop.Generate.Help
-         Develop.Generate.Index
--        Develop.StaticFiles
--        Develop.StaticFiles.Build
-         Diff
-         Init
-         Install
-diff --git a/ui/terminal/src/Develop.hs b/ui/terminal/src/Develop.hs
-index 4b2252e1..7ed7716e 100644
---- a/ui/terminal/src/Develop.hs
-+++ b/ui/terminal/src/Develop.hs
-@@ -23,7 +23,6 @@ import Snap.Util.FileServe
- import qualified Elm.Project as Project
- import qualified Develop.Generate.Help as Generate
- import qualified Develop.Generate.Index as Index
--import qualified Develop.StaticFiles as StaticFiles
- import qualified Generate.Output as Output
- import qualified Json.Encode as Encode
- import qualified Reporting.Exit as Exit
-@@ -219,16 +218,7 @@ compileToHtmlBuilder mode file =
- 
- 
- serveAssets :: Snap ()
--serveAssets =
--  do  file <- getSafePath
--      case StaticFiles.lookup file of
--        Nothing ->
--          pass
--
--        Just (content, mimeType) ->
--          do  modifyResponse (setContentType (mimeType <> ";charset=utf-8"))
--              writeBS content
--
-+serveAssets = pass
- 
- 
- -- MIME TYPES
-diff --git a/ui/terminal/src/Main.hs b/terminal/src/Main.hs
-index 7000f3ca..2c76965a 100644
---- a/ui/terminal/src/Main.hs
-+++ b/ui/terminal/src/Main.hs
-@@ -39,7 +39,6 @@ main =
-       complex intro outro
-         [ repl
-         , init
--        , reactor
-         , make
-         , install
-         , bump
diff --git a/gnu/packages/patches/elm-compiler-fix-map-key.patch b/gnu/packages/patches/elm-compiler-fix-map-key.patch
deleted file mode 100644
index 4f05ded530..0000000000
--- a/gnu/packages/patches/elm-compiler-fix-map-key.patch
+++ /dev/null
@@ -1,38 +0,0 @@
-commit e3512d887df41a8162c3e361171c04beca08415b
-Author: Tom Stejskal <tom.stejskal@gmail.com>
-Date:   Mon Nov 19 20:09:43 2018 +0100
-
-    Fix Map.!: given key is not an element in the map
-
-diff --git a/compiler/src/Elm/Compiler/Type/Extract.hs b/compiler/src/Elm/Compiler/Type/Extract.hs
-index 1aafe1d4..99763392 100644
---- a/compiler/src/Elm/Compiler/Type/Extract.hs
-+++ b/compiler/src/Elm/Compiler/Type/Extract.hs
-@@ -10,6 +10,7 @@ module Elm.Compiler.Type.Extract
- 
- 
- import Data.Map ((!))
-+import qualified Data.Map as Map
- import qualified Data.Maybe as Maybe
- import qualified Data.Set as Set
- 
-@@ -134,11 +135,15 @@ extractUnion interfaces (Opt.Global home name) =
-     else
-       let
-         pname = toPublicName home name
--        unions = I._unions (interfaces ! home)
-+        maybeUnions = I._unions <$> Map.lookup home interfaces
-       in
--      case I.toUnionInternals (unions ! name) of
--        Can.Union vars ctors _ _ ->
--          T.Union pname vars <$> traverse extractCtor ctors
-+      case Map.lookup name =<< maybeUnions of
-+        Just union ->
-+          case I.toUnionInternals union of
-+            Can.Union vars ctors _ _ ->
-+              T.Union pname vars <$> traverse extractCtor ctors
-+        Nothing ->
-+          return $ T.Union pname [] []
- 
- 
- extractCtor :: Can.Ctor -> Extractor (N.Name, [T.Type])
diff --git a/gnu/packages/patches/elm-reactor-static-files.patch b/gnu/packages/patches/elm-reactor-static-files.patch
new file mode 100644
index 0000000000..94c4aa0cd1
--- /dev/null
+++ b/gnu/packages/patches/elm-reactor-static-files.patch
@@ -0,0 +1,251 @@
+From 41d219a29b03f3114af7a0521c8b2dbbb487c3e1 Mon Sep 17 00:00:00 2001
+From: Philip McGrath <philip@philipmcgrath.com>
+Date: Wed, 13 Apr 2022 18:45:58 -0400
+Subject: [PATCH] reactor: look for static files relative to executable
+
+Must built with `-DGUIX_REACTOR_STATIC_REL_ROOT="../path/to/reactor"`.
+
+This lets us build a version of Elm without the `elm reactor` for
+bootstrapping, then simply put the files in place in the final package.
+---
+ elm.cabal                                 |  2 +-
+ terminal/src/Develop.hs                   | 32 +++++++++++----
+ terminal/src/Develop/StaticFiles.hs       | 37 ++++++++++-------
+ terminal/src/Develop/StaticFiles/Build.hs | 50 ++++++++++++++---------
+ 4 files changed, 79 insertions(+), 42 deletions(-)
+
+diff --git a/elm.cabal b/elm.cabal
+index bf1cfcf0..93161072 100644
+--- a/elm.cabal
++++ b/elm.cabal
+@@ -50,6 +50,7 @@ Executable elm
+ 
+     other-extensions:
+         TemplateHaskell
++        CPP
+ 
+     Main-Is:
+         Main.hs
+@@ -211,7 +212,6 @@ Executable elm
+         containers >= 0.5.8.2 && < 0.6,
+         directory >= 1.2.3.0 && < 2.0,
+         edit-distance >= 0.2 && < 0.3,
+-        file-embed,
+         filelock,
+         filepath >= 1 && < 2.0,
+         ghc-prim >= 0.5.2,
+diff --git a/terminal/src/Develop.hs b/terminal/src/Develop.hs
+index 00339364..6855b03e 100644
+--- a/terminal/src/Develop.hs
++++ b/terminal/src/Develop.hs
+@@ -33,6 +33,7 @@ import qualified Reporting.Exit as Exit
+ import qualified Reporting.Task as Task
+ import qualified Stuff
+ 
++import System.Exit as SysExit
+ 
+ 
+ -- RUN THE DEV SERVER
+@@ -45,13 +46,29 @@ data Flags =
+ 
+ 
+ run :: () -> Flags -> IO ()
+-run () (Flags maybePort) =
++run () flags = do
++  frontEnd <- StaticFiles.prepare
++  case frontEnd of
++    Right lookup ->
++      reallyRun lookup flags
++    Left missing ->
++      SysExit.die $ unlines
++      [ "The `reactor` command is not available."
++      , ""
++      , "On Guix, these files are needed for `elm reactor` to work,"
++      , "but they are missing:"
++      , ""
++      , unlines (map (\pth -> "    " ++ (show pth)) missing)
++      ]
++
++reallyRun :: StaticFiles.Lookup -> Flags -> IO ()
++reallyRun lookup (Flags maybePort) =
+   do  let port = maybe 8000 id maybePort
+       putStrLn $ "Go to http://localhost:" ++ show port ++ " to see your project dashboard."
+       httpServe (config port) $
+         serveFiles
+         <|> serveDirectoryWith directoryConfig "."
+-        <|> serveAssets
++        <|> serveAssets lookup
+         <|> error404
+ 
+ 
+@@ -169,16 +186,15 @@ compile path =
+ -- SERVE STATIC ASSETS
+ 
+ 
+-serveAssets :: Snap ()
+-serveAssets =
++serveAssets :: StaticFiles.Lookup -> Snap ()
++serveAssets lookup =
+   do  path <- getSafePath
+-      case StaticFiles.lookup path of
++      case lookup path of
+         Nothing ->
+           pass
+ 
+-        Just (content, mimeType) ->
+-          do  modifyResponse (setContentType (mimeType <> ";charset=utf-8"))
+-              writeBS content
++        Just (fsPath, mimeType) ->
++          serveFileAs (mimeType <> ";charset=utf-8") fsPath
+ 
+ 
+ 
+diff --git a/terminal/src/Develop/StaticFiles.hs b/terminal/src/Develop/StaticFiles.hs
+index 94ee72dc..3227d617 100644
+--- a/terminal/src/Develop/StaticFiles.hs
++++ b/terminal/src/Develop/StaticFiles.hs
+@@ -2,7 +2,8 @@
+ {-# LANGUAGE OverloadedStrings #-}
+ {-# LANGUAGE TemplateHaskell #-}
+ module Develop.StaticFiles
+-  ( lookup
++  ( prepare
++  , Lookup
+   , cssPath
+   , elmPath
+   , waitingPath
+@@ -11,9 +12,7 @@ module Develop.StaticFiles
+ 
+ import Prelude hiding (lookup)
+ import qualified Data.ByteString as BS
+-import Data.FileEmbed (bsToExp)
+ import qualified Data.HashMap.Strict as HM
+-import Language.Haskell.TH (runIO)
+ import System.FilePath ((</>))
+ 
+ import qualified Develop.StaticFiles.Build as Build
+@@ -26,20 +25,29 @@ import qualified Develop.StaticFiles.Build as Build
+ type MimeType =
+   BS.ByteString
+ 
++type Lookup = FilePath -> Maybe (FilePath, MimeType)
+ 
+-lookup :: FilePath -> Maybe (BS.ByteString, MimeType)
+-lookup path =
++prepare :: IO (Either [FilePath] Lookup)
++prepare = do
++  found <- Build.findReactorFrontEnd expectedFiles
++  return $ case found of
++    Left missing ->
++      Left missing
++    Right resolved ->
++      Right (mkLookup (HM.fromList resolved))
++
++mkLookup :: HM.HashMap FilePath (FilePath, MimeType) -> Lookup
++mkLookup dict path =
+   HM.lookup path dict
+ 
+ 
+-dict :: HM.HashMap FilePath (BS.ByteString, MimeType)
+-dict =
+-  HM.fromList
+-    [ faviconPath  ==> (favicon , "image/x-icon")
+-    , elmPath      ==> (elm     , "application/javascript")
+-    , cssPath      ==> (css     , "text/css")
+-    , codeFontPath ==> (codeFont, "font/ttf")
+-    , sansFontPath ==> (sansFont, "font/ttf")
++expectedFiles :: [(FilePath, MimeType)]
++expectedFiles =
++    [ faviconPath  ==> "image/x-icon"
++    , elmPath      ==> "application/javascript"
++    , cssPath      ==> "text/css"
++    , codeFontPath ==> "font/ttf"
++    , sansFontPath ==> "font/ttf"
+     ]
+ 
+ 
+@@ -82,7 +90,7 @@ sansFontPath =
+   "_elm" </> "source-sans-pro.ttf"
+ 
+ 
+-
++{-
+ -- ELM
+ 
+ 
+@@ -121,3 +129,4 @@ sansFont =
+ favicon :: BS.ByteString
+ favicon =
+   $(bsToExp =<< runIO (Build.readAsset "favicon.ico"))
++-}
+diff --git a/terminal/src/Develop/StaticFiles/Build.hs b/terminal/src/Develop/StaticFiles/Build.hs
+index c61fae57..c39b08b0 100644
+--- a/terminal/src/Develop/StaticFiles/Build.hs
++++ b/terminal/src/Develop/StaticFiles/Build.hs
+@@ -1,28 +1,39 @@
+ {-# LANGUAGE OverloadedStrings #-}
++{-# LANGUAGE CPP #-}
+ module Develop.StaticFiles.Build
+-  ( readAsset
+-  , buildReactorFrontEnd
++  ( findReactorFrontEnd
+   )
+   where
+ 
+-
+-import qualified Data.ByteString as BS
+-import qualified Data.ByteString.Builder as B
+-import qualified Data.ByteString.Lazy as LBS
+-import qualified Data.NonEmptyList as NE
+ import qualified System.Directory as Dir
+-import System.FilePath ((</>))
+-
+-import qualified BackgroundWriter as BW
+-import qualified Build
+-import qualified Elm.Details as Details
+-import qualified Generate
+-import qualified Reporting
+-import qualified Reporting.Exit as Exit
+-import qualified Reporting.Task as Task
+-
+-
+-
++import System.FilePath ((</>), takeDirectory)
++import System.Environment (getExecutablePath)
++import Data.Either as Either
++
++reactorStaticRelRoot :: FilePath
++reactorStaticRelRoot = GUIX_REACTOR_STATIC_REL_ROOT
++
++type Resolved a = (FilePath, (FilePath, a))
++
++findReactorFrontEnd :: [(FilePath, a)] -> IO (Either [FilePath] [Resolved a])
++findReactorFrontEnd specs = do
++  exe <- getExecutablePath
++  let dir = takeDirectory exe </> reactorStaticRelRoot
++  dirExists <- Dir.doesDirectoryExist dir
++  files <- sequence (map (findFile dir) specs)
++  return $ case Either.lefts files of
++           [] ->
++             Right (Either.rights files)
++           missing ->
++             Left $ if dirExists then missing else [dir]
++
++findFile :: FilePath -> (FilePath, a) -> IO (Either FilePath (Resolved a))
++findFile dir (rel, rhs) = do
++  let abs = dir </> rel
++  exists <- Dir.doesFileExist abs
++  return $ if not exists then Left abs else Right (rel, (abs, rhs))
++
++{-
+ -- ASSETS
+ 
+ 
+@@ -71,3 +82,4 @@ runTaskUnsafe task =
+                 \\nCompile with `elm make` directly to figure it out faster\
+                 \\n--------------------------------------------------------\
+                 \\n"
++-}
+-- 
+2.32.0
+