Carp/core/Macros.carp

;; Defining the meta data macros early so that they can be used by all the other code.
;; Defined early so that `doc` can accept a rest arg
(defndynamic map-internal [f xs acc]
    (if (= 0 (length xs))
        acc
        (map-internal f (cdr xs) (cons-last (f (car xs)) acc))))

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

(defmodule Dynamic
  (defndynamic quoted [x]
    (list 'quote x))

  (defndynamic /= [a b] (not (= a b)))

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

  (defmodule List
    ; this should be defined using cond, but is defined before cond
    (defndynamic in? [elem l]
      (if (empty? l)
        false
        (if (= elem (car l))
          true
          (List.in? elem (cdr l))))))

  (defndynamic string? [s]
    (= (dynamic-type s) 'string))

  (defndynamic symbol? [s]
    (= (dynamic-type s) 'symbol))

  (defndynamic list? [s]
    (= (dynamic-type s) 'list))

  (defndynamic array? [s]
    (= (dynamic-type s) 'array))

  (defndynamic number? [s]
    (List.in? (dynamic-type s) '(int long double float byte))))

(meta-set! doc "doc" "Set documentation for a binding.")
(defmacro doc [name :rest strings]
  (let [newline "
" ;; Looks a bit odd but the newline literal is important here! (str \newline) currently results in unwanted escapes
        separated (map-internal (fn [x] (if (list? x)
                                            (if (cadr x)
                                                (Dynamic.String.concat [(car x) newline])
                                                (car x))
                                            (Dynamic.String.concat [x newline])))
                                strings
                                ())]
    (list 'meta-set! name "doc" (Dynamic.String.concat (list-to-array-internal separated [])))))

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

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

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

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

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

(hidden      and-)
(defndynamic and- [xs]
; (defndynamic and- [xs]   ; shorter but currently not entirely stable
;   (if (= 0 (length xs))
;      true
;      (list 'if (car xs) (and- (cdr xs)) false) ))
  (if (= 0 (length xs))
    true
    (if (= 1 (length xs))
      (car xs)
      (list 'if (car xs) (and- (cdr xs)) false) )))
(defmacro and [:rest xs]
  (and- xs))

(hidden      or-)
(defndynamic or- [xs]
;    (if (= 0 (length xs))  ; shorter but currently not entirely stable
;      false
;      (list 'if (car xs) true (or- (cdr xs))) ))
  (if (= 0 (length xs))
    false
    (if (= 1 (length xs))
      (car xs)
      (list 'if (car xs) true (or- (cdr xs))) )))
(defmacro or [:rest xs]
  (or- xs))


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

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

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

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

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

(doc deprecated "Declares that a binding is deprecated, using an optional explanation.")
(defmacro deprecated [name :rest explanation]
  (let [v (if (= (length explanation) 0) true (car explanation))]
    (eval (list 'meta-set! name "deprecated" v))))

(doc defn- "Declares a function while marking it as private and hidden.")
(defmacro defn- [name args form]
  (do
   (eval (list 'private name))
   (eval (list 'hidden name))
   (list 'defn name args form)))

(doc def- "Declares a variable while marking it as private and hidden.")
(defmacro def- [name value]
  (do
   (eval (list 'private name))
   (eval (list 'hidden name))
   (list 'def name value)))

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

(doc cond
     "Executes a block of code if a specified condition is true. Multiple"
     "such blocks can be chained."
     ""
     "```"
     "(cond"
     "  (< 10 1) (println \"Condition 1 is true\")"
     "  (> 10 1) (println \"Condition 2 is true\")"
     "  (println \"Else branch\"))"
     "```")
(defmacro cond [:rest xs]
  (cond-internal xs))

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

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

(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 comment [:rest forms]
  ())

(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 ignore [form]
  (list 'let (array '_ form) (list)))

(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 defdynamic-once "Creates a dynamic variable and sets its value if it's not already defined.")
(defmacro defdynamic-once [var expr]
  (eval
    (list 'if (list 'defined? var)
          ()
          (list 'defdynamic var expr))))

(doc inline-c "Inlines some custom C code.")
(defmacro inline-c [name defcode :rest declcode]
  (eval (list 'deftemplate name (list) defcode (if (empty? declcode) "" (car declcode)))))

(deftemplate bottom (Fn [] a) "$a $NAME()" "$DECL { abort(); }")

(doc unreachable
     "Asserts that a block of code will never be reached. If it is"
     "the program will be aborted with an error message.")
(defmacro unreachable [msg]
  (list 'do
    (list 'IO.println
      (list 'ref
        (list 'fmt "%s:%d:%d: %s"
          (eval (list 'file msg))
          (eval (list 'line msg))
          (eval (list 'column msg))
          msg)))
    (list 'System.abort)
    (list 'bottom)))

(defndynamic implement-declaration [mod interface]
  (list 'implements interface (Symbol.prefix mod interface)))

(doc implements-all
     "Declares functions in mod with names matching `interfaces` as implementations"
     "of those interfaces.")
(defmacro implements-all [mod :rest interfaces]
  (cons 'do (map (curry implement-declaration mod) interfaces)))

(defmodule Unsafe
  (defmodule C
    (defndynamic emit-c-line [append-strings args]
      (let [strs (map (fn [x] (String.concat [x " "])) (map str args))
            arr (collect-into strs array)
            code (String.concat (append append-strings arr))]
      (list 'Unsafe.preproc (list 'Unsafe.emit-c code))))

    (doc pragma
       "Emits a #pragma compiler directive in Carp's c output.")
    (defmacro pragma [:rest args]
      (eval (Unsafe.C.emit-c-line ["#pragma "] args)))

    (doc define
      "Emits a #define compiler directive in Carp's c output.")
    (defmacro define [name value]
      (Unsafe.C.emit-c-line ["#define "] [name value]))

    (doc undef
      "Emits a #undef compiler directive in Carp's c output.")
    (defmacro undef [name]
      (Unsafe.C.emit-c-line ["#undef "] [name]))

    (defndynamic if- [if-pre name then else]
      (do (eval (Unsafe.C.emit-c-line [if-pre] [name]))
          (eval (Unsafe.C.emit-c-line ["  "] [then]))
          (if (not (empty? else))
              (do (eval (Unsafe.C.emit-c-line ["#else"] []))
                  (eval (Unsafe.C.emit-c-line ["  "] else)))
              ())
          (eval (Unsafe.C.emit-c-line ["#endif"] []))))

    (doc ifpre
      "Emits a #if compiler directive in Carp's c output.")
    (defmacro ifpre [name then :rest else]
      (Unsafe.C.if- "#if " name then else))

    (doc ifdef
      "Emits a #ifdef compiler directive in Carp's c output.")
    (defmacro ifdef [name then :rest else]
      (Unsafe.C.if- "#ifdef " name then else))

    (doc ifndef
      "Emits a #ifndef compiler directive in Carp's c output.")
    (defmacro ifndef [name then :rest else]
      (Unsafe.C.if- "#ifndef " name then else))

    (doc warning
      "Emits a #warning compiler directive in Carp's c output.")
    (defmacro warning [message]
      (eval (Unsafe.C.emit-c-line ["#warning "] [message])))

    (doc error
      "Emits a #error compiler directive in Carp's c output.")
    (defmacro error [message]
    (eval (Unsafe.C.emit-c-line ["#error "] [message])))

    (hidden asmify)
    (defndynamic asmify [instruction]
      (if (string? instruction)
        (String.concat ["\"" instruction "\" "])
        (str instruction)))

    (doc asm
      "Allows to define a named ASM construct. It allows both simple and "
      "extended ASM."
      ""
      "Example:"
      "```"
      "; exits with eit code 5, uses macOS syscalls"
      "(Unsafe.C.asm exit5 \"mov $0x2000001, %rax\\n\" \"mov $5, %rdi\\n\" \"syscall\")"
      ""
      "; writes from a variable called src into a variable dst and then adds 1 to dst"
      "(Unsafe.C.asm addr \"mov %1, %0\\n\" \"add $1, %0\\n\" : \"=r\" (dst) : \"r\" (src))"
      "```")
    (defmacro asm [name :rest instructions]
      (do
        (eval (list 'Unsafe.C.define (String.concat [(str name) "()"])
          (String.concat [
            "__asm__("
            (String.concat (collect-into (Dynamic.map Unsafe.C.asmify instructions) array))
            ");"])))
        (eval (list 'register name '(Fn [] ())))))
  )
)