Reimplement snack-exe in haskell

bin/Snack.hs

@@ -0,0 +1,206 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Main where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Aeson ((.:))
+import Data.ByteString as BS
+import Data.FileEmbed (embedStringFile)
+import Data.Semigroup
+import Data.String (fromString)
+import Data.String.Interpolate
+import Data.Text as T
+import Shelly (Sh)
+import System.Posix.Process (executeFile)
+import qualified Data.Aeson as Aeson
+import qualified Options.Applicative as Opts
+import qualified Shelly as S
+
+{-
+
+  TODO:
+    Mode
+      = HPack HPackPah
+      | Standalone SnackNix
+      | Discovery (Either HPackPath SnackNix)
+-}
+
+data Mode
+  = Standalone SnackNix -- Reads a snack.nix file
+
+-- | Like a FilePath, but Nix friendly
+newtype SnackNix = SnackNix { unSnackNix :: FilePath }
+
+mkSnackNix :: FilePath -> SnackNix
+mkSnackNix = SnackNix -- XXX: this is not nix friendly, but it's ok, because
+  -- it'll be gone soon
+
+data Command
+  = Build
+  | Run
+  | Ghci
+
+main :: IO ()
+main = do
+    opts <- Opts.execParser (Opts.info (options <**> Opts.helper) mempty)
+    runCommand (mode opts) (command opts)
+
+data Options = Options
+  { mode :: Mode
+  , command :: Command
+  }
+
+data Project = Project
+  { outPath :: FilePath
+  , exePath :: FilePath
+  }
+
+instance Aeson.FromJSON Project where
+  parseJSON = Aeson.withObject "project" $ \o ->
+    Project <$> o .: "out_path" <*> o .: "exe_path"
+
+parseMode :: Opts.Parser Mode
+parseMode =
+    Opts.flag Standalone Standalone
+      (Opts.long "--standalone")
+
+      <*> (mkSnackNix <$>
+        Opts.strOption
+        (Opts.long "--snack-nix"
+        <> Opts.short 's'
+        <> Opts.value "./snack.nix"
+        <> Opts.metavar "PATH")
+        )
+
+options :: Opts.Parser Options
+options = Options <$> parseMode <*> parseCommand
+
+snackGhci :: SnackNix -> Sh ()
+snackGhci snackNix = do
+    path <- S.print_stdout False $ exePath <$> snackBuildGhci snackNix
+    S.print_stdout True $ run_ (fromString path) []
+
+snackBuildGhci :: SnackNix -> Sh Project
+snackBuildGhci snackNix = do
+    out <- runStdin1
+      (T.pack [i|
+        { snackNix, lib64, specJson }:
+        let
+          spec = builtins.fromJSON specJson;
+          pkgs = import (builtins.fetchTarball
+            { url = "https://github.com/${spec.owner}/${spec.repo}/archive/${spec.rev}.tar.gz";
+              sha256 = spec.sha256;
+            }) {} ;
+          libDir =
+            let
+              b64 = pkgs.writeTextFile { name = "lib-b64"; text = lib64; };
+            in
+              pkgs.runCommand "snack-lib" {}
+              ''
+                cat ${b64} | base64 --decode > out.tar.gz
+                mkdir -p $out
+                tar -C $out -xzf out.tar.gz
+                chmod +w $out
+              '';
+          snack = pkgs.callPackage libDir {};
+          proj = snack.executable (import snackNix);
+        in
+          { build = proj.build;
+            ghci = proj.ghci;
+          }
+      |]
+      )
+      "nix-build"
+      [ "-"
+      , "--arg", "snackNix", T.pack $ unSnackNix snackNix
+      , "--argstr", "lib64", libb64
+      , "--argstr", "specJson", specJson
+      , "--no-out-link"
+      , "-A", "ghci.json"
+      ]
+    json <- liftIO $ BS.readFile (T.unpack out)
+    let Just proj = Aeson.decodeStrict' json
+    pure proj
+
+snackBuild :: SnackNix -> Sh Project
+snackBuild snackNix = do
+    out <- runStdin1
+      (T.pack [i|
+        { snackNix, lib64, specJson }:
+        let
+          spec = builtins.fromJSON specJson;
+          pkgs = import (builtins.fetchTarball
+            { url = "https://github.com/${spec.owner}/${spec.repo}/archive/${spec.rev}.tar.gz";
+              sha256 = spec.sha256;
+            }) {} ;
+          libDir =
+            let
+              b64 = pkgs.writeTextFile { name = "lib-b64"; text = lib64; };
+            in
+              pkgs.runCommand "snack-lib" {}
+              ''
+                cat ${b64} | base64 --decode > out.tar.gz
+                mkdir -p $out
+                tar -C $out -xzf out.tar.gz
+                chmod +w $out
+              '';
+          snack = pkgs.callPackage libDir {};
+          proj = snack.executable (import snackNix);
+        in
+          { build = proj.build;
+            ghci = proj.ghci;
+          }
+      |]
+      )
+      "nix-build"
+      [ "-"
+      , "--arg", "snackNix", T.pack $ unSnackNix snackNix
+      , "--argstr", "lib64", libb64
+      , "--argstr", "specJson", specJson
+      , "--no-out-link"
+      , "-A", "build.json"
+      ]
+    json <- liftIO $ BS.readFile (T.unpack out)
+    let Just proj = Aeson.decodeStrict' json
+    pure proj
+
+runCommand :: Mode -> Command -> IO ()
+runCommand (Standalone snackNix) = \case
+  Build -> S.shelly $ void $ snackBuild snackNix
+  Run -> snackRun snackBuild
+  Ghci -> snackRun snackBuildGhci
+  where
+    snackRun build = do
+      fp <- S.shelly $ S.print_stdout False $ exePath <$> build snackNix
+      executeFile fp True [] Nothing
+
+parseCommand :: Opts.Parser Command
+parseCommand =
+  Opts.hsubparser $
+    ( Opts.command "build" (Opts.info (pure Build) mempty)
+    <>  Opts.command "run" (Opts.info (pure Run) mempty)
+    <>  Opts.command "ghci" (Opts.info (pure Ghci) mempty)
+    )
+
+run :: S.FilePath -> [T.Text] -> Sh [T.Text]
+run p args = T.lines <$> S.run p args
+
+runStdin1 :: T.Text -> S.FilePath -> [T.Text] -> Sh T.Text
+runStdin1 stin p args = do
+    S.setStdin stin
+    [out] <- run p args
+    pure out
+
+run_ :: S.FilePath -> [T.Text] -> Sh ()
+run_ p args = void $ run p args
+
+specJson :: T.Text
+specJson = $(embedStringFile "spec.json")
+
+libb64 :: T.Text
+libb64 = $(embedStringFile "lib.tar.gz.b64")

bin/snack

@@ -1,110 +0,0 @@
-#!/usr/bin/env bash
-set -euo pipefail
-
-## Defaults
-
-NIXPKGS=
-NIX_BUILD=nix-build
-SNACK_NIX="./snack.nix"
-WRAPPER_NIX=
-COMMAND=
-
-## Functions
-
-log_error() {
-  echo "ERROR: $*" >&2
-}
-
-show_usage() {
-  cat <<USAGE
-Usage: snack [options] <command>
-
-Snack is a Haskell build tool
-
-Options:
-  -f | --snack-nix <PATH>: sets the path ot the "snack.nix" file. Default: "./snack.nix"
-  -w | --wrapper-nix <PATH>: sets the path ot the nix wrapper file. This file
-        should take at least one argument, "snackNix", which is the path to the
-        "snack.nix".
-  -n | --nixpkgs <PATH>: use the path to import nixpkgs. The expression should
-        take no arguments and evaluate to a set containing at least
-        "snack-lib".
-  -h | --help: Shows this help
-
-Commands:
-  run: builds and executes
-  build: builds
-  ghci: builds and loads in ghci
-USAGE
-}
-
-## Main
-
-while [[ $# -gt 0 ]]; do
-  key="$1"
-
-  case $key in
-    -f | --snack-nix)
-      SNACK_NIX="$2"
-      shift
-      shift
-      ;;
-    -w | --wrapper-nix)
-      WRAPPER_NIX="$2"
-      shift
-      shift
-      ;;
-    -n | --nixpkgs)
-      NIXPKGS="$2"
-      shift
-      shift
-      ;;
-    -h | --help)
-      show_usage
-      exit 0
-      ;;
-    run | build | ghci)
-      COMMAND="$1"
-      shift # past argument
-      ;;
-    *) # unknown option
-      echo "unknown option: $1"
-      exit 1
-      ;;
-  esac
-done
-
-if [[ -z "$COMMAND" ]]; then
-  log_error "missing <command>\n"
-  show_usage
-  exit 1
-fi
-
-if [[ -z "$WRAPPER_NIX" ]]; then
-  log_error "missing <wrapper>\n"
-  show_usage
-  exit 1
-fi
-
-call_snack() {
-  "$NIX_BUILD" \
-    --no-out-link \
-    -A $1 \
-    "$WRAPPER_NIX" \
-    --arg snackNix "$SNACK_NIX" \
-    --arg nixpkgs "$NIXPKGS"
-}
-
-case $COMMAND in
-  build)
-    call_snack build
-    ;;
-  ghci)
-    res=$(call_snack ghci)
-    "$res"
-    ;;
-  run)
-    res=$(call_snack build)
-    "$res/out"
-    ;;
-esac

bin/snack.nix

@@ -0,0 +1,35 @@
+{ runCommand, writeTextFile, symlinkJoin }:
+let
+  specJson = writeTextFile
+    { name = "spec-json";
+      text = builtins.readFile ../nix/nixpkgs/nixpkgs-src.json;
+      destination = "/spec.json";
+    };
+  lib64 = runCommand "lib64" {}
+    ''
+      tar -czf lib.tar.gz -C ${../snack-lib} .
+      mkdir -p $out
+      base64 lib.tar.gz > $out/lib.tar.gz.b64
+    '';
+in
+  { main = "Snack";
+    src = ./.;
+    dependencies =
+      [
+        "aeson"
+        "file-embed"
+        "interpolate"
+        "optparse-applicative"
+        "shelly"
+        "text"
+        "unix"
+      ];
+    ghcOpts = [ "-Werror" "-Wall" ] ;
+
+    extra-directories =
+      { Snack =
+          [ specJson
+            lib64
+          ];
+      };
+  }

nix/overlay.nix

@@ -1,9 +1,4 @@
-_: pkgs: {
+_: pkgs: rec {
   snack-lib = pkgs.callPackage ../snack-lib/default.nix { };
-  snack-exe = pkgs.writeScriptBin
-    "snack"
-    (builtins.replaceStrings
-      ["NIX_BUILD=nix-build"  "WRAPPER_NIX="]
-      ["NIX_BUILD=${pkgs.nix}/bin/nix-build"  "WRAPPER_NIX=${../snack-lib/wrapper.nix}"]
-      (builtins.readFile ../bin/snack));
+  snack-exe = (snack-lib.executable (import ../bin/snack.nix { inherit (pkgs) writeTextFile symlinkJoin runCommand;})).build.out;
 }

script/snack-fmt

@@ -1,4 +1,4 @@
 #!/usr/bin/env nix-shell
 #!nix-shell -p shfmt -i bash
 cd "$(dirname "$0")/.."
-shfmt -i 2 -w bin/snack
+shfmt -i 2 -w script/test

script/test

@@ -4,6 +4,7 @@
 #!nix-shell -p snack-exe
 #!nix-shell -p shfmt
 #!nix-shell -p jq
+#!nix-shell -p nix
 #!nix-shell --pure
 # vim: ft=sh sw=2 et
 
@@ -12,14 +13,14 @@ set -euo pipefail
 ## Functions
 
 banner() {
-    echo
-    echo "--- $*"
+  echo
+  echo "--- $*"
 }
 
 capture_io() {
-    OUT_FILE="$1"
+  OUT_FILE="$1"
 
-    cat <<END_HEREDOC
+  cat <<END_HEREDOC
 import GHC.IO.Handle
 import System.IO
 old_stdout <- hDuplicate stdout
@@ -34,8 +35,6 @@ END_HEREDOC
 
 export -f capture_io
 
-export SNACK="snack -n $(readlink -f ./nix)"
-
 fail() {
   echo "ERROR: $*"
   exit 1
@@ -85,9 +84,9 @@ pushd tests/extensions
 ./test
 popd
 
-banner "Test stack-exe formatting"
-list=$(shfmt -i 2 -l bin/snack)
+banner "Test this file's formatting"
+list=$(shfmt -i 2 -l script/test)
 if [[ -n "$list" ]]; then
-  fail "Please apply script/snack-fmt to format bin/snack"
+  fail "Please apply script/snack-fmt to format script/test"
 fi
 echo OK

snack-lib/default.nix

@@ -6,7 +6,7 @@
 , rsync
 , stdenv
 , symlinkJoin
-, writeScript
+, writeScriptBin
 , writeText
 , runCommand
 , callPackage
@@ -135,15 +135,22 @@ let
       ghc = ghcWith deps;
       ghcOptsArgs = lib.strings.escapeShellArgs mod.moduleGhcOpts;
       packageList = map (p: "-package ${p}") deps;
-    in runCommand "linker" {}
+      relExePath = "bin/${lib.strings.toLower mod.moduleName}";
+      drv = runCommand "linker" {}
         ''
-          mkdir -p $out
+          mkdir -p $out/bin
           ${ghc}/bin/ghc \
             ${lib.strings.escapeShellArgs packageList} \
             ${lib.strings.escapeShellArgs objList} \
             ${ghcOptsArgs} \
-            -o $out/out
+            -o $out/${relExePath}
         '';
+    in
+      {
+        out = drv;
+        relExePath = relExePath;
+      };
+
 
   # Write a new ghci executable that loads all the modules defined in the
   # module spec
@@ -182,8 +189,9 @@ let
           };
     in
       # This symlinks the extra dirs to $PWD for GHCi to work
-      writeScript "ghci-with-files"
+      writeScriptBin "ghci-with-files"
         ''
+        #!/usr/bin/env bash
         set -euo pipefail
 
         TRAPS=""
@@ -253,10 +261,23 @@ let
         in
           {
             build =
-              writeText
-                "library-build"
-                (builtins.toJSON (buildLibrary ghcWith modSpecs));
-            ghci = ghciWithModules ghcWith modSpecs;
+              # This json is a bit different than the other ones, because it's
+              # a map of modules to object files (rather than out_path +
+              # exe_path)
+              { json = writeText "build_output"
+                  (builtins.toJSON (buildLibrary ghcWith modSpecs));
+              };
+            ghci =
+              let
+                drv = ghciWithModules ghcWith modSpecs;
+                json =
+                  { out_path = "${drv.out}";
+                    exe_path = "${drv.out}/bin/ghci-with-files";
+                  };
+              in
+                { out = drv.out;
+                  json = writeText "ghci_output" (builtins.toJSON json);
+                };
           }
       else
         let
@@ -267,8 +288,29 @@ let
               modSpecs = foldDAG fld [mainModName];
             in modSpecs.${mainModName};
         in
-          { build = linkMainModule ghcWith mainModSpec;
-            ghci = ghciWithMain ghcWith mainModSpec;
+          { build =
+              let
+                drv = linkMainModule ghcWith mainModSpec;
+                json =
+                  { out_path = "${drv.out}";
+                    exe_path = "${drv.out}/${drv.relExePath}";
+                  };
+              in
+                { out = drv.out;
+                  json = writeText "build_output" (builtins.toJSON json);
+                };
+
+            ghci =
+              let
+                drv = ghciWithMain ghcWith mainModSpec;
+                json =
+                  { out_path = "${drv.out}";
+                    exe_path = "${drv.out}/bin/ghci-with-files";
+                  };
+                in
+                  { out = drv.out;
+                    json = writeText "ghci_output" (builtins.toJSON json);
+                  };
           };
 in
   {

tests/extensions/test

@@ -3,12 +3,12 @@
 
 set -euo pipefail
 
-$SNACK build
-$SNACK run | diff golden -
+snack build
+snack run | diff golden -
 
 TMP_FILE=$(mktemp)
 
-capture_io "$TMP_FILE" main | $SNACK ghci
+capture_io "$TMP_FILE" main | snack ghci
 
 diff golden $TMP_FILE
 rm $TMP_FILE

tests/library-2/test

@@ -5,11 +5,11 @@ set -euo pipefail
 
 TMP_FILE=$(mktemp)
 
-cat $($SNACK build) | jq -M 'keys' > $TMP_FILE
+cat $(snack build) | jq -M 'keys' > $TMP_FILE
 
 diff golden.jq $TMP_FILE
 
-capture_io "$TMP_FILE" main | $SNACK ghci
+capture_io "$TMP_FILE" main | snack ghci
 diff golden $TMP_FILE
 
 rm $TMP_FILE

tests/library/test

@@ -3,12 +3,12 @@
 
 set -euo pipefail
 
-$SNACK build
-$SNACK run | diff golden -
+snack build
+snack run | diff golden -
 
 TMP_FILE=$(mktemp)
 
-capture_io "$TMP_FILE" main | $SNACK ghci
+capture_io "$TMP_FILE" main | snack ghci
 
 diff golden $TMP_FILE
 rm $TMP_FILE

tests/packages/test

@@ -3,12 +3,12 @@
 
 set -euo pipefail
 
-$SNACK build
-$SNACK run | diff golden -
+snack build
+snack run | diff golden -
 
 TMP_FILE=$(mktemp)
 
-capture_io "$TMP_FILE" main | $SNACK ghci
+capture_io "$TMP_FILE" main | snack ghci
 
 diff golden $TMP_FILE
 rm $TMP_FILE

tests/template-haskell-2/test

@@ -3,12 +3,12 @@
 
 set -euo pipefail
 
-$SNACK build -f code/snack.nix
-$SNACK run -f code/snack.nix | diff golden -
+snack build -s code/snack.nix
+snack run -s code/snack.nix | diff golden -
 
 TMP_FILE=$(mktemp)
 
-capture_io "$TMP_FILE" main | $SNACK -f code/snack.nix ghci
+capture_io "$TMP_FILE" main | snack -s code/snack.nix ghci
 
 diff golden $TMP_FILE
 rm $TMP_FILE

tests/template-haskell-3/test

@@ -3,12 +3,12 @@
 
 set -euo pipefail
 
-$SNACK build
-$SNACK run | diff golden -
+snack build
+snack run | diff golden -
 
 TMP_FILE=$(mktemp)
 
-capture_io "$TMP_FILE" main | $SNACK ghci
+capture_io "$TMP_FILE" main | snack ghci
 
 diff golden $TMP_FILE
 rm $TMP_FILE

tests/template-haskell-4/test

@@ -3,12 +3,12 @@
 
 set -euo pipefail
 
-$SNACK build
-$SNACK run | diff golden -
+snack build
+snack run | diff golden -
 
 TMP_FILE=$(mktemp)
 
-capture_io "$TMP_FILE" main | $SNACK ghci
+capture_io "$TMP_FILE" main | snack ghci
 
 diff golden $TMP_FILE
 rm $TMP_FILE

tests/template-haskell/test

@@ -3,12 +3,12 @@
 
 set -euo pipefail
 
-$SNACK build
-$SNACK run | diff golden -
+snack build
+snack run | diff golden -
 
 TMP_FILE=$(mktemp)
 
-capture_io "$TMP_FILE" main | $SNACK ghci
+capture_io "$TMP_FILE" main | snack ghci
 
 diff golden $TMP_FILE
 rm $TMP_FILE