parser based on extensible continuations

a.hs

let {
	list_push x =
		let rec ret y =
			match y
			| [y; ys] -> [y; ret ys]
			| _ -> [x; ()];
		ret;
	list_push_sorted f x =
		let g = f x;
		let rec ret y0 =
			match y0
			| [y; ys] if g >= f y -> [y; ret ys]
			| _ -> [x; y0];
		ret;
	list_append x y =
		let rec ret x =
			match x
			| [x; xs] -> [x; ret xs]
			| _ -> y;
		ret x;
	list_length = let rec ret n x = (
		match x
		| [_; xs] -> ret (n + 1) xs
		| _ -> n
	); ret 0;
	list_rev x =
		let rec ret x y =
			match x
			| [x; xs] -> ret xs [x; y]
			| _ -> y;
		ret x ();
	list_iter f =
		let rec iter x =
			match x
			| [x; xs] -> (f x; iter xs)
			| _ -> ();
		iter;
	(* like iter, but call second function when done *)
	list_iter2 f g =
		let rec iter x =
			match x
			| [x; xs] -> (f x; iter xs)
			| _ -> g();
		iter;
	list_map f =
		let rec iter x =
			match x
			| [x; xs] -> [f x; iter xs]
			| _ -> ();
		iter;
	list_filter f =
		let rec iter x =
			match x
			| [x; xs] -> let xs = iter xs; if f x then [x; xs] else xs
			| _ -> ();
		iter;
	list_foldl f =
		let rec iter acc x =
			match x
			| [x; xs] -> iter (f acc x) xs
			| _ -> acc;
		iter;
	list_foldr f =
		let rec iter x acc =
			match x
			| [x; xs] -> f (iter xs) acc
			| _ -> acc;
		iter;
	list_find f =
		let rec iter x =
			match x
			| [x; xs] -> if f x then [x] else iter xs
			| _ -> [];
		iter;
	list_contains f =
		let rec iter x =
			match x
			| [x; xs] -> if f x then true else iter xs
			| _ -> false;
		iter;
	list_sort_by f r =
		let keyed = list_map (\x -> [f x; x]) r;
		let rec ret r = (
			match r
			| () -> ()
			| x ->
				let {
					[[k; v]; xs] = x;
					lt = ret (list_filter (\[k1; _] -> k1 < k) xs);
					gt = ret (list_filter (\[k1; _] -> k1 >= k) xs);
				};
				list_append lt [v; gt]
		);
		ret keyed;
	list_index f x = (
		let m = mutmap();
		list_iter (\x -> mutmapadd m x x) x;
		mutmapget m
	);
	list_strict f =
		let rec ret x =
			match x
			| [x; xs] -> ret xs
			| _ -> f ();
		ret;
};

let rec {
	mk_cont x = [x; .[]];
	cont_prepend [b; c] f = [b; [f; c]];
	cont_extend [b; c] f = [b; list_push f c];
	cont_call [b; c] x =
		match c
		| [f; fs] -> f x (\_ -> cont_call [b; fs] x)
		| _ -> ["error"; b];
	cont_map [b; c] f = [b; list_map f c];
};

let rec {
	parse_tok_ws [xs0; c] bt =
		match xs0
		| [' '; xs] -> parse_tok c xs
		| ['	'; xs] -> parse_tok c xs
		| ['
'; xs] -> parse_tok c xs
		| _ -> bt();

	parse_tok_num [xs0; c] bt =
		let c0 = char2int '0';
		let c9 = char2int '9';
		let run sign x xs =
			let ca = char2int 'a';
			let cA = char2int 'A';
			let digit base n =
				let n = char2int n;
				if (if n >= c0 then if n <= c9 then n < c0 + base else false else false) then [n - c0]
				else if (if n >= ca then n < ca + base - 10 else false) then [n - ca + 10]
				else if (if n >= cA then n < cA + base - 10 else false) then [n - cA + 10]
				else [];
			let rec iter base xs =
				match xs
				| [x; xs] -> if let [d] = digit base x then (
					let [ns; xs] = iter base xs;
					[[d; ns]; xs]
				) else [(); xs]
				| _ -> [(); xs];
			let [base; xs] =
				match [x; xs]
				| ['0'; ['x'; xs]] -> [16; xs]
				| ['0'; ['o'; xs]] -> [8; xs]
				| ['0'; ['b'; xs]] -> [2; xs]
				| xs -> [10; xs];
			let [ns; xs] = iter base xs;
			let #[num] = c;
			num (sign * base) ns xs;
		match xs0
		| [x; xs] if (let n = char2int x; if n >= c0 then n <= c9 else false) ->
			run 1 x xs
		| ['+'; [x; xs]] if (let n = char2int x; if n >= c0 then n <= c9 else false) ->
			run 1 x xs
		| ['-'; [x; xs]] if (let n = char2int x; if n >= c0 then n <= c9 else false) ->
			run (0-1) x xs
		| _ -> bt();

	parse_tok_op [xs0; c] bt =
		match xs0
		| ['+'; xs] -> let #[+] = c; + xs
		| ['*'; xs] -> let #[*] = c; * xs
		| ['-'; xs] -> let #[-] = c; - xs
		| ['/'; xs] -> let #[/] = c; / xs
		| _ -> bt();

	parse_tok_paren [xs0; c] bt =
		match xs0
		| ['('; xs] -> let #[LP] = c; LP xs
		| [')'; xs] -> let #[RP] = c; RP xs
		| _ -> bt();

	parse_tok_eof [xs; c] bt =
		if xs = () then let #[eof] = c; eof() else bt();

	parse_tok_ = list_foldl cont_extend (mk_cont "tok") .[parse_tok_ws; parse_tok_num; parse_tok_op; parse_tok_paren; parse_tok_eof];
	parse_tok c ch = cont_call parse_tok_ [ch; c];

	parse_term_num m c = #[
		num signbase n ch = parse_tok (c let #[num] = m; num signbase n) ch
	];
	parse_term_group m c = #[
		LP ch = parse_tok (parse_expr m \expr -> #[
			RP ch = parse_tok (c expr) ch
		]) ch
	];
	parse_term m c = merge (parse_term_num m c) (parse_term_group m c);

	parse_app m c =
		let next = parse_term m;
		let rec cont expr = merge (c expr) (next \rhs -> cont let #[app] = m; app expr rhs);
		next cont;

	parse_unary m c =
		let next = parse_app m;
		merge (next c) #[
			+ ch = parse_tok (next \expr -> c let #[unp] = m; unp expr) ch;
			- ch = parse_tok (next \expr -> c let #[unm] = m; unm expr) ch;
		];

	parse_prod m c =
		let next = parse_unary m;
		let rec cont expr = merge (c expr) #[
			* ch = parse_tok (next \rhs -> cont let #[*] = m; expr * rhs) ch;
			/ ch = parse_tok (next \rhs -> cont let #[/] = m; expr / rhs) ch;
		];
		next cont;

	parse_sums m c =
		let next = parse_prod m;
		let rec cont expr = merge (c expr) #[
			+ ch = parse_tok (next \rhs -> cont let #[+] = m; expr + rhs) ch;
			- ch = parse_tok (next \rhs -> cont let #[-] = m; expr - rhs) ch;
		];
		next cont;
	parse_expr = parse_sums;
};

let mk_expr = #[
	app lhs rhs = ["app"; lhs; rhs];
	* lhs rhs = ["*"; lhs; rhs];
	/ lhs rhs = ["/"; lhs; rhs];
	+ lhs rhs = ["+"; lhs; rhs];
	- lhs rhs = ["-"; lhs; rhs];
	unp expr = ["+"; expr];
	unm expr = ["-"; expr];
	num signbase n = ["num"; signbase; n];
];

parse_tok
	(parse_sums mk_expr
		(\expr -> #[eof = \_ -> println ["got"; expr]]))
	(readfile "program3.txt");