Skip to content

GitLab

C
cduce
Commit b6d68c05 authored by Pietro Abate's avatar Pietro Abate
Browse files
Options

[r2002-11-16 00:26:48 by cvscast] Empty log message 

Original author: cvscast
Date: 2002-11-16 00:26:50+00:00
parent 847b5f6a
Hide whitespace changes
Inline Side-by-side
Showing with 295 additions and 41 deletions
Makefile
View file @ b6d68c05
......@@ -32,7 +32,7 @@ DRIVER = driver/cduce.cmo
OBJECTS = $(MISC) $(TYPES) $(PARSER) $(TYPING) $(RUNTIME)
CDUCE = $(OBJECTS) $(DRIVER) driver/run.cmo
WEBIFACE = $(OBJECTS) $(DRIVER) driver/webiface.cmo
WEBIFACE = $(OBJECTS) $(DRIVER) driver/examples.cmo driver/webiface.cmo
TOPLEVEL = $(OBJECTS) toplevel/toploop.cmo
XOBJECTS = $(OBJECTS:.cmo=.cmx)
......@@ -137,22 +137,13 @@ test: all.cma
include depend
driver/examples.ml: cduce tests/web.cd tests/examples.xml
./cduce -quiet tests/web.cd
# Site-specific installation
build_web:
rsh cedre ". .env; cd IMPLEM/CDUCE; make webiface"
install_web:
ssh cduce@iris "cp ~frisch/IMPLEM/CDUCE/webiface cgi-bin/cduce2; chmod +s cgi-bin/cduce2"
driver/cduce.ml
View file @ b6d68c05
......@@ -176,7 +176,7 @@ let run ppf ppf_err input =
) bindings
in
let phrase ph =
let phrase ph =
match ph.descr with
| Ast.EvalStatement e ->
let (fv,e) = Typer.expr !glb_env e in
......@@ -200,6 +200,16 @@ let run ppf ppf_err input =
insert_type_bindings (Typer.type_rec_funs !typing_env decls);
List.iter eval_decl decls
in
let rec phrases funs = function
| { descr = Ast.LetDecl (p,({descr=Ast.Abstraction _} as e))} :: phs ->
phrases ((p,e)::funs) phs
| ph :: phs ->
do_fun_decls funs;
phrase ph;
phrases [] phs
| _ ->
do_fun_decls funs
in
try
let p =
try Parser.prog input
......@@ -216,8 +226,7 @@ let run ppf ppf_err input =
| _ -> accu
) ([],[]) p in
glb_env := Typer.register_global_types !glb_env type_decls;
do_fun_decls fun_decls;
List.iter phrase p;
phrases [] p;
true
with
| (Failure _ | Not_found | Invalid_argument _) as e ->
......
driver/examples.ml 0 → 100644
View file @ b6d68c05
let examples = [ "ovfun","
type Person = FPerson | MPerson;;
type FPerson = <person gender = \"F\" >[ Name Children (Tel | Email)?];;
type MPerson = <person gender=\"M\">[ Name Children (Tel | Email)?];;
type Children = <children>[Person*];;
type Name = <name>[ PCDATA ];;
type Tel = <tel kind=?\"home\"|\"work\">['0'--'9'+ '-' '0'--'9'+];;
type Email = <email>[PCDATA '@' PCDATA];;
type Man = <man name=String>[ Sons Daughters ];;
type Woman = <woman name=String>[ Sons Daughters ];;
type Sons = <sons>[ Man* ];;
type Daughters = <daughters>[ Woman* ];;
let fun sort (MPerson -> Man ; FPerson -> Woman)
<person gender=g>[ <name>n <children>[(mc::MPerson | fc::FPerson)*]; _] ->
let tag = match g with \"F\" -> `woman | \"M\" -> `man in
let s = map mc with x -> sort x in
let d = map fc with x -> sort x in
<(tag) name=n>[ <sons>s <daughters>d ]
;;
let base : Person =
<person gender=\"M\">[
<name>\"Claude\"
<children>[
<person gender=\"F\">[
<name>\"Vronique\"
<children>[
<person gender=\"F\">[
<name>\"Ilaria\"
<children>[]
]
]
<tel> \"314-1592654\"
]
]
<tel kind=\"home\"> \"271-828182\"
]
;;
sort base;;
";"note","
type Doc = <doc>Text;;
type Text = [ (Char | (Letter+ ' '* Note))* ];;
type Letter = 'a'--'z' | 'A'--'Z';;
type Note = <note>[ PCDATA ];;
type Flow = [ (Char | <ref no=Int>[ PCDATA ])* ];;
type Notes = [ <note no=Int>[ PCDATA ]* ];;
type Result = <doc>[ <body>Flow <notes>Notes ];;
let fun format (<doc>s : Doc) : Result =
let (body,notes) = text (s,1) in
<doc>[ <body>body <notes>notes ];;
let fun text ( (Text,Int) -> (Flow,Notes) )
| ([ pre::Char*? (word::Letter+ ' '* <note>n); rem ], count) ->
let (body,notes) = text (rem, count + 1) in
(pre @ [<ref no=count>word] @ body,
[<note no=count>n] @ notes)
| (body,_) -> (body, []);;
let src : Doc = <doc>[ 'CDuce ' <note>\"Frisch, Castagna, Benzaken\"
' is an XML ' <note>\"a W3C standard\"
'-friendly programming language.' ];;
format src;;
"; ];;
let present = "<ul
><li
><a href=\"/cgi-bin/cduce2?example=ovfun\"
>Overloaded functions.</a
>This examples demonstrates the use of overloaded functions.</li
><li
><a href=\"/cgi-bin/cduce2?example=note\"
>Footnotes.</a
> This example shows how to bind an XML element with surrounding text.</li
></ul
>";;
\ No newline at end of file
driver/webiface.ml
View file @ b6d68c05
......@@ -36,6 +36,13 @@ let max_sess = 10
(*****************)
(* Loading examples *)
let example code =
try List.assoc code Examples.examples
with Not_found -> ""
let persistant = ref false
let session_id = ref ""
......@@ -47,6 +54,7 @@ let html_header p =
<body>
<h1>CDuce online prototype</h1>
";
p Examples.present;
if !persistant then
(p "You're running the CDuce prototype in session mode: values and
types accepted by CDuce when you click 'Submit' will be available
......@@ -109,6 +117,7 @@ let cmds = [ "open", `Open;
"close", `Close;
"dump", `Dump;
"exec", `Exec;
"example", `Example;
"new", `New;
]
......@@ -168,7 +177,7 @@ let main (cgi : Netcgi.std_activation) =
let ppf = Format.str_formatter
and input = Stream.of_string src in
Location.set_source (`String src);
Load_xml.set_auth false;
Location.set_protected true;
let ok = Cduce.run ppf ppf input in
if ok then Format.fprintf ppf "@\nOk.@\n";
......@@ -199,6 +208,7 @@ let main (cgi : Netcgi.std_activation) =
| `New -> dialog ""
| `Dump -> dump prog
| `Close -> dialog ""
| `Example -> dialog (example (cgi # argument_value "example"))
);
html_footer p;
cgi # output # commit_work()
......
parser/location.ml
View file @ b6d68c05
......@@ -101,3 +101,14 @@ let protect ppf f =
let s = Netencoding.Html.encode_from_latin1 s in
Format.fprintf ppf "@[%s@]" s
| _ -> f ppf
let protected = ref false
let set_protected p = protected := p
let is_protected () = !protected
let protect_op op =
if (!protected) then
raise
(Generic (op ^ ": operation not authorized in the web prototype"))
parser/location.mli
View file @ b6d68c05
......@@ -23,3 +23,9 @@ val html_hilight: Format.formatter -> loc -> unit
type 'a located = { loc : loc; descr : 'a }
val mk: loc -> 'a -> 'a located
(* Are we working in a protected environement (web prototype ...) ? *)
val set_protected : bool -> unit
val is_protected : unit -> bool
val protect_op : string -> unit
parser/parser.ml
View file @ b6d68c05
......@@ -119,6 +119,8 @@ EXTEND
| LIDENT "int_of"
];
e = expr -> mk loc (Op (op,[e]))
| op = [ LIDENT "dump_to_file" ];
e1 = expr LEVEL "no_appl"; e2 = expr -> mk loc (Op (op, [e1;e2]))
| e1 = expr; e2 = expr -> mk loc (Apply (e1,e2))
]
......
runtime/eval.ml
View file @ b6d68c05
......@@ -64,6 +64,8 @@ let rec eval env e0 =
| Typed.Op ("print_xml", [e]) -> eval_print_xml (eval env e)
| Typed.Op ("print", [e]) -> eval_print (eval env e)
| Typed.Op ("int_of", [e]) -> eval_int_of (eval env e)
| Typed.Op ("dump_to_file", [e1; e2]) ->
eval_dump_to_file (eval env e1) (eval env e2)
| Typed.Dot (e, l) -> eval_dot l (eval env e)
| Typed.Op (o,_) -> failwith ("Unknown operator " ^ o)
......@@ -139,4 +141,12 @@ and eval_print_xml v =
and eval_print v =
let s = get_string v in
print_endline s;
v
Value.nil
and eval_dump_to_file f v =
Location.protect_op "dump_to_file";
let oc = open_out (get_string f) in
output_string oc (get_string v);
close_out oc;
Value.nil
runtime/load_xml.ml
View file @ b6d68c05
......@@ -2,9 +2,6 @@
(*TODO: close the file ! *)
let auth = ref true
let set_auth b = auth := b
open Pxp_yacc
open Pxp_lexer_types
open Pxp_types
......@@ -75,11 +72,7 @@ let run s =
let run s =
if not !auth then
raise
(Location.Generic
"load_xml: operation not authorized in the web prototype"
);
Location.protect_op "load_xml";
try run s
with exn ->
raise
......
runtime/load_xml.mli
View file @ b6d68c05
val set_auth: bool -> unit
val run: string -> Value.t
runtime/print_xml.ml
View file @ b6d68c05
......@@ -32,9 +32,10 @@ let string_of_xml v=
wms ("<" ^ name); List.iter write_att attrs; wms "\n>"
and element_end name = wms ("</" ^ name ^ "\n>")
and document_start () =
wms ("<?xml version='1.0' encoding='" ^
(* wms ("<?xml version='1.0' encoding='" ^
Netconversion.string_of_encoding to_enc ^
"'?>\n")
"'?>\n") *)
()
and text s = wds s in
let rec print_elt = function
......
tests/examples.xml 0 → 100644
View file @ b6d68c05
<?xml version="1.0" encoding="iso-8859-1"?>
<examples>
<example code="ovfun">
<title>Overloaded functions</title>
<abstract>
This examples demonstrates the use of overloaded functions.
</abstract>
<code>
<![CDATA[
type Person = FPerson | MPerson;;
type FPerson = <person gender = "F" >[ Name Children (Tel | Email)?];;
type MPerson = <person gender="M">[ Name Children (Tel | Email)?];;
type Children = <children>[Person*];;
type Name = <name>[ PCDATA ];;
type Tel = <tel kind=?"home"|"work">['0'--'9'+ '-' '0'--'9'+];;
type Email = <email>[PCDATA '@' PCDATA];;
type Man = <man name=String>[ Sons Daughters ];;
type Woman = <woman name=String>[ Sons Daughters ];;
type Sons = <sons>[ Man* ];;
type Daughters = <daughters>[ Woman* ];;
let fun sort (MPerson -> Man ; FPerson -> Woman)
<person gender=g>[ <name>n <children>[(mc::MPerson | fc::FPerson)*]; _] ->
let tag = match g with "F" -> `woman | "M" -> `man in
let s = map mc with x -> sort x in
let d = map fc with x -> sort x in
<(tag) name=n>[ <sons>s <daughters>d ]
;;
let base : Person =
<person gender="M">[
<name>"Claude"
<children>[
<person gender="F">[
<name>"Vronique"
<children>[
<person gender="F">[
<name>"Ilaria"
<children>[]
]
]
<tel> "314-1592654"
]
]
<tel kind="home"> "271-828182"
]
;;
sort base;;
]]>
</code>
</example>
<example code="note">
<title>Footnotes</title>
<abstract>
This example shows how to bind an XML element with surrounding text.
</abstract>
<code>
<![CDATA[
type Doc = <doc>Text;;
type Text = [ (Char | (Letter+ ' '* Note))* ];;
type Letter = 'a'--'z' | 'A'--'Z';;
type Note = <note>[ PCDATA ];;
type Flow = [ (Char | <ref no=Int>[ PCDATA ])* ];;
type Notes = [ <note no=Int>[ PCDATA ]* ];;
type Result = <doc>[ <body>Flow <notes>Notes ];;
let fun format (<doc>s : Doc) : Result =
let (body,notes) = text (s,1) in
<doc>[ <body>body <notes>notes ];;
let fun text ( (Text,Int) -> (Flow,Notes) )
| ([ pre::Char*? (word::Letter+ ' '* <note>n); rem ], count) ->
let (body,notes) = text (rem, count + 1) in
(pre @ [<ref no=count>word] @ body,
[<note no=count>n] @ notes)
| (body,_) -> (body, []);;
let src : Doc = <doc>[ 'CDuce ' <note>"Frisch, Castagna, Benzaken"
' is an XML ' <note>"a W3C standard"
'-friendly programming language.' ];;
format src;;
]]>
</code>
</example>
</examples>
tests/overloading.cd
View file @ b6d68c05
......@@ -34,6 +34,19 @@ let base : Person =
]
]
<tel kind="home"> "271-828182"
<children>[
<person gender="F">[
<name>"Ilaria"
<children>[]
]
]
<tel> "314-1592654"
]
]
<tel kind="home"> "271-828182"
]
;;
]
;;
......
tests/stress_opt_seq.cd
View file @ b6d68c05
......@@ -3,9 +3,7 @@ type T = [ `A? `B? `C? `D? `E? `F? `G? `H? `I? `J?
let fun f (Any -> T) T & x -> x | x -> f x;;
(*
debug compile Any T;;
*)
(*
debug compile T
......@@ -24,4 +22,4 @@ match [ `A `B `C ] with (P1 where
P3 = (`C & (c := 1), P4) | (c := 2) & P4 and
P4 = (`D & (d := 1), P5) | (d := 2) & P5 and
P5 = `nil) -> (a,b,c,d);;
*)
\ No newline at end of file
*)
tests/web.cd
View file @ b6d68c05
(* An approximation of HTML *)
type Flow = Char | Block | Inline | Misc;;
type Block = P | Heading | Div | Lists | Table | Blocktext;;
type Lists = Ul;;
......@@ -38,12 +40,33 @@ type Small = <small>[ Inline* ];;
type Table = Empty;;
(* Input documents: CDuce examples *)
type Examples = <examples>[Example+];;
type Example = <example code=String>[
<title>String
<abstract>String
<code>String
];;
let examples =
match load_xml "tests/examples.xml" with
| Examples & <_>e -> e
| _ -> raise "Invalid input document";;
let cduce = [ <b>"C" 'Duce' ];;
let website : String = "http://www.cduce.org";;
let fun script (code : String) : String =
"/cgi-bin/cduce2?example=" @ code;;
let fun do_example (<_ code=c>[<title>t <abstract>a; _] : Example) : Li =
<li>[ <a href = script c >[ !t '.' ] !a ];;
let presentation : [ Block* ] =
[ <h2>"Presentation of the language"
<p>[ 'Bla bla' ]
<p>[ !cduce ' is an higher-order functional language adapted to '
' XML applications.' ]
];;
......@@ -56,9 +79,23 @@ let doc : Html =
'at our main ' <a href=website>"site" '.' ]
!presentation
<h2>"Papers"
<h2>"Examples"
<ul>(map examples with e -> do_example e)
<hr>[]
<address>[ 'This page has been generated by a ' !cduce ' program.' ]
]
];;
print (print_xml doc);;
let fun protect_quote (s : String) : String =
transform s with '"' -> [ '\\"' ] | c -> [c];;
let fun to_ml (e : [Example*]) : String =
transform e with
<_ code=c>[_ _ <code>cd] -> [ '"' !c '","' !(protect_quote cd) '";'];;
dump_to_file "tests/examples.html" (print_xml doc);;
dump_to_file "driver/examples.ml"
[ 'let examples = [ ' !(to_ml examples) ' ];;
let present = "' !(protect_quote (print_xml <ul>(map examples with e -> do_example e))) '";;' ];;
types/types.ml
View file @ b6d68c05
......@@ -376,7 +376,6 @@ This version explodes when dealing with
(t & t1, s - s1) | ... | (t & tn, s - sn) | (t - (t1|...|tn), s)
*)
(*
let get_aux d =
let accu = ref [] in
let line (left,right) =
......@@ -398,7 +397,7 @@ This version explodes when dealing with
in
List.iter line d;
!accu
*)
let get ?(kind=`Normal) d =
match kind with
| `Normal -> get_aux d.times
......
typing/typer.ml
View file @ b6d68c05
......@@ -786,11 +786,17 @@ and type_op loc op args =
Sequence.string
| "print", [loc1,t1] ->
check loc1 t1 Sequence.string
"The argument of print";
t1
"The argument of print must be a string";
Sequence.nil_type
| "dump_to_file", [loc1,t1; loc2,t2] ->
check loc1 t1 Sequence.string
"The argument of dump_to_file must be a string (filename)";
check loc2 t2 Sequence.string
"The argument of dump_to_file must be a string (value to dump)";
Sequence.nil_type
| "int_of", [loc1,t1] ->
check loc1 t1 Sequence.string
"The argument of int_of must a string";
"The argument of int_of must be a string";
if not (Types.subtype t1 Builtin.intstr) then
warning loc "This application of int_of may fail";
Types.interval Intervals.any
......
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