diff --git a/lib/forgejo.ballcloud.cc/wball/proof-checker/parser/PARSER.sig b/lib/forgejo.ballcloud.cc/wball/proof-checker/parser/PARSER.sig new file mode 100644 index 0000000..287878d --- /dev/null +++ b/lib/forgejo.ballcloud.cc/wball/proof-checker/parser/PARSER.sig @@ -0,0 +1,6 @@ +signature PARSER = +sig + type result + type state + val parse : state -> result ParseUtils.p +end diff --git a/lib/forgejo.ballcloud.cc/wball/proof-checker/parser/ParseUtils.sml b/lib/forgejo.ballcloud.cc/wball/proof-checker/parser/ParseUtils.sml new file mode 100644 index 0000000..a6f2555 --- /dev/null +++ b/lib/forgejo.ballcloud.cc/wball/proof-checker/parser/ParseUtils.sml @@ -0,0 +1,2 @@ +structure ParseUtils = + Parse (type token = Scanner.token val pp_token = Scanner.pp_token) diff --git a/lib/forgejo.ballcloud.cc/wball/proof-checker/parser/TermParser.sml b/lib/forgejo.ballcloud.cc/wball/proof-checker/parser/TermParser.sml new file mode 100644 index 0000000..f0df4e1 --- /dev/null +++ b/lib/forgejo.ballcloud.cc/wball/proof-checker/parser/TermParser.sml @@ -0,0 +1,44 @@ +structure TermParser: PARSER = +struct + type result = Term.t + + structure StringSet = Utils.StringSet + structure ArityMap = Utils.ArityMap + + type state = + {binders: string list, constants: StringSet.t, functions: ArityMap.t} + + open ParseUtils + infix >>> ->> >>- ?? ??? || oo oor ??* + + open Term + open Scanner + + fun parse {binders = binders, constants = constants, functions = functions} = + let + fun term_p nil = + NO (Region.botloc, fn () => + "expecting identifier but reached the end") + | term_p ((Scanner.IDENT id, r) :: rest) = + (case Utils.findIndex (id, binders) of + SOME i => OK (Var i, r, rest) + | NONE => + if StringSet.member (constants, id) then + OK (Const id, r, rest) + else if ArityMap.member (functions, id) then + (args_p oo (fn args => Function (id, rev args))) rest + else + OK (Free id, r, rest)) + | term_p ((t, r) :: rest) = + NO (#1 r, fn () => + "expecting variable but found token " ^ pp_token t) + + and args_p ts = + (eat LPAREN + ->> + ((term_p oo (fn x => [x])) ??* (eat COMMA ->> term_p)) + (Utils.flip op::) >>- eat RPAREN) ts + in + term_p + end +end diff --git a/lib/forgejo.ballcloud.cc/wball/proof-checker/parser/parser.mlb b/lib/forgejo.ballcloud.cc/wball/proof-checker/parser/parser.mlb index 881c0a0..5ce090c 100644 --- a/lib/forgejo.ballcloud.cc/wball/proof-checker/parser/parser.mlb +++ b/lib/forgejo.ballcloud.cc/wball/proof-checker/parser/parser.mlb @@ -1,8 +1,11 @@ $(SML_LIB)/basis/basis.mlb ../kernel/kernel.mlb +../utils/utils.mlb ../../../../github.com/diku-dk/sml-parse/parse.mlb ../../../../github.com/diku-dk/sml-parse/simple_token.mlb SCANNER.sig Scanner.sml - +ParseUtils.sml +PARSER.sig +TermParser.sml repl.sml diff --git a/lib/forgejo.ballcloud.cc/wball/proof-checker/parser/repl.sml b/lib/forgejo.ballcloud.cc/wball/proof-checker/parser/repl.sml index 3adf621..db31f3a 100644 --- a/lib/forgejo.ballcloud.cc/wball/proof-checker/parser/repl.sml +++ b/lib/forgejo.ballcloud.cc/wball/proof-checker/parser/repl.sml @@ -1,16 +1,39 @@ open Scanner -fun scan_repl s = scan {srcname = "repl", input = s} +structure TermTesting: +sig + val parse_repl: string -> unit +end = +struct + open TermParser + open Utils + open ParseUtils + open Scanner -fun report_scan s = print ((String.concatWith ", " (map (pp_token o #1) (scan_repl s))) ^ "\n") + val binders = ["y", "x"] + val functions = ArityMap.fromList [("S", 1), ("plus", 2)] + val constants = StringSet.fromList ["zero"] + val state = {binders = binders, functions = functions, constants = constants} + + fun parse_repl s = + let + val toks = scan {input = s, srcname = "repl"} + in + case parse state toks of + OK (t, _, []) => print ("Parsed successfully: " ^ Term.ppd 2 t ^ "\n") + | OK (t, r, rest) => + print + ("Parsed '" ^ Term.ppd 2 t ^ "' up to " ^ Region.pp r ^ ", but " + ^ Int.toString (length rest) ^ " tokens remain unparsed\n") + | NO (r, err) => print ("ERROR: " ^ Region.ppLoc r ^ ", " ^ err () ^ "\n") + end +end fun repl () = ( print "> " ; case (TextIO.inputLine TextIO.stdIn) of - SOME s => (report_scan s; repl ()) + SOME s => (TermTesting.parse_repl s; repl ()) | NONE => () ) -fun main () = repl () - -(* val () = main () *) +fun main () = repl () (* val () = main () *) diff --git a/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/MAP.sig b/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/MAP.sig new file mode 100644 index 0000000..7bf07bc --- /dev/null +++ b/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/MAP.sig @@ -0,0 +1,13 @@ +signature MAP = +sig + type key + type value + type t + + val empty: t + val insert: t * key * value -> t + val member: t * key -> bool + val get: t * key -> value option + val fromList: (key * value) list -> t + val toList: t -> (key * value) list +end diff --git a/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/Map.sml b/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/Map.sml new file mode 100644 index 0000000..4942e53 --- /dev/null +++ b/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/Map.sml @@ -0,0 +1,39 @@ +functor Map (structure Ord: ORD type value) :> MAP + where type key = Ord.t + and type value = value = +struct + type key = Ord.t + type value = value + datatype t = Leaf | Node of t * key * value * t + + val empty = Leaf + + fun insert (Leaf, x, v) = Node (Leaf, x, v, Leaf) + | insert (s as Node (left, y, u, right), x, v) = + case Ord.compare (x, y) of + LESS => Node (insert (left, x, v), y, u, right) + | EQUAL => s + | GREATER => Node (left, y, u, insert (right, x, v)) + + fun member (Leaf, _) = false + | member (Node (left, y, _, right), x) = + case Ord.compare (x, y) of + LESS => member (left, x) + | EQUAL => true + | GREATER => member (right, x) + + fun get (Leaf, _) = NONE + | get (Node (left, y, v, right), x) = + case Ord.compare (x, y) of + LESS => get (left, x) + | EQUAL => SOME v + | GREATER => get (right, x) + + fun fromList [] = Leaf + | fromList ((x, v) :: xs) = + insert (fromList xs, x, v) + + fun toList Leaf = [] + | toList (Node (left, x, v, right)) = + toList left @ ((x, v) :: toList right) +end diff --git a/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/ORD.sig b/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/ORD.sig new file mode 100644 index 0000000..6891d7b --- /dev/null +++ b/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/ORD.sig @@ -0,0 +1,5 @@ +signature ORD = +sig + type t + val compare: t * t -> order +end diff --git a/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/Ord.sml b/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/Ord.sml new file mode 100644 index 0000000..f2809bb --- /dev/null +++ b/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/Ord.sml @@ -0,0 +1,4 @@ +structure IntOrd: ORD = struct type t = int val compare = Int.compare end + +structure StringOrd: ORD = +struct type t = string val compare = String.compare end diff --git a/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/SET.sig b/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/SET.sig new file mode 100644 index 0000000..6aefb24 --- /dev/null +++ b/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/SET.sig @@ -0,0 +1,11 @@ +signature SET = +sig + type elem + type t + + val empty: t + val insert: t * elem -> t + val member: t * elem -> bool + val fromList: elem list -> t + val toList: t -> elem list +end diff --git a/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/Set.sml b/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/Set.sml new file mode 100644 index 0000000..6b5544f --- /dev/null +++ b/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/Set.sml @@ -0,0 +1,29 @@ +functor Set(Ord: ORD) :> SET where type elem = Ord.t = +struct + type elem = Ord.t + datatype t = Leaf | Node of t * elem * t + + val empty = Leaf + + fun insert (Leaf, x) = Node (Leaf, x, Leaf) + | insert (s as Node (left, y, right), x) = + case Ord.compare (x, y) of + LESS => Node (insert (left, x), y, right) + | EQUAL => s + | GREATER => Node (left, y, insert (right, x)) + + fun member (Leaf, _) = false + | member (Node (left, y, right), x) = + case Ord.compare (x, y) of + LESS => member (left, x) + | EQUAL => true + | GREATER => member (right, x) + + fun fromList [] = Leaf + | fromList (x :: xs) = + insert (fromList xs, x) + + fun toList Leaf = [] + | toList (Node (left, x, right)) = + toList left @ (x :: toList right) +end diff --git a/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/UTILS.sig b/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/UTILS.sig new file mode 100644 index 0000000..f2ab3bd --- /dev/null +++ b/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/UTILS.sig @@ -0,0 +1,9 @@ +signature UTILS = +sig + val const: 'a -> 'b -> 'a + val flip: ('a * 'b -> 'c) -> ('b * 'a -> 'c) + val findIndex: ''a * ''a list -> int option + + structure StringSet: SET where type elem = string + structure ArityMap: MAP where type key = string and type value = int +end diff --git a/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/Utils.sml b/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/Utils.sml new file mode 100644 index 0000000..232a196 --- /dev/null +++ b/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/Utils.sml @@ -0,0 +1,16 @@ +structure Utils: UTILS = +struct + fun const k _ = k + + fun flip f = + fn (b, a) => f (a, b) + + fun findIndex' (_, [], _) = NONE + | findIndex' (y, (x :: xs), acc) = + if x = y then SOME acc else findIndex' (y, xs, acc + 1) + + fun findIndex (x, xs) = findIndex' (x, xs, 0) + + structure StringSet = Set(StringOrd) + structure ArityMap = Map (structure Ord = StringOrd type value = int) +end diff --git a/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/utils.mlb b/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/utils.mlb new file mode 100644 index 0000000..b0626ef --- /dev/null +++ b/lib/forgejo.ballcloud.cc/wball/proof-checker/utils/utils.mlb @@ -0,0 +1,9 @@ +$(SML_LIB)/basis/basis.mlb +ORD.sig +Ord.sml +SET.sig +Set.sml +MAP.sig +Map.sml +UTILS.sig +Utils.sml