(**************************************************************************)
(*                   Cameleon                                             *)
(*                                                                        *)
(*      Copyright (C) 2002 Institut National de Recherche en Informatique et   *)
(*      en Automatique. All rights reserved.                              *)
(*                                                                        *)
(*      This program is free software; you can redistribute it and/or modify  *)
(*      it under the terms of the GNU General Public License as published by  *)
(*      the Free Software Foundation; either version 2 of the License, or  *)
(*      any later version.                                                *)
(*                                                                        *)
(*      This program is distributed in the hope that it will be useful,   *)
(*      but WITHOUT ANY WARRANTY; without even the implied warranty of    *)
(*      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     *)
(*      GNU General Public License for more details.                      *)
(*                                                                        *)
(*      You should have received a copy of the GNU General Public License  *)
(*      along with this program; if not, write to the Free Software       *)
(*      Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA          *)
(*      02111-1307  USA                                                   *)
(*                                                                        *)
(*      Contact: Maxence.Guesdon@inria.fr                                *)
(**************************************************************************)

(** Main module of the command line translation tool. *)

(** {2 Old structures} *)

module Old = struct
(*[Ty] The type for the user-defined OCaml types.
   The OCaml type can be a user-defined one,
   whose name is given, with two function names, one
   to translate this type to a string and another
   one to translate a string to this type.
   [Ty]*)
type user_type = {
    ut_name : string; (* the name of the type *)
    ut_string_of : string; (* the function string_of_<user_type> name *)
    ut_of_string : string (* the function <user_type>_of_string name *)
  } 

(*[Ty] This type represents the OCaml type used to represent
   a given SQL data_type.[Ty]*)
type ocaml_type =
    Int
  | Float
  | String
  | UserType of user_type
    
(*[Fonc] This function takes a SQL data_type and returns the 
   corresponding default OCaml type.[Fonc]*)
let ocaml_type_from_data_type dt = 
  match dt with
    Ocamlsql_types.Char _
  | Ocamlsql_types.VarChar _ 
  | Ocamlsql_types.NationalChar _ 
  | Ocamlsql_types.NationalVarChar _ ->
      String
  | Ocamlsql_types.Bit _
  | Ocamlsql_types.VarBit _ ->
      Int
  | Ocamlsql_types.Num (Ocamlsql_types.ExactNumType _) ->
      Int
  | Ocamlsql_types.Num (Ocamlsql_types.Approximate_num_type _) ->
      Float
  | Ocamlsql_types.Date
  | Ocamlsql_types.Time _
  | Ocamlsql_types.Timestamp _->
      String
  | Ocamlsql_types.Interval _ ->
      String

(*[Fonc] This function takes a ocaml_type and returns
   the corresponding string.[Fonc]*)
let string_of_ocaml_type ot =
  match ot with
    Int -> "int"
  | Float -> "float"
  | String -> "string"
  | UserType ut -> ut.ut_name

(*[Fonc] This function takes a SQL column_type and returns the 
   corresponding default OCaml type.[Fonc]*)
let ocaml_type_from_column_type ct = 
  match ct with
    Ocamlsql_types.Data_type data_type ->
      ocaml_type_from_data_type data_type
  | Ocamlsql_types.Domain domain_name ->
      (* A VOIR : how to treat domain names ? *)
      raise (Failure "ocaml_type_from_column_type not implemented for domain names")

class column
    (f_change : unit -> unit)
    ?(name="unnamed")
    ?(comment="")
    ?(definition="")
    ?(user_type=(None : user_type option))
    () =
  object (self)
    (*[At] The name of the table.[At]*)
    val mutable name = name
    (*[Me] Access to the name.[Me]*)
    method name = name
    (*[Me] Access to the name in lower case.[Me]*)
    method lower_name = String.lowercase name
    (*[Me] Setting the name.[Me]*)
    method set_name n = 
      name <-  n ;
      f_change ()

    (*[At] The comment of the table.[At]*)
    val mutable comment = comment
    (*[Me] Access to the comment.[Me]*)
    method comment = comment
    (*[Me] Setting the comment.[Me]*)
    method set_comment c = 
      comment <- c ;
      f_change ()

    (*[At] The definition of the table.[At]*)
    val mutable definition = definition
    (*[Me] Access to the definition.[Me]*)
    method definition = definition
    (*[Me] Setting the definition.[Me]*)
    method set_definition d = 
      definition <- d ;
      f_change ()

    (*[At] The OCaml user type for the column, if specified. [At]*)
    val mutable user_type = user_type
    (*[Me] Setting the user_type. [Me]*)
    method set_user_type t_opt =
      user_type <- t_opt ;
      f_change ()
    (*[Me] Access to the user_type. [Me]*)
    method user_type = user_type
    (*[Me] Access to the column type. If a user type is given,
       then it's returned in a UserType constructor.
       If not, an OCaml type is returned according to the column
       definition (parse of the definition).
       If an error occurs during the parse of the definition,
       the type string is assumed.[Me]*)
    method column_type =
      match user_type with
	None ->
	  (
	   (* we parse the definition to get the default OCaml type *)
	   try
	     ocaml_type_from_column_type
	       (Ocamlsql.parse_column_def ("dummyname "^self#definition)).Ocamlsql_types.col_type
	   with
	     Failure s ->
	       (*DEBUG*)print_string ("method column#column_type : "^s);
	       (*DEBUG*)print_newline ();
	       String
	  )
      |	Some ut ->
	  UserType ut
  end

class table
    (f_change : unit -> unit)
    ?(name="unnamed")
    ?(comment="")
    ?(columns=([] : column list))
    () =
  object (self)
    (*[At] The name of the table.[At]*)
    val mutable name = name
    (*[Me] Access to the name.[Me]*)
    method name = name
    (*[Me] Setting the name.[Me]*)
    method set_name n =
      name <- n ;
      f_change ()

    (*[At] The comment of the table.[At]*)
    val mutable comment = comment
    (*[Me] Access to the comment.[Me]*)
    method comment = comment
    (*[Me] Setting the comment.[Me]*)
    method set_comment c = 
      comment <- c ;
      f_change ()

    (*[At] The columns of the table.[At]*)
    val mutable columns = columns
    (*[Me] Access to the columns.[Me]*)
    method columns = columns
    (*[Me] Setting the columns. Raises Failure if an error occurs 
       for a column, but add the other columns.[Me]*)
    method set_columns l = 
      columns <- [] ;
      f_change () ;
      let rec f err l =
	match l with
	  [] ->
	    err
	| c :: q ->
	    let err_opt = 
	      try 
		self#add_column c;
		err
	      with
		Failure s ->
		  match err with
		    None -> Some s
		  | Some s2 -> Some (s2^"\n"^s)
	    in
	    f err_opt q
      in
      match f None l with
	None ->
	  (* no error *)
	  ()
      |	Some mes ->
	  raise (Failure mes)

    (*[Me] Adding a column. [Me]*)
    method add_column c =
      try
	self#column_by_name c#name;
	raise (Failure (Dbf_messages.column_exists c#name))
      with
	Not_found ->
	  columns <- c :: columns ;
	  f_change ()

    (*[Me] Deleting a column. [Me]*)
    method del_column c = 
      columns <- List.filter (fun c2 -> c2 <> c) columns ;
      f_change ()

    (*[Me] Sorting the columns. [Me]*)
    method sort_columns = 
      columns <- Sort.list (fun c1 -> fun c2 -> c1#name < c2#name) columns
    (*[Me] Retrieving a column by its name.
       Raises Not_found if no column matches the given name.[Me]*)
    method column_by_name n =
      (* we must compare the correct names (=normalized names) *)
      let correct_name =  n in
      List.find (fun t -> t#name = correct_name) columns

  end

class schema
    ?(name="unnamed")
    ?(comment="")
    ?(tables=([] : table list))
    () =
  object (self)
    (* The function to call when the schema is modified. *)
    val mutable f_change = fun () -> ()
    (* Call the f_change function. *)
    method f_change () = f_change ()
    (* To set the f_change function. *)
    method set_f_change f = f_change <- f

    (*[At] The name of the schema.[At]*)
    val mutable name = name
    (*[Me] Access to the name.[Me]*)
    method name = name
    (*[Me] Setting the name.[Me]*)
    method set_name n = 
      f_change () ;
      name <- n

    (*[At] The comment of the schema.[At]*)
    val mutable comment = comment
    (*[Me] Access to the comment.[Me]*)
    method comment = comment
    (*[Me] Setting the comment.[Me]*)
    method set_comment c = 
      f_change () ;
      comment <- c

    (*[At] The tables of the schema.[At]*)
    val mutable tables = tables
    (*[Me] Access to the tables.[Me]*)
    method tables = tables
    (*[Me] Setting the tables. Raises Failure if an error occurs 
       for a table, but add the other tables.[Me]*)
    method set_tables l = 
      f_change () ;
      tables <- [];
      let rec f err l =
	match l with
	  [] ->
	    err
	| t :: q ->
	    let err_opt = 
	      try 
		self#add_table t;
		err
	      with
		Failure s ->
		  match err with
		    None -> Some s
		  | Some s2 -> Some (s2^"\n"^s)
	    in
	    f err_opt q
      in
      match f None l with
	None ->
	  (* no error *)
	  ()
      |	Some mes ->
	  raise (Failure mes)

    (*[Me] Adding a table. Raises Failure if a table with the same (normalized) name exists.[Me]*)
    method add_table t = 
      try
	self#table_by_name t#name;
	raise (Failure (Dbf_messages.table_exists t#name))
      with
	Not_found ->
	  tables <- t :: tables ;
	  f_change ()

    (*[Me] Deleting a table. [Me]*)
    method del_table t = 
      tables <- List.filter (fun t2 -> t2 <> t) tables ;
      f_change ()

    (*[Me] Sorting the tables. [Me]*)
    method sort_tables = 
      tables <- Sort.list (fun t1 -> fun t2 -> t1#name < t2#name) tables
    (*[Me] Retrieving a table by its name.
       Raises Not_found if no table matches the given name.[Me]*)
    method table_by_name n =
      (* we must compare the correct names (=normalized names) *)
      let correct_name =  n in
      List.find (fun t -> t#name = correct_name) tables
  end



(*[Mo] This module contains the functor used to create 
   read and write modules for "xml" documents. [Mo]*)
module Dbforge_documentIO = Dbft_documentIO


module Dbforge_marks = struct

(*[Mo] This module contains the various marks used in the description languages.[Mo]*)

  let name = "NAME"
  let comment = "COMMENT"
  let schema = "SCHEMA"
  let table = "TABLE"
  let column ="COLUMN"
  let definition = "DEF"
  let typ = "TYPE"
  let string_of = "STRING_OF"
  let of_string = "OF_STRING"

end


module Dbforge_schemaIO = struct
(*[Mo] This module contains the module SchemaIO used
   to read and write a database schema from and to disk.[Mo]*)

module M = Dbforge_marks
module IO = Dbforge_documentIO

(*[Mo] This module contains the functions used to convert 
   a schema object from and to an item (Dbforge_documentIO.item).[Mo]*)
module SchemaConverter =
   struct
   type t = schema
   let t_of_item item = 
     let rec iter ?schema ?table ?column = function
	 IO.Simple_item (mark, v) when mark = M.name ->
	   let _ = 
	     (* we look for the deepest current objet *)
	     match (schema, table, column) with
	       (None, None, None) ->
	         (* nothing to set the name to *)
		 ()
	     | (_, _, Some col) ->
		 col#set_name v
	     | (_, Some tab, _) ->
		 tab#set_name v
	     | (Some sch, _, _) ->
		 sch#set_name v
	   in
	   (* we did not create a schema *)
	   None
       | IO.Simple_item (mark, v) when mark = M.comment ->
	   let _ = 
	     (* we look for the deepest current objet *)
	     match (schema, table, column) with
	       (None, None, None) ->
	         (* nothing to set the comment to *)
		 ()
	     | (_, _, Some col) ->
		 col#set_comment v
	     | (_, Some tab, _) ->
		 tab#set_comment v
	     | (Some sch, _, _) ->
		 sch#set_comment v
	   in
	   (* we did not create a schema *)
	   None

       | IO.Simple_item (mark, v) when mark = M.definition ->
	   let _ = 
	     (* we look for the deepest current objet *)
	     match (schema, table, column) with
	       (None, None, None) ->
	         (* nothing to set the comment to *)
		 ()
	     | (_, _, Some col) ->
		 col#set_definition v
	     | (_, Some tab, _) ->
		 (* nothing to do *)
		 ()
	     | (Some sch, _, _) ->
		 (* nothing to do *)
		 ()
	   in
	   (* we did not create a schema *)
	   None

       | IO.Simple_item (mark, v) when 
	   mark = M.typ or mark = M.string_of or mark = M.of_string ->
	   let _ = 
	     (* we look if we have a column *)
	     match (schema, table, column) with
	     | (_, _, Some col) ->
		 (
		  match col#user_type with
		    Some ut ->
		      col#set_user_type
			(Some 
			   (
			    if mark = M.typ then
			      {ut with ut_name = v}
			    else if mark = M.string_of then
			      {ut with ut_string_of = v}
			    else if mark = M.of_string then
			      {ut with ut_of_string = v}
			    else
			      ut
			   )
			)
		  | None ->
		      col#set_user_type
			(Some
			   (
			    if mark = M.typ then
			      { ut_name = v ;
				ut_string_of = "" ;
				ut_of_string = ""
			      }
			    else if mark = M.string_of then
			      { ut_name = "" ;
				ut_string_of = v ;
				ut_of_string = ""
			      }
			    else 
			      { ut_name = "" ;
				ut_string_of = "" ;
				ut_of_string = v
			      }
			   )
			)
		 )
	     | _ ->
		 (* nothing to do *)
		 ()
	   in
	   (* we did not create a schema *)
	   None

       | IO.Subitems (mark, l) when mark = M.schema ->
	   let new_schema = new schema () in
	   let _ = List.map (fun i -> iter ~schema: new_schema i) l in
	   Some new_schema

       | IO.Subitems (mark, l) when mark = M.table ->
	   let _ = 
	     match (schema, table, column) with
	       (Some sch, None, None) ->
	         (* we create and add the table to the schema *)
		 let new_table = new table sch#f_change () in
		 sch#add_table new_table;
	         (* then we continue with the info of the table *)
		 let _ = List.map (fun i -> iter ~schema: sch ~table: new_table i) l in
		 ()
	     | _ ->
	         (* we can't add the table to anything !
		    we don't create it and do nothing *)
		 ()
	   in
	   (* we did not create a schema here *)
	   None

       | IO.Subitems (mark, l) when mark = M.column ->
	   let _ = 
	     match (schema, table, column) with
	       (Some sch, Some tab, None) ->
	         (* we create and add the column to the table *)
		 let new_column = new column sch#f_change () in
		 tab#add_column new_column;
	         (* then we continue with the info of the column *)
		 let _ = List.map (fun i -> iter ~schema: sch ~table: tab ~column: new_column i) l in
		 ()
	     | _ ->
	         (* we can't add the column to anything !
		    we don't create it and do nothing *)
		 ()
	   in
	   (* we did not create a schema here *)
	   None
       | _ ->
	   None
     in
     match iter item with
       None ->
	 (* there is no schema in the item structure *)
	 raise (Failure ("no schema"))
     | Some schema ->
	 schema

   (*[Fonc] This function takes a schema object and return the
      corresponding item structure.[Fonc]*)
   let item_of_t schema = 
     let item_of_column column =
       IO.Subitems (M.column,
		    [
		      IO.Simple_item (M.name, column#name) ;
		      IO.Simple_item (M.comment, column#comment) ;
		      IO.Simple_item (M.definition, column#definition)
		    ] @
		    (
		     match column#column_type with
		       UserType ut ->
			 [
			   IO.Simple_item (M.typ, ut.ut_name) ;
			   IO.Simple_item (M.of_string, ut.ut_of_string) ;
			   IO.Simple_item (M.string_of, ut.ut_string_of)
			 ] 
		     | Int | Float | String ->
			 []
		    )
		   )
     in
     let item_of_table table =
       IO.Subitems (M.table,
		    [
		      IO.Simple_item (M.name, table#name) ;
		      IO.Simple_item (M.comment, table#comment)
		    ] @ (List.map item_of_column table#columns)
		   )
     in
     IO.Subitems (M.schema,
		  [
		    IO.Simple_item (M.name, schema#name) ;
		    IO.Simple_item (M.comment, schema#comment)
		  ] @ (List.map item_of_table schema#tables)
		 )
   end

(*[Mo] The module used to read and write schema objects.Mo]*)
module SchemaIO = Dbforge_documentIO.DocumentIO(Dbft_lexer.Parser)(SchemaConverter)

end

end
 (* end of old structures *)

let file = 
  try Sys.argv.(1) 
  with _ ->
    prerr_endline (Printf.sprintf "usage: %s <old dbforge file>" Sys.argv.(0));
    exit 1;;

let s = Old.Dbforge_schemaIO.SchemaIO.read_file file 

open Dbf_types
open Old

let trans_column c =
  { col_name = c#name ;
    col_comment = c#comment ;
    col_type_ml = 
      (match c#column_type with
	UserType ut -> ut.ut_name
      |	String -> "string"
      |	Int -> "int"
      |	Float -> "float"
      ) ;
    col_nullable = 
      (try 
	ignore (Str.search_forward
		  (Str.regexp_string "notnull")
		  (Dbf_misc.remove_blanks (String.lowercase c#definition))
		  0);
	false
      with 
	Not_found -> true
      );
    col_index =
      (try 
	ignore (Str.search_forward
		  (Str.regexp_string "unique")
		  (Dbf_misc.remove_blanks (String.lowercase c#definition))
		  0);
	true
      with 
	Not_found ->
	  (try 
	    ignore (Str.search_forward
		      (Str.regexp_string "primarykey")
		      (Dbf_misc.remove_blanks (String.lowercase c#definition))
		      0);
	    true
	  with 
	    Not_found -> false
	  )
      );
    col_dbms = [
      Odbc, { 
              col_type_sql = ("other", Some c#definition, None) ;
	      col_2ml = 
	        (match c#column_type with
		  UserType ut -> ut.ut_of_string
		| String -> "string_of_sqlstring"
		| Int -> "int_of_string"
		| Float -> "float_of_string"
		) ;
	      col_ml2 = 
	        (match c#column_type with
		  UserType ut -> ut.ut_string_of
		| String -> "sqlstring_of_string"
		| Int -> "string_of_int"
		| Float -> "string_of_float"
		) ;
	      col_key = None ;
	      col_default = None ;
	      col_atts = []
	    } 
  ] 
  } 

let trans_table t =
  { ta_name = t#name ;
    ta_comment = t#comment ;
    ta_columns = List.map trans_column t#columns ;
    ta_atts = [] ;
    ta_indexes = []
  } 

let trans_schema s =
  let s = {
    sch_tables = List.map trans_table s#tables
  } 
  in
  s
  
let schema = trans_schema s ;;

let fmt = Format.std_formatter;;


Format.pp_open_box fmt 0;;
Dbf_types.xprint_schema fmt schema;;
Format.pp_close_box fmt ();;
Format.pp_print_flush fmt ();;
