Carp/core/Macros.carp

;; Defining the meta data macros early so that they can be used by all the other code.

(meta-set! doc "doc" "Set documentation for a binding.")
(defmacro doc [name string]
  (list 'meta-set! name "doc" string))

(doc print-doc "Print the documentation for a binding.")
(defmacro print-doc [name]
  (list 'macro-log (list 'meta name "doc")))

(doc sig "Annotate a binding with the desired signature.")
(defmacro sig [name signature]
  (list 'meta-set! name "sig" signature))

(doc print-sig "Print the annotated signature for a binding.")
(defmacro print-sig [name]
  (list 'macro-log (list 'meta name "sig")))

(doc hide "Mark a binding as hidden, this will make it not print with the 'info' command.")
(defmacro hidden [name]
  (list 'meta-set! name "hidden" true))

(doc private "Mark a binding as private, this will make it inaccessible from other modules.")
(defmacro private [name]
  (list 'meta-set! name "private" true))

(doc todo "sets the todo property for a binding.")
(defmacro todo [name value]
  (list 'meta-set! name "todo" value))

(doc private? "Is this binding private?")
(defmacro private? [name]
  (list 'not (list 'list? (meta name "private"))))

(doc hidden? "Is this binding hidden?")
(defmacro hidden? [name]
  (list 'not (list 'list? (meta name "hidden"))))

(defndynamic annotate-helper [name annotation]
  (cons annotation (meta name "annotations")))

(doc annotate "Add an annotation to this binding.")
(defmacro annotate [name annotation]
  (list 'meta-set! name "annotations" (annotate-helper name annotation)))

(defmodule Dynamic
  (defndynamic caar [pair] (car (car pair)))
  (defndynamic cadr [pair] (car (cdr pair)))
  (defndynamic cdar [pair] (cdr (car pair)))
  (defndynamic cddr [pair] (cdr (cdr pair)))
  (defndynamic caaar [pair] (car (car (car pair))))
  (defndynamic caadr [pair] (car (car (cdr pair))))
  (defndynamic cadar [pair] (car (cdr (car pair))))
  (defndynamic cdaar [pair] (cdr (car (car pair))))
  (defndynamic caddr [pair] (car (cdr (cdr pair))))
  (defndynamic cdadr [pair] (cdr (car (cdr pair))))
  (defndynamic cddar [pair] (cdr (cdr (car pair))))
  (defndynamic cdddr [pair] (cdr (cdr (cdr pair))))
  (defndynamic caaaar [pair] (car (car (car (car pair)))))
  (defndynamic caaadr [pair] (car (car (car (cdr pair)))))
  (defndynamic caadar [pair] (car (car (cdr (car pair)))))
  (defndynamic caaddr [pair] (car (car (cdr (cdr pair)))))
  (defndynamic cadaar [pair] (car (cdr (car (car pair)))))
  (defndynamic cadadr [pair] (car (cdr (car (cdr pair)))))
  (defndynamic caddar [pair] (car (cdr (cdr (car pair)))))
  (defndynamic cadddr [pair] (car (cdr (cdr (cdr pair)))))
  (defndynamic cdaaar [pair] (cdr (car (car (car pair)))))
  (defndynamic cdaadr [pair] (cdr (car (car (cdr pair)))))
  (defndynamic cdadar [pair] (cdr (car (cdr (car pair)))))
  (defndynamic cdaddr [pair] (cdr (car (cdr (cdr pair)))))
  (defndynamic cddaar [pair] (cdr (cdr (car (car pair)))))
  (defndynamic cddadr [pair] (cdr (cdr (car (cdr pair)))))
  (defndynamic cdddar [pair] (cdr (cdr (cdr (car pair)))))
  (defndynamic cddddr [pair] (cdr (cdr (cdr (cdr pair)))))

  (defndynamic cxr [x pair]
    (if (= (length x) 0)
      (list 'quote pair)
      (list
        (if (= 'a (cadr x))
          'car
          (if (= 'd (cadr x))
            'cdr
            (macro-error "`cxr` expects either `a` or `d` symbols, got " (cadr x))))
        (if (= 1 (car x))
          (cxr (cddr x) pair)
          (cxr (cons (- (car x) 1) (cdr x)) pair)))))

  (defndynamic nthcdr [n pair]
    (cxr (list (+ n 1) 'd) pair))

  (defndynamic nthcar [n pair]
    (cxr (list 1 'a n 'd) pair))

  (defndynamic eval-internal [form]
    (list 'do
          (list 'defn 'main [] (list 'IO.println* form))
          (list 'build)
          (list 'run)))

  (defmacro evaluate [form]
    (eval-internal form))

  (defmacro e [form]
    (eval-internal form))

  (defndynamic list-to-array-internal [xs acc]
    (if (= 0 (length xs))
        acc
        (list-to-array-internal (cdr xs) (append acc (array (car xs))))))

  (defndynamic collect-into-internal [xs acc f]
    (if (= 0 (length xs))
        acc
        (collect-into-internal (cdr xs) (append acc (f (car xs))) f)))

  (doc collect-into
    "Transforms a dynamic data literal into another, preserving order")
  (defndynamic collect-into [xs f]
    (list 'quote
      (collect-into-internal xs (f) f)))
)

(defndynamic cond-internal [xs]
  (if (= (length xs) 0)
    (list)
    (if (= (length xs) 2)
      (macro-error "cond has even number of branches; add an else branch")
      (if (= (length xs) 1)
        (car xs)
        (list
         'if
         (car xs)
         (cadr xs)
         (cond-internal (cddr xs)))))))

(defmacro cond [:rest xs]
  (cond-internal xs))

(defmacro for [settings :rest body] ;; settings = variable, from, to, <step>
  (if (> (length body) 1)
    (macro-error "Warning: the body of the 'for' loop can only contain one expression")
    (let [variable (car settings)
          from (cadr settings)
          to (caddr settings)
          step (if (> (length settings) 3) (cadddr settings) 1)
          comp (if (> (length settings) 4)
                 (cadddr (cdr settings))
                 (if (< step (- step step)) '> '<))
          ]
      (list
       'let (array variable from)
       (list
        'while (list comp variable to)
        (list
         'do
         (if (= (length body) 0)
           ()
           (if (list? body)
             (car body)
             body))
         (list
          'set! variable
          (list '+ variable step))))))))

(defmacro refstr [x]
  (list 'ref
        (list 'str x)))

(defmacro doall [f xs]
  (list 'for ['i 0 (list 'Array.length (list 'ref xs))]
        (list f (list 'Array.unsafe-nth (list 'ref xs) 'i))))

(defndynamic foreach-internal [var xs expr]
  (let [xsym (gensym-with 'xs)
        len (gensym-with 'len)
        i (gensym-with 'i)]
    (list 'let [xsym xs
                len (list 'Array.length xsym)]
          (list 'for [i 0 len]
                (list 'let [var (list 'Array.unsafe-nth xsym i)]
                      expr)))))

(defmacro foreach [binding expr]
  (if (array? binding)
    (foreach-internal (car binding) (cadr binding) expr)
    (macro-error "Binding has to be an array.")))

(defndynamic thread-first-internal [xs]
  (if (= (length xs) 2)
    (if (list? (last xs))
      (cons (caadr xs)
            (cons (car xs)
                  (cdadr xs)))
      (list (cadr xs) (car xs)))
    (if (list? (last xs))
      (append
       (list
        (car (last xs))
        (thread-first-internal (all-but-last xs)))
       (cdr (last xs)))
      (list (last xs) (thread-first-internal (all-but-last xs))))))

(defndynamic thread-last-internal [xs]
  (if (= (length xs) 2)
    (if (list? (last xs))
      (cons-last (car xs) (last xs))
      (list (cadr xs) (car xs)))
    (if (list? (last xs))
      (cons-last (thread-last-internal (all-but-last xs)) (last xs))
      (list (last xs) (thread-last-internal (all-but-last xs))))))

(defmacro => [:rest forms]
  (thread-first-internal forms))

(defmacro ==> [:rest forms]
  (thread-last-internal forms))

(defmacro swap! [x y]
  (list 'let (array 'tmp y) (list 'do (list 'set! y x) (list 'set! x 'tmp))))

(defmacro update! [x f]
  (list 'set! x (list f x)))

(defmacro mac-only [:rest forms]
  (if (= "darwin" (os))
    (eval (cons (quote do) forms))
    ()))

(defmacro linux-only [:rest forms]
  (if (= "linux" (os))
    (eval (cons (quote do) forms))
    ()))

(defmacro windows-only [:rest forms]
  (if (Dynamic.or (= "windows" (os)) (= "mingw32" (os)))
    (eval (cons (quote do) forms))
    ()))

(defmacro not-on-windows [:rest forms]
  (if (not (Dynamic.or (= "windows" (os)) (= "mingw32" (os))))
    (eval (cons (quote do) forms))
    ()))

(defndynamic use-all-fn [names]
  (if (= (length names) 0)
    (macro-error "Trying to call use-all without arguments")
    (do
      (eval (list 'use (car names)))
      (if (= (length names) 1)
        ()
        (use-all-fn (cdr names))))))

(defmacro use-all [:rest names]
  (use-all-fn names))

(defmacro load-and-use [name]
  (do
    (eval (list 'load (str name ".carp")))
    (eval (list 'use name))))

(defmacro when [condition form]
  (list 'if condition form (list)))

(defmacro unless [condition form]
  (list 'if condition (list) form))

(defmacro let-do [bindings :rest forms]
  (list 'let bindings
    (cons 'do forms)))

(defmacro while-do [condition :rest forms]
  (list 'while condition
    (cons 'do forms)))

(defmacro defn-do [name arguments :rest body]
  (eval (list 'defn name arguments (cons 'do body))))

(defmacro comment [:rest forms]
  ())

(defmacro forever-do [:rest forms]
  (list 'while true (cons 'do forms)))

(defndynamic case-internal [name xs]
  (if (= (length xs) 0)
    (list)
    (if (= (length xs) 2)
      (macro-error "case has even number of branches; add an else branch")
      (if (= (length xs) 1)
        (car xs)
        (list 'if
         (list '= name (car xs))
          (cadr xs)
          (case-internal name (cddr xs)))))))

(defmacro case [name :rest forms]
  (case-internal name forms))

(defmacro and [x y]
  (list 'if x y false))

(defmacro or [x y]
  (list 'if x true y))

(defndynamic build-vararg [func forms]
  (if (= (length forms) 0)
    (macro-error "vararg macro needs at least one argument")
    (if (= (length forms) 1)
      (car forms)
      (list func (car forms) (build-vararg func (cdr forms))))))

(defmacro and* [:rest forms]
  (build-vararg 'and forms))

(defmacro or* [:rest forms]
  (build-vararg 'or forms))

(defndynamic build-str* [forms]
  (if (= (length forms) 0)
    (list "")
    (if (= (length forms) 1)
      (list 'ref (list 'str (car forms)))
      (list 'ref (list 'String.append (list 'ref (list 'str (car forms))) (build-str* (cdr forms)))))))

(defmacro str* [:rest forms]
  (list 'copy (build-str* forms)))

(defmacro println* [:rest forms]
  (list 'IO.println (build-str* forms)))

(defmacro print* [:rest forms]
  (list 'IO.print (build-str* forms)))

(defmacro ignore [form]
  (list 'let (array '_ form) (list)))

(defmacro save-docs [:rest modules]
  ;; A trick to be able to send unquoted symbols to 'save-docs'
  (list 'save-docs-internal (list 'quote modules)))

(defndynamic project-config [bindings]
  (if (< (length bindings) 2)
    (list)
    (cons-last (project-config (cdr (cdr bindings))) (list 'do (list 'Project.config
    (car bindings) (car (cdr bindings)))))))

(doc defproject "Define a project configuration.")
(defmacro defproject [:rest bindings]
  (project-config bindings))

(doc const-assert "asserts that the expression `expr` is true at compile time.
Otherwise it will fail with the message `msg`.

The expression must be evaluable at compile time.")
(defndynamic const-assert [expr msg]
  (if expr () (macro-error msg)))

(doc *gensym-counter* "is a helper counter for `gensym`.")
(defdynamic *gensym-counter* 1000)

(doc gensym-with "generates symbols dynamically, based on a symbol name.")
(defndynamic gensym-with [x]
  (do
    (set! *gensym-counter* (inc *gensym-counter*))
    (Symbol.join [x (Symbol.from *gensym-counter*)])))

(doc gensym "generates symbols dynamically as needed.")
(defndynamic gensym []
  (gensym-with 'gensym-generated))

(doc until "executes `body` until the condition `cnd` is true.")
(defmacro until [cnd body]
  (list 'while (list 'not cnd)
    body))

(doc defdynamic-once "creates a dynamic variable and sets its value if it's not already defined.")
(defmacro defdynamic-once [var expr]
  (list 'if (list 'defined? var)
        ()
        (list 'defdynamic var expr)))

(defndynamic comp-internal [sym fns]
  (if (= (length fns) 0)
    sym
    (list (car fns) (comp-internal sym (cdr fns)))))

(doc comp "composes the functions `fns` into one `fn`.")
(defmacro comp [:rest fns]
  (let [x (gensym)]
    (list 'fn [x] (comp-internal x fns))))