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

#
# 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 [] ,;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))

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

#
# OS and shell helpers
#

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

(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]
  (if (= (os/lstat path :mode) :directory)
    (do
      (each subpath (os/dir path)
        (rm (string path sep subpath)))
      (os/rmdir path))
    (os/rm path)))

(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]
  (os/mkdir dir))

#
# 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 "...")
        (create-dirs 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 "...")
        (create-dirs 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 "...")
        (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]
  (dedent
    ```
    ```
    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_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"))
  (rule 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 @[])

        # 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 (make-bin-source declarations lookup-into-invocations) :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 parse
  "Read a string of Janet source and parse out the first expression."
  [src]
  (let [p (parser/new)]
    (:consume p src)
    (if (= :error (:status p))
      (error (string "Could not parse: " (parser/error p))))
    (:produce p)))

(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 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)
    (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 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" "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))
      (unless (dyn :offline)
        (os/execute ["git" "submodule" "update" "--init" "--recursive"] :p))
      (import-rules "./project.janet")
      (unless no-deps (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)))

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

(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
  (with [f (file/open filename :w)] (with-dyns [:out f] (printf "%j" ordered-packages))))

(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))
  (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 :deps deps}]
  (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 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."
  [&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- 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" []
         (print "generating " manifest "...")
         (mkdir manifests)
         (def sha (pslurp "git rev-parse HEAD"))
         (def url (pslurp "git 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).

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.
  rule-tree (root rule) (depth) : Print a nice tree to see what rules depend on other rules.
                                  Optinally 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.
  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.
  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.
  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).
  --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:
  --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
  [&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" 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" true)
  (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))

(defn jpm-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
   "repl" jpm-repl
   "rule-tree" show-rule-tree
   "show-paths" show-paths
   "clear-cache" clear-cache
   "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)))))