@@ -1024,8 +1024,7 @@ dist_patch_DATA = \
%D%/packages/patches/einstein-build.patch \
%D%/packages/patches/elfutils-tests-ptrace.patch \
%D%/packages/patches/elixir-path-length.patch \
- %D%/packages/patches/elm-compiler-disable-reactor.patch \
- %D%/packages/patches/elm-compiler-fix-map-key.patch \
+ %D%/packages/patches/elm-reactor-static-files.patch \
%D%/packages/patches/elogind-revert-polkit-detection.patch \
%D%/packages/patches/emacs-exec-path.patch \
%D%/packages/patches/emacs-git-email-missing-parens.patch \
@@ -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 @@ (define-module (gnu packages elm)
#: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 @@ (define-public elm-compiler
(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
deleted file mode 100644
@@ -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
deleted file mode 100644
@@ -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])
new file mode 100644
@@ -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
+