(chapter-start 'nydp/syntax "Provides core nydp keywords and syntax, including lazy
boolean expressions, special syntax for symbols and lists, special macros for
scoping, assignment, anonymous functions and more...")

(mac and args
  ; returns last arg if all 'args evaluate to non-nil
  ; nil otherwise
  (if args
      (if (cdr args)
          `(if ,(car args) (and ,@(cdr args)))
          (car args))
      't))

(def orf args
  ; evaluates each arg in 'args, returns the
  ; first non-nil value, or nil if they are
  ; all nil
  (cond args
        (cond (car args)
              (car args)
              (apply orf
                     (cdr args)))))

(def caris (obj things)
  ; returns true if 'things is a list and the first item of the
  ; list is the given object
  (and (pair? things)
       (eq? (car things)  obj)))

(mac unless (arg . body)
  ; evaluate 'body if 'arg is nil
  `(if (no ,arg) (do ,@body)))

(def expand-colon-syntax (names)
  (if (no (cdr names))
          `(apply ,(car names) args)
          `(,(car names) ,(expand-colon-syntax (cdr names)))))

(def default-colon-syntax (names)
  `(fn args ,(expand-colon-syntax names)))

(assign colon-syntax-overrides (hash))

(mac def-colon-syntax (name var . body)
  `(hash-set colon-syntax-overrides
             ',name
             (fn (,var) ,@body)))

(def-colon-syntax || names
  (error "Irregular ': syntax: got ~(inspect names) : not prefix-syntax : in ~(join-str (car names) ":" (cdr names))"))

(mac colon-syntax names
  ; handle syntax of the form a:b, which the parser expands to
  ; (colon-syntax a b). By default, this complains if colon is used
  ; as a prefix (ie it disallows ":foo"), otherwise creates a new
  ; function which is the composition of the functions named in its
  ; arguments. For example,
  ; (count:parts spaceship) is the same as (count (parts spaceship))
  ((orf (hash-get colon-syntax-overrides (car names))
        default-colon-syntax)
   names))

(mac bang-syntax (pfx . rest)
  ; handle syntax of the form !x, which the parser expands to
  ; (bang-syntax || x). By default, this complains if there is
  ; a non-empty prefix (ie it disallows x!y), otherwise it creates
  ; a new function which is the negation of the given named function.
  ; For example,
  ; (!eq? a 10) is the same as (no:eq? a 10), which is the same as (no (eq? a 10))
  (if (no (eq? pfx '||))
      (error "Irregular '! syntax: got prefix ~(inspect pfx) in ~(join-str pfx "!" rest)"))
  (if (cdr rest)
      (error "Irregular '! syntax: got suffix ~(inspect (cdr rest)) in ~(join-str pfx "!" rest)")
      (if (caris 'colon-syntax (car rest))
          `(colon-syntax no ,@(cdar rest))
          `(colon-syntax no ,(car rest)))))

(mac when (condition . body)
  `(cond ,condition (do ,@body)))

(def pairs (things)
  (if (no things)       nil
      (no (cdr things)) (list (list (car things)))
      (cons (list (car things) (cadr things))
            (pairs (cddr things)))))

(mac with (parms . body)
     `((fn ,(map car (pairs parms))
           ,@body)
       ,@(map cadr (pairs parms))))

(mac let (var val . body)
     `(with (,var ,val) ,@body))

(mac rfn (name parms . body)
  ; creates a named, locally-scoped function
  ; with the given parameter names. It is possible
  ; to reference the function by its name from within
  ; the function (to pass as an argument or for
  ; recursive invocation)
  `(let ,name nil
     (assign ,name (fn ,parms ,@body))))

(mac afn (parms . body)
  ; same as 'rfn, but using the name 'self
  `(rfn self ,parms ,@body))

(mac rfnwith (name params . body)
  ; a mix of rfn and with; creates a locally-scoped named function with
  ; the given parameter names, and invokes it with the given parameter
  ; values. It is possible to reference the function by its name from
  ; within the function (to pass as an argument or for recursive
  ; invocation)
  (let ppairs (pairs params)
    `(let ,name nil
       (assign ,name (fn ,(map car ppairs) ,@body))
       (,name ,@(map cadr ppairs)))))

(let uniq-counter 0
  (def uniq (prefix)
    (assign uniq-counter (+ uniq-counter 1))
    (sym (join-str prefix "-" (list uniq-counter))))
  (def reset-uniq-counter ()
    (assign uniq-counter 0)))

(mac w/uniq (vars . body)
  ; creates a lexical scope with a unique symbol assigned to
  ; each variable in 'vars ; executes the 'body.
  (if (pair? vars)
      `(with ,(apply + (map (fn (n) (list n '(uniq ',n))) vars))
             ,@body)
      `(let ,vars (uniq ',vars) ,@body)))

(mac or args
  ; lazy-evaluates each argument, returns the first
  ; non-nil result, or nil if all evaluate to nil.
  (cond args
        (w/uniq ora
                `(let ,ora ,(car args)
                   (cond ,ora ,ora (or ,@(cdr args)))))))

(mac pop (xs)
     (w/uniq gp
             `(let ,gp (car ,xs)
                   (assign ,xs (cdr ,xs))
                   ,gp)))

(def build-keyword-args (pairs)
  (map (fn (ab) `(list (quote ,(car ab)) ,@(cdr ab))) pairs))

(def build-hash-get-key (name)
  (if (pair? name)
      (if (caris 'unquote name)
          (cadr name)
          name)
      (list 'quote name)))

(def build-hash-getters (names acc)
  ;; (build-hash-getters '(a b c)) => (hash-get (hash-get a 'b) 'c)
  (if (no acc)
      (build-hash-getters (cdr names) (car names))
      names
      (build-hash-getters (cdr names) `(hash-get ,acc ,(build-hash-get-key (car names))))
      acc))

(def build-hash-lookup-from (root names)
  (build-hash-getters (cons root names) nil))

(mac hash-lookup (names)
  (build-hash-getters names nil))

(mac dot-syntax names
  ; parser expands a.b to (dot-syntax a b)
  `(hash-lookup ,names))

(mac dollar-syntax (_ name)
  ; parser expands a$b to (dollar-syntax a b)
  `(,name))

(def dot-syntax-assignment (names value-expr)
  (let rnames (rev names)
    `(hash-set ,(build-hash-getters (rev (cdr rnames)) nil)
               ,(build-hash-get-key:car rnames)
               ,value-expr)))

(def hash-get-assignment (lookup value)
  `(hash-set ,@lookup ,value))

(mac = (name value)
  ; generic assignment which unlike builtin 'assign, knows how to assign
  ; to hash keys
  (if (isa 'symbol name)
      `(assign ,name ,value)
      (caris 'dot-syntax name)
      (dot-syntax-assignment (cdr name) value)
      (caris 'hash-get name)
      (hash-get-assignment (cdr name) value)))

(mac def-assign args
  ; override previous definition to allow expressions like (def hsh.foo (arg arg2) ...)
  `(= ,@args))

(mac or= (place val)
  ; evaluate ,val and assign result to ,place only if ,place is already nil
  `(or ,place (= ,place ,val)))

(def brace-list-hash-key (k)
  (if (isa 'symbol k)      `(quote ,k)
      (caris 'unquote k)   (cadr k)
      k))

(def brace-list-build-hash (args)
  (w/uniq hash
    (let mappings (pairs args)
      `(let ,hash (hash)
            ,@(map (fn (m) `(hash-set ,hash ,(brace-list-hash-key (car m)) ,(cadr m))) mappings)
            ,hash))))

(def build-ampersand-syntax (arg)
  (if (caris 'dot-syntax arg)
      `(fn (obj) ,(build-hash-lookup-from 'obj (cdr arg)))
      `(fn (obj) ,(build-hash-lookup-from 'obj (list arg)))))

(mac ampersand-syntax (pfx . rest)
  ; parser expands a&b to (ampersand-syntax a b)
  (if (no (eq? pfx '||))
      (error "Irregular '& syntax: got prefix ~(inspect pfx) in ~(join-str pfx "&" rest)"))
  (if (cdr rest)
      (error "Irregular '& syntax: got suffix ~(inspect (cdr rest)) in ~(join-str pfx "&" rest)")
      (build-ampersand-syntax (car rest))))

(mac brace-list-mono (arg)
  ; override 'brace-list-mono in order to provide a useful interpretation for "{ x }" syntax
  arg)

(mac brace-list-empty ()
  ; interprets "{ }" as new hash
  '(hash))

(mac brace-list args
  ; parser expands { foo bar } to (brace-list foo bar)
  (if (no args)
      `(brace-list-empty)
      (no (cdr args))
      `(brace-list-mono ,(car args))
      (brace-list-build-hash args)))

(mac returnlet (var val . body)
  ; stores ,val in ,var, executes ,@body, returns ,var. Saves a line of code at the end of
  ; 'let. Assumes 'body is going to do something destructive with 'val, but you want 'val before
  ; it gets changed. See also 'returning
  `(let ,var ,val ,@body ,var))

(mac returning (val . body)
  ; stores ,val, executes ,@body, and returns ,val. Assumes 'body is going to do something
  ; destructive with 'val, but you want 'val before it gets changed. See also 'returnlet
  (w/uniq retval `(returnlet ,retval ,val ,@body)))