Enable gist saving plus other updates

client/README.md

@@ -0,0 +1,25 @@
+Rewrite of TryPureScript using latest features of PS ecosystem, such as:
+* Halogen Hooks
+* Tailwind CSS
+
+Lots of HTML and JS code was eliminated.
+
+Also enables gist saving and tracking state in URL rather than local storage.
+
+### Local Development
+```
+npm i
+npm config set tps:configpath "config/dev/*.purs"
+npm run gen-css # Create initial tailwind css files
+npm run start # Launch local dev server with automatic reload/refresh.
+
+# Optional:
+npm run build # To manually rebuild if IDE does not do this automatically.
+npm run lock-css # To speed up rebuilds if you're not adding new css classes.
+```
+
+### Building for production
+```
+npm config set tps:configpath "config/prod/*.purs"
+npm run prod # Create minified production build
+```

client/config/dev/Try.Config.purs

@@ -1,10 +1,22 @@
 module Try.Config where
 
+appDomain :: String
+appDomain = "http://localhost:1234"
+
+tokenServerUrl :: String
+--tokenServerUrl = "http://localhost:7071/api/localtrigger"
+tokenServerUrl = "https://localtpsfunction.azurewebsites.net/api/localtps?code=Il1fqBKydiLWqoognUIzgppwi10qfmXjkhAa75yRg5S4S10LNfsiTw=="
+
+-- GitHub OAuth app for saving gists.
+-- This is tied to a specific app domain.
+clientID :: String
+clientID = "6f4e10fd8cef6995ac09"
+
 loaderUrl :: String
-loaderUrl = "js/output"
+--loaderUrl = "js/output"
+--loaderUrl = "http://localhost:8080"
+loaderUrl = "https://compile.purescript.org/output"
 
 compileUrl :: String
-compileUrl = "http://localhost:8081"
-
-mainGist :: String
-mainGist = "7ad2b2eef11ac7dcfd14aa1585dd8f69"
+--compileUrl = "http://localhost:8081"
+compileUrl = "https://compile.purescript.org"

client/config/dev/index.js

@@ -0,0 +1 @@
+require("../output/Main/index.js").main();

client/config/prod/Try.Config.purs

@@ -1,10 +1,18 @@
 module Try.Config where
 
+appDomain :: String
+appDomain = "https://try.ps.ai"
+
+tokenServerUrl :: String
+tokenServerUrl = "https://tpsfunction.azurewebsites.net/api/tps?code=JmxFIJvNG9E4qFtrwyD2v40YIWAtKUt1HDxLQ9rjmP4bRafnxWjNZg=="
+
+-- GitHub OAuth app for saving gists.
+-- This is tied to a specific app domain.
+clientID :: String
+clientID = "3634da383bb531261af5"
+
 loaderUrl :: String
 loaderUrl = "https://compile.purescript.org/output"
 
 compileUrl :: String
 compileUrl = "https://compile.purescript.org"
-
-mainGist :: String
-mainGist = "7ad2b2eef11ac7dcfd14aa1585dd8f69"

client/css/css2purs.py

@@ -0,0 +1,82 @@
+#!/usr/bin/python3
+import re
+import fileinput
+
+# Usage:
+# cat tailwind.css | ./css2purs.py > Tailwind.purs
+
+# vim Regex
+# /^\s*\.[^ ]*
+
+# Using list rather than set to preserve sorted order
+# Assuming that duplicates are always adjacent
+cssNames = []
+
+def process(line):
+    # Example input:
+    # line = '    .-sm\:-space-y-0-w-1\/2:hover {'
+    regName = re.compile('^\s*\.([^ ]*?[^\\\\])(:.*)? .*$')
+
+    m = regName.match(line)
+
+    if m:
+        escaped = m.group(1)
+        # Just escaped class name
+        # -sm\:-space-y-0-w-1\/2
+
+        cssStr = escaped.replace('\\', '')
+        # Remove escaped symbols - this is the CSS string
+        # -sm:-space-y-0-w-1/2
+
+        # don't add duplicates
+        # assuming always adjacent
+        if len(cssNames) and cssNames[-1] == cssStr:
+            return
+
+        cssNames.append(cssStr)
+
+def cssToPs(cssStr):
+    # Conversion to PureScript-compatible name
+    # Must remove symbols
+
+    def negRepl(m):
+        return m.group(1) + 'neg' + m.group(3).upper()
+    negSub = re.sub(r'(^|:)(-)(.)', negRepl, cssStr)
+    # Replace leading dashes (used to represent negatives) with 'neg'
+    # Camel-case for next word
+    # negSm:negSpace-y-0-w-1/2
+
+    colonDivSub = negSub.replace(':', '-').replace('/', 'd')
+    # replace colon separator with dash
+    # replace division sign for fractions with 'd'
+    # negSm-negSpace-y-0-w-1d2
+
+    def dashRepl(m):
+        return m.group(1).upper()
+    dashSub = re.sub(r'-(.)', dashRepl, colonDivSub)
+    # Convert dash-separator to camelCase
+    # negSmNegSpaceY0W1d2
+
+    # Debug prints
+    # print('cssStr', cssStr)
+    # print(escaped)
+    # print(negSub)
+    # print(colonDivSub)
+    # print(dashSub)
+
+    psName = dashSub
+    print()
+    print('-- | ' + cssStr)
+    print(psName + ' :: ClassName')
+    print(psName + ' = ClassName "' + cssStr + '"')
+
+for line in fileinput.input():
+    process(line)
+
+print('-- | Autogenerated from tailwind.css')
+print('module Tailwind where')
+print()
+print('import Halogen.HTML.Core (ClassName(..))')
+
+for cssName in cssNames:
+    cssToPs(cssName)

client/css/tailwind_inputs.css

@@ -0,0 +1,3 @@
+@tailwind base;
+@tailwind components;
+@tailwind utilities;

client/package.json

@@ -1,17 +1,56 @@
 {
-  "name": "trypurescript-client",
+  "name": "tps",
   "private": true,
   "config": {
     "configpath": "config/dev/*.purs"
   },
   "scripts": {
-    "clean": "rimraf output",
-    "build": "spago bundle-app --path $npm_package_config_configpath --purs-args '--censor-lib --strict' --to public/js/index.js"
+    "c-user-facing": "# --------- user facing scripts -------",
+
+    "c-gen-css": "# -- Generate tailwind css AND purs css wrapper",
+    "gen-css": "npm run build-css-only && npm run css2purs",
+
+    "c1-lock-css": "# -- Strip away unused css from autogenerated purs files.",
+    "c2-lock-css": "# -- This improves rebuild times, but won't allow adding new css.",
+    "c3-lock-css": "# -- So re-run gen-css before making additional css changes.",
+    "lock-css": "npm run bundle && npm run css-purge && npm run css2purs",
+
+    "c-build": "# -- Build purs code in project",
+    "build": "spago build --path $npm_package_config_configpath",
+
+    "c-start": "# -- Launch development server in web browser",
+    "start": "npm run build && cp config/dev/index.js public && webpack-dev-server --port 1234 --open --config webpack.dev.js",
+
+    "c-prod": "# -- Create minified production build",
+    "prod": "npm run bundle && npm run css-purge && webpack --config webpack.prod.js",
+
+    "c-wp-dev-build": "# -- Create unminified dev build. This is useful for troubleshooting the production build.",
+    "wp-dev-build": "cp config/dev/index.js public && webpack --config webpack.dev.js",
+
+    "c-serve-static": "# -- serves static files locally. For checking if everything was bundled correctly.",
+    "serve-static": "http-server dist/ -c-1 -o tps --port 1234 -P http://localhost:1234\\?",
+
+    "c-internal": "# -------- internal helper scripts -------",
+
+    "bundle": "spago bundle-app --path $npm_package_config_configpath --to public/index.js",
+    "build-css-only": "tailwindcss build css/tailwind_inputs.css -o public/tailwind.css",
+    "css2purs": "cat public/tailwind.css | ./css/css2purs.py > src/Tailwind.purs",
+    "css-purge": "NODE_ENV=production npm run build-css-only"
   },
   "devDependencies": {
-    "purescript": "^0.13.6",
-    "purescript-psa": "^0.7.3",
-    "rimraf": "^2.5.4",
-    "spago": "^0.14.0"
+    "clean-webpack-plugin": "^3.0.0",
+    "copy-webpack-plugin": "^6.0.3",
+    "css-loader": "^3.6.0",
+    "cssnano": "^4.1.10",
+    "exports-loader": "^1.1.0",
+    "file-loader": "^6.0.0",
+    "html-webpack-plugin": "^4.3.0",
+    "style-loader": "^1.2.1",
+    "tailwindcss": "^1.4.6",
+    "webpack": "^4.43.0",
+    "webpack-cli": "^3.3.12",
+    "webpack-dev-server": "^3.11.0",
+    "webpack-merge": "^5.0.9",
+    "xhr2": "^0.2.0"
   }
 }

client/packages.dhall

@@ -119,9 +119,12 @@ let additions =
 
 
 let upstream =
-      https://github.com/purescript/package-sets/releases/download/psc-0.13.6-20200404/packages.dhall sha256:f239f2e215d0cbd5c203307701748581938f74c4c78f4aeffa32c11c131ef7b6
+      https://github.com/purescript/package-sets/releases/download/psc-0.13.8-20200724/packages.dhall sha256:bb941d30820a49345a0e88937094d2b9983d939c9fd3a46969b85ce44953d7d9
 
-let overrides = {=}
+let overrides =
+  { halogen-hooks-extra =
+      upstream.halogen-hooks-extra // { version = "v0.7.1" }
+  }
 
 let additions = {=}
 

client/public/CNAME

@@ -0,0 +1 @@
+try.ps.ai

client/public/ace.css

@@ -0,0 +1,18 @@
+.error {
+  position: absolute;
+  z-index: 20;
+  border-bottom: 2px dotted red;
+}
+
+/* Currently unsued, but can re-enable. Assuming it's spammy */
+.warning {
+  position: absolute;
+  z-index: 20;
+  border-bottom: 2px dotted #c4953a;
+}
+
+/* Can re-enable if there's an issue without this option
+.ace_gutter-tooltip {
+  white-space: pre-wrap;
+}
+*/

client/public/frame.html → client/public/frame-error.html

@@ -1,13 +1,11 @@
 <!DOCTYPE HTML>
 <html>
 <head>
-  <title>Try PureScript!</title>
+  <title>Try PureScript iFrame</title>
   <meta content="text/html;charset=utf-8" http-equiv="Content-Type">
   <meta content="utf-8" http-equiv="encoding">
-  <meta name="viewport" content="width=device-width, initial-scale=1.0">
-  <script src="js/frame.js"></script>
 </head>
 <body>
-<main id="main"></main>
+  <p>Your browser is missing <a href=https://caniuse.com/#feat=iframe-srcdoc>srcdoc</a> support</p>
 </body>
 </html>

client/public/frame-load.js

@@ -0,0 +1,87 @@
+/*
+This script executes the JS files returned by PS compilation.
+*/
+
+// Get directory name of path
+function dirname(str) {
+  let ix = str.lastIndexOf("/");
+  return ix < 0 ? "" : str.slice(0, ix);
+};
+
+// Concatenates paths together
+function resolvePath(a, b) {
+  // `b` relative to current directory with `./`
+  if (b[0] === "." && b[1] === "/") {
+    return dirname(a) + b.slice(1);
+  }
+  // `b` relative to `a` parent directory with `../`
+  if (b[0] === "." && b[1] === "." && b[2] === "/") {
+    return dirname(dirname(a)) + b.slice(2);
+  }
+  // `b` is either shim or path from root
+  return b;
+};
+
+// Executes JS source and all dependencies.
+// Maintains cache of previously-executed sources.
+function evalSources(sources) {
+  // Cache all modules
+  var modules = {};
+  // Executes module source, or returns cached exports.
+  return function load(name) {
+    // Check if module is already cached
+    if (modules[name]) {
+      return modules[name].exports;
+    }
+    // Not cached, so execute contents.
+    // Provide custom `require`, `module`, and `exports`.
+    // Custom `require` which executes file contents, as well as any dependencies.
+    function require(path) {
+      return load(resolvePath(name, path));
+    }
+    // Provide empty exports, which will be set, and then returned.
+    var module = modules[name] = { exports: {} };
+    // Create a function from the module's file contents,
+    // and execute this function with our substitutions.
+    new Function("module", "exports", "require", sources[name])(module, module.exports, require);
+    return module.exports;
+  };
+};
+
+function loadFrame(str) {
+  // Convert JSON string back to object.
+  // keys: file paths
+  // values: compressed JS source
+  obj = JSON.parse(str);
+
+  // Decompress values back to JS source
+  Object.keys(obj).forEach(function (key) {
+    obj[key] = LZString.decompressFromEncodedURIComponent(obj[key]);
+  });
+
+  // Execute all sources, and save returned `exports` from `<file>`.
+  // Expecting a `exports.main` entry point.
+  let file = evalSources(obj)("<file>");
+
+  // Check if `main` can be launched
+  if (!file.main) {
+    console.log('Missing "main"');
+  } else if (typeof file.main !== "function") {
+    console.log('"main" is not a function');
+  } else {
+    // Launch entry point
+    file.main();
+  }
+};
+
+// Call script tag contents when frame loads.
+// Expects a call to loadFrame, passing JS sources.
+window.onload = function() {
+  // https://stackoverflow.com/a/8677590
+  //grab the last script tag in the DOM
+  //this will always be the one that is currently evaluating during load
+  let tags = document.getElementsByTagName('script');
+  let tag = tags[tags.length -1];
+  //force evaluation of the contents
+  eval( tag.innerHTML );
+};

client/public/index.html

@@ -1,198 +1,11 @@
 <!DOCTYPE HTML>
 <html>
-<head>
-  <title>Try PureScript!</title>
-  <meta content="text/html;charset=utf-8" http-equiv="Content-Type">
-  <meta content="utf-8" http-equiv="encoding">
-  <meta name="viewport" content="width=device-width, initial-scale=1.0">
-
-  <link rel="icon" type="image/png" href="./img/favicon_clear-16.png" sizes="16x16">
-  <link rel="icon" type="image/png" href="./img/favicon_clear-32.png" sizes="32x32">
-  <link rel="icon" type="image/png" href="./img/favicon_clear-256.png" sizes="256x256">
-
-  <script type="text/javascript" src="//cdnjs.cloudflare.com/ajax/libs/underscore.js/1.8.3/underscore-min.js"></script>
-  <script type="text/javascript" src="//cdnjs.cloudflare.com/ajax/libs/jquery/1.12.4/jquery.js"></script>
-  <script type="text/javascript" src="//cdnjs.cloudflare.com/ajax/libs/ace/1.1.01/ace.js" charset="utf-8"></script>
-  <script type="text/javascript" src="//cdnjs.cloudflare.com/ajax/libs/ace/1.1.01/mode-haskell.js"></script>
-  <script type="text/javascript" src="//cdnjs.cloudflare.com/ajax/libs/ace/1.1.01/theme-dawn.js"></script>
-
-  <link rel="stylesheet" type="text/css" href="//fonts.googleapis.com/css?family=Roboto:300,600">
-  <link rel="stylesheet" type="text/css" href="//fonts.googleapis.com/css?family=Roboto+Slab:300,600">
-  <link rel="stylesheet" type="text/css" href="css/index.css">
-</head>
-<body>
-  <div id="wrapper">
-    <div id="body">
-      <ul id="menu">
-        <a id="home_link" class="menu-item" href="/" title="Try PureScript!">
-          <img src="img/favicon-white.svg" width="40" height="40">
-        </a><li class="menu-item menu-dropdown no-mobile">
-          <label title="Select a view mode">View Mode</label>
-          <ul id="view_mode">
-            <li>
-              <input type="radio" name="view_mode" value="sidebyside" id="view_sidebyside" checked="true">
-              <label for="view_sidebyside" title="Show the code and output side by side">Side-by-side</label>
-            </li>
-            <li>
-              <input type="radio" name="view_mode" value="code" id="view_code">
-              <label for="view_code" title="Show only the code">Code</label>
-            </li>
-            <li>
-              <input type="radio" name="view_mode" value="output" id="view_output">
-              <label for="view_output" title="Show only the output">Output</label>
-            </li>
-            <li class="view_gist_li">
-              <a class="view_gist" target="trypurs_gist">
-                <label title="Open the original gist in a new window">Gist</label>
-              </a>
-            </li>
-          </ul>
-        </li><li class="menu-item view_gist_li mobile-only">
-          <a class="view_gist" target="trypurs_gist">
-            <label title="Open the original gist in a new window">View Gist</label>
-          </a>
-          <!-- TODO: uncomment the below once https://github.com/purescript/trypurescript/issues/118 is resolved -->
-          <!-- </li><li class="menu-item no-mobile"> -->
-          <!-- <label id="gist_save" name="save_gist" title="Save file as a Gist">Share</label> -->
-        </li><li class="menu-item no-mobile">
-          <label id="compile_label" name="compile_label" title="Compile Now">Compile</label>
-        </li><li class="menu-item nowrap no-mobile">
-          <input id="auto_compile" name="auto_compile" title="Toggle auto-compliation of the file on code changes" value="auto_compile" type="checkbox" checked="true">
-          <label id="auto_compile_label" for="auto_compile" title="Compile on code changes">Auto-Compile</label>
-        </li><li class="menu-item nowrap">
-          <input id="showjs" name="showjs" title="Show resulting JavaScript code instead of output" value="showjs" type="checkbox">
-          <label id="showjs_label" for="showjs" title="Show resulting JavaScript code instead of output">Show JS</label>
-        </li><li class="menu-item">
-          <a id="helplink" href="https://github.com/purescript/trypurescript/blob/master/README.md" target="trypurs_readme">
-            <label id="help" title="Learn more about Try PureScript">Help</label>
-          </a>
-        </li>
-      </ul>
-
-      <div class="mobile-only mobile-banner">
-        Your screen size is too small. Code editing has been disabled.
-      </div>
-
-      <div id="editor_view" data-view-mode="sidebyside">
-        <div id="column1" class="no-mobile">
-
-          <div id="code">
-          </div>
-          <textarea name="code" id="code_textarea" style="display: none;"></textarea>
-        </div>
-
-        <div class="separator">
-        </div>
-
-        <div id="column2_wrapper">
-          <div id="column2"></div>
-          <div id="loading"></div>
-        </div>
-      </div>
-    </div>
-  </div>
-
-  <script type="text/javascript">
-    $.ajaxSetup({
-      dataType: 'text'
-    });
-
-    var editor, cleanupActions = [];
-
-    editor = ace.edit('code');
-
-    editor.renderer.setShowGutter(true);
-    editor.setFontSize(13);
-    editor.setShowPrintMargin(false);
-
-    var session = editor.getSession();
-
-    session.setMode('ace/mode/haskell');
-    session.setOptions({
-      tabSize: 2,
-      useSoftTabs: true
-    });
-
-    function setEditorContent(value) {
-      session.setValue(value);
-    }
-
-    function onEditorChanged(callback, millis) {
-      session.on('change', _.debounce(function() {
-        callback(session.getValue());
-      }, millis));
-    }
-
-    function cleanUpMarkers() {
-      for (var i = 0; i < cleanupActions.length; i++) {
-        cleanupActions[i]();
-      }
-
-      cleanupActions = [];
-    }
-
-    function setAnnotations(annotations) {
-      editor.session.setAnnotations(annotations);
-    }
-
-    function addMarker(type, startLine, startColumn, endLine, endColumn) {
-      if (startLine === endLine && endColumn <= startColumn) {
-        // Make sure the range is at least one character wide.
-        if (startColumn > 0) {
-          startColumn = endColumn - 1;
-        } else {
-          endColumn = startColumn + 1;
-        }
-      }
-
-      // Add an error marker
-      var range = new(ace.require("ace/range").Range)
-        (startLine - 1, startColumn - 1, endLine - 1, endColumn - 1);
-
-      var marker = editor.session.addMarker(range, type, "text", true);
-
-      cleanupActions.push((function(marker) {
-        return function() {
-          editor.session.removeMarker(marker);
-        };
-      })(marker));
-    }
-
-    function setupIFrame($ctr, data) {
-      var $iframe = $('<iframe sandbox="allow-scripts" id="output-iframe" src="frame.html">');
-
-      $ctr
-        .empty()
-        .append($iframe);
-
-      var tries = 0;
-      var sendSources = setInterval(function() {
-        // Stop after 10 seconds
-        if (tries >= 100) {
-          return clearInterval(sendSources);
-        }
-        tries++;
-        var iframe = $iframe.get(0).contentWindow;
-        if (iframe) {
-          iframe.postMessage(data, "*");
-        } else {
-          console.warn("Frame is not available");
-        }
-      }, 100);
-
-      window.addEventListener("message", function() {
-        clearInterval(sendSources);
-      }, { once: true });
-
-      window.addEventListener("message", function(event) {
-        if (event.data && event.data.gistId && /^[0-9a-f]+$/.test(event.data.gistId)) {
-          window.location.search = "gist=" + event.data.gistId;
-        }
-      });
-
-      return $iframe;
-    }
-  </script>
-  <script type="text/javascript" src="js/index.js"></script>
-</body>
+  <head>
+    <title>Try PureScript!</title>
+    <link rel="icon" type="image/svg+xml" href="/img/favicon-black.svg">
+    <link rel="alternate icon" href="/img/favicon-black.ico">
+    <script type="text/javascript" src="https://cdnjs.cloudflare.com/ajax/libs/ace/1.4.12/ace.min.js" charset="utf-8"></script>
+    <script type="text/javascript" src="https://cdnjs.cloudflare.com/ajax/libs/ace/1.4.12/mode-haskell.min.js"></script>
+    <script type="text/javascript" src="https://cdnjs.cloudflare.com/ajax/libs/lz-string/1.4.4/lz-string.min.js"></script>
+  </head>
 </html>

client/spago.dhall

@@ -4,53 +4,18 @@ You can edit this file as you like.
 -}
 { name = "try-purescript"
 , dependencies =
-  [ "arrays"
-  , "bifunctors"
+  [ "ace"
+  , "affjax"
+  , "argonaut"
+  , "argonaut-generic"
   , "console"
-  , "const"
-  , "contravariant"
-  , "control"
-  , "distributive"
   , "effect"
-  , "either"
-  , "enums"
-  , "exceptions"
-  , "exists"
-  , "foldable-traversable"
-  , "foreign"
-  , "foreign-generic"
-  , "foreign-object"
-  , "free"
-  , "functions"
-  , "functors"
-  , "generics-rep"
-  , "globals"
-  , "identity"
-  , "integers"
-  , "jquery"
-  , "js-timers"
-  , "lazy"
-  , "math"
-  , "maybe"
-  , "ordered-collections"
-  , "parallel"
-  , "prelude"
-  , "profunctor"
-  , "proxy"
+  , "halogen"
+  , "halogen-css"
+  , "halogen-hooks"
+  , "halogen-hooks-extra"
   , "psci-support"
-  , "quickcheck"
-  , "random"
-  , "refs"
-  , "semirings"
-  , "st"
-  , "strings"
-  , "tailrec"
-  , "transformers"
-  , "tuples"
-  , "typelevel-prelude"
-  , "unfoldable"
-  , "validation"
-  , "web-html"
+  , "routing"
   ]
 , packages = ./packages.dhall
 , sources = [ "src/**/*.purs" ]

client/src/LzString.js

@@ -0,0 +1,10 @@
+"use strict";
+
+exports.compressToEncodedURIComponent = function (input) {
+  return LZString.compressToEncodedURIComponent(input);
+}
+
+exports.decompressFromEncodedURIComponent = function (input) {
+  let result = LZString.decompressFromEncodedURIComponent(input);
+  return result || "Failed to decompress URI";
+}

client/src/LzString.purs

@@ -0,0 +1,5 @@
+module LzString where
+
+foreign import compressToEncodedURIComponent :: String -> String
+
+foreign import decompressFromEncodedURIComponent :: String -> String

client/src/Main.purs

@@ -1,312 +1,33 @@
 module Main where
 
 import Prelude
-
-import Control.Monad.Cont.Trans (ContT(..), runContT)
-import Control.Monad.Except.Trans (runExceptT)
-import Data.Array (mapMaybe)
-import Data.Array as Array
-import Data.Either (Either(..))
-import Data.Foldable (elem, fold, for_, intercalate, traverse_)
-import Data.FoldableWithIndex (forWithIndex_)
-import Data.Maybe (Maybe(..), fromMaybe)
 import Effect (Effect)
-import Effect.Console (error)
-import Effect.Uncurried (EffectFn1, EffectFn2, EffectFn5, mkEffectFn1, runEffectFn1, runEffectFn2, runEffectFn5)
-import Foreign (renderForeignError)
-import Foreign.Object (Object)
-import Foreign.Object as Object
-import JQuery as JQuery
-import JQuery.Extras as JQueryExtras
-import Try.API (CompileError(..), CompileResult(..), CompileWarning(..), CompilerError(..), ErrorPosition(..), FailedResult(..), SuccessResult(..))
-import Try.API as API
-import Try.Config as Config
-import Try.Gist (getGistById, tryLoadFileFromGist, uploadGist)
-import Try.Loader (Loader, makeLoader, runLoader)
-import Try.QueryString (getQueryStringMaybe, setQueryStrings)
-import Try.Session (createSessionIdIfNecessary, storeSession, tryRetrieveSession)
-import Try.Types (JS(..))
-import Web.HTML (window)
-import Web.HTML.Location (setHref)
-import Web.HTML.Window (alert, confirm, location)
-
-displayLoadingMessage :: Effect Unit
-displayLoadingMessage = JQuery.select "#loading" >>= JQueryExtras.fadeIn
-
-hideLoadingMessage :: Effect Unit
-hideLoadingMessage = JQuery.select "#loading" >>= JQueryExtras.fadeOut
-
--- | Display a list of errors in the right hand column.
-displayErrors :: Array CompilerError -> Effect Unit
-displayErrors errs = do
-  column2 <- JQuery.select "#column2"
-  JQueryExtras.empty column2
-
-  forWithIndex_ errs \i (CompilerError{ message }) -> do
-    h1 <- JQuery.create "<h1>"
-    JQuery.addClass "error-banner" h1
-    JQuery.setText ("Error " <> show (i + 1) <> " of " <> show (Array.length errs)) h1
-
-    pre <- JQuery.create "<pre>"
-    code_ <- JQuery.create "<code>"
-    JQuery.append code_ pre
-    JQuery.setText message code_
-
-    JQuery.append h1 column2
-    JQuery.append pre column2
-
--- | Display plain text in the right hand column.
-displayPlainText
-  :: String
-  -> Effect Unit
-displayPlainText s = do
-  column2 <- JQuery.select "#column2"
-  JQueryExtras.empty column2
-  pre <- JQuery.create "<pre>"
-  code_ <- JQuery.create "<code>"
-  JQuery.append code_ pre
-  JQuery.setText s code_
-  JQuery.append pre column2
-
-isShowJsChecked :: Effect Boolean
-isShowJsChecked = JQuery.select "#showjs" >>= \jq -> JQueryExtras.is jq ":checked"
-
-isAutoCompileChecked :: Effect Boolean
-isAutoCompileChecked = JQuery.select "#auto_compile" >>= \jq -> JQueryExtras.is jq ":checked"
-
--- | Update the view mode based on the menu selection
-changeViewMode :: Maybe String -> Effect Unit
-changeViewMode viewMode =
-  for_ viewMode \viewMode_ ->
-    JQuery.select "#editor_view" >>= JQuery.setAttr "data-view-mode" viewMode_
-
-getTextAreaContent :: Effect String
-getTextAreaContent = fold <$> (JQuery.select "#code_textarea" >>= JQueryExtras.getValueMaybe)
-
-setTextAreaContent :: String -> Effect Unit
-setTextAreaContent value = JQuery.select "#code_textarea" >>= JQuery.setValue value
-
--- | Set the editor content to the specified string.
-foreign import setEditorContent :: EffectFn1 String Unit
-
--- | Register a callback for editor change events.
-foreign import onEditorChanged
-  :: EffectFn2 (EffectFn1 String Unit)
-               Int
-               Unit
-
--- | Clean up any global state associated with any visible error markers.
-foreign import cleanUpMarkers :: Effect Unit
-
--- | Add a visible marker at the specified location.
-foreign import addMarker :: EffectFn5 String Int Int Int Int Unit
-
-type Annotation =
-  { row :: Int
-  , column :: Int
-  , type :: String
-  , text :: String
-  }
-
--- | Set the gutter annotations
-foreign import setAnnotations :: EffectFn1 (Array Annotation) Unit
-
-clearAnnotations :: Effect Unit
-clearAnnotations = runEffectFn1 setAnnotations []
-
--- | Set up a fresh iframe in the specified container, and use it
--- | to execute the provided JavaScript code.
-foreign import setupIFrame
-  :: EffectFn2 JQuery.JQuery
-               (Object JS)
-               Unit
-
-loader :: Loader
-loader = makeLoader Config.loaderUrl
-
--- | Compile the current code and execute it.
-compile :: Effect Unit
-compile = do
-  code <- getTextAreaContent
-
-  displayLoadingMessage
-  clearAnnotations
-
-  runContT (runExceptT (API.compile Config.compileUrl code)) \res_ ->
-    case res_ of
-      Left err -> displayPlainText err
-      Right res -> do
-        cleanUpMarkers
-
-        case res of
-          Right (CompileSuccess (SuccessResult { js, warnings })) -> do
-            showJs <- isShowJsChecked
-            if showJs
-              then do hideLoadingMessage
-                      displayPlainText js
-              else runContT (runExceptT $ runLoader loader (JS js)) \sources -> do
-                     hideLoadingMessage
-                     for_ warnings \warnings_ -> do
-                       let toAnnotation (CompileWarning{ errorCode, position, message }) =
-                             position <#> \(ErrorPosition pos) ->
-                               { row: pos.startLine - 1
-                               , column: pos.startColumn - 1
-                               , type: "warning"
-                               , text: message
-                               }
-                       runEffectFn1 setAnnotations (mapMaybe toAnnotation warnings_)
-                     for_ sources (execute (JS js))
-          Right (CompileFailed (FailedResult { error })) -> do
-            hideLoadingMessage
-            case error of
-              CompilerErrors errs -> do
-                displayErrors errs
-
-                let toAnnotation (CompilerError{ position, message }) =
-                      position <#> \(ErrorPosition pos) ->
-                        { row: pos.startLine - 1
-                        , column: pos.startColumn - 1
-                        , type: "error"
-                        , text: message
-                        }
-                runEffectFn1 setAnnotations (mapMaybe toAnnotation errs)
-
-                for_ errs \(CompilerError{ position }) ->
-                  for_ position \(ErrorPosition pos) ->
-                    runEffectFn5 addMarker
-                      "error"
-                      pos.startLine
-                      pos.startColumn
-                      pos.endLine
-                      pos.endColumn
-              OtherError err -> displayPlainText err
-          Left errs -> do
-            hideLoadingMessage
-            displayPlainText "Unable to parse the response from the server"
-            traverse_ (error <<< renderForeignError) errs
-
--- | Execute the compiled code in a new iframe.
-execute :: JS -> Object JS -> Effect Unit
-execute js modules = do
-  let eventData = Object.insert "<file>" js modules
-  column2 <- JQuery.select "#column2"
-  runEffectFn2 setupIFrame column2 eventData
-
--- | Setup the editor component and some event handlers.
-setupEditor :: forall r. { code :: String | r } -> Effect Unit
-setupEditor { code } = do
-  loadOptions
-
-  setTextAreaContent code
-  runEffectFn1 setEditorContent code
-
-  runEffectFn2 onEditorChanged (mkEffectFn1 \value -> do
-    setTextAreaContent value
-    cacheCurrentCode
-    autoCompile <- isAutoCompileChecked
-    when autoCompile do
-      compile) 750
-
-  JQuery.select "#showjs" >>= JQuery.on "change" \e _ ->
-    compile
-
-  JQuery.select "#compile_label" >>= JQuery.on "click" \e _ ->
-    compile
-
-  JQuery.select "#gist_save" >>= JQuery.on "click" \e _ ->
-    publishNewGist
-
-  compile
-  cacheCurrentCode
-
-loadFromGist
-  :: String
-  -> ({ code :: String } -> Effect Unit)
-  -> Effect Unit
-loadFromGist id_ k = do
-  runContT (runExceptT (getGistById id_ >>= \gi -> tryLoadFileFromGist gi "Main.purs")) $
-    case _ of
-      Left err -> do
-        window >>= alert err
-        k { code: "" }
-      Right code -> k { code }
-
-withSession
-  :: String
-  -> ({ code :: String } -> Effect Unit)
-  -> Effect Unit
-withSession sessionId k = do
-  state <- tryRetrieveSession sessionId
-  case state of
-    Just state' -> k state'
-    Nothing -> do
-      gist <- fromMaybe Config.mainGist <$> getQueryStringMaybe "gist"
-      loadFromGist gist k
-
--- | Cache the current code in the session state
-cacheCurrentCode :: Effect Unit
-cacheCurrentCode  = do
-  sessionId <- getQueryStringMaybe "session"
-  case sessionId of
-    Just sessionId_ -> do
-      code <- getTextAreaContent
-      storeSession sessionId_ { code }
-    Nothing -> error "No session ID"
-
--- | Create a new Gist using the current content
-publishNewGist :: Effect Unit
-publishNewGist = do
-  ok <- window >>= confirm (intercalate "\n"
-          [ "Do you really want to publish this code as an anonymous Gist?"
-          , ""
-          , "Note: this code will be available to anyone with a link to the Gist."
-          ])
-  when ok do
-    content <- getTextAreaContent
-    runContT (runExceptT (uploadGist content)) $
-      case _ of
-        Left err -> do
-          window >>= alert "Failed to create gist"
-          error ("Failed to create gist: " <> err)
-        Right gistId -> do
-          setQueryStrings (Object.singleton "gist" gistId)
-
--- | Navigate to the specified URL.
-navigateTo :: String -> Effect Unit
-navigateTo uri = void (window >>= location >>= setHref uri)
-
--- | Read query string options and update the state accordingly
-loadOptions :: Effect Unit
-loadOptions = do
-  viewMode <- getQueryStringMaybe "view"
-  case viewMode of
-    Just viewMode_
-      | viewMode_ `elem` ["sidebyside", "code", "output"]
-      -> changeViewMode viewMode
-    _ -> pure unit
-
-  showJs <- getQueryStringMaybe "js"
-  case showJs of
-    Just showJs_ ->
-      JQuery.select "input:checkbox[name=showjs]" >>= JQuery.setProp "checked" (showJs_ == "true")
-    _ -> pure unit
-
-  autoCompile <- getQueryStringMaybe "compile"
-  case autoCompile of
-    Just autoCompile_ ->
-      JQuery.select "input:checkbox[name=auto_compile]" >>= JQuery.setProp "checked" (autoCompile_ == "true")
-    _ -> pure unit
-
-  gist <- getQueryStringMaybe "gist"
-  case gist of
-    Just gist_ -> JQuery.select ".view_gist" >>= JQuery.attr { href: "https://gist.github.com/" <> gist_ }
-    Nothing -> JQuery.select ".view_gist_li" >>= JQuery.hide
+import Effect.Aff (launchAff_)
+import Effect.Class (liftEffect)
+import Effect.Class.Console (log)
+import Foreign (Foreign, unsafeToForeign)
+import Halogen as H
+import Halogen.Aff as HA
+import Halogen.VDom.Driver (runUI)
+import Routing.PushState (makeInterface, matches)
+import Try.Component (component, Query(..))
+import Try.Routing (route)
+import Web.HTML (HTMLElement)
 
 main :: Effect Unit
-main = JQuery.ready do
-  JQuery.select "input[name=view_mode]" >>= JQuery.on "change" \_ jq -> do
-    viewMode <- JQueryExtras.filter jq ":checked" >>= JQueryExtras.getValueMaybe
-    changeViewMode viewMode
-
-  runContT (do sessionId <- ContT createSessionIdIfNecessary
-               ContT (withSession sessionId)) setupEditor
+main =
+  HA.runHalogenAff do
+    (body :: HTMLElement) <- HA.awaitBody
+    (replaceState :: Foreign -> String -> Effect Unit) <-
+      liftEffect
+        $ do
+            nav <- makeInterface
+            pure nav.replaceState
+    halogenIO <- runUI component (replaceState $ unsafeToForeign {}) body
+    void
+      $ liftEffect do
+          nav <- makeInterface
+          nav
+            # matches route \oldRoute newRoute -> do
+                log $ show oldRoute <> " -> " <> show newRoute
+                launchAff_ $ halogenIO.query $ H.tell $ Nav newRoute

client/src/MyAce.js

@@ -0,0 +1,15 @@
+"use strict";
+
+// Upstream version missing inFront, which is
+// interpreted as `false` when omitted.
+exports.getMarkersImpl = function (inFront, session) {
+  return function () {
+    var markerObj = session.getMarkers(inFront);
+    var ks = Object.getOwnPropertyNames(markerObj);
+    var result = [];
+    for (var i = 0; i < ks.length; i++) {
+      result[i] = markerObj[ks[i]];
+    }
+    return result;
+  };
+};

client/src/MyAce.purs

@@ -0,0 +1,16 @@
+module MyAce where
+
+import Ace (EditSession, Marker)
+import Data.Function.Uncurried (Fn2, runFn2)
+import Effect (Effect)
+
+{-
+Fixes some issues in package.
+Todo - make PRs for these.
+-}
+-- Returns array of marker IDs
+-- Boolean to indicate front or back
+foreign import getMarkersImpl :: Fn2 Boolean EditSession (Effect (Array Marker))
+
+getMarkers :: Boolean -> EditSession -> Effect (Array Marker)
+getMarkers inFront session = runFn2 getMarkersImpl inFront session

client/src/Try/Classes.purs

@@ -0,0 +1,58 @@
+module Try.Classes where
+
+import Prelude
+import Halogen (ClassName)
+import Tailwind as T
+
+{-
+Groups of Tailwind CSS classes
+-}
+--
+data Responsiveness
+  = NonMobile
+  | MobileOnly
+  | RenderAlways
+
+nonMobileBlockClasses :: Array ClassName
+nonMobileBlockClasses = [ T.hidden, T.smBlock ]
+
+nonMobileBlock :: Responsiveness -> Array ClassName
+nonMobileBlock NonMobile = nonMobileBlockClasses
+
+nonMobileBlock _ = []
+
+commonBgClasses :: Array ClassName
+commonBgClasses =
+  [ T.bgTpsBlack
+  , T.hoverBgBlack
+  ]
+
+commonMenuClasses :: Array ClassName
+commonMenuClasses =
+  [ T.px3
+  , T.block
+  ]
+    <> commonBgClasses
+
+commonTextClasses :: Array ClassName
+commonTextClasses =
+  [ T.textWhite
+  , T.leading10
+  ]
+
+menuTextClasses :: Array ClassName
+menuTextClasses =
+  [ T.borderL
+  , T.borderSolid
+  , T.borderGray700
+  ]
+    <> commonMenuClasses
+    <> commonTextClasses
+
+dropdownItemClasses :: Array ClassName
+dropdownItemClasses =
+  [ T.block
+  , T.wFull
+  ]
+    <> commonBgClasses
+    <> commonTextClasses

client/src/Try/Common.purs

@@ -0,0 +1,61 @@
+module Try.Common where
+
+import Prelude
+
+{-
+Common values and newtype wrappers
+-}
+--
+-- Page to launch on startup and when clicking home button
+homeRoute :: String
+homeRoute = "/?github=milesfrain/tps/demo/examples/Home.purs"
+
+-- Query param for compressed code.
+pursQP :: String
+pursQP = "purs"
+
+-- Query param for gist.
+gistQP :: String
+gistQP = "gist"
+
+-- Query param for path to file on github
+ghPathQP :: String
+ghPathQP = "github"
+
+newtype AuthCode
+  = AuthCode String
+
+instance showAuthCode :: Show AuthCode where
+  show (AuthCode c) = c
+
+newtype Compressed
+  = Compressed String
+
+instance showCompressed :: Show Compressed where
+  show (Compressed c) = c
+
+newtype Content
+  = Content String
+
+instance showContent :: Show Content where
+  show (Content c) = c
+
+derive instance eqContent :: Eq Content
+
+newtype GistID
+  = GistID String
+
+instance showGistID :: Show GistID where
+  show (GistID g) = g
+
+newtype GhToken
+  = GhToken String
+
+instance showToken :: Show GhToken where
+  show (GhToken t) = t
+
+newtype GhPath
+  = GhPath String
+
+instance showGhPath :: Show GhPath where
+  show (GhPath p) = p

client/src/Try/Compile.purs

@@ -0,0 +1,182 @@
+module Try.Compile where
+
+import Prelude
+import Ace (Range)
+import Ace.Range as Range
+import Affjax as AX
+import Affjax.RequestBody as AXRB
+import Affjax.ResponseFormat as AXRF
+import Control.Alternative ((<|>))
+import Data.Argonaut (class DecodeJson, decodeJson)
+import Data.Argonaut.Core as J
+import Data.Argonaut.Decode.Generic.Rep (genericDecodeJsonWith)
+import Data.Argonaut.Types.Generic.Rep (defaultEncoding)
+import Data.Either (Either(..))
+import Data.Generic.Rep (class Generic)
+import Data.Maybe (Maybe(..))
+import Effect (Effect)
+import Effect.Aff (Aff)
+import Try.Common (Content(..))
+import Try.Config (compileUrl)
+
+------- Compile API types -------
+--
+-- The result of calling the compile API.
+data CompileResult
+  = CompileSuccess SuccessResult
+  | CompileFailed FailedResult
+
+-- A successful compilation result
+type SuccessResult
+  = { js :: String
+    , warnings :: Maybe (Array CompileWarning)
+    }
+
+-- A warning about the code found during compilation
+type CompileWarning
+  = { errorCode :: String
+    , message :: String
+    , position :: Maybe ErrorPosition
+    , suggestion :: Maybe Suggestion
+    }
+
+-- The range of text associated with an error or warning
+type ErrorPosition
+  = { startLine :: Int
+    , endLine :: Int
+    , startColumn :: Int
+    , endColumn :: Int
+    }
+
+-- A code suggestion
+type Suggestion
+  = { replacement :: String
+    , replaceRange :: Maybe ErrorPosition
+    }
+
+-- A failed compilation result
+type FailedResult
+  = { error :: CompileError }
+
+-- An error reported from the compile API
+data CompileError
+  = CompilerErrors (Array CompilerError)
+  -- Examples of `OtherError` include:
+  -- * Code is not "module Main"
+  -- * The code snippet is too large
+  | OtherError String
+
+-- An error found with the code during compilation
+type CompilerError
+  = { message :: String
+    , position :: Maybe ErrorPosition
+    }
+
+------- Json Decoding -------
+--
+-- The Compile API returns an object representing the contents of either:
+-- * CompileSuccess
+-- * CompileFailed
+-- Decoding to CompileResult requires attempting to match each of these.
+instance decodeJsonCompileResult :: DecodeJson CompileResult where
+  decodeJson j =
+    CompileSuccess <$> decodeJson j
+      <|> CompileFailed
+      <$> decodeJson j
+
+derive instance genericCompileResult :: Generic CompileResult _
+
+-- The Compile API encodes the CompileError tagged union differently than
+-- argonaut's generic options, so we need to adjust the default encoding
+-- options to successfully decode.
+instance decodeJsonCompileError :: DecodeJson CompileError where
+  decodeJson =
+    genericDecodeJsonWith
+      $ defaultEncoding
+          { valuesKey = "contents"
+          , unwrapSingleArguments = true
+          }
+
+derive instance genericCompileError :: Generic CompileError _
+
+-- | POST the specified code to the Try PureScript API, and wait for
+-- | a response.
+compile :: Content -> Aff (Either String CompileResult)
+compile (Content ct) = do
+  result <- AX.post AXRF.json (compileUrl <> "/compile") $ Just $ AXRB.string ct
+  pure
+    $ case result of
+        Left err -> Left $ "POST compile response failed to decode: " <> AX.printError err
+        Right response -> do
+          let
+            respStr = "POST /api response: " <> J.stringify response.body
+          case decodeJson response.body of
+            Left err -> Left $ "Failed to decode json response: " <> respStr <> ", Error: " <> show err
+            Right (decoded :: CompileResult) -> Right decoded
+
+------  generate errors for editor --------------
+-- Todo - move this to another file
+type Annotation
+  = { row :: Int
+    , column :: Int
+    , type :: String
+    , text :: String
+    }
+
+-- | Set the gutter annotations
+--foreign import setAnnotations :: EffectFn1 (Array Annotation) Unit
+data AnnotationType
+  = AnnotateWarning
+  | AnnotateError
+
+instance showAnnotationType :: Show AnnotationType where
+  show AnnotateWarning = "warning"
+  show AnnotateError = "error"
+
+-- Common fields of CompileWarning and CompilerError
+-- Todo - should both of these have `er` ending?
+type WarningOrError r
+  = { message :: String
+    , position :: Maybe ErrorPosition
+    | r
+    }
+
+-- Creates an annotation from a warning or error,
+-- but only if there's a position.
+toAnnotation :: forall r. AnnotationType -> WarningOrError r -> Maybe Annotation
+toAnnotation _ { position: Nothing } = Nothing
+
+toAnnotation annType { position: Just pos, message } =
+  Just
+    { row: pos.startLine - 1
+    , column: pos.startColumn - 1
+    , type: show annType
+    , text: message
+    }
+
+-- Make sure position's range is at least one character wide.
+nonZeroRange :: ErrorPosition -> ErrorPosition
+nonZeroRange p =
+  if p.startLine == p.endLine && p.endColumn <= p.startColumn then
+    if p.startColumn > 0 then
+      p { startColumn = p.endColumn - 1 }
+    else
+      p { endColumn = p.startColumn + 1 }
+  else
+    p
+
+-- Creates a Range for making Markers from a warning or error,
+-- but only if there's a position.
+mkMarkerRange :: forall r. WarningOrError r -> Effect (Maybe Range)
+mkMarkerRange { position: Nothing } = pure Nothing
+
+mkMarkerRange { position: Just p0 } = do
+  let
+    p = nonZeroRange p0
+  rg <-
+    Range.create
+      (p.startLine - 1)
+      (p.startColumn - 1)
+      (p.endLine - 1)
+      (p.endColumn - 1)
+  pure $ Just rg

client/src/Try/Loader.purs

@@ -1,17 +1,14 @@
-module Try.Loader
-  ( Loader
-  , makeLoader
-  , runLoader
-  ) where
+module Try.Loader where
 
 import Prelude
-
+import Affjax as AX
+import Affjax.ResponseFormat as AXRF
+import Try.Config (loaderUrl)
 import Control.Bind (bindFlipped)
-import Control.Monad.Cont (ContT)
-import Control.Monad.Except (ExceptT)
 import Control.Parallel (parTraverse)
 import Data.Array as Array
 import Data.Array.NonEmpty as NonEmpty
+import Data.Either (Either(..))
 import Data.Maybe (Maybe(..), fromMaybe)
 import Data.Newtype (unwrap)
 import Data.String (Pattern(..))
@@ -22,39 +19,45 @@ import Data.String.Regex.Flags (noFlags)
 import Data.String.Regex.Unsafe (unsafeRegex)
 import Data.Tuple (Tuple(..))
 import Effect (Effect)
+import Effect.Aff (Aff)
 import Effect.Class (liftEffect)
 import Effect.Ref (Ref)
 import Effect.Ref as Ref
 import Effect.Unsafe (unsafePerformEffect)
 import Foreign.Object (Object)
 import Foreign.Object as Object
-import Try.API as API
 import Try.Shim (shims)
 import Try.Types (JS(..))
 
-type Module =
-  { name :: String
-  , path :: Maybe String
-  , deps :: Array Dependency
-  , src :: JS
-  }
-
-type Dependency =
-  { name :: String
-  , path :: Maybe String
-  }
+{-
+Collects all JS modules required by compled code.
+-}
+--
+type Module
+  = { name :: String
+    , path :: Maybe String
+    , deps :: Array Dependency
+    , src :: JS
+    }
+
+type Dependency
+  = { name :: String
+    , path :: Maybe String
+    }
 
 requireRegex :: Regex
 requireRegex = unsafeRegex """^var\s+\S+\s*=\s*require\(["']([^"']*)["']\)""" noFlags
 
+-- Consider replacing these with node-path dirname and concat
 dirname :: String -> String
-dirname path = fromMaybe "" do
-  ix <- String.lastIndexOf (Pattern "/") path
-  pure $ String.take ix path
+dirname path =
+  fromMaybe "" do
+    ix <- String.lastIndexOf (Pattern "/") path
+    pure $ String.take ix path
 
 resolvePath :: String -> String -> Maybe String
 resolvePath a b
-  | String.take 2 b == "./"  = Just $ dirname a <> String.drop 1 b
+  | String.take 2 b == "./" = Just $ dirname a <> String.drop 1 b
   | String.take 3 b == "../" = Just $ dirname (dirname a) <> String.drop 2 b
   | otherwise = Nothing
 
@@ -65,23 +68,39 @@ parseDeps current = Array.mapMaybe go <<< String.split (Pattern "\n") <<< unwrap
   go line = do
     match <- Regex.match requireRegex line
     requirePath <- join $ NonEmpty.index match 1
-    pure $ case resolvePath current requirePath of
-      Just path ->
-        { name: path
-        , path: String.stripPrefix (Pattern "/") path
-        }
-      _ ->
-        { name: requirePath
-        , path: Nothing
-        }
-
-newtype Loader = Loader (JS -> ExceptT String (ContT Unit Effect) (Object JS))
-
-runLoader :: Loader -> JS -> ExceptT String (ContT Unit Effect) (Object JS)
-runLoader (Loader k) = k
-
-makeLoader :: String -> Loader
-makeLoader rootPath = Loader (go Object.empty <<< parseDeps "<file>")
+    pure
+      $ case resolvePath current requirePath of
+          Just path ->
+            { name: path
+            , path: String.stripPrefix (Pattern "/") path
+            }
+          _ ->
+            { name: requirePath
+            , path: Nothing
+            }
+
+{-
+Notes
+
+Could change error handling, but kinda nice to
+just throw the errors from JS.
+
+Assuming makeLoader runLoader pattern is to save
+cache between calls to runLoader.
+
+-}
+newtype Loader
+  = Loader (JS -> Aff (Object JS))
+
+runLoader :: Loader -> JS -> Aff (Object JS)
+runLoader (Loader k) js = do
+  -- Run loader to collect all dependencies for compiled code
+  obj <- k js
+  -- Return dependencies along with compiled code
+  pure $ Object.insert "<file>" js obj
+
+makeLoader :: Loader
+makeLoader = Loader (go Object.empty <<< parseDeps "<file>")
   where
   moduleCache :: Ref (Object Module)
   moduleCache = unsafePerformEffect (Ref.new Object.empty)
@@ -92,32 +111,51 @@ makeLoader rootPath = Loader (go Object.empty <<< parseDeps "<file>")
   getModule :: String -> Effect (Maybe Module)
   getModule a = Object.lookup a <$> Ref.read moduleCache
 
-  load :: Dependency -> ExceptT String (ContT Unit Effect) Module
+  load :: Dependency -> Aff Module
   load { name, path } = do
     cached <- liftEffect $ getModule name
     case cached of
       Just mod -> pure mod
       Nothing -> do
-        mod <-
-          case path of
-            Just path' -> do
-              srcStr <- API.get (rootPath <> "/" <> path')
-              let src = JS $ srcStr <> "\n//# sourceURL=" <> path'
-              pure { name, path, deps: parseDeps name src, src }
-            Nothing -> case Object.lookup name shims of
-              Just shim -> do
-                srcStr <- API.get shim.url
-                let
-                  src = JS $ srcStr <> "\n//# sourceURL=" <> shim.url
+        mod <- case path of
+          -- Path means dependency is another file
+          Just path' -> do
+            let
+              url = loaderUrl <> "/" <> path'
+            --log $ "get: " <> url
+            res <- AX.get AXRF.string url
+            case res of
+              Left err -> pure { name, path, deps: [], src }
+                where
+                src = throwJSError $ "Could not get file " <> url <> ", " <> AX.printError err
+              Right { body } -> do
+                --log $ "got body:\n" <> body
+                pure { name, path, deps: parseDeps name src, src }
+                where
+                src = JS $ body <> "\n//# sourceURL=" <> path'
+          -- No path means dependency is a shim
+          Nothing -> case Object.lookup name shims of
+            Just shim -> do
+              res <- AX.get AXRF.string shim.url
+              case res of
+                Left err -> pure { name, path, deps: [], src }
+                  where
+                  src = throwJSError $ "Could not get shim " <> name <> " at " <> shim.url <> ", " <> AX.printError err
+                Right { body } -> pure { name, path, deps, src }
+                  where
+                  src = JS $ body <> "\n//# sourceURL=" <> shim.url
+
                   deps = { name: _, path: Nothing } <$> shim.deps
-                pure { name, path, deps, src }
-              Nothing ->
-                pure { name, path, deps: [], src: ffiDep name }
+            Nothing -> pure { name, path, deps: [], src }
+              where
+              -- Todo - link to instructions for adding shims
+              src = throwJSError $ "FFI dependency not provided: " <> name
         liftEffect $ putModule name mod
         pure mod
 
-  go :: Object JS -> Array Dependency -> ExceptT String (ContT Unit Effect) (Object JS)
-  go ms []   = pure ms
+  go :: Object JS -> Array Dependency -> Aff (Object JS)
+  go ms [] = pure ms
+
   go ms deps = do
     modules <- parTraverse load deps
     let
@@ -131,5 +169,5 @@ makeLoader rootPath = Loader (go Object.empty <<< parseDeps "<file>")
       # Array.nubBy (comparing _.name)
       # go ms'
 
-ffiDep :: String -> JS
-ffiDep name = JS $ "throw new Error('FFI dependency not provided: " <> name <> "');"
+throwJSError :: String -> JS
+throwJSError err = JS $ "throw new Error('" <> err <> "');"

client/src/Try/Request.purs

@@ -0,0 +1,110 @@
+module Try.Request where
+
+import Prelude
+import Affjax as AX
+import Affjax.RequestBody as AXRB
+import Affjax.RequestHeader as AXRH
+import Affjax.ResponseFormat as AXRF
+import Data.Argonaut (decodeJson, encodeJson)
+import Data.Argonaut.Core as J
+import Data.Either (Either(..))
+import Data.HTTP.Method (Method(..))
+import Data.Maybe (Maybe(..))
+import Effect.Aff (Aff)
+import Try.Common (AuthCode(..), Content(..), GhToken(..), GistID(..))
+import Try.Config (tokenServerUrl)
+
+{-
+Handles HTTP requests for fetching github files and gists,
+and saving gists.
+-}
+--
+type TokenResp
+  = { access_token :: String }
+
+ghRequestToken :: AuthCode -> Aff (Either String GhToken)
+ghRequestToken (AuthCode code) = do
+  result <- AX.post AXRF.json tokenServerUrl $ Just $ AXRB.json $ encodeJson { code }
+  pure
+    $ case result of
+        Left err -> do
+          Left $ "POST /api response failed to decode: " <> AX.printError err
+        Right response -> do
+          let
+            respStr = "POST /api response: " <> J.stringify response.body
+          case decodeJson response.body of
+            Left err -> Left $ "Failed to decode json response: " <> respStr <> ", Error: " <> show err
+            Right (decoded :: TokenResp) -> Right $ GhToken decoded.access_token
+
+gistApiUrl :: String
+gistApiUrl = "https://api.github.com/gists"
+
+type GistJson
+  = { files :: { "Main.purs" :: { content :: String } }
+    }
+
+type GistJsonWithDescription
+  = { files ::
+        { "Main.purs" ::
+            { content :: String
+            , description :: String
+            }
+        }
+    }
+
+setGistContent :: Content -> GistJsonWithDescription
+setGistContent (Content content) =
+  { files:
+      { "Main.purs":
+          { content
+          , description: "Created by TryPurescript"
+          }
+      }
+  }
+
+getGistContent :: GistJson -> Content
+getGistContent obj = Content obj.files."Main.purs".content
+
+ghGetGist :: GistID -> Aff (Either String Content)
+ghGetGist (GistID gistID) = do
+  result <- AX.get AXRF.json $ gistApiUrl <> "/" <> gistID
+  pure
+    $ case result of
+        Left err -> Left $ "GET gist response failed to decode: " <> AX.printError err
+        Right response -> do
+          let
+            respStr = "POST /api response: " <> J.stringify response.body
+          case decodeJson response.body of
+            Left err -> Left $ "Failed to decode json response: " <> respStr <> ", Error: " <> show err
+            Right (decoded :: GistJson) -> Right $ getGistContent decoded
+
+getFile :: String -> Aff (Either String Content)
+getFile url = do
+  result <- AX.get AXRF.string url
+  pure
+    $ case result of
+        Left err -> Left $ "Failed to get file at: " <> url <> ", " <> AX.printError err
+        Right response -> Right $ Content response.body
+
+ghCreateGist :: GhToken -> Content -> Aff (Either String GistID)
+ghCreateGist token content = do
+  result <-
+    AX.request
+      ( AX.defaultRequest
+          { url = gistApiUrl
+          , method = Left POST
+          , responseFormat = AXRF.json
+          , headers = [ AXRH.RequestHeader "Authorization" $ "token " <> show token ]
+          , content = Just $ AXRB.json $ encodeJson $ setGistContent content
+          }
+      )
+  pure
+    $ case result of
+        Left err -> do
+          Left $ "POST /api response failed to decode: " <> AX.printError err
+        Right response -> do
+          let
+            respStr = "POST /api response: " <> J.stringify response.body
+          case decodeJson response.body of
+            Left err -> Left $ "Failed to decode json response: " <> respStr <> ", Error: " <> show err
+            Right (decoded :: { id :: String }) -> Right $ GistID decoded.id

client/src/Try/Routing.purs

@@ -0,0 +1,35 @@
+module Try.Routing where
+
+import Prelude
+import Data.Foldable (oneOf)
+import Data.Generic.Rep (class Generic)
+import Data.Generic.Rep.Show (genericShow)
+import Routing.Match (Match, end, param, root)
+import Try.Common (AuthCode(..), Compressed(..), GhPath(..), GistID(..), ghPathQP, gistQP, pursQP)
+
+{-
+Handles navigation within the single-page-app.
+-}
+--
+data Route
+  = AuthorizeCallback AuthCode Compressed
+  | LoadCompressed Compressed
+  | LoadGist GistID
+  | LoadGitHub GhPath
+  | Home
+
+derive instance genericRoute :: Generic Route _
+
+instance showRoute :: Show Route where
+  show = genericShow
+
+route :: Match Route
+route =
+  root
+    *> oneOf
+        [ AuthorizeCallback <$> (AuthCode <$> param "code") <*> (Compressed <$> param pursQP)
+        , LoadCompressed <$> Compressed <$> param pursQP
+        , LoadGist <$> GistID <$> param gistQP
+        , LoadGitHub <$> GhPath <$> param ghPathQP
+        , Home <$ end
+        ]

client/src/Try/Shim.purs

@@ -4,36 +4,42 @@ import Data.Tuple (Tuple(..))
 import Foreign.Object (Object)
 import Foreign.Object as Object
 
-type Shim =
-  { url :: String
-  , deps :: Array String
-  }
+{-
+Allows loading additional dependencies, which are required by
+some libraries.
+Feel free to add additional entries to this file.
+-}
+--
+type Shim
+  = { url :: String
+    , deps :: Array String
+    }
 
 shims :: Object Shim
-shims = Object.fromFoldable
-  [ Tuple "react"
-      { url: "https://unpkg.com/react@16.13.1/umd/react.development.js"
-      , deps: []
-      }
-  , Tuple "react-dom"
-      { url: "https://unpkg.com/react-dom@16.13.1/umd/react-dom.development.js"
-      , deps: [ "react" ]
-      }
-  , Tuple "react-dom/server"
-      { url: "https://unpkg.com/react-dom@16.13.1/umd/react-dom-server.browser.development.js"
-      , deps: [ "react" ]
-      }
-  , Tuple "big-integer"
-      { url: "https://unpkg.com/big-integer@1.6.48/BigInteger.min.js"
-      , deps: []
-      }
-  , Tuple "decimal.js"
-      { url: "https://unpkg.com/decimal.js@10.2.0/decimal.min.js"
-      , deps: []
-      }
-  , Tuple "uuid"
-      { url: "https://cdnjs.cloudflare.com/ajax/libs/uuid/8.1.0/uuid.min.js"
-      , deps: []
-      }
-  ]
-
+shims =
+  Object.fromFoldable
+    [ Tuple "react"
+        { url: "https://unpkg.com/react@16.13.1/umd/react.development.js"
+        , deps: []
+        }
+    , Tuple "react-dom"
+        { url: "https://unpkg.com/react-dom@16.13.1/umd/react-dom.development.js"
+        , deps: [ "react" ]
+        }
+    , Tuple "react-dom/server"
+        { url: "https://unpkg.com/react-dom@16.13.1/umd/react-dom-server.browser.development.js"
+        , deps: [ "react" ]
+        }
+    , Tuple "big-integer"
+        { url: "https://unpkg.com/big-integer@1.6.48/BigInteger.min.js"
+        , deps: []
+        }
+    , Tuple "decimal.js"
+        { url: "https://unpkg.com/decimal.js@10.2.0/decimal.min.js"
+        , deps: []
+        }
+    , Tuple "uuid"
+        { url: "https://cdnjs.cloudflare.com/ajax/libs/uuid/8.1.0/uuid.min.js"
+        , deps: []
+        }
+    ]

client/src/Try/Types.purs

@@ -1,12 +1,17 @@
-module Try.Types
-  ( JS(..)
-  ) where
+module Try.Types where
 
+import Data.Argonaut (class EncodeJson)
 import Data.Newtype (class Newtype)
-import Foreign.Class (class Encode)
 
-newtype JS = JS String
+{-
+Some common types.
+Just the `JS` type for now.
+-}
+--
+newtype JS
+  = JS String
 
+-- enable `unwrap`
 derive instance newtypeJS :: Newtype JS _
 
-derive newtype instance encodeJS :: Encode JS
+derive newtype instance encodeJsonJS :: EncodeJson JS

client/src/Try/Utility.purs

@@ -0,0 +1,61 @@
+module Try.Utility where
+
+import Prelude
+import Try.Common (Compressed(..), Content(..), GistID, pursQP)
+import Try.Config (appDomain, clientID)
+import Effect (Effect)
+import LzString (compressToEncodedURIComponent, decompressFromEncodedURIComponent)
+import Web.HTML (window)
+import Web.HTML.Location (setHref)
+import Web.HTML.Window (location)
+
+{-
+Helper functions that can exist outside of the main component.
+-}
+--
+data ViewMode
+  = SideBySide
+  | Code
+  | Output
+
+-- Could alternatively derive if displaying "SideBySide"(no hyphens) is okay.
+instance showViewMode :: Show ViewMode where
+  show SideBySide = "Side-by-side"
+  show Code = "Code"
+  show Output = "Output"
+
+derive instance eqViewMode :: Eq ViewMode
+
+type PushRoute
+  = String -> Effect Unit
+
+data ContentSource
+  = NewContent --NoGist
+  | SavingGist
+  | HaveGist GistID
+  | HaveGhFile String
+
+compress :: Content -> Compressed
+compress (Content c) = Compressed $ compressToEncodedURIComponent c
+
+decompress :: Compressed -> Content
+decompress (Compressed c) = Content $ decompressFromEncodedURIComponent c
+
+ghAuthorize :: Content -> Effect Unit
+ghAuthorize content = do
+  win <- window
+  loc <- location win
+  -- I believe it's fine for client ID to be public information
+  let
+    authUrl =
+      "https://github.com/login/oauth/authorize?"
+        <> "client_id="
+        <> clientID
+        <> "&scope=gist"
+        <> "&redirect_uri="
+        <> appDomain
+        <> "/?"
+        <> pursQP
+        <> "="
+        <> (show $ compress content)
+  setHref authUrl loc

client/tailwind.config.js

@@ -0,0 +1,21 @@
+// tailwind.config.js
+module.exports = {
+  purge: [
+    './public/index.js',
+  ],
+  theme: {
+    extend: {
+      colors: {
+        'tps-black': '#1d222d',
+        //'tps-button-enabled-background': '#8490a9',
+        'tps-disabled': '#ababab',
+        'tps-enabled': '#c4953a',
+        'tps-mobile-banner': '#dabf8b',
+        // mobile border same as button background
+
+      }
+    }
+  },
+  variants: {},
+  plugins: [],
+}

client/webpack.common.js

@@ -0,0 +1,44 @@
+const path = require('path');
+const HtmlWebpackPlugin = require('html-webpack-plugin');
+const { CleanWebpackPlugin } = require('clean-webpack-plugin');
+const CopyPlugin = require('copy-webpack-plugin');
+const webpack = require('webpack');
+
+module.exports = {
+  entry: {
+    "index.js": [
+     "./public/tailwind.css",
+     "./public/ace.css",
+     "./public/index.js",
+    ],
+  },
+  plugins: [
+    new CleanWebpackPlugin(),
+    new HtmlWebpackPlugin({
+      template: './public/index.html',
+    }),
+    new CopyPlugin({
+      patterns: [
+        {from: 'public/frame-load.js'},
+        {from: 'public/img', to: 'img'},
+        {from: 'public/CNAME'},
+      ],
+    }),
+  ],
+  module: {
+    rules: [
+      {
+        test: /\.css$/,
+        use: [
+          'style-loader',
+          'css-loader',
+        ],
+      },
+    ],
+  },
+  output: {
+    filename: '[name]',
+    path: path.resolve(__dirname, 'dist'),
+    publicPath: '/',
+  },
+};

client/webpack.dev.js

@@ -0,0 +1,11 @@
+const { merge } = require('webpack-merge');
+const common = require('./webpack.common.js');
+
+module.exports = merge(common, {
+  mode: 'development',
+  devtool: 'inline-source-map',
+  devServer: {
+    contentBase: false,
+  },
+});
+

client/webpack.prod.js

@@ -0,0 +1,6 @@
+const { merge } = require('webpack-merge');
+const common = require('./webpack.common.js');
+
+module.exports = merge(common, {
+  mode: 'production',
+});

examples/Home.purs

@@ -0,0 +1,62 @@
+module Main where
+
+import Prelude
+
+import Effect (Effect)
+import Data.Foldable (fold)
+import TryPureScript (h1, h2, p, text, list, indent, link, render, code)
+
+main :: Effect Unit
+main =
+    render $ fold
+      [ h1 (text "Try PureScript!")
+      , p (text "Try out the examples below, or create your own!")
+      , h2 (text "Examples")
+      , list ([thisHomepage] <> map fromExample examples)
+      , h2 (text "Share Your Code")
+      , p (text "Code can be loaded from a GitHub Gist or file. To share code, simply include the Gist ID or file path in the URL as follows:")
+      , indent (p (code (text "  try.ps.ai?gist=gist-id")))
+      , indent (p (code (text "  try.ps.ai?github=path-to-file")))
+      , p (fold
+          [ text "The Gist should contain a file named "
+          , code (text "Main.purs")
+          , text " containing your PureScript code."
+          ])
+      , p (text "The github file path option is more flexible")
+      ]
+  where
+    thisHomepage =
+      link "?github=milesfrain/tps/demo/examples/Home.purs" (text "This Homepage")
+
+    fromExample { title, gist } =
+      link ("?gist=" <> gist) (text title)
+
+    examples =
+      [ { title: "Algebraic Data Types"
+        , gist: "387999a4467a39744ece236e69a442ec"
+        }
+      , { title: "Loops"
+        , gist: "429eab1e957e807f9feeddbf4f573dd0"
+        }
+      , { title: "Operators"
+        , gist: "8395d2b421a5ca6d1056e301a6e12599"
+        }
+      , { title: "Records"
+        , gist: "170c3ca22f0141ed06a120a12b8243af"
+        }
+      , { title: "Recursion"
+        , gist: "659ae8a085f1cf6e52fed2c35ad93643"
+        }
+      , { title: "Do Notation"
+        , gist: "525cb36c147d3497f652028db1214ec8"
+        }
+      , { title: "Type Classes"
+        , gist: "b04463fd49cd4d7d385941b3b2fa226a"
+        }
+      , { title: "Generic Programming"
+        , gist: "e3b6284959f65ac674d39aa981fcb8fb"
+        }
+      , { title: "QuickCheck"
+        , gist: "69f7f94fe4ff3bd47f4b"
+        }
+      ]