;;;; symbol-qualified-utils.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18

(declare
  (bound-to-procedure
    ##sys#size
    ##sys#fragments->string
    ##sys#intern-symbol
    ##sys#make-string
    ##sys#symbol->string))

(module symbol-qualified-utils

(;export
  ;
  qualified-symbol-components
  exploded-qualified-symbol=? exploded-qualified-symbol<?
  ;
  symbol->qualified-string
  make-qualified-uninterned-symbol
  make-qualified-symbol
  qualified-symbol?)

(import scheme
  (chicken base)
  (chicken fixnum)
  (chicken type)
  (only (chicken string) ->string)
  (only type-checks check-symbol))

;;;

;;

(define-type ##sys#fragments->string (fixnum (list-of string) -> string))
(define-type ##sys#size (string -> fixnum))

;;

(define (->boolean obj)
  (and obj #t ) )

;;;

;;

(: qualified-symbol-components (symbol -> (or boolean string) (or boolean string)))
;
(define (qualified-symbol-components sym)
  (let (
    (p (##sys#qualified-symbol-prefix (check-symbol 'qualified-symbol-components sym))) )
    (if p
      (values p (substring p 1))
      (values #f (##sys#symbol->string sym)) ) ) )

;;

(: exploded-qualified-symbol=? (string string string string --> boolean))
;
(define (exploded-qualified-symbol=? px sx py sy)
  (and (string=? px py) (string=? sx sy)) )

(: exploded-qualified-symbol<? (string string string string --> boolean))
;
(define (exploded-qualified-symbol<? px sx py sy)
  (or
    (and (string=? px py) (string<? sx sy))
    (string<? px py)) )

;;

(define-constant NAMESPACE-MAX-ID-LEN 31)

(define (valid-prefix-length? len)
  (and (fx<= 1 len) (fx<= len NAMESPACE-MAX-ID-LEN)) )

(define (%fixnum->char n)
  (##core#inline "C_make_character" (##core#inline "C_unfix" n)) )

;Note keywords are in the null namespace!

(: make-qualified-string (symbol * * -> string))
;
(define (make-qualified-string loc prefix name)
  (let* (
    (name       (->string name))
    (prefix     (->string prefix))
    (prefix-len (##sys#size prefix)) )
    (unless (valid-prefix-length? prefix-len)
      (error loc "invalid namespace identifier length" prefix) )
    (let (
      (length-prefix (##sys#make-string 1 (%fixnum->char prefix-len))) )
      (##sys#fragments->string
        (fx+ 1 (fx+ prefix-len (##sys#size name)))
        `(,length-prefix ,prefix ,name)) ) ) )

;; Chicken namespace qualified symbol.

(: make-qualified-symbol (* * --> symbol))
;
(define (make-qualified-symbol prefix name)
  (##sys#intern-symbol
    (make-qualified-string 'make-qualified-symbol prefix name)) )

;FIXME um, ugh
(define ##sys#make-symbol (##core#primitive "C_make_symbol"))

(: make-qualified-uninterned-symbol (* * -> symbol))
;
(define (make-qualified-uninterned-symbol prefix name)
  (##sys#make-symbol
    (make-qualified-string 'make-qualified-symbol prefix name)) )

(: qualified-symbol? (* -> boolean : symbol))
;
(define (qualified-symbol? sym)
  (and
    (symbol? sym)
    (->boolean (##sys#qualified-symbol-prefix sym))) )

(: symbol->qualified-string (symbol -> string))
;
(define (symbol->qualified-string sym)
  (##sys#symbol->qualified-string (check-symbol 'symbol->qualified-string sym)) )

) ;module symbol-qualified-utils