Add WASM-based Ormolu Live

Co-authored-by: Mark Karpov <mark.karpov@tweag.io>

.github/workflows/ci.yml

@@ -49,3 +49,88 @@ jobs:
       - name: pre-commit-check
         run: |
           nix build -L .#pre-commit-check
+  live-wasm:
+    needs: lint
+    name: Build Ormolu WASM
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v3
+      - uses: cachix/install-nix-action@v18
+        with:
+          # https://github.com/NixOS/nix/issues/7644
+          install_url: https://releases.nixos.org/nix/nix-2.12.0/install
+          extra_nix_config: |
+            accept-flake-config = true
+      - uses: actions/cache@v3
+        with:
+          path: |
+            ~/.ghc-wasm/.cabal/store
+            ormolu-live/dist-newstyle
+          key: wasm-${{ github.run_id }}
+          restore-keys: |
+            wasm-${{ github.run_id }}
+            wasm-
+      - name: Build Ormolu WASM
+        run: |
+          cd ormolu-live
+          nix develop .#ghcWasm -c sh -c \
+            'wasm32-wasi-cabal update && ./build-wasm.sh -Oz'
+      - uses: actions/upload-artifact@v3
+        with:
+          name: wasm
+          path: ormolu-live/src/ormolu.wasm
+  live-frontend:
+    needs: lint
+    name: Build Ormolu Live frontend
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v3
+      - uses: cachix/install-nix-action@v18
+        with:
+          # https://github.com/NixOS/nix/issues/7644
+          install_url: https://releases.nixos.org/nix/nix-2.12.0/install
+          extra_nix_config: |
+            accept-flake-config = true
+      - uses: cachix/cachix-action@v12
+        with:
+          name: tweag-ormolu
+          authToken: '${{ secrets.CACHIX_TWEAG_ORMOLU_AUTH_TOKEN }}'
+      - name: Build frontend
+        run: |
+          nix build -L .#ormoluLive
+          cp -r --no-preserve=mode,ownership result/ site
+      - uses: actions/upload-artifact@v3
+        with:
+          name: frontend
+          path: site/
+  live-deploy:
+    needs: [live-wasm, live-frontend]
+    name: Deploy Ormolu Live
+    runs-on: ubuntu-latest
+    env:
+      NETLIFY_AUTH_TOKEN: ${{ secrets.NETLIFY_AUTH_TOKEN }}
+      NETLIFY_SITE_ID: ${{ secrets.NETLIFY_SITE_ID }}
+    steps:
+      - uses: actions/download-artifact@v3
+      - name: Combine
+        run: |
+          cp wasm/ormolu.wasm frontend/ormolu.*.wasm
+      - uses: geekyeggo/delete-artifact@v2
+        with:
+          name: |
+            wasm
+            frontend
+      - name: Deploy to Netlify, preview
+        if: env.NETLIFY_AUTH_TOKEN != ''
+        uses: nwtgck/actions-netlify@v2
+        with:
+          publish-dir: ./frontend
+          github-token: ${{ secrets.GITHUB_TOKEN }}
+          alias: ${{ github.event.pull_request.head.sha || github.sha }}
+          enable-pull-request-comment: true
+          enable-commit-comment: false
+          enable-commit-status: true
+      - name: Deploy to Netlify, production
+        if: env.NETLIFY_AUTH_TOKEN != '' && github.ref == 'refs/heads/master'
+        run: |
+          netlify deploy --prod -d ./frontend

.gitignore

@@ -32,3 +32,6 @@ result*
 # These are touched on every :reload in GHCi.
 # https://gitlab.haskell.org/ghc/ghc/-/issues/22669
 *.o-boot
+
+# Local Netlify folder
+.netlify

flake.nix

@@ -8,6 +8,18 @@
       inputs.nixpkgs.follows = "nixpkgs";
       inputs.flake-utils.follows = "flake-utils";
     };
+
+    # for Ormolu Live
+    ghc-wasm-meta.url = "gitlab:ghc/ghc-wasm-meta?host=gitlab.haskell.org";
+    npmlock2nix = { url = "github:nix-community/npmlock2nix"; flake = false; };
+    ps-tools = {
+      follows = "purs-nix/ps-tools";
+      inputs.nixpkgs.follows = "nixpkgs";
+    };
+    purs-nix = {
+      url = "github:purs-nix/purs-nix/ps-0.15";
+      inputs.nixpkgs.follows = "nixpkgs";
+    };
   };
   outputs = inputs@{ self, nixpkgs, flake-utils, ... }:
     flake-utils.lib.eachDefaultSystem (system:
@@ -97,13 +109,20 @@
           hooks = {
             nixpkgs-fmt.enable = true;
             deadnix.enable = true;
+            purs-tidy.enable = true;
           };
+          tools = { inherit (ormoluLive) purs-tidy; };
+        };
+
+        ormoluLive = import ./ormolu-live {
+          inherit pkgs inputs defaultGHC;
         };
       in
       {
         packages = flake-utils.lib.flattenTree {
           inherit binaries pre-commit-check;
           default = defaultGHC.ormolu;
+          ormoluLive = ormoluLive.package;
         };
         apps = {
           default = flake-utils.lib.mkApp {
@@ -135,6 +154,8 @@
             exactDeps = false;
             inherit (pre-commit-check) shellHook;
           };
+          ormoluLive = ormoluLive.shell;
+          ghcWasm = ormoluLive.ghcWasmShell;
         };
         legacyPackages = defaultGHC // perGHC;
       });

nix/format.sh

@@ -4,7 +4,8 @@ export LANG="C.UTF-8"
 
 cabal format
 (cd extract-hackage-info && cabal format)
+(cd ormolu-live && cabal format)
 
-export dirs="src app tests extract-hackage-info/src"
+export dirs="src app tests extract-hackage-info/src ormolu-live/app"
 # shellcheck disable=SC2046,SC2086
 ormolu -m inplace $(find $dirs -type f -name "*.hs" -o -name "*.hs-boot")

ormolu-live/.envrc

@@ -0,0 +1 @@
+use flake ..#ormoluLive

ormolu-live/.gitignore

@@ -0,0 +1,6 @@
+node_modules
+output/
+dist/
+site/
+.parcel-cache/
+src/ormolu.wasm

ormolu-live/README.md

@@ -1,25 +1,65 @@
 # Ormolu Live
 
-Play around with ormolu in the browser via GHCJS!
+Play around with Ormolu in the browser via the GHC WASM backend!
+
+https://ormolu-live.tweag.io
+
+## Overview
+
+ATM, the GHC WASM backend only supports emitting [WASI binaries][WASI], which can be run in the browser via e.g. [browser_wasi_shim][] or the more fully-featured [wasmer-wasi][].
+
+Hence, Ormolu Live consists of two parts:
+
+ - A regular Purescript frontend (in `src/`) that displays input/output and manages options.
+ - A background web worker (in this directory with the source in `app/Main.hs`) that formats Haskell source code via the WASM-compiled Ormolu.
 
 ## Development
 
-### Building the site with GHCJS
+Make sure to be in the `.#ormoluLive` Nix shell when entering `./ormolu-live`, e.g. conveniently via [nix-direnv][].
 
+### Local interactive development
+
+For building the WASM binary, run
+```console
+wasm32-wasi-cabal update
 ```
-nix-build -A ormoluLive.website
+and then iterate by running something like
+```console
+watchexec -w app ./build-wasm.sh
 ```
 
-### Local development with JSaddle
-
-In a `nix-shell` (or if you have cabal installed), run
-
+For the Purescript frontend, you can run
+```console
+watchexec -w src purs-nix compile
 ```
-ghcid -r -W
+and
+```console
+parcel www/index.html
 ```
+in parallel. The latter command will display the URL to a dev server, usually http://localhost:1234.
 
-and open `http://localhost:8080` in a Chromium-based browser.
+### Building the site for deployment
+
+First, build the components:
+```console
+nix build .#ormoluLive
+wasm32-wasi-cabal update
+./build-wasm.sh -Oz
+```
+Here, `-Oz` tells `wasm-opt` to aggressively optimize for code size.
+
+Then, combine the two:
+```console
+cp -r --no-preserve=mode,ownership result/ site
+cp src/ormolu.wasm site/ormolu.*.wasm
+```
+The self-contained site is now in `site`.
 
 ## Acknowledgements
 
 https://github.com/monadfix/ormolu-live
+
+[WASI]: https://wasi.dev/
+[browser_wasi_shim]: https://github.com/bjorn3/browser_wasi_shim
+[wasmer-wasi]: https://github.com/wasmerio/wasmer-js
+[nix-direnv]: https://github.com/nix-community/nix-direnv

ormolu-live/app/Main.hs

@@ -0,0 +1,118 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Main where
+
+import Control.Exception qualified as E
+import Data.Aeson qualified as A
+import Data.ByteString.Lazy qualified as BL
+import Data.ByteString.Unsafe qualified as BU
+import Data.Knob qualified as Knob
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
+import Foreign
+import Foreign.C.Types
+import GHC.Driver.Ppr (showSDocUnsafe)
+import GHC.Generics (Generic)
+import GHC.Hs.Dump qualified as Dump
+import Ormolu
+import Ormolu.Config qualified as O
+import Ormolu.Exception qualified as O
+import Ormolu.Fixity.Internal qualified as O
+import Ormolu.Parser qualified as O
+import Ormolu.Parser.Result as O
+import Ormolu.Terminal qualified as O
+import System.Environment (setEnv)
+import System.IO (IOMode (..))
+
+main :: IO ()
+main = mempty
+
+-- marshalling
+
+foreign export ccall mallocPtr :: IO (Ptr (Ptr a))
+
+mallocPtr :: IO (Ptr (Ptr a))
+mallocPtr = malloc
+
+foreign export ccall formatRaw :: Ptr CChar -> Int -> Ptr (Ptr CChar) -> IO Int
+
+formatRaw :: Ptr CChar -> Int -> Ptr (Ptr CChar) -> IO Int
+formatRaw inputPtr inputLen outputPtrPtr = do
+  Just input <-
+    A.decodeStrict' <$> BU.unsafePackMallocCStringLen (inputPtr, inputLen)
+  outputBytes <- BL.toStrict . A.encode <$> format input
+  BU.unsafeUseAsCStringLen outputBytes \(buf, len) -> do
+    outputPtr <- mallocBytes len
+    poke outputPtrPtr outputPtr
+    copyBytes outputPtr buf len
+    pure len
+
+foreign export ccall initFixityDB :: Ptr CChar -> Int -> IO ()
+
+initFixityDB :: Ptr CChar -> Int -> IO ()
+initFixityDB ptr len = do
+  let IntPtr ptr' = ptrToIntPtr ptr
+  setEnv "ORMOLU_HACKAGE_INFO" $ show (ptr', len)
+
+-- actual logic
+
+data Input = Input
+  { inputStr :: Text,
+    checkIdempotence :: Bool,
+    unsafeMode :: Bool,
+    formatBackpack :: Bool,
+    showAST :: Bool
+  }
+  deriving stock (Show, Generic)
+  deriving anyclass (A.FromJSON)
+
+data Output = Output
+  { fmtStr :: Text,
+    inputAST :: Text,
+    outputAST :: Text
+  }
+  deriving stock (Show, Generic)
+  deriving anyclass (A.ToJSON)
+
+format :: Input -> IO Output
+format Input {..} = do
+  output <-
+    (Right <$> ormolu cfg "<input>" inputStr) `E.catch` \ex -> do
+      knob <- Knob.newKnob mempty
+      Knob.withFileHandle knob "err" WriteMode $
+        O.runTerm (O.printOrmoluException ex) Never
+      Left . T.decodeUtf8 <$> Knob.getContents knob
+  inputAST <- if showAST then prettyAST cfg inputStr else pure T.empty
+  outputAST <- case output of
+    Right src' | showAST -> prettyAST cfg src'
+    _ -> pure T.empty
+  pure Output {fmtStr = either id id output, ..}
+  where
+    cfg =
+      defaultConfig
+        { cfgCheckIdempotence = checkIdempotence,
+          cfgUnsafe = unsafeMode,
+          cfgSourceType = if formatBackpack then SignatureSource else ModuleSource
+        }
+
+prettyAST :: Config RegionIndices -> Text -> IO Text
+prettyAST cfg src = do
+  (_, eSnippets) <-
+    O.parseModule cfgWithDeltas (O.LazyFixityMap []) "<input>" src
+  pure case eSnippets of
+    Left e -> T.pack $ show e
+    Right snippets -> T.unlines $ showSnippet <$> snippets
+  where
+    cfgWithDeltas = O.regionIndicesToDeltas (length (T.lines src)) <$> cfg
+    showSnippet = \case
+      O.ParsedSnippet O.ParseResult {..} ->
+        T.pack
+          . showSDocUnsafe
+          . Dump.showAstData Dump.NoBlankSrcSpan Dump.NoBlankEpAnnotations
+          $ prParsedSource
+      O.RawSnippet r -> r

ormolu-live/build-wasm.sh

@@ -0,0 +1,10 @@
+#!/usr/bin/env bash
+set -e
+wasm32-wasi-cabal build exe:ormolu-live
+wasm32-wasi-cabal list-bin exe:ormolu-live
+ORMOLU_WASM="$(wasm32-wasi-cabal list-bin exe:ormolu-live).wasm"
+if [ $# -eq 0 ]; then
+    cp "$ORMOLU_WASM" src/ormolu.wasm
+else
+    wasm-opt "$@" "$ORMOLU_WASM" -o src/ormolu.wasm
+fi

ormolu-live/cabal.project

@@ -0,0 +1,21 @@
+packages: . ..
+
+index-state:
+  , hackage.haskell.org 2023-01-13T16:50:23Z
+  , head.hackage 2022-12-25T15:05:28Z
+
+allow-newer: base, ghc-prim, transformers, unix
+
+package ormolu
+  flags: -internal-bundle-fixities
+
+-- Reasons for the fork:
+--  - Disable threaded runtime: https://github.com/digital-asset/ghc-lib/issues/184#issuecomment-1372466968
+--    Will be unnecessary starting with the next ghc-lib-parser release.
+--  - Remove build-tool-depends. Cabal does not support cross-toolchains.
+--  - Fix compile error due to GHC 9.6 change: https://gitlab.haskell.org/ghc/ghc/-/wikis/migration/9.6#type-changing-record-updates-involving-type-families
+source-repository-package
+  type: git
+  location: https://github.com/amesgen/stuff
+  tag: 7745cda8368298589fd70f34463c24dcaa6145ea
+  subdir: ghc-lib-parser-9.4.4.20221225

ormolu-live/default.nix

@@ -0,0 +1,58 @@
+{ pkgs, inputs, defaultGHC }:
+
+let
+  inherit (pkgs) system lib;
+  npmlock2nix = (pkgs.callPackage inputs.npmlock2nix { }).v2;
+  ps-tools = inputs.ps-tools.legacyPackages.${system}.for-0_15;
+  purs-nix = inputs.purs-nix { inherit system; };
+  ps = purs-nix.purs {
+    dependencies = [ "halogen" "ace" "profunctor-lenses" ];
+    dir = ./.;
+  };
+  es-opt = npmlock2nix.build {
+    src = ./.;
+    installPhase = "cp -r output-es $out";
+    buildCommands = lib.singleton ''
+      purs-backend-es build --int-tags \
+        --corefn-dir ${ps.output { codegen = "corefn"; }}
+    '';
+  };
+  metadata = builtins.toJSON {
+    inherit (inputs.self.packages.${system}.default) version;
+    inherit (inputs.self) rev;
+    ghcAPIVersion =
+      defaultGHC.dev.hsPkgs.ghc-lib-parser.components.library.version;
+  };
+  ghcWasmDeps = [
+    inputs.ghc-wasm-meta.packages.${system}.default
+    pkgs.haskellPackages.happy
+    pkgs.haskellPackages.alex
+  ];
+in
+{
+  package = npmlock2nix.build {
+    src = ./.;
+    installPhase = "cp -r dist $out";
+    buildCommands = lib.optional (inputs.self ? rev) ''
+      echo ${lib.escapeShellArg metadata} > src/meta.json
+    '' ++ lib.singleton ''
+      cp -r ${es-opt} output
+      date > src/ormolu.wasm
+      cp --remove-destination \
+        ${../extract-hackage-info/hackage-info.bin} src/hackage-info.bin
+      parcel build --no-source-maps www/index.html
+    '';
+  };
+  shell = npmlock2nix.shell {
+    src = ./.;
+    buildInputs = [
+      pkgs.nodejs
+      pkgs.watchexec
+      (ps.command { })
+      ps-tools.purs-tidy
+      ps-tools.purescript
+    ] ++ ghcWasmDeps;
+  };
+  ghcWasmShell = pkgs.mkShell { packages = [ ghcWasmDeps ]; };
+  inherit (ps-tools) purs-tidy;
+}

ormolu-live/deploy.sh

@@ -1,5 +0,0 @@
-#!/usr/bin/env bash
-set -eo pipefail
-ORMOLU_LIVE=$(nix-build -A ormoluLive.website --argstr ormoluCompiler ghc8107 -j 1)
-netlify deploy --alias=$(git log -1 --format="%H") -d $ORMOLU_LIVE
-netlify deploy --prod -d $ORMOLU_LIVE

ormolu-live/ormolu-live.cabal

@@ -1,50 +1,22 @@
-cabal-version: 2.4
+cabal-version: 3.0
 name:          ormolu-live
 version:       0.0.0.0
 maintainer:    Alexander Esgen <alexander.esgen@tweag.io>
 author:        Alexander Esgen <alexander.esgen@tweag.io>
 
 executable ormolu-live
-    main-is:            Main.hs
-    hs-source-dirs:     src
-    other-modules:      Language.Javascript.JSaddle.Warp.Extra
-    default-language:   Haskell2010
-    default-extensions:
-        BlockArguments CPP DeriveGeneric DerivingStrategies
-        FlexibleContexts LambdaCase NamedFieldPuns OverloadedLabels
-        OverloadedStrings RecordWildCards TemplateHaskell TypeApplications
-        ViewPatterns
-
+    main-is:          Main.hs
+    hs-source-dirs:   app
+    default-language: GHC2021
     ghc-options:
-        -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns
-        -fno-warn-name-shadowing -Wmissing-deriving-strategies
-        -Wunused-packages
+        -Wall -Wunused-packages -no-hs-main -optl-mexec-model=reactor
+        "-optl-Wl,--export=hs_init,--export=malloc,--export=mallocPtr,--export=free,--export=formatRaw,--export=initFixityDB"
 
-    ghcjs-options:      -dedupe
     build-depends:
         base,
-        bytestring,
-        filepath,
-        generic-lens ^>=2.2,
-        ghc-lib-parser,
-        ghc-syntax-highlighter,
-        gitrev >=1.3 && <1.4,
-        lens ^>=5.0,
-        miso ^>=1.8,
         ormolu,
-        text ^>=1.2,
-        unliftio ^>=0.2
-
-    if !impl(ghcjs >=0)
-        build-depends:
-            jsaddle ^>=0.9,
-            jsaddle-warp ^>=0.9,
-            wai-app-static ^>=3.1,
-            warp ^>=3.3,
-            websockets ^>=0.12
-
-    if !impl(ghc >=8.10 && <8.11)
-        buildable: False
-
-    if impl(ghcjs >=0)
-        ghc-options: +RTS -K0 -RTS
+        bytestring,
+        text,
+        aeson,
+        ghc-lib-parser,
+        knob

ormolu-live/package.json

@@ -0,0 +1,17 @@
+{
+  "name": "ormolu-live",
+  "version": "0.0.0",
+  "devDependencies": {
+    "@parcel/transformer-sass": "^2.8.2",
+    "buffer": "^5.7.1",
+    "npm-check-updates": "^16.6.2",
+    "parcel": "^2.8.2",
+    "purs-backend-es": "^1.3.1"
+  },
+  "dependencies": {
+    "@bjorn3/browser_wasi_shim": "^0.2.1",
+    "ace-builds": "^1.14.0",
+    "bulma": "^0.9.4",
+    "clipboard": "^2.0.11"
+  }
+}

ormolu-live/shell.nix

@@ -1 +0,0 @@
-(import ../default.nix { ormoluCompiler = "ghc8107"; }).dev.ormoluLiveShell

ormolu-live/src/Language/Javascript/JSaddle/Warp/Extra.hs

@@ -1,25 +0,0 @@
-module Language.Javascript.JSaddle.Warp.Extra (run) where
-
-#ifndef ghcjs_HOST_OS
-import qualified Data.ByteString.Lazy as B
-import Language.Javascript.JSaddle.Run (syncPoint)
-import Language.Javascript.JSaddle.Types (JSM)
-import Language.Javascript.JSaddle.WebSockets
-import qualified Network.Wai.Application.Static as WaiStatic
-import qualified Network.Wai.Handler.Warp as Warp
-import qualified Network.WebSockets as WS
-import System.FilePath ( (</>) )
-#endif
-
-#ifdef ghcjs_HOST_OS
-run :: Int -> FilePath -> IO () -> IO ()
-run _ _ = id
-#else
-run :: Int -> FilePath -> JSM () -> IO ()
-run port dir f = do
-  clipboardJs <- B.readFile (dir </> "clipboard.min.js")
-  let staticApp = WaiStatic.staticApp $ WaiStatic.defaultFileServerSettings dir
-      app = jsaddleAppWithJsOr (jsaddleJs False <> clipboardJs) staticApp
-  app <- jsaddleOr WS.defaultConnectionOptions (f *> syncPoint) app
-  Warp.runSettings (Warp.setPort port . Warp.setTimeout 3600 $ Warp.defaultSettings) app
-#endif

ormolu-live/src/Main.hs

@@ -1,272 +0,0 @@
-module Main (main) where
-
-import Control.Lens
-import Data.Bool (bool)
-import Data.Foldable (toList)
-import Data.Functor (void)
-import Data.Generics.Labels ()
-import Data.List (intersperse)
-import Data.Maybe (maybeToList)
-import Data.Text (Text)
-import qualified Data.Text as T
-import Development.GitRev
-import GHC.Driver.Ppr (showSDocUnsafe)
-import GHC.Generics (Generic)
-import qualified GHC.Hs.Dump as Dump
-import GHC.SyntaxHighlighter
-import qualified Language.Javascript.JSaddle.Warp.Extra as JSaddleWarp
-import Miso
-import Miso.String (MisoString, fromMisoString, ms)
-import qualified Ormolu as O
-import qualified Ormolu.Config as O
-import Ormolu.Fixity
-import qualified Ormolu.Parser as O
-import qualified Ormolu.Parser.Result as O
-import qualified Ormolu.Utils as O
-import System.IO.Unsafe (unsafePerformIO)
-import UnliftIO.Exception
-
-type Output = Either (Either String O.OrmoluException) Text
-
-type OrmoluConfig = O.Config O.RegionIndices
-
-data Model = Model
-  { input :: MisoString,
-    output :: Output,
-    config :: OrmoluConfig,
-    showParseResult :: Bool
-  }
-  deriving stock (Show, Eq, Generic)
-
-data Action
-  = Setup
-  | SetInput MisoString
-  | SetOutput Output
-  | Format
-  | UpdateConfig (OrmoluConfig -> OrmoluConfig)
-  | SetShowParseResult Bool
-
-main :: IO ()
-main = JSaddleWarp.run 8080 "www" $ startApp App {..}
-  where
-    initialAction = Setup
-    model = Model {..}
-      where
-        input = ""
-        output = Right ""
-        config = O.defaultConfig {O.cfgCheckIdempotence = True}
-        showParseResult = False
-    update = fromTransition . updateModel
-    view = viewModel
-    events = defaultEvents
-    subs = []
-    mountPoint = Nothing
-    logLevel = Off
-
-updateModel :: Action -> Transition Action Model ()
-updateModel = \case
-  Setup ->
-    -- Format something with an unusual operator in order to fill the
-    -- fixity map cache
-    runOrmolu "1++++++1" $ scheduleIO_ . void
-  SetInput t -> do
-    #input .= t
-    format
-  SetOutput o ->
-    #output .= o
-  Format -> do
-    input <- fromMisoString <$> use #input
-    runOrmolu input $ scheduleIO . fmap SetOutput
-  UpdateConfig f -> do
-    #config %= f
-    format
-  SetShowParseResult b ->
-    #showParseResult .= b
-  where
-    format = scheduleIO $ pure Format
-    runOrmolu input schedule = do
-      config <- use #config
-      schedule $
-        tryAnyDeep (O.ormolu config "<input>" input)
-          <&> _Left %~ extractOrmoluException
-
-viewModel :: Model -> View Action
-viewModel model@Model {..} =
-  div_
-    []
-    [ link_ [rel_ "stylesheet", href_ "bulma.min.css"],
-      link_ [rel_ "stylesheet", href_ "editor.css"],
-      script_ [] "new ClipboardJS('.copy-output');",
-      section_ [class_ "section"] . pure . div_ [class_ "container is-fluid"] $
-        [ h1_ [class_ "title"] [text "Ormolu Live"],
-          div_
-            [class_ "content"]
-            [ p_
-                []
-                [ text $ "Version " <> VERSION_ormolu <> ", commit ",
-                  a_
-                    [href_ $ "https://github.com/tweag/ormolu/commit/" <> $gitHash, target_ "blank"]
-                    [span_ [class_ "is-family-code"] [text . ms . T.take 7 $ $gitHash]],
-                  text $ ", using ghc-lib-parser " <> VERSION_ghc_lib_parser
-                ],
-              p_
-                []
-                [ a_
-                    [class_ "button is-link is-light", href_ "https://github.com/tweag/ormolu", target_ "blank"]
-                    [text "See the GitHub repository"]
-                ],
-              div_ [] . intersperse (br_ []) $
-                [ configCheckbox
-                    #cfgCheckIdempotence
-                    "Check idempotence (formatting twice is the same as formatting once)",
-                  configCheckbox
-                    #cfgUnsafe
-                    "Unsafe mode (don't ensure that formatting preserves the AST)",
-                  configCheckbox
-                    (#cfgSourceType . iso (== O.SignatureSource) (bool O.ModuleSource O.SignatureSource))
-                    "Format a Backpack signature",
-                  checkbox (^. #showParseResult) SetShowParseResult "Show internal parse result"
-                ]
-            ],
-          div_
-            [class_ "columns"]
-            [ div_
-                [class_ "column is-half is-flex"]
-                [ div_
-                    [class_ "editor"]
-                    [ div_
-                        [class_ "line-numbers"]
-                        (replicate (editorLineNumbers . fromMisoString $ input) (span_ [] [])),
-                      textarea_
-                        [class_ "is-family-code", onInput SetInput, rows_ "20", autofocus_ True]
-                        [text input]
-                    ]
-                ],
-              div_
-                [id_ "output", class_ "column is-half is-flex card is-shadowless is-radiusless"]
-                [ out,
-                  div_
-                    [class_ "card-content is-overlay"]
-                    [ button_
-                        [class_ "button copy-output", data_ "clipboard-target" "#output", styleInline_ "left:90%;margin-right:20px;"]
-                        [text "Copy"]
-                    ]
-                ]
-            ]
-        ]
-          <> [ div_
-                 [class_ "columns"]
-                 [ pre_
-                     [class_ "column is-half is-family-code"]
-                     [ text . ms . prettyAST . fromMisoString $ input
-                     ],
-                   pre_
-                     [class_ "column is-half is-family-code"]
-                     [text . ms . prettyAST . T.unpack $ m | m <- toList output]
-                 ]
-               | showParseResult
-             ]
-    ]
-  where
-    checkbox fromModel action desc =
-      label_
-        [class_ "checkbox"]
-        [ input_
-            [ type_ "checkbox",
-              checked_ $ fromModel model,
-              onChecked \(Checked c) -> action c
-            ],
-          text $ " " <> desc
-        ]
-    configCheckbox (cloneLens -> l) = checkbox (^. #config . l) \c -> UpdateConfig $ l .~ c
-
-    out = case output of
-      Right t ->
-        pre_ [class_ "is-family-code is-flex-grow-1"]
-          . maybe (pure . text . ms $ t) (tokenToHtml <$>)
-          . tokenizeHaskell
-          $ t
-      Left e ->
-        pre_
-          [class_ "is-flex-grow-1 content has-background-danger-light has-text-danger-dark"]
-          [text . ms . showOrmoluException $ e]
-    tokenToHtml (token, t) = span_ (maybeToList $ class_ <$> tokenClass token) [text $ ms t]
-    tokenClass = \case
-      KeywordTok -> Just "has-text-link"
-      PragmaTok -> Just "has-text-grey"
-      ConstructorTok -> Just "has-text-primary-dark"
-      CharTok -> Just "has-text-success"
-      StringTok -> Just "has-text-success"
-      CommentTok -> Just "has-text-grey"
-      OperatorTok -> Just "has-text-warning-dark"
-      SymbolTok -> Just "has-text-warning-dark"
-      _ -> Nothing
-
-    showOrmoluException = \case
-      Right oe ->
-        unlines case oe of
-          O.OrmoluParsingFailed s m ->
-            [ "The GHC parser failed:",
-              "",
-              O.showOutputable s,
-              "",
-              m
-            ]
-          O.OrmoluOutputParsingFailed s m ->
-            [ "Parsing of formatted code failed:",
-              "",
-              O.showOutputable s,
-              "",
-              m
-            ]
-          O.OrmoluASTDiffers _ ss ->
-            [ "AST of input and AST of formatted code differ. Please, consider reporting the bug.",
-              ""
-            ]
-              <> do O.showOutputable <$> ss
-          O.OrmoluNonIdempotentOutput _ ->
-            ["Formatting is not idempotent. Please, consider reporting the bug."]
-          O.OrmoluUnrecognizedOpts os ->
-            [ "The following GHC options were not recognized:",
-              "",
-              unwords $ toList os
-            ]
-          O.OrmoluCabalFileParsingFailed _ -> error "unreachable"
-          O.OrmoluMissingStdinInputFile -> error "unreachable"
-          O.OrmoluFixityOverridesParseError _ -> error "unreachable"
-      Left e -> e
-
-    prettyAST t = case parseModule t of
-      Left e ->
-        T.pack $ showOrmoluException e
-      Right (_, Left (srcSpan, msg)) ->
-        T.pack $ show (srcSpan, msg)
-      Right (_, Right snippets) ->
-        T.unlines . fmap printSnippet $ snippets
-      where
-        parseModule =
-          unsafePerformIO
-            . do mapped . _Left %~ extractOrmoluException
-            . tryAny
-            . O.parseModule configWithDeltas defaultFixityMap "<input>"
-        configWithDeltas = O.regionIndicesToDeltas (length (lines t)) <$> config
-
-        printSnippet = \case
-          O.ParsedSnippet O.ParseResult {..} ->
-            T.pack
-              . showSDocUnsafe
-              . Dump.showAstData Dump.NoBlankSrcSpan Dump.NoBlankEpAnnotations
-              $ prParsedSource
-          O.RawSnippet r -> r
-
-    editorLineNumbers text = 1 + T.count "\n" text
-
-extractOrmoluException :: SomeException -> Either String O.OrmoluException
-extractOrmoluException = \case
-  (fromException -> Just oe) -> Right oe
-  e -> Left . displayException $ e
-
--- | The default fixity map, using the default value for the popularity
--- ratio threshold, and an empty list of dependencies.
-defaultFixityMap :: LazyFixityMap
-defaultFixityMap = buildFixityMap defaultStrategyThreshold mempty

ormolu-live/src/Main.js

@@ -0,0 +1,24 @@
+import Clipboard from "clipboard";
+import meta from "../../src/meta.json";
+
+export const metadata = meta;
+
+export const spawnOrmoluWorker = init => onmessage => () => {
+    const worker = new Worker(
+        new URL('../../src/worker.js', import.meta.url),
+        {type: 'module'}
+    );
+    worker.onmessage = e => {
+        const r = e.data;
+        if (r === 42) {
+            init();
+        } else {
+            onmessage(JSON.parse(r))();
+        }
+    };
+    return s => () => worker.postMessage(JSON.stringify(s));
+};
+
+export const newClipboard = el => getStr => () => {
+    new Clipboard(el, { text: trigger => getStr() });
+};

ormolu-live/src/Main.purs

@@ -0,0 +1,260 @@
+module Main (main) where
+
+import Prelude
+
+import Ace as Ace
+import Ace.EditSession as AceSession
+import Ace.Editor as AceEditor
+import Ace.Selection as AceSelection
+import Control.Alternative (guard)
+import Control.Monad.Error.Class (throwError)
+import Data.Array (intersperse)
+import Data.Foldable (for_)
+import Data.Lens (cloneLens, (%~), (.~), (^.))
+import Data.Lens.Record (prop)
+import Data.Maybe (Maybe(..), isNothing, maybe)
+import Data.String as S
+import Effect (Effect)
+import Effect.Aff (Aff)
+import Effect.Class (liftEffect)
+import Effect.Exception (error)
+import Halogen as H
+import Halogen.Aff as HA
+import Halogen.HTML as HH
+import Halogen.HTML.Events as HE
+import Halogen.HTML.Properties as HP
+import Halogen.Subscription as HS
+import Halogen.VDom.Driver (runUI)
+import Type.Proxy (Proxy(..))
+import Web.DOM.ParentNode (QuerySelector(..))
+
+main :: Effect Unit
+main = HA.runHalogenAff $ runUI component unit =<< HA.awaitBody
+
+type OrmoluInput =
+  { inputStr :: String
+  , checkIdempotence :: Boolean
+  , unsafeMode :: Boolean
+  , formatBackpack :: Boolean
+  , showAST :: Boolean
+  }
+
+type OrmoluOutput =
+  { fmtStr :: String
+  , inputAST :: String
+  , outputAST :: String
+  }
+
+type State =
+  { input :: OrmoluInput
+  , output :: OrmoluOutput
+  , inputCursor :: Ace.Position
+  , inProgress :: Maybe OrmoluInput
+  , notifyWorker :: OrmoluInput -> Effect Unit
+  , inputEditor :: Maybe Ace.Editor
+  , outputEditor :: Maybe Ace.Editor
+  }
+
+data Action
+  = Initialize
+  | ModifyInput (OrmoluInput -> OrmoluInput)
+  | InputCursorChanged Ace.Position
+  | SetOutput OrmoluOutput
+  | OrmoluWorkerReady
+
+component :: forall query input output. H.Component query input output Aff
+component =
+  H.mkComponent
+    { initialState: const initialState
+    , render
+    , eval: H.mkEval H.defaultEval
+        { initialize = Just Initialize
+        , handleAction = handleAction
+        }
+    }
+  where
+  initialState :: State
+  initialState =
+    { input:
+        { inputStr: ""
+        , checkIdempotence: true
+        , unsafeMode: false
+        , formatBackpack: false
+        , showAST: false
+        }
+    , output: mempty
+    , inputCursor: Ace.Position { row: 0, column: 0 }
+    , inProgress: Nothing
+    , notifyWorker: mempty
+    , inputEditor: Nothing
+    , outputEditor: Nothing
+    }
+
+  render state =
+    HH.section [ HP.classes [ HH.ClassName "section" ] ]
+      [ HH.div [ HP.classes [ HH.ClassName "container", HH.ClassName "is-fluid" ] ] $
+          [ HH.h1 [ HP.classes [ HH.ClassName "title" ] ] [ HH.text "Ormolu Live" ]
+          , HH.div [ HP.classes [ HH.ClassName "content" ] ]
+              [ HH.p_
+                  [ HH.text $ "Version " <> metadata.version <> ", commit "
+                  , HH.a
+                      [ HP.href $ "https://github.com/tweag/ormolu/commit/" <> metadata.rev
+                      , HP.target "blank"
+                      ]
+                      [ HH.span [ HP.classes [ HH.ClassName "is-family-code" ] ]
+                          [ HH.text $ S.take 7 metadata.rev ]
+                      ]
+                  , HH.text $ ", using ghc-lib-parser " <> metadata.ghcAPIVersion
+                  ]
+              , HH.p_
+                  [ HH.a
+                      [ HP.classes [ HH.ClassName "button", HH.ClassName "is-link", HH.ClassName "is-light" ]
+                      , HP.href "https://github.com/tweag/ormolu"
+                      , HP.target "blank"
+                      ]
+                      [ HH.text "See the GitHub repository" ]
+                  ]
+              , HH.div_ $ intersperse HH.br_
+                  [ checkbox (prop (Proxy :: _ "checkIdempotence"))
+                      "Check idempotence (formatting twice is the same as formatting once)"
+                  , checkbox (prop (Proxy :: _ "unsafeMode"))
+                      "Unsafe mode (don't ensure that formatting preserves the AST)"
+                  , checkbox (prop (Proxy :: _ "formatBackpack"))
+                      "Format a Backpack signature"
+                  , checkbox (prop (Proxy :: _ "showAST"))
+                      "Show internal parse result"
+                  ]
+              ]
+          , HH.div [ HP.classes [ HH.ClassName "columns" ] ]
+              [ HH.div [ HP.classes [ HH.ClassName "column" ] ]
+                  [ HH.div [ HP.ref aceInputRef, HP.classes [ HH.ClassName "is-size-6" ] ]
+                      [ HH.text "Loading Ormolu WASM..." ]
+                  , HH.text $ "Cursor: "
+                  , let
+                      Ace.Position { row, column } = state.inputCursor
+                    in
+                      HH.span [ HP.classes [ HH.ClassName "is-family-monospace" ] ]
+                        [ HH.text $ show (row + 1) <> ":" <> show (column + 1) ]
+                  ]
+              , HH.div [ HP.classes [ HH.ClassName "column" ], HP.style "position: relative;" ]
+                  [ HH.div [ HP.ref aceOutputRef, HP.classes [ HH.ClassName "is-size-6" ] ] []
+                  , HH.button [ HP.id "copy-btn" ] [ HH.text "Copy" ]
+                  ]
+              ]
+          ] <> do
+            guard state.input.showAST
+            [ HH.div [ HP.classes [ HH.ClassName "columns" ] ]
+                [ astBox state.output.inputAST
+                , astBox state.output.outputAST
+                ]
+            ]
+      , HH.div [ HP.classes [ HH.ClassName "container", HH.ClassName "is-fluid", HH.ClassName "mt-4" ] ]
+          [ HH.div [ HP.classes [ HH.ClassName "content", HH.ClassName "has-text-centered" ] ]
+              [ HH.text
+                  """
+                  Note that this website is entirely client-side;
+                  in particular, your input is never sent to a remote server.
+                  """
+              ]
+          ]
+      ]
+    where
+    checkbox l desc = HH.label [ HP.classes [ HH.ClassName "checkbox" ] ]
+      [ HH.input
+          [ HP.type_ HP.InputCheckbox
+          , HP.checked (state ^. prop (Proxy :: _ "input") <<< cloneLens l)
+          , HE.onChecked $ ModifyInput <<< (cloneLens l .~ _)
+          ]
+      , HH.text $ " " <> desc
+      ]
+
+    astBox ast = HH.pre
+      [ HP.classes [ HH.ClassName "column", HH.ClassName "is-family-code" ] ]
+      [ HH.text ast ]
+
+  handleAction = case _ of
+    Initialize -> do
+      let
+        mkAceEditor ref = do
+          el <- maybe (throwError $ error "Missing text box.") pure
+            =<< H.getHTMLElementRef ref
+          liftEffect do
+            editor <- Ace.editNode el Ace.ace
+            AceEditor.setMinLines 25 editor
+            AceEditor.setMaxLines 50 editor
+            AceEditor.setReadOnly true editor
+            AceEditor.setShowPrintMargin false editor
+            AceEditor.setTheme "ace/theme/chrome" editor
+            session <- AceEditor.getSession editor
+            AceSession.setTabSize 2 session
+            AceSession.setUseSoftTabs true session
+            AceSession.setMode "ace/mode/haskell" session
+            pure { editor, session }
+      do
+        { emitter, listener } <- liftEffect HS.create
+        { editor, session } <- mkAceEditor aceInputRef
+        liftEffect do
+          AceEditor.setPlaceholder "Type or paste Haskell code here" editor
+          AceSession.onChange session \_ -> do
+            str <- AceSession.getValue session
+            HS.notify listener $ ModifyInput _ { inputStr = str }
+          selection <- AceEditor.getSelection editor
+          AceSelection.onChangeCursor selection $
+            HS.notify listener <<< InputCursorChanged =<< AceSelection.getCursor selection
+        _ <- H.subscribe emitter
+        H.modify_ _ { inputEditor = Just editor }
+      do
+        { editor, session } <- mkAceEditor aceOutputRef
+        liftEffect do
+          AceEditor.setHighlightActiveLine false editor
+          newClipboard (QuerySelector "#copy-btn") $ AceSession.getValue session
+        H.modify_ _ { outputEditor = Just editor }
+      do
+        { emitter, listener } <- liftEffect HS.create
+        postMessage <- liftEffect $ spawnOrmoluWorker
+          do HS.notify listener OrmoluWorkerReady
+          do HS.notify listener <<< SetOutput
+        _ <- H.subscribe emitter
+        H.modify_ _ { notifyWorker = postMessage }
+    ModifyInput f -> do
+      H.modify_ $ prop (Proxy :: _ "input") %~ f
+      format
+    InputCursorChanged pos ->
+      H.modify_ _ { inputCursor = pos }
+    SetOutput o -> do
+      { input, inProgress, outputEditor } <- H.get
+      liftEffect $ for_ outputEditor $
+        AceSession.setValue o.fmtStr <=< AceEditor.getSession
+      H.modify_ _ { output = o, inProgress = Nothing }
+      when (Just input /= inProgress) format
+    OrmoluWorkerReady -> do
+      { inputEditor } <- H.get
+      liftEffect $ for_ inputEditor \editor -> do
+        AceSession.setValue "" =<< AceEditor.getSession editor
+        AceEditor.setReadOnly false editor
+        AceEditor.focus editor
+    where
+    format = do
+      { input, inProgress, notifyWorker } <- H.get
+      when (isNothing inProgress) do
+        liftEffect $ notifyWorker input
+        H.modify_ _ { inProgress = Just input }
+
+  aceInputRef = H.RefLabel "aceInput"
+  aceOutputRef = H.RefLabel "aceOutput"
+
+type Metadata =
+  { version :: String
+  , rev :: String
+  , ghcAPIVersion :: String
+  }
+
+foreign import metadata :: Metadata
+
+foreign import spawnOrmoluWorker
+  :: Effect Unit -- init callback
+  -> (OrmoluOutput -> Effect Unit)
+  -> Effect (OrmoluInput -> Effect Unit)
+
+foreign import newClipboard
+  :: QuerySelector -> Effect String -> Effect Unit

ormolu-live/src/hackage-info.bin

@@ -0,0 +1 @@
+../../extract-hackage-info/hackage-info.bin

ormolu-live/src/meta.json

@@ -0,0 +1,5 @@
+{
+    "version": "0.0.0",
+    "rev": "aaaaaaaaaaaaaaaa",
+    "ghcAPIVersion": "0.0.0.0"
+}

ormolu-live/src/worker.js

@@ -0,0 +1,49 @@
+import { WASI } from "@bjorn3/browser_wasi_shim/src";
+import ormoluWasm from "url:./ormolu.wasm";
+import hackageInfoBin from "url:./hackage-info.bin";
+
+async function run() {
+    const wasi = new WASI([], [], []);
+    const wasiImportObj = { wasi_snapshot_preview1: wasi.wasiImport };
+    const [wasm, hackageInfoBuf] = await Promise.all([
+        WebAssembly.instantiateStreaming(fetch(ormoluWasm), wasiImportObj),
+        fetch(hackageInfoBin).then(r => r.arrayBuffer()),
+    ]);
+    wasi.inst = wasm.instance;
+    const exports = wasm.instance.exports;
+    const memory = exports.memory;
+    const encoder = new TextEncoder();
+    const decoder = new TextDecoder();
+
+    exports._initialize();
+    exports.hs_init(0, 0);
+    const hackageInfoLen = hackageInfoBuf.byteLength;
+    const hackageInfoPtr = exports.malloc(hackageInfoLen);
+    const hackageInfoArrSrc =
+          new Uint8Array(hackageInfoBuf, 0, hackageInfoLen);
+    const hackageInfoArrDst =
+          new Uint8Array(memory.buffer, hackageInfoPtr, hackageInfoLen);
+    hackageInfoArrDst.set(hackageInfoArrSrc);
+    exports.initFixityDB(hackageInfoPtr, hackageInfoLen);
+    const outputPtrPtr = exports.mallocPtr();
+    console.log("Initialized WASI reactor.");
+
+    self.onmessage = event => {
+        const input = event.data;
+        const inputLen = Buffer.byteLength(input);
+        const inputPtr = exports.malloc(inputLen);
+        const inputArr = new Uint8Array(memory.buffer, inputPtr, inputLen);
+        encoder.encodeInto(input, inputArr);
+        const outputLen = exports.formatRaw(inputPtr, inputLen, outputPtrPtr);
+        const outputPtrArr = new Uint32Array(memory.buffer, outputPtrPtr, 1);
+        const outputPtr = outputPtrArr[0];
+        const outputArr = new Uint8Array(memory.buffer, outputPtr, outputLen);
+        const output = decoder.decode(outputArr);
+        self.postMessage(output);
+        exports.free(outputPtr);
+    };
+
+    self.postMessage(42);
+}
+
+run();

ormolu-live/www/editor.css

@@ -1,38 +0,0 @@
-.editor {
-    width: 100%;
-    display: inline-flex;
-    gap: 10px;
-    font-family: monospace;
-    line-height: 21px;
-    background: #282a3a;
-    border-radius: 2px;
-    padding: 20px 10px;
-}
-
-.editor > textarea {
-    flex-grow: 1;
-    line-height: 21px;
-    font-size: 14px;
-    overflow-y: hidden;
-    padding: 0;
-    border: 0;
-    background: #282a3a;
-    color: #FFF;
-    outline: none;
-    resize: none;
-}
-
-.line-numbers {
-    width: 20px;
-    text-align: right;
-}
-
-.line-numbers span {
-    counter-increment: linenumber;
-}
-
-.line-numbers span::before {
-    content: counter(linenumber);
-    display: block;
-    color: #506882;
-}

ormolu-live/www/index.html

@@ -4,9 +4,9 @@
     <meta charset="utf-8">
     <meta name="viewport" content="width=device-width, initial-scale=1">
     <title>Ormolu Live</title>
-    <script src="clipboard.min.js"></script>
+    <link rel="stylesheet" href="index.scss"/>
   </head>
   <body>
-    <script src="all.min.js"></script>
+    <script src="index.js" type="module"></script>
   </body>
 </html>

ormolu-live/www/index.js

@@ -0,0 +1,6 @@
+require("../node_modules/ace-builds/src/ace.js");
+require("../node_modules/ace-builds/src/mode-haskell.js");
+require("../node_modules/ace-builds/src/theme-chrome.js");
+
+import { main } from "../output/Main";
+main();

ormolu-live/www/index.scss

@@ -0,0 +1,9 @@
+@use "bulma";
+
+#copy-btn {
+    @extend .button, .is-link, .is-light, .p-4;
+    position: absolute;
+    top: 0;
+    right: 0;
+    z-index: 20;
+}

src/Ormolu/Exception.hs

@@ -4,6 +4,7 @@
 -- | 'OrmoluException' type and surrounding definitions.
 module Ormolu.Exception
   ( OrmoluException (..),
+    printOrmoluException,
     withPrettyOrmoluExceptions,
   )
 where