;;; WebAssembly support library
;;; Copyright (C) 2026 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:
;;;
;;; Subtyping.
;;;
;;; Code:

(define-module (wasm subtyping)
  #:use-module (ice-9 match)
  #:use-module (wasm types)
  #:use-module (wasm canonical-types)
  #:export (heap-type<?
            heap-type<=?
            val-type<=?))

(define* (heap-type<? ht1 ht2 canonicalization)
  "Given two heap types (either as symbols like @code{any}, @code{eq}, and
so on or as heap type indices), return true if the first is a strict
subtype of the second."
  (define (base-heap-type<? base)
    (match base
      (($ <func-sig>)
       (match ht2
         ('func #t)
         (_ #f)))
      (($ <struct-type>)
       (match ht2
         ((or 'any 'eq 'struct) #t)
         (_ #f)))
      (($ <array-type>)
       (match ht2
         ((or 'any 'eq 'array) #t)
         (_ #f)))))

  (match ht1
    ((or 'eq 'string)
     (match ht2
       ('any #t)
       (_ #f)))
    ((or 'i31 'struct 'array)
     (match ht2
       ((or 'eq 'any) #t)
       (_ #f)))
    ((or 'any 'extern 'func 'exn)
     #f)
    ((? exact-integer?)
     (match (canonical-type-ref canonicalization ht1)
       (($ <sub-type> final? () base)
        (base-heap-type<? base))
       (($ <sub-type> final? (super) base)
        (heap-type<=? super ht2 canonicalization))
       (base (base-heap-type<? base))))
    ('nofunc
     (and (not (eq? ht1 ht2)) (heap-type<=? ht2 'func canonicalization)))
    ('noextern
     (and (not (eq? ht1 ht2)) (heap-type<=? ht2 'extern canonicalization)))
    ('none
     (and (not (eq? ht1 ht2)) (heap-type<=? ht2 'any canonicalization)))
    ('noexn
     (and (not (eq? ht1 ht2)) (heap-type<=? ht2 'exn canonicalization)))))

(define* (heap-type<=? ht1 ht2 canonicalization)
  "Given two heap types (either as symbols like @code{any}, @code{eq}, and
so on or as heap type indices), return true if the first is a subtype of
the second."
  (or (eq? ht1 ht2)
      (heap-type<? ht1 ht2 canonicalization)))

(define* (val-type<=? t1 t2 canonicalization)
  "Given two value types (either as symbols like @code{i32}, @code{f64},
and so on or as @code{<ref-type>} instances), return true if the first
is a subtype of the second."
  (define (unabbreviate type)
    (match type
      ('nullexnref 'noexn)
      ('nullfuncref 'nofunc)
      ('nullexternref 'noextern)
      ('nullref 'none)
      ('funcref 'func)
      ('externref 'extern)
      ('anyref 'any)
      ('eqref 'eq)
      ('i31ref 'i31)
      ('structref 'struct)
      ('arrayref 'array)
      ('exnref 'exn)
      ('stringref 'string)
      ('stringview_wtf8ref 'stringview_wtf8)
      ('stringview_wtf16ref 'stringview_wtf16)
      ('stringview_iterref 'stringview_iter)
      (_ #f)))

  (define (ref-types<=? t1-nullable? t1-ht t2-nullable? t2-ht)
    (and (or t2-nullable? (not t1-nullable?))
         (heap-type<=? t1-ht t2-ht canonicalization)))

  (define (ref-type<=? t1-nullable? t1-ht t2)
    (cond
     ((ref-type? t2)
      (ref-types<=? t1-nullable? t1-ht
                    (ref-type-nullable? t2) (ref-type-heap-type t2)))
     ((unabbreviate t2)
      => (lambda (t2-ht)
           (ref-types<=? t1-nullable? t1-ht #t t2-ht)))
     (else #f)))

  (cond
   ((eq? t1 t2) #t)
   ((ref-type? t1)
    (ref-type<=? (ref-type-nullable? t1) (ref-type-heap-type t1) t2))
   ((unabbreviate t1)
    => (lambda (t1-heap-type)
         (ref-type<=? #t t1-heap-type t2)))
   (else #f)))
