add buildHaskellApp nix function

13 files changed, 203 insertions, 74 deletions

diff --git a/com/influencedbybooks/aero.hs b/com/influencedbybooks/aero.hs
index 92d071d..63066c5 100644
--- a/com/influencedbybooks/aero.hs
+++ b/com/influencedbybooks/aero.hs
@@ -3,11 +3,11 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 
 -- | Front-end
-module Com.InfluencedByBooks.Aero where
+module Com.Influencedbybooks.Aero where
 
 import Com.Simatime.Alpha
-import Com.InfluencedByBooks.Move (move)
-import Com.InfluencedByBooks.Core (Action(..), see, init)
+import Com.Influencedbybooks.Move (move)
+import Com.Influencedbybooks.Core (Action(..), see, init)
 import Miso (App(..), defaultEvents, miso)
 
 main :: IO ()
diff --git a/com/influencedbybooks/apex.hs b/com/influencedbybooks/apex.hs
index fd4766b..32e6403 100644
--- a/com/influencedbybooks/apex.hs
+++ b/com/influencedbybooks/apex.hs
@@ -8,25 +8,24 @@
 {-# LANGUAGE TypeOperators #-}
 
 -- | Server
-module Com.InfluencedByBooks.Apex where
+module Com.Influencedbybooks.Apex where
 
-import Com.Simatime Alpha
-import Com.InfluencedByBooks.Core
-import qualified Com.InfluencedByBooks.Keep as Keep
-import qualified Com.InfluencedByBooks.Look as Look
+import Com.Simatime.Alpha
+import Com.Influencedbybooks.Core
+import qualified Com.Influencedbybooks.Keep as Keep
+import qualified Com.Influencedbybooks.Look as Look
 import qualified Clay
 import qualified Data.Text.Lazy                as Lazy
 import qualified Data.Text.Lazy.Encoding       as Lazy
 import Data.Maybe (fromMaybe)
 import Data.Acid (AcidState)
 import qualified Data.Acid.Abstract as Acid
-import GitHash (giHash, tGitInfoCwd)
 import qualified Lucid as L
 import Lucid.Base
 import Miso
 import           Network.HTTP.Media             ((//), (/:))
 import Network.HTTP.Types
-import Network.RemoteData
+import Com.Simatime.Network
 import Network.Wai
 import Network.Wai.Application.Static
 import Network.Wai.Handler.Warp
@@ -60,10 +59,8 @@ instance L.ToHtml a => L.ToHtml (HtmlPage a) where
         cssRef "/css/main.css"
       L.body_ $ do
         page
-        L.p_ gitCommit
     where
       page = L.toHtml x
-      gitCommit = L.toHtml $ giHash $$tGitInfoCwd
       jsRef href = L.with (L.script_ mempty)
         [ makeAttribute "src" href
         , makeAttribute "type" "text/javascript"
diff --git a/com/influencedbybooks/core.hs b/com/influencedbybooks/core.hs
index 9bd2353..2a616f3 100644
--- a/com/influencedbybooks/core.hs
+++ b/com/influencedbybooks/core.hs
@@ -5,7 +5,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 -- | Main app logic
-module Com.InfluencedByBooks.Core where
+module Com.Influencedbybooks.Core where
 
 import Com.Simatime.Alpha
 import Data.Aeson hiding (Success)
diff --git a/com/influencedbybooks/default.nix b/com/influencedbybooks/default.nix
deleted file mode 100644
index f2ff1ec..0000000
--- a/com/influencedbybooks/default.nix
+++ /dev/null
@@ -1,32 +0,0 @@
-# TODO: translate this back to regular nix?
-{
-  name = "ibb";
-  deps = {
-    both = [
-      "clay"
-      "miso"
-      "protolude"
-      "servant"
-      "text"
-    ];
-    apex = [
-      "MonadRandom"
-      "acid-state"
-      "blaze-html"
-      "blaze-markup"
-      "bytestring"
-      "githash"
-      "ixset"
-      "random"
-      "safecopy"
-      "scotty"
-      "servant-server"
-      "text"
-    ];
-    aero = [
-      "aeson"
-      "containers"
-      "ghcjs-base"
-    ];
-  };
-}
diff --git a/com/influencedbybooks/influencers.hs b/com/influencedbybooks/influencers.hs
index 2583770..c0cb143 100644
--- a/com/influencedbybooks/influencers.hs
+++ b/com/influencedbybooks/influencers.hs
@@ -2,9 +2,9 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 
-module Com.InfluencedByBooks.Influencers where
+module Com.Influencedbybooks.Influencers where
 
-import Com.InfluencedByBooks.Core
+import Com.Influencedbybooks.Core
 
 allPeople :: [Person]
 allPeople =
diff --git a/com/influencedbybooks/keep.hs b/com/influencedbybooks/keep.hs
index 0bc527a..2b7ff3a 100644
--- a/com/influencedbybooks/keep.hs
+++ b/com/influencedbybooks/keep.hs
@@ -10,9 +10,9 @@
 -- `Biz.Keep`. I could wrap all the safecopy stuff in my own template haskell
 -- like `$(keep ''MyType)`.
 --
-module Com.InfluencedByBooks.Keep where
+module Com.Influencedbybooks.Keep where
 
-import Com.InfluencedByBooks.Core (Person(..), Book(..))
+import Com.Influencedbybooks.Core (Person(..), Book(..))
 import Control.Monad.State (get, put)
 import Control.Monad.Reader (ask)
 import Data.Acid (Update, makeAcidic)
@@ -24,7 +24,7 @@ import Data.SafeCopy
 import Data.Text (Text)
 import qualified Data.Text as Text
 
-import qualified Com.InfluencedByBooks.Influencers as Influencers
+import qualified Com.Influencedbybooks.Influencers as Influencers
 
 -- * Keep
 
diff --git a/com/influencedbybooks/look.hs b/com/influencedbybooks/look.hs
index d61fc11..68ae81f 100644
--- a/com/influencedbybooks/look.hs
+++ b/com/influencedbybooks/look.hs
@@ -2,7 +2,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 
 -- | The look and feel of Ibb
-module Com.InfluencedByBooks.Look  where
+module Com.Influencedbybooks.Look  where
 
 import Com.Simatime.Alpha
 import Clay
diff --git a/com/influencedbybooks/move.hs b/com/influencedbybooks/move.hs
index 2c0ee37..63af430 100644
--- a/com/influencedbybooks/move.hs
+++ b/com/influencedbybooks/move.hs
@@ -2,7 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 -- | App update logic
-module Com.InfluencedByBooks.Move (
+module Com.Influencedbybooks.Move (
     move
   -- * Server interactions
   , fetchPeople
@@ -10,7 +10,7 @@ module Com.InfluencedByBooks.Move (
 
 import Alpha
 import Data.Aeson
-import Com.InfluencedByBooks.Core as Core
+import Com.Influencedbybooks.Core as Core
 import JavaScript.Web.XMLHttpRequest (Request(..), Method(GET), RequestData(NoData), contents, xhrByteString)
 import Miso
 import Miso.String
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 )))))