You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
256 lines
6.3 KiB
256 lines
6.3 KiB
open import "prelude.ml"
|
|
open import "./monads.ml"
|
|
|
|
private type consumed = C | E
|
|
|
|
private type error = Unexpected of string * list string
|
|
|
|
instance show error begin
|
|
let show = function
|
|
| Unexpected (s, []) -> s
|
|
| Unexpected (s, ms) ->
|
|
"Unexpected " ^ s ^ "\n"
|
|
^ "Expecting one of " ^ foldl (^) "" ms
|
|
end
|
|
|
|
private type pos <- { line : int, col : int }
|
|
|
|
private type result 'a =
|
|
| Ok of consumed * 'a * string * pos
|
|
| Err of consumed * error * string * pos
|
|
|
|
let join_consumed x y =
|
|
match x with
|
|
| C -> C
|
|
| E -> y
|
|
|
|
type parser_t 'm 'a = private P of pos -> string -> 'm (result 'a)
|
|
type parser <- parser_t identity
|
|
|
|
instance functor 'm => functor (parser_t 'm) begin
|
|
let f <$> P x = P @@ fun pos i ->
|
|
flip map (x pos i) @@ fun p ->
|
|
match p with
|
|
| Ok (c, x, i) -> Ok (c, f x, i)
|
|
| Err e -> Err e
|
|
end
|
|
|
|
instance monad 'm => applicative (parser_t 'm) begin
|
|
let pure x = P (fun p s -> pure (Ok (E, x, s, p)))
|
|
let P f <*> P x = P @@ fun p s ->
|
|
let! f = f p s
|
|
match f with
|
|
| Ok (c, f, s, p) ->
|
|
let! x = x p s
|
|
match x with
|
|
| Ok (c', x, s, p) -> pure @@ Ok (join_consumed c c', f x, s, p)
|
|
| Err (c', p) -> pure @@ Err (join_consumed c c', p)
|
|
| Err e -> pure @@ Err e
|
|
end
|
|
|
|
let x *> y = (fun _ x -> x) <$> x <*> y
|
|
let x <* y = (| const x y |)
|
|
let x <$ a = map (const x) a
|
|
|
|
instance monad 'm => monad (parser_t 'm) begin
|
|
let P x >>= f = P @@ fun p s ->
|
|
let! x = x p s
|
|
match x with
|
|
| Ok (c, x, s, p) ->
|
|
let P kont = f x
|
|
let! x = kont p s
|
|
match x with
|
|
| Ok (c', x, s) -> pure @@ Ok (join_consumed c c', x, s)
|
|
| Err (c', p) -> pure @@ Err (join_consumed c c', p)
|
|
| Err e -> pure @@ Err e
|
|
end
|
|
|
|
let private fail e = P (fun p s -> pure (Err (E, e, s, p)))
|
|
|
|
let empty : forall 'm 'a. monad 'm => parser_t 'm 'a =
|
|
fail (Unexpected ("empty parse", []))
|
|
|
|
let unexpected e =
|
|
fail (Unexpected (e, []))
|
|
|
|
let alt_err (Unexpected (u, xs)) (Unexpected (_, ys)) =
|
|
Unexpected (u, xs ++ ys)
|
|
|
|
let P x <|> P y = P @@ fun p s ->
|
|
let! x = x p s
|
|
match x with
|
|
| Ok x -> pure (Ok x)
|
|
| Err (c, m, s, p) ->
|
|
let! y = y p s
|
|
match y with
|
|
| Ok (c', x, s) -> pure (Ok (join_consumed c c', x, s))
|
|
| Err (c', m', s) -> pure (Err (join_consumed c c', alt_err m m', s))
|
|
|
|
let P x <+> y = P @@ fun p s ->
|
|
let! x = x p s
|
|
match x with
|
|
| Ok x -> pure (Ok x)
|
|
| Err (c, m, s, p) ->
|
|
let P y = force y
|
|
let! y = y p s
|
|
match y with
|
|
| Ok (c', x, s) -> pure (Ok (join_consumed c c', x, s))
|
|
| Err (c', m', s) -> pure (Err (join_consumed c c', alt_err m m', s))
|
|
|
|
private module S = import "lua/string.ml"
|
|
|
|
let char : forall 'm. applicative 'm => parser_t 'm string =
|
|
P @@ fun p s ->
|
|
let x = S.substring s 1 1
|
|
if x <> "" then
|
|
let r = S.substring s 2 (S.length s)
|
|
if x == "\n" then
|
|
pure @@ Ok (C, x, r, { line = p.line + 1, col = 0 })
|
|
else
|
|
pure @@ Ok (C, x, r, { line = p.line, col = p.col + 1 })
|
|
else
|
|
pure @@ Err (E, Unexpected ("end-of-file", ["character"]), s, p)
|
|
|
|
let eof : forall 'm. applicative 'm => parser_t 'm () =
|
|
P @@ fun p s ->
|
|
if s == "" then
|
|
pure @@ Ok (E, (), s, p)
|
|
else
|
|
pure @@
|
|
Err (E, Unexpected (S.substring s 1 1, ["end-of-file"]), s, p)
|
|
|
|
let satisfy pred =
|
|
P @@ fun p s ->
|
|
let x = S.substring s 1 1
|
|
if x <> "" && pred x then
|
|
let r = S.substring s 2 (S.length s)
|
|
if x == "\n" then
|
|
pure @@ Ok (C, x, r, { line = p.line + 1, col = 0 })
|
|
else
|
|
pure @@ Ok (C, x, r, { line = p.line, col = p.col + 1 })
|
|
else
|
|
let m =
|
|
if x == "" then
|
|
"end of file"
|
|
else
|
|
x
|
|
pure @@ Err (E, Unexpected (m, ["character"]), s, p)
|
|
|
|
let P k <?> m = P @@ fun p s ->
|
|
let! x = k p s
|
|
match x with
|
|
| Ok e -> pure (Ok e)
|
|
| Err (c, Unexpected (u, _), s) -> pure (Err (c, Unexpected (u, [m]), s))
|
|
|
|
let many_fold k z (P x) =
|
|
let rec go consumed kont pos s =
|
|
let! x = x pos s
|
|
match x with
|
|
| Err ((c, _, s, pos) as p) ->
|
|
match c with
|
|
| C -> pure (Err p)
|
|
| E -> kont consumed z pos s
|
|
| Ok (c, x, s, pos) ->
|
|
match c with
|
|
| E -> error @@ "many: got parser that accepts the empty string"
|
|
| C -> go C (fun c -> kont c # k x) pos s
|
|
P (go E (fun c z pos s -> pure (Ok (c, z, s, pos))))
|
|
|
|
let many p = many_fold (::) [] p
|
|
let some p =
|
|
let! x = p
|
|
(x ::) <$> many p
|
|
|
|
let sep_by_1 sep p =
|
|
let! x = p
|
|
let! xs = many (sep *> p)
|
|
pure (x :: xs)
|
|
|
|
let sep_by sep p = sep_by_1 sep p <|> pure []
|
|
external private val is_infix_of : string -> string -> bool =
|
|
"function(s, s2) return s2:find(s) ~= nil end"
|
|
|
|
external private val is_prefix_of : string -> string -> bool =
|
|
"function(s, s2) return (s2:find(s)) == 1 end"
|
|
|
|
let one_of chs =
|
|
let len = S.length chs
|
|
let rec loop ch i =
|
|
if i > len then
|
|
fail @@ Unexpected (ch, ["one of \"" ^ chs ^ "\""])
|
|
else if ch == S.substring chs i i then
|
|
pure ch
|
|
else
|
|
loop ch (i + 1)
|
|
let! ch = char
|
|
loop ch 1
|
|
|
|
let symbol str =
|
|
let len = S.length str
|
|
let rec loop acc i =
|
|
if i > len then
|
|
pure acc
|
|
else
|
|
let! c = char <?> S.substring str i i
|
|
if c == S.substring str i i then
|
|
loop (acc ^ c) (i + 1)
|
|
else
|
|
fail @@ Unexpected (acc ^ c, [S.substring str 1 i])
|
|
loop "" 1
|
|
|
|
let between o c p =
|
|
let! _ = o
|
|
let! x = p
|
|
let! _ = c
|
|
pure x
|
|
|
|
let try (P x) = P @@ fun pos s ->
|
|
let! x = x pos s
|
|
match x with
|
|
| Ok c -> pure (Ok c)
|
|
| Err (_, p, _) -> pure (Err (E, p, s, pos))
|
|
|
|
let optionally p = map Some (try p) <|> pure None
|
|
|
|
|
|
let rec sep_end_by_1 sep p =
|
|
let! x = p
|
|
( let! _ = sep
|
|
let! xs = sep_end_by sep p
|
|
pure (x :: xs)
|
|
) <|> pure [x]
|
|
and sep_end_by sep p =
|
|
sep_end_by_1 sep p <|> pure []
|
|
|
|
let chainr1 p op =
|
|
let rec scan =
|
|
let! x = p
|
|
rest x
|
|
and rest x =
|
|
( let! f = op
|
|
let! y = scan
|
|
pure (f x y)
|
|
) <|> pure x
|
|
let _ = rest (* shut up, amc *)
|
|
scan
|
|
|
|
let parse (P x) s =
|
|
let! x = x { line = 0, col = 0 } s
|
|
match x with
|
|
| Ok (_, x, r) -> pure @@ Right (x, r)
|
|
| Err (_, m, _, p) -> pure @@ Left (m, p)
|
|
|
|
let run_parser p s =
|
|
let Id x = parse p s
|
|
x
|
|
|
|
let run_parser' (P x) s =
|
|
let Id x = x { line = 0, col = 0 } s
|
|
x
|
|
|
|
let lift m = P @@ fun pos s ->
|
|
let! x = m
|
|
pure @@ Ok (E, x, s, pos)
|
|
|
|
let morph (k : forall 'a. 'm 'a -> 'n 'a) (P x) = P @@ fun s -> k (x s)
|
|
let void x = map (const ()) x
|