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.
This repo is archived. You can view files and clone it, but cannot push or open issues/pull-requests.
 
 

101 lines
3.2 KiB

open Printf
let provider lexbuf () =
let tok = Lex.token lexbuf in
let start, stop = Sedlexing.lexing_positions lexbuf in
tok, start, stop
let parser_result lexbuf = MenhirLib.Convert.Simplified.traditional2revised
Parser.prog
(provider lexbuf)
let print_position outx lexbuf =
let (_, pos) = Sedlexing.lexing_positions lexbuf in
fprintf outx "%s:%d:%d" pos.pos_fname
pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1)
let parse_with_error lexbuf =
try (parser_result lexbuf; ) with
| Lex.SyntaxError msg ->
eprintf "%a: %s\n" print_position lexbuf msg;
[]
| Parser.Error ->
eprintf "%a: syntax error\n" print_position lexbuf;
[]
exception Rendering_failed of string
let render axs =
let render_node shape name label = sprintf "\"%s\" [shape=%s,label=%s]" name shape label in
let render_atgen pfx name label =
let rndrd_coll = sprintf "%s_%s" pfx name in
[ (render_node "ellipse" rndrd_coll label)
; (sprintf "\"%s\" -- \"%s\"" pfx rndrd_coll)
]
in
let render_primary pfx name = render_atgen pfx name (sprintf "<<u>%s</u>>" name) in
let render_attr pfx name = render_atgen pfx name (sprintf "\"%s\"" name) in
let render_tab name t = (
let pfx = sprintf "T%s" name in
(render_node "box" pfx name)
::
(List.append
(List.map (render_primary pfx) t.Ast.tprimkeys)
(List.map (render_attr pfx) t.Ast.tattrs)
|> List.flatten)
) in
let render_rel i r = (
let pfx = sprintf "R%d" i in
let qnos = ref 0 in
let render_relcol rc: string = (
let lbl = match rc.Ast.rccardty with
| Optional | One -> "1"
| N -> (
let oqnos = !qnos in
let x = match oqnos with
| 0 -> "n"
| 1 -> "m"
| 2 -> "o"
| 3 -> "p"
| _ -> raise (Rendering_failed (sprintf "attempted to render %d. n-cardinality" oqnos))
in let () = (qnos := (oqnos + 1)) in
x
)
in
sprintf "\"%s\" -- \"T%s\" [label=\"%s\",len=3.0]" pfx rc.Ast.rctabnam lbl
) in
(render_node "diamond" pfx r.Ast.rname)
::
(List.append
(List.map render_relcol r.Ast.relates)
(List.map (render_attr pfx) r.Ast.rattrs |> List.flatten)
)
) in
(sprintf "graph ER {
layout=neato
%s}" (String.concat "" ((List.append
(Ast.Tables.to_seq axs.Ast.atables |> Seq.map (fun (name, t) -> render_tab name t) |> List.of_seq)
(List.mapi render_rel axs.Ast.arelations)
) |> List.flatten |> List.map (sprintf " %s;\n"))))
let perfile filename () =
let inx = Stdlib.open_in filename in
let lexbuf = Sedlexing.Utf8.from_channel inx in
Sedlexing.set_filename lexbuf filename;
parse_with_error lexbuf |> Ast.build_ast_of_list |> render |> print_endline;
Stdlib.close_in inx
module Arg = Cmdliner.Arg
module Term = Cmdliner.Term
let files = Arg.(non_empty & pos_all file [] & info [] ~docv:"FILE")
let rec main files = match files with
| [] -> ()
| x::xs -> perfile x (); main xs
let () =
let doc = "parse and render" in
(Term.(const main $ files),
Term.info "ermit" ~version:"v0.0.0" ~doc ~exits:Term.default_exits)
|> Term.eval |> Term.exit