lib/mlton/basic/string.sml

   1 (* Copyright (C) 2009,2014 Matthew Fluet.
   2  * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  *
   5  * MLton is released under a BSD-style license.
   6  * See the file MLton-LICENSE for details.
   7  *)
   8
   9 structure String: STRING =
  10    struct
  11       open String1
  12
  13       fun unfold (n, a, f) =
  14          let
  15             val r = ref a
  16          in
  17             tabulate (n, fn _ =>
  18                       let
  19                          val (b, a) = f (!r)
  20                          val () = r := a
  21                       in
  22                          b
  23                       end)
  24          end
  25
  26       fun concatV ss =
  27          case Vector.length ss of
  28             0 => ""
  29           | 1 => Vector.sub (ss, 0)
  30           | _ =>
  31                let
  32                   val n =
  33                      Vector.fold (ss, 0, fn (s, n) => n + size s)
  34                   val a = Array.new (n, #"a")
  35                   val _ =
  36                      Vector.fold
  37                      (ss, 0, fn (s, i) =>
  38                       fold (s, i, fn (c, i) =>
  39                             (Array.update (a, i, c);
  40                              i + 1)))
  41                in
  42                   tabulate (n, fn i => Array.sub (a, i))
  43                end
  44
  45       fun implodeV cs =
  46          tabulate (Vector.length cs, fn i => Vector.sub (cs, i))
  47
  48       fun existsi (s, f) = Int.exists (0, size s, fn i => f (i, sub (s, i)))
  49
  50       fun exists (s, f) = existsi (s, f o #2)
  51
  52       fun keepAll (s: t, f: char -> bool): t =
  53          implode (List.rev
  54                   (fold (s, [], fn (c, ac) => if f c then c :: ac else ac)))
  55
  56       fun memoizeList (init: string -> 'a, l: (t * 'a) list): t -> 'a =
  57          let
  58             val set: (word * t * 'a) HashSet.t = HashSet.new {hash = #1}
  59             fun lookupOrInsert (s, f) =
  60                let
  61                   val hash = hash s
  62                in HashSet.lookupOrInsert
  63                   (set, hash,
  64                    fn (hash', s', _) => hash = hash' andalso s = s',
  65                    fn () => (hash, s, f ()))
  66                end
  67             val _ =
  68                List.foreach (l, fn (s, a) =>
  69                              ignore (lookupOrInsert (s, fn () => a)))
  70          in
  71             fn s => #3 (lookupOrInsert (s, fn () => init s))
  72          end
  73
  74       fun memoize init = memoizeList (init, [])
  75
  76       fun posToLineCol (s: string): int -> {line: int, col: int} =
  77          let
  78             open Int
  79             val lineStarts =
  80                Array.fromList
  81                (List.rev (foldi (s, [0], fn (i, c, is) =>
  82                                  if c = #"\n"
  83                                     then (i + 1) :: is
  84                                  else is)))
  85             fun find (pos: int) =
  86                let
  87                   val line =
  88                      valOf (BinarySearch.largest (lineStarts, fn x => x <= pos))
  89                (* The 1+'s are to make stuff one based *)
  90                in {line = 1 + line,
  91                    col = 1 + pos - Array.sub (lineStarts, line)}
  92                end
  93          in find
  94          end
  95
  96       fun substituteFirst (s, {substring, replacement}) =
  97          case findSubstring (s, {substring = substring}) of
  98             NONE => s
  99           | SOME i =>
 100                let
 101                   val n = length substring
 102                   val prefix = Substring.substring (s, {start = 0, length = i})
 103                   val suffix = Substring.extract (s, i + n, NONE)
 104                in
 105                   Substring.concat [prefix, Substring.full replacement, suffix]
 106                end
 107       fun substituteAll (s, {substring, replacement}) =
 108          case findSubstring (s, {substring = substring}) of
 109             NONE => s
 110           | SOME i =>
 111                let
 112                   val ls = length s
 113                   val lss = length substring
 114                   val prefix = dropSuffix (s, ls - i)
 115                   val suffix = substituteAll (dropPrefix (s, i + lss),
 116                                               {substring = substring,
 117                                                replacement = replacement})
 118                in
 119                   concat [prefix, replacement, suffix]
 120                end
 121    end
 122
 123 structure ZString = String (* CM bug ?? -- see instream.sml *)