Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- datatype ('s, 'a) state = STATE of 's -> 's * 'a
- type position =
- { line : int
- , pos : int
- }
- fun position_to_str {line, pos} =
- Int.toString line ^ ": " ^ Int.toString pos
- type 'a tracked = (position, 'a) state
- datatype block
- = BLOCK of substring
- | EOF
- datatype ('cont, 'res) coroutine
- = AWAIT of 'cont
- | STOP of 'res
- and 'a parseResult
- = OK of 'a
- | EXPECTED of string
- and 'a parser = PARSER of (block -> 'a parser, 'a parseResult) coroutine tracked
- fun mapState (f : 'a -> 'b) (STATE sa : ('s, 'a) state) : ('s, 'b) state =
- STATE (fn s =>
- case sa s of
- (s, a) => (s, f a))
- fun returnState (value : 'a) : ('s, 'a) state =
- STATE (fn s =>
- (s, value))
- fun mapCoroutine
- (f : 'cont -> 'cont1)
- (g : 'res -> 'res1)
- (c : ('cont, 'res) coroutine)
- : ('cont1, 'res1) coroutine =
- case c
- of AWAIT cont => AWAIT (f cont)
- | STOP res => STOP (g res)
- val get : ('s, 's) state =
- STATE (fn s => (s, s))
- fun modify (f : 's -> 's) : ('s, unit) state =
- STATE (fn s => (f s, ()))
- fun return (value : 'a) : 'a parser =
- PARSER (returnState (STOP (OK value)))
- fun expected (msg : string) : 'a parser =
- PARSER (returnState (STOP (EXPECTED msg)))
- infix matched_as
- fun matched_as ((PARSER (STATE ma), amb) : 'a parser * ('a -> 'b parser)) : 'b parser =
- PARSER (STATE (fn position =>
- let
- val (newPos, action) = ma position
- in
- case action
- of AWAIT xma =>
- (newPos, AWAIT (fn block =>
- xma block matched_as amb
- ))
- | STOP (OK a) =>
- (case amb a of
- PARSER (STATE sb) =>
- sb newPos)
- | STOP (EXPECTED text) =>
- (newPos, STOP (EXPECTED text))
- end
- ))
- infix wraped_with
- fun wraped_with ((parser, f) : 'a parser * ('a -> 'b)) : 'b parser =
- parser matched_as (return o f)
- infix catch
- fun catch
- ( (PARSER (STATE ma) , spmb)
- : 'a parser * (string * position -> 'a parser)
- )
- : 'a parser =
- PARSER (STATE (fn position =>
- let
- val (newPos, action) = ma position
- in
- case action
- of AWAIT xma =>
- (newPos, AWAIT (fn block =>
- xma block catch spmb
- ))
- | STOP (OK a) =>
- (newPos, STOP (OK a))
- | STOP (EXPECTED text) =>
- (case spmb (text, newPos)
- of PARSER (STATE sa) =>
- sa position)
- end
- ))
- infix being
- fun being ((msg, parser) : string * 'a parser) : 'a parser =
- parser catch (fn (err, at) =>
- expected (msg ^ " (" ^ err ^ " at " ^ position_to_str at ^ ")")
- )
- fun zeroOrMore (parser : 'a parser) : 'a list parser =
- (parser matched_as (fn a =>
- zeroOrMore parser matched_as (fn az =>
- return (a :: az))))
- catch (fn _ => return [])
- fun oneOrMore (parser : 'a parser) : 'a list parser =
- parser matched_as (fn a =>
- zeroOrMore parser matched_as (fn az =>
- return (a :: az)))
- fun maybe (parser : 'a parser) : 'a option parser =
- parser wraped_with SOME
- catch (fn _ => return NONE)
- val getPosition : position parser =
- PARSER (STATE (fn position =>
- (position, STOP (OK position))
- ))
- fun any_of (parsers : 'a parser list) : 'a parser =
- let
- fun collect_errors errors parsers =
- case parsers
- of (parser :: rest) =>
- parser catch (fn error =>
- collect_errors (error :: errors) rest
- )
- | [] =>
- expected (pack_errors errors)
- and pack_errors errors =
- let
- infix further_than
- fun further_than
- ( {line = l1, pos = p1}
- , {line = l2, pos = p2}
- ) =
- l1 > l2 orelse (l1 = l2 andalso p1 > p2)
- fun take_furthest ((e2, at2), list) =
- case list
- of (e1, at1) :: rest =>
- if at1 further_than at2
- then list
- else if at2 further_than at1
- then (e2, at2) :: rest
- else (e2, at2) :: list
- | [] =>
- [(e2, at2)]
- val far = foldl take_furthest [] errors
- fun error_to_str (e, at) = e ^ " at " ^ position_to_str at
- val text =
- "any of [" ^ String.concatWith ", "
- (map error_to_str far) ^
- "]"
- in
- text
- end
- in
- collect_errors [] parsers
- end
- infix or
- fun or (l, r) = any_of [l, r]
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement