open Parser
let wsfail msg = raise(Failure(msg))
let indenting_space program =
let rec space_indenting rtokens = function
| NEWLINE::SPACE(n)::rest -> space_indenting (SPACE(n)::NEWLINE::rtokens) rest
| COLON::SPACE(n)::rest -> space_indenting (SPACE(n)::COLON::rtokens) rest
| SPACE(n)::rest -> space_indenting rtokens rest
| token::rest -> space_indenting (token::rtokens) rest
| [] -> List.rev rtokens in
match (space_indenting [] (NEWLINE::program)) with
| NEWLINE::rest -> rest
| _ -> wsfail "Indenting should have left a NEWLINE at the start of program; did not."
let despace_brace program =
let rec brace_despace depth tokens rtokens last =
if depth > 0 then
match tokens with
| SPACE(_)::rest -> brace_despace depth rest rtokens last
| NEWLINE::rest -> brace_despace depth rest rtokens last
| COLON::_ -> wsfail "Colon inside brace scoping."
| LBRACE::rest -> brace_despace (depth+1) rest (LBRACE::rtokens) last
| RBRACE::rest -> let rtokens = if depth = 1
then SPACE(last)::NEWLINE::RBRACE::rtokens
else RBRACE::rtokens in
brace_despace (depth-1) rest rtokens last
| token::rest -> brace_despace depth rest (token::rtokens) last
| [] -> List.rev rtokens
else
match tokens with
| SPACE(n)::rest -> brace_despace depth rest (SPACE(n)::rtokens) n
| LBRACE::rest -> brace_despace (depth+1) rest (LBRACE::rtokens) last
| token::rest -> brace_despace depth rest (token::rtokens) last
| [] -> List.rev rtokens in
brace_despace 0 program [] 0
let trim_lines program =
let rec lines_trim tokens rtokens =
match tokens with
| [] -> List.rev rtokens
| SPACE(_)::NEWLINE::rest -> lines_trim rest (NEWLINE::rtokens)
| SPACE(_)::COLON::rest -> lines_trim rest (COLON::rtokens)
| token::rest -> lines_trim rest (token::rtokens) in
lines_trim program []
let squeeze_lines program =
let rec lines_squeeze tokens rtokens =
match tokens with
| [] -> List.rev rtokens
| NEWLINE::NEWLINE::rest -> lines_squeeze (NEWLINE::rest) rtokens
| COLON::NEWLINE::rest -> lines_squeeze (COLON::rest) rtokens
| token::rest -> lines_squeeze rest (token::rtokens) in
lines_squeeze program []
let spacing = function
| SPACE(n)::rest -> (n, rest)
| list -> (0, list)
let tokens_to_lines program =
let rec lines_from_tokens rline rlines = function
| NEWLINE::rest ->
(match rline with
| [] -> lines_from_tokens [] rlines rest
| _ -> let (spacer, line) = spacing (List.rev rline) in
lines_from_tokens [] ((spacer, line, false)::rlines) rest)
| COLON::rest ->
(match rline with
| [] -> lines_from_tokens [] rlines rest
| _ -> let (spacer, line) = spacing (List.rev rline) in
lines_from_tokens [] ((spacer, line, true)::rlines) rest)
| [] ->
(match rline with
| [] -> List.rev rlines
| _ -> let (spacer, line) = spacing (List.rev rline) in
lines_from_tokens [] ((spacer, line, false)::rlines) [])
| token::rest -> lines_from_tokens (token::rline) rlines rest in
lines_from_tokens [] [] program
let merge_lines program_lines =
let rec lines_merge rlines = function
| ((n1, _, _) as line1)::((n2, _, _) as line2)::rest when n1 >= n2 -> lines_merge (line1::rlines) (line2::rest)
| (n, line1, false)::(_, line2, colon)::rest -> lines_merge rlines ((n, line1@line2, colon)::rest)
| ((_, _, true) as line)::rest -> lines_merge (line::rlines) rest
| line::[] -> lines_merge (line::rlines) []
| [] -> List.rev rlines in
lines_merge [] program_lines
let rec needs_semi = function
| [] -> true
| RBRACE::[] -> false
| SEMI::[] -> false
| _::rest -> needs_semi rest
let block_merge lines =
let add_semi = function
| (n, toks, true) -> (n, toks, true, false)
| (n, toks, false) -> (n, toks, false, needs_semi toks) in
let lines = List.map add_semi lines in
let rec merge_blocks rblocks = function
| (n1, line1, false, s1)::(n2, line2, colon, s2)::rest when n1 = n2 ->
let newline = line1 @ (if s1 then [SEMI] else []) @ line2 in
merge_blocks rblocks ((n1, newline, colon, s2)::rest)
| (n, line, colon, _)::rest -> merge_blocks ((n, line, colon)::rblocks) rest
| [] -> List.rev rblocks in
merge_blocks [] lines
let terminate_blocks blocks =
let rec block_terminate rblocks = function
| (n, toks, false)::rest ->
let terminated = if (needs_semi toks) then toks@[SEMI] else toks in
block_terminate ((n, terminated, false)::rblocks) rest
| other::rest ->
block_terminate (other::rblocks) rest
| [] -> List.rev rblocks in
block_terminate [] blocks
let rec arrange n stack rtokens =
match stack with
| top::rest when n <= top -> arrange n rest (RBRACE::rtokens)
| _ -> (stack, rtokens)
let space_to_brace = function
| [] -> []
| linelist -> let rec despace_enbrace stack rtokens = function
| [] -> List.rev ((List.map (function _ -> RBRACE) stack) @ rtokens)
| (n, line, colon)::rest ->
let (stack, rtokens) = arrange n stack rtokens in
let (lbrace, stack) = if colon then ([LBRACE], n::stack) else ([], stack) in
despace_enbrace stack (lbrace@(List.rev line)@rtokens) rest
in despace_enbrace [] [] linelist
let drop_eof program =
let rec eof_drop rtokens = function
| EOF::[] -> List.rev rtokens
| EOF::rest -> raise(Failure("Misplaced EOF"))
| [] -> raise(Failure("No EOF available."))
| tk::tks -> eof_drop (tk::rtokens) tks in
eof_drop [] program
let append_eof program =
let rec eof_add rtokens = function
| [] -> List.rev (EOF::rtokens)
| tk::tks -> eof_add (tk::rtokens) tks in
eof_add [] program
let convert program =
let noeof = drop_eof program in
let indented = indenting_space noeof in
let despaced = despace_brace indented in
let trimmed = trim_lines despaced in
let squeezed = squeeze_lines trimmed in
let lines = tokens_to_lines squeezed in
let merged = merge_lines lines in
let blocks = block_merge merged in
let terminated = terminate_blocks blocks in
let converted = space_to_brace terminated in
append_eof converted
let lextoks toks =
let tokens = ref (convert toks) in
function _ ->
match !tokens with
| [] -> raise(Failure("Not even EOF given."))
| tk::tks -> tokens := tks; tk