Commits

Sébastien Ferré committed 105b040

Saving the store as a .db file (memory dump) and .ttl file.

Comments (0)

Files changed (5)

       Hashtbl.add views v (new state_view ext_colors v)
   end
 
-class history =
+let get_store filepath =
+  try Lisql.load_store filepath
+  with _ ->
+    if question "The database is missing or deprecated. Do you want to load from the logfile ?"
+    then Lisql.create_store filepath
+    else failwith "The logfile could not be read."
+
+class history filepath0 =
   object (self)
-    val mutable store : Lisql.store = new Lisql.store !log_file
+    val mutable filepath = filepath0
+    val mutable store : Lisql.store = get_store filepath0
     val st_backward : state Stack.t = Stack.create ()
     val st_forward : state Stack.t = Stack.create ()
 
+    method filepath = filepath
+
     method store = store
 
     method root : Lisql.focus = Lisql.focus_top
 
     method current = Stack.top st_backward
 
-    method init_store filepath =
-      store <- new Lisql.store filepath;
+    method init_store filepath0 =
+      try
+	filepath <- filepath0;
+	store <- get_store filepath0;
+	self#init
+      with exn ->
+	error_message ("The store could not be loaded: " ^ Printexc.to_string exn)
+	      
+    method save_store =
+      try
+	store#save
+      with exn ->
+	error_message ("The store could not be saved :" ^ Printexc.to_string exn)
+
+    method init =
+      store#add_prefix Logui.prefix Logui.namespace;
       Stack.clear st_backward;
       Stack.clear st_forward;
       Stack.push (new state self#store self#home) st_backward
 	Stack.push s st_backward
       end
 
-    initializer
-      store#add_prefix Logui.prefix Logui.namespace;
-      Stack.push (new state self#store self#home) st_backward
   end
 
-let history = new history
-
+let history =
+  let h = new history !log_file in
+  h#init;
+  h
 
 let preview_of_uri ~obs uri =
   Lisql.print_to_string (history#store#preview_uri ~obs) uri
 let file_menu_factory = new GMenu.factory file_menu
 let cmd_new = file_menu_factory#add_item "New..."
 let cmd_open = file_menu_factory#add_item "Open..."
+let cmd_save = file_menu_factory#add_item ~key:_s "Save"
 (*
-   let cmd_save = file_menu_factory#add_item ~key:_s "Save"
    let cmd_saveas = file_menu_factory#add_item "Save as..."
    let cmd_close = file_menu_factory#add_item "Close"
  *)
       refresh true)
     ()
 
-(*
-   let menu_saveas () =
-   file_dialog ~title:"Save a LIS context" ~filter:filter_lis ~filename:!last_dir
-   ~callback:(fun name ->
-   if confirm_overwrite name then begin
-   history#save_store_as name;
-   history#load_store name;
-   window#set_title (utf (title ()))
-   end) ()
-
-   let menu_save () =
-   match history#store#filename with
-   | None -> menu_saveas ()
-   | Some f -> history#save_store
-
-   let menu_close () =
-   history#init_store None;
-   window#set_title (utf (title ()));
-   refresh true
- *)
+let menu_save () =
+  history#save_store;
+  history#store#export_rdf
+    ~src:!current_src
+    ~base:history#store#base
+    ~xmlns:history#store#xmlns
+    (history#filepath ^ ".ttl")
+
 
 let menu_define_label uri_label default_lang uri () =
   fields_dialog ~title:"Define a new label"
  *)
 
 let menu_quit () =
-  if question "Do you really want to quit?"
-  then begin
-    GMain.quit ();
-    Printf.printf "Profiling...\n";
-    let l =
-      Hashtbl.fold
-	(fun s elem res -> (elem.Common.prof_time, elem.Common.prof_nb, elem.Common.prof_mem,s)::res)
-	Common.tbl_prof [] in
-    let l = List.sort Pervasives.compare l in
-    List.iter
-      (fun (t,n,m,s) -> Printf.printf "%s: %d calls, %.1f seconds\n" s n t)
-      l
-  end
+  if question "Do you want to save the current store before exiting ?" then
+    menu_save ();
+  GMain.quit ();
+  Printf.printf "Profiling...\n";
+  let l =
+    Hashtbl.fold
+      (fun s elem res -> (elem.Common.prof_time, elem.Common.prof_nb, elem.Common.prof_mem,s)::res)
+      Common.tbl_prof [] in
+  let l = List.sort Pervasives.compare l in
+  List.iter
+    (fun (t,n,m,s) -> Printf.printf "%s: %d calls, %.1f seconds\n" s n t)
+    l
 
 let menu_cd ?msg = function
   | Some foc ->
 
   cmd_new#connect#activate ~callback:menu_new;
   cmd_open#connect#activate ~callback:menu_open;
+  cmd_save#connect#activate ~callback:menu_save;
 (*
    cmd_save#connect#activate ~callback:menu_save;
    cmd_save#add_accelerator ~group:accel_group ~modi:[`CONTROL] _s;
 
     method log = log
 
+        (* db file *)
+
+    method save =
+      let filename = filepath ^ ".db" in
+      let ch = open_out_bin filename in
+      Marshal.to_channel ch self [Marshal.Closures];
+      close_out ch
+
 	(* base and xmlns *)
 
     val mutable base : Uri.t = Name.uri_of_file (Filename.concat (Filename.dirname filepath) "")
 
     method place (foc : focus) = new place self foc
 
-    initializer
+    method init =
+      super#init;
       (* base knowledge *)
       List.iter
 	(fun (s,p,o) -> self#add_triple ~src:self#name (Rdf.URI s) p (Rdf.URI o))
       self#pagerank_iterations 5
 
   end
+
+let create_store log_file =
+  let store = new store log_file in
+  store#init;
+  store
+
+let load_store db_file =
+  let filename = db_file ^ ".db" in
+  let ch = open_in_bin filename in
+  let store = (Marshal.from_channel ch : store) in
+  close_in ch;
+  store
   let filename = base ^ ".log" in
   let dirname = base ^ "-files" in
   object (self)
-    val ch_log = open_out_gen [Open_creat; Open_wronly; Open_append; Open_text] 0o660 filename
+(*    val ch_log = open_out_gen [Open_creat; Open_wronly; Open_append; Open_text] 0o660 filename *) (* cannot be marshaled *)
     val mutable silent = false
 
     method filename = filename
 
     method append (line : string) =
       if not silent then begin
+	let ch_log = open_out_gen [Open_creat; Open_wronly; Open_append; Open_text] 0o660 filename in
 	output_string ch_log line;
 	output_string ch_log "\n";
-	flush ch_log
+	flush ch_log;
+	close_out ch_log
       end
 
     method fold : 'a. ('a -> string -> 'a) -> 'a -> 'a =
 
     initializer
       if not (Sys.file_exists dirname) then
-	Unix.mkdir dirname 0o751;
-      at_exit (fun () -> flush ch_log; close_out ch_log)
+	Unix.mkdir dirname 0o751
+(*      at_exit (fun () -> flush ch_log; close_out ch_log) *)
   end
 
 	  done
 
 
-	initializer
+	method init =
 	  
 print_endline "Creating core properties and classes...";
 	  let res = self#rdfs_Resource in
 
 term:Functor
 	rdfs:label "functor" ;
-	rdfs:comment "The class of all term functors, which are types of terms." ;
-	rdfs:subClassOf rdfs:Class .
+	rdfs:comment "The class of all term functors, which are subclasses of terms." ;
+	rdfs:subClassOf rdfs:Term .
 
 term:functor
 	rdfs:label "functor" ;
 	rdfs:domain term:implicitFunctor ;
 	rdfs:range rdf:Seq . # a sequence of properties, given in the same order as arguments
 
+term:Cons
+	rdfs:label "cons" ;
+	rdfs:comment "The implicit functor for RDF lists." ;
+	a term:ImplicitFunctor ;
+	term:implicitClass rdf:List ;
+	term:implicitProperties [ a rdf:Seq ; rdf:_1 rdf:first ; rdf:_2 rdf:rest ] ;
+	term:arity 2 .
+	
 
 # example: functor :some for existential restrictions in OWL
 #
 # :some
 #	a term:ImplicitFunctor ;
-#	term:implicitType owl:Restriction ;
+#	term:implicitClass owl:Restriction ;
 #	term:implicitProperties [ a rdf:Seq ; rdf:_1 owl:onProperty; rdf:_2 owl:someValuesFrom ] ;
 #	a term:RightAssociativeInfixOperator ;
 #	rdfs:label "some" ;