Skip to content

parser: disambiguate bare-token compound patterns in defn (eigentrust pitfall #7) #16

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
hierophantos merged 1 commit into from
Apr 27, 2026
Merged

parser: disambiguate bare-token compound patterns in defn (eigentrust pitfall #7) #16

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
25 changes: 24 additions & 1 deletion racket/prologos/parser.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4105,13 +4105,36 @@
(datum->syntax #f (map stx->datum body-parts) (car body-parts))))
(define body (parse-datum body-stx))
;; Parse patterns: single bracket element → use parse-pattern-bracket
;; Multiple bare elements → parse each as individual pattern
;; Multiple bare elements → either ONE compound (if ctor) or N args.
;;
;; Disambiguation rule:
;; `cons r nil` written as bare tokens after `|` is ambiguous between
;; (a) one compound pattern: cons-of-(r,nil)
;; (b) three separate arg patterns
;; ML/Haskell convention reads (a). To match user intuition while
;; preserving (b) for genuinely multi-arg defns like `defn add | x y -> ...`,
;; detect: if the leading bare token names a known constructor whose
;; field-count equals the remaining token count, parse as ONE compound.
;; Otherwise, fall back to N separate arg patterns.
(define patterns
(cond
[(and (= (length pattern-stxs) 1)
(pair? (stx->datum (car pattern-stxs))))
;; Single bracket [patterns...] → existing parse-pattern-bracket
(parse-pattern-bracket (car pattern-stxs) loc)]
[(and (> (length pattern-stxs) 1)
(let* ([head (stx->datum (car pattern-stxs))]
[meta (and (symbol? head) (lookup-ctor head))])
(and meta
(= (length (ctor-meta-field-types meta))
(- (length pattern-stxs) 1)))))
;; Leading symbol is a known constructor with matching field count.
;; Treat as one compound pattern: cons r nil → (cons r nil)
(list (parse-single-pattern
(datum->syntax #f
(map stx->datum pattern-stxs)
(car pattern-stxs))
loc))]
[else
;; Bare patterns: each element is one argument pattern
(for/list ([p (in-list pattern-stxs)])
Expand Down
315 changes: 315 additions & 0 deletions racket/prologos/tests/test-defn-multiarg-patterns.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,315 @@
#lang racket/base

;;;
;;; Tests for Multi-Arg Pattern Disambiguation in `defn name | ... -> ...`
;;;
;;; Eigentrust pitfalls doc #7 fix: bare-token patterns after `|` in
;;; `defn name | pat -> body | ...` were ambiguous between
;;; (a) one compound pattern: `cons r nil` → cons-of-(r,nil) [ML/Haskell-like]
;;; (b) N separate arg patterns: `cons r nil` → cons, r, nil [old behavior]
;;;
;;; The fix in parser.rkt's parse-defn-clause auto-detects (a) when the
;;; leading token is a known constructor whose field count matches the
;;; remaining tokens. Otherwise it falls back to (b), preserving genuinely
;;; multi-arg defns like `defn add | x y -> [+ x y]`.
;;;
;;; Coverage:
;;; - Single-arg multi-clause (regression of canonical multi-clause defn)
;;; - Multi-arg multi-clause with all-variable patterns (regression of (b))
;;; - Eigentrust reproducer (sum-rows): `cons r nil` → one compound
;;; - Multi-arg with constructor patterns in non-first positions
;;; - Wildcards `_` mixed in
;;;

(require rackunit
racket/list
racket/path
racket/string
racket/port
racket/file
"../macros.rkt"
"../prelude.rkt"
"../syntax.rkt"
"../source-location.rkt"
"../surface-syntax.rkt"
"../errors.rkt"
"../metavar-store.rkt"
"../parser.rkt"
"../elaborator.rkt"
"../pretty-print.rkt"
"../global-env.rkt"
"../driver.rkt"
"../reduction.rkt"
(prefix-in tc: "../typing-core.rkt")
"../namespace.rkt"
"../trait-resolution.rkt"
"../parse-reader.rkt"
"../multi-dispatch.rkt")

;; ========================================
;; Shared Fixture (prelude loaded once)
;; ========================================

(define here (path->string (path-only (syntax-source #'here))))
(define lib-dir (simplify-path (build-path here ".." "lib")))

(define-values (shared-global-env
shared-ns-context
shared-module-reg
shared-trait-reg
shared-impl-reg
shared-param-impl-reg
shared-bundle-reg)
(parameterize ([current-prelude-env (hasheq)]
[current-module-definitions-content (hasheq)]
[current-ns-context #f]
[current-module-registry (hasheq)]
[current-lib-paths (list lib-dir)]
[current-mult-meta-store (make-hasheq)]
[current-preparse-registry (current-preparse-registry)]
[current-trait-registry (current-trait-registry)]
[current-impl-registry (current-impl-registry)]
[current-param-impl-registry (current-param-impl-registry)]
[current-bundle-registry (current-bundle-registry)])
(install-module-loader!)
(process-string "(ns test-defn-multiarg)")
(values (current-prelude-env)
(current-ns-context)
(current-module-registry)
(current-trait-registry)
(current-impl-registry)
(current-param-impl-registry)
(current-bundle-registry))))

;; Run sexp code using shared environment
(define (run s)
(parameterize ([current-prelude-env shared-global-env]
[current-ns-context shared-ns-context]
[current-module-registry shared-module-reg]
[current-lib-paths (list lib-dir)]
[current-mult-meta-store (make-hasheq)]
[current-preparse-registry (current-preparse-registry)]
[current-trait-registry shared-trait-reg]
[current-impl-registry shared-impl-reg]
[current-param-impl-registry shared-param-impl-reg]
[current-bundle-registry shared-bundle-reg])
(process-string s)))

(define (run-last s) (last (run s)))

;; Run WS code via temp file using shared environment
(define (run-ws s)
(define tmp (make-temporary-file "prologos-test-~a.prologos"))
(call-with-output-file tmp #:exists 'replace
(lambda (out) (display s out)))
(define result
(parameterize ([current-prelude-env shared-global-env]
[current-ns-context shared-ns-context]
[current-module-registry shared-module-reg]
[current-lib-paths (list lib-dir)]
[current-mult-meta-store (make-hasheq)]
[current-preparse-registry (current-preparse-registry)]
[current-trait-registry shared-trait-reg]
[current-impl-registry shared-impl-reg]
[current-param-impl-registry shared-param-impl-reg]
[current-bundle-registry shared-bundle-reg])
(process-file tmp)))
(delete-file tmp)
result)

(define (run-ws-last s) (last (run-ws s)))

;; ========================================
;; A. Single-arg multi-clause regression
;; ========================================
;; The canonical `is-zero` example from prologos-syntax.md.

(test-case "marg/single-arg-is-zero"
(check-equal?
(run-ws-last
"defn iz-marg\n | zero -> true\n | suc _ -> false\neval [iz-marg 0N]")
"true : Bool")
(check-equal?
(run-ws-last
"defn iz-marg2\n | zero -> true\n | suc _ -> false\neval [iz-marg2 3N]")
"false : Bool"))

;; ========================================
;; B. Multi-arg with all-variable patterns: must NOT be packed
;; ========================================
;; `x y` does not have a leading ctor, so falls back to N args.
;; Critical regression: confirms genuinely multi-arg defns still work.

(test-case "marg/all-var-two-arg"
;; `defn add-marg | x y -> [+ x y]` — 2 args, both variables
;; Use Nat constructors so the type infers as Nat -> Nat -> Nat
(check-equal?
(run-ws-last
"spec add-marg Nat -> Nat -> Nat\ndefn add-marg\n | x y -> [+ x y]\neval [add-marg 3N 4N]")
"7N : Nat"))

(test-case "marg/all-var-three-arg"
;; 3 args, all variable — must be parsed as 3 args
(check-equal?
(run-ws-last
"spec triple-add Nat -> Nat -> Nat -> Nat\ndefn triple-add\n | x y z -> [+ [+ x y] z]\neval [triple-add 1N 2N 3N]")
"6N : Nat"))

;; ========================================
;; C. Eigentrust reproducer: `cons r nil` packs to one compound
;; ========================================

(test-case "marg/eigentrust-sum-rows-typechecks"
;; The eigentrust reproducer: previously failed with `Unbound variable
;; sum-rows::1` because bare-token clauses produced split arities
;; (1, 3, 3 instead of 1, 1, 1). With the fix, all three clauses are
;; arity 1 and `sum-rows-eig` defines as `[List Nat] -> Nat` — a single
;; function, no per-clause helpers, no unbound reference.
;;
;; This test verifies the *parsing* fix (single arity, single function).
;; A latent compile-match-tree bug (variable bindings for outer-param
;; names broken across nested compound dispatch) is orthogonal and
;; tracked separately; see commit message for details. We exercise the
;; eigentrust case at empty + singleton inputs which are unaffected.
(define results
(run-ws
(string-append
"spec sum-rows-eig [List Nat] -> Nat\n"
"defn sum-rows-eig\n"
" | nil -> 0N\n"
" | cons r nil -> r\n"
" | cons r rest -> [+ r [sum-rows-eig rest]]\n"
"eval [sum-rows-eig '[5N]]")))
;; First non-error result line confirms parse + type-check + arity-1 def.
(check-true (for/or ([r (in-list results)])
(and (string? r)
(string-contains? r "sum-rows-eig")
(string-contains? r "List Nat] -> Nat")))))

(test-case "marg/eigentrust-sum-rows-empty"
;; Empty list → first clause matches: nil → 0N (no nested binding bug).
(define results
(run-ws
(string-append
"spec sum-rows-eig2 [List Nat] -> Nat\n"
"defn sum-rows-eig2\n"
" | nil -> 0N\n"
" | cons r nil -> r\n"
" | cons r rest -> [+ r [sum-rows-eig2 rest]]\n"
"eval [sum-rows-eig2 [the [List Nat] nil]]")))
(check-true (for/or ([r (in-list results)])
(and (string? r) (string-contains? r "0N")))))

(test-case "marg/eigentrust-sum-rows-singleton"
;; Singleton list → second clause matches: cons r nil → r.
;; This is the boundary that the fix unlocks — pre-fix the function
;; was arity-1 with only the nil clause, so any non-empty list would
;; hit ??__match-fail.
(define results
(run-ws
(string-append
"spec sum-rows-eig3 [List Nat] -> Nat\n"
"defn sum-rows-eig3\n"
" | nil -> 0N\n"
" | cons r nil -> r\n"
" | cons r rest -> [+ r [sum-rows-eig3 rest]]\n"
"eval [sum-rows-eig3 '[42N]]")))
(check-true (for/or ([r (in-list results)])
(and (string? r) (string-contains? r "42N")))))

;; ========================================
;; D. Constructor patterns in non-first positions
;; ========================================
;; `[+ ... 0N]`-like patterns: peano addition with zero on the right.

(test-case "marg/ctor-pattern-non-first-position"
;; `add-zero-r | n zero -> n | n [suc m] -> [suc [add-zero-r n m]]`
;; Bare `n zero` has leading `n` (variable, not ctor) → falls back to 2 args.
;; This is the "bare patterns" case where the user genuinely wants N args.
(check-equal?
(run-ws-last
(string-append
"spec add-zr Nat -> Nat -> Nat\n"
"defn add-zr\n"
" | n zero -> n\n"
" | n [suc m] -> [suc [add-zr n m]]\n"
"eval [add-zr 2N 3N]"))
"5N : Nat"))

;; ========================================
;; E. Wildcards mixed in
;; ========================================

(test-case "marg/wildcard-in-bare-tokens"
;; `cons _ nil` — `cons` is leading ctor with 2 fields, 2 remaining tokens.
;; Should be packed as one pattern: cons-of-(_,nil).
(check-equal?
(run-ws-last
(string-append
"defn singleton?\n"
" | nil -> false\n"
" | cons _ nil -> true\n"
" | cons _ _ -> false\n"
"eval [singleton? '[42N]]"))
"true : Bool")
(check-equal?
(run-ws-last
(string-append
"defn singleton?2\n"
" | nil -> false\n"
" | cons _ nil -> true\n"
" | cons _ _ -> false\n"
"eval [singleton?2 '[1N 2N]]"))
"false : Bool"))

(test-case "marg/wildcard-in-all-var"
;; `_ _` — both wildcards, no leading ctor → 2 args.
(check-equal?
(run-ws-last
(string-append
"spec const-zero-2 Nat -> Nat -> Nat\n"
"defn const-zero-2\n"
" | _ _ -> 0N\n"
"eval [const-zero-2 5N 7N]"))
"0N : Nat"))

;; ========================================
;; F. Mixed: some clauses pack, others don't
;; ========================================
;; All clauses must end up at the SAME arity. A bare-pattern clause
;; whose leading token is a ctor with matching arity packs to one
;; pattern; a `nil` clause is already one pattern. Both → arity 1.

(test-case "marg/mixed-leading-ctor-and-nullary"
;; nil (1 token, nullary ctor) + cons _ _ (3 tokens, packs to 1 compound)
(check-equal?
(run-ws-last
(string-append
"spec list-len-marg [List Nat] -> Nat\n"
"defn list-len-marg\n"
" | nil -> 0N\n"
" | cons _ rest -> [suc [list-len-marg rest]]\n"
"eval [list-len-marg '[10N 20N 30N]]"))
"3N : Nat"))

;; ========================================
;; G. Bracketed form continues to work (regression)
;; ========================================
;; `[cons r nil]` (single bracket) is the explicit way to write a
;; compound pattern in a multi-arg context. This remains supported.

(test-case "marg/double-bracket-compound-still-works"
;; [[cons _ nil]] (double bracket) is the legacy way to write a
;; compound pattern as a single arg in the bracketed form: outer
;; bracket = "this is the params list with 1 element"; inner bracket
;; = "the element is the compound pattern (cons _ nil)". This path
;; is unchanged by the fix (regression check).
(check-equal?
(run-ws-last
(string-append
"defn singleton?-dblbracket\n"
" | [[nil]] -> false\n"
" | [[cons _ nil]] -> true\n"
" | [[cons _ _]] -> false\n"
"eval [singleton?-dblbracket '[42N]]"))
"true : Bool"))
Loading