Merge pull request elm#2217 from elm/new-compile-endpoint

Add compile/v2 returning errors in JSON
cllns · Aug 22, 2021 · 3994905 · 3994905
2 parents fc50335 + 2b1be53
commit 3994905
Show file tree

Hide file tree

Showing 2 changed files with 111 additions and 20 deletions.
diff --git a/worker/src/Endpoint/Compile.hs b/worker/src/Endpoint/Compile.hs
@@ -1,7 +1,8 @@
 {-# OPTIONS_GHC -Wall #-}
 {-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
 module Endpoint.Compile
-  ( endpoint
+  ( endpoint_V1
+  , endpoint_V2
   , loadErrorJS
   )
   where
@@ -63,26 +64,50 @@ allowedOrigins =
 
 
 
+-- ENDPOINT (V1)
+
+
+endpoint_V1 :: A.Artifacts -> Snap ()
+endpoint_V1 artifacts =
+  endpoint artifacts $ \result ->
+    case result of
+      Ok name js -> writeBuilder $ Html.sandwich name js
+      Err report -> writeBuilder $ renderProblem_V1 report
+
+
+
+-- ENDPOINT (V2)
+
+
+endpoint_V2 :: A.Artifacts -> Snap ()
+endpoint_V2 artifacts =
+  endpoint artifacts $ \result ->
+    case result of
+      Ok name js -> writeBuilder $ renderSuccess_V2 name js
+      Err report -> writeBuilder $ renderProblem_V2 report
+
+
+
 -- ENDPOINT
 
 
-endpoint :: A.Artifacts -> Snap ()
-endpoint artifacts =
+data Result
+  = Ok N.Name B.Builder
+  | Err Help.Report
+
+
+endpoint :: A.Artifacts -> (Result -> Snap ()) -> Snap ()
+endpoint artifacts callback =
   Cors.allow POST allowedOrigins $
   do  result <- foldMultipart defaultUploadPolicy ignoreFile 0
       case result of
         ([("code",source)], 0) ->
           do  modifyResponse $ setContentType "text/html; charset=utf-8"
-              case compile artifacts source of
-                Success builder ->
-                  writeBuilder builder
-
-                NoMain ->
-                  writeBuilder $ renderReport noMain
-
-                BadInput name err ->
-                  writeBuilder $ renderReport $
-                    Help.compilerReport "/" (Error.Module name "/try" File.zeroTime source err) []
+              callback $
+                case compile artifacts source of
+                  Success name js   -> Ok name js
+                  NoMain            -> Err noMain
+                  BadInput name err -> Err $ Help.compilerReport "/" (Error.Module name "/try" File.zeroTime source err) []
 
         _ ->
           do  modifyResponse $ setResponseStatus 400 "Bad Request"
@@ -104,7 +129,7 @@ ignoreFile _ _ count =
 
 
 data Outcome
-  = Success B.Builder
+  = Success N.Name B.Builder
   | NoMain
   | BadInput ModuleName.Raw Error.Error
 
@@ -138,7 +163,7 @@ compile (A.Artifacts interfaces objects) source =
                     mains = Map.singleton home main_
                     graph = Opt.addLocalGraph locals objects
                   in
-                  Success $ Html.sandwich name $ JS.generate mode graph mains
+                  Success name $ JS.generate mode graph mains
 
 
 checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either (NE.List Import.Error) (Map.Map ModuleName.Raw I.Interface)
@@ -163,11 +188,11 @@ checkImports interfaces imports =
 
 
 
--- RENDER REPORT
+-- RENDER PROBLEM (V1)
 
 
-renderReport :: Help.Report -> B.Builder
-renderReport report =
+renderProblem_V1 :: Help.Report -> B.Builder
+renderProblem_V1 report =
   [r|<!DOCTYPE HTML>
 <html>
 <head>
@@ -179,14 +204,79 @@ renderReport report =
   <script>
     var app = Elm.Errors.init({flags:|] <> Encode.encodeUgly (Exit.toJson report) <> [r|});
     app.ports.jumpTo.subscribe(function(region) {
-      window.parent.postMessage(JSON.stringify(region), '*');
+      window.parent.postMessage(JSON.stringify(region), "*");
     });
   </script>
 </body>
 </html>|]
 
 
 
+-- RENDER SUCCESS (V2)
+
+
+renderSuccess_V2 :: N.Name -> B.Builder -> B.Builder
+renderSuccess_V2 moduleName javascript =
+  let name = N.toBuilder moduleName in
+  [r|<!DOCTYPE HTML>
+<html>
+<head>
+  <meta charset="UTF-8">
+  <title>|] <> name <> [r|</title>
+  <style>body { padding: 0; margin: 0; }</style>
+</head>
+
+<body>
+
+<pre id="elm"></pre>
+
+<script>
+window.parent.postMessage("SUCCESS", "*");
+
+try {
+|] <> javascript <> [r|
+
+  var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm") });
+}
+catch (e)
+{
+  // display initialization errors (e.g. bad flags, infinite recursion)
+  var header = document.createElement("h1");
+  header.style.fontFamily = "monospace";
+  header.innerText = "Initialization Error";
+  var pre = document.getElementById("elm");
+  document.body.insertBefore(header, pre);
+  pre.innerText = e;
+  throw e;
+}
+</script>
+
+</body>
+</html>|]
+
+
+
+-- RENDER PROBLEM (V2)
+
+
+renderProblem_V2 :: Help.Report -> B.Builder
+renderProblem_V2 report =
+  [r|<!DOCTYPE HTML>
+<html>
+<head>
+  <meta charset="UTF-8">
+  <style>body { padding: 0; margin: 0; display: none; }</style>
+</head>
+<body>
+  <script>
+    var errors = |] <> Encode.encodeUgly (Exit.toJson report) <> [r|;
+    window.parent.postMessage(JSON.stringify(errors), "*");
+  </script>
+</body>
+</html>|]
+
+
+
 -- NO MAIN
 
 

diff --git a/worker/src/Main.hs b/worker/src/Main.hs
@@ -31,7 +31,8 @@ main =
       httpServe config $ msum $
         [ ifTop $ status
         , path "repl" $ Repl.endpoint rArtifacts
-        , path "compile" $ Compile.endpoint cArtifacts
+        , path "compile" $ Compile.endpoint_V1 cArtifacts
+        , path "compile/v2" $ Compile.endpoint_V2 cArtifacts
         , path "compile/errors.js" $ serveJavaScript errorJS
         , path "compile/deps-info.json" $ serveDepsInfo depsInfo
         , notFound