;;; Library parser
;;; Copyright (C) 2024, 2025 Igalia, S.L.
;;; Copyright (C) 2025 David Thompson <dave@spritely.institute>
;;;
;;; 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 for `define-module`, `define-library`, and `library` forms.
;;;
;;; Code:

(define-library (hoot library)
  (export <iset-library>
          make-iset-library
          iset-library?
          iset-library-name
          iset-library-version

          <iset-only>
          make-iset-only
          iset-only?
          iset-only-iset
          iset-only-ids

          <iset-except>
          make-iset-except
          iset-except?
          iset-except-iset
          iset-except-ids

          <iset-rename>
          make-iset-rename
          iset-rename?
          iset-rename-iset
          iset-rename-renamings

          <iset-prefix>
          make-iset-prefix
          iset-prefix?
          iset-prefix-iset
          iset-prefix-prefix

          <iset-rename-proc>
          make-iset-rename-proc
          iset-rename-proc?
          iset-rename-proc-iset
          iset-rename-proc-exp

          <library>
          make-library
          library?
          library-src
          library-name
          library-version
          library-trusted?
          library-duplicates
          library-exports
          library-replacements
          library-isets
          library-body

          %default-guile-duplicates
          parse-guile-import
          finish-guile-imports
          parse-guile-library
          parse-r6rs-library
          parse-r7rs-imports
          parse-r7rs-library
          parse-library)
  (import (ice-9 match)
          (srfi srfi-9))
  (cond-expand
   (hoot
    (import (hoot assoc)
            (hoot eq)
            (hoot errors)
            (hoot keywords)
            (hoot lists)
            (hoot not)
            (hoot numbers)
            (hoot pairs)
            (hoot strings)
            (hoot symbols)
            (hoot syntax)
            (hoot syntax-objects)
            (hoot values)
            (hoot write)))
   (guile
    (import (guile)
            (only (srfi srfi-1) fold fold-right)
            (only (system syntax internal) syntax? syntax-sourcev))))

  (begin
    (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)
      iset-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))

    ;; For define-module only, where procedural renaming is allowed.
    (define-record-type <iset-rename-proc>
      (make-iset-rename-proc iset exp)
      iset-rename-proc?
      (iset iset-rename-proc-iset)
      (exp iset-rename-proc-exp))

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

      (define (id? x) (symbol? 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-r6rs-name+version name+version)
        (define (parse-srfi-n n)
          (let ((s (symbol->string n)))
            (if (eqv? (string-ref s 0) #\:)
                (string->symbol (string-append "srfi-" (string-drop s 1)))
                n)))
        (define (parse-name name)
          (match name
            (('srfi n . rest)               ; canonicalize SRFI names
             `(srfi ,(parse-srfi-n n) ,@rest))
            (_ name)))
        (match name+version
          (((? id? name) ... ((? version-component? version) ...))
           (values (parse-name name) version))
          (((? id? name) ...)
           (values (parse-name name) '()))))

      (define (parse-r6rs-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-r6rs-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) ...)
          (match exports
            (() '())
            ((spec . exports)
             (match spec
               ((? id? id)
                (cons (cons id id) (parse-exports exports)))
               (('rename . renames)
                (let lp ((renames renames))
                  (match renames
                    (() (parse-exports exports))
                    ((((? id? from) (? id? to)) . renames)
                     (cons (cons from to) (lp renames))))))))))

        (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-r6rs-name+version (syntax->datum #'(name ...))))
             (define exports
               (parse-exports (syntax->datum #'(export-spec ...))))
             (define imports
               (parse-r6rs-imports (syntax->datum #'(import-spec ...))))
             (make-library src modname version trusted? #f
                           exports '() imports #'(body ...))))))

      (define (parse-r7rs-name name)
        (define (exact-non-negative-integer? x)
          (and (exact-integer? x) (not (negative? x))))
        (map (match-lambda
               ((? id? id) id)
               ((? exact-non-negative-integer? x)
                (string->symbol (number->string x))))
             name))

      (define (parse-r7rs-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)
                      (make-iset-library (parse-r7rs-name name) '()))))
               (_
                (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-r7rs-library form trusted? include-file features)
        "Given the R7RS 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))

        (define (include-files filenames tail)
          (fold-right (lambda (filename tail)
                        (append (include-file filename) tail))
                      tail
                      filenames))

        (define (resolve-cond-expand form)
          (define (has-req? req)
            (match req
              (('and req ...)
               (and-map has-req? req))
              (('or req ...)
               (or-map has-req? req))
              (('not req)
               (not (has-req? req)))
              (('library lib-name)
               ;; FIXME: No libraries, for the time being.
               #f)
              ((? symbol? req)
               (memq req features))))
          (syntax-case form ()
            ((_ ce-clause ...)
             (let lp ((clauses #'(ce-clause ...)))
               (syntax-case clauses ()
                 (()
                  (syntax-violation 'cond-expand "Unfulfilled cond-expand" #'form))
                 (((else decl ...))
                  (symbolic-match? else)
                  #'(decl ...))
                 (((req decl ...) . clauses)
                  (if (has-req? (syntax->datum #'req))
                      #'(decl ...)
                      (lp #'clauses))))))))

        (syntax-case form ()
          ((define-library (name ...) clause ...)
           (symbolic-match? define-library)
           (let ((modname (parse-r7rs-name (syntax->datum #'(name ...))))
                 (src (and (syntax? #'library) (syntax-sourcev #'library))))
             (let lp ((clauses #'(clause ...)) (exports '()) (imports '()) (body '()))
               (syntax-case clauses ()
                 (()
                  (make-library src modname '() trusted? #f exports
                                '() imports body))
                 (((export spec ...) . clauses)
                  (symbolic-match? export)
                  (lp #'clauses
                      (append (parse-exports (syntax->datum #'(spec ...))) exports)
                      imports
                      body))
                 (((import spec ...) . clauses)
                  (symbolic-match? import)
                  (lp #'clauses
                      exports
                      (append (parse-r7rs-imports (syntax->datum #'(spec ...)))
                              imports)
                      body))
                 (((begin form ...) . clauses)
                  (symbolic-match? begin)
                  (lp #'clauses
                      exports
                      imports
                      #`(form ... . #,body)))
                 (((include filename ...) . clauses)
                  (and (symbolic-match? include)
                       (and-map string? #'(filename ...)))
                  (lp #'clauses
                      exports
                      imports
                      (include-files (syntax->datum #'(filename ...)) body)))
                 (((include-ci filename ...) . clauses)
                  (and (symbolic-match? include-ci)
                       (and-map string? #'(filename ...)))
                  (lp #'clauses
                      exports
                      imports
                      ;; FIXME: Actually be case-insensitive!
                      (include-files (syntax->datum #'(filename ...)) body)))
                 (((include-library-definitions filename ...) . clauses)
                  (and (symbolic-match? include-library-definitions)
                       (and-map string? #'(filename ...)))
                  (lp (include-files (syntax->datum #'(filename ...)) #'clauses)
                      exports
                      imports
                      body))
                 (((cond-expand . ce-clauses) . clauses)
                  (symbolic-match? cond-expand)
                  (lp (append (resolve-cond-expand #'(cond-expand . ce-clauses))
                              #'clauses)
                      exports
                      imports
                      body))))))))

      (define (convert-sloppy-keyword x)
        (if (symbol? x)
            (let ((str (symbol->string x)))
              (if (string-prefix? ":" str)
                  (symbol->keyword (string->symbol (substring str 1)))
                  x))
            x))

      (define (parse-guile-import ispec)
        (define (parse-args args)
          (let lp ((args args) (select #f) (hide #f) (prefix #f) (renamer #f) (version #f))
            (match args
              (()
               (values select (or hide '()) prefix renamer (or version '())))
              (((= convert-sloppy-keyword kw) . args)
               (unless (keyword? kw)
                 (syntax-violation 'use-module "expected a keyword argument" ispec
                                   (datum->syntax ispec kw)))
               (match args
                 ((val . args)
                  (match kw
                    (#:select
                     (when select
                       (syntax-violation 'use-module "too many #:select clauses"
                                         ispec))
                     (lp args
                         (match val
                           (((or (? id?) ((? id?) . (? id?))) ...) val)
                           (_
                            (syntax-violation 'use-module "bad #:select declaration"
                                              ispec val)))
                         hide prefix renamer version))
                    (#:hide
                     (when hide
                       (syntax-violation 'use-module "too many #:hide clauses"
                                         ispec))
                     (lp args select
                         (match val
                           (((or (? id?) ((? id?) . (? id?))) ...) val)
                           (_
                            (syntax-violation 'use-module "bad #:select declaration"
                                              ispec val)))
                         prefix renamer version))
                    (#:renamer
                     (when (or prefix renamer)
                       (syntax-violation 'use-module "too many #:renamer/#:prefix clauses"
                                         ispec))
                     (lp args select hide prefix val version))
                    (#:prefix
                     (when (or prefix renamer)
                       (syntax-violation 'use-module "too many #:renamer/#:prefix clauses"
                                         ispec))
                     (lp args select hide
                         (match val
                           ((? id?) val)
                           (else
                            (syntax-violation 'use-module "invalid #:prefix"
                                              ispec val)))
                         renamer version))
                    (#:version
                     (when version
                       (syntax-violation 'use-module "too many #:version clauses"
                                         ispec))
                     (lp args select hide prefix renamer
                         (match val
                           (((? version-component?) ...) val)
                           (else
                            (syntax-violation 'use-module "invalid #:version"
                                              ispec val)))))
                    (_
                     (syntax-violation 'use-module "unrecognized keyword arg"
                                       ispec kw))))
                 (_
                  (syntax-violation 'use-module "missing keyword argument" ispec
                                    kw)))))))
        (match (syntax->datum ispec)
          (((? id? mod) ...)
           (make-iset-library mod '()))
          ((((? id? mod) ...) arg ...)
           (call-with-values (lambda () (parse-args arg))
             (lambda (select hide prefix renamer version)
               (let* ((iset (make-iset-library mod version))
                      (iset (if (null? hide)
                                iset
                                (make-iset-except iset hide)))
                      (iset (if select
                                (make-iset-only
                                 iset
                                 (map (match-lambda
                                        ((from . to) from)
                                        (var var))
                                      select))
                                iset))
                      (iset (if (and select (or-map pair? select))
                                (make-iset-rename
                                 iset
                                 (filter pair? select))
                                iset))
                      (iset (if prefix
                                (make-iset-prefix iset prefix)
                                (if renamer
                                    (make-iset-rename-proc iset renamer)
                                    iset))))
                 iset))))
          (_
           (syntax-violation 'use-module "invalid guile module import" ispec))))

      (define* (finish-guile-imports imports #:key pure?)
        (if pure?
            imports
            (cons (make-iset-library '(guile) '()) imports)))

      (define %default-guile-duplicates '(replace warn-override-core warn last))

      (define (parse-guile-library head body trusted?)
        (define (parse-exports val prev)
          (syntax-case val ()
            ((spec ...)
             (fold
              (lambda (spec prev)
                (syntax-case spec ()
                  (id
                   (id? (syntax->datum #'id))
                   (acons (syntax->datum #'id) (syntax->datum #'id)
                          prev))
                  ((from . to)
                   (and (id? (syntax->datum #'from))
                        (id? (syntax->datum #'to)))
                   (acons (syntax->datum #'from) (syntax->datum #'to)
                          prev))
                  (_
                   (syntax-violation 'define-module "invalid export"
                                     head spec))))
              prev #'(spec ...)))
            (_
             (syntax-violation 'define-module "invalid export list"
                               head #'val))))

        (define (parse-autoload modname bindings)
          (match (syntax->datum modname)
            (((? id? modname) ...)
             (match (syntax->datum bindings)
               (((? id? bindings) ...)
                (make-iset-only (make-iset-library modname '()) bindings))
               (_
                (syntax-violation 'define-module "bad #:autoload bindings"
                                  head bindings))))
            (_
             (syntax-violation 'define-module "bad #:autoload module name"
                               head modname))))

        (define (duplicate-resolver? x)
          (memq x '(check first last noop replace warn warn-override-core
                          merge-generics merge-accessors)))

        (define (parse-define-module-args args)
          (let parse ((args args)
                      (imports '()) (exports '()) (replacements '())
                      (version #f) (pure? #f)
                      (duplicates %default-guile-duplicates))
            (syntax-case args ()
              (()
               (values (finish-guile-imports (reverse imports) #:pure? pure?)
                       (reverse exports)
                       (reverse replacements)
                       version duplicates))
              ((kw . args)
               (match (convert-sloppy-keyword (syntax->datum #'kw))
                 (#:pure
                  (parse #'args imports exports replacements version #t duplicates))
                 (#:no-backtrace
                  ;; Ignore.
                  (parse #'args imports exports replacements version pure? duplicates))
                 ((? keyword? kw')
                  (syntax-case #'args ()
                    ((val . args)
                     (match kw'
                       (#:version
                        (when version
                          (syntax-violation 'define-module "duplicate #:version"
                                            head #'val))
                        (match (syntax->datum #'val)
                          (((? version-component? version) ...)
                           (parse #'args imports exports replacements
                                  version pure? duplicates))
                          (_
                           (syntax-violation 'define-module "invalid #:version"
                                             head #'val))))
                       (#:duplicates
                        (match (syntax->datum #'val)
                          ((and ((? duplicate-resolver?) ..1) duplicates)
                           (parse #'args imports exports replacements
                                  version pure? duplicates))
                          (_
                           (syntax-violation 'define-module "invalid #:duplicates"
                                             head #'val))))
                       (#:filename
                        ;; Ignore.
                        (parse #'args imports exports replacements
                               version pure? duplicates))
                       (#:declarative?
                        (syntax-case #'val ()
                          (#t
                           (parse #'args imports exports replacements
                                  version pure? duplicates))
                          (_
                           (syntax-violation
                            'define-module
                            "library-group only supports modules with #:declarative? #t"
                            head #'val))))
                       (#:use-module
                        (let ((ispec (parse-guile-import #'val)))
                          (parse #'args (cons ispec imports) exports replacements
                                 version pure? duplicates)))
                       (#:use-syntax
                        (syntax-violation 'define-module "#:use-syntax not supported"
                                          head #'val))
                       ((or #:export #:re-export
                            #:export-syntax #:re-export-syntax)
                        (parse #'args imports (parse-exports #'val exports) replacements
                               version pure? duplicates))
                       ((or #:replace #:replace-syntax
                            #:re-export-and-replace)
                        (parse #'args imports exports (parse-exports #'val replacements)
                               version pure? duplicates))
                       (#:autoload
                        (syntax-case #'args ()
                          ((bindings . args)
                           (let ((ispec (parse-autoload #'val #'bindings)))
                             (parse #'args (cons ispec imports) exports replacements
                                    version pure? duplicates)))
                          (_
                           (syntax-violation 'define-module "missing #:autoload bindings"
                                             head #'(val . args)))))
                       (_
                        (syntax-violation 'define-module "unrecognized keyword arg"
                                          head #'kw))))
                    (_
                     (syntax-violation 'define-module "missing value for keyword arg"
                                       head #'kw))))
                 (_
                  (syntax-violation 'define-module "expected a keyword arg"
                                    head #'kw))))
              (_ (syntax-violation 'define-module "invalid form" head)))))

        (syntax-case head ()
          ((define-module (modname ...) arg ...)
           (and-map id? (syntax->datum #'(modname ...)))
           (call-with-values (lambda () (parse-define-module-args #'(arg ...)))
             (lambda (imports exports replacements version duplicate-handler)
               (define src
                 (and (syntax? #'define-module) (syntax-sourcev #'define-module)))
               (make-library src (syntax->datum #'(modname ...)) version trusted?
                             duplicate-handler exports replacements imports body))))
          (_
           (syntax-violation 'define-module "invalid define-module form" head))))

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

      (define* (parse-library forms trusted? #:key (include-file includes-forbidden)
                              (features '()))
        "Parse @var{forms} to a @code{<library>} record."
        (syntax-case forms ()
          (((library . body))
           (symbolic-match? library)
           (parse-r6rs-library #'(library . body) trusted?))
          (((define-library . body))
           (symbolic-match? define-library)
           (parse-r7rs-library #'(define-library . body) trusted? include-file
                               features))
          (((define-module modname . modargs) . body)
           (symbolic-match? define-module)
           (parse-guile-library #'(define-module modname . modargs) #'body
                                trusted?))
          (_
           (error "invalid module forms" forms))))))
