cl-ds / src /cl_macros /knowledge_base.py
CL macro fine-tuning dataset: src
a383597 verified 6 months ago
33.4 kB
"""Curated macro transformation examples — exact macro definitions from
the Let Over Lambda source repository (thephoeron/let-over-lambda).
Each entry has the verified defmacro form from the production repo.
Uses raw triple-quoted strings (r\"\"\") for CL code to avoid escaping issues.
"""

from cl_macros.schema import (
    Complexity,
    MacroCategory,
    MacroTechnique,
    Source,
    TransformationExample,
)

# ============================================================
# 1. defmacro/g! — Automatic gensym generation
# ============================================================

_gbang_macro = r"""(defun g!-symbol-p (s)
  (and (symbolp s)
       (> (length (symbol-name s)) 2)
       (string= (symbol-name s)
                "G!"
                :start1 0
                :end1 2)))
(defmacro defmacro/g! (name args &rest body)
  (let ((syms (remove-duplicates
               (remove-if-not #'g!-symbol-p
                              (flatten body)))))
    (multiple-value-bind (body declarations docstring)
        (parse-body body :documentation t)
      `(defmacro ,name ,args
         ,@(when docstring
             (list docstring))
         ,@declarations
         (let ,(mapcar
                (lambda (s)
                  `(,s (gensym ,(subseq
                                 (symbol-name s)
                                 2))))
                syms)
           ,@body)))))"""

_gbang_before = r""";; Manual gensym creation is boilerplate-heavy
(defmacro with-temp (var &body body)
  (let ((g (gensym)))
    `(let ((,g ,var))
       ,@body)))
;; Every macro needs this pattern - repetitive and error-prone"""

_gbang_after = r""";; Usage:
;; (defmacro/g! with-temp (g!var &body body)
;;   `(let ((,g!var ,g!var))
;;      ,@body))
;;
;; g!var is automatically gensym'd to #:VAR1234 at expansion time
;; No capture risk - gensym is uninterned"""

G_BANG = TransformationExample(
    id="lol-defmacro-g",
    before_code=_gbang_before,
    problem_pattern="Repeated gensym boilerplate in macro definitions — want automatic gensym creation from naming convention",
    macro_definition=_gbang_macro,
    after_expansion=_gbang_after,
    macro_category=MacroCategory.CAPTURE_MANAGEMENT,
    technique=[MacroTechnique.GENSYM, MacroTechnique.CODE_WALKING],
    source=Source.LET_OVER_LAMBDA,
    source_chapter="ch3",
    complexity=Complexity.ADVANCED,
    has_capture_risk=False,
    requires_gensyms=True,
    commentary="Scans macro body for G!-prefixed symbols, creates gensym bindings at expansion time. Uses alexandria:parse-body for proper docstring/declaration handling. This is NOT hygienic macros — it's automatic gensym generation in full Lisp.",
)

# ============================================================
# 2. defmacro! — Automatic once-only + gensym
# ============================================================

_defmacrobang_macro = r"""(defun o!-symbol-p (s)
  (and (symbolp s)
       (> (length (symbol-name s)) 2)
       (string= (symbol-name s)
                "O!"
                :start1 0
                :end1 2)))
(defun o!-symbol-to-g!-symbol (s)
  (symb "G!"
        (subseq (symbol-name s) 2)))
(defmacro defmacro! (name args &rest body)
  (let* ((os (remove-if-not #'o!-symbol-p (flatten args)))
         (gs (mapcar #'o!-symbol-to-g!-symbol os)))
    (multiple-value-bind (body declarations docstring)
        (parse-body body :documentation t)
      `(defmacro/g! ,name ,args
         ,@(when docstring
            (list docstring))
         ,@declarations
         `(let ,(mapcar #'list (list ,@gs) (list ,@os))
            ,(progn ,@body))))))"""

_defmacrobang_before = r""";; Macro with double-evaluation bug
(defmacro square (x)
  `(* ,x ,x))
;; (square (incf y)) evaluates (incf y) TWICE
;; Manual fix requires gensym + let boilerplate every time
(defmacro square (x)
  (let ((g (gensym)))
    `(let ((,g ,x))
       (* ,g ,g))))"""

_defmacrobang_after = r""";; (defmacro! square (o!x)
;;   `(* ,g!x ,g!x))
;;
;; (macroexpand '(square (incf y)))
;; => (LET ((#:X1633 (INCF Y)))
;;      (* #:X1633 #:X1633))
;;
;; o!x = original form (still accessible via ',o!x)
;; g!x = evaluated value, bound once"""

DEFMACRO_BANG = TransformationExample(
    id="lol-defmacro-bang",
    before_code=_defmacrobang_before,
    problem_pattern="Macro arguments evaluated multiple times (double evaluation) — need automatic once-only that also provides both original form and evaluated value",
    macro_definition=_defmacrobang_macro,
    after_expansion=_defmacrobang_after,
    macro_category=MacroCategory.CAPTURE_MANAGEMENT,
    technique=[MacroTechnique.ONCE_ONLY, MacroTechnique.GENSYM],
    source=Source.LET_OVER_LAMBDA,
    source_chapter="ch3",
    complexity=Complexity.ADVANCED,
    has_capture_risk=False,
    requires_gensyms=True,
    commentary="O!-prefixed args trigger once-only: argument form evaluated exactly once, result bound to corresponding G!-prefixed gensym. The O! symbol still names the original unevaluated form (accessible via quote). Builds on top of defmacro/g!.",
)

# ============================================================
# 3. aif — Anaphoric if (Graham)
# ============================================================

_aif_macro = r"""(defmacro aif (test then &optional else)
  `(let ((it ,test))
     (if it ,then ,else)))"""

_aif_before = r""";; Common pattern: test a value, use result in then-branch
(let ((result (compute-something)))
  (if result
      (format t "Got: ~a~%" result)
      :nothing))
;; Want: implicit 'it' bound to test result"""

_aif_after = r""";; (aif (compute-something)
;;      (format t "Got: ~a~%" it)
;;      :nothing)
;; Expands to:
;; (LET ((IT (COMPUTE-SOMETHING)))
;;   (IF IT
;;       (FORMAT T "Got: ~a~%" IT)
;;       :NOTHING))"""

AIFF = TransformationExample(
    id="lol-aif",
    before_code=_aif_before,
    problem_pattern="Repeated pattern of binding test result then branching on it — want implicit 'it' anaphor",
    macro_definition=_aif_macro,
    after_expansion=_aif_after,
    macro_category=MacroCategory.ANAPHORIC,
    technique=[MacroTechnique.ANAPHOR],
    source=Source.LET_OVER_LAMBDA,
    source_chapter="ch6",
    complexity=Complexity.BASIC,
    has_capture_risk=True,
    requires_gensyms=False,
    commentary="Paul Graham's classic anaphoric if. Deliberately captures 'it' so the then-clause can reference the test result. This is intentional free variable injection — the user must know 'it' exists.",
)

# ============================================================
# 4. alambda — Anaphoric lambda (Graham)
# ============================================================

_alambda_macro = r"""(defmacro alambda (parms &body body)
  `(labels ((self ,parms ,@body))
     #'self))"""

_alambda_before = r""";; Anonymous recursion requires explicit labels every time
(labels ((self (n)
           (if (> n 0)
             (cons n (self (- n 1)))
             nil)))
  #'self)
;; labels boilerplate obscures the recursive logic"""

_alambda_after = r""";; (alambda (n)
;;   (if (> n 0)
;;     (cons n (self (- n 1)))
;;     nil))
;; Expands to:
;; (LABELS ((SELF (N)
;;            (IF (> N 0)
;;              (CONS N (SELF (- N 1)))
;;              NIL)))
;;   #'SELF)"""

ALAMBDA = TransformationExample(
    id="lol-alambda",
    before_code=_alambda_before,
    problem_pattern="Need anonymous recursion without writing labels boilerplate — want implicit 'self' for recursion",
    macro_definition=_alambda_macro,
    after_expansion=_alambda_after,
    macro_category=MacroCategory.ANAPHORIC,
    technique=[MacroTechnique.ANAPHOR],
    source=Source.LET_OVER_LAMBDA,
    source_chapter="ch6",
    complexity=Complexity.BASIC,
    has_capture_risk=True,
    requires_gensyms=False,
    commentary="Anaphoric lambda: captures 'self' to enable recursion in anonymous functions. The function body can call (self ...) to recurse. Used as a building block for more complex anaphoric macros.",
)

# ============================================================
# 5. dlambda — Dispatching lambda
# ============================================================

_dlambda_macro = r"""(defmacro! dlambda (&rest ds)
  `(lambda (&rest ,g!args)
     (case (car ,g!args)
       ,@(mapcar
           (lambda (d)
             `(,(if (eq t (car d))
                  t
                  (list (car d)))
               (apply (lambda ,@(cdr d))
                      ,(if (eq t (car d))
                         g!args
                         `(cdr ,g!args)))))
           ds))))"""

_dlambda_before = r""";; Manual dispatch by keyword with multiple lambdas is repetitive
(let ((count 0))
  (setf (symbol-function 'counter)
        (lambda (&rest args)
          (case (car args)
            (:inc (apply (lambda (n) (incf count n)) (cdr args)))
            (:dec (apply (lambda (n) (decf count n)) (cdr args)))
            (:reset (progn (setf count 0) nil))
            (t (error "Unknown: ~a" (car args)))))))
;; Every method: keyword, lambda wrapper, arg destructuring - repetitive"""

_dlambda_after = r""";; (dlambda
;;   (:inc (n) (incf count n))
;;   (:dec (n) (decf count n))
;;   (:reset () (setf count 0))
;;   (t (&rest args) (format t "Unknown: ~a~%" args)))
;;
;; Expands to a single lambda with case dispatch.
;; Each method has its own destructured argument list.
;; t as the key provides a default/catch-all."""

DLAMBDA = TransformationExample(
    id="lol-dlambda",
    before_code=_dlambda_before,
    problem_pattern="Repeated keyword-dispatch with automatic argument destructuring — each keyword maps to a lambda with its own parameter list",
    macro_definition=_dlambda_macro,
    after_expansion=_dlambda_after,
    macro_category=MacroCategory.DISPATCH,
    technique=[MacroTechnique.DLAMBDA, MacroTechnique.GENSYM],
    source=Source.LET_OVER_LAMBDA,
    source_chapter="ch5",
    complexity=Complexity.INTERMEDIATE,
    has_capture_risk=False,
    requires_gensyms=True,
    commentary="Dispatching lambda: compact syntax for building closures with keyword-dispatch. Each clause is (keyword arglist body...). Uses defmacro! for hygiene. Combines case, lambda, and apply into a closure-building DSL.",
)

# ============================================================
# 6. alet — Anaphoric let with indirection
# ============================================================

_alet_macro = r"""(defmacro alet (letargs &rest body)
  `(let ((this) ,@letargs)
     (setq this ,@(last body))
     ,@(butlast body)
     (lambda (&rest params)
       (apply this params))))"""

_alet_before = r""";; Building a closure with mutable behavior requires manual forwarding
(let ((counter 0)
      (impl (lambda (n) (incf counter n))))
  (lambda (&rest args)
    (apply impl args)))
;; To change behavior: build an entirely new closure"""

_alet_after = r""";; (alet ((acc 0))
;;   (format t "Initialized~%")
;;   (lambda (n) (incf acc n)))
;;
;; Returns a forwarding closure where 'this' can be swapped.
;; The lambda inside can (setq this #'new-fn) to hotpatch."""

ALET = TransformationExample(
    id="lol-alet",
    before_code=_alet_before,
    problem_pattern="Need mutable closure behavior changeable at runtime, with implicit 'this' pointing to current implementation",
    macro_definition=_alet_macro,
    after_expansion=_alet_after,
    macro_category=MacroCategory.ANAPHORIC,
    technique=[MacroTechnique.ANAPHOR],
    source=Source.LET_OVER_LAMBDA,
    source_chapter="ch6",
    complexity=Complexity.INTERMEDIATE,
    has_capture_risk=True,
    requires_gensyms=False,
    commentary="Anaphoric let: introduces 'this' bound to last body form, returns a forwarding closure. Enables runtime behavior swapping (hotpatching) without rebuilding the closure. The indirection through apply enables dynamic dispatch.",
)

# ============================================================
# 7. pandoriclet — Pandora's box closure
# ============================================================

_pandoriclet_macro = r"""(defun pandoriclet-get (letargs)
  `(case sym
     ,@(mapcar #`((,(car a1)) ,(car a1))
               letargs)
     (t (error
          "Unknown pandoric get: ~a"
          sym))))
(defun pandoriclet-set (letargs)
  `(case sym
     ,@(mapcar #`((,(car a1))
                   (setq ,(car a1) val))
               letargs)
     (t (error
          "Unknown pandoric set: ~a"
          sym val))))
(defmacro pandoriclet (letargs &rest body)
  (let ((letargs (cons
                   '(this)
                   (let-binding-transform
                     letargs))))
    `(let (,@letargs)
       (setq this ,@(last body))
       ,@(butlast body)
       (dlambda
         (:pandoric-get (sym)
           ,(pandoriclet-get letargs))
         (:pandoric-set (sym val)
           ,(pandoriclet-set letargs))
         (t (&rest args)
           (apply this args))))))"""

_pandoriclet_before = r""";; Closure variables are opaque - can't inspect or modify them
(let ((acc 0) (mul 1))
  (lambda (n)
    (incf acc n)
    (setf mul (* mul n))))
;; To access acc/mul: must add specific getter/setter methods
;; This doesn't scale - every variable needs its own accessor"""

_pandoriclet_after = r""";; (pandoriclet ((acc 0) (mul 1))
;;   (lambda (n) (incf acc n) (setf mul (* mul n))))
;;
;; Now:
;; (closure :pandoric-get 'acc)    => value of acc
;; (closure :pandoric-set 'acc 100) => sets acc to 100
;; (closure 5)                      => normal call
;;
;; with-pandoric makes them look like regular variables:
;; (with-pandoric (acc mul) closure
;;   (setf acc (+ acc 10)))"""

PANDORICLET = TransformationExample(
    id="lol-pandoriclet",
    before_code=_pandoriclet_before,
    problem_pattern="Closure internals are opaque — want a general protocol for reading/writing any closed-over variable",
    macro_definition=_pandoriclet_macro,
    after_expansion=_pandoriclet_after,
    macro_category=MacroCategory.DISPATCH,
    technique=[MacroTechnique.DLAMBDA, MacroTechnique.NESTED_BACKQUOTE, MacroTechnique.ANAPHOR],
    source=Source.LET_OVER_LAMBDA,
    source_chapter="ch6",
    complexity=Complexity.ADVANCED,
    has_capture_risk=False,
    requires_gensyms=False,
    commentary="Pandoric macros: combine dlambda dispatch with a protocol for reading/writing closure internals. Named after Pandora's box — opening the closure. The #` (sharp-backquote) read macro provides compact lambda syntax in the helper functions.",
)

# ============================================================
# 8. with-pandoric — Transparent pandoric variable access
# ============================================================

_with_pandoric_macro = r"""(defun get-pandoric (box sym)
  (funcall box :pandoric-get sym))
(defsetf get-pandoric (box sym) (val)
  `(progn
     (funcall ,box :pandoric-set ,sym ,val)
     ,val))
(defmacro with-pandoric (syms box &rest body)
  (let ((g!box (gensym "box")))
    `(let ((,g!box ,box))
       (declare (ignorable ,g!box))
       (symbol-macrolet
         (,@(mapcar #`(,a1 (get-pandoric ,g!box ',a1))
                    syms))
         ,@body))))"""

_with_pandoric_before = r""";; Accessing pandoric variables requires verbose funcall
(let ((sum (funcall box :pandoric-get 'sum))
      (count (funcall box :pandoric-get 'count)))
  (format t "sum=~a count=~a~%" sum count))
;; Setting is even worse:
(progn
  (funcall box :pandoric-set 'sum new-value)
  new-value)
;; Want: regular variable syntax for pandoric access"""

_with_pandoric_after = r""";; (with-pandoric (sum count) #'counter
;;   (format t "sum=~a count=~a~%" sum count)
;;   (incf sum 10)
;;   (setf count 0))
;;
;; Expands to:
;; (SYMBOL-MACROLET
;;   ((SUM (GET-PANDORIC #:BOX123 'SUM))
;;    (COUNT (GET-PANDORIC #:BOX123 'COUNT)))
;;   (FORMAT T "sum=~a count=~a~%" SUM COUNT)
;;   (INCF SUM 10)
;;   (SETF COUNT 0))
;;
;; Reading SUM expands to (GET-PANDORIC ... 'SUM)
;; Writing SUM expands to setf -> get-pandoric setf expander"""

WITH_PANDORIC = TransformationExample(
    id="lol-with-pandoric",
    before_code=_with_pandoric_before,
    problem_pattern="Pandoric get/set requires verbose keyword funcalls — want transparent variable syntax using symbol-macrolet",
    macro_definition=_with_pandoric_macro,
    after_expansion=_with_pandoric_after,
    macro_category=MacroCategory.DISPATCH,
    technique=[MacroTechnique.SYMBOL_MACROLET, MacroTechnique.DEFSETF, MacroTechnique.GENSYM],
    source=Source.LET_OVER_LAMBDA,
    source_chapter="ch6",
    complexity=Complexity.ADVANCED,
    has_capture_risk=False,
    requires_gensyms=True,
    commentary="Uses symbol-macrolet to make pandoric variables look like regular lexical variables. The duality of syntax — same variable syntax for two completely different mechanisms. defsetf enables setf and incf/decf to work transparently.",
)

# ============================================================
# 9. nlet-tail — Guaranteed tail-call via tagbody/go
# ============================================================

_nlet_tail_macro = r"""(defmacro! nlet-tail (n letargs &body body)
  (let ((gs (loop for i in letargs
               collect (gensym))))
    `(macrolet
         ((,n ,gs
            `(progn
               (psetq
                ,@(apply #'nconc
                         (mapcar
                          #'list
                          ',(mapcar #'car letargs)
                          (list ,@gs))))
               (go ,',g!n))))
       (block ,g!b
         (let ,letargs
           (tagbody
              ,g!n (return-from
                    ,g!b (progn ,@body))))))))"""

_nlet_tail_before = r""";; Recursive factorial - stack overflow on large N in CL
;; (CL does not guarantee tail-call optimization)
(defun fact (n)
  (labels ((iter (n acc)
             (if (zerop n)
               acc
               (iter (- n 1) (* n acc)))))
    (iter n 1)))
;; (fact 1000000) => stack overflow on most implementations"""

_nlet_tail_after = r""";; (defun fact (n)
;;   (nlet-tail fact ((n n) (acc 1))
;;     (if (zerop n)
;;       acc
;;       (fact (- n 1) (* acc n)))))
;;
;; "Calling" (fact ...) expands via macrolet to:
;; (progn (psetq n (- n 1) acc (* acc n)) (go #:TAG))
;; = a jump, not a function call. Zero stack consumption."""

NLET_TAIL = TransformationExample(
    id="lol-nlet-tail",
    before_code=_nlet_tail_before,
    problem_pattern="Need guaranteed tail-call elimination for recursive algorithms — CL doesn't mandate TCO",
    macro_definition=_nlet_tail_macro,
    after_expansion=_nlet_tail_after,
    macro_category=MacroCategory.CONTROL_FLOW,
    technique=[MacroTechnique.MACROLET, MacroTechnique.TAGBODY, MacroTechnique.GENSYM],
    source=Source.LET_OVER_LAMBDA,
    source_chapter="ch5",
    complexity=Complexity.ADVANCED,
    has_capture_risk=False,
    requires_gensyms=True,
    commentary="Guaranteed tail calls via code-walking. The local macrolet redefines the function name to expand into psetq + go — a jump into tagbody, not a function call. No stack frame allocated. The 'call site' looks like a function call but compiles to a goto.",
)

# ============================================================
# 10. sortf — Sorting network macro
# ============================================================

_sortf_macro = r"""(defun build-batcher-sn (n)
  (let* (network
         (tee (ceiling (log n 2)))
         (p (ash 1 (- tee 1))))
    (loop while (> p 0) do
      (let ((q (ash 1 (- tee 1)))
            (r 0)
            (d p))
        (loop while (> d 0) do
          (loop for i from 0 to (- n d 1) do
            (if (= (logand i p) r)
              (push (list i (+ i d))
                    network)))
          (setf d (- q p)
                q (ash q -1)
                r p)))
      (setf p (ash p -1)))
    (nreverse network)))
(defmacro! sortf (comparator &rest places)
  (if places
    `(tagbody
       ,@(mapcar
           #`(let ((,g!a #1=,(nth (car a1) places))
                   (,g!b #2=,(nth (cadr a1) places)))
               (if (,comparator ,g!b ,g!a)
                 (setf #1# ,g!b
                       #2# ,g!a)))
           (build-batcher-sn (length places))))))"""

_sortf_before = r""";; Sorting multiple places requires manual compare-and-swap
(when (> b a) (rotatef a b))
(when (> c a) (rotatef a c))
(when (> c b) (rotatef b c))
;; This is a sorting network but manually written - error-prone
;; For more than 3 elements, the network is complex"""

_sortf_after = r""";; (sortf string< a b c d e)
;; Generates a Batcher sorting network of compare-and-swap operations
;; Each pair is: (let ((#:ga (nth 0 places)) (#:gb (nth 3 places)))
;;                (if (string< #:gb #:ga) (setf #1# #:gb #2# #:ga)))
;; All within a tagbody for compiler optimization"""

SORTF = TransformationExample(
    id="lol-sortf",
    before_code=_sortf_before,
    problem_pattern="Sorting multiple values in-place requires compare-and-swap networks — want automatic sorting network generation",
    macro_definition=_sortf_macro,
    after_expansion=_sortf_after,
    macro_category=MacroCategory.EFFICIENCY,
    technique=[MacroTechnique.GENSYM, MacroTechnique.TAGBODY],
    source=Source.LET_OVER_LAMBDA,
    source_chapter="ch7",
    complexity=Complexity.ADVANCED,
    has_capture_risk=False,
    requires_gensyms=True,
    commentary="Sorting network macro: generates optimal compare-and-swap networks using Batcher's merge-exchange algorithm. The network is generated at macro-expansion time from the number of places.",
)

# ============================================================
# 11. Compiler macro: fformat
# ============================================================

_fformat_macro = r"""(defun fformat (&rest all)
  (apply #'format all))
(define-compiler-macro fformat
                       (&whole form
                        stream fmt &rest args)
  (if (constantp fmt)
    (if stream
      `(funcall (formatter ,fmt)
         ,stream ,@args)
      (let ((g!stream (gensym "stream")))
        `(with-output-to-string (,g!stream)
           (funcall (formatter ,fmt)
             ,g!stream ,@args))))
    form))"""

_fformat_before = r""";; format with constant control strings interprets directives at runtime
(format nil "Value: ~a, Name: ~a" val name)
;; Every call: parse the ~a directives, resolve them, dispatch formatting
;; The format string is known at compile time but still interpreted at runtime"""

_fformat_after = r""";; (fformat t "Value: ~a, Name: ~a" val name)
;; Compiler macro sees constant fmt, expands to:
;; (FUNCALL (FORMATTER "Value: ~a, Name: ~a") T VAL NAME)
;;
;; formatter macro-expands the control string into direct
;; write-string, princ, etc. calls - no runtime parsing.
;;
;; When fmt is NOT constant: returns original form unchanged.
;; Graceful degradation - always correct, sometimes faster."""

FFORMAT = TransformationExample(
    id="lol-fformat",
    before_code=_fformat_before,
    problem_pattern="format with compile-time-constant control strings wastes time interpreting directives at runtime — want compile-time compilation of format strings",
    macro_definition=_fformat_macro,
    after_expansion=_fformat_after,
    macro_category=MacroCategory.COMPILER_MACRO,
    technique=[MacroTechnique.COMPILER_MACRO, MacroTechnique.GENSYM],
    source=Source.LET_OVER_LAMBDA,
    source_chapter="ch7",
    complexity=Complexity.INTERMEDIATE,
    has_capture_risk=False,
    requires_gensyms=True,
    commentary="Compiler macro with &whole + constantp guard. When fmt is constant, delegates to formatter which macro-expands directives into direct function calls. &whole captures the original form — returning it unchanged declines optimization.",
)

# ============================================================
# 12. defun! — defun with automatic gensyms
# ============================================================

_defun_bang_macro = r"""(defmacro defun! (name args &body body)
  (let ((syms (remove-duplicates
               (remove-if-not #'g!-symbol-p
                              (flatten body)))))
    (multiple-value-bind (body declarations docstring)
        (parse-body body :documentation t)
      `(defun ,name ,args
         ,@(when docstring
             (list docstring))
         ,@declarations
         (let ,(mapcar (lambda (s)
                         `(,s (gensym ,(subseq (symbol-name s)
                                               2))))
                       syms)
           ,@body)))))"""

_defun_bang_before = r""";; Functions that build code also need gensyms for hygiene
(defun build-setter (var)
  (let ((g (gensym)))
    `(lambda (,g)
       (setf ,var ,g))))
;; Gensym boilerplate in code-generating functions"""

_defun_bang_after = r""";; (defun! build-setter (var)
;;   `(lambda (,g!param)
;;      (setf ,var ,g!param)))
;;
;; g!param is automatically gensym'd when the function runs
;; Each call produces a fresh uninterned symbol"""

DEFUN_BANG = TransformationExample(
    id="lol-defun-bang",
    before_code=_defun_bang_before,
    problem_pattern="Functions that generate code also need gensyms — want same G! prefix convention extended to defun",
    macro_definition=_defun_bang_macro,
    after_expansion=_defun_bang_after,
    macro_category=MacroCategory.CAPTURE_MANAGEMENT,
    technique=[MacroTechnique.GENSYM, MacroTechnique.CODE_WALKING],
    source=Source.LET_OVER_LAMBDA,
    source_chapter="ch3",
    complexity=Complexity.INTERMEDIATE,
    has_capture_risk=False,
    requires_gensyms=True,
    commentary="defun! extends the G! prefix convention to functions that generate code. Scans the body for G!-prefixed symbols and gensyms them. Verified in test suite: (defun! fn! () `(let ((,g!test 123)) ,g!test)).",
)

# ============================================================
# 13. plambda — Pandoric lambda (exporting closure vars)
# ============================================================

_plambda_macro = r"""(defmacro plambda (largs pargs &rest body)
  (let ((pargs (mapcar #'list pargs)))
    `(let (this self)
       (setq
         this (lambda ,largs ,@body)
         self (dlambda
                (:pandoric-get (sym)
                  ,(pandoriclet-get pargs))
                (:pandoric-set (sym val)
                  ,(pandoriclet-set pargs))
                (t (&rest args)
                  (apply this args)))))))"""

_plambda_before = r""";; Exporting closure variables requires building pandoric protocol manually
(let ((a 0))
  (let ((b 1))
    (let (this self)
      (setq
        this (lambda (n) (incf a n) (setq b (* b n)))
        self (dlambda
               (:pandoric-get (sym)
                 (case sym
                   ((a) a)
                   ((b) b)
                   (t (error "Unknown: ~a" sym))))
               (:pandoric-set (sym val)
                 (case sym
                   ((a) (setq a val))
                   ((b) (setq b val))))
               (t (&rest args) (apply this args)))))))
;; Manual self construction for every closure is painful"""

_plambda_after = r""";; (let ((a 0))
;;   (let ((b 1))
;;     (plambda (n) (a b)
;;       (incf a n)
;;       (setq b (* b n)))))
;;
;; Now:
;; (with-pandoric (a b) closure
;;   (format t "a=~a b=~a~%" a b))
;; a and b are accessible through the pandoric protocol"""

PLAMBDA = TransformationExample(
    id="lol-plambda",
    before_code=_plambda_before,
    problem_pattern="Need to export closure variables through pandoric protocol, but manually building the self dlambda for each set of variables is repetitive",
    macro_definition=_plambda_macro,
    after_expansion=_plambda_after,
    macro_category=MacroCategory.DISPATCH,
    technique=[MacroTechnique.DLAMBDA, MacroTechnique.NESTED_BACKQUOTE],
    source=Source.LET_OVER_LAMBDA,
    source_chapter="ch6",
    complexity=Complexity.ADVANCED,
    has_capture_risk=True,
    requires_gensyms=False,
    commentary="Pandoric lambda: like pandoriclet but explicitly lists which variables to export. Useful for exposing variables from nested lets. The self closure handles :pandoric-get/:pandoric-set while forwarding normal calls to this.",
)

# ============================================================
# 14. if-match — Pattern matching with regex captures
# ============================================================

_if_match_macro = r"""#+cl-ppcre
(defun dollar-symbol-p (s)
  (and (symbolp s)
       (> (length (symbol-name s)) 1)
       (string= (symbol-name s)
                "$"
                :start1 0
                :end1 1)
       (ignore-errors (parse-integer (subseq (symbol-name s) 1)))))
(defmacro! if-match ((match-regex str) then &optional else)
  (let* ((dollars (remove-duplicates
                   (remove-if-not #'dollar-symbol-p
                                  (flatten then))))
         (top (or (car (sort (mapcar #'dollar-symbol-p dollars) #'>))
                  0)))
    `(multiple-value-bind (,g!matches ,g!captures) (,match-regex ,str)
       (declare (ignorable ,g!matches ,g!captures))
       (let ((,g!captures-len (length ,g!captures)))
         (declare (ignorable ,g!captures-len))
         (symbol-macrolet ,(mapcar #`(,(symb "$" a1)
                                       (if (< ,g!captures-len ,a1)
                                           (error "Too few matchs: ~a unbound." ,(mkstr "$" a1))
                                           (aref ,g!captures ,(1- a1))))
                                   (loop for i from 1 to top collect i))
           (if ,g!matches
               ,then
               ,else))))))"""

_if_match_before = r""";; Regex matching with captures requires manual multiple-value-bind
(multiple-value-bind (matchp captures)
    (cl-ppcre:scan-to-strings "_(\\w+)@(\\w+)\\.com_" email)
  (if matchp
      (let ((user (aref captures 0))
            (domain (aref captures 1)))
        (format t "~a at ~a~%" user domain))
      :invalid))
;; Verbose: bind result, extract captures by index, branch - repetitive"""

_if_match_after = r""";; (if-match (#~m_(\\w+)@(\\w+)\\.com_ email)
;;   (format t "~a at ~a~%" $1 $2)
;;   :invalid)
;;
;; $1, $2 bound to capture groups via symbol-macrolet
;; Out-of-bounds $N signals a clear error at runtime
;; Nested if-match works - each has its own capture bindings"""

IF_MATCH = TransformationExample(
    id="lol-if-match",
    before_code=_if_match_before,
    problem_pattern="Regex matching with named captures requires verbose destructuring — want $1, $2, ... anaphors bound to capture groups",
    macro_definition=_if_match_macro,
    after_expansion=_if_match_after,
    macro_category=MacroCategory.CONTROL_FLOW,
    technique=[MacroTechnique.SYMBOL_MACROLET, MacroTechnique.GENSYM, MacroTechnique.CODE_WALKING],
    source=Source.LET_OVER_LAMBDA,
    source_chapter="ch6",
    complexity=Complexity.ADVANCED,
    has_capture_risk=False,
    requires_gensyms=True,
    commentary="Combines regex matching with anaphoric capture variables ($1, $2, ...). Scans the then-branch for $N symbols and creates symbol-macrolet bindings. Uses defmacro! for hygiene. Requires cl-ppcre.",
)

# ============================================================
# 15. pandoric-eval — Tunneling lexical scope through eval
# ============================================================

_pandoric_eval_macro = r"""(defvar pandoric-eval-tunnel)
(defmacro pandoric-eval (vars expr)
  `(let ((pandoric-eval-tunnel
           (plambda () ,vars t)))
     (eval `(with-pandoric
              ,',vars pandoric-eval-tunnel
              ,,expr))))"""

_pandoric_eval_before = r""";; eval loses lexical environment - can't access surrounding bindings
(let ((x 1))
  (eval '(+ 1 x)))  ;; Error: X is unbound!
;; Need: way to tunnel lexical variables into eval"""

_pandoric_eval_after = r""";; (let ((x 1))
;;   (pandoric-eval (x)
;;     '(+ 1 x)))
;; => 2
;;
;; (let ((x 1))
;;   (pandoric-eval (x)
;;     '(incf x))
;;   x)
;; => 2  ;; modifications persist!
;;
;; Builds a plambda capturing x, then eval-with-pandoric
;; reconstructs x as symbol-macrolet inside eval"""

PANDORIC_EVAL = TransformationExample(
    id="lol-pandoric-eval",
    before_code=_pandoric_eval_before,
    problem_pattern="eval cannot access lexical environment — want a 'tunnel' that bridges lexical scope into eval's dynamic world",
    macro_definition=_pandoric_eval_macro,
    after_expansion=_pandoric_eval_after,
    macro_category=MacroCategory.SCOPE,
    technique=[MacroTechnique.DLAMBDA, MacroTechnique.SYMBOL_MACROLET],
    source=Source.LET_OVER_LAMBDA,
    source_chapter="ch6",
    complexity=Complexity.ADVANCED,
    has_capture_risk=True,
    requires_gensyms=False,
    commentary="Two-way tunnel between lexical scope and eval. Uses plambda to capture the lexical bindings, then with-pandoric inside eval to make them accessible. Modifications flow back because symbol-macrolet changes go through setf -> pandoric-set.",
)

# ============================================================
# Aggregate all examples
# ============================================================

from cl_macros.on_lisp import ON_LISP_EXAMPLES

ALL_EXAMPLES: list[TransformationExample] = [
    G_BANG,
    DEFMACRO_BANG,
    AIFF,
    ALAMBDA,
    DLAMBDA,
    ALET,
    PANDORICLET,
    WITH_PANDORIC,
    NLET_TAIL,
    SORTF,
    FFORMAT,
    DEFUN_BANG,
    PLAMBDA,
    IF_MATCH,
    PANDORIC_EVAL,
    *ON_LISP_EXAMPLES,
]