Support SRFI 253 / relax type annotation syntax

[aartaka]

Hello! I want to see SRFI 253 supported in Bigloo, and I’m ready to implement it myself. In fact, I tried that. I thought that type annotations consist of three separatable parts: symbol, type annotation indicator (::,) and the type itself. This is the way it works on Kawa, where I successfully used that syntax to bring in SRFI 253 types:

(define-syntax %lambda-checked
     (syntax-rules (::
                    number? complex? real? rational? exact-integer? integer? inexact?
                    symbol? keyword? list? pair? string? char?
                    vector? procedure? input-port? output-port?

                    number complex real rational integer double
                    symbol keyword list pair string character
                    vector procedure input-port output-port)
       ((_ name (body ...) (args ...) (checks ...))
        (lambda (args ...)
          checks ...
          body ...))
       ((_ name body (args ...) (checks ...) (arg number?) . rest)
        ;; See this ::?
        (%lambda-checked name body (args ... arg :: number) (checks ...) . rest))
       #|...|#
       ((_ name body (args ...) (checks ...) (arg output-port?) . rest)
        (%lambda-checked name body (args ... arg :: output-port) (checks ...) . rest))
       ((_ name body (args ...) (checks ...) (arg pred) . rest)
        (%lambda-checked
         name body
         (args ... arg) (checks ... (check-arg pred arg name)) . rest))
       ((_ name body (args ...) (checks ...) arg . rest)
        (%lambda-checked
         name body
         (args ... arg) (checks ...) . rest))
       ((_ (body ...) (args ...) (checks ...) . last)
        (lambda (args ... . last)
          checks ...
          body ...))))

However, trying to reproduce this approach, I discovered that Bigloo treats type-annotated symbols as inseparable entities, and separating them turns them into three independent symbols instead. So this macro doesn't work:

(define-syntax %define-checked
  (syntax-rules (=> :: check-impl?
                    procedure? pair? null? list? integer? exact-integer?
                    inexact? real? boolean?
                    string? char? vector? output-port? input-port? symbol? keyword?

                    obj procedure pair nil pair-nil bignum real bbool bstring
                    bchar vector output-port input-port symbol keyword)
    ((_ name (=> (returns ...) body ...) (args ...) (checks ...))
     (define (name args ...)
       checks ...
       body ...))
    ((_ name (body ...) (args ...) (checks ...))
     (define (name args ...)
       checks ...
       body ...))
    ((_ name body (args ...) (checks ...) (arg procedure?) . rest)
     (%define-checked name body (args ... arg :: procedure) (checks ...) . rest))
    ((_ name body (args ...) (checks ...) (arg pair?) . rest)
     (%define-checked name body (args ... arg :: pair) (checks ...) . rest))
    ((_ name body (args ...) (checks ...) (arg null?) . rest)
     (%define-checked name body (args ... arg :: nil) (checks ...) . rest))
    ((_ name body (args ...) (checks ...) (arg list?) . rest)
     (%define-checked name body (args ... arg :: pair-nil) (checks ...) . rest))
    ((_ name body (args ...) (checks ...) (arg integer?) . rest)
     (%define-checked name body (args ... arg :: bignum) (checks ...) . rest))
    ((_ name body (args ...) (checks ...) (arg exact-integer?) . rest)
     (%define-checked name body (args ... arg :: bignum) (checks ...) . rest))
    ((_ name body (args ...) (checks ...) (arg inexact?) . rest)
     (%define-checked name body (args ... arg :: real) (checks ...) . rest))
    ((_ name body (args ...) (checks ...) (arg real?) . rest)
     (%define-checked name body (args ... arg :: real) (checks ...) . rest))
    ((_ name body (args ...) (checks ...) (arg boolean?) . rest)
     (%define-checked name body (args ... arg :: bbool) (checks ...) . rest))
    ((_ name body (args ...) (checks ...) (arg string?) . rest)
     (%define-checked name body (args ... arg :: bstring) (checks ...) . rest))
    ((_ name body (args ...) (checks ...) (arg char?) . rest)
     (%define-checked name body (args ... arg :: bchar) (checks ...) . rest))
    ((_ name body (args ...) (checks ...) (arg vector?) . rest)
     (%define-checked name body (args ... arg :: vector) (checks ...) . rest))
    ((_ name body (args ...) (checks ...) (arg output-port?) . rest)
     (%define-checked name body (args ... arg :: output-port) (checks ...) . rest))
    ((_ name body (args ...) (checks ...) (arg input-port?) . rest)
     (%define-checked name body (args ... arg :: input-port) (checks ...) . rest))
    ((_ name body (args ...) (checks ...) (arg symbol?) . rest)
     (%define-checked name body (args ... arg :: symbol) (checks ...) . rest))
    ((_ name body (args ...) (checks ...) (arg keyword?) . rest)
     (%define-checked name body (args ... arg :: keyword) (checks ...) . rest))
    ((_ name body (args ...) (checks ...) (arg (check-impl? type)) . rest)
     (%define-checked name body (args ... arg :: type) (checks ...) . rest))
    ((_ name body (args ...) (checks ...) (arg pred) . rest)
     (%define-checked
      name body
      (args ... arg :: obj) (checks ... (check-arg pred arg name)) . rest))
    ((_ name body (args ...) (checks ...) arg . rest)
     (%define-checked
      name body
      (args ... arg) (checks ...) . rest))))

Any pointers on how I might generate type annotations in macros? Does that require a change in Bigloo parser? Is that feasible?

[manuel-serrano]

I don't think I have fully understood the problem you are currently facing. Is your current problem is that you don't know how to generate types identifier? For instance, you would like to generate the identifier x::double? I am probably missing some context but I would say that (string->symbol (format "~a::double" "x")) should make it. Am I missing something?

Probably the problem is coming the define-syntax and syntax-rules that do not let you make the decomposition. In that case, if you are considering a Bigloo only port, I would strong suggest to use an expander + match-case. This way you can control exactly what is expanded and how.

I realize that this is probably not the answer you would have dreamed of but at least, it is guaranteed to work fine.

[aartaka]

@manuel-serrano yes, syntax-rules are too restrictive. I’ll try your approach, thanks for elaborating!

[manuel-serrano]

Give a simple example made of a single user expression and its expansion (with just one case for the sake of simplicity) and I will be happy to show you how to implement the expansion.

[aartaka]

Give a simple example made of a single user expression and its expansion (with just one case for the sake of simplicity) and I will be happy to show you how to implement the expansion.

So let’s say

(define-checked (my-add (x integer?) (y integer?))
  (+ x y))
;; expands to
(define (my-add x::bint y::bint)
  (+ x y))

Return type annotations seem to not be present in Bigloo, thus the omission of SRFI 273 syntax for these.

[manuel-serrano]

Here is a simplified solution where it is assumed that the functions defined with define-checked accept only a fix number of required arguments:

(module ex
   (export (foo::long x)))

(define (foo::int x)
   (my-add x x))

(define-macro (define-checked proto . body)
   
   (define (predicate->type p)
      (case p
	 ((integer?) '|::bint|)
	 ((real?) '|::real|)
	 (else '|::obj|)))
   
   (match-case proto
      ((?id . ?args)
       `(define (,id ,@(map (lambda (a)
			       (match-case a
				  (((and ?id (? symbol?)) (and ?ty (? symbol?)))
				   (symbol-append id (predicate->type ty)))
				  (else
				   a)))
			  args))
	   ,@body))
      (else
       (error "define-checked" "bad proto" proto))))
       
(define-checked (my-add (x integer?) (y integer?))
   (+ x y))

This expands into:

$ bigloo foo.scm -expand
$ cat foo.escm
(module ex (export (foo::long x)))

;; foo::long
(define (foo::longx) (my-add x x))
;; my-add
(define (my-add x::bint y::bint) (+ x y))

and you can see, Bigloo does support return type annotation ;-)

[manuel-serrano]

oops, sorry for the typo, the correct definition of foo is:

(define (foo::long x) ;; ::long instead of ::int
  (my-add x x))

[aartaka]

I don’t fully understand the structure of the repo, so can you please add this code to Bigloo?

;; SPDX-FileCopyrightText: 2024 Artyom Bologov
;; SPDX-License-Identifier: MIT

;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use,
;;; copy, modify, merge, publish, distribute, sublicense, and/or
;;; sell copies of the Software, and to permit persons to whom the
;;; Software is furnished to do so, subject to the following
;;; conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;;; OTHER DEALINGS IN THE SOFTWARE.

(define-syntax assume
  (syntax-rules ()
    ((_ expr message rest ...)
     (or (and expr #t)
         (error message 'expr rest ...)))))

(define-syntax check-arg
  (syntax-rules ()
    ((_ pred val caller)
     (assume (pred val) "assumption violated" caller))
    ((_ pred val)
     (check-arg pred val 'check-arg))))

(define-syntax values-checked
  (syntax-rules ()
    ((_ (predicate) value)
     (let ((v value))
       (check-arg predicate v 'values-checked)
       v))
    ((_ (predicate ...) value ...)
     (values (values-checked (predicate) value) ...))))

(define-syntax %check-case
  (syntax-rules (else)
    ((_ val (clause ...) (else body ...))
     (cond
      clause ...
      (else body ...)))
    ((_ val ((clause-check clause-body ...) ...))
     (cond
      (clause-check clause-body ...)
      ...
      (else (assume (or clause-check ...)
              "at least one branch of check-case should be true"
              '(clause-check ...)))))
    ((_ val (clause ...) (pred body ...) rest ...)
     (%check-case
      val
      (clause ... ((pred val) body ...))
      rest ...))))
(define-syntax check-case
  (syntax-rules ()
    ((_ value clause ...)
     (let ((v value))
       (%check-case v () clause ...)))))

(define-syntax %lambda-checked
  (syntax-rules (=>)
    ((_ name (=> (returns ...) body ...) args (checks ...))
     (lambda args
       checks ...
       (values-checked
        (returns ...)
        (begin body ...))))
    ((_ name (body ...) args (checks ...))
     (lambda args
       checks ...
       body ...))
    ((_ name body (args ...) (checks ...) (arg pred) . rest)
     (%lambda-checked
      name body
      (args ... arg) (checks ... (check-arg pred arg 'name)) . rest))
    ((_ name body (args ...) (checks ...) arg . rest)
     (%lambda-checked
      name body
      (args ... arg) (checks ...) . rest))
    ((_ name body (args ...) (checks ...) . last)
     (%lambda-checked
      name body
      (args ... . last) (checks ...)))))

(define-syntax lambda-checked
  (syntax-rules ()
    ((_ () body ...)
     (lambda () body ...))
    ((_ (arg . args) body ...)
     (%lambda-checked lambda-checked (body ...) () () arg . args))
    ;; Case of arg->list lambda, no-op.
    ((_ arg body ...)
     (lambda arg body ...))))

(define-macro (%define-checked proto . body)
  (define (predicate->type p)
    (case p
      ((procedure?) '|::procedure|)
      ((pair?) '|::pair|)
      ((null?) '|::nil|)
      ((list?) '|::pair-nil|)
      ((integer?) '|::bint|)
      ((inexact?) '|::real|)
      ((real?) '|::real|)
      ((boolean?) '|::bbool|)
      ((string?) '|::bstring|)
      ((char?) '|::bchar|)
      ((vector?) '|::vector|)
      ((output-port?) '|::output-port|)
      ((input-port?) '|::input-port|)
      ((symbol?) '|::symbol|)
      ((keyword?) '|::keyword|)
      (else (if (and (pair? p)
                     (eq? 'check-impl? (car p)))
                (symbol-append '|::| (cadr p))
                '|::obj|))))
  (let* ((ret-types (if (eq? '=> (car body))
                        (cadr body)
                        #f))
         (body (if ret-types
                   (cddr body)
                   body)))
    (match-case
     proto
     ((?name . ?args)
      `(define (,(if (and ret-types (= 1 (length ret-types)))
                     (symbol-append name (predicate->type (car ret-types)))
                     name)
                ,@(let loop ((args args))
                    (if (not (pair? args))
                        args
                        (cons (match-case
                               (car args)
			       (((and ?id (? symbol?)) (and ?ty (? symbol?)))
			        (symbol-append id (predicate->type ty)))
                               (((and ?id (? symbol?)) ?ty)
			        id)
			       (else
			        (car args)))
                              (loop (cdr args))))))
	 ,@body))
     (else
      (error "define-checked" "bad proto" proto)))))

(define-syntax define-checked
  (syntax-rules ()
    ;; Procedure
    ((_ (name . args) body ...)
     (%define-checked (name . args) body ...))
    ((_ name pred value)
     (define name (values-checked (pred) value)))))

(define-syntax %define-record-type-checked
  (syntax-rules ()
    ((_ type-name constructor predicate
        (fields ...) (field-wrappers ...))
     (begin
       (define-record-type
           type-name constructor predicate
           fields ...)
       field-wrappers ...))
    ((_ type-name constructor predicate
        (fields ...) (field-wrappers ...) (field pred accessor modifier)
        fields-to-process ...)
     (%define-record-type-checked
      type-name constructor predicate
      (fields ... (field internal-accessor internal-modifier))
      (field-wrappers
       ...
       (define-checked (accessor (record predicate))
         (internal-accessor record))
       (define-checked (modifier (record predicate) (val pred))
         (internal-modifier record val)))
      fields-to-process ...))
    ((_ type-name constructor predicate
        (fields ...) (field-wrappers ...) (field pred accessor)
        fields-to-process ...)
     (%define-record-type-checked
      type-name constructor predicate
      (fields ... (field internal-accessor))
      (field-wrappers
       ...
       (define-checked (accessor (record predicate))
         (internal-accessor record)))
      fields-to-process ...))))
(define-syntax %wrap-constructor
  (syntax-rules ()
    ((_ constructor internal-constructor (arg-names ...) (args ...))
     (define-checked (constructor args ...)
       (internal-constructor arg-names ...)))
    ((_ constructor internal-constructor (arg-names ...) (args ...)
        (name pred rest ...) fields-to-process ...)
     (%wrap-constructor constructor internal-constructor
                        (arg-names ... name) (args ... (name pred))
                        fields-to-process ...))))

(define-syntax define-record-type-checked
  (syntax-rules ()
    ((_ type-name (constructor constructor-args ...) predicate field ...)
     (begin
       (%define-record-type-checked
        type-name
        (internal-constructor constructor-args ...)
        predicate
        () () field ...)
       (%wrap-constructor constructor internal-constructor () () field ...)))))

[aartaka]

@manuel-serrano does it look alright to you?