; Chez Scheme bindings for (a subset of) PCRE2

(library (pcre2 (1))
         (export
           pcre2-compile
           pcre2-match
           pcre2-get-match-count
           pcre2-get-match-groupcount
           pcre2-get-match-group 
           pcre2-get-match-groups)
         (import (chezscheme))

         (define pcre2-library-load (load-shared-object "libpcre2-8.so"))

         ;;; BEGIN Constants

         (define SIZE_T-SIZE (foreign-sizeof 'size_t))
         (define PCRE2-ZERO-TERMINATED (- (expt 2 (* 8 SIZE_T-SIZE)) 1))
         (define PCRE2-UNSET PCRE2-ZERO-TERMINATED)

         ;;; END Constants

         ;;; BEGIN Memory Management

         ; This guardian handles deallocating PCRE2-allocated foreign pointers when they're no 
         ; longer accessible from scheme
         (define pcre2-guardian (make-guardian))

         ; Add a pointer to the guardian with the given cleanup function (`pcre2-code-free-base` or
         ; `pcre2-match-data-free-base`)
         (define (pcre2-guard-pointer ptr cleanup)
           (cons ptr cleanup))


         ; Get the foreign pointer from a guarded pointer
         (define (pcre2-get-pointer-ptr ptr)
           (car ptr))

         ; Get the cleanup function from a guarded pointer
         (define (pcre2-get-pointer-cleanup ptr)
           (cdr ptr))

         ; Guard a code pointer
         (define (pcre2-guard-code-pointer ptr)
           (pcre2-guard-pointer ptr pcre2-code-free-base))

         ; Guard a match data pointer
         (define (pcre2-guard-match-pointer ptr)
           (pcre2-guard-pointer ptr pcre2-match-data-free-base))

         ; Run cleanup; called when new data is allocated
         (define (pcre2-cleanup)
           (let f ()
             (let ((x (pcre2-guardian)))
               (when x
                 ((pcre2-get-pointer-cleanup x) (pcre2-get-pointer-ptr x))
                 (f)))))

         ;;; END Memory Management

         ;;; BEGIN Compilation Functions

         (define pcre2-compile-base
           (foreign-procedure "pcre2_compile_8"
                              (string size_t unsigned-32 void* void* void*)
                              void*))

         (define pcre2-code-free-base
           (foreign-procedure "pcre2_code_free_8"
                              (void*)
                              void))

         ; Compile a string pattern for use in match
         (define (pcre2-compile pattern options)
           (pcre2-cleanup)
           (let* ((errorcode (foreign-alloc (foreign-sizeof 'int)))
                  (erroroffset (foreign-alloc (foreign-sizeof 'size_t)))
                  (code (pcre2-compile-base pattern PCRE2-ZERO-TERMINATED options errorcode erroroffset 0))
                  (errorc (foreign-ref 'int errorcode 0)))
             (if (< errorc 0)
               (error 'pcre2-compile (pcre2-get-error-message errorc) (foreign-ref 'size_t erroroffset 0))
               (pcre2-guard-code-pointer code))))

         ;;; END Compilation Functions

         ;;; BEGIN Utility Functions

         (define pcre2-get-error-message-base 
           (foreign-procedure "pcre2_get_error_message_8"
                              (int u8* size_t)
                              int))

         ; Get the PCRE2 error message corresponding to the given code
         (define (pcre2-get-error-message errorcode)
           (let* ((buff (make-bytevector 255))
                  (len (pcre2-get-error-message-base errorcode buff 255)))
             (substring (utf8->string buff) 0 len)))

         ;;; END Utility Functions

         ;;; BEGIN Matching Functions

         ; Note: functions here take either `match-data-ptr` or `match-data`; if they take 
         ; `match-data-ptr`, they expect a guarded pointer as returned from `pcre2-guard-pointer`.
         ; Otherwise, they expect a match data object as returned from `pcre2-match`

         (define pcre2-match-base
           (foreign-procedure "pcre2_match_8"
                              (void* string size_t size_t unsigned-32 void* void*)
                              int))

         (define pcre2-match-data-free-base 
           (foreign-procedure "pcre2_match_data_free_8"
                              (void*)
                              void))

         (define pcre2-match-data-create-from-pattern-base
           (foreign-procedure "pcre2_match_data_create_from_pattern_8"
                              (void* void*)
                              void*))

         ; Create a match data block with enough storage to hold the groups in `pattern`
         (define (pcre2-match-data-create-from-pattern pattern)
           (pcre2-guard-match-pointer (pcre2-match-data-create-from-pattern-base (pcre2-get-pointer-ptr pattern) 0)))

         (define pcre2-get-ovector-count-base
           (foreign-procedure "pcre2_get_ovector_count_8"
                              (void*)
                              unsigned-32))

         ; Get the number of groups in a given match data block
         (define (pcre2-get-ovector-count match-data-ptr)
           (pcre2-get-ovector-count-base (pcre2-get-pointer-ptr match-data-ptr)))

         (define pcre2-get-ovector-pointer-base
           (foreign-procedure "pcre2_get_ovector_pointer_8"
                              (void*)
                              void*))

         ; Get the pointer to the first group in the match data block
         (define (pcre2-get-ovector-pointer match-data-ptr)
           (pcre2-get-ovector-pointer-base (pcre2-get-pointer-ptr match-data-ptr)))

         ; Create a match data object for `match-data-ptr` with the relevant info
         (define (pcre2-make-match-data-object count match-data-ptr)
           (list match-data-ptr count (pcre2-get-ovector-count match-data-ptr) (pcre2-get-ovector-pointer match-data-ptr)))

         ; Accessor functions for match data objects returned from `pcre2-match`
         (define pcre2-get-match-ptr car)
         (define pcre2-get-match-ovector-ptr cadddr)
         ; These three are the only public ones
         (define pcre2-get-match-count cadr)
         (define pcre2-get-match-groupcount caddr)

         ; Match `str` against `pattern` starting at `offset`; returns #f if no match
         (define (pcre2-match pattern str offset options)
           (pcre2-cleanup)
           (let* ((match-data (pcre2-match-data-create-from-pattern pattern))
                  (errorcode (pcre2-match-base (pcre2-get-pointer-ptr pattern) str PCRE2-ZERO-TERMINATED offset options (pcre2-get-pointer-ptr match-data) 0)))
             (display errorcode)
             (newline)
             (cond ((< errorcode -1) (error 'pcre2-match (pcre2-get-error-message errorcode) errorcode))
                   ((< errorcode 2) #f)
                   (else (pcre2-make-match-data-object (- errorcode 1) match-data)))))

         (define pcre2-substring-length-bynumber-base
           (foreign-procedure "pcre2_substring_length_bynumber_8"
                              (void* unsigned-32 void*)
                              int))

         ; Get the length of a substring
         (define (pcre2-substring-length-bynumber match-data-ptr num)
           (let* ((lenptr (foreign-alloc SIZE_T-SIZE))
                  (errorcode (pcre2-substring-length-bynumber-base (pcre2-get-pointer-ptr match-data-ptr) num lenptr))
                  (len (foreign-ref 'size_t lenptr 0)))
             (if (< errorcode 0)
               (error 'pcre2-substring-length-bynumber (pcre2-get-error-message errorcode) match-data-ptr)
               len)))

         (define (pcre2-substring-length-bynumber-b match-data num)
           (let* ((ovector (pcre2-get-match-ovector-ptr match-data))
                  (start (foreign-ref 'size_t ovector (* 2 num SIZE_T-SIZE)))
                  (end (foreign-ref 'size_t ovector (* (+ 1 (* 2 num)) SIZE_T-SIZE))))
             (if (= start end PCRE2-UNSET) #f
               (- end start))))

         (define pcre2-substring-copy-bynumber-base
           (foreign-procedure "pcre2_substring_copy_bynumber_8"
                              (void* unsigned-32 u8* void*)
                              int))

         ; Get a match substring; some gymnastics are needed because PCRE2 operates in code units 
         ; (bytes) while Chez Scheme operates in UTF-8 characters
         (define (pcre2-substring-copy-bynumber match-data num)
           (let* ((strlen (pcre2-substring-length-bynumber-b match-data num)))
             (if (not strlen) 
               #f ; This group is unset
               (begin
                 (let* 
                   ((match-data-ptr (pcre2-get-match-ptr match-data))
                    (bufflen (+ strlen 1))
                    (buff (make-bytevector (+ bufflen 1)))
                    (bufflenptr (foreign-alloc SIZE_T-SIZE)))
                   (foreign-set! 'size_t bufflenptr 0 bufflen)
                   (let* ((errorcode (pcre2-substring-copy-bynumber-base 
                                       (pcre2-get-pointer-ptr match-data-ptr)
                                       num
                                       buff
                                       bufflenptr)))
                     (when (< errorcode 0)
                       (error 'pcre2-substring-copy-bynumber (pcre2-get-error-message errorcode) match-data-ptr))
                     (bytevector-truncate! buff (- bufflen 1))
                     (utf8->string buff)))))))

         ; Get a match group for `match-data`
         (define (pcre2-get-match-group match-data n)
           (when (or (>= n (pcre2-get-match-groupcount match-data)) (< n 0))
             (error 'pcre2-get-match-group "Invalid group number" n))
           (pcre2-substring-copy-bynumber match-data n))

         ; Get all the substring groups for `match-data`
         (define (pcre2-get-match-groups match-data)
           (define count (pcre2-get-match-groupcount match-data))
           (define (inner n running)
             (if (= n -1) running
               (inner (- n 1) (cons (pcre2-get-match-group match-data n) running))))
           (inner (- count 1) '()))

         ;;; END Matching Functions

         )