janet/jpm

#!/usr/bin/env janet

# CLI tool for building janet projects.

#
# Basic Path Settings
#

# Windows is the OS outlier
(def- is-win (= (os/which) :windows))
(def- is-mac (= (os/which) :macos))
(def- sep (if is-win "\\" "/"))
(def- objext (if is-win ".obj" ".o"))
(def- modext (if is-win ".dll" ".so"))
(def- statext (if is-win ".static.lib" ".a"))
(def- absprefix (if is-win "C:\\" "/"))

#
# Defaults
#

###START###

# Overriden on some installs.
(def- exe-dir
  "Directory containing jpm script"
  (do
    (def exe (dyn :current-file))
    (def i (last (string/find-all sep exe)))
    (slice exe 0 i)))

(defn- install-paths []
  {:headerpath (os/realpath (string exe-dir "/../include/janet"))
   :libpath (os/realpath (string exe-dir "/../lib"))
   :binpath exe-dir})

###END###

# Default based on janet binary location
(def JANET_HEADERPATH (or (os/getenv "JANET_HEADERPATH")
                          (get (install-paths) :headerpath)))
(def JANET_LIBPATH (or (os/getenv "JANET_LIBPATH")
                       (get (install-paths) :libpath)))
# We want setting JANET_PATH to contain installed binaries. However, it is convenient
# to have globally installed binaries got to the same place as jpm itself, which is on
# the $PATH.
(def JANET_BINPATH (or (os/getenv "JANET_BINPATH")
                       (if-let [mp (os/getenv "JANET_MODPATH")] (string mp "/bin"))
                       (if-let [mp (os/getenv "JANET_PATH")] (string mp "/bin"))
                       (get (install-paths) :binpath)))

# modpath should only be derived from the syspath being used or an environment variable.
(def JANET_MODPATH (or (os/getenv "JANET_MODPATH") (dyn :syspath)))

#
# Utilities
#

(defn find-manifest-dir
  "Get the path to the directory containing manifests for installed
  packages."
  []
  (string (dyn :modpath JANET_MODPATH) sep ".manifests"))

(defn find-manifest
  "Get the full path of a manifest file given a package name."
  [name]
  (string (find-manifest-dir) sep name ".jdn"))

(defn find-cache
  "Return the path to the global cache."
  []
  (def path (dyn :modpath JANET_MODPATH))
  (string path sep ".cache"))

(defn rm
  "Remove a directory and all sub directories."
  [path]
  (case (os/lstat path :mode)
    :directory (do
      (each subpath (os/dir path)
        (rm (string path sep subpath)))
      (os/rmdir path))
    nil nil # do nothing if file does not exist
    # Default, try to remove
    (os/rm path)))

(defn- rimraf
  "Hard delete directory tree"
  [path]
  (if is-win
    # windows get rid of read-only files
    (when (os/stat path :mode)
      (os/shell (string `rmdir /S /Q "` path `"`)))
    (rm path)))

(defn clear-cache
  "Clear the global git cache."
  []
  (def cache (find-cache))
  (print "clearing cache " cache "...")
  (rimraf cache))

(defn clear-manifest
  "Clear the global installation manifest."
  []
  (def manifest (find-manifest-dir))
  (print "clearing manifests " manifest "...")
  (rimraf manifest))

(def- default-pkglist
  (or (os/getenv "JANET_PKGLIST") "https://github.com/janet-lang/pkgs.git"))

(defn- pslurp
  "Like slurp, but with file/popen instead file/open. Also trims output"
  [cmd]
  (string/trim (with [f (file/popen cmd)] (:read f :all))))

(def- path-splitter
  "split paths on / and \\."
  (peg/compile ~(any (* '(any (if-not (set `\/`) 1)) (+ (set `\/`) -1)))))

(defn create-dirs
  "Create all directories needed for a file (mkdir -p)."
  [dest]
  (def segs (peg/match path-splitter dest))
  (for i 1 (length segs)
    (def path (string/join (slice segs 0 i) sep))
    (unless (empty? path) (os/mkdir path))))

(def- filepath-replacer
  "Convert url with potential bad characters into a file path element."
  (peg/compile ~(% (any (+ (/ '(set "<>:\"/\\|?*") "_") '1)))))

(def- entry-replacer
  "Convert url with potential bad characters into an entry-name"
  (peg/compile ~(% (any (+ '(range "AZ" "az" "09" "__") (/ '1 ,|(string "_" ($ 0) "_")))))))

(defn entry-replace
  "Escape special characters in the entry-name"
  [name]
  (get (peg/match entry-replacer name) 0))

(defn filepath-replace
  "Remove special characters from a string or path
  to make it into a path segment."
  [repo]
  (get (peg/match filepath-replacer repo) 0))

(defn shell
  "Do a shell command"
  [& args]
  (if (dyn :verbose)
    (print ;(interpose " " args)))
  (def res (os/execute args :p))
  (unless (zero? res)
    (error (string "command exited with status " res))))

(defn copy
  "Copy a file or directory recursively from one location to another."
  [src dest]
  (print "copying " src " to " dest "...")
  (if is-win
    (let [end (last (peg/match path-splitter src))
          isdir (= (os/stat src :mode) :directory)]
      (shell "C:\\Windows\\System32\\xcopy.exe"
             (string/replace "/" "\\" src) (string/replace "/" "\\" (if isdir (string dest "\\" end) dest))
             "/y" "/s" "/e" "/i"))
    (shell "cp" "-rf" src dest)))

(defn mkdir
  "Create a directory if it doesn't exist. If it does exist, do nothing.
  If we can't create it, give a friendly error. Return true if created, false if
  existing. Throw an error if we can't create it."
  [dir]
  (os/mkdir dir))

(defn- abspath
  "Create an absolute path. Does not resolve . and .. (useful for
  generating entries in install manifest file)."
  [path]
  (if (if is-win
        (peg/match '(+ "\\" (* (range "AZ" "az") ":\\")) path)
        (string/has-prefix? "/" path))
    path
    (string (os/cwd) sep path)))

#
# Rule Engine
#

(defn- getrules []
  (if-let [rules (dyn :rules)] rules (setdyn :rules @{})))

(defn- gettarget [target]
  (def item ((getrules) target))
  (unless item (error (string "No rule for target " target)))
  item)

(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))
  (unless (find |(= dep $) deps)
    (array/push deps dep)))

(defn- add-thunk
  [target more &opt phony]
  (def item (gettarget target))
  (def [_ thunks pthunks] item)
  (array/push (if phony pthunks thunks) more)
  item)

(defn- rule-impl
  [target deps thunk &opt phony]
  (def rules (getrules))
  (unless (rules target) (put rules target @[(array/slice deps) @[] @[]]))
  (each d deps (add-dep target d))
  (add-thunk target thunk phony))

(defmacro rule
  "Add a rule to the rule graph."
  [target deps & body]
  ~(,rule-impl ,target ,deps (fn [] ,;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))

(defmacro sh-rule
  "Add a rule that invokes a shell command, and fails if the command returns non-zero."
  [target deps & body]
  ~(,rule-impl ,target ,deps (fn [] (,assert (,zero? (,os/shell (,string ,;body)))))))

(defmacro sh-phony
  "Add a phony rule that invokes a shell command, and fails if the command returns non-zero."
  [target deps & body]
  ~(,rule-impl ,target ,deps (fn [] (,assert (,zero? (,os/shell (,string ,;body))))) true))

(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 thunks phony] item)
  (def realdeps (seq [dep :in deps :let [x (do-rule dep)] :when x] x))
  (each thunk phony (thunk))
  (unless (empty? thunks)
    (when (needs-build-some target realdeps)
      (each thunk thunks (thunk))
    target)))

#
# Importing a file
#

(def- _env (fiber/getenv (fiber/current)))

(defn- proto-flatten
  [into x]
  (when x
    (proto-flatten into (table/getproto x))
    (merge-into into x))
  into)

(defn make-jpm-env
  "Build an environment table with jpm functions preloaded."
  [&opt no-deps]
  (def env (make-env))
  (put env :jpm-no-deps no-deps)
  (loop [k :keys _env :when (symbol? k)]
    (unless ((_env k) :private) (put env k (_env k))))
  env)

(defn require-jpm
  "Require a jpm file project file. This is different from a normal require
  in that code is loaded in the jpm environment."
  [path &opt no-deps]
  (unless (os/stat path :mode)
    (error (string "cannot open " path)))
  (def env (make-jpm-env no-deps))
  (def currenv (proto-flatten @{} (fiber/getenv (fiber/current))))
  (loop [k :keys currenv :when (keyword? k)]
    (put env k (currenv k)))
  (dofile path :env env :exit true)
  env)

(defn import-rules
  "Import another file that defines more rules. This ruleset
  is merged into the current ruleset."
  [path &opt no-deps]
  (def env (require-jpm path no-deps))
  (when-let [rules (env :rules)] (merge-into (getrules) rules))
  env)

(defmacro post-deps
  "Run code at the top level if jpm dependencies are installed. Build
  code that imports dependencies should be wrapped with this macro, as project.janet
  needs to be able to run successfully even without dependencies installed."
  [& body]
  (unless (dyn :jpm-no-deps)
    ~',(reduce |(eval $1) nil body)))

#
# C Compilation
#

(def default-compiler (or (os/getenv "CC") (if is-win "cl.exe" "cc")))
(def default-cpp-compiler (or (os/getenv "CXX") (if is-win "cl.exe" "c++")))
(def default-linker (or (os/getenv "CC") (if is-win "link.exe" "cc")))
(def default-cpp-linker (or (os/getenv "CXX") (if is-win "link.exe" "c++")))
(def default-archiver (or (os/getenv "AR") (if is-win "lib.exe" "ar")))

# Detect threads
(def env (fiber/getenv (fiber/current)))
(def threads? (not (not (env 'thread/new))))
(def- thread-flags
  (if is-win []
    (if threads? ["-lpthread"] [])))

# flags needed for the janet binary and compiling standalone
# executables.
(def janet-lflags
  (case (os/which)
    :macos ["-ldl" "-lm" ;thread-flags]
    :windows [;thread-flags]
    :linux ["-lm" "-ldl" "-lrt" ;thread-flags]
    ["-lm" ;thread-flags]))
(def janet-ldflags [])
(def janet-cflags [])

# Default flags for natives, but not required
# How can we better detect the need for -pthread?
# we probably want to better detect compiler
(def default-lflags (if is-win ["/nologo"] []))
(def default-cflags
  (if is-win
    ["/nologo" "/MD"]
    ["-std=c99" "-Wall" "-Wextra"]))
(def default-cppflags
  (if is-win
    ["/nologo" "/MD" "/EHsc"]
    ["-std=c++11" "-Wall" "-Wextra"]))
(def default-ldflags [])

# Required flags for dynamic libraries. These
# are used no matter what for dynamic libraries.
(def- dynamic-cflags
  (if is-win
    ["/LD"]
    ["-fPIC"]))
(def- dynamic-lflags
  (if is-win
    ["/DLL"]
    (if is-mac
      ["-shared" "-undefined" "dynamic_lookup" ;thread-flags]
      ["-shared" ;thread-flags])))

(defn- opt
  "Get an option, allowing overrides via dynamic bindings AND some
  default value dflt if no dynamic binding is set."
  [opts key dflt]
  (def ret (or (opts key) (dyn key dflt)))
  (if (= nil ret)
    (error (string "option :" key " not set")))
  ret)

(defn check-cc
  "Ensure we have a c compiler."
  []
  (if is-win
    (do
      (if (os/getenv "INCLUDE") (break))
      (error "Run jpm inside a Developer Command Prompt.
 jpm needs a c compiler to compile natives. You can install the MSVC compiler from
 microsoft.com"))
    (do)))

(defn- embed-name
  "Rename a janet symbol for embedding."
  [path]
  (->> path
       (string/replace-all "\\" "___")
       (string/replace-all "/" "___")
       (string/replace-all ".janet" "")))

(defn- out-path
  "Take a source file path and convert it to an output path."
  [path from-ext to-ext]
  (->> path
       (string/replace-all "\\" "___")
       (string/replace-all "/" "___")
       (string/replace-all from-ext to-ext)
       (string "build" sep)))

(defn- make-define
  "Generate strings for adding custom defines to the compiler."
  [define value]
  (if value
    (string "-D" define "=" value)
    (string "-D" define)))

(defn- make-defines
  "Generate many defines. Takes a dictionary of defines. If a value is
  true, generates -DNAME (/DNAME on windows), otherwise -DNAME=value."
  [defines]
  (seq [[d v] :pairs defines] (make-define d (if (not= v true) v))))

(defn- getcflags
  "Generate the c flags from the input options."
  [opts]
  @[;(opt opts :cflags default-cflags)
    (string "-I" (dyn :headerpath JANET_HEADERPATH))
    (string "-O" (opt opts :optimize 2))])

(defn- getcppflags
  "Generate the cpp flags from the input options."
  [opts]
  @[;(opt opts :cppflags default-cppflags)
    (string "-I" (dyn :headerpath JANET_HEADERPATH))
    (string "-O" (opt opts :optimize 2))])

(defn- entry-name
  "Name of symbol that enters static compilation of a module."
  [name]
  (string "janet_module_entry_" (entry-replace name)))

(defn- compile-c
  "Compile a C file into an object file."
  [opts src dest &opt static?]
  (def cc (opt opts :compiler default-compiler))
  (def cflags [;(getcflags opts) ;(if static? [] dynamic-cflags)])
  (def entry-defines (if-let [n (and static? (opts :entry-name))]
                       [(make-define "JANET_ENTRY_NAME" n)]
                       []))
  (def defines [;(make-defines (opt opts :defines {})) ;entry-defines])
  (def headers (or (opts :headers) []))
  (rule dest [src ;headers]
        (check-cc)
        (print "compiling " src " to " dest "...")
        (create-dirs dest)
        (if is-win
          (shell cc ;defines "/c" ;cflags (string "/Fo" dest) src)
          (shell cc "-c" src ;defines ;cflags "-o" dest))))

(defn- compile-cpp
  "Compile a C++ file into an object file."
  [opts src dest &opt static?]
  (def cpp (opt opts :cpp-compiler default-cpp-compiler))
  (def cflags [;(getcppflags opts) ;(if static? [] dynamic-cflags)])
  (def entry-defines (if-let [n (and static? (opts :entry-name))]
                       [(make-define "JANET_ENTRY_NAME" n)]
                       []))
  (def defines [;(make-defines (opt opts :defines {})) ;entry-defines])
  (def headers (or (opts :headers) []))
  (rule dest [src ;headers]
        (check-cc)
        (print "compiling " src " to " dest "...")
        (create-dirs dest)
        (if is-win
          (shell cpp ;defines "/c" ;cflags (string "/Fo" dest) src)
          (shell cpp "-c" src ;defines ;cflags "-o" dest))))

(defn- libjanet
  "Find libjanet.a (or libjanet.lib on windows) at compile time"
  []
  (def libpath (dyn :libpath JANET_LIBPATH))
  (unless libpath
    (error "cannot find libpath: provide --libpath or JANET_LIBPATH"))
  (string (dyn :libpath JANET_LIBPATH)
          sep
          (if is-win "libjanet.lib" "libjanet.a")))

(defn- win-import-library
  "On windows, an import library is needed to link to a dll statically."
  []
  (def hpath (dyn :headerpath JANET_HEADERPATH))
  (unless hpath
    (error "cannot find headerpath: provide --headerpath or JANET_HEADERPATH"))
  (string hpath `\\janet.lib`))

(defn- link-c
  "Link C object files together to make a native module."
  [opts target & objects]
  (def linker (opt opts (if is-win :linker :compiler) default-linker))
  (def cflags (getcflags opts))
  (def lflags [;(opt opts :lflags default-lflags)
               ;(if (opts :static) [] dynamic-lflags)])
  (def ldflags [;(opt opts :ldflags [])])
  (rule target objects
        (check-cc)
        (print "linking " target "...")
        (create-dirs target)
        (if is-win
          (shell linker ;ldflags (string "/OUT:" target) ;objects (win-import-library) ;lflags)
          (shell linker ;cflags ;ldflags `-o` target ;objects ;lflags))))

(defn- link-cpp
  "Link C++ object files together to make a native module."
  [opts target & objects]
  (def linker (opt opts (if is-win :cpp-linker :cpp-compiler) default-cpp-linker))
  (def cflags (getcppflags opts))
  (def lflags [;(opt opts :lflags default-lflags)
               ;(if (opts :static) [] dynamic-lflags)])
  (def ldflags [;(opt opts :ldflags [])])
  (rule target objects
        (check-cc)
        (print "linking " target "...")
        (create-dirs target)
        (if is-win
          (shell linker ;ldflags (string "/OUT:" target) ;objects (win-import-library) ;lflags)
          (shell linker ;cflags ;ldflags `-o` target ;objects ;lflags))))

(defn- archive-c
  "Link object files together to make a static library."
  [opts target & objects]
  (def ar (opt opts :archiver default-archiver))
  (rule target objects
        (check-cc)
        (print "creating static library " target "...")
        (create-dirs target)
        (if is-win
          (shell ar "/nologo" (string "/out:" target) ;objects)
          (shell ar "rcs" target ;objects))))

(defn- create-buffer-c-impl
  [bytes dest name]
  (create-dirs dest)
  (def out (file/open dest :w))
  (def chunks (seq [b :in bytes] (string b)))
  (file/write out
              "#include <janet.h>\n"
              "static const unsigned char bytes[] = {"
              (string/join (interpose ", " chunks))
              "};\n\n"
              "const unsigned char *" name "_embed = bytes;\n"
              "size_t " name "_embed_size = sizeof(bytes);\n")
  (file/close out))

(defn- create-buffer-c
  "Inline raw byte file as a c file."
  [source dest name]
  (rule dest [source]
        (print "generating " dest "...")
        (create-dirs dest)
        (with [f (file/open source :r)]
          (create-buffer-c-impl (:read f :all) dest name))))

(def- root-env (table/getproto (fiber/getenv (fiber/current))))

(defn- modpath-to-meta
  "Get the meta file path (.meta.janet) corresponding to a native module path (.so)."
  [path]
  (string (string/slice path 0 (- (length modext))) "meta.janet"))

(defn- modpath-to-static
  "Get the static library (.a) path corresponding to a native module path (.so)."
  [path]
  (string (string/slice path 0 (- -1 (length modext))) statext))

(defn- make-bin-source
  [declarations lookup-into-invocations]
  (string
    declarations
    ```

int main(int argc, const char **argv) {

#if defined(JANET_PRF)
    uint8_t hash_key[JANET_HASH_KEY_SIZE + 1];
#ifdef JANET_REDUCED_OS
    char *envvar = NULL;
#else
    char *envvar = getenv("JANET_HASHSEED");
#endif
    if (NULL != envvar) {
        strncpy((char *) hash_key, envvar, sizeof(hash_key) - 1);
    } else if (janet_cryptorand(hash_key, JANET_HASH_KEY_SIZE) != 0) {
        fputs("unable to initialize janet PRF hash function.\n", stderr);
        return 1;
    }
    janet_init_hash_key(hash_key);
#endif

    janet_init();

    /* Get core env */
    JanetTable *env = janet_core_env(NULL);
    JanetTable *lookup = janet_env_lookup(env);
    JanetTable *temptab;
    int handle = janet_gclock();

    /* Load natives into unmarshalling dictionary */

    ```
    lookup-into-invocations
    ```
    /* Unmarshal bytecode */
    Janet marsh_out = janet_unmarshal(
      janet_payload_image_embed,
      janet_payload_image_embed_size,
      0,
      lookup,
      NULL);

    /* Verify the marshalled object is a function */
    if (!janet_checktype(marsh_out, JANET_FUNCTION)) {
        fprintf(stderr, "invalid bytecode image - expected function.");
        return 1;
    }
    JanetFunction *jfunc = janet_unwrap_function(marsh_out);

    /* Check arity */
    janet_arity(argc, jfunc->def->min_arity, jfunc->def->max_arity);

    /* Collect command line arguments */
    JanetArray *args = janet_array(argc);
    for (int i = 0; i < argc; i++) {
        janet_array_push(args, janet_cstringv(argv[i]));
    }

    /* Create enviornment */
    temptab = janet_table(0);
    temptab = env;
    janet_table_put(temptab, janet_ckeywordv("args"), janet_wrap_array(args));
    janet_gcroot(janet_wrap_table(temptab));

    /* Unlock GC */
    janet_gcunlock(handle);

    /* Run everything */
    JanetFiber *fiber = janet_fiber(jfunc, 64, argc, argc ? args->data : NULL);
    fiber->env = temptab;
    Janet out;
    JanetSignal result = janet_continue(fiber, janet_wrap_nil(), &out);
    if (result != JANET_SIGNAL_OK && result != JANET_SIGNAL_EVENT) {
      janet_stacktrace(fiber, out);
      janet_deinit();
      return result;
    }
#ifdef JANET_NET
    janet_loop();
#endif
    janet_deinit();
    return 0;
}

```))

(defn- create-executable
  "Links an image with libjanet.a (or .lib) to produce an
  executable. Also will try to link native modules into the
  final executable as well."
  [opts source dest]

  # Create executable's janet image
  (def cimage_dest (string dest ".c"))
  (def no-compile (opts :no-compile))
  (rule (if no-compile cimage_dest dest) [source]
        (check-cc)
        (print "generating executable c source...")
        (create-dirs dest)
        # Load entry environment and get main function.
        (def entry-env (dofile source))
        (def main ((entry-env 'main) :value))
        (def dep-lflags @[])
        (def dep-ldflags @[])

        # Create marshalling dictionary
        (def mdict (invert (env-lookup root-env)))
        # Load all native modules
        (def prefixes @{})
        (def static-libs @[])
        (loop [[name m] :pairs module/cache
               :let [n (m :native)]
               :when n
               :let [prefix (gensym)]]
          (print "found native " n "...")
          (put prefixes prefix n)
          (array/push static-libs (modpath-to-static n))
          (def oldproto (table/getproto m))
          (table/setproto m nil)
          (loop [[sym value] :pairs (env-lookup m)]
            (put mdict value (symbol prefix sym)))
          (table/setproto m oldproto))

        # Find static modules
        (var has-cpp false)
        (def declarations @"")
        (def lookup-into-invocations @"")
        (loop [[prefix name] :pairs prefixes]
          (def meta (eval-string (slurp (modpath-to-meta name))))
          (if (meta :cpp) (set has-cpp true))
          (buffer/push-string lookup-into-invocations
                              "    temptab = janet_table(0);\n"
                              "    temptab->proto = env;\n"
                              "    " (meta :static-entry) "(temptab);\n"
                              "    janet_env_lookup_into(lookup, temptab, \""
                              prefix
                              "\", 0);\n\n")
          (when-let [lfs (meta :lflags)]
            (array/concat dep-lflags lfs))
          (when-let [lfs (meta :ldflags)]
            (array/concat dep-ldflags lfs))
          (buffer/push-string declarations
                              "extern void "
                              (meta :static-entry)
                              "(JanetTable *);\n"))

        # Build image
        (def image (marshal main mdict))
        # Make image byte buffer
        (create-buffer-c-impl image cimage_dest "janet_payload_image")
        # Append main function
        (spit cimage_dest (make-bin-source declarations lookup-into-invocations) :ab)
        (def oimage_dest (out-path cimage_dest ".c" ".o"))
        # Compile and link final exectable
        (unless no-compile
          (def ldflags [;dep-ldflags ;(opt opts :ldflags []) ;janet-ldflags])
          (def lflags [;static-libs (libjanet) ;dep-lflags ;(opt opts :lflags default-lflags) ;janet-lflags])
          (def defines (make-defines (opt opts :defines {})))
          (def cc (opt opts :compiler default-compiler))
          (def cflags [;(getcflags opts) ;janet-cflags])
          (check-cc)
          (print "compiling " cimage_dest " to " oimage_dest "...")
          (create-dirs oimage_dest)
          (if is-win
            (shell cc ;defines "/c" ;cflags (string "/Fo" oimage_dest) cimage_dest)
            (shell cc "-c" cimage_dest ;defines ;cflags "-o" oimage_dest))
          (if has-cpp
            (let [linker (opt opts (if is-win :cpp-linker :cpp-compiler) default-cpp-linker)
                  cppflags [;(getcppflags opts) ;janet-cflags]]
              (print "linking " dest "...")
              (if is-win
                (shell linker ;ldflags (string "/OUT:" dest) oimage_dest ;lflags)
                (shell linker ;cppflags ;ldflags `-o` dest oimage_dest ;lflags)))
            (let [linker (opt opts (if is-win :linker :compiler) default-linker)]
              (print "linking " dest "...")
              (create-dirs dest)
              (if is-win
                (shell linker ;ldflags (string "/OUT:" dest) oimage_dest ;lflags)
                (shell linker ;cflags ;ldflags `-o` dest oimage_dest ;lflags)))))))

#
# Installation and Dependencies
#

(var- stored-git-path nil)
(defn- git-path
    "Get the location of git such that it can be passed as an argument to os/execute."
    "(Some builds/configurations of windows don't like just the string 'git')"
    []
    (if stored-git-path (break stored-git-path))
    (set stored-git-path
         (if is-win
           (or (os/getenv "JANET_GIT") (first (string/split "\n" (pslurp "where git"))))
           (os/getenv "JANET_GIT" "git"))))

(defn uninstall
  "Uninstall bundle named name"
  [name]
  (def manifest (find-manifest name))
  (when-with [f (file/open manifest)]
    (def man (parse (:read f :all)))
    (each path (get man :paths [])
      (print "removing " path)
      (rm path))
    (print "removing manifest " manifest)
    (:close f) # I hate windows
    (rm manifest)
    (print "Uninstalled.")))

(defn install-git
  "Install a bundle from git. If the bundle is already installed, the bundle
   is reinistalled (but not rebuilt if artifacts are cached)."
  [repotab &opt recurse no-deps]
  (def repo (if (string? repotab) repotab (repotab :repo)))
  (def tag (unless (string? repotab) (repotab :tag)))
  # prevent infinite recursion (very unlikely, but consider
  # 'my-package "my-package" in the package listing)
  (when (> (or recurse 0) 100)
    (error "too many references resolving package url"))
  # Handle short names
  (unless (string/find ":" repo)
    (def pkgs
      (try (require "pkgs")
        ([err f]
          (install-git (dyn :pkglist default-pkglist))
          (require "pkgs"))))
    (def next-repo (get-in pkgs ['packages :value (symbol repo)]))
    (unless next-repo
      (error (string "package " repo " not found.")))
    (unless (or (string? next-repo) (dictionary? next-repo))
      (error (string "expected string or table for repository, got " next-repo)))
    (break (install-git next-repo (if recurse (inc recurse) 0))))
  (def cache (find-cache))
  (mkdir cache)
  (def id (filepath-replace repo))
  (def module-dir (string cache sep id))
  (var fresh false)
  (if (dyn :offline)
    (if (not= :directory (os/stat module-dir :mode))
      (error (string "did not find cached repo for dependency " repo))
      (set fresh true))
    (when (mkdir module-dir)
      (set fresh true)
      (print "cloning repository " repo " to " module-dir)
      (unless (zero? (os/execute [(git-path) "clone" repo module-dir] :p))
        (rimraf module-dir)
        (error (string "could not clone git dependency " repo)))))
  (def olddir (os/cwd))
  (try
    (with-dyns [:rules @{}
                :modpath (abspath (dyn :modpath JANET_MODPATH))
                :headerpath (abspath (dyn :headerpath JANET_HEADERPATH))
                :libpath (abspath (dyn :libpath JANET_LIBPATH))
                :binpath (abspath (dyn :binpath JANET_BINPATH))]
      (os/cd module-dir)
      (unless fresh
        (os/execute [(git-path) "pull" "origin" "master" "--ff-only"] :p))
      (when tag
        (os/execute [(git-path) "reset" "--hard" tag] :p))
      (unless (dyn :offline)
        (os/execute [(git-path) "submodule" "update" "--init" "--recursive"] :p))
      (import-rules "./project.janet" true)
      (unless no-deps (do-rule "install-deps"))
      (do-rule "build")
      (do-rule "install"))
    ([err f] (print "Error building git repository dependency: " err) (propagate err f)))
  (os/cd olddir))

(defn install-rule
  "Add install and uninstall rule for moving file from src into destdir."
  [src destdir]
  (def parts (peg/match path-splitter src))
  (def name (last parts))
  (def path (string destdir sep name))
  (array/push (dyn :installed-files) path)
  (phony "install" []
          (mkdir destdir)
          (copy src destdir)))

(defn- make-lockfile
  [&opt filename]
  (default filename "lockfile.jdn")
  (def cwd (os/cwd))
  (def packages @[])
  # Read installed modules from manifests
  (def mdir (find-manifest-dir))
  (each man (os/dir mdir)
    (def package (parse (slurp (string mdir sep man))))
    (if (and (dictionary? package) (package :repo) (package :sha))
      (array/push packages package)
      (print "Cannot add local or malformed package " mdir sep man " to lockfile, skipping...")))
  # Put in correct order, such that a package is preceded by all of its dependencies
  (def ordered-packages @[])
  (def resolved @{})
  (while (< (length ordered-packages) (length packages))
    (var made-progress false)
    (each p packages
      (def {:repo r :sha s :dependencies d} p)
      (def dep-urls (map |(if (string? $) $ ($ :repo)) d))
      (unless (resolved r)
        (when (all resolved dep-urls)
          (array/push ordered-packages {:repo r :sha s})
          (set made-progress true)
          (put resolved r true))))
    (unless made-progress
      (error (string/format "could not resolve package order for: %j"
                            (filter (complement resolved) (map |($ :repo) packages))))))
  # Write to file, manual format for better diffs.
  (with [f (file/open filename :w)]
    (with-dyns [:out f]
      (prin "@[")
      (eachk i ordered-packages
        (unless (zero? i)
          (prin "\n  "))
        (prinf "%j" (ordered-packages i)))
      (print "]"))))

(defn- load-lockfile
  [&opt filename]
  (default filename "lockfile.jdn")
  (def lockarray (parse (slurp filename)))
  (each {:repo url :sha sha} lockarray
    (install-git {:repo url :tag sha} nil true)))

#
# Declaring Artifacts - used in project.janet, targets specifically
# tailored for janet.
#

(defn declare-native
  "Declare a native module. This is a shared library that can be loaded
  dynamically by a janet runtime. This also builds a static libary that
  can be used to bundle janet code and native into a single executable."
  [&keys opts]
  (def sources (opts :source))
  (def name (opts :name))
  (def path (dyn :modpath JANET_MODPATH))

  # Make dynamic module
  (def lname (string "build" sep name modext))

  # Get objects to build with
  (var has-cpp false)
  (def objects
    (seq [src :in sources]
      (cond
        (string/has-suffix? ".cpp" src)
        (let [op (out-path src ".cpp" objext)]
          (compile-cpp opts src op)
          (set has-cpp true)
          op)
        (string/has-suffix? ".c" src)
        (let [op (out-path src ".c" objext)]
          (compile-c opts src op)
          op)
        (errorf "unknown source file type: %s, expected .c or .cpp"))))

  (when-let [embedded (opts :embedded)]
    (loop [src :in embedded]
      (def c-src (out-path src ".janet" ".janet.c"))
      (def o-src (out-path src ".janet" (if is-win ".janet.obj" ".janet.o")))
      (array/push objects o-src)
      (create-buffer-c src c-src (embed-name src))
      (compile-c opts c-src o-src)))
  ((if has-cpp link-cpp link-c) opts lname ;objects)
  (add-dep "build" lname)
  (install-rule lname path)

  # Add meta file
  (def metaname (modpath-to-meta lname))
  (def ename (entry-name name))
  (rule metaname []
        (print "generating meta file " metaname "...")
        (spit metaname (string/format
                         "# Metadata for static library %s\n\n%.20p"
                         (string name statext)
                         {:static-entry ename
                          :cpp has-cpp
                          :ldflags ~',(opts :ldflags)
                          :lflags ~',(opts :lflags)})))
  (add-dep "build" metaname)
  (install-rule metaname path)

  # Make static module
  (unless (dyn :nostatic)
    (def sname (string "build" sep name statext))
    (def opts (merge @{:entry-name ename} opts))
    (def sobjext (string ".static" objext))
    (def sjobjext (string ".janet" sobjext))

    # Get static objects
    (def sobjects
      (seq [src :in sources]
        (cond
          (string/has-suffix? ".cpp" src)
          (let [op (out-path src ".cpp" sobjext)]
            (compile-cpp opts src op true)
            op)
          (string/has-suffix? ".c" src)
          (let [op (out-path src ".c" sobjext)]
            (compile-c opts src op true)
            op)
          (errorf "unknown source file type: %s, expected .c or .cpp"))))

    (when-let [embedded (opts :embedded)]
      (loop [src :in embedded]
        (def c-src (out-path src ".janet" ".janet.c"))
        (def o-src (out-path src ".janet" sjobjext))
        (array/push sobjects o-src)
        # Buffer c-src is already declared by dynamic module
        (compile-c opts c-src o-src true)))
    (archive-c opts sname ;sobjects)
    (add-dep "build" sname)
    (install-rule sname path)))

(defn declare-source
  "Create Janet modules. This does not actually build the module(s),
  but registers them for packaging and installation. :source should be an
  array of files and directores to copy into JANET_MODPATH or JANET_PATH.
  :prefix can optionally be given to modify the destination path to be
  (string JANET_PATH prefix source)."
  [&keys {:source sources :prefix prefix}]
  (def path (string (dyn :modpath JANET_MODPATH) (or prefix "")))
  (if (bytes? sources)
    (install-rule sources path)
    (each s sources
      (install-rule s path))))

(defn declare-bin
  "Declare a generic file to be installed as an executable."
  [&keys {:main main}]
  (install-rule main (dyn :binpath JANET_BINPATH)))

(defn declare-executable
  "Declare a janet file to be the entry of a standalone executable program. The entry
  file is evaluated and a main function is looked for in the entry file. This function
  is marshalled into bytecode which is then embedded in a final executable for distribution.\n\n
  This executable can be installed as well to the --binpath given."
  [&keys {:install install :name name :entry entry :headers headers
          :cflags cflags :lflags lflags :deps deps :ldflags ldflags
          :no-compile no-compile}]
  (def name (if is-win (string name ".exe") name))
  (def dest (string "build" sep name))
  (create-executable @{:cflags cflags :lflags lflags :ldflags ldflags :no-compile no-compile} entry dest)
  (if no-compile
    (let [cdest (string dest ".c")]
      (add-dep "build" cdest))
    (do
      (add-dep "build" dest)
      (when headers
        (each h headers (add-dep dest h)))
      (when deps
        (each d deps (add-dep dest d)))
      (when install
        (install-rule dest (dyn :binpath JANET_BINPATH))))))

(defn declare-binscript
  "Declare a janet file to be installed as an executable script. Creates
  a shim on windows. If hardcode is true, will insert code into the script
  such that it will run correctly even when JANET_PATH is changed."
  [&keys {:main main :hardcode-syspath hardcode}]
  (def binpath (dyn :binpath JANET_BINPATH))
  (if hardcode
    (let [syspath (dyn :modpath JANET_MODPATH)]
      (def parts (peg/match path-splitter main))
      (def name (last parts))
      (def path (string binpath sep name))
      (array/push (dyn :installed-files) path)
      (phony "install" []
                (def contents
                  (with [f (file/open main)]
                    (def first-line (:read f :line))
                    (def second-line (string/format "(put root-env :syspath %v)\n" syspath))
                    (def rest (:read f :all))
                    (string first-line second-line rest)))
                (create-dirs path)
                (spit path contents)
                (unless is-win (shell "chmod" "+x" path))))
    (install-rule main binpath))
  # Create a dud batch file when on windows.
  (when is-win
    (def name (last (peg/match path-splitter main)))
    (def fullname (string binpath sep name))
    (def bat (string "@echo off\r\njanet \"" fullname "\" %*"))
    (def newname (string binpath sep name ".bat"))
    (array/push (dyn :installed-files) newname)
    (phony "install" []
              (spit newname bat))))

(defn- print-rule-tree
  "Show dependencies for a given rule recursively in a nice tree."
  [root depth prefix prefix-part]
  (print prefix root)
  (when-let [[root-deps] ((getrules) root)]
    (when (pos? depth)
      (def l (-> root-deps length dec))
      (eachp [i d] (sorted root-deps)
        (print-rule-tree
          d (dec depth)
          (string prefix-part (if (= i l) " └─" " ├─"))
          (string prefix-part (if (= i l) "   " " │ ")))))))

(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."
  [&keys opts]
  (def entry (opts :entry))
  (def name (opts :name))
  (def iname (string "build" sep name ".jimage"))
  (rule iname (or (opts :deps) [])
        (create-dirs iname)
        (spit iname (make-image (require entry))))
  (def path (dyn :modpath JANET_MODPATH))
  (add-dep "build" iname)
  (install-rule iname path))

(defn declare-project
  "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)

  (def installed-files @[])
  (def manifests (find-manifest-dir))
  (def manifest (find-manifest (meta :name)))
  (setdyn :manifest manifest)
  (setdyn :manifest-dir manifests)
  (setdyn :installed-files installed-files)

  (phony "build" [])

  (phony "manifest" [manifest])
  (rule manifest []
         (print "generating " manifest "...")
         (mkdir manifests)
         (def sha (pslurp (string "\"" (git-path) "\" rev-parse HEAD")))
         (def url (pslurp (string "\"" (git-path) "\" remote get-url origin")))
         (def man
           {:sha (if-not (empty? sha) sha)
            :repo (if-not (empty? url) url)
            :dependencies (array/slice (get meta :dependencies []))
            :paths installed-files})
         (spit manifest (string/format "%j\n" man)))

  (phony "install" ["uninstall" "build" manifest]
         (when (dyn :test)
           (do-rule "test"))
         (print "Installed as '" (meta :name) "'."))

  (phony "install-deps" []
         (if-let [deps (meta :dependencies)]
           (each dep deps
             (install-git dep))
           (print "no dependencies found")))

  (phony "uninstall" []
         (uninstall (meta :name)))

  (phony "clean" []
         (when (os/stat "./build" :mode)
           (rm "build")
           (print "Deleted build directory.")))

  (phony "test" ["build"]
         (defn dodir
           [dir]
           (each sub (sort (os/dir dir))
             (def ndir (string dir sep sub))
             (case (os/stat ndir :mode)
               :file (when (string/has-suffix? ".janet" ndir)
                       (print "running " ndir " ...")
                       (def result (os/execute [(dyn :executable "janet") ndir] :p))
                       (when (not= 0 result)
                         (os/exit result)))
               :directory (dodir ndir))))
         (dodir "test")
         (print "All tests passed.")))

#
# CLI
#

(def- argpeg
  (peg/compile
    '(* "--" '(some (if-not "=" 1)) (+ (* "=" '(any 1)) -1))))

(defn- local-rule
  [rule &opt no-deps]
  (import-rules "./project.janet" no-deps)
  (do-rule rule))

(defn- help
  []
  (print `
usage: jpm [--key=value, --flag] ... [subcommand] [args] ...

Run from a directory containing a project.janet file to perform operations
on a project, or from anywhere to do operations on the global module cache (modpath).
Commands that need write permission to the modpath are considered privileged commands - in
some environments they may require super user privileges.
Other project-level commands need to have a ./project.janet file in the current directory.

Unprivileged global subcommands:
  help : show this help text
  show-paths : prints the paths that will be used to install things.
  quickbin entry executable : Create an executable from a janet script with a main function.

Privileged global subcommands:
  install (repo or name)... : install artifacts. If a repo is given, install the contents of that
                   git repository, assuming that the repository is a jpm project. If not, build
                   and install the current project.
  uninstall (module)... : uninstall a module. If no module is given, uninstall the module
                       defined by the current directory.
  clear-cache : clear the git cache. Useful for updating dependencies.
  clear-manifest : clear the manifest. Useful for fixing broken installs.
  make-lockfile (lockfile) : Create a lockfile based on repositories in the cache. The
            lockfile will record the exact versions of dependencies used to ensure a reproducible
            build. Lockfiles are best used with applications, not libraries. The default lockfile
            name is lockfile.jdn.
  load-lockfile (lockfile) : Install modules from a lockfile in a reproducible way. The
                             default lockfile name is lockfile.jdn.
  update-pkgs : Update the current package listing from the remote git repository selected.

Privileged project subcommands:
  deps : install dependencies for the current project.
  install : install artifacts of the current project.
  uninstall : uninstall the current project's artifacts.

Unprivileged project subcommands:
  build : build all artifacts
  clean : remove any generated files or artifacts
  test : run tests. Tests should be .janet files in the test/ directory relative to project.janet.
  run rule : run a rule. Can also run custom rules added via (phony "task" [deps...] ...)
             or (rule "ouput.file" [deps...] ...).
  rules : list rules available with run.
  list-installed : list installed packages in the current syspath.
  list-pkgs (search) : list packages in the package listing that the contain the string search.
                       If no search pattern is given, prints the entire package listing.
  rule-tree (root rule) (depth) : Print a nice tree to see what rules depend on other rules.
                                  Optionally provide a root rule to start printing from, and a
                                  max depth to print. Without these options, all rules will print
                                  their full dependency tree.
  debug-repl : Run a repl in the context of the current project.janet file. This lets you run rules and
               otherwise debug the current project.janet file.

Keys are:
  --modpath : The directory to install modules to. Defaults to $JANET_MODPATH, $JANET_PATH, or (dyn :syspath)
  --headerpath : The directory containing janet headers. Defaults to $JANET_HEADERPATH.
  --binpath : The directory to install binaries and scripts. Defaults to $JANET_BINPATH.
  --libpath : The directory containing janet C libraries (libjanet.*). Defaults to $JANET_LIBPATH.
  --compiler : C compiler to use for natives. Defaults to $CC or cc (cl.exe on windows).
  --cpp-compiler : C++ compiler to use for natives. Defaults to $CXX or c++ (cl.exe on windows).
  --archiver : C archiver to use for static libraries. Defaults to $AR ar (lib.exe on windows).
  --linker : C linker to use for linking natives. Defaults to link.exe on windows, not used on
             other platforms.
  --pkglist : URL of git repository for package listing. Defaults to $JANET_PKGLIST or https://github.com/janet-lang/pkgs.git

Flags are:
  --nocolor : Disable color in the jpm repl.
  --verbose : Print shell commands as they are executed.
  --test : If passed to jpm install, runs tests before installing. Will run tests recursively on dependencies.
  --offline : Prevents jpm from going to network to get dependencies - all dependencies should be in the cache or this command will fail.
    `))

(defn show-help
  []
  (print help))

(defn show-paths
  []
  (print "binpath:    " (dyn :binpath JANET_BINPATH))
  (print "modpath:    " (dyn :modpath JANET_MODPATH))
  (print "libpath:    " (dyn :libpath JANET_LIBPATH))
  (print "headerpath: " (dyn :headerpath JANET_HEADERPATH))
  (print "syspath:    " (dyn :syspath)))

(defn build
  []
  (local-rule "build"))

(defn clean
  []
  (local-rule "clean"))

(defn install
  [& repo]
  (if (empty? repo)
    (local-rule "install")
    (each rep repo (install-git rep))))

(defn test
  []
  (local-rule "test"))

(defn- uninstall-cmd
  [& what]
  (if (empty? what)
    (local-rule "uninstall")
    (each wha what (uninstall wha))))

(defn deps
  []
  (local-rule "install-deps" true))

(defn show-rule-tree
  [&opt root depth]
  (import-rules "./project.janet")
  (def max-depth (if depth (scan-number depth) math/inf))
  (if root
    (print-rule-tree root max-depth "" "")
    (let [ks (sort (seq [k :keys (dyn :rules)] k))]
      (each k ks (print-rule-tree k max-depth "" "")))))

(defn list-rules
  [&opt ctx]
  (import-rules "./project.janet")
  (def ks (sort (seq [k :keys (dyn :rules)] k)))
  (each k ks (print k)))

(defn list-installed
  []
  (def xs
    (seq [x :in (os/dir (find-manifest-dir))
          :when (string/has-suffix? ".jdn" x)]
      (string/slice x 0 -5)))
  (sort xs)
  (each x xs (print x)))

(defn list-pkgs
  [&opt search]
  (def [ok _] (module/find "pkgs"))
  (unless ok
    (eprint "no local package listing found. Run `jpm update-pkgs` to get listing.")
    (os/exit 1))
  (def pkgs-mod (require "pkgs"))
  (def ps
    (seq [p :keys (get-in pkgs-mod ['packages :value] [])
          :when (if search (string/find search p) true)]
      p))
  (sort ps)
  (each p ps (print p)))

(defn update-pkgs
  []
  (install-git (dyn :pkglist default-pkglist)))

(defn quickbin
  [input output]
  (create-executable @{} input output)
  (do-rule output))

(defn jpm-debug-repl
  []
  (def env
    (try
      (require-jpm "./project.janet")
      ([err f]
        (if (= "cannot open ./project.janet" err)
          (put (make-jpm-env) :project {})
          (propagate err f)))))
  (setdyn :pretty-format (if-not (dyn :nocolor) "%.20Q" "%.20q"))
  (setdyn :err-color (if-not (dyn :nocolor) true))
  (def p (env :project))
  (def name (p :name))
  (if name (print "Project:     " name))
  (if-let [r (p :repo)] (print "Repository:  " r))
  (if-let [a (p :author)] (print "Author:      " a))
  (defn getchunk [buf p]
    (def [line] (parser/where p))
    (getline (string "jpm[" (or name "repl") "]:" line ":" (parser/state p :delimiters) "> ") buf env))
  (repl getchunk nil env))

(def- subcommands
  {"build" build
   "clean" clean
   "help" show-help
   "install" install
   "test" test
   "help" help
   "deps" deps
   "debug-repl" jpm-debug-repl
   "rule-tree" show-rule-tree
   "show-paths" show-paths
   "list-installed" list-installed
   "list-pkgs" list-pkgs
   "clear-cache" clear-cache
   "clear-manifest" clear-manifest
   "run" local-rule
   "rules" list-rules
   "update-pkgs" update-pkgs
   "uninstall" uninstall-cmd
   "make-lockfile" make-lockfile
   "load-lockfile" load-lockfile
   "quickbin" quickbin})

(def- args (tuple/slice (dyn :args) 1))
(def- len (length args))
(var i :private 0)

# Get flags
(while (< i len)
  (if-let [m (peg/match argpeg (args i))]
    (if (= 2 (length m))
      (let [[key value] m]
        (setdyn (keyword key) value))
      (setdyn (keyword (m 0)) true))
    (break))
  (++ i))

# Run subcommand
(if (= i len)
  (help)
  (do
    (if-let [com (subcommands (args i))]
      (com ;(tuple/slice args (+ i 1)))
      (do
        (print "invalid command " (args i))
        (help)))))