case.scm

;
; Copyright (C) 2024 The Goldfish Scheme Authors
;
; Licensed under the Apache License, Version 2.0 (the "License");
; you may not use this file except in compliance with the License.
; You may obtain a copy of the License at
;
; http://www.apache.org/licenses/LICENSE-2.0
;
; Unless required by applicable law or agreed to in writing, software
; distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
; WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
; License for the specific language governing permissions and limitations
; under the License.
;

(define-library (liii case)
(import (liii base))
(export case*)
(begin

; 0 clause BSD, from S7 repo case.scm
(define case* 
  (let ((case*-labels (lambda (label)
      (let ((labels ((funclet ((funclet 'case*) 'case*-helper)) 'labels)))
        (labels (symbol->string label))))) ; if ellipsis, this has been quoted by case*
  
  (case*-match? (lambda* (matchee pattern (e (curlet)))
      (let ((matcher ((funclet ((funclet 'case*) 'case*-helper)) 'handle-sequence)))
        (or (equivalent? matchee pattern)
            (and (or (pair? matchee) 
               (vector? matchee))
           (begin
             (fill! ((funclet ((funclet 'case*) 'case*-helper)) 'labels) #f) ; clear labels
             ((matcher pattern e) matchee)))))))
  (case*-helper
   (with-let (unlet)
     (define labels (make-hash-table))

     (define (ellipsis? pat)
       (and (undefined? pat)
      (or (equal? pat #<...>)
          (let ((str (object->string pat)))
      (and (char-position #\: str)
           (string=? "...>" (substring str (- (length str) 4))))))))
       
     (define (ellipsis-pair-position pos pat)
       (and (pair? pat)
      (if (ellipsis? (car pat))
          pos
          (ellipsis-pair-position (+ pos 1) (cdr pat)))))

     (define (ellipsis-vector-position pat vlen)
       (let loop ((pos 0))
         (and (< pos vlen)
        (if (ellipsis? (pat pos))
      pos
      (loop (+ pos 1))))))

     (define (splice-out-ellipsis sel pat pos e)
       (let ((sel-len (length sel))
       (new-pat-len (- (length pat) 1))
       (ellipsis-label (and (not (eq? (pat pos) #<...>))              
          (let* ((str (object->string (pat pos)))
                 (colon (char-position #\: str)))
            (and colon
                 (substring str 2 colon))))))
         (let ((func (and (string? ellipsis-label)
        (let ((comma (char-position #\, ellipsis-label)))
          (and comma
               (let ((str (substring ellipsis-label (+ comma 1))))
           (set! ellipsis-label (substring ellipsis-label 0 comma))
           (let ((func-val (symbol->value (string->symbol str) e)))
             (if (undefined? func-val)
                 (error 'unbound-variable "function ~S is undefined\n" func))
             (if (not (procedure? func-val))
                 (error 'wrong-type-arg "~S is not a function\n" func))
             func-val)))))))
     (if (pair? pat)
         (cond ((= pos 0)               ; ellipsis at start of pattern
          (if ellipsis-label
        (set! (labels ellipsis-label) 
              (list 'quote (copy sel (make-list (- sel-len new-pat-len))))))
          (values (list-tail sel (- sel-len new-pat-len))
            (cdr pat)
            (or (not func)
          (func (cadr (labels ellipsis-label)))))) ; value is (quote ...) and we want the original list here
         
         ((= pos new-pat-len)     ; ellipsis at end of pattern
          (if ellipsis-label
        (set! (labels ellipsis-label) 
              (list 'quote (copy sel (make-list (- sel-len pos)) pos))))
          (values (copy sel (make-list pos))
            (copy pat (make-list pos))
            (or (not func) 
          (func (cadr (labels ellipsis-label))))))
         
         (else                    ; ellipsis somewhere in the middle
          (let ((new-pat (make-list new-pat-len))
          (new-sel (make-list new-pat-len)))
            (if ellipsis-label
          (set! (labels ellipsis-label) 
          (list 'quote (copy sel (make-list (- sel-len new-pat-len)) pos))))
            (copy pat new-pat 0 pos)
            (copy pat (list-tail new-pat pos) (+ pos 1))
            (copy sel new-sel 0 pos)
            (copy sel (list-tail new-sel pos) (- sel-len pos))
            (values new-sel new-pat
              (or (not func) 
            (func (cadr (labels ellipsis-label))))))))
         
         (cond ((= pos 0)
          (if ellipsis-label
        (set! (labels ellipsis-label) 
              (list 'quote (copy sel (make-list (- sel-len new-pat-len))))))
          (values (subvector sel (max 0 (- sel-len new-pat-len)) sel-len) ; was new-pat-len (max 0 (- sel-len new-pat-len))
            (subvector pat 1 (+ new-pat-len 1))                     ;     new-pat-len 1
            (or (not func) 
          (func (cadr (labels ellipsis-label))))))
         
         ((= pos new-pat-len)
          (if ellipsis-label
        (set! (labels ellipsis-label) 
              (list 'quote (copy sel (make-list (- sel-len new-pat-len)) pos))))
          (values (subvector sel 0 new-pat-len)
            (subvector pat 0 new-pat-len)
            (or (not func) 
          (func (cadr (labels ellipsis-label))))))
         
         (else
          (let ((new-pat (make-vector new-pat-len))
          (new-sel (make-vector new-pat-len)))
            (if ellipsis-label
          (set! (labels ellipsis-label) 
          (list 'quote (copy sel (make-list (- sel-len new-pat-len)) pos))))
            (copy pat new-pat 0 pos)
            (copy pat (subvector new-pat pos new-pat-len) (+ pos 1))       ; (- new-pat-len pos) pos)   copy: (+ pos 1))
            (copy sel new-sel 0 pos)
            (copy sel (subvector new-sel pos new-pat-len) (- sel-len pos))
                                                                           ; (- new-pat-len pos) pos)  copy: (- sel-len pos))
            (values new-sel new-pat
              (or (not func) 
            (cadr (func (labels ellipsis-label))))))))))))
       
     (define (handle-regex x) #f)
     ;(define handle-regex
     ;  (let ((rg ((*libc* 'regex.make))) ; is this safe?
     ;  (local-regcomp (*libc* 'regcomp))
     ;  (local-regerror (*libc* 'regerror))
     ;  (local-regexec (*libc* 'regexec))
     ;  (local-regfree (*libc* 'regfree)))
     ;    (lambda (reg)
     ;(lambda (x)
     ;  (and (string? x)
     ; (let ((res (local-regcomp rg (substring reg 1 (- (length reg) 1)) 0)))
     ;   (unless (zero? res)
     ;     (error 'regex-error "~S~%" (local-regerror res rg)))
     ;   (set! res (local-regexec rg x 0 0))
     ;   (local-regfree rg)
     ;   (zero? res)))))))

     (define (undefined->function undef e)   ; handle the pattern descriptor ("undef") of the form #< whatever >, "e" = caller's curlet
       (let* ((str1 (object->string undef))
        (str1-end (- (length str1) 1)))
         (if (not (char=? (str1 str1-end) #\>))
       (error 'wrong-type-arg "pattern descriptor does not end in '>': ~S\n" str1))
         (let ((str (substring str1 2 str1-end)))
     (if (= (length str) 0)                                           ; #<> = accept anything
         (lambda (x) #t)
         (let ((colon (char-position #\: str)))
           (cond (colon                                               ; #<label:...> might be #<label:> or #<label:func>
            (let ((label (substring str 0 colon))               ; str is label:...
            (func (substring str (+ colon 1))))           ; func might be ""
        (cond ((labels label)                             ; see if we already have saved something under this label
               (lambda (sel)                              ;   if so, return function that will return an error
           (error 'syntax-error "label ~S is defined twice: old: ~S, new: ~S~%" label (labels label) sel)))
              
              ;; otherwise the returned function needs to store the current sel-item under label in labels
              ((zero? (length func))
               (lambda (x)
           (set! (labels label) x)                  ; #<label:>, set label, accept anything
           #t))
              
              ((char=? (func 0) #\")                      ; labelled regex, #<label:"regexp">
               (lambda (x)
           (set! (labels label) x)
           (handle-regex func)))
              
              (else                                       ; #<label:func>
               (let ((func-val (symbol->value (string->symbol func) e)))
           (if (undefined? func-val)
               (error 'unbound-variable "function ~S is undefined\n" func)
               (if (not (procedure? func-val))
             (error 'wrong-type-arg "~S is not a function\n" func)
             (lambda (x)                     ; set label and call func
               (set! (labels label) x)
               (func-val x)))))))))
           
           ;; if no colon either #<label> or #<func> or #<"regexp"> -- label means match its saved expr, func = call func
           ((char=? (str 0) #\")
            (handle-regex str))
           
           (else                                                ; #<label> or #<func>
            (let ((saved (labels str)))
        (if saved                                         ; #<label>
            (lambda (x) (equivalent? x saved))
            (symbol->value (string->symbol str) e)))))))))) ; #<func> using curlet=e passed in above
     
     (define (handle-pattern sel-item pat-item e)
       (and (undefined? pat-item)      ; turn #<func> into func and call it on the current selector element
      (not (eq? pat-item #<undefined>))
      (let ((func (undefined->function pat-item e)))
        (if (undefined? func)
      (error 'unbound-variable "function ~S is undefined\n" pat-item))
        (if (not (procedure? func))
      (error 'wrong-type-arg "~S is not a function\n" func))
        (func sel-item))))

     (define (handle-sequence pat e)
       (lambda (sel)
         ;(format *stderr* "~S ~S~%" sel pat)
         (and (eq? (type-of sel) (type-of pat))
        (let ((func-ok #t))

          (when (or (pair? pat)                           ; look for ellipsis
        (vector? pat))
      (if (pair? (cyclic-sequences pat))
          (error 'wrong-type-arg "case* pattern is cyclic: ~S~%" pat))
      (let ((pos (if (pair? pat)
               (ellipsis-pair-position 0 pat)
               (ellipsis-vector-position pat (length pat)))))
        (when (and pos
             (>= (length sel) (- (length pat) 1))) ; else pat without ellipsis is too long for sel
          (let ((new-vars (list (splice-out-ellipsis sel pat pos e))))
            (set! sel (car new-vars))
            (set! pat (cadr new-vars))
            (set! func-ok (caddr new-vars))))))

          (and (= (length sel) (length pat))             ; march through selector and current target matching elements
         func-ok
         (call-with-exit
          (lambda (return)
            (for-each 
             (lambda (sel-item pat-item)
         (or (equivalent? sel-item pat-item) ; items match

             (and (or (pair? pat-item)       ; recursive check (* (+ #<symbol?> 1) 2), pat-item: (+ #symbol?> 1)
                (vector? pat-item))    ; pat-item, not sel-item here so pat-item can cover anything (a list for example)
            ((handle-sequence pat-item e) sel-item))

             (handle-pattern sel-item pat-item e)

             (return #f)))                   ; else give up (selector does not match target)
             sel pat)
            
            ;; dotted list, check final cdr
            (unless (or (not (pair? sel)) 
            (proper-list? sel))
        (let ((sel-item (list-tail sel (abs (length sel))))
              (pat-item (list-tail pat (abs (length pat)))))
          (return (or (equivalent? sel-item pat-item)
                (handle-pattern sel-item pat-item e)))))
              
            #t)))))))

     (define (find-labelled-pattern tree)
       ;; walk body looking for a labelled pattern
       (or (undefined? tree)
     (and (pair? tree)
          (or (find-labelled-pattern (car tree))
        (find-labelled-pattern (cdr tree))))
     (and (vector? tree)
          (let vector-walker ((pos 0))
      (and (< pos (length tree))
           (or (undefined? (tree pos))
         (and (pair? (tree pos))
              (find-labelled-pattern (tree pos)))
         (and (vector? (tree pos))
              (vector-walker (tree pos)))
         (vector-walker (+ pos 1))))))))

     (define (handle-body select body return e)
       (if (null? body)
     (return select))

       (when (find-labelled-pattern body) ; if labelled, remake the body substituting the labelled-exprs for the labels
         (set! body (let pair-builder ((tree body))
          (cond ((undefined? tree)
           (let ((label (let ((str (object->string tree)))
              (substring str 2 (- (length str) 1)))))
             (or (labels label) tree)))
          
          ((pair? tree)
           (cons (pair-builder (car tree))
           (pair-builder (cdr tree))))
          
          ((vector? tree)
           (vector (map pair-builder tree)))
          
          (else tree)))))
     
       ;; evaluate the result (case* expands into a call on case*-helper; we need to evaluate the result expressions ourselves)
       (return (eval (if (null? (cdr body))
             (car body)
             (if (eq? (car body) '=>)
           (list (cadr body) select)
           (cons 'begin body)))
         e)))
    
     ;; case*-helper
     (lambda (select clauses e)
       (call-with-exit
        (lambda (return)
    (for-each
     (lambda (clause)                                        ;((target...) body...)
       (let ((targets (car clause))
       (body (cdr clause)))
         (fill! labels #f)                                   ; clear previous labels
         (if (memq targets '(else #t))                       ; (else...) or (#t...)
       (return (eval (cons 'begin body) e))
       (for-each
        (lambda (target)
          (if (or (equivalent? target select)
            (and (undefined? target)              ; #<...>
           (not (eq? target #<undefined>))
           (let ((func (undefined->function target e)))
             ;(format *stderr* "func: ~S~%" func)
             ;; (if (undefined? func) (error 'unbound-variable "function ~A is undefined\n" str))
             ;; not the above check because we want to be able to pass patterns as selectors! (scase37 in s7test)
             ;;    this seems like a mistake: #<symbol?> won't work? 
             (and (procedure? func)
            (func select))))
            (and (sequence? target)
           ((handle-sequence target e) select)))
        (handle-body select body return e)))
        targets))))
     clauses)))))))
    ;; case*
    (#_macro (selector . clauses)
      `(((#_funclet 'case*) 'case*-helper) ,selector ',clauses (#_curlet)))))

) ; end of begin
) ; end of define-library