foo.lisp

#!/usr/bin/env fennel

(macros {
        :append (fn [t v]
                    `(let [t# ,t] (rawset t# (+ (length t#) 1) ,v)))

        ; TODO(ashkan): this results in an error when you try
        ; to do (tset? (tset? {} :a 123) :b 321)
        ; :tset? (fn [t k v]
        ; `(let [t# ,t k# ,k]
        ; (if
        ; (not (rawget t# k#)) (rawset t# k# ,v)
        ; t#)))

        ; :loop (fn X [...]
        ; (for [i 1 (select :# ...)]
        ; (local v (select i ...))
        ; (if (list? v)
        ; (X (unpack v))
        ; ; `(loop ,v)
        ; (print (sym? v) (tostring v)))))

        })

(local luv (require :luv))
(local {: band} (require :bit))
(local executable-bit (tonumber :100 8))
(local view (require :fennelview))

(local validate-types {
       :t :table :f :function
       :s :string :n :number
       :b :boolean
       :table :table :function :function
       :string :string :number :number
       :boolean :boolean
       })

(local NIL {})

(global DEBUG false)

(lambda tset? [t k v]
  (if (not (rawget t k))
    (rawset t k v)
    t))

(lambda validate [config]
  (assert (= (type config) :table) "validate: config must be a table")
  (each [name [v ty optional?] (pairs config)]
        (let [xty (. validate-types ty)]
          (or xty (error (string.format "Invalid type %q for %q" ty name)))
          (if (and (= v nil) (not optional?))
            (error (string.format "%q is required to be a %q, but we got nil" name xty))
            (let [vty (type v)]
              (when (not= vty xty)
                (error (string.format "%q is required to be a %q, but we got a %q" name xty vty))))))))

(fn P [...]
    (for [i 1 (select :# ...)]
         (io.stderr:write (view (select i ...)) "\t"))
    (io.stderr:write "\n"))

(local D (if DEBUG P (fn [])))

(fn type-dispatcher [config]
    (let [default (or config.default #(error "Unsupported type"))]
      (fn [head ...]
          ((or
             (. config (type head))
             (default head ...))
           head ...))))

(local inspect?
       (type-dispatcher
         {
         :function (fn [it proc]
                       (fn pass [...]
                           (proc ...)
                           ...)
                       (fn [] (pass (it))))
         :default (fn [it proc] (do (proc it) it))
         }))

(local map
       (type-dispatcher
         {
         :function (lambda [it mapper]
                     (validate {:mapper [mapper :f]})
                     (fn pass [head ...]
                         (if
                           (= head nil) nil
                           (mapper head ...)))
                     (fn [] (pass (it))))
         }))

(local filter
       (type-dispatcher
         {
         :function (lambda [it filterer]
                     (validate {:filterer [filterer :f]})
                     (fn pass [head ...]
                         (if
                           (= head nil) nil
                           (filterer head ...) (values head ...)
                           (pass (it))))
                     (fn [] (pass (it))))
         :table (lambda [it filterer]
                  (validate {:filterer [filterer :f]})
                  (let [res []]
                    (each [i v (ipairs it)]
                          (when (filterer v i) (append res v)))
                    res))
         }))

(local filter-map
       (type-dispatcher
         {
         :function (do
                     (fn or-NIL [head ...]
                         (if (= head nil) NIL
                           (values head ...)))
                     (fn not-NIL [head] (not= head NIL))
                     (lambda [it filterer]
                       (validate {:filterer [filterer :f]})
                       (-> it
                           (map (fn [...] (or-NIL (filterer ...))))
                           (filter not-NIL))))
         }))

(local first
       (type-dispatcher
         {
         :function (fn [t] (t))
         :table (fn [t] (. t 1))
         }))

(local last
       (type-dispatcher
         {
         :function (fn [t]
                       (do
                         (var ret nil)
                         (each [v t] (set ret v))
                         ret))
         :table (fn [t] (. t (length t)))
         }))

(local foldl
       (type-dispatcher
         {
         :function (fn [it z f]
                       (var z z)
                       (each [v it] (set z (f z v)))
                       z)
         :table (fn [it] it)
         :default (fn [it] [it])
         }))

; (fn accumulate [it] (foldl it [] #(append $1 $2)))

(local accumulate
       (type-dispatcher
         {
         :function (fn [it] (let [res []]
                              (each [v it] (append res v))
                              res))
         :table (fn [it] it)
         :default (fn [it] [it])
         }))

(lambda exists? [file]
  (-?> (luv.fs_stat file)
       (. :type)
       (= :file)))

(lambda spawn [cmd ?options]
  (let [
        args (filter cmd #(> $2 1))
        cmd (. cmd 1)
        options (-> (or ?options {})
                    ; TODO(ashkan): compiler error. This reuses the same hash
                    ; suffix for both tset? which results in a conflict.
                    (tset? :args args)
                    ; (rawset :args args)
                    (tset? :stdio [nil 1 2]))
        ]
    (D cmd options)
    (luv.spawn cmd options)
    (luv.run)))

; TODO(ashkan): use luv.os_tmpdir instead?
(fn tmpfile [opts]
    (let [
          template "/tmp/tmp.XXXXXXX"
          opts     (or opts {})
          {: ext}  opts
          template (if ext (.. template ext) template)
          file     (io.popen (.. "mktemp " template))
          ]
      (if file
        (let [ret (file:read "*l")]
          (file:close)
          ret)
        nil)))

(lambda gsplit [input sep ?plain]
  (if (= sep "")
    (do
      (var i 0)
      (fn []
          (when (< i (length input))
            (set i (+ i 1))
            (string.sub input i i))))
    (do
      (var start 1)
      (fn passthrough [i j ...]
          (if i
            (let [segment (string.sub input start (- i 1))]
              (set start (+ j 1))
              (values segment ...))
            (let [i start]
              (set start nil)
              (string.sub input i))))
      (fn []
          (when start
            (passthrough (string.find input sep start ?plain)))))))

(lambda split [input sep ?plain]
  (accumulate (gsplit input sep ?plain)))

; (lambda split [input sep ?plain]
;   (let [res []]
;   (each [v (gsplit input sep ?plain)]
;         (append res v))
;   res))

; (lambda scan-dir [dirname]
;   (let [h (or (luv.fs_scandir dirname) (error (.. dirname " does not exist")))]
;   (fn [] (luv.fs_scandir_next h))))

; ; TODO(ashkan): check perf diff between filter-map and filter + map
; (lambda scan-files [dirname]
;   (-> (scan-dir dirname)
;     (filter-map #(if (= $2 :file) (values $1 (.. dirname :/ $1))))))
; ; (filter #(= $2 :file))
; ; (map #(values $1 (.. dirname :/ $1)))))

; Iterator of (kind basename full_path)
(lambda scan-dir [dirname]
  (let [h (or (luv.fs_scandir dirname) (error (.. dirname " does not exist")))]
    (fn []
        (let [(e k) (luv.fs_scandir_next h)]
          (when e (values k e (.. dirname :/ e)))))))

; Iterator of (basename full_path)
(lambda scan-files [dirname]
  (-> (scan-dir dirname)
      (filter-map #(if (= $1 :file) (values $2 $3)))))

(lambda fs-executable? [name]
  (-?> (luv.fs_stat name)
       (. :mode)
       (band executable-bit)
       (not= 0)))

(lambda executable? [name]
  (or 
    (fs-executable? name)
    (-> (os.getenv :PATH)
        (gsplit ":" true)
        (filter-map #(-> (scan-files $)
                         (filter #(if (= name $1) (fs-executable? $2)))
                         (first)))
        (first)
        (->> (select 2)))))

(lambda genseq [n]
  (var i 0)
  (fn []
      (when (< i n)
        (set i (+ i 1))
        i)))

(local for-each
       (type-dispatcher
         {
         :function (fn [it proc]
                       (validate {:proc [proc :f]})
                       (fn pass [head ...]
                           (if (not= head nil) (do (proc head ...) true)))
                       (while (pass (it))))
         :default (fn [it proc] (proc it))
         }))

(lambda main [program file ...]
  (let [program (assert (executable? program) (.. "Invalid executable " program))]
    (if (exists? file)
      (spawn [program file ...])
      (let [
            url file
            file (tmpfile {:ext (string.match url "%.[^.]+$")})
            ]
        (pcall spawn [:cookiecurl :-sL url :-o file])
        (pcall spawn [program file ...])
        (luv.fs_unlink file)))))

(let [(ok? err) (pcall main (unpack arg))]
  (when (not ok?)
    (print "Error: " err)))

; PROGRAM="$1"
; shift 
; test -e "$1" && exec feh "$1"
; 
; FILE=$(mktemp /tmp/tmp.XXXXXXX.${1##*.})
; cookiecurl -qL "$1" -o $FILE
; feh "$FILE"
; rm "$FILE"

; vim:ft=lisp noet ts=3 sw=3 cms=;\ %s