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

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

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

; looks up a key in @
; assumes local lexical context has defined a hash called '@
(mac prefix-at-syntax (name . names)
  `(hash-get @ ',name))

(mac at-syntax names
  (if (eq? (car names) '||)
      `(prefix-at-syntax ,@(cdr names))
      (error "unknown at-syntax: expected prefix-syntax (eg @name), got ~(join-str (car names) "@" (cdr names))")))

(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)
     `((fun ,(map car (pairs parms))
            ,@body)
       ,@(map cadr (pairs parms))))

;; same as ( (fn (var) body) val ) -> ie create a lexical scope
;; where val is assigned to var, execute 'body in that scope
(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 (fun ,(map car ppairs) ,@body))
       (,name ,@(map cadr ppairs)))))

;; (andify a b c) is equivalent to
;; (fn args (and (apply a args) (apply b args) (apply c args)))
;; or more simply
;; (fn (x) (and (a x) (b x) (c x)))
;; note: alias as 'andf ??
(def andify args
  (fn args2 (rfnwith self (ands args)
                     (if ands (if (apply (car ands) args2)
                                  (self (cdr ands)))
                         t))))

(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) `(,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.
  (if (cdr args)
      (let arg (car args)
        (if (isa 'symbol arg)
            `(cond ,arg ,arg (or ,@(cdr args)))
            (w/uniq ora
                    `(let ,ora ,arg
                       (cond ,ora ,ora (or ,@(cdr args)))))))
      (car 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))

(def ampersand-expression? (name)
  (and (pair? name)
       (caris 'ampersand-syntax (car name))))

(def ampersand-expression-assignment (place value)
  ; (= (&key (expr)) (val))
  ; (= ((ampersand-syntax key) (expr)) (val))
  ; 'place is ((ampersand-syntax || key) (expr))
  ; we need (hash-set (expr) 'key (val))
  ; however,
  ; (= (&key.subkey (expr)) (val))
  ; 'place is ((ampersand-syntax || (dot-syntax key subkey)) (expr))
  ; we need (hash-set (hash-get (expr) 'key) 'subkey (val))
  (with (k   (cadr:cdar place)
         hsh (cadr place))
    (if (caris 'dot-syntax k)
        (dot-syntax-assignment (cons hsh (cdr k)) value)
        `(hash-set ,hsh ',k ,value))))

(mac = (name value)
  ; generic assignment which unlike builtin 'assign, knows how to assign
  ; to hash keys
  ; (= (hash-get (expr) 'key) (val) => (hash-set (expr) 'key (val))
  ; (= h.k (val))                   => (hash-set h 'k (val))
  ; (= h.j.k (val))                 => (hash-set (hash-get h 'j) 'k (val))
  ; (= (&key (expr)) (val))         => (hash-set (expr) 'key (val))
  ; (= (&j.k (expr)) (val))         => (hash-set (hash-get (expr) 'j) 'k (val))
  (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)
      (ampersand-expression? name)
      (ampersand-expression-assignment name value)
      (caris 'at-syntax name)
      `(hash-set @ ',(caddr name) ,value)
      (error "unknown assignment to place: ~(inspect name)")))

;; quiet assignment ; like =, but expression returns nil
(mac #= (name value)
  `(do (= ,name ,value) nil))

; increment the value at 'place by 'inc (default 1)
(mac ++ (place inc) `(= ,place (+ ,place ,(or inc 1))))

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

; evaluate ,val and assign result to ,place only if ,place is already nil
(mac or= (place val) `(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))))

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

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

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

; stores ,val in ,var, executes ,@body, returns ,var. Saves a line of code at the end of
; 'let. If 'body assigns to 'var, the assigned value of 'var will be returned. See also 'returning
(mac returnlet (var val . body) `(let ,var ,val ,@body ,var))

; 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. Note that if 'val is mutated
; (eg hash), the mutated value will be returned. See also 'returnlet
(mac returning (val . body) (w/uniq retval `(returnlet ,retval ,val ,@body)))

(mac ifv (var expr . body)
  `(let ,var ,expr
     (if ,var
         ,@(if (cddr body)
               `(,(car body) (ifv ,var ,@(cdr body)))
               body))))

; like if, except the value of each condition is locally bound to the variable 'it
; eg (aif (find thing) (show it))
; source: arc.arc
(mac aif (expr . body)
  `(ifv it ,expr ,@body))

(def destructure/with (var args n)
  ; provides the argument expression to 'with when
  ; destructuring arguments are present in a 'fun definition
  (if (pair? args)
      `(,(car args) (nth ,n ,var) ,@(destructure/with var (cdr args) (+ n 1)))
      args
      `(,args (nthcdr ,n ,var))))

(def destructure/build (given-args new-args body)
  ; used internally by 'fun
  (if (pair? given-args)
      (if (sym? (car given-args))
          (destructure/build (cdr given-args)
                             (cons (car given-args) new-args)
                             body)
          (w/uniq destructure
                  (destructure/build (cdr given-args)
                                     (cons destructure new-args)
                                     `((with ,(destructure/with destructure (car given-args) 0) ,@body)))))
      `(fn ,(rev new-args given-args) ,@body)))


(def fun/approve-arg-names (orig args body)
  (if (pair? args)
      (do (fun/approve-arg-names orig (car args) body)
          (fun/approve-arg-names orig (cdr args) body))
      args
      (if (hash-get macs args)
          (warnings/new 'arg-shadows-macro "arg " args " shadows macro " args " in arg list " orig " and body " body))))

;; build a 'fn form, changing 'args and 'body to
;; properly handle any destructuring args if present
(mac fun (args . body)
  (fun/approve-arg-names args args body)
  (destructure/build args nil body))

;; assign (f place) to place
(mac zap (f place . args)
  `(= ,place (,f ,place ,@args)))