lib/mlton/basic/mark.sml

   1 (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  *
   4  * MLton is released under a BSD-style license.
   5  * See the file MLton-LICENSE for details.
   6  *)
   7
   8 structure Mark: MARK =
   9 struct
  10
  11 datatype t =
  12    T of {string: string,
  13          pos: int}
  14
  15 fun pos (T {pos, ...}) = pos
  16
  17 local
  18    val numChars: int = 15
  19 in
  20    fun layout (T {string, pos}) =
  21       String.layout (String.substring1 (string, {start = pos, length = numChars}))
  22 end
  23
  24 fun length (T {string, ...}) = String.size string
  25 fun isAtBeginning (m: t): bool = pos m = 0
  26 fun isAtEnd (m: t): bool = pos m = length m - 1
  27 fun diff (m: t, m': t): int = pos m - pos m'
  28
  29 fun fromString s = T {string = s, pos = 0}
  30 fun fromFile f = fromString (File.contents f)
  31
  32 fun beginning (T {string, ...}) = T {string = string, pos = 0}
  33
  34 exception BackwardChars
  35 fun backwardChars (T {string, pos},n) =
  36    let val pos = pos - n
  37    in if pos < 0 then raise BackwardChars
  38       else T {string = string, pos = pos}
  39    end
  40 fun backwardChar m = backwardChars (m, 1)
  41 val backwardChar = Trace.trace ("Mark.backwardChar", layout, layout) backwardChar
  42
  43 exception ForwardChars
  44 fun forwardChars (T {string, pos},n) =
  45    let val pos = pos + n
  46    in if pos > String.size string then raise ForwardChars
  47       else T {string = string, pos = pos}
  48    end
  49 fun forwardChar m = forwardChars (m, 1)
  50 val forwardChar = Trace.trace ("Mark.forwardChar", layout, layout) forwardChar
  51
  52 fun charAt (T {string, pos}) = String.sub (string, pos)
  53
  54 fun lookingAtChar (m, c) = Char.equals (charAt m, c)
  55
  56 local
  57    fun searchChar move (m, c) =
  58       let
  59          fun loop m =
  60             if lookingAtChar (m, c) then m else loop (move m)
  61       in loop m
  62       end
  63 in
  64    val searchCharForward = searchChar forwardChar
  65    fun searchCharBackward (m, c) =
  66       searchChar backwardChar (backwardChar m, c)
  67 end
  68
  69 fun bol m = forwardChar (searchCharBackward (m, #"\n"))
  70    handle _ => beginning m
  71
  72 fun eol m = searchCharForward (m, #"\n")
  73
  74 fun whatColumn m = diff (m, bol m)
  75
  76 fun numColumns m = diff (eol m, bol m)
  77
  78 local
  79    fun moveLines move =
  80       let
  81          fun moves (m as T {string, pos}, n: int) =
  82          let
  83             val c = whatColumn m
  84             fun loop (m, n) =
  85                if n <= 0 then forwardChars (m, Int.min (c, numColumns m))
  86                else loop (move m, n - 1)
  87          in loop (bol m, n)
  88          end
  89           fun move m = moves (m, 1)
  90       in (move, moves)
  91       end
  92 in
  93    val (previousLine, previousLines) = moveLines (bol o backwardChar)
  94    val (nextLine, nextLines) = moveLines (forwardChar o eol)
  95 end
  96
  97 fun lookingAtString (T {string, pos}, string') =
  98    let
  99       val len = String.size string
 100       val len' = String.size string'
 101       fun loop (pos, pos') =
 102          pos < len
 103          andalso (pos' >= len'
 104                   orelse (Char.equals (String.sub (string, pos),
 105                                        String.sub (string', pos'))
 106                           andalso loop (pos + 1, pos' + 1)))
 107    in loop (pos, 0)
 108    end
 109 val lookingAtString =
 110    Trace.trace2 ("Mark.lookingAtString", layout, String.layout, Bool.layout)
 111    lookingAtString
 112
 113 exception Search
 114 fun makeSearch move (m, s) =
 115    let
 116       fun search m =
 117          if lookingAtString (m, s)
 118             then forwardChars (m, String.size s)
 119          else (search (move m) handle _ => raise Search)
 120    in search m
 121    end
 122
 123 val search = makeSearch forwardChar
 124 val searchBackward = makeSearch backwardChar
 125
 126 fun skip p =
 127    let fun skip m = if p (charAt m) then skip (forwardChar m)
 128                     else m
 129    in skip
 130    end
 131
 132 fun skipUntil p = skip (not o p)
 133
 134 val skipSpaces = skip Char.isSpace
 135 val skipUntilSpace = skipUntil Char.isSpace
 136
 137 fun substring (T {string, pos}, T {pos=pos', ...}) =
 138    String.substring2 (string, {start=pos, finish=pos'})
 139
 140 fun num (fromString, exn) m =
 141    let val m = skipSpaces m
 142       val m' = skipUntilSpace m
 143    in case fromString (substring (m, m')) of
 144       NONE => raise exn
 145     | SOME n => (m',n)
 146    end
 147
 148 exception Int
 149 val int = num (Int.fromString, Int)
 150
 151 exception Real
 152 val real = num (Real.fromString, Real)
 153
 154 val real = Trace.trace ("Mark.real", layout, Layout.tuple2 (layout, Real.layout)) real
 155
 156 val op < = fn (m, m') => pos m < pos m'
 157
 158 val equals = fn (m, m') => pos m = pos m'
 159
 160 val {>, >=, <=, min, max, compare} =
 161    Relation.lessEqual {< = op <, equals = op =}
 162
 163 end