string.ss
#lang mzscheme

(require scheme/contract
         mzlib/kw
         mzlib/pregexp
         srfi/13/string)

;; string-namecase : string -> string
;;
;; Similar to string-titlecase, but deals with various special cases:
;;
;;     MACDONALD      => MacDonald
;;     MCPHERSON      => McPherson
;;     O'LEARY        => O'Leary
;;     LE COMBER      => le Comber
;;     VAN DER GIEZEN => van der Giezen
(define (string-namecase str)
  (let* ([ans (string-titlecase str)]
         [do-correction
          (lambda (correct! positions offset)
            (if positions
                (for-each
                 (lambda (pair)
                   (if pair
                       (let ([pos-to-correct (+ (cdr pair) offset)])
                         (correct! ans pos-to-correct (add1 pos-to-correct)))))
                 positions)))])
    (do-correction string-upcase!   (pregexp-match-positions "^Mac" ans) 0)
    (do-correction string-upcase!   (pregexp-match-positions " Mac" ans) 0)
    (do-correction string-upcase!   (pregexp-match-positions "^Mc"  ans) 0)
    (do-correction string-upcase!   (pregexp-match-positions " Mc"  ans) 0)
    (do-correction string-upcase!   (pregexp-match-positions "^O'"  ans) 0)
    (do-correction string-upcase!   (pregexp-match-positions " O'"  ans) 0)
    (do-correction string-downcase! (pregexp-match-positions "^Von" ans) -3)
    (do-correction string-downcase! (pregexp-match-positions " Von" ans) -3)
    (do-correction string-downcase! (pregexp-match-positions "^Van" ans) -3)
    (do-correction string-downcase! (pregexp-match-positions " Van" ans) -3)
    (do-correction string-downcase! (pregexp-match-positions "^Der" ans) -3)
    (do-correction string-downcase! (pregexp-match-positions " Der" ans) -3)
    (do-correction string-downcase! (pregexp-match-positions "^Le"  ans) -2)
    (do-correction string-downcase! (pregexp-match-positions " Le"  ans) -2)
    ans))

;; ensure-string : (U string bytes any-other) -> (U string any-other)
(define (ensure-string str)
  (cond [(string? str) str]
        [(bytes? str)  (bytes->string/utf-8 str)]
        [else          str]))

;; string-delimit : (list-of string) string [#:prefix string] [#:suffix string] -> string
(define string-delimit
  (lambda/kw (items delimiter #:key [prefix #f] [suffix #f])
    (let ([delimited (string-join items delimiter)])
      (if prefix
          (if suffix
              (string-append prefix delimited suffix)
              (string-append prefix delimited))
          (if suffix
              (string-append delimited suffix)
              delimited)))))

; Provide statements ---------------------------

(provide string-delimit
         ensure-string)

(provide/contract
 [string-namecase (-> string? string?)])