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]
    [collection
     ["." list ("#\." fold)]]]
   [math
    [number
     ["." i64]
     ["n" nat]]]])

(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 line_feed ..new_line)

(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 (encloses? boundary value)
  (-> Text Text Bit)
  (and (starts_with? boundary value)
       (ends_with? boundary value)))

(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 replacement template)
  (-> Text Text Text Text)
  (<| (maybe.default template)
      (do maybe.monad
        [[pre post] (split_with pattern template)]
        (wrap ($_ "lux text concat" pre replacement post)))))

(def: #export (replace_all pattern replacement template)
  (-> Text Text Text Text)
  (case (..split_with pattern template)
    (#.Some [pre post])
    ($_ "lux text concat" pre replacement (replace_all pattern replacement 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 {@.old
          (|> input
              (: (primitive "java.lang.String"))
              "jvm invokevirtual:java.lang.String:hashCode:"
              "jvm convert int-to-long"
              (:coerce Nat))

          @.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 format
  (-> Text Text)
  (..enclose' ..double_quote))

(def: #export space
  Text
  " ")

(def: #export (space? char)
  {#.doc "Checks whether the character is white-space."}
  (-> Char Bit)
  (with_expansions [<options> (template [<char>]
                                [(^ (char (~~ (static <char>))))]

                                [..tab]
                                [..vertical_tab]
                                [..space]
                                [..new_line]
                                [..carriage_return]
                                [..form_feed]
                                )]
    (`` (case char
          (^or <options>)
          true

          _
          false))))