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

(.module:
  [library
   [lux (#- char)
    ["@" target]
    [abstract
     [hash (#+ Hash)]
     [monoid (#+ Monoid)]
     [equivalence (#+ Equivalence)]
     [order (#+ Order)]
     [monad (#+ do)]
     [codec (#+ Codec)]]
    [control
     ["." maybe]]
    [data
     [collection
      ["." list ("#\." fold)]]]
    [math
     [number
      ["n" nat]
      ["." i64]]]]])

(type: .public Char
  {#.doc (example "A character code number.")}
  Nat)

... TODO: Instead of ints, chars should be produced fron nats.
... (The JVM specifies chars as 16-bit unsigned integers)
(def: .public of_char
  (-> Char Text)
  (|>> .int "lux i64 char"))

(template [<code> <short> <long>]
  [(def: .public <long> (..of_char <code>))
   (def: .public <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: .public line_feed
  {#.doc (example "Same as 'new_line'.")}
  ..new_line)

(def: .public size
  (-> Text Nat)
  (|>> "lux text size"))

(def: .public (char index input)
  {#.doc (example "Yields the character at the specified index.")}
  (-> Nat Text (Maybe Char))
  (if (n.< ("lux text size" input) index)
    (#.Some ("lux text char" index input))
    #.None))

(def: .public (index_of' from pattern input)
  (-> Nat Text Text (Maybe Nat))
  ("lux text index" from pattern input))

(def: .public (index_of pattern input)
  (-> Text Text (Maybe Nat))
  (index_of' 0 pattern input))

(def: (last_index_of' from part text)
  (-> Nat Text Text (Maybe Nat))
  (loop [from from
         output (: (Maybe Nat)
                   #.None)]
    (let [output' ("lux text index" from part text)]
      (case output'
        #.None
        output

        (#.Some from')
        (recur (inc from') output')))))

(def: .public (last_index_of part text)
  (-> Text Text (Maybe Nat))
  (last_index_of' 0 part text))

(def: .public (starts_with? prefix x)
  (-> Text Text Bit)
  (case (index_of prefix x)
    (#.Some 0)
    true

    _
    false))

(def: .public (ends_with? postfix x)
  (-> Text Text Bit)
  (case (last_index_of postfix x)
    (#.Some n)
    (n.= (size x)
         (n.+ (size postfix) n))

    _
    false))

(def: .public (enclosed_by? boundary value)
  (-> Text Text Bit)
  (and (starts_with? boundary value)
       (ends_with? boundary value)))

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

    _
    false))

(def: .public (prefix param subject)
  (-> Text Text Text)
  ("lux text concat" param subject))

(def: .public (suffix param subject)
  (-> Text Text Text)
  ("lux text concat" subject param))

(def: .public (enclosed [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: .public (enclosed' boundary content)
  {#.doc "Surrounds the given content text with the same boundary text."}
  (-> Text Text Text)
  (enclosed [boundary boundary] content))

(def: .public format
  (-> Text Text)
  (..enclosed' ..double_quote))

(def: .public (clip offset size input)
  {#.doc (example "Clips a chunk of text from the input at the specified offset and of the specified size.")}
  (-> Nat Nat Text (Maybe Text))
  (if (|> size (n.+ offset) (n.<= ("lux text size" input)))
    (#.Some ("lux text clip" offset size input))
    #.None))

(def: .public (clip' offset input)
  {#.doc (example "Clips the remaining text from the input at the specified offset.")}
  (-> Nat Text (Maybe Text))
  (let [size ("lux text size" input)]
    (if (n.<= size offset)
      (#.Some ("lux text clip" offset (n.- offset size) input))
      #.None)))

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

    _
    #.None))

(def: .public (split_by token sample)
  (-> Text Text (Maybe [Text Text]))
  (do maybe.monad
    [index (index_of token sample)
     [pre post'] (split_at index sample)
     [_ post] (split_at (size token) post')]
    (in [pre post])))

(def: .public (all_split_by token sample)
  (-> Text Text (List Text))
  (loop [input sample
         output (: (List Text) (list))]
    (case (..split_by token input)
      (#.Some [pre post])
      (|> output
          (#.Item pre)
          (recur post))

      #.None
      (|> output
          (#.Item input)
          list.reversed))))

(def: .public (replaced/1 pattern replacement template)
  (-> Text Text Text Text)
  (<| (maybe.else template)
      (do maybe.monad
        [[pre post] (..split_by pattern template)]
        (in ($_ "lux text concat" pre replacement post)))))

(def: .public (replaced pattern replacement template)
  (-> Text Text Text Text)
  (for {@.old
        (:as Text
             ("jvm invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"
              (:as (primitive "java.lang.String") template)
              (:as (primitive "java.lang.CharSequence") pattern)
              (:as (primitive "java.lang.CharSequence") replacement)))
        @.jvm
        (:as Text
             ("jvm member invoke virtual" [] "java.lang.String" "replace" []
              (:as (primitive "java.lang.String") template)
              ["Ljava/lang/CharSequence;" (:as (primitive "java.lang.CharSequence") pattern)]
              ["Ljava/lang/CharSequence;" (:as (primitive "java.lang.CharSequence") replacement)]))
        ... TODO: Comment/turn-off when generating a JS compiler using a JVM-based compiler because Nashorn's implementation of "replaceAll" is incorrect. 
        @.js
        (:as Text
             ("js object do" "replaceAll" template [pattern replacement]))
        @.python
        (:as Text
             ("python object do" "replace" template pattern replacement))
        ... TODO @.lua
        @.ruby
        (:as Text
             ("ruby object do" "gsub" template pattern replacement))
        @.php
        (:as Text
             ("php apply" (:expected ("php constant" "str_replace"))
              pattern replacement template))
        ... TODO @.scheme
        ... TODO @.common_lisp
        ... TODO @.r
        }
       ... Inefficient default
       (loop [left ""
              right template]
         (case (..split_by pattern right)
           (#.Some [pre post])
           (recur ($_ "lux text concat" left pre replacement) post)

           #.None
           ("lux text concat" left right)))))

(implementation: .public equivalence
  (Equivalence Text)
  
  (def: (= reference sample)
    ("lux text =" reference sample)))

(implementation: .public order
  (Order Text)
  
  (def: &equivalence ..equivalence)

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

(implementation: .public monoid
  (Monoid Text)
  
  (def: identity "")
  
  (def: (compose left right)
    ("lux text concat" left right)))

(implementation: .public 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"
              (:as Nat))

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

(def: .public joined
  (-> (List Text) Text)
  (let [(^open ".") ..monoid]
    (|>> list.reversed
         (list\fold compose identity))))

(def: .public (interposed separator texts)
  (-> Text (List Text) Text)
  (case separator
    "" (..joined texts)
    _ (|> texts (list.interposed separator) ..joined)))

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

(def: .public space
  Text
  " ")

(def: .public (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))))

(def: .public (lower_cased value)
  (-> Text Text)
  (for {@.old
        (:as Text
             ("jvm invokevirtual:java.lang.String:toLowerCase:"
              (:as (primitive "java.lang.String") value)))
        @.jvm
        (:as Text
             ("jvm member invoke virtual" [] "java.lang.String" "toLowerCase" []
              (:as (primitive "java.lang.String") value)))
        @.js
        (:as Text
             ("js object do" "toLowerCase" value []))
        @.python
        (:as Text
             ("python object do" "lower" value))
        @.lua
        (:as Text
             ("lua apply" ("lua constant" "string.lower") value))
        @.ruby
        (:as Text
             ("ruby object do" "downcase" value))}))

(def: .public (upper_cased value)
  (-> Text Text)
  (for {@.old
        (:as Text
             ("jvm invokevirtual:java.lang.String:toUpperCase:"
              (:as (primitive "java.lang.String") value)))
        @.jvm
        (:as Text
             ("jvm member invoke virtual" [] "java.lang.String" "toUpperCase" []
              (:as (primitive "java.lang.String") value)))
        @.js
        (:as Text
             ("js object do" "toUpperCase" value []))
        @.python
        (:as Text
             ("python object do" "upper" value))
        @.lua
        (:as Text
             ("lua apply" ("lua constant" "string.upper") value))
        @.ruby
        (:as Text
             ("ruby object do" "upcase" value))}))