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

;;; Library-group expander
;;; 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:
;;;
;;; Parser, linker, and expander for `library-group` form.
;;;
;;; Code:

(define-module (hoot library-group)
  #:use-module (ice-9 match)
  #:use-module (language tree-il)
  #:use-module (language tree-il primitives)
  #:use-module ((srfi srfi-1) #:select (append-map partition fold))
  #:use-module (srfi srfi-9)
  #:use-module ((system syntax internal) #:select (syntax? syntax-sourcev))
  #:export (library-group?
            parse-r6rs-library
            parse-library-group
            link-library-group
            expand-library-group))

(define-record-type <iset-library>
  (make-iset-library name version)
  iset-library?
  (name iset-library-name)
  (version iset-library-version))

(define-record-type <iset-only>
  (make-iset-only iset ids)
  only?
  (iset iset-only-iset)
  (ids iset-only-ids))

(define-record-type <iset-except>
  (make-iset-except iset ids)
  iset-except?
  (iset iset-except-iset)
  (ids iset-except-ids))

(define-record-type <iset-rename>
  (make-iset-rename iset renamings)
  iset-rename?
  (iset iset-rename-iset)
  (renamings iset-rename-renamings))

(define-record-type <iset-prefix>
  (make-iset-prefix iset prefix)
  iset-prefix?
  (iset iset-prefix-iset)
  (prefix iset-prefix-prefix))

(define-record-type <library>
  (make-library src name version trusted? exports isets body)
  library?
  (src library-src)
  (name library-name)
  (version library-version)
  (trusted? library-trusted?)
  (exports library-exports)
  (isets library-isets)
  (body library-body))

(define-record-type <program>
  (make-program src trusted? isets body)
  program?
  (src program-src)
  (trusted? program-trusted?)
  (isets program-isets)
  (body program-body))

(define-record-type <library-group>
  (make-library-group src libraries program)
  library-group?
  (src library-group-src)
  (libraries library-group-libraries)
  (program library-group-program))

(define imported-library-name
  (match-lambda
    (($ <iset-only> iset select) (imported-library-name iset))
    (($ <iset-except> iset hide) (imported-library-name iset))
    (($ <iset-rename> iset renamings) (imported-library-name iset))
    (($ <iset-prefix> iset prefix) (imported-library-name iset))
    (($ <iset-library> name version) name)))

(define (id? x) (symbol? x))
(define (name-component? x) (id? x))
(define (version-component? x) (and (exact-integer? x) (not (negative? x))))
(define (name-matches? stx sym)
  (eq? (syntax->datum stx) sym))
(define-syntax-rule (symbolic-match? name)
  (name-matches? #'name 'name))

(define parse-name+version
  (match-lambda
    (((? name-component? name) ... ((? version-component? version) ...))
     (values name version))
    (((? name-component? name) ...)
     (values name '()))))

(define (includes-forbidden filename)
  (error "library-group include clause forbidden" filename))

(define (parse-imports import-sets)
  (define parse-import-set
    (match-lambda
      ((head . tail)
       (match head
         ('only
          (match tail
            ((iset (? id? select) ...)
             (make-iset-only (parse-import-set iset) select))))
         ('except
          (match tail
            ((iset (? id? hide) ...)
             (make-iset-except (parse-import-set iset) hide))))
         ('prefix
          (match tail
            ((iset (? id? prefix))
             (make-iset-prefix (parse-import-set iset) prefix))))
         ('rename
          (match tail
            ((iset ((? id? from) (? id? to)) ...)
             (make-iset-rename (parse-import-set iset) (map cons from to)))))
         ('library
             (match tail
               ((name+version)
                (call-with-values (lambda ()
                                    (parse-name+version name+version))
                  (lambda (name version)
                    (make-iset-library name version))))))
         (_
          (parse-import-set `(library (,head . ,tail))))))))
  (map (match-lambda
         ;; Strip level.
         (('for iset level ...) (parse-import-set iset))
         (iset                  (parse-import-set iset)))
       import-sets))

(define (parse-r6rs-library form trusted?)
  "Given the R6RS library @var{form}, as a syntax object, parse out the
imports and exports to a @code{library}."
  (define (parse-exports exports)
    ;; -> ((local . public) ...)
    (map (match-lambda
           ((? id? id) (cons id id))
           (('rename (? id? from) (? id? to)) (cons from to)))
         exports))

  (syntax-case form ()
    ((library (name ...)
       (export export-spec ...)
       (import import-spec ...)
       body ...)
     (and (symbolic-match? library)
          (symbolic-match? export)
          (symbolic-match? import))
     (let ()
       (define src
         (and (syntax? #'library) (syntax-sourcev #'library)))
       (define-values (modname version)
         (parse-name+version (syntax->datum #'(name ...))))
       (define exports
         (parse-exports (syntax->datum #'(export-spec ...))))
       (define imports
         (parse-imports (syntax->datum #'(import-spec ...))))
       (make-library src modname version trusted? exports imports
                     #'(body ...))))))

(define* (parse-library-group form #:key (include-file includes-forbidden))
  "Parse a @code{library-group} form to a @code{<library-group>} record,
processing includes.  No other expansion or analysis is performed beyond
syntactic validity."
  
  (define* (parse forms libraries #:key (trusted? #f))
    "For each form in @var{forms}, which should be a list of syntax objects,
process any includes, collecting the prefix of @code{<library>} forms
and then parsing the tail @code{<program>}, or @code{#f} if there is no
program."
    (syntax-case forms ()
      (() (values (reverse libraries) #f))
      ((form . forms)
       (syntax-case #'form ()
         (#:untrusted
          (parse #'forms libraries #:trusted? #f))
         ((library . _)
          (symbolic-match? library)
          (parse #'forms (cons (parse-r6rs-library #'form trusted?) libraries)
                 #:trusted? trusted?))
         ((define-library . _)
          (symbolic-match? define-library)
          (error "R7RS libraries not yet supported"))
         ((include filename)
          (symbolic-match? include)
          (parse (append (include-file (syntax->datum #'filename)) #'forms)
                 libraries #:trusted? trusted?))
         ((import import-spec ...)
          (symbolic-match? import)
          (values (reverse libraries)
                  (make-program #f trusted?
                                (parse-imports
                                 (syntax->datum #'(import-spec ...)))
                                #'forms)))))))

  (syntax-case form ()
    ((library-group form ...)
     (symbolic-match? library-group)
     (let ((src (and (syntax? #'library-group)
                     (syntax-sourcev #'library-group))))
       (call-with-values (lambda () (parse #'(form ...) '() #:trusted? #t))
         (lambda (libraries program)
           (make-library-group src libraries program)))))
    (_
     (error "invalid library-group" form))))

(define* (link-library-group group #:key
                             (load-library (lambda (name) #f))
                             (allow-dangling-import? (lambda (name) #f)))
  (define linked '()) ;; List of libraries.
  (define by-name (make-hash-table))

  (define (link-library! library)
    (let ((name (library-name library)))
      (when (hash-ref by-name name)
        (error "duplicate library definition" name))
      (hash-set! by-name name 'linking)
      (for-each link-import! (library-isets library))
      (set! linked (cons library linked))
      (hash-set! by-name name 'linked)))

  (define (link-import! iset)
    (let ((name (imported-library-name iset)))
      (match (hash-ref by-name name 'unvisited)
        ('linked (values))
        ('linking (error "cycle in module graph" name))
        ('unvisited
         (cond
          ((load-library name) => link-library!)
          ((allow-dangling-import? name) (values))
          (else (error "module not found" name)))))))

  (match group
    (($ <library-group> src libraries program)
     (for-each link-library! libraries)
     (when program (for-each link-import! (program-isets program)))
     (make-library-group src (reverse linked) program))))

(define-record-type <import>
  (make-import modname exported-name imported-name)
  import?
  (modname import-modname)
  (exported-name exported-name)
  (imported-name imported-name))

(define-record-type <lexical>
  (make-lexical sym)
  lexical?
  (sym lexical-sym))

(define-record-type <primitive>
  (make-primitive name)
  primitive?
  (name primitive-name))

(define-record-type <expand-time-value>
  (make-expand-time-value)
  expand-time-value?)

;; <value> := <lexical>
;;          | <primitive>
;;          | <expand-time-value>
(define-record-type <module-definitions>
  (make-module-definitions private public)
  module-definitions?
  ;; Hash table of symbol -> <value>.
  (private module-private-definitions)
  ;; Hash table of symbol -> <value>.
  (public module-public-definitions))

(define-record-type <definition>
  (make-definition name sym val)
  definition?
  (name definition-name)
  (sym definition-sym)
  (val definition-val))

(define-record-type <statement>
  (make-statement exp)
  statement?
  (exp statement-exp))

;; FIXME: Get this exported from (language tree-il primitives).
(define (primitive-for-variable box)
  (hashq-ref (@@ (language tree-il primitives) *interesting-primitive-vars*)
             box))

(define (expand-library call-with-target mod form)
  "Expand the syntax object @var{form} in the module @var{mod}.

The term will be expanded twice: once to create the expand-time module,
which will then be evaluated directly, and once to residualize a Tree-IL
term for the compilation unit.

Syntax transformers (macros) will be evaluated at expansion-time, and
not residualized into the compilation unit."
  (save-module-excursion
   (lambda ()
     (set-current-module mod)
     (primitive-eval (macroexpand form 'e '(expand eval)))
     (call-with-target
      (lambda () (macroexpand form 'c '()))))))

(define (expand-program call-with-target mod form)
  "Expand the syntax object @var{form} in the module @var{mod}.

Syntax transformers (macros) will be evaluated at expansion-time, and
not residualized into the compilation unit."
  (save-module-excursion
   (lambda ()
     (set-current-module mod)
     (call-with-target
      (lambda () (macroexpand form 'c '(expand)))))))

(define* (expand-library-group group #:key
                               (call-with-target (lambda (f) (f)))
                               (primitives #f))
  "Take a @code{<library-group>} record and expand it to a big
@code{letrec*}.
The libraries in the group are expanded one-by-one.  Expanding a library
residualises a Tree-IL AST node as part of the compilation unit, and
additionally populates a compile-time host module with definitions.  If
expanding a module needs compile-time values from another module, it
uses the bindings in the host module.

All definitions and expressions in the expanded libraries are then
rewritten to be part of a big @code{letrec*}, and top-level and module
references in those definitions and expressions are rewritten to use
lexical references.

The final program in the @code{<library-group>} is given the same
treatment, except that its final expression (if any) is evaluated in
tail position."
  ;; A mapping from module,name,public? tuple to <binding> record, for
  ;; all modules in the library group.
  (define module-definitions (make-hash-table))
  (define (add-module-definitions! modname)
    (when (hash-ref module-definitions modname)
      (error "duplicate module" modname))
    (define defs
      (make-module-definitions (make-hash-table) (make-hash-table)))
    (hash-set! module-definitions modname defs)
    defs)
  (define (lookup-module-definitions modname)
    (or (hash-ref module-definitions modname)
        (error "unknown module" modname)))

  (define (add-definition! defs name public? value)
    (match defs
      (($ <module-definitions> private public)
       (let ((t (if public? public private)))
         (when (hashq-ref t name)
           (error "duplicate definition" name))
         (hashq-set! t name value)))))
  (define (lookup-definition defs name public?)
    (match defs
      (($ <module-definitions> private public)
       (hashq-ref (if public? public private) name))))

  ;; Add definitions from primitive module.
  (when primitives
    (let ((defs (add-module-definitions! primitives)))
      (module-for-each
       (lambda (name box)
         (add-definition! defs name #t
                          (match (primitive-for-variable box)
                            (#f (make-expand-time-value))
                            (name (make-primitive name)))))
       (resolve-interface primitives))))

  (define (parse-isets isets trusted?)
    (define parse-iset
      (match-lambda
        (($ <iset-only> iset select)
         (filter (match-lambda
                   (($ <import> mod-name exported imported)
                    (memq imported select)))
                 (parse-iset iset)))
        (($ <iset-except> iset hide)
         (filter (match-lambda
                   (($ <import> mod-name exported imported)
                    (not (memq imported hide))))
                 (parse-iset iset)))
        (($ <iset-prefix> iset prefix)
         (map (match-lambda
                (($ <import> mod-name exported imported)
                 (let ((renamed (symbol-append prefix imported)))
                   (make-import mod-name exported renamed))))
              (parse-iset iset)))
        (($ <iset-rename> iset renamings)
         (map (match-lambda
                (($ <import> mod-name exported imported)
                 (define renamed
                   (or (assq-ref renamings imported) imported))
                 (make-import mod-name exported renamed)))
              (parse-iset iset)))
        (($ <iset-library> modname version)
         (unless (null? version)
           (error "version references unsupported"))
         (when (equal? modname primitives)
           (unless trusted?
             (error "untrusted module cannot import primitives")))
         (let ((exports (module-public-definitions
                         (lookup-module-definitions modname))))
           (define (id<? a b)
             (string<? (symbol->string a) (symbol->string b)))
           (define (import<? a b)
             (id<? (exported-name a) (exported-name b)))
           (sort (hash-map->list (lambda (name binding)
                                   (make-import modname name name))
                                 exports)
                 import<?)))))
    (append-map parse-iset isets))

  ;; Because each invocation of expand-library-group gets its own
  ;; namespace, we don't have to deal with lingering definitions from
  ;; any previous expansion; all modules defined by this compilation
  ;; unit are fresh.  This also allows expansion to happen in parallel.
  (define namespace (gensym "%library-group"))

  (define (host-modname? modname)
    (match modname
      (() #f)
      ((head . tail)
       (not (eq? namespace head)))))
  (define (annotate-modname modname)
    (if (equal? modname primitives)
        modname
        (cons namespace modname)))
  (define (strip-modname modname)
    (match modname
      (((? (lambda (x) (eq? x namespace))) . modname) modname)
      (_
       (unless (equal? modname primitives)
         (error "unexpected modname" modname))
       modname)))

  (define (make-expand-time-module modname filename version imports exports)
    "Create the host module in which to store compile-time library
definitions.  The module may import other host libraries."
    (define imports-by-module (make-hash-table))
    (define (add-import! modname exported imported)
      (define tail (hash-ref imports-by-module modname '()))
      (define entry (cons exported imported))
      (hash-set! imports-by-module modname (cons entry tail)))
    (for-each (match-lambda
                (($ <import> modname exported imported)
                 (add-import! modname exported imported)))
              imports)
    (define (id<? a b)
      (string<? (symbol->string a) (symbol->string b)))
    (define (modname<? a b)
      (match a
        (() #t)
        ((a . a*) (match b
                    (() #f)
                    ((b  . b*) (and (id<? a b) (modname<? a* b*)))))))
    (define module-import-decls
      (sort (hash-map->list (lambda (modname entries)
                              (list (annotate-modname modname)
                                    #:select
                                    (sort entries
                                          (lambda (a b)
                                            (id<? (car a) (car b))))))
                            imports-by-module)
            (lambda (a b)
              (modname<? (car a) (car b)))))
    (define-values (module-export-decls module-re-export-decls)
      (let ()
        (define imports-by-name (make-hash-table))
        (for-each (match-lambda
                    ((and import ($ <import> _ _ imported))
                     (match (hashq-ref imports-by-name imported)
                       (#f (hashq-set! imports-by-name imported import))
                       (existing
                        (error "duplicate imports" existing import)))))
                  imports)
        (partition (match-lambda
                     ((local . public) (not (hashq-ref imports-by-name local))))
                   exports)))
    (define-module* (annotate-modname modname)
      #:filename filename
      #:pure #t
      #:version version
      #:imports module-import-decls
      #:exports module-export-decls
      #:re-exports module-re-export-decls
      #:declarative? #t))

  (define (tree-il->reversed-bindings exp modname imports exports bindings)
    "Given the expanded library @var{exp}, as a Tree-IL node, transform it to
a sequence of definitions and expressions, as @code{<binding>} nodes.
Rewrite references to other top-level bindings to refer to primitive or
lexical definitions.  Append those @code{<binding>} nodes to
@var{bindings}, in reverse order."
    ;; Make defs for module.
    (define defs (add-module-definitions! modname))

    (define (has-expand-time-value? name)
      (module-variable (resolve-module (annotate-modname modname)) name))

    ;; Add definitions for imports.
    (for-each (match-lambda
                (($ <import> imod exported imported)
                 (match (lookup-definition (lookup-module-definitions imod)
                                           exported #t)
                   (#f (error "unknown import?" imod exported))
                   (value (add-definition! defs imported #f value)))))
              imports)

    (define (tree-il-for-each f exp)
      (define fold (make-tree-il-folder))
      (fold exp (lambda (exp) (values)) f))

    ;; Prohibit set! to imports.  Check module on expanded toplevel defs
    ;; and uses.
    (tree-il-for-each (match-lambda
                        (($ <toplevel-define> src mod name val)
                         (unless (equal? (strip-modname mod) modname)
                           (error "unexpected mod" exp mod modname))
                         (values))
                        (($ <toplevel-ref> src mod name)
                         (unless (equal? (strip-modname mod) modname)
                           (error "unexpected mod" exp mod modname))
                         (values))
                        (($ <toplevel-set> src mod name val)
                         (unless (equal? (strip-modname mod) modname)
                           (error "unexpected mod" exp mod modname))
                         (when (lookup-definition defs name #f)
                           (error "set! to imported binding" src name))
                         (values))
                        (_ (values)))
                      exp)

    ;; Record local definitions and allocate lexicals for them.
    (tree-il-for-each (match-lambda
                        (($ <toplevel-define> src mod name exp)
                         (when (lookup-definition defs name #f)
                           (error "duplicate definition" modname name))
                         (add-definition! defs name #f (make-lexical (gensym "top")))
                         (values))
                        (_ (values)))
                      exp)

    ;; Check for unbound top-levels.
    (tree-il-for-each (match-lambda
                        (($ <toplevel-ref> src mod name)
                         (unless (lookup-definition defs name #f)
                           (error "unbound top-level" src name))
                         (values))
                        (($ <toplevel-set> src mod name val)
                         (unless (lookup-definition defs name #f)
                           (error "unbound top-level" src name))
                         (values))
                        (($ <module-ref> src mod name public?)
                         (unless (or (host-modname? mod)
                                     (let ((defs (lookup-module-definitions
                                                  (strip-modname mod))))
                                       (lookup-definition defs name public?)))
                           (error "unbound macro-introduced top-level for module"
                                  src (strip-modname mod) name))
                         (values))
                        (($ <module-set> src mod name public? val)
                         (unless (let ((defs (lookup-module-definitions
                                              (strip-modname mod))))
                                   (lookup-definition defs name public?))
                           (error "unbound macro-introduced top-level for module"
                                  src (strip-modname mod) name))
                         (values))
                        (_ (values)))
                      exp)

    ;; Find local definitions for exports.
    (for-each (match-lambda
                ((local . exported)
                 (match (lookup-definition defs local #f)
                   (#f
                    ;; An export without a binding in the compilation
                    ;; unit.  Perhaps it is an expansion-time binding.
                    (unless (has-expand-time-value? local)
                      (error "missing definition for export"
                             modname local exported))
                    (let ((val (make-expand-time-value)))
                      (add-definition! defs local #f val)
                      (add-definition! defs exported #t val)))
                   (val (add-definition! defs exported #t val)))))
              exports)

    ;; Resolve references to local definitions and residualized
    ;; module-private definitions to lexical-ref or primitive-ref.
    (define (visit-expr exp)
      (post-order
       (lambda (exp)
         (match exp
           (($ <toplevel-ref> src mod name)
            (match (lookup-definition defs name #f)
              (($ <lexical> sym) (make-lexical-ref src name sym))
              (($ <primitive> name) (make-primitive-ref src name))
              (($ <expand-time-value>)
               (error "reference to expansion-time value in generated code"
                      src modname name))))
           (($ <toplevel-set> src mod name val)
            (match (lookup-definition defs name #f)
              (($ <lexical> sym) (make-lexical-set src name sym val))
              (($ <expand-time-value>)
               (error "reference to expansion-time value in generated code"
                      src modname name))))
           (($ <module-ref> src (? host-modname? mod) name #f)
            ;; A primitive reference introduced by a primitive syntax
            ;; expander.
            (match (primitive-for-variable
                    (module-variable (resolve-module mod) name))
              (#f (error "can't find name for primitive reference" mod name))
              (name (make-primitive-ref src name))))
           (($ <module-ref> src mod name public?)
            (let ((defs (lookup-module-definitions (strip-modname mod))))
              (match (lookup-definition defs name public?)
                (($ <lexical> sym) (make-lexical-ref src name sym))
                (($ <primitive> name) (make-primitive-ref src name))
                (($ <expand-time-value>)
                 (error "reference to expansion-time value in generated code"
                        src mod name)))))
           (($ <module-set> src mod name public? val)
            (let ((defs (lookup-module-definitions (strip-modname mod))))
              (match (lookup-definition defs name public?)
                (($ <lexical> sym) (make-lexical-set src name sym val))
                (($ <expand-time-value>)
                 (error "reference to expansion-time value in generated code"
                        src mod name)))))
           (($ <toplevel-define>)
            (error "unexpected nested toplevel define" exp))
           (($ <call> src ($ <primitive-ref> _ name) args)
            (expand-primcall (make-primcall src name args)))
           (_ exp)))
       exp))

    ;; Walk the chain of <seq> and <toplevel-define> to extract
    ;; definitions and statements.
    (define (visit-top-level exp bindings)
      (match exp
        (($ <toplevel-define> src mod name val)
         (match (lookup-definition defs name #f)
           (($ <lexical> sym)
            (cons (make-definition name sym (visit-expr val))
                  bindings))))

        (($ <seq> src head tail)
         (visit-top-level tail (visit-top-level head bindings)))

        ;; Could fold in let and letrec* bindings.  Dunno.
        (_ (cons (make-statement (visit-expr exp)) bindings))))

    (visit-top-level exp bindings))

  (define (srcv-filename srcv)
    (match srcv
      (#f #f)
      (#(filename line column) filename)))

  (define (library->reversed-bindings library bindings)
    "Given the R6RS library @var{form}, as a syntax object, parse out the
imports and exports, create a compile-time module, and expand the body
of the library within that module.  Add the residual definitions and
expressions from the module to @var{bindings}, as in
@code{tree-il->reversed-bindings}."
    (match library
      (($ <library> src modname version trusted? exports isets body)
       (define filename (srcv-filename src))
       (define imports (parse-isets isets trusted?))
       (define ctmod
         (make-expand-time-module modname filename version imports exports))
       (define expanded
         (expand-library call-with-target ctmod #`(begin . #,body)))
       (tree-il->reversed-bindings expanded modname imports exports
                                   bindings))))

  (define (program->reversed-bindings program bindings)
    "Same as @code{r6rs-library->reversed-bindings}, but for a program.
@var{imports} is already parsed, as a list of @code{<import>}.  A new
module with a fresh name will be defined for the purposes of expanding "
    (match program
      (#f (cons (make-statement (make-void #f)) bindings))
      (($ <program> src trusted? isets body)
       (define modname (list (gensym "library-group-program")))
       (define filename (srcv-filename src))
       (define imports (parse-isets isets trusted?))
       (define ctmod
         (make-expand-time-module modname filename '() imports '()))
       (define expanded
         (expand-program call-with-target ctmod #`(begin . #,body)))
       (tree-il->reversed-bindings expanded modname imports '() bindings))))

  (define reversed-bindings
    (match group
      (($ <library-group> src libraries program)
       (program->reversed-bindings
        program
        (fold library->reversed-bindings '() libraries)))))

  (match reversed-bindings
    ((($ <statement> tail) . bindings)
     (let ((bindings (reverse bindings)))
       (make-letrec (library-group-src group)
                    #t                  ; in-order?
                    (map (match-lambda
                           (($ <definition> name sym val) name)
                           (($ <statement> exp) '_))
                         bindings)
                    (map (match-lambda
                           (($ <definition> name sym val) sym)
                           (($ <statement> exp) (gensym "_")))
                         bindings)
                    (map (match-lambda
                           (($ <definition> name sym val) val)
                           (($ <statement> exp)
                            (if (void? exp)
                                exp
                                (make-seq #f exp (make-void #f)))))
                         bindings)
                    tail)))))