Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
A
ACGtk
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
7
Issues
7
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
Operations
Operations
Incidents
Packages & Registries
Packages & Registries
Container Registry
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
ACG
dev
ACGtk
Commits
db752686
Commit
db752686
authored
Oct 01, 2018
by
POGODALLA Sylvain
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
It now compiles. Testing starts...
parent
b992620a
Changes
6
Hide whitespace changes
Inline
Side-by-side
Showing
6 changed files
with
194 additions
and
48 deletions
+194
-48
src/scripting/acg.ml
src/scripting/acg.ml
+6
-6
src/scripting/command_parser.mly
src/scripting/command_parser.mly
+23
-25
src/scripting/functions.ml
src/scripting/functions.ml
+25
-14
src/scripting/functions.mli
src/scripting/functions.mli
+5
-3
src/scripting/parse_functions.ml
src/scripting/parse_functions.ml
+129
-0
src/scripting/parse_functions.mli
src/scripting/parse_functions.mli
+6
-0
No files found.
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_
W
ait
))
in
let
()
=
F
.
help
(
F
.
Help
(
Some
F
.
Dont_
w
ait
))
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
l
oc
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
.
I
DB
))
in
let
()
=
F
.
help
(
F
.
Help
(
Some
F
.
I
db
))
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
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment