string.lisp

(coalton/utils:defstdlib-package #:coalton/string
  (:use
   #:coalton
   #:coalton/builtin
   #:coalton/classes)
  (:import-from
   #:coalton/hash
   #:define-sxhash-hasher)
  (:import-from
   #:coalton/vector
   #:Vector)
  (:local-nicknames
   (#:cell #:coalton/cell)
   (#:iter #:coalton/iterator))
  (:export
   #:concat
   #:reverse
   #:length
   #:substring
   #:split
   #:split-at
   #:strip-prefix
   #:strip-suffix
   #:parse-int
   #:ref
   #:ref-unchecked
   #:substring-index
   #:substring?
   #:chars
   #:upcase
   #:downcase))


(in-package #:coalton/string)

(named-readtables:in-readtable coalton:coalton)

#+coalton-release
(cl:declaim #.coalton-impl/settings:*coalton-optimize-library*)

;;;
;;; String
;;;


(cl:defmacro define-instance-into-integral-string (type)
  `(coalton-toplevel
     (define-instance (Into ,type String)
       (define (into z)
         (lisp (-> String) (z)
           (cl:format cl:nil "~D" z))))))

(coalton-toplevel
  (declare concat (String * String -> String))
  (define (concat str1 str2)
    "Concatenate STR1 and STR2 together, returning a new string."
    (lisp (-> String) (str1 str2)
      (cl:concatenate 'cl:string str1 str2)))

  (declare reverse (String -> String))
  (define (reverse s)
    "Reverse a string."
    (lisp (-> String) (s) (cl:reverse s)))

  (declare length (String -> UFix))
  (define (length str)
    "The length of a string STR."
    (lisp (-> UFix) (str)
      (cl:length str)))

  (declare substring (String * UFix * UFix -> String))
  (define (substring str start end)
    "Compute a substring of a string bounded by given indices."
    (let ((real-start (max 0 (min start end)))
          (real-end (min (length str) (max start end))))
      (lisp (-> String) (real-start real-end str)
        (cl:subseq str real-start real-end))))

  (declare split-at (UFix * String -> (Tuple String String)))
  (define (split-at n str)
    "Splits a string into a substring of the first N characters and a substring of the remaining characters."
    (Tuple (substring str 0 n)
           (substring str n (length str))))

  (declare split (Char * String -> (List String)))
  (define (split c str)
    "Split a string around the separator character `c`."
    (lisp (-> (List String)) (c str)
      (cl:let ((split-chars (cl:list c)))
        (cl:declare (cl:dynamic-extent split-chars))
        (uiop:split-string str :separator split-chars))))

  (declare strip-prefix (String * String -> (Optional String)))
  (define (strip-prefix prefix str)
    "Returns a string without a give prefix, or `None` if the string
does not have that suffix."
    (let prefix-len = (length prefix))
    (let substr = (substring str 0 prefix-len))
    (if (== substr prefix)
        (Some (substring str prefix-len (length str)))
        None))

  (declare strip-suffix (String * String -> (Optional String)))
  (define (strip-suffix suffix str)
    "Returns a string without a give suffix, or `None` if the string
does not have that suffix."
    (let suffix-len = (length suffix))
    (let str-len = (length str))
    (let substr = (substring str (- str-len suffix-len) str-len))
    (if (== substr suffix)
        (Some (substring str 0 (- str-len suffix-len)))
        None))

  (declare parse-int (String -> (Optional Integer)))
  (define (parse-int str)
    "Parse the integer in string `str`."
    (lisp (-> (Optional Integer)) (str)
      (cl:let ((x (cl:parse-integer str :junk-allowed cl:t)))
        (cl:if x
               (Some x)
               None))))

  (declare ref-unchecked (String * UFix -> Char))
  (define (ref-unchecked str idx)
    "Return the `idx`th character of `str`. This function is partial."
    (lisp (-> Char) (str idx)
      (cl:char str idx)))

  (declare ref (String * UFix -> (Optional Char)))
  (define (ref str idx)
    "Return the `idx`th character of `str`."
    (if (< idx (length str))
        (Some (ref-unchecked str idx))
        None))

  (declare substring-index (String * String -> (Optional UFix)))
  (define (substring-index small big)
    "If the first argument appears as a substring within the second argument, return the starting index into the second argument."
    (lisp (-> (Optional UFix)) (small big)
      (alexandria:if-let (idx (cl:search small big))
        (Some idx)
        None)))

  (declare substring? (String * String -> Boolean))
  (define (substring? small big)
    "Return true if the first argument appears as a substring within the second argument."
    ;; not a call to `optional:some?' because this file is loaded before optional.lisp
    (match (substring-index small big)
      ((None) False)
      ((Some _) True)))

  (declare chars (String -> iter:Iterator Char))
  (define (chars str)
    "Returns an iterator over the characters in `str`."
    (let idx = (cell:new 0))
    (iter:with-size
        (fn ()
          (let i = (cell:read idx))
          (if (>= i (length str))
              None
              (progn
                (cell:increment! idx)
                (Some (ref-unchecked str i)))))
      (length str)))

  (declare upcase (String -> String))
  (define (upcase str)
    "Returns a new string with uppercase characters."
    (lisp (-> String) (str)
      (cl:string-upcase str)))

  (declare downcase (String -> String))
  (define (downcase str)
    "Returns a new string with lowercase characters."
    (lisp (-> String) (str)
      (cl:string-downcase str)))

  ;;
  ;; Instances
  ;;

  (define-instance (Eq String)
    (define (== a b)
      (lisp (-> Boolean) (a b) (to-boolean (cl:string= a b)))))

  (define-instance (Ord String)
    (define (<=> a b)
      (lisp (-> Ord) (a b)
        (cl:cond
          ((cl:string> a b) GT)
          ((cl:string< a b) LT)
          (cl:t EQ)))))

  (define-instance (Semigroup String)
    (define <> concat))

  (define-instance (Monoid String)
    (define mempty ""))

  (define-instance (iter:IntoIterator String Char)
    (define (iter:into-iter str)
      (map (fn (idx) (ref-unchecked str idx))
           (iter:up-to (length str)))))

  (define-instance (iter:FromIterator String Char)
    (define (iter:collect! iter)
      (let vec = (the (Vector Char) (iter:collect! iter)))
      (lisp (-> String) (vec)
        (cl:coerce vec 'cl:string))))

  ;;
  ;; Conversions
  ;;

  (define-instance (Into String (List Char))
    (define (into str)
      (lisp (-> (List Char)) (str)
        (cl:coerce str 'cl:list))))

  (define-instance (Into String (Vector Char))
    (define (into str)
      (lisp (-> (Vector Char)) (str)
        (cl:make-array (length str)
                       :adjustable cl:t
                       :fill-pointer cl:t
                       :initial-contents str))))

  (define-instance (Into Char String)
    (define (into chr)
      (lisp (-> String) (chr)
        (cl:string chr))))

  (define-instance (Into (List Char) String)
    (define (into lst)
      (lisp (-> String) (lst)
        (cl:coerce lst 'cl:string))))

  (define-instance (Into (Vector Char) String)
    (define (into vec)
      (lisp (-> String) (vec)
        (cl:coerce vec 'cl:string))))

  (define-instance (Iso (List Char) String)))

(define-instance-into-integral-string Integer)
(define-instance-into-integral-string IFix)
(define-instance-into-integral-string UFix)
(define-instance-into-integral-string I8)
(define-instance-into-integral-string U8)
(define-instance-into-integral-string I16)
(define-instance-into-integral-string U16)
(define-instance-into-integral-string I32)
(define-instance-into-integral-string U32)
(define-instance-into-integral-string I64)
(define-instance-into-integral-string U64)

(coalton-toplevel
  (define-instance (Into Fraction String)
    (define (into frc)
      (lisp (-> String) (frc)
        (cl:format cl:nil "~A" frc))))

  (define-instance (Into F32 String)
    (define (into z)
      (lisp (-> String) (z)
        (cl:prin1-to-string z))))

  (define-instance (Into F64 String)
    (define (into z)
      (lisp (-> String) (z)
        (cl:prin1-to-string z))))

  (define-instance (TryInto String Integer)
    (define (tryInto s)
      (lisp (-> (Optional Integer)) (s)
        (cl:let ((z (cl:ignore-errors (cl:parse-integer s))))
          (cl:if (cl:null z)
                 None
                 (Some z))))))

  (define-instance (Default String)
    (define (default) ""))

  (define-sxhash-hasher String))


#+sb-package-locks
(sb-ext:lock-package "COALTON/STRING")