Skip to content

GitLab

A
ACGtk
Commit db752686 authored by POGODALLA Sylvain's avatar POGODALLA Sylvain
Browse files
Options

It now compiles. Testing starts...

parent b992620a
Hide whitespace changes
Inline Side-by-side
Showing with 194 additions and 48 deletions
src/scripting/acg.ml
View file @ db752686
......@@ -31,9 +31,9 @@ let svg_output = ref (Some "realize.svg")
let dont_exit_on_end_of_file = ref false
module P = Script_parser.Parser
module P = Parse_functions
module F = P.F
module F = Functions
let options =
[
......@@ -101,7 +101,7 @@ let print_welcome_message () =
let anon_fun s =
let () = print_welcome_message () in
let () = resize_terminal () in
env := P.parse_file ?svg_output:!svg_output s !dirs !env
env := snd (P.parse_file ?svg_output:!svg_output s !dirs !env)
let invite () =
......@@ -120,7 +120,7 @@ let main first =
let () = resize_terminal () in
while !continue do
try
let () = env := P.parse_entry ~resize:!pp_output ?svg_output:!svg_output stdin_tmp_in_ch !dirs !env in
let () = env := snd (P.parse_entry ~resize:!pp_output ?svg_output:!svg_output stdin_tmp_in_ch !dirs !env) in
Format.print_flush ()
with
| End_of_file ->
......@@ -148,8 +148,8 @@ let _ =
*)
let () =
try main true with
| P.F.Stop -> ()
| P.F.Quit -> ()
| F.Stop -> ()
| F.Quit -> ()
| Sys.Break -> () in
Logs.app (fun m -> m "Goodbye.")
src/scripting/command_parser.mly
View file @ db752686
%{
open Logic
open AcgData.Environment
let id = fun x -> x
let pr s = Logs.app (fun m -> m "%s" s)
module F=Functions.Functions
let echo ctx:F.context s = if ctx.echo then Logs.app (fun m -> m "%s" s) else ()
let wait ctx:F.context = if F.should_wait ctx then ignore (f () )
let svg ctx:F.context = F.svg ctx
let echo ctx s = if F.echo ctx then Logs.app (fun m -> m "%s" s) else ()
let wait ctx f = if F.should_wait ctx then ignore (f () )
let svg ctx = F.svg ctx
%}
......@@ -33,7 +30,7 @@
%token <(string*Logic.Abstract_syntax.Abstract_syntax.location*string)>SAVE
%start <Functions.Functions.context -> AcgData.Environment.Environment.t -> AcgData.Environment.Environment.t> commands
%start <Functions.Functions.context -> AcgData.Environment.Environment.t -> Functions.Functions.context * AcgData.Environment.Environment.t> commands
%%
......@@ -42,7 +39,7 @@
{
fun ctx e ->
List.fold_left
(fun acc command -> command acc)
(fun (c,e') command -> command c e')
(ctx,e)
commands
}
......@@ -51,8 +48,8 @@
| EXIT l = SEMICOLONN {
fun ctx e ->
let () = echo ctx l in
let () = F.exit in
e}
let () = F.exit () in
ctx,e}
| WAIT l = SEMICOLONN {
fun ctx e ->
......@@ -75,27 +72,28 @@
| DONT WAIT HELP l = SEMICOLONN {
fun ctx e ->
let () = echo ctx l in
let () = F.help (F.Help (Some F.Dont_Wait)) in
let () = F.help (F.Help (Some F.Dont_wait)) in
ctx,e}
| params = LOAD_DATA {
fun ctx e ->
let s,loc,l = params in
let () = echo ctx l in
let e' = F.load F.Data s (F.dirs ctx) e in
ctx,e'}
F.load F.Data s (F.dirs ctx) (ctx,e)
}
| params = LOAD_OBJECT {
fun ctx e ->
let s,loc,l = params in
let () = echo ctx l in
ctx,F.load F.Object s (F.dirs ctx) e}
F.load F.Object s (F.dirs ctx) (ctx,e)}
| params = LOAD_SCRIPT {
fun ctx e ->
let s,loc,l = params in
let () = echo ctx l in
ctx,F.load (F.Script (F.parse_script ctx)) s (F.dirs ctx) e }
let () = echo ctx l in
let parse_script_fn filename dirs (_,env) = (F.parse_script ctx) filename dirs env in
F.load (F.Script parse_script_fn) s (F.dirs ctx) (ctx,e) }
| LIST l = SEMICOLONN {fun ctx e ->
let () = echo ctx l in
......@@ -124,7 +122,7 @@
| UNSELECT l = SEMICOLONN {
fun ctx e ->
let () = echo ctx l in
ctx,F.unselect}
ctx,F.unselect e}
| UNSELECT HELP l = SEMICOLONN {
fun ctx e ->
......@@ -162,7 +160,7 @@
let () =
match name with
| None -> F.print e p
| Some (n,l) -> F.print ~name:n e loc in
| Some (n,l) -> F.print ~name:n e l in
ctx,e}
| IDENTT? PRINT HELP l = SEMICOLONN {
......@@ -259,10 +257,10 @@
| Some (n,l) -> F.idb ~name:n e l in
ctx,e}
| name = IDENTT? p = IDB HELP l = SEMICOLONN {
| IDENTT? IDB HELP l = SEMICOLONN {
fun ctx e ->
let () = echo ctx l in
let () = F.help (F.Help (Some F.IDB)) in
let () = F.help (F.Help (Some F.Idb)) in
ctx,e}
| params = ADD {
......@@ -295,7 +293,7 @@
| HELP HELP l = SEMICOLONN {
fun ctx e ->
let () = echo ctx l in
let () = F.help (F.Help (Some F.Help)) in
let () = F.help (F.Help (Some (F.Help None))) in
ctx,e}
| LOAD_HELP l = SEMICOLONN {
......@@ -367,13 +365,13 @@
fun ctx e ->
let filename,l,line = params in
let () = echo ctx line in
let e' = F.save filename e l in
ctx,e'}
let () = F.save filename e l in
ctx,e}
| names = IDENTT+ params = SAVE {
fun ctx e ->
let filename,l,line = params in
let () = echo ctx line in
let e' = F.save ~names filename e l in
ctx,e'}
let () = F.save ~names filename e l in
ctx,e}
src/scripting/functions.ml
View file @ db752686
......@@ -74,13 +74,13 @@ sig
type file_type =
| Data
| Object
| Script of (string -> string list -> env -> env)
| Script of (string -> string list -> context * env -> context * env)
val color_output : bool -> unit
val set_config : string -> string list -> unit
val load : file_type -> string -> string list -> env -> env
val load : file_type -> string -> string list -> context * env -> context * env
val list : env -> unit
......@@ -111,6 +111,8 @@ sig
string * (Lexing.position * Lexing.position) ->
string * (Lexing.position * Lexing.position) -> env -> env
val context : wait:bool -> echo:bool -> svg:string option -> dirs:string list -> parse_fun:(?verbose:bool -> ?svg_output:string -> string -> string list -> Environment.t -> context * Environment.t) -> context
val wait : context -> context
val dont_wait : context -> context
......@@ -123,7 +125,7 @@ sig
val dirs : context -> string list
val parse_script : context -> (?verbose:bool -> ?svg_output:string option -> string -> string list -> Environment.t -> Environment.t)
val parse_script : context -> (?verbose:bool -> ?svg_output:string -> string -> string list -> Environment.t -> context * Environment.t)
val help : action -> unit
......@@ -153,7 +155,7 @@ struct
echo:bool; (* whether the command should be echoed on the output *)
dirs:string list; (* list of the included dirs *)
svg:string option; (* whether a svg output "file" (if relevant) should be produced *)
parse_function: parse_script : context -> (?verbose:bool -> ?svg_output:string option -> string -> string list -> Environment.t -> Environment.t);
parse_function: ?verbose:bool -> ?svg_output:string -> string -> string list -> Environment.t -> context * Environment.t;
}
......@@ -175,7 +177,7 @@ struct
type file_type =
| Data
| Object
| Script of (string -> string list -> env -> env)
| Script of (string -> string list -> context * env -> context * env)
module Data_parser = Grammars.Parsers
module ShowI = Show.Make(Env)
......@@ -309,19 +311,19 @@ struct
let load t filename dirs e =
let load t filename dirs (ctx,e) =
match t with
| Data ->
(match Data_parser.parse_data ~overwrite:true filename dirs e with
| None -> e
| Some e' -> e')
| None -> ctx,e
| Some e' -> ctx,e')
| Object ->
(let new_env = Env.read filename dirs in
match new_env with
| Some n_e -> Env.append e n_e
| None -> e)
| Script f -> f filename dirs e
| exception Stop -> e
| Some n_e -> ctx,Env.append e n_e
| None -> ctx,e)
| Script f -> f filename dirs (ctx,e)
| exception Stop -> ctx,e
let list e =
......@@ -772,8 +774,17 @@ struct
| Env.Lexicon lex -> Printf.fprintf outch "%s\n\n%!" (Env.Lexicon.to_string lex))
entries in
close_out outch
let context ~wait ~echo ~svg ~dirs ~parse_fun =
{
wait;
echo;
dirs;
svg;
parse_function=parse_fun;
}
let wait ctx = {ctx with wait=true}
let dont_wait ctx = {ctx with wait=false}
......
src/scripting/functions.mli
View file @ db752686
......@@ -58,13 +58,13 @@ sig
type file_type =
| Data
| Object
| Script of (string -> string list -> env -> env)
| Script of (string -> string list -> context * env -> context * env)
val color_output : bool -> unit
val set_config : string -> string list -> unit
val load : file_type -> string -> string list -> env -> env
val load : file_type -> string -> string list -> context * env -> context * env
val list : env -> unit
......@@ -98,6 +98,8 @@ sig
string * (Lexing.position * Lexing.position) ->
string * (Lexing.position * Lexing.position) -> env -> env
val context : wait:bool -> echo:bool -> svg:string option -> dirs:string list -> parse_fun:(?verbose:bool -> ?svg_output:string -> string -> string list -> Environment.t -> context * Environment.t) -> context
val wait : context -> context
val dont_wait : context -> context
......@@ -110,7 +112,7 @@ sig
val dirs : context -> string list
val parse_script : context -> (?verbose:bool -> ?svg_output:string option -> string -> string list -> Environment.t -> Environment.t)
val parse_script : context -> (?verbose:bool -> ?svg_output:string -> string -> string list -> Environment.t -> context * Environment.t)
val help : action -> unit
......
src/scripting/parse_functions.ml 0 → 100644
View file @ db752686
open AcgData.Environment
open Functions
module I = Command_parser.MenhirInterpreter
module Error = AcgData.Error
(* -------------------------------------------------------------------------- *)
(* The above loop is shown for explanatory purposes, but can in fact be
replaced with the following code, which exploits the functions
[lexer_lexbuf_to_supplier] and [loop_handle] offered by Menhir. *)
let succeed (data : (Functions.context -> Environment.t -> Functions.context * Environment.t)) =
(* The parser has succeeded and produced a semantic value. *)
data
let fail lexbuf (c : (Functions.context -> Environment.t -> Functions.context * Environment.t) I.checkpoint) =
(* The parser has suspended itself because of a syntax error. Stop. *)
match c with
| I.HandlingError env ->
let loc = Lexing.lexeme_start_p lexbuf,Lexing.lexeme_end_p lexbuf in
let current_state_num = I.current_state_number env in
raise Error.(Error (Parse_error (Syntax_error ((Messages.message current_state_num)),loc)))
| _ -> failwith "Should not happen. Always fails with a HandlingError"
| exception Not_found ->
let loc = Lexing.lexeme_start_p lexbuf,Lexing.lexeme_end_p lexbuf in
raise Error.(Error (Parse_error (Syntax_error (""),loc)))
let core_supplier lexbuf = I.lexer_lexbuf_to_supplier Script_lexer.lexer lexbuf
(*
let supplier lexbuf =
let sup () =
let (tok,_,_) as res = core_supplier lexbuf () in
let () = Printf.printf "Token: \"%s\"\n%!" (tok_to_string tok) in
res in
sup
*)
let supplier = core_supplier
let rec parse_file ?(verbose=true) ?svg_output filename includes env =
let ctx = Functions.context ~wait:false ~echo:verbose ~dirs:includes ~svg:svg_output ~parse_fun:parse_file in
try
let in_ch =
let fullname = UtilsLib.Utils.find_file filename includes in
open_in fullname in
let lexbuf = Lexing.from_channel in_ch in
let () = Printf.printf "Parsing script file \"%s\"...\n%!" filename in
let ctx',new_env= (I.loop_handle succeed (fail lexbuf) (supplier lexbuf) (Command_parser.Incremental.commands lexbuf.lex_curr_p)) ctx env in
let () = Printf.printf "Done.\n%!" in
ctx',new_env
with
| UtilsLib.Utils.No_file(f,msg) ->
let e = AcgData.Error.System_error (Printf.sprintf "No such file \"%s\" in %s" f msg) in
let () = Printf.fprintf stderr "Error: %s\n%!" (AcgData.Error.error_msg e filename) in
let _ = Script_lexer.reset_echo () in
ctx,env
| Sys_error s ->
let e = AcgData.Error.System_error s in
let () = Printf.fprintf stderr "Error: %s\n%!" (AcgData.Error.error_msg e filename) in
let _ = Script_lexer.reset_echo () in
ctx,env
| AcgData.Error.Error e ->
let () = Printf.fprintf stderr "Error: %s\n%!" (AcgData.Error.error_msg e filename) in
let _ = Script_lexer.reset_echo () in
ctx,env
| Scripting_errors.Error (e,p) ->
let () = Printf.fprintf stderr "Error: %s\n%!" (Scripting_errors.error_msg e p) in
let _ = Script_lexer.reset_echo () in
ctx,env
let commented_regexp = Str.regexp "^[ \t#]*#"
let is_fully_commented_line s = Str.string_match commented_regexp s 0
let read_line_from_in_ch in_ch =
let () = flush stdout in
input_line in_ch
let bufferize in_ch =
let () = Printf.printf "# " in
let buf = Buffer.create 16 in
let no_semi_colon=ref true in
let () =
while !no_semi_colon do
let input = read_line_from_in_ch in_ch in
if not (is_fully_commented_line input) then
try
let semi_colon_index=String.index input ';' in
let () = Buffer.add_string buf (String.sub input 0 (semi_colon_index+1)) in
no_semi_colon:=false
with
| Not_found ->
Buffer.add_string buf input ;
Buffer.add_char buf '\n';
Printf.printf " "
else
()
done in
Buffer.contents buf
let parse_entry ~resize ?svg_output ?(verbose=true) in_ch includes env =
let in_str = bufferize in_ch in
let lexbuf = Lexing.from_string in_str in
let () =
if resize then
let () = UtilsLib.Utils.sterm_set_size () in
UtilsLib.Utils.term_set_size ()
else
() in
let ctx = Functions.context ~wait:false ~echo:verbose ~svg:svg_output ~dirs:includes ~parse_fun:parse_file in
try
(I.loop_handle succeed (fail lexbuf) (supplier lexbuf) (Command_parser.Incremental.commands lexbuf.lex_curr_p)) ctx env
with
| Functions.Stop -> ctx,env
| Failure f when f="lexing: empty token" -> ctx,env
| AcgData.Error.Error e ->
let () = Printf.fprintf stderr "Error: %s\n%!" (AcgData.Error.error_msg e "stdin") in
let _ = Script_lexer.reset_echo () in
ctx,env
| Scripting_errors.Error (e,p) ->
let () = Printf.fprintf stderr "Error: %s\n%!" (Scripting_errors.error_msg e p) in
let _ = Script_lexer.reset_echo () in
ctx,env
src/scripting/parse_functions.mli 0 → 100644
View file @ db752686
open AcgData.Environment
open Functions
val parse_file : ?verbose:bool -> ?svg_output:string -> string -> string list -> Environment.t -> Functions.context * Environment.t
val parse_entry : resize:bool -> ?svg_output:string -> ?verbose:bool -> in_channel -> string list -> Environment.t -> Functions.context * Environment.t
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment