;;;; symbol-module-name-utils.scm  -*- Scheme -*-
;;;; Kon Lovett, Sep '25

(module symbol-module-name-utils

(;export
  module-printname module-printnames
  canonical-module-name canonicalize-module-name)

(import scheme utf8)
(import (chicken base))
(import (chicken type))
(import (chicken fixnum))
(import (only (chicken string) reverse-string-append))
(import (only (srfi 1) every reverse!))
(import utf8-srfi-13)

(: module-printname (* -> (or false string)))
(: module-printnames (* -> (or false (list-of string))))

(: canonical-module-name (* -> (or false symbol)))
(: canonicalize-module-name (* -> symbol))

;;

(define (norm-module-printname obj)
  (cond ((string? obj) obj)
        ((symbol? obj) (symbol->string obj))
        ((list? obj)
          (and-let* ((l (foldl
                          (lambda (l s)
                            (and (list? l) (symbol? s)
                                 (cons (symbol->string s) l)))
                          '() obj)) )
          (string-concatenate (intersperse (reverse! l) ".")) ) )
        (else #f)) )

(define (srfi-module-printname obj)
  (and (list? obj) (fx= 2 (length obj))
       (eq? 'srfi (car obj))
       (and-let* ((n (cadr obj))
                  ((and (fixnum? n) (not (fx< n 0)))) )
         (string-append "srfi-" (number->string n)) ) ) )

(define (module-printname obj)
  (or (srfi-module-printname obj)
      (norm-module-printname obj)) )

(define (module-printnames obj)
  (and (list? obj)
       (and-let* ((l (foldl
                       (lambda (l s)
                         (and (list? l)
                              (and-let* ((m (module-printname s)))
                                (cons m l))) )
                       '() obj)) )
         (reverse! l) ) ) )

;;

;FIXME sloppy, # only after srfi, which must be 1st
(define (module-name-element? x) (or (symbol? x) (fixnum? x)))

(define (module-name-element->string m) (->string m))

(define (reverse-module-name-elements->symbol l)
 (string->symbol (reverse-string-append (intersperse  l "."))) )

(define (srfi-module? mdl)
  (and (eq? 'srfi (car mdl))
       (pair? (cdr mdl))
       (number? (cadr mdl))) )

(define (canonicalize-srfi-name n)
  (string-append "srfi" "-" (number->string n)) )

(define (canonical-module-name x)
  (cond ((symbol? x)
          x )
        ((and (pair? x) (every module-name-element? x))
          (let loop ((mdl x) (l '()))
            (cond ((null? mdl)
                    (reverse-module-name-elements->symbol l))
                  ((and (null? l) ;1st time
                        (srfi-module? mdl))
                    (let ((md (canonicalize-srfi-name (cadr mdl))))
                      (loop (cddr mdl) (cons md l))) )
                  (else
                    (let ((md (module-name-element->string (car mdl))))
                      (loop (cdr mdl) (cons md l))) ) ) ) )
        (else
          #f ) ) )

(define (canonicalize-module-name x)
  (or (canonical-module-name x)
      (error 'canonicalize-module-name "invalid module name" x)) )

) ;module symbol-module-name-utils