lib/mlton/basic/parse.sml

   1 (* Copyright (C) 2017 Jason Carr.
   2  *
   3  * MLton is released under a BSD-style license.
   4  * See the file MLton-LICENSE for details.
   5  *)
   6
   7 structure Parse :> PARSE =
   8 struct
   9
  10 infix 1 <|> >>=
  11 infix  3 <*> <* *>
  12 infixr 4 <$> <$$> <$$$> <$ <$?>
  13
  14 structure Location =
  15    struct
  16       type t = {line: int, column: int}
  17    end
  18 structure State =
  19    struct
  20       (* this is our state representation for readers *)
  21       type t = (char * Location.t) Stream.t
  22    end
  23
  24
  25 datatype 'a result = Success of 'a * (char * Location.t) Stream.t
  26                    | Failure of string list (* expected options *)
  27                    | FailCut of string list (* as failure, but the
  28                    closest upstream choice point won't try other options, and
  29                    their errors will be silenced *)
  30 type 'a t =
  31    State.t -> 'a result
  32
  33
  34 fun indexStream({line, column}, s) =
  35    case Stream.force s of
  36       NONE => Stream.empty ()
  37     | SOME(h, r) =>
  38          Stream.cons((h, {line=line, column=column}),
  39             Stream.delay(fn () =>
  40                if h = #"\n"
  41                then
  42                   indexStream({line=line+1, column=0}, r)
  43                else
  44                   indexStream({line=line, column=column+1}, r)
  45             )
  46          )
  47
  48 fun doFail([]) = Result.No ("Parse error")
  49   | doFail([msg]) = Result.No ("Parse error: Expected " ^ msg)
  50   | doFail(msgs) = Result.No ("Parse error: Expected one of \n" ^
  51        (String.concat(List.map(msgs, fn x => x ^ "\n"))))
  52
  53 fun parseStream(p : 'a t, stream) : 'a Result.t =
  54    case p (indexStream({line=1, column=1}, stream))
  55    of Success (b, _) => Result.Yes b
  56     | Failure ms => doFail ms
  57     | FailCut ms => doFail ms
  58 fun parseString(p : 'a t, string) : 'a Result.t =
  59    parseStream(p, Stream.fromList (String.explode string))
  60 fun parseFile(p : 'a t, file) : 'a Result.t =
  61    File.withIn
  62    (file, fn i =>
  63     let
  64        fun toStream () =
  65           case In.inputChar i of
  66              SOME c => Stream.cons (c, Stream.delay toStream)
  67            | NONE => Stream.empty ()
  68     in
  69        parseStream(p, toStream ())
  70     end)
  71
  72
  73
  74 fun tf <*> tx = fn (s : State.t) =>
  75    case tf s
  76       of Success (f, s') =>
  77           (case tx s'
  78              of Success (b, s'') =>
  79                    Success (f b, s'')
  80               (* constructors have to be explict to typecheck *)
  81               | Failure err => Failure err
  82               | FailCut err => FailCut err)
  83        | Failure err => Failure err
  84        | FailCut err => FailCut err
  85
  86 fun ta >>= f = fn (s : State.t) =>
  87    case ta s
  88       of Success (a, s') =>
  89          f a s'
  90        | Failure err => Failure err
  91        | FailCut err => FailCut err
  92
  93
  94 fun fst a _ = a
  95 fun snd _ b = b
  96
  97 fun curry f a b = f (a, b)
  98 fun curry3 f a b c = f (a, b, c)
  99
 100 fun pure a (s : State.t)  =
 101   Success (a, s)
 102
 103 fun f <$> p = (pure f) <*> p
 104 fun f <$$> (p1, p2) = curry <$> (pure f) <*> p1 <*> p2
 105 fun f <$$$> (p1, p2, p3) = curry3 <$> (pure f) <*> p1 <*> p2 <*> p3
 106 fun f <$?> p = p >>= (fn a => case f a of SOME b => pure b
 107                                         | NONE => fn _ => Failure [])
 108 fun a <* b = fst <$> a <*> b
 109 fun a *> b = snd <$> a <*> b
 110 fun v <$ p = (fn _ => v) <$> p
 111 fun a <|> b = fn s => case (a s)
 112    of Success r => Success r
 113     | Failure err1 => (case (b s) of
 114         Success r => Success r
 115       | Failure err2 => Failure (List.append(err1, err2))
 116       | FailCut err2 => Failure (err2))
 117     | FailCut err1 => Failure err1
 118
 119 structure Ops = struct
 120    val (op >>=) = (op >>=)
 121    val (op <*>) = (op <*>)
 122    val (op <$>) = (op <$>)
 123    val (op <$?>) = (op <$?>)
 124    val (op <$$>) = (op <$$>)
 125    val (op <$$$>) = (op <$$$>)
 126    val (op <*) = (op <*)
 127    val (op *>) = (op *>)
 128    val (op <$) = (op <$)
 129    val (op <|>) = (op <|>)
 130 end
 131
 132
 133
 134 fun failString (m, p : Location.t, s : (char * Location.t) Stream.t) =
 135    (m ^ " at " ^
 136       (Int.toString (#line p)) ^ ":" ^ (Int.toString (#column p)) ^
 137       "\n     Near: " ^ (String.implode (List.map(Stream.firstNSafe(s, 20), #1))))
 138
 139 fun fail m (s : State.t) = case Stream.force (s)
 140    of NONE => Failure []
 141     | SOME((_, p : Location.t), _) => Failure [failString (m, p, s)]
 142
 143 fun failCut m (s : State.t) = case Stream.force (s)
 144    of NONE => FailCut []
 145     | SOME((_, p : Location.t), _) => FailCut [failString (m, p, s)]
 146
 147 fun cut p s = case p s
 148    of Success x => Success x
 149     | Failure m => FailCut m
 150     | FailCut m => FailCut m
 151
 152 fun uncut p s = case p s of
 153     Success x => Success x
 154   | Failure m => Failure m
 155   | FailCut m => Failure m
 156
 157 fun delay p = fn s => p () s
 158
 159 fun next (s : State.t)  = case Stream.force (s)
 160    of NONE => Failure ["Any character at end of file"]
 161     | SOME((h, _), r) => Success (h, r)
 162
 163 fun satExpects(t, p, m) s =
 164    case t s of
 165        Success (a, s') =>
 166          (if p a then Success (a, s') else fail m s)
 167      | Failure err => Failure err
 168      | FailCut err => FailCut err
 169
 170 fun sat(t, p) s = satExpects(t, p, "Satisfying") s
 171 fun nextSat p s = case Stream.force s
 172    of NONE => Failure ["Any character at end of file"]
 173     | SOME((h, _), r) => (case p h of
 174          false => Failure ["Satisfying character"]
 175        | true => Success (h, r))
 176
 177 fun peek p (s : State.t) =
 178    case p s of Success (h', _) => Success (h', s)
 179              | err => err
 180
 181 fun failing p s =
 182    case p s
 183       of Success _ => fail "failure" s
 184        | _ => Success ((), s)
 185
 186 fun notFollowedBy(p, c) =
 187    p <* failing c
 188
 189 fun any'([]) s = Failure []
 190   | any'(p::ps) s =
 191        case p s of
 192           Success (a, s) => Success (a, s)
 193         | Failure m => (case any'(ps) s
 194            of Failure m2 => Failure (List.append(m, m2))
 195             | succ => succ)
 196         | FailCut m => FailCut m
 197 fun 'a any ps = uncut (any' ps)
 198
 199
 200 fun 'a many' (t : 'a t) s = case ((op ::) <$$> (t, fn s' => many' t s')) s of
 201     Success x => Success x
 202   | Failure y => pure [] s
 203   | FailCut z => FailCut z
 204 fun 'a many t = uncut (many' t)
 205 fun 'a many1 (t : 'a t) = uncut ((op ::) <$$> (t, many' t))
 206
 207 fun manyFailing(p, f) = many (failing f *> p)
 208 fun manyCharsFailing f = many (failing f *> next)
 209
 210 fun sepBy1(t, sep) = uncut ((op ::) <$$> (t, many' (sep *> t)))
 211 fun sepBy(t, sep) = uncut ((op ::) <$$> (t, many' (sep *> t)) <|> pure [])
 212
 213 fun optional t = SOME <$> t <|> pure NONE
 214
 215 fun char c s = case Stream.force (s)
 216    of NONE => Failure [String.fromChar c ^ " at end of file"]
 217     | SOME((h, _), r) =>
 218          if h = c
 219             then Success (h, r)
 220             else fail (String.fromChar c) s
 221
 222
 223 fun each([]) = pure []
 224   | each(p::ps) = (curry (op ::)) <$> p <*> (each ps)
 225
 226
 227 fun matchList s1 l2 = case (Stream.force s1, l2)
 228    of (_, []) => Success ((), s1)
 229     | (NONE, (_::_)) => Failure []
 230     | (SOME ((h, _), r), (x :: xs)) => if h = x then matchList r xs else Failure []
 231 fun str str s = case matchList (s) (String.explode str)
 232    of Success ((), r) => Success (str, r)
 233     | _ => fail str s
 234
 235 fun location (s : State.t) = case Stream.force s of
 236        NONE => Failure ["any character end of file location"]
 237      | SOME((h, n), r) => Success (n, s)
 238
 239 fun toReader (p : 'a t) (s : State.t) : ('a * State.t) option =
 240    case p s of
 241       Success (a, s') => SOME (a, s')
 242     | _ => NONE
 243
 244 fun fromReader (r : State.t -> ('a * State.t) option) (s : State.t) =
 245    case r s of
 246       SOME (b, s') =>
 247          Success (b, s')
 248     | NONE => fail "fromReader" s
 249
 250 fun compose (p1 : char list t, p2 : 'a t) (s : State.t) =
 251    let
 252       (* easiest way to escape here *)
 253       exception ComposeFail of string list
 254       fun makeStr s' () = case Stream.force s' of
 255          NONE => Stream.empty ()
 256        | SOME ((_, pos), r) =>
 257             (case p1 s' of
 258                 Success (b, r) => (case b of
 259                     (* equivalent, but avoids the jumping from append of fromList *)
 260                     c::[] => Stream.cons((c, pos), Stream.delay (makeStr r))
 261                   | _  => Stream.append
 262                         (indexStream(pos, Stream.fromList b),
 263                          Stream.delay (makeStr r)))
 264               | Failure m => raise ComposeFail m
 265               | FailCut m => raise ComposeFail m)
 266    in
 267       p2 (makeStr (s) () ) handle ComposeFail m => Failure m end
 268
 269
 270 val digits = many (nextSat (fn c => Char.isDigit c orelse c = #"~"))
 271
 272 val int = (fromReader (Int.scan (StringCvt.DEC, (toReader next)))) <|> failCut "integer"
 273 val intInf = (fromReader (IntInf.scan (StringCvt.DEC, (toReader next)))) <|> failCut "integer"
 274
 275 val uint = (fromReader (Int.scan (StringCvt.DEC, (toReader (nextSat Char.isDigit))))) <|> failCut "unsigned integer"
 276 val uintInf = (fromReader (IntInf.scan (StringCvt.DEC, (toReader (nextSat Char.isDigit))))) <|> failCut "unsigned integer"
 277
 278 val space = nextSat Char.isSpace
 279
 280 val spaces = many space
 281
 282 fun tuple p = Vector.fromList <$>
 283    (char #"(" *> sepBy(spaces *> p, char #",") <* char #")")
 284
 285 fun vector p = Vector.fromList <$>
 286    (char #"[" *> sepBy(spaces *> p, char #",") <* char #"]")
 287
 288
 289 end