path: root/stdlib/source/lux/data/text.lux

(.module:
  [lux #*
   ["@" target]
   [abstract
    hash
    [monoid (#+ Monoid)]
    [equivalence (#+ Equivalence)]
    [order (#+ Order)]
    [monad (#+ Monad do)]
    [codec (#+ Codec)]]
   [data
    ["." maybe]
    [number
     ["." i64]
     ["n" nat]]
    [collection
     ["." list ("#@." fold)]]]])

(type: #export Char Nat)

## TODO: Instead of ints, chars should be produced fron nats.
## (The JVM specifies chars as 16-bit unsigned integers)
(def: #export from-code
  (-> Char Text)
  (|>> (:coerce Int) "lux i64 char"))

(template [<code> <short> <long>]
  [(def: #export <long> (from-code <code>))
   (def: #export <short> <long>)]

  [00 \0  null]
  [07 \a  alarm]
  [08 \b  back-space]
  [09 \t  tab]
  [10 \n  new-line]
  [11 \v  vertical-tab]
  [12 \f  form-feed]
  [13 \r  carriage-return]
  [34 \'' double-quote]
  )

(def: #export (size x)
  (-> Text Nat)
  ("lux text size" x))

(def: #export (nth idx input)
  (-> Nat Text (Maybe Char))
  (if (n.< ("lux text size" input) idx)
    (#.Some ("lux text char" idx input))
    #.None))

(def: #export (index-of' pattern from input)
  (-> Text Nat Text (Maybe Nat))
  ("lux text index" from pattern input))

(def: #export (index-of pattern input)
  (-> Text Text (Maybe Nat))
  ("lux text index" 0 pattern input))

(def: (last-index-of'' part since text)
  (-> Text Nat Text (Maybe Nat))
  (case ("lux text index" (inc since) part text)
    #.None
    (#.Some since)

    (#.Some since')
    (last-index-of'' part since' text)))

(def: #export (last-index-of' part from text)
  (-> Text Nat Text (Maybe Nat))
  (case ("lux text index" from part text)
    (#.Some since)
    (last-index-of'' part since text)

    #.None
    #.None))

(def: #export (last-index-of part text)
  (-> Text Text (Maybe Nat))
  (case ("lux text index" 0 part text)
    (#.Some since)
    (last-index-of'' part since text)

    #.None
    #.None))

(def: #export (starts-with? prefix x)
  (-> Text Text Bit)
  (case (index-of prefix x)
    (#.Some 0)
    true

    _
    false))

(def: #export (ends-with? postfix x)
  (-> Text Text Bit)
  (case (last-index-of postfix x)
    (#.Some n)
    (n.= (size x)
         (n.+ (size postfix) n))

    _
    false))

(def: #export (contains? sub text)
  (-> Text Text Bit)
  (case ("lux text index" 0 sub text)
    (#.Some _)
    true

    _
    false))

(def: #export (clip from to input)
  (-> Nat Nat Text (Maybe Text))
  (if (and (n.<= to from)
           (n.<= ("lux text size" input) to))
    (#.Some ("lux text clip" from to input))
    #.None))

(def: #export (clip' from input)
  (-> Nat Text (Maybe Text))
  (let [size ("lux text size" input)]
    (if (n.<= size from)
      (#.Some ("lux text clip" from size input))
      #.None)))

(def: #export (split at x)
  (-> Nat Text (Maybe [Text Text]))
  (case [(..clip 0 at x) (..clip' at x)]
    [(#.Some pre) (#.Some post)]
    (#.Some [pre post])

    _
    #.None))

(def: #export (split-with token sample)
  (-> Text Text (Maybe [Text Text]))
  (do maybe.monad
    [index (index-of token sample)
     [pre post'] (split index sample)
     [_ post] (split (size token) post')]
    (wrap [pre post])))

(def: #export (split-all-with token sample)
  (-> Text Text (List Text))
  (case (..split-with token sample)
    (#.Some [pre post])
    (#.Cons pre (split-all-with token post))

    #.None
    (#.Cons sample #.Nil)))

(def: #export (replace-once pattern value template)
  (-> Text Text Text Text)
  (<| (maybe.default template)
      (do maybe.monad
        [[pre post] (split-with pattern template)]
        (wrap ($_ "lux text concat" pre value post)))))

(def: #export (replace-all pattern value template)
  (-> Text Text Text Text)
  (case (..split-with pattern template)
    (#.Some [pre post])
    ($_ "lux text concat" pre value (replace-all pattern value post))

    #.None
    template))

(structure: #export equivalence (Equivalence Text)
  (def: (= reference sample)
    ("lux text =" reference sample)))

(structure: #export order (Order Text)
  (def: &equivalence ..equivalence)

  (def: (< reference sample)
    ("lux text <" reference sample)))

(structure: #export monoid (Monoid Text)
  (def: identity "")
  
  (def: (compose left right)
    ("lux text concat" left right)))

(structure: #export hash (Hash Text)
  (def: &equivalence ..equivalence)
  
  (def: (hash input)
    (`` (for {(~~ (static @.old))
              (|> input
                  (: (primitive "java.lang.String"))
                  "jvm invokevirtual:java.lang.String:hashCode:"
                  "jvm convert int-to-long"
                  (:coerce Nat))

              (~~ (static @.jvm))
              (|> input
                  (:coerce (primitive "java.lang.String"))
                  ("jvm member invoke virtual" [] "java.lang.String" "hashCode" [])
                  "jvm conversion int-to-long"
                  "jvm object cast"
                  (: (primitive "java.lang.Long"))
                  (:coerce Nat))}
             ## Platform-independent default.
             (let [length ("lux text size" input)]
               (loop [idx 0
                      hash 0]
                 (if (n.< length idx)
                   (recur (inc idx)
                          (|> hash
                              (i64.left-shift 5)
                              (n.- hash)
                              (n.+ ("lux text char" idx input))))
                   hash)))))))

(def: #export concat
  (-> (List Text) Text)
  (let [(^open ".") ..monoid]
    (|>> list.reverse (list@fold compose identity))))

(def: #export (join-with sep texts)
  (-> Text (List Text) Text)
  (|> texts (list.interpose sep) concat))

(def: #export (empty? text)
  (-> Text Bit)
  (case text
    "" true
    _  false))

(def: #export (prefix param subject)
  (-> Text Text Text)
  ("lux text concat" param subject))

(def: #export (suffix param subject)
  (-> Text Text Text)
  ("lux text concat" subject param))

(def: #export (enclose [left right] content)
  {#.doc "Surrounds the given content text with left and right side additions."}
  (-> [Text Text] Text Text)
  ($_ "lux text concat" left content right))

(def: #export (enclose' boundary content)
  {#.doc "Surrounds the given content text with the same boundary text."}
  (-> Text Text Text)
  (enclose [boundary boundary] content))

(def: #export encode
  (-> Text Text)
  (..enclose' ..double-quote))

(def: #export (space? char)
  {#.doc "Checks whether the character is white-space."}
  (-> Char Bit)
  (`` (case char
        (^or (^ (char (~~ (static ..tab))))
             (^ (char (~~ (static ..vertical-tab))))
             (^ (char " "))
             (^ (char (~~ (static ..new-line))))
             (^ (char (~~ (static ..carriage-return))))
             (^ (char (~~ (static ..form-feed)))))
        true

        _
        false)))