More work on jpm

Switch to rea dependency graph for a rake-like tool.
This model is more powerful for writing build scripts.

tools/cook.janet

@@ -1,6 +1,88 @@
-# Library to help build janet natives and other
+### cook.janet
-# build artifacts.
+###
-# Copyright 2019 © Calvin Rose
+### Library to help build janet natives and other
+### build artifacts.
+###
+### Copyright 2019 © Calvin Rose
+
+#
+# Rule Engine
+#
+
+(defn- getrules []
+  (def rules (dyn :rules))
+  (if rules rules (setdyn :rules @{})))
+
+(defn- gettarget [target]
+  (def item ((getrules) target))
+  (unless item (error (string "No rule for target " target)))
+  item)
+
+(defn- rule-impl
+  [target deps thunk &opt phony]
+  (put (getrules) target @[(array/slice deps) thunk phony]))
+
+(defmacro rule
+  "Add a rule to the rule graph."
+  [target deps & body]
+  ~(,rule-impl ,target ,deps (fn [] nil ,;body)))
+
+(defmacro phony
+  "Add a phony rule to the rule graph. A phony rule will run every time
+  (it is always considered out of date). Phony rules are good for defining
+  user facing tasks."
+  [target deps & body]
+  ~(,rule-impl ,target ,deps (fn [] nil ,;body) true))
+
+(defn add-dep
+  "Add a dependency to an existing rule. Useful for extending phony
+  rules or extending the dependency graph of existing rules."
+  [target dep]
+  (def [deps] (gettarget target))
+  (array/push deps dep))
+
+(defn- add-thunk
+  [target more]
+  (def item (gettarget target))
+  (def [_ thunk] item)
+  (put item 1 (fn [] (more) (thunk))))
+
+(defmacro add-body
+  "Add recipe code to an existing rule. This makes existing rules do more but
+  does not modify the dependency graph."
+  [target & body]
+  ~(,add-thunk ,target (fn [] ,;body)))
+
+(defn- needs-build
+  [dest src]
+  (let [mod-dest (os/stat dest :modified)
+        mod-src (os/stat src :modified)]
+    (< mod-dest mod-src)))
+
+(defn- needs-build-some
+  [dest sources]
+  (def f (file/open dest))
+  (if (not f) (break true))
+  (file/close f)
+  (some (partial needs-build dest) sources))
+
+(defn do-rule
+  "Evaluate a given rule."
+  [target]
+  (def item ((getrules) target))
+  (unless item
+    (if (os/stat target :mode)
+      (break target)
+      (error (string "No rule for file " target " found."))))
+  (def [deps thunk phony] item)
+  (def realdeps (seq [dep :in deps :let [x (do-rule dep)] :when x] x))
+  (when (or phony (needs-build-some target realdeps))
+    (thunk))
+  (unless phony target))
+
+#
+# Configuration
+#
 
 # Windows is the OS outlier
 (def- is-win (= (os/which) :windows))
@@ -10,57 +92,67 @@
 (def- modext (if is-win ".dll" ".so"))
 
 # Get default paths and options from environment
-(def prefix (or (os/getenv "PREFIX")
+(def PREFIX (or (os/getenv "PREFIX")
                 (if is-win "C:\\Janet" "/usr/local")))
-(def bindir (or (os/getenv "BINDIR")
+(def BINDIR (or (os/getenv "BINDIR")
-                (string prefix sep "bin")))
+                (string PREFIX sep "bin")))
-(def libdir (or (os/getenv "LIBDIR")
+(def LIBDIR (or (os/getenv "LIBDIR")
-                (string prefix sep (if is-win "Library" "lib/janet"))))
+                (string PREFIX sep (if is-win "Library" "lib/janet"))))
-(def includedir (or (os/getenv "INCLUDEDIR") module/*headerpath*))
+(def INCLUDEDIR (or (os/getenv "INCLUDEDIR")
-(def optimize (or (os/getenv "OPTIMIZE") 2))
+                    module/*headerpath*
+                    (string PREFIX sep "include" sep "janet")))
+(def OPTIMIZE (or (os/getenv "OPTIMIZE") 2))
 (def CC (or (os/getenv "CC") (if is-win "cl" "cc")))
+(def LD (or (os/getenv "LINKER") (if is-win "link" CC)))
+(def LDFLAGS (or (os/getenv "LFLAGS")
+                 (if is-win ""
+                   (string " -shared"
+                           (if is-mac " -undefined dynamic_lookup" "")))))
+(def CFLAGS (or (os/getenv "CFLAGS") (if is-win "" " -std=c99 -Wall -Wextra -fpic")))
 
-(defn artifact
+(defn- opt
-  "Add an artifact. An artifact is an item that can be installed
+  "Get an option, allowing overrides via dynamic bindings AND some
-  or otherwise depended upon after being built."
+  default value dflt if no dynamic binding is set."
-  [x]
+  [opts key dflt]
-  (let [as (dyn :artifacts)]
+  (or (opts key) (dyn key dflt)))
-    (array/push (or as (setdyn :artifacts @[])) x)))
 
-(defn- add-command
+#
-  "Add a build command."
+# OS and shell helpers
-  [cmd]
+#
-  (let [cmds (dyn :commands)]
-    (array/push (or cmds (setdyn :commands @[])) cmd)))
 
 (defn shell
   "Do a shell command"
   [& args]
-  (add-command (string ;args)))
+  (def cmd (string/join args))
+  (print cmd)
+  (def res (os/shell cmd))
+  (unless (zero? res)
+    (error (string "command exited with status " res))))
 
-(defmacro delay-build
+(defn rm
-  "Delay an express to build time."
+  "Remove a directory and all sub directories."
-  [& expr]
+  [path]
-  ~(,add-command (fn [] ,;expr)))
+  (if (= (os/stat path :mode) :directory)
+    (do
+      (each subpath (os/dir path)
+        (rm (string path sep subpath)))
+      (os/rmdir path))
+    (os/rm path)))
 
-(defn- copy
+(defn copy
-  "Copy a file from one location to another."
+  "Copy a file or directory recursively from one location to another."
   [src dest]
   (shell (if is-win "robocopy " "cp -rf ") src " " dest (if is-win " /s /e" "")))
 
-(defn- needs-build
+(defn- install-data
-  [dest src]
+  "Helper for installing file at path into dir."
-  "Check if dest is older than src. Used for checking if a file should be updated."
+  [path dir]
-  (def f (file/open dest))
+  (try (os/mkdir dir) ([err] nil))
-  (if (not f) (break true))
+  (copy path dir))
-  (file/close f)
-  (let [mod-dest (os/stat dest :modified)
-        mod-src (os/stat src :modified)]
-    (< mod-dest mod-src)))
 
-(defn- needs-build-some
+#
-  [f others]
+# C Compilation
-  (some (partial needs-build f) others))
+#
 
 (defn- embed-name
   "Rename a janet symbol for embedding."
@@ -101,10 +193,10 @@
 (defn- make-define
   "Generate strings for adding custom defines to the compiler."
   [define value]
-  (def prefix (if is-win "/D" "-D"))
+  (def pre (if is-win "/D" "-D"))
   (if value
-    (string prefix define "=" value)
+    (string pre define "=" value)
-    (string prefix define)))
+    (string pre define)))
 
 (defn- make-defines
   "Generate many defines. Takes a dictionary of defines. If a value is
@@ -112,204 +204,134 @@
   [defines]
   (seq [[d v] :pairs defines] (make-define d (if (not= v true) v))))
 
-# Defaults
+(defn- getcflags
-(def LD (if is-win
+  "Generate the c flags from the input options."
-          "link"
+  [opts]
-          (string CC
+  (string (opt opts :cflags CFLAGS)
-                  " -shared"
+          (if is-win " /I" " -I")
-                  (if is-mac " -undefined dynamic_lookup" ""))))
+          (opt opts :includedir INCLUDEDIR)
-(def CFLAGS (string
+          (if is-win " /O" " -O")
-              (if is-win "/I" "-I")
+          (opt opts :optimize OPTIMIZE)))
-              includedir
-              (if is-win " /O" " -std=c99 -Wall -Wextra -fpic -O")
-              optimize))
 
 (defn- compile-c
-  "Compile a C file into an object file. Delayed."
+  "Compile a C file into an object file."
   [opts src dest]
-  (def cc (or (opts :compiler) CC))
+  (def cc (opt opts :compiler CC))
-  (def cflags (or (opts :cflags) CFLAGS))
+  (def cflags (getcflags opts))
-  (def defines (interpose " " (make-defines (or (opts :defines) {}))))
+  (def defines (interpose " " (make-defines (opt opts :defines {}))))
-  (if (needs-build dest src)
+  (rule dest [src]
-    (if is-win
+        (if is-win
-      (shell cc " " ;defines " /nologo /c " cflags " /Fo" dest " " src)
+          (shell cc " " ;defines " /nologo /c " cflags " /Fo" dest " " src)
-      (shell cc " -c " src " " ;defines " " cflags " -o " dest))))
+          (shell cc " -c " src " " ;defines " " cflags " -o " dest))))
 
 (defn- link-c
-  "Link a number of object files together. Delayed."
+  "Link a number of object files together."
   [opts target & objects]
-  (def ld (or (opts :linker) LD))
+  (def ld (opt opts :linker LD))
-  (def cflags (or (opts :cflags) CFLAGS))
+  (def cflags (getcflags opts))
-  (def lflags (or (opts :lflags) ""))
+  (def lflags (opt opts :lflags LDFLAGS))
   (def olist (string/join objects " "))
-  (if (needs-build-some target objects)
+  (rule target objects
-    (if is-win
+        (if is-win
-      (shell ld " /DLL /OUT:" target " " olist " %JANET_PATH%\\janet.lib")
+          (shell ld " " lflags " /DLL /OUT:" target " " olist " %JANET_PATH%\\janet.lib")
-      (shell ld " " cflags " -o " target " " olist " " lflags))))
+          (shell ld " " cflags " -o " target " " olist " " lflags))))
 
 (defn- create-buffer-c
-  "Inline raw byte file as a c file. Immediate."
+  "Inline raw byte file as a c file."
   [source dest name]
-  (when (needs-build dest source)
+  (rule dest [source]
-    (def f (file/open source :r))
+        (def f (file/open source :r))
-    (if (not f) (error (string "file " f " not found")))
+        (if (not f) (error (string "file " f " not found")))
-    (def out (file/open dest :w))
+        (def out (file/open dest :w))
-    (def chunks (seq [b :in (file/read f :all)] (string b)))
+        (def chunks (seq [b :in (file/read f :all)] (string b)))
-    (file/write out
+        (file/write out
-                "#include <janet.h>\n"
+                    "#include <janet.h>\n"
-                "static const unsigned char bytes[] = {"
+                    "static const unsigned char bytes[] = {"
-                ;(interpose ", " chunks)
+                    ;(interpose ", " chunks)
-                "};\n\n"
+                    "};\n\n"
-                "const unsigned char *" name "_embed = bytes;\n"
+                    "const unsigned char *" name "_embed = bytes;\n"
-                "size_t " name "_embed_size = sizeof(bytes);\n")
+                    "size_t " name "_embed_size = sizeof(bytes);\n")
-    (file/close out)
+        (file/close out)
-    (file/close f)))
+        (file/close f)))
 
-# Installation Helpers
+#
-
+# Declaring Artifacts - used in project.janet, targets specifically
-(defn- prep-install
+# tailored for janet.
-  [dir]
+#
-  (try (os/mkdir dir) ([err] nil)))
-
-(defn- install-janet-module
-  "Install a janet source module."
-  [name]
-  (prep-install libdir)
-  (copy name libdir))
-
-(defn- install-native-module
-  "Install a native module."
-  [name]
-  (prep-install libdir)
-  (copy name libdir))
-
-(defn- install-binscript
-  "Install a binscript."
-  [name]
-  (prep-install bindir)
-  (copy name bindir))
-
-# Declaring Artifacts - used in project.janet
 
 (defn declare-native
   "Build a native binary. This is a shared library that can be loaded
   dynamically by a janet runtime."
-  [& opts]
+  [&keys opts]
-  (def opt-table (table ;opts))
+  (def sources (opts :source))
-  (def sources (opt-table :source))
+  (def name (opts :name))
-  (def name (opt-table :name))
   (def lname (lib-name name))
-  (artifact [lname :native opt-table])
   (loop [src :in sources]
-    (compile-c opt-table src (object-name src)))
+    (compile-c opts src (object-name src)))
   (def objects (map object-name sources))
-  (when-let [embedded (opt-table :embedded)]
+  (when-let [embedded (opts :embedded)]
             (loop [src :in embedded]
               (def c-src (embed-c-name src))
               (def o-src (embed-o-name src))
               (array/push objects o-src)
-              (delay-build (create-buffer-c src c-src (embed-name src)))
+              (create-buffer-c src c-src (embed-name src))
-              (compile-c opt-table c-src o-src)))
+              (compile-c opts c-src o-src)))
-  (link-c opt-table lname ;objects))
+  (link-c opts lname ;objects)
+  (add-dep "build" lname)
+  (def libdir (opt opts :libdir LIBDIR))
+  (add-body "install" (install-data lname LIBDIR))
+  lname)
 
 (defn declare-source
   "Create a Janet modules. This does not actually build the module(s),
   but registers it for packaging and installation."
-  [& opts]
+  [&keys opts]
-  (def opt-table (table ;opts))
+  (def sources (opts :source))
-  (def sources (opt-table :source))
+  (def libdir (opt opts :libdir LIBDIR))
   (each s sources
-    (artifact [s :janet opt-table])))
+    (add-body "install" (install-data s libdir))))
 
 (defn declare-binscript
   "Declare a janet file to be installed as an executable script."
-  [& opts]
+  [&keys opts]
-  (def opt-table (table ;opts))
+  (def main (opts :main))
-  (def main (opt-table :main))
+  (def bindir (opt opts :bindir BINDIR))
-  (artifact [main :binscript opt-table]))
+  (add-body "install" (install-data main bindir))
+  main)
 
 (defn declare-archive
   "Build a janet archive. This is a file that bundles together many janet
   scripts into a janet image. This file can the be moved to any machine with
   a janet vm and the required dependencies and run there."
-  [& opts]
+  [&keys opts]
-  (def opt-table (table ;opts))
+  (def entry (opts :entry))
-  (def entry (opt-table :entry))
+  (def name (opts :name))
-  (def name (opt-table :name))
   (def iname (string "build" sep name ".jimage"))
-  (artifact [iname :image opt-table])
+  (rule iname (or (opts :deps) [])
-  (delay-build (spit iname (make-image (require entry)))))
+        (spit iname (make-image (require entry))))
+  (def libdir (opt opts :libdir LIBDIR))
+  (add-body "install" (install-data iname libdir))
+  iname)
 
 (defn declare-project
-  "Define your project metadata."
+  "Define your project metadata. This should
+  be the first declaration in a project.janet file.
+  Also sets up basic phony targets like clean, build, test, etc."
   [&keys meta]
-  (setdyn :project meta))
+  (setdyn :project meta)
-
+  (try (os/mkdir "build") ([err] nil))
-# Tool usage - called from tool
+  (phony "build" [] (print "Built."))
-
+  (phony "install" ["build"] (print "Installed."))
-(defn- rm
+  (phony "clean" [] (rm "build") (print "Deleted build directory."))
-  "Remove a directory and all sub directories."
+  (phony "test" ["build"]
-  [path]
+         (defn dodir
-  (if (= (os/stat path :mode) :directory)
+           [dir]
-    (do
+           (each sub (os/dir dir)
-      (each subpath (os/dir path)
+             (def ndir (string dir sep sub))
-        (rm (string path sep subpath)))
+             (case (os/stat ndir :mode)
-      (os/rmdir path))
+               :file (when (string/has-suffix? ".janet" ndir)
-    (os/rm path)))
+                       (print "running " ndir " ...")
-
+                       (dofile ndir :exit true))
-(defn- flush-commands
+               :directory (dodir ndir))))
-  "Run all pending commands."
+         (dodir "test")
-  []
+         (print "All tests passed.")))
-  (os/mkdir "build")
-  (when-let [cmds (dyn :commands)]
-            (each cmd cmds
-              (if (bytes? cmd)
-                (do
-                  (print cmd)
-                  (def res (os/shell cmd))
-                  (unless (zero? res)
-                    (error (string "command exited with status " res))))
-                (cmd)))
-            (setdyn :commands @[])))
-
-(defn clean
-  "Remove all built artifacts."
-  []
-  (print "cleaning...")
-  (rm "build"))
-
-(defn build
-  "Build all artifacts."
-  []
-  (print "building...")
-  (flush-commands))
-
-(defn install
-  "Install all artifacts."
-  []
-  (flush-commands)
-  (print "installing...")
-  (each [name kind opts] (dyn :artifacts ())
-    (case kind
-      :janet (install-janet-module name)
-      :image (install-janet-module name)
-      :native (install-native-module name)
-      :binscript (install-binscript name)))
-  (flush-commands))
-
-(defn test
-  "Run all tests. This means executing janet files in the test directory."
-  []
-  (flush-commands)
-  (print "testing...")
-  (defn dodir
-    [dir]
-    (each sub (os/dir dir)
-      (def ndir (string dir sep sub))
-      (case (os/stat ndir :mode)
-        :file (when (string/has-suffix? ".janet" ndir)
-                (print "running " ndir " ...")
-                (dofile ndir :exit true))
-        :directory (dodir ndir))))
-  (dodir "test")
-  (print "All tests passed."))

tools/jpm

@@ -1,29 +1,40 @@
 #!/usr/bin/env janet
 
-# Cook CLI tool for building janet projects.
+# CLI tool for building janet projects. Wraps cook.
 
 (import cook :prefix "")
 
-(defn- load
+(dofile "./project.janet" :env (fiber/getenv (fiber/current)))
-  []
-  (dofile "./project.janet" :env (fiber/getenv (fiber/current))))
 
-# Flag handlers
+(def- argpeg
-(case (process/args 2)
+  (peg/compile
-  "install" (do (load) (install))
+    '(* "--" '(some (if-not "=" 1)) "=" '(any 1))))
-  "build" (do (load) (build))
+
-  "clean" (clean)
+(defn- help
-  "test" (do (load) (test))
+  []
-  (do
+  (print "usage: jpm [targets]... --key=value ...")
-    (def x (process/args 2))
+  (print "Available targets are:")
-      (if (not= x "help") (print "unknown command: " x))
+  (each k (sort (keys (dyn :rules @{})))
-      (print "usage: jpm [command]")
+    (print "  " k))
-      (print
+  (print `
-        `
+
-  Commands are:
+Keys are:
-  help : Show this help
+  --prefix : The prefix to install to. Defaults to $PREFIX or /usr/local
-  install : Install all artifacts 
+  --libdir : The directory to install. Defaults to $LIBDIR or $prefix/lib/janet
-  test : Run all tests
+  --includedir : The directory containing janet headers. Defaults to $INCLUDEDIR or module/*headerpath*.
-  build : Build all artifacts
+  --bindir : The directory to install binaries and scripts. Defaults to $BINDIR or $prefix/bin
-  clean : Remove all artifacts
+  --optimize : Optimization level for natives. Defaults to $OPTIMIZE or 2.
-        `)))
+  --compiler : C compiler to use for natives. Defaults to $CC or cc.
+  --linker : C linker to use for linking natives. Defaults to $LINKER or cc.
+  --cflags : Extra compiler flags for native modules. Defaults to $CFLAGS if set.
+  --lflags : Extra linker flags for native modules. Defaults to $LFLAGS if set.
+    `))
+
+(def args (tuple/slice process/args 2))
+(each arg args
+  (if (string/has-prefix? "--" arg)
+    (let [[key value] (peg/match argpeg arg)]
+      (setdyn (keyword key) value))
+    (do-rule arg)))
+
+(if (empty? args) (help))