Merge pull request #25 from cedretaber/cedretaber/add-u2dl

u2dl コマンドを実装

bin/dune

@@ -0,0 +1,5 @@
+(executable
+ (public_name u2dl)
+ (name u2dl)
+ (modules u2dl)
+ (libraries birds sql))

bin/u2dl.ml

@@ -0,0 +1,45 @@
+open Birds
+
+let check_arguments_count argv =
+  if Array.length argv < 3 then
+    Result.Error "Invalid arguments. Both SQL file name and Datalog file name must be passed."
+  else
+    Result.Ok ()
+
+let open_sql_ast filename =
+  let chan = open_in filename in
+  let lexbuf = Lexing.from_channel chan in
+  let ast = Sql.Parser.update Sql.Lexer.token lexbuf in
+  Result.Ok ast
+
+let open_view_ast filename =
+  let filename = filename in
+  let chan = open_in filename in
+  let lexbuf = Lexing.from_channel chan in
+  let ast = Parser.main Lexer.token lexbuf in
+  Result.Ok ast
+
+let extract_schema expr =
+  match expr.Expr.view with
+  | Some (_, cols) -> Result.Ok (List.map fst cols)
+  | None -> Result.Error "Invalid schema file. A view definition must be."
+
+let convert_to_dl sql cols =
+  match Sql2ast.update_to_datalog sql cols with
+  | Result.Ok _ as succ -> succ
+  | Result.Error err -> Result.Error (Sql2ast.string_of_error err)
+
+let main =
+  let open Utils.ResultMonad in
+  check_arguments_count Sys.argv >>= fun _ ->
+  open_sql_ast Sys.argv.(1) >>= fun sql ->
+  open_view_ast Sys.argv.(2) >>= fun expr ->
+  extract_schema expr >>= fun cols ->
+  convert_to_dl sql cols >>= fun rules ->
+  return @@ print_endline @@ Expr.to_string Expr.{ expr with rules }
+
+let _ =
+  match main with
+  | Result.Ok _ -> ()
+  | Result.Error err -> print_endline err
+

examples/schema.dl

@@ -0,0 +1 @@
+view ced('EMP_NAME':string, 'DEPT_NAME':string).

examples/sql_sample.dl

@@ -0,0 +1 @@
+view ced('EMP_NAME':string, 'DEPT_NAME':string).

examples/sql_sample.sql

@@ -0,0 +1,7 @@
+UPDATE
+  ced
+SET
+  DEPT_NAME = 'R&D'
+WHERE
+  DEPT_NAME = 'Dev'
+;

src/dune

@@ -5,7 +5,7 @@
 
 (library
  (name birds)
- (libraries logic ocamlgraph num str))
+ (libraries logic sql ocamlgraph num str))
 
 (env
  (dev

src/sql/ast.ml

@@ -0,0 +1,113 @@
+
+type binary_operator =
+  | Plus    (* + *)
+  | Minus   (* - *)
+  | Times   (* * *)
+  | Divides (* / *)
+  | Lor     (* || *)
+
+type unary_operator =
+  | Negate (* - *)
+
+type operator =
+  | RelEqual
+  | RelNotEqual
+  | RelGeneral of string
+
+type table_name = string
+
+type column_name = string
+
+type instance_name = string
+
+type column = instance_name option * column_name
+
+type const =
+  | Int of int
+  | Real of float
+  | String of string
+  | Bool of bool 
+  | Null
+
+type vterm =
+  | Const    of const
+  | Column   of column
+  | UnaryOp  of unary_operator * vterm
+  | BinaryOp of binary_operator * vterm * vterm
+
+type sql_constraint =
+  | Constraint of vterm * operator * vterm
+
+type where_clause =
+  | Where of sql_constraint list
+
+type update =
+  | UpdateSet of table_name * (column * vterm) list * where_clause option
+
+let string_of_binary_operator = function
+  | Plus    -> "+"
+  | Minus   -> "-"
+  | Times   -> "*"
+  | Divides -> "/"
+  | Lor     -> "||"
+
+let string_of_unary_operator = function
+  | Negate -> "-"
+
+let string_of_operator = function
+  | RelEqual      -> "="
+  | RelNotEqual   -> "<>"
+  | RelGeneral op -> op
+
+let string_of_column (instance_name, column) =
+  match instance_name with
+  | Some instance_name -> Printf.sprintf "%s.%s" instance_name column
+  | None -> column
+
+let string_of_column_ignore_instance (_, column) = column
+
+let string_of_const = function
+  | Int i -> string_of_int i
+  | Real f -> string_of_float f
+  | String s -> s
+  | Bool b -> string_of_bool b
+  | Null -> "NULL"
+
+let rec string_of_vterm = function
+  | Const c -> string_of_const c
+  | Column c -> string_of_column c
+  | UnaryOp (op, e) -> string_of_unary_operator op ^ string_of_vterm e
+  | BinaryOp (op, left, right) ->
+      Printf.sprintf "%s %s %s"
+        (string_of_vterm left)
+        (string_of_binary_operator op)
+        (string_of_vterm right)
+
+let string_of_constraint = function
+  | Constraint (left, op, right) ->
+      Printf.sprintf "%s %s %s"
+        (string_of_vterm left)
+        (string_of_operator op)
+        (string_of_vterm right)
+
+let to_string = function
+  | UpdateSet (table_name, sets, where) ->
+    let string_of_set (col, vterm) =
+      Printf.sprintf "  %s = %s" (string_of_column col) (string_of_vterm vterm)
+    in
+    "UPDATE\n" ^
+    "  " ^ table_name ^ "\n" ^
+    "SET\n" ^ (
+      sets
+      |> List.map string_of_set
+      |> String.concat "\n"
+    ) ^
+    match where with
+    | None -> ""
+    | Some (Where cs) ->
+      "\nWHERE\n" ^ (
+        cs
+        |> List.map (fun c -> "  " ^ string_of_constraint c)
+        |> String.concat "\n"
+      )
+    ^ "\n;"

src/sql/dune

@@ -0,0 +1,7 @@
+(menhir
+  (modules parser))
+
+(ocamllex lexer)
+
+(library
+  (name sql))

src/sql/lexer.mll

@@ -0,0 +1,59 @@
+{
+    open Parser;;
+    open Lexing;;
+
+    let spec_error msg start finish =
+      Printf.sprintf
+        "File \"%s\", line %d, characters %d-%d: '%s'"
+        start.pos_fname
+        start.pos_lnum
+        (start.pos_cnum - start.pos_bol)
+        (finish.pos_cnum - finish.pos_bol)
+        msg
+
+    exception LexErr of string
+    let spec_lex_error lexbuf =
+      raise (LexErr (spec_error (lexeme lexbuf) (lexeme_start_p lexbuf) (lexeme_end_p lexbuf)))
+
+    let keywords = [
+        "update", UPDATE;
+        "UPDATE", UPDATE;
+        "where", WHERE;
+        "WHERE", WHERE;
+        "set", SET;
+        "SET", SET;
+        "and", AND;
+        "AND", AND;
+    ]
+}
+let digit = ['0'-'9']
+let alpha = ['a'-'z' 'A'-'Z']
+let ident = (alpha) (alpha | digit | '_' )*
+let wsp = [' ' '\r' '\t']
+
+rule token = parse
+  | wsp { token lexbuf }
+  | '\n' | ';' { Lexing.new_line lexbuf; token lexbuf }
+  | "--" (wsp | alpha | digit) ('\n' | eof) { Lexing.new_line lexbuf; token lexbuf }
+  | digit+ as lxm { INTEGER (int_of_string lxm) }
+  | digit* '.'? digit+ (['e' 'E'] ['-' '+']? digit+)? as lxm { FLOAT (float_of_string (lxm)) }
+  | '\'' (('\'' '\'') | [^'\n''\''])* '\'' as lxm { TEXT lxm }
+  | ident as lxm {
+    match List.assoc_opt lxm keywords with
+    | Some t -> t
+    | None -> IDENT lxm
+  }
+  | '(' { LPAREN }
+  | ')' { RPAREN }
+  | ',' { COMMA }
+  | '.' { DOT }
+  | "NULL" | "null" { NULL }
+  | '=' { EQUAL }
+  | '*' { ASTERISK }
+  | "||" { CONCAT_OP }
+  | '/' { NUM_DIV_OP }
+  | "!=" | "<>" { NUM_NEQ_OP }
+  | '+' { PLUS }
+  | '-' { MINUS }
+  | eof { EOF }
+  | _ { spec_lex_error lexbuf }

src/sql/parser.mly

@@ -0,0 +1,79 @@
+%token <int> INTEGER
+%token <string> IDENT TEXT
+%token <float> FLOAT
+%token LPAREN RPAREN COMMA EOF DOT NULL
+%token UPDATE WHERE EQUAL ASTERISK SET AND CONCAT_OP
+%token NUM_DIV_OP NUM_NEQ_OP PLUS MINUS
+
+%left CONCAT_OP
+%left AND
+%nonassoc EQUAL NUM_NEQ_OP
+%left PLUS MINUS
+%left ASTERISK NUM_DIV_OP
+%nonassoc UNARY_MINUS
+
+%start <Ast.update> update
+
+%%
+
+  update:
+  | update_stmt EOF { $1 }
+  ;
+
+  update_stmt:
+  | UPDATE table=IDENT SET ss=commas(set_column) w=where? { Ast.UpdateSet (table, ss, w) }
+  ;
+
+  set_column:
+  | c=column EQUAL e=vterm { c, e }
+  ;
+
+  vterm:
+  | const { Ast.Const $1 }
+  | column { Ast.Column $1 }
+  | unary_op { $1 }
+  | left=vterm op=binary_op right=vterm { Ast.BinaryOp (op, left, right) }
+  | LPAREN e=vterm RPAREN { e }
+  ;
+
+
+  const:
+  | INTEGER { Ast.Int $1 }
+  | FLOAT { Ast.Real $1 }
+  | TEXT { Ast.String $1 }
+  | NULL { Ast.Null }
+  ;
+
+  column:
+  | table=IDENT DOT cname=IDENT { (Some table), cname }
+  | cname=IDENT { None, cname }
+  ;
+
+  unary_op:
+  | MINUS e=vterm %prec UNARY_MINUS { Ast.UnaryOp (Ast.Negate, e) }
+  ;
+
+  binary_op:
+  | PLUS { Ast.Plus }
+  | MINUS { Ast.Minus }
+  | ASTERISK { Ast.Times }
+  | NUM_DIV_OP { Ast.Divides }
+  | CONCAT_OP { Ast.Lor }
+  ;
+
+  where:
+  | WHERE cs=ands(sql_constraint) { Ast.Where cs }
+  ;
+
+  sql_constraint:
+  | left=vterm op=operator right=vterm { Ast.Constraint (left, op, right) }
+  ;
+
+  operator:
+  | EQUAL { Ast.RelEqual }
+  | NUM_NEQ_OP { Ast.RelNotEqual }
+  | op=IDENT { Ast.RelGeneral op }
+  ;
+
+%inline commas(X): l=separated_nonempty_list(COMMA, X) { l }
+%inline ands(X): l=separated_nonempty_list(AND, X) { l }