Function: majutsu-template--validate-returns-via
majutsu-template--validate-returns-via is a function defined in
majutsu-template.el.
Signature
(majutsu-template--validate-returns-via FN-NAME RETURNS-VIA ARGS)
Documentation
Validate RETURNS-VIA for FN-NAME against ARGS and return normalized value.
Source Code
;; Defined in /nix/store/jagqw3nms546pad0gxi5f3wsckk6pji7-emacs-packages-deps/share/emacs/site-lisp/majutsu-template.el
(eval-and-compile
(defun majutsu-template--normalize-arg-specialize (fn-name arg-name arg-type specialize)
"Validate SPECIALIZE metadata for FN-NAME ARG-NAME of ARG-TYPE."
(when specialize
(unless (memq specialize '(:element-lambda))
(user-error "majutsu-template-defun %s: argument %s has unknown :specialize %S"
fn-name arg-name specialize))
(unless (eq (majutsu-template--type-ref-base-type arg-type) 'Lambda)
(user-error "majutsu-template-defun %s: argument %s uses :specialize %S but is not Lambda"
fn-name arg-name specialize))))
(defun majutsu-template--parse-arg-options (name opts)
"Internal helper to parse OPTS plist for argument NAME."
(let ((optional nil)
(rest nil)
(doc nil)
(specialize nil))
(while opts
(let ((key (pop opts))
(val (pop opts)))
(pcase key
(:optional (setq optional (not (null val))))
(:rest (setq rest (not (null val))))
(:doc (setq doc val))
(:specialize (setq specialize val))
(_ (user-error "majutsu-template-defun %s: unknown option %S" name key)))))
(list optional rest doc specialize)))
(defun majutsu-template--parse-args (fn-name arg-specs)
"Parse ARG-SPECS for FN-NAME into `majutsu-template--arg' structs.
Also validates placement of optional/rest arguments."
(let ((parsed '())
(rest-seen nil))
(dolist (spec arg-specs)
(unless (and (consp spec) (symbolp (car spec)) (>= (length spec) 2))
(user-error "majutsu-template-defun %s: invalid parameter spec %S" fn-name spec))
(let* ((arg-name (car spec))
(type (cadr spec))
(opts (cddr spec))
(_ (unless (or (symbolp type)
(keywordp type)
(and (consp type)
(memq (car type) '(:list :option :lambda))))
(user-error "majutsu-template-defun %s: argument %s has invalid type %S"
fn-name arg-name type)))
(opt-data (majutsu-template--parse-arg-options arg-name opts))
(optional (nth 0 opt-data))
(rest (nth 1 opt-data))
(doc (nth 2 opt-data))
(specialize (nth 3 opt-data)))
(when (and rest (not (null (cdr (memq spec arg-specs)))))
(user-error "majutsu-template-defun %s: :rest parameter must be last" fn-name))
(when (and rest rest-seen)
(user-error "majutsu-template-defun %s: only one :rest parameter allowed" fn-name))
(when (and rest optional)
(user-error "majutsu-template-defun %s: parameter %s cannot be both optional and :rest"
fn-name arg-name))
(when (and optional rest-seen)
(user-error "majutsu-template-defun %s: optional parameters must precede :rest" fn-name))
(majutsu-template--normalize-arg-specialize fn-name arg-name type specialize)
(when rest (setq rest-seen t))
(push (majutsu-template--make-arg
:name arg-name
:type type
:optional optional
:rest rest
:doc doc
:specialize specialize)
parsed)))
(nreverse parsed)))
(defun majutsu-template--build-lambda-list (args)
"Return lambda list corresponding to ARGS metadata."
(let ((required '())
(optional '())
(rest nil))
(dolist (arg args)
(when (majutsu-template--arg-rest arg)
(when rest
(user-error "majutsu-template: multiple :rest parameters not allowed"))
(setq rest (majutsu-template--arg-name arg)))
(cond
((majutsu-template--arg-rest arg))
((majutsu-template--arg-optional arg)
(push (majutsu-template--arg-name arg) optional))
(t
(push (majutsu-template--arg-name arg) required))))
(setq required (nreverse required)
optional (nreverse optional))
(append required
(when optional (cons '&optional optional))
(when rest (list '&rest rest)))))
(defun majutsu-template--build-arg-normalizers (args)
"Return forms that normalize function parameters described by ARGS."
(cl-loop for arg in args
collect
(let ((name (majutsu-template--arg-name arg)))
(cond
((majutsu-template--arg-rest arg)
`(setq ,name (mapcar #'majutsu-template--rewrite ,name)))
((majutsu-template--arg-optional arg)
`(when ,name (setq ,name (majutsu-template--rewrite ,name))))
(t
`(setq ,name (majutsu-template--rewrite ,name)))))))
(defun majutsu-template--build-arg-type-checks (fn-name args)
"Return forms that validate normalized ARGS for helper FN-NAME."
(cl-loop for arg in args
collect
(let ((name (majutsu-template--arg-name arg))
(type (majutsu-template--arg-type arg)))
(cond
((majutsu-template--arg-rest arg)
`(dolist (majutsu-template--item ,name)
(majutsu-template--assert-node-type ',fn-name ',name ',type
majutsu-template--item)))
((majutsu-template--arg-optional arg)
`(when ,name
(majutsu-template--assert-node-type ',fn-name ',name ',type ,name)))
(t
`(majutsu-template--assert-node-type ',fn-name ',name ',type ,name))))))
(defun majutsu-template--lookup-arg (args name)
"Return argument metadata from ARGS matching NAME, or nil."
(cl-find-if (lambda (arg)
(eq (majutsu-template--arg-name arg) name))
args))
(defun majutsu-template--normalize-returns-via (fn-name returns-via)
"Validate RETURNS-VIA metadata for FN-NAME and return normalized value."
(pcase returns-via
('nil nil)
(`(:list-of-lambda-return ,arg-name)
(unless (symbolp arg-name)
(user-error "majutsu-template-defun %s: :returns-via expects a symbol argument name, got %S"
fn-name arg-name))
returns-via)
(_
(user-error "majutsu-template-defun %s: unsupported :returns-via %S"
fn-name returns-via))))
(defun majutsu-template--validate-returns-via (fn-name returns-via args)
"Validate RETURNS-VIA for FN-NAME against ARGS and return normalized value."
(setq returns-via (majutsu-template--normalize-returns-via fn-name returns-via))
(pcase returns-via
('nil nil)
(`(:list-of-lambda-return ,arg-name)
(let ((arg (majutsu-template--lookup-arg args arg-name)))
(unless arg
(user-error "majutsu-template-defun %s: :returns-via refers to unknown argument %S"
fn-name arg-name))
(unless (eq (majutsu-template--type-ref-base-type
(majutsu-template--arg-type arg))
'Lambda)
(user-error "majutsu-template-defun %s: :returns-via %S requires Lambda argument %S"
fn-name returns-via arg-name))
returns-via))))
(defun majutsu-template--validate-bind-self (fn-name bind-self args)
"Validate BIND-SELF for FN-NAME against ARGS and return its arg metadata."
(when bind-self
(unless (symbolp bind-self)
(user-error "majutsu-template-defun %s: :bind-self expects parameter name, got %S"
fn-name bind-self))
(let ((arg (majutsu-template--lookup-arg args bind-self)))
(unless arg
(user-error "majutsu-template-defun %s: :bind-self parameter %S is not declared"
fn-name bind-self))
(when (majutsu-template--arg-rest arg)
(user-error "majutsu-template-defun %s: :bind-self parameter %S cannot be :rest"
fn-name bind-self))
arg)))
(defun majutsu-template--parse-signature (fn-name signature)
"Parse SIGNATURE plist for FN-NAME, returning plist with metadata."
(unless (and (consp signature) (eq (car signature) :returns) (cadr signature))
(user-error "majutsu-template-defun %s: signature must start with (:returns TYPE ...)" fn-name))
(let ((returns (cadr signature))
(rest (cddr signature))
(doc nil)
(owner nil)
(template-name nil)
(keyword nil)
(bind-self nil)
(returns-via nil))
(unless (or (symbolp returns)
(keywordp returns)
(and (consp returns)
(memq (car returns) '(:list :option :lambda))))
(user-error "majutsu-template-defun %s: invalid return type %S" fn-name returns))
(while rest
(let ((key (pop rest))
(value (pop rest)))
(pcase key
(:doc (setq doc value))
(:owner (setq owner value))
(:template-name (setq template-name value))
(:keyword (setq keyword value))
(:bind-self (setq bind-self value))
(:returns-via (setq returns-via value))
(_ (user-error "majutsu-template-defun %s: unknown signature key %S" fn-name key)))))
(when (and owner
(not (or (symbolp owner)
(keywordp owner)
(and (consp owner)
(memq (car owner) '(:list :option :lambda))))))
(user-error "majutsu-template-defun %s: :owner expects a type ref, got %S" fn-name owner))
(when (and template-name (not (stringp template-name)))
(user-error "majutsu-template-defun %s: :template-name expects string, got %S"
fn-name template-name))
(setq keyword (and keyword (not (null keyword))))
(when (and keyword (not owner))
(user-error "majutsu-template-defun %s: :keyword requires :owner to be specified" fn-name))
(list :returns returns
:doc doc
:owner owner
:template-name template-name
:keyword keyword
:bind-self bind-self
:returns-via returns-via)))
(defun majutsu-template--type-ref-string (type)
"Return readable string form for TYPE reference."
(setq type (majutsu-template--type-ref-normalize type))
(cond
((symbolp type) (symbol-name type))
((and (consp type) (eq (car type) :list))
(format "(:list %s)"
(majutsu-template--type-ref-string (cadr type))))
((and (consp type) (eq (car type) :option))
(format "(:option %s)"
(majutsu-template--type-ref-string (cadr type))))
((and (consp type) (eq (car type) :lambda))
(format "(:lambda (%s) %s)"
(mapconcat #'majutsu-template--type-ref-string (cadr type) " ")
(majutsu-template--type-ref-string (caddr type))))
(t (format "%S" type))))
(defun majutsu-template--compose-docstring (name base-doc args)
"Compose docstring for helper NAME using BASE-DOC and ARGS metadata."
(let ((header (or base-doc (format "Template helper %s." name)))
(param-lines
(when args
(mapconcat
(lambda (arg)
(let ((arg-name (majutsu-template--arg-name arg))
(type (majutsu-template--arg-type arg))
(optional (majutsu-template--arg-optional arg))
(rest (majutsu-template--arg-rest arg))
(doc (majutsu-template--arg-doc arg)))
(concat " " (symbol-name arg-name)
" (" (majutsu-template--type-ref-string type) ")"
(cond
(rest " [rest]")
(optional " [optional]")
(t ""))
(if doc
(format ": %s" doc)
""))))
args
"\n"))))
(if param-lines
(concat header "\n\nParameters:\n" param-lines)
header)))
(defun majutsu-template--ensure-owner-type (owner fn-name)
"Validate declared OWNER type for callable FN-NAME when provided."
(when owner
(setq owner (majutsu-template--type-ref-normalize owner))
(unless (majutsu-template--lookup-type
(majutsu-template--type-ref-base-type owner))
(message "majutsu-template: warning – declaring %s for unknown type %S"
fn-name owner)))
owner)
(defun majutsu-template-def--inherit-signature (signature owner &optional keyword)
(append signature
(list :owner owner)
(when keyword '(:keyword t))))
(defun majutsu-template-def--owned-meta-form (name owner args signature &optional keyword)
"Return metadata-construction form for owner-bound callable NAME.
OWNER is the receiver type, ARGS are parameters after the implicit SELF, and
SIGNATURE is the declaration plist accepted by `majutsu-template-defun'."
(let* ((signature-info (majutsu-template--parse-signature
name
(majutsu-template-def--inherit-signature signature owner keyword)))
(bind-self (plist-get signature-info :bind-self)))
(when bind-self
(user-error "majutsu-template: owner-bound callables such as %s do not support :bind-self; use majutsu-template-defun instead"
name))
(let* ((owner (majutsu-template--ensure-owner-type
(plist-get signature-info :owner)
name))
(template-name (or (plist-get signature-info :template-name)
(symbol-name name)))
(keyword-flag (plist-get signature-info :keyword))
(parsed-args (majutsu-template--parse-args
name
(cons `(self ,owner) args)))
(returns-via (majutsu-template--validate-returns-via
name
(plist-get signature-info :returns-via)
parsed-args))
(return-type (plist-get signature-info :returns))
(docstring (majutsu-template--compose-docstring
template-name
(plist-get signature-info :doc)
parsed-args)))
`(majutsu-template--make-fn
:name ,template-name
:symbol 'majutsu-template--method-stub
:args ',parsed-args
:returns ',return-type
:returns-via ',returns-via
:doc ,docstring
:owner ',owner
:keyword ',keyword-flag)))))