Boot like tasks in Babashka

tasks.cljc

(ns adgoji.application.tasks
  (:require [spartan.spec :as s]))
;; export BABASHKA_CLASSPATH="$(clojure -Sdeps '{:deps {spartan.spec {:git/url "https://github.com/borkdude/spartan.spec" :sha "104129aae9eab6dd4622937d0f46abeed9c9c537"}}}' -Spath)"


(defn strlen-1? [x]
  (= 1 (count (str x))))

(defn strlen-2+? [x]
  (< 1 (count (str x))))

(s/def ::short-option (s/or ::nil nil? ;; FIXME :nil is not accepted by https://github.com/borkdude/edamame/issues/40
                            :v (s/and symbol? strlen-1?)) )

(s/def ::long-option (s/or ::nil nil? ;; FIXME :nil is not accepted by https://github.com/borkdude/edamame/issues/40
                           :v (s/and symbol? strlen-2+?)) )

(defn upper-cased? [x]
  (let [xs (str x)]
    (= xs (clojure.string/upper-case xs))))

(defn upper-cased-symbol? [x]
  (and (symbol? x)
       (upper-cased? x)))

(def opt-types
  '#{bool char code edn file float int kw regexp sym str})

(s/def ::option (s/cat :short-opt ::short-option
                       :long-opt ::long-option
                       :argname (s/? upper-cased-symbol?)
                       :default (s/? (complement upper-cased-symbol?)) ;; DSL extension!
                       :opt-type opt-types
                       :desc string?))

(s/def ::tasks (s/cat
                ; :description (s/? string?)
                :options (s/* ::option)
                ))

(def ^:dynamic *opts* {})

(def tasks (atom {}))


(defn spec-parse-options [forms]
  (map (fn [option] (keep #(%1 option) [(comp second :short-opt) (comp second :long-opt) :argname :default :opt-type :desc])) 
    (:options (s/conform ::tasks forms))))

#_(defn spec-parse-options [forms]
  (let [{:keys [description options]} (s/conform ::tasks forms)
        get-v (fn [x k]
                (let [[t v] (get x k)]
                  (case t
                    :v v
                    ::nil nil)))]
    (map (fn [{:keys [opt-type argname desc opts] :as opt}]
           (let [base
                 [(some->> (get-v opt :short-opt)
                           symbol #_(str "-"))
                  (let [v (get-v opt :long-opt)]
                    (some->> (cond-> v
                               (and v argname)
                               (str " " argname))
                             (str "--")))
                  desc]
                 kw-opts
                 (case opt-type
                   bool (if-not argname
                          {:parse-fn (comp boolean identity)}
                          {:parse-fn #(case %
                                        "true" true
                                        "false" false
                                        %)
                           :validate [#(contains? #{true false} %) "Must be a boolean"]})
                   char {:parse-fn first :validate [char?]}
                   (code edn file) (throw (ex-info "not supported" {:opt opt-type}))

                   float {:parse-fn #(Double/parseDouble %)
                          :validate [float? "Must be a floating point number"]}
                   int (if-not argname
                         {:default 0 :update-fn inc}
                         {:parse-fn #(Integer/parseInt %) ;; TODO add Long/parseLong to Babashka
                          :validate [integer? "Must be an integer"]})
                   kw {:parse-fn keyword
                       :validate [keyword? "Must be a keyword"]}
                   (regexp ) (throw (ex-info "not supported" {:opt opt-type}))
                   sym {:parse-fn symbol
                        :validate [symbol? "Must be a symbol"]}
                   nil)]
             (into base (mapcat identity (merge kw-opts opts)))))
         options)))


(defn quick-parse-options [opts]
  (loop [acc []
         opt []
         [current & [next & left :as cleft]] opts]
    (if (not current)
      acc
      (if (and (opt-types current)
               (string? next))
        (let [[part left] (split-with #(keyword? (first %)) (partition-all 2 left))
              rst (mapcat identity left)]
          (recur (conj acc (into (conj opt current next) (mapcat identity) part))
                 []
                 rst))
        (recur acc
               (conj opt current)
               cleft)))))

               
(defn parse-options [opts] 
  (if (System/getenv "QUICK") (quick-parse-options opts) (spec-parse-options opts)))


(defn list-tasks []
  (clojure.string/join "\n" (map (fn [[task {:keys [description]}]]
                                     (str "* " task " : " description)) (sort-by key @tasks))))


(defn exit
  ([status]
   (exit status nil))
  ([status msg]
   (throw (ex-info "" {:type :exit
                       :exit/code status
                       :exit/message msg}))))


(defn run-tasks [args]
  (let [[dispatch & task-args] args]
    (if-let [{f :fn} (and dispatch (get @tasks (symbol dispatch)))]
      (f task-args)
      (do
        (println (str "No task found for '" dispatch "'"))
        (println)
        (if (seq @tasks)
          (do
            (println "Existing tasks")
            (println (list-tasks)))
          (println "No existing tasks"))
        (exit 1)))))

(require '[clojure.tools.cli :as cli])

(defn register-task [task-sym {f :fn :keys [description]} config]
  (swap! tasks update task-sym
         (fn [prev]
           (when prev
             (println (format "deftask %s/%s was overridden\n" *ns* task-sym)))

           {:fn (fn [cli-args]
                  (let [cli-options (parse-options config)
                        {:keys [errors options] :as parsed-args}
                        (cli/parse-opts cli-args cli-options)]
                    (if-let [errors (seq errors)]
                      (do
                        (println "Invalid")
                        (println errors))
                      (binding [*opts* options]
                        (f options)))


                    #_(binding [*options* {:a 1}]
                        (run-cmd {:description '~description
                                  :cmd '~sym} '~bindings args#
                                 (fn [{:keys [~@syms]}]
                                   (do ~@tails))))))
            :description description})))



(comment
  (quick-parse-options
   '[a a-option AA kw    "The option." :a 1 :b 2
     c counter       int   "The counter."
     e entry     sym   "An entrypoint symbol."
     f flag          bool  "Enable flag."
     o o-option   str   "The other option."
     z nil  str   "The other option."
     nil yy   str   "The other option."]))

(defmacro deftask
  "Define a boot task."
  [sym desc opts & fn-body]
  (let [opt-syms (keep second (parse-options opts))]
    `(let [f# (fn [{:keys [~@opt-syms
                           ]}]
                (do ~@fn-body))]
       (register-task (quote ~sym)
                      {:fn f# :description ~desc}
                      (quote ~opts)))))


  ;; https://github.com/boot-clj/boot/wiki/Task-Options-DSL
(deftask options
  "Demonstrate the task options DSL."
  [a a-option VAL  200 kw    "The option."
   c counter       int   "The counter."
   e entry    VAL  sym   "An entrypoint symbol."
   f flag          bool  "Enable flag."
   o o-option VAL  str   "The other option."
   z nil VAL  str   "The other option."
   nil yy VAL  str   "The othe r option."]
  (prn a-option))


(defn -main [& args]
  (run-tasks args))


#?(:bb
   (try
     (apply -main *command-line-args*)

     (catch Exception ex
       (let [{ex-type :type :keys [ :exit/code :exit/message]} (ex-data ex)]
         (if-not (= ex-type :exit)
           (throw ex)
           (do
             (when message
               (println message))
             (System/exit code)))))))