janet/auxbin/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:\\" "/"))

#
# 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- 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 [_ thunks] item)
  (array/push thunks more)
  item)

(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))
  (when (or phony (needs-build-some target realdeps))
    (each thunk thunks (thunk)))
  (unless phony target))

#
# Configuration
#

(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)))

(def JANET_MODPATH (or (os/getenv "JANET_MODPATH") (dyn :syspath)))

# Default based on janet binary location
(def JANET_HEADERPATH (or (os/getenv "JANET_HEADERPATH")
                          (string exe-dir "/../include/janet")))
(def JANET_LIBPATH (or (os/getenv "JANET_LIBPATH")
                       (string exe-dir "/../lib")))

(def JANET_BINPATH (or (os/getenv "JANET_BINPATH")
                       (string (dyn :syspath) "/bin")))

#
# Compilation Defaults
#

(def default-compiler (or (os/getenv "CC") (if is-win "cl.exe" "cc")))
(def default-linker (or (os/getenv "CC") (if is-win "link.exe" "cc")))
(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))))

# Default flags for natives, but not required
(def default-lflags (if is-win ["/nologo"] []))
(def default-cflags
  (if is-win
    ["/nologo" "/MD"]
    ["-std=c99" "-Wall" "-Wextra"]))

# Link to pthreads
(def- thread-flags (if is-win [] (if threads? ["-lpthread"] [])))

# 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" ;thread-flags]
      (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)))

#
# Importing a file
#

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

(defn- proto-flatten
  [into x]
  (when x
    (proto-flatten into (table/getproto x))
    (loop [k :keys x]
      (put into k (x k))))
  into)

(defn import-rules
  "Import another file that defines more rules. This ruleset
  is merged into the current ruleset."
  [path]
  (def env (make-env))
  (unless (os/stat path :mode)
    (error (string "cannot open " path)))
  (loop [k :keys _env :when (symbol? k)]
     (unless ((_env k) :private) (put env k (_env k))))
  (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)
  (when-let [rules (env :rules)] (merge-into (getrules) rules)))

#
# OS and shell helpers
#

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

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

(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 rm
  "Remove a directory and all sub directories."
  [path]
  (try
    (if (= (os/stat path :mode) :directory)
      (do
        (each subpath (os/dir path)
          (rm (string path sep subpath)))
        (os/rmdir path))
      (os/rm path))
    ([err f] (unless (string/has-prefix? "No such file or directory" err)
               (propagate err f)))))

(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 "xcopy" src (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]
  (if (os/mkdir dir)
    true
    (if (os/stat dir :mode)
      false
      (error (string "Could not create " dir " - this could be a permission issue.")))))

#
# C Compilation
#

(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 (if is-win "/D" "-D") define "=" value)
    (string (if is-win "/D" "-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 (if is-win "/I" "-I") (dyn :headerpath JANET_HEADERPATH))
    (string (if is-win "/O" "-O") (opt opts :optimize 2))])

(defn- entry-name
  "Name of symbol that enters static compilation of a module."
  [name]
  (string "janet_module_entry_" (filepath-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 (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 " dest "...")
        (if is-win
          (shell cc ;defines "/c" ;cflags (string "/Fo" dest) src)
          (shell cc "-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 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)])
  (rule target objects
        (check-cc)
        (print "linking " target "...")
        (if is-win
          (shell linker ;lflags (string "/OUT:" target) ;objects (win-import-library))
          (shell linker ;cflags `-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 "...")
        (if is-win
          (shell ar "/nologo" (string "/out:" target) ;objects)
          (shell ar "rcs" target ;objects))))

(defn- create-buffer-c-impl
  [bytes dest name]
  (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 "...")
        (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- 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"))
  (rule dest [source]
        (check-cc)
        (print "generating executable c source...")
        # Load entry environment and get main function.
        (def entry-env (dofile source))
        (def main ((entry-env 'main) :value))
        (def dep-lflags @[])

        # 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
        (def declarations @"")
        (def lookup-into-invocations @"")
        (loop [[prefix name] :pairs prefixes]
          (def meta (eval-string (slurp (modpath-to-meta name))))
          (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))
          (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 (string
                            "\n"
                            declarations
```

int main(int argc, const char **argv) {
    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_stacktrace(fiber, out);
      janet_deinit();
      return result;
    }
    janet_deinit();
    return 0;
}

```) :ab)

# Compile and link final exectable
(do
  (def extra-lflags (case (os/which)
                      :macos ["-ldl" "-lm" ;thread-flags]
                      :windows [;thread-flags]
                      :linux ["-lm" "-ldl" "-lrt" ;thread-flags]
                      #default
                      ["-lm" ;thread-flags]))
  (def cc (opt opts :compiler default-compiler))
  (def lflags [;dep-lflags ;(opt opts :lflags default-lflags) ;extra-lflags])
  (def cflags (getcflags opts))
  (def defines (make-defines (opt opts :defines {})))
  (print "compiling and linking " dest "...")
  (if is-win
    (shell cc ;cflags cimage_dest ;static-libs (libjanet) ;lflags `/link` (string "/OUT:" dest))
    (shell cc ;cflags `-o` dest cimage_dest ;static-libs (libjanet) ;lflags)))))

(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)))

#
# Public 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 ".txt"))

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

(defn uninstall
  "Uninstall bundle named name"
  [name]
  (def manifest (find-manifest name))
  (def f (file/open manifest :r))
  (unless f (print manifest " does not exist") (break))
  (loop [line :iterate (:read f :line)]
    (def path ((string/split "\n" line) 0))
    (def path ((string/split "\r" path) 0))
    (print "removing " path)
    (rm path))
  (:close f)
  (print "removing " manifest)
  (rm manifest)
  (print "Uninstalled."))

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

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

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

(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]
  (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)
  (when (mkdir module-dir)
      (set fresh true)
      (print "cloning repository " repo " to " module-dir)
      (unless (zero? (os/execute ["git" "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" "pull" "origin" "master"] :p))
      (when tag
        (os/execute ["git" "reset" "--hard" tag] :p))
      (os/execute ["git" "submodule" "update" "--init" "--recursive"] :p)
      (import-rules "./project.janet")
      (do-rule "install-deps")
      (do-rule "build")
      (do-rule "install"))
    ([err] (print "Error building git repository dependency: " err)))
  (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)
  (add-body "install"
            (mkdir destdir)
            (copy src destdir)))

#
# 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))
  (loop [src :in sources]
    (compile-c opts src (out-path src ".c" objext)))
  (def objects (map (fn [path] (out-path path ".c" objext)) sources))
  (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)))
  (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
                          :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))
    (loop [src :in sources]
      (compile-c opts src (out-path src ".c" sobjext) true))
    (def sobjects (map (fn [path] (out-path path ".c" sobjext)) sources))
    (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 a Janet modules. This does not actually build the module(s),
  but registers it for packaging and installation."
  [&keys {:source sources}]
  (def path (dyn :modpath JANET_MODPATH))
  (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}]
  (def name (if is-win (string name ".exe") name))
  (def dest (string "build" sep name))
  (create-executable @{:cflags cflags :lflags lflags} entry dest)
  (add-dep "build" dest)
  (when headers
    (each h headers (add-dep dest h)))
  (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."
  [&keys opts]
  (def main (opts :main))
  (def binpath (dyn :binpath JANET_BINPATH))
  (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)
    (add-body "install"
              (spit newname bat))))

(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) [])
        (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)

  (rule "./build" [] (mkdir "build"))
  (phony "build" ["./build"])

  (phony "manifest" []
         (print "generating " manifest "...")
         (mkdir manifests)
         (spit manifest (string (string/join installed-files "\n") "\n")))
  (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]
  (import-rules "./project.janet")
  (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).

Subcommands are:
  build : build all artifacts
  help : show this help text
  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.
  show-paths : prints the paths that will be used to install things.
  clean : remove any generated files or artifacts
  test : run tests. Tests should be .janet files in the test/ directory relative to project.janet.
  deps : install dependencies for the current project.
  clear-cache : clear the git cache. Useful for updating dependencies.
  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.
  update-pkgs : Update the current package listing from the remote git repository selected.
  quickbin entry executable : Create an executable from a janet script with a main function.

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).
  --archiver : C compiler 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:
  --verbose : Print shell commands as they are executed.
  --test : If passed to jpm install, runs tests before installing. Will run tests recursively on dependencies.
    `))

(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
  [&opt repo]
  (if repo
    (install-git repo)
    (local-rule "install")))

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

(defn- uninstall-cmd
  [&opt what]
  (if what
    (uninstall what)
    (local-rule "uninstall")))

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

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

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

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

(def- subcommands
  {"build" build
   "clean" clean
   "help" show-help
   "install" install
   "test" test
   "help" help
   "deps" deps
   "show-paths" show-paths
   "clear-cache" clear-cache
   "run" local-rule
   "rules" list-rules
   "update-pkgs" update-pkgs
   "uninstall" uninstall-cmd
   "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)))))