From 9756eb0806aef63137ed53c7f78eee13aa3db9d7 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Fri, 1 Nov 2019 14:24:24 -0700
Subject: add buildHaskellApp nix function

---
 com/simatime/bild.scm            | 24 ++----------
 com/simatime/buildHaskellApp.nix | 79 ++++++++++++++++++++++++++++++++++++++++
 com/simatime/caplinks.scm        | 45 +++++++++++++++++++++++
 com/simatime/shell.scm           | 34 +++++++++++++++++
 com/simatime/string.scm          | 24 ++++++++++++
 5 files changed, 185 insertions(+), 21 deletions(-)
 create mode 100644 com/simatime/buildHaskellApp.nix
 create mode 100755 com/simatime/caplinks.scm
 create mode 100644 com/simatime/shell.scm
 create mode 100644 com/simatime/string.scm

(limited to 'com/simatime')

diff --git a/com/simatime/bild.scm b/com/simatime/bild.scm
index 604a545..44f6c74 100755
--- a/com/simatime/bild.scm
+++ b/com/simatime/bild.scm
@@ -122,6 +122,9 @@ exec guile -e "(@ (com simatime bild) main)" -s "$0" "$@"
 (define-module (com simatime bild)
   #:use-module ((ice-9 popen) #:prefix popen/)
   #:use-module ((ice-9 format) #:select (format))
+  #:use-module ((ice-9 rdelim) #:prefix rdelim/)
+  #:use-module ((com simatime shell) #:prefix sh/)
+  #:use-module ((com simatime string) #:prefix string/)
   #:export (ns?
             ns->path
             path->ns
@@ -156,24 +159,3 @@ exec guile -e "(@ (com simatime bild) main)" -s "$0" "$@"
      ((symbol? path) (to-ns (symbol->string path)))
      ((string? path) (to-ns path))
      (else (error "path should be a string or symbol")))))
-
-
-;;
-;; general funs, to be moved to a core lib
-;;
-
-(define (string/replace s match replacement)
-  (string-fold
-   (lambda (a b)
-     (let ((next-char (if (eq? a match)
-                          replacement
-                          a)))
-       (string-concatenate (list b (string next-char)))))
-   ""
-   s))
-
-(define (sh/exec cmd)
-  (let* ((port (popen/open-input-pipe cmd))
-         (ret (read port)))
-    (popen/close-pipe port)
-    ret))
diff --git a/com/simatime/buildHaskellApp.nix b/com/simatime/buildHaskellApp.nix
new file mode 100644
index 0000000..d9cb211
--- /dev/null
+++ b/com/simatime/buildHaskellApp.nix
@@ -0,0 +1,79 @@
+/*
+
+A function for building a Haskell Miso app.
+
+*/
+
+nixpkgs:
+
+{
+  # the namespace. We can't figure this out with Nix code, but when we port to
+  # guix/scheme we should be able to
+  name
+, apex # compiled with ghc
+, aero # compiled with ghcjs
+  # deps get passed to GHC
+, deps
+
+}:
+
+with nixpkgs;
+
+let
+  nsToPath = ns:
+    builtins.toString (builtins.replaceStrings ["."] ["/"] ns);
+
+  depsToPackageSet = packageSet: deps:
+    map (s: builtins.getAttr s packageSet) deps;
+
+  ghc844_ = pkgs.haskell.packages.ghc844.override (oldAttrs: {
+    overrides = with pkgs.haskell.lib; self: super: {
+      clay = dontCheck super.clay;
+    };
+  });
+
+  ghc = ghc844_.ghcWithPackages (hp: depsToPackageSet hp
+    (deps.both ++ deps.apex));
+
+  ghcjs_ = pkgs.haskell.packages.ghcjs.override (oldAttrs: {
+    overrides = with pkgs.haskell.lib; self: super: {
+      clay = dontCheck super.clay;
+      http-types = dontCheck super.http-types;
+      tasty-quickcheck = dontCheck super.tasty-quickcheck;
+      scientific = dontCheck super.scientific; # takes forever
+      servant = dontCheck super.servant;
+      comonad = dontCheck super.comonad;
+      QuickCheck = dontCheck super.QuickCheck;
+    };
+  });
+
+  ghcjs = ghcjs_.ghcWithPackages (hp:
+    depsToPackageSet hp (deps.both ++ deps.aero));
+
+in stdenv.mkDerivation {
+  name = name;
+  version = "0";
+  src = ../../.; # this is the git root
+  nativeBuildInputs = [
+    ghc ghcjs guile bash
+  ];
+  strictDeps = true;
+  buildPhase = ''
+    echo ":: build"
+    . .envrc
+    guile -e '(com simatime caplinks)' -s ./com/simatime/caplinks.scm .
+    mkdir -p _bild/${nsToPath apex}
+    mkdir -p _bild/${nsToPath aero}
+    ${ghc}/bin/ghc -i. --make ${nsToPath apex}.hs -main-is ${apex} \
+        -o _bild/${nsToPath apex}
+    ${ghcjs}/bin/ghcjs -i. --make ${nsToPath aero}.hs -main-is ${aero} \
+        -o _bild/${nsToPath aero}
+  '';
+  installPhase = ''
+    echo ":: install"
+    mkdir -p $out
+    pwd && ls -al .
+    cp -r ./${nsToPath apex}* $out/${apex}
+    cp -r ./${nsToPath aero}* $out/${aero}
+  '';
+}
diff --git a/com/simatime/caplinks.scm b/com/simatime/caplinks.scm
new file mode 100755
index 0000000..21f0b88
--- /dev/null
+++ b/com/simatime/caplinks.scm
@@ -0,0 +1,45 @@
+
+(define-module (com simatime caplinks)
+  #:use-module ((ice-9 popen) #:prefix popen/)
+  #:use-module ((com simatime string) #:prefix string/)
+  #:use-module ((com simatime shell) #:prefix sh/)
+  #:export (main get-all-nodes make-symlink))
+
+;; given a root directory, walk the tree and get a list of all the files. Then,
+;; for each file, symlink a capitalized version
+(define (main args)
+  (let* ((root (cadr args))
+         (files (get-all-nodes root)))
+    (for-each (lambda (file)
+                (display file)
+                (move-file file (capitalize-file file)))
+              files)
+    (display root) (newline)
+    (display "done moving files") (newline)
+    (newline)))
+
+(define (get-all-nodes root)
+  (filter (lambda (s) (not (equal? "" s)))
+          (string-split (sh/stream
+                         (format #f "find ~a -name '*.hs*'" root))
+                        #\newline)))
+
+(define (capitalize-file file)
+  (string-join (map string/capitalize (string-split file #\/))
+               "/"))
+
+(define (butlast ls)
+  (let ((len (length ls)))
+    (list-head ls (- len 1))))
+
+(define (dir-for f)
+  (string-join
+   (butlast (string-split f #\/))
+   "/"))
+
+(define (move-file here there)
+  (display (format #f "~a -> ~a" here there))
+  (newline)
+  ;; make the directory tree for the link, if it doesn't already exist
+  (system (format #f "mkdir -p ~a" (dir-for there)))
+  (system (format #f "mv ~a ~a" here there)))
diff --git a/com/simatime/shell.scm b/com/simatime/shell.scm
new file mode 100644
index 0000000..7c6bb5c
--- /dev/null
+++ b/com/simatime/shell.scm
@@ -0,0 +1,34 @@
+(define-module (com simatime shell)
+  #:use-module ((ice-9 popen) #:prefix popen/)
+  #:use-module ((ice-9 rdelim) #:prefix rdelim/)
+  #:use-module ((ice-9 ftw) #:prefix ftw/)
+  #:export (exec
+            stream
+            pwd
+            ls
+            cd))
+
+(define (exec cmd)
+  (let* ((port (popen/open-input-pipe cmd))
+         (ret (read port)))
+    (popen/close-pipe port)
+    ret))
+
+(define (stream cmd)
+  (let* ((port (popen/open-input-pipe cmd))
+         (_ (setvbuf port 'none))
+         (ret (rdelim/read-string port)))
+    (flush-all-ports)
+    (popen/close-pipe port)
+    ret))
+
+(define (pwd)
+  (regexp-substitute/global
+   #f "/home/ben" (getcwd) 'pre "~" 'post))
+
+(define (ls)
+  (ftw/scandir (getcwd)))
+
+(define (cd path)
+  (chdir path)
+  (ls))
diff --git a/com/simatime/string.scm b/com/simatime/string.scm
new file mode 100644
index 0000000..01c5a70
--- /dev/null
+++ b/com/simatime/string.scm
@@ -0,0 +1,24 @@
+(define-module (com simatime string)
+  #:export (replace to-string str capitalize))
+
+(define (replace s match repl)
+  (let ((f (lambda (a b)
+             (let ((next-char (if (eq? a match) repl a)))
+               (string-concatenate (list b (string next-char)))))))
+    (string-fold f "" s)))
+
+(define (to-string x)
+  (format #f "~a" x))
+
+(define str
+  (case-lambda
+    (() "")
+    ((x) (to-string x))
+    ((x . rest) (string-concatenate (map str (cons x rest))))))
+
+(define (capitalize s)
+  (let ((s (to-string s)))
+    (if (< (string-length s) 2)
+        (string-upcase s)
+        (str (string-upcase (substring s 0 1))
+             (substring s 1 )))))
-- 
cgit v1.2.3