Guile-hoot/test/test-library-group.scm

;;; Copyright (C) 2024 Igalia, S.L.
;;;
;;; 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.

;;; Commentary:
;;;
;;; Tests for library-group.
;;;
;;; Code:

(use-modules (srfi srfi-64)
             (ice-9 match)
             (test utils)
             ((language tree-il) #:select (tree-il->scheme))
             (hoot library-group))

(test-begin "test-library-group")

(define (parse-and-expand exp)
  (tree-il->scheme
   (expand-library-group (parse-library-group exp)
                         #:primitives '(hoot primitives))))

(define-syntax-rule (test-library-group exp expanded)
  (test-equal 'exp 'expanded (parse-and-expand 'exp)))

(define-syntax-rule (test-invalid-library-group exp)
  (test-assert 'exp
               (catch #t
                      (lambda () (parse-and-expand 'exp) #f)
                      (lambda _ #t))))

(test-invalid-library-group 42)
(test-invalid-library-group ())
(test-invalid-library-group '())

(test-library-group
 (library-group)
 (if #f #f))

(test-library-group
 (library-group
  (library (foo)
    (export a)
    (import (only (hoot primitives) define))
    (define a 42))
  (import (foo))
  a)
 (let ()
   (define a 42)
   a))

(test-library-group
 (library-group
  (library (foo)
    (export a)
    (import (only (hoot primitives) define))
    (define a 42))
  (library (bar)
    (export b)
    (import (only (hoot primitives) define))
    (define b 10))
  (import (foo) (bar)
          (rename (only (hoot primitives) %+)
                  (%+ +)))
  (+ a b))
 (let ()
   (define a 42)
   (define b 10)
   (+ a b)))

(test-library-group
 (library-group
  (library (foo)
    (export a)
    (import (only (hoot primitives) define))
    (define a 42))
  (library (bar)
    (export a)
    (import (only (hoot primitives) define))
    (define a 10))
  (import (foo)
    (rename (bar) (a b))
    (rename (only (hoot primitives) %+)
            (%+ +)))
  (+ a b))
 (let ()
   (define a-1 42)
   (define a 10)
   (+ a-1 a)))

(test-invalid-library-group
 (library-group
  (library (foo)
    (export a)
    (import (only (hoot primitives) define))
    (define a 42))
  (library (bar)
    (export a)
    (import (only (hoot primitives) define))
    (define a 10))
  #:untrusted
  (import (foo)
    (rename (bar) (a b))
    (rename (only (hoot primitives) %+)
            (%+ +)))
  (+ a b)))

(test-library-group
 (library-group
  (library (foo)
    (export a)
    (import (only (hoot primitives) define))
    (define a 42))
  (library (bar)
    (export a)
    (import (only (hoot primitives) define))
    (define a 10))
  (library (plus)
    (export +)
    (import (only (hoot primitives) define %+))
    (define (+ a b) (%+ a b)))
  #:untrusted
  (import (foo)
    (rename (bar) (a b))
    (plus))
  (+ a b))
 (let ()
   (define a-1 42)
   (define a 10)
   (define (+-1 a b) (+ a b))
   (+-1 a-1 a)))

(test-library-group
 (library-group
  (library (ctplus)
    (export (rename ctplus +))
    (import (hoot primitives))
    (define-syntax ctplus
      (lambda (stx)
        (syntax-case stx ()
          ((_ a b)
           (%+ (syntax->datum #'a)
               (syntax->datum #'b)))))))
  (import (ctplus))
  (+ 42 10))
 (let ()
   (define _ (if #f #f)) ;; The ctplus binding, not residualized.
   52))

(test-library-group
 (library-group
  (library (ct10)
    (export ten)
    (import (hoot primitives))
    (define ten 10))
  (library (ctplus10)
    (export ctplus10)
    (import (hoot primitives) (ct10))
    (define-syntax ctplus10
      (lambda (stx)
        (syntax-case stx ()
          ((_ a)
           (%+ (syntax->datum #'a) ten))))))
  (import (ctplus10))
  (ctplus10 42))
 (let ()
   (define ten 10)
   (define _ (if #f #f)) ;; The ctplus10 binding, not residualized.
   52))

(test-library-group
 (library-group
  (library (inc)
    (export inc)
    (import (hoot primitives))
    (define-syntax-rule (1+ x)
      (%+ x 1))
    (define (inc x) (1+ x)))
  (import (inc))
  (inc 42))
 ;; A very silly tree-il->scheme rendering, but it is correct.
 (let inc ((x 42))
   (+ x 1)))

(test-end* "test-library-group")