VSL - The prelude.string Structure

# Copyright 2011  Petter Urkedal
#
# This file is part of the Viz Standard Library <http://www.vizlang.org/>.
#
# The Viz Standard Library (VSL) is free software: you can redistribute it
# and/or modify it under the terms of the GNU Lesser General Public License as
# published by the Free Software Foundation, either version 3 of the License,
# or (at your option) any later version.
#
# The VSL is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public License for
# more details.
#
# You should have received a copy of the GNU Lesser General Public License
# along with the VSL.  If not, see <http://www.gnu.org/licenses/>.

open prereq
open effect

type t := string

#?ffoc include compat.ocaml_unicode.string

in buf
    #?ffoc include compat.ocaml_unicode.string_buf

let of_char ch be init 1 (_  ch)

let show s be observe (that : ψ. effect ψ α) which!
    let buf do buf.create
    let! put_escaped
	at c"\\" do buf.put_string buf "\\\\"
	at c"\t" do buf.put_string buf "\\t"
	at c"\n" do buf.put_string buf "\\n"
	at c"\r" do buf.put_string buf "\\r"
	# FIXME: Use char.is_print.
	at ch do buf.put_char buf ch
    do buf.put_char buf c"\""
    do iter put_escaped s
    do buf.put_char buf c"\""
    do buf.contents buf

let cat x y
    let nx be length x
    let n be nx + length y
    be init n (i  (i < nx  get i x; get (i - nx) y))

let cat_list xs be observe (that : ψ. effect ψ α) which!
    let buf do buf.create
    do list.iter (buf.put_string buf) xs
    do buf.contents buf

let join s
    at [] be ""
    at [x; xs] be observe (that : ψ. effect ψ α) which!
	let buf do buf.create
	do buf.put_string buf x
	do list.iter (x  buf.put_string buf s >> buf.put_string buf x) xs
	do buf.contents buf

let tile n s
    if n  0 be ""
    be observe (that : ψ. effect ψ α) which!
	let buf do buf.create
	let! loop at 0 be ()
		  at n do buf.put_string buf s >> loop (n - 1)
	do loop n
	do buf.contents buf

let slice i j x
    assert 0  i  j  length x
    be init (j - i) (k  get (i + k) x)

let as_list x
    let collect_upto n accu
	if n = 0 be accu
	else be collect_upto (n - 1) [get (n - 1) x; accu]
    be collect_upto (length x) []

let of_list xs be observe (that : ψ. effect ψ α) which!
    let buf do buf.create
    do list.iter (buf.put_char buf) xs
    do buf.contents buf


let fold f x
    let n be length x
    let fold_from i accu
	if i  n be accu
	be fold_from (i + 1) (f (get i x) accu)
    be fold_from 0

let foldr f x
    let foldr_from i accu
	if i < 0 be accu
	be foldr_from (i - 1) (f (get i x) accu)
    be foldr_from (length x - 1)

let! iter f x
    let n be length x
    let! iter_from i
	if i  n be ()
	do f (get i x)
	do iter_from (i + 1)
    do iter_from 0

let map f x be init (length x) (i  f (get i x))

let mapi f x be init (length x) (i  f i (get i x))

let for_all f x
    let n be length x
    let true_above i be i  n  f (get i x)  true_above (i + 1)
    be true_above 0

let for_some f x
    let n be length x
    let true_above i be i < n  (f (get i x)  true_above (i + 1))
    be true_above 0

let starts_with x y
    let n be length x
    if n > length y be false
    let loop i be i = n  get i x = get i y  loop (i + 1)
    be loop 0

let ends_with x y
    let n be length x
    let j be length y - n
    if j < 0 be false
    let loop i be i = n  get i x = get (i + j) y  loop (i + 1)
    be loop 0

let contains_char c x
    let n be length x
    let loop i be i < n  (get i x = c  loop (i + 1))
    be loop 0

let contains_sub x y
    let n be length x
    let j_max be length y - n
    let try_from j
	if j > j_max be false
	let ok_from i be i  n  get i x = get (j + i) y  ok_from (i + 1)
	be ok_from 0  try_from (j + 1)
    be try_from 0

let count_char ch s
    let loop i accu
	if i < 0 be accu
	be loop (i - 1) (get i s = ch  accu + 1; accu)
    be loop (length s - 1) 0

let count_for f s
    let loop i accu
	if i < 0 be accu
	be loop (i - 1) (f (get i s)  accu + 1; accu)
    be loop (length s - 1) 0


let skip_while f s i
    assert 0  i  length s
    be i < length s  f (get i s)  skip_while f s (i + 1); i

let rskip_while f s i
    assert 0  i  length s
    be i > 0  f (get (i - 1) s)  rskip_while f s (i - 1); i

let skip_to_char ch s i
    assert 0  i  length s
    be i < length s  ¬ char.eq ch (get i s)  skip_to_char ch s (i + 1); i

let rskip_to_char ch s i
    assert 0  i  length s
    be i > 0  ¬ char.eq ch (get (i - 1) s)  rskip_to_char ch s (i - 1); i

let skip_space be skip_while char.is_space

let rskip_space be rskip_while char.is_space

let skip_to_sub s r j
    let n be length s
    let j_max be length r - n
    let try_from j
	if j > j_max be length r
	let ok_from i be i  n  get i s = get (j + i) r  ok_from (i + 1)
	if ok_from 0 be j
	be try_from (j + 1)
    be try_from j


let scan_while f s i
    let j be skip_while f s i
    be (slice i j s, j)

let rscan_while f s i
    let j be rskip_while f s i
    be (slice j i s, j)

let scan_to_char ch s i
    let j be skip_to_char ch s i
    be (slice i j s, j)

let rscan_to_char ch s i
    let j be rskip_to_char ch s i
    be (slice j i s, j)

let scan_to_sub su s i
    let j be skip_to_sub su s i
    be (slice i j s, j)


let strip s
    let i be skip_space s 0
    let j be rskip_space s (length s)
    be i < j  slice i j s; ""

let strip_left s
    let i be skip_space s 0
    be slice i (length s) s

let strip_right s
    let j be rskip_space s (length s)
    be slice 0 j s


let split_where f s
    let loop j accu
	if j < 0 be accu
	if j = 0 be [""; accu]
	let i be rskip_while (¬* f) s j
	be loop (i - 1) [slice i j s; accu]
    be loop (length s) []

let split_on ch be split_where (char.eq ch)

let csplit_where f s
    let loop j accu
	if j = 0 be accu
	let i be rskip_while (¬* f) s j
	be loop (rskip_while f s i) [slice i j s; accu]
    be loop (rskip_while f s (length s)) []

let csplit_on_space be csplit_where char.is_space