Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
cduce
cduce
Commits
808e84a0
Commit
808e84a0
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2003-06-30 16:35:47 by cvscast] Bug fix in typechecking print_xml
Original author: cvscast Date: 2003-06-30 16:35:47+00:00
parent
762270b5
Changes
4
Hide whitespace changes
Inline
Side-by-side
Makefile.distrib
View file @
808e84a0
...
...
@@ -169,6 +169,5 @@ install_web_local:web/files webiface
local_website
:
cduce webiface
(
cd
web
;
../cduce
--quiet
site.cd
--arg
site.xml
)
cp
web/www/
*
.html web/cduce.css
$(CDUCE_HTML_DIR)
/
cp
webiface
$(CGI_DIR)
/cduce
# cp web/www/*.html web/cduce.css $(CDUCE_HTML_DIR)/
# cp webiface $(CGI_DIR)/cduce
driver/examples.ml
View file @
808e84a0
...
...
@@ -260,6 +260,86 @@ let bib : Biblio =
let titles = [bib]/<paper>_/<title>_
let authors = [bib]/<paper>_/<author>_
let titles_concat = [bib]/<paper>_/<title>_/Char
"
;
"xtransform"
,
"
(* For the purpose of the example we can consider this hugely
simplified definition of Xhtml
*)
type Flow = Char | Block | Inline ;;
type Block = P | Heading | Lists | Blocktext | Char
type Lists = Ul
type Blocktext = Pre | Address | Center;;
type Inline = Char | A | Fontstyle
type Fontstyle = Tt | I | B | Big | Small;;
type Xhtml = <html>[ Head Body ];;
type Head = <head>[ Title <link>[ ]];;
type Title = <title>[ PCDATA ];;
type Body = <body bgcolor=?String>[ Block* ];;
type P = <p>[ Inline* ];;
type Heading = <(`h1 | `h2 | `h3 | `h4)>[ Inline* ];;
type Ul = <ul>[Li+];;
type Li = <li>[ Flow* ];;
type Address = <address>[ Inline* ];;
type Pre = <pre>[ (PCDATA | A | Fontstyle)* ];;
type Center = <center>[ Block* ];;
type A = <a ({ name = String } | { href = String })>[ (Inline
\
A)* ];;
type Tt = <tt>[ Inline* ];;
type I = <i>[ Inline* ];;
type B = <b>[ Inline* ];;
type Big = <big>[ Inline* ];;
type Small = <small>[ Inline* ];;
(* xtransform matches the patterns against the root element of each
XML tree and, if it fails, it recursively applies itself to the
sequence of sons of the root.
It can be used to put in boldface all the links of an XHTML
document as follows
*)
let bold(x:[Xhtml]):[Xhtml]=xtransform x with <a (y)>t -> [ <a(y)>[<b>t] ]
(* let us apply the function to a document where links appear
at different depths
*)
let doc : Xhtml =
<html>[
<head>[<title>
\"
Example
\"
<link>[]]
<body>[
<h2>['You can have links ' <a href=
\"
here
\"
>
\"
here
\"
]
<pre>['Or they can be down']
<ul>[
<li>['In ' <a name=
\"
list
\"
>
\"
lists
\"
' for instance']
<li>['or you oddly decided to '
<center>[<p>[<a href=
\"
what?
\"
>
\"
center
\"
]]
' them '
]
]
<address>[
'and even if they are in fancy ' <a name=
\"
address
\"
>
\"
address boxes
\"
]
<p>[
'nevertheless ' <a href=
\"
http://www.cduce.org
\"
>
\"
Cduce
\"
' and '
<a href=
\"
xtransform
\"
>[<tt>
\"
xtransform
\"
]
' will put all links in bold so that when'
' you program your transformation you '
<big>[<a name=
\"\"
>
\"
don
\'
t
\"
] ' have to worry about it'
]
]
];;
bold [doc];;
let [x] = bold [doc] in print_xml x;;
"
;
]
let
present
=
"<ul><li><a href=
\"
/cgi-bin/cduce?example=functions
\"
>Functions.</a>
Several syntaxes to define functions.
...
...
@@ -281,4 +361,6 @@ This examples demonstrates the use of overloaded functions.
The good old XML bibliography example.
</li><li><a href=
\"
/cgi-bin/cduce?example=projection
\"
>Projection.</a>
Syntactic sugar for projection.
</li><li><a href=
\"
/cgi-bin/cduce?example=xtransform
\"
>Tree transformations.</a>
How to perform XSLT-like transformations.
</li></ul>"
\ No newline at end of file
expat/expat_stubs.c
View file @
808e84a0
...
...
@@ -5,7 +5,7 @@
/* LICENCE for details. */
/***********************************************************************/
/* $Id: expat_stubs.c,v 1.
4
2003/06/
12 13:1
5:
5
7 cvscast Exp $ */
/* $Id: expat_stubs.c,v 1.
5
2003/06/
30 16:3
5:
4
7 cvscast Exp $ */
/* Stub code to interface Ocaml with Expat */
...
...
@@ -22,11 +22,12 @@
#define XML_Parser_val(v) (*((XML_Parser *) Data_custom_val(v)))
/* Define the place where the handlers will be located inside the
/*
* Define the place where the handlers will be located inside the
* handler tuple which is registered as global root. Handlers for
* new functions should go here.
*/
#define NUM_HANDLERS
8
#define NUM_HANDLERS
9
enum
expat_handler
{
EXPAT_START_ELEMENT_HANDLER
,
EXPAT_END_ELEMENT_HANDLER
,
...
...
@@ -35,7 +36,8 @@ enum expat_handler {
EXPAT_COMMENT_HANDLER
,
EXPAT_START_CDATA_HANDLER
,
EXPAT_END_CDATA_HANDLER
,
EXPAT_DEFAULT_HANDLER
EXPAT_DEFAULT_HANDLER
,
EXPAT_EXTERNAL_ENTITY_REF_HANDLER
};
static
void
...
...
@@ -47,6 +49,7 @@ xml_parser_finalize(value parser)
remove_global_root
(
handlers
);
XML_ParserFree
(
xml_parser
);
stat_free
(
handlers
);
}
static
int
...
...
@@ -99,14 +102,16 @@ create_ocaml_expat_parser(XML_Parser xml_parser)
int
i
;
value
*
handlers
;
/* I don't know how to find out how much memory the parser consumes, so
* I've set some figures here, which seems to do well.
/*
* I don't know how to find out how much memory the parser consumes,
* so I've set some figures here, which seems to do well.
*/
parser
=
alloc_custom
(
&
xml_parser_ops
,
sizeof
(
XML_Parser
),
1
,
5000
);
Store_field
(
parser
,
1
,
Val_bp
(
xml_parser
));
/* Malloc a value for a tuple which will contain the callback
* handlers and register it as global root.
/*
* Malloc a value for a tuple which will contain the callback
* handlers and register it as global root.
*/
handlers
=
stat_alloc
(
sizeof
*
handlers
);
*
handlers
=
Val_unit
;
...
...
@@ -120,7 +125,8 @@ create_ocaml_expat_parser(XML_Parser xml_parser)
Field
(
*
handlers
,
i
)
=
Val_unit
;
}
/* Associate it as user data with the parser. This is possible because
/*
* Associate it as user data with the parser. This is possible because
* a global root will not be relocated.
*/
XML_SetUserData
(
xml_parser
,
handlers
);
...
...
@@ -183,6 +189,16 @@ expat_XML_ExpatVersion(value unit)
return
copy_string
(
XML_ExpatVersion
());
}
/*
* Set the expat parameter for entity parsing
*/
value
expat_XML_SetParamEntityParsing
(
value
parser
,
value
choice
)
{
CAMLparam2
(
parser
,
choice
);
CAMLreturn
(
Val_bool
(
XML_SetParamEntityParsing
(
XML_Parser_val
(
parser
),
Int_val
(
choice
))));
}
/*
* Return a string with the expat error message.
*/
...
...
@@ -252,7 +268,6 @@ expat_XML_ParseSub(value parser, value string, value pos, value len)
CAMLreturn
(
Val_unit
);
}
/*
* The final call
*/
...
...
@@ -269,7 +284,6 @@ expat_XML_Final(value parser)
CAMLreturn
(
Val_unit
);
}
/*
* Start element handling, setting and resetting.
*/
...
...
@@ -649,3 +663,90 @@ expat_XML_ResetDefaultHandler(value parser)
CAMLparam1
(
parser
);
CAMLreturn
(
set_default_handler
(
parser
,
NULL
,
Val_unit
));
}
/*
* Return None if a null string is passed as a parameter, and Some str
* if a string is used.
*/
static
value
Val_option_string
(
const
char
*
str
)
{
CAMLparam0
();
CAMLlocal2
(
some
,
some_str
);
if
(
str
==
NULL
)
{
CAMLreturn
(
Val_int
(
0
));
}
else
{
some
=
alloc
(
1
,
1
);
some_str
=
copy_string
(
str
);
Store_field
(
some
,
0
,
some_str
);
CAMLreturn
(
some
);
}
}
/*
* External Entity Ref handler, setting and resetting
*/
static
int
external_entity_ref_handler
(
XML_Parser
xml_parser
,
const
char
*
context
,
const
char
*
base
,
const
char
*
systemId
,
const
char
*
publicId
)
{
CAMLparam0
();
CAMLlocal4
(
caml_context
,
caml_base
,
caml_systemId
,
caml_publicId
);
value
*
handlers
=
XML_GetUserData
(
xml_parser
);
value
arg
[
4
];
/*
* Now put the strings into ocaml values. The parameters context,
* base, and publicId are optional systemId is never optional.
*/
caml_context
=
Val_option_string
(
context
);
caml_base
=
Val_option_string
(
base
);
caml_systemId
=
copy_string
(
systemId
);
caml_publicId
=
Val_option_string
(
publicId
);
/* Call the callback which has more than 3 parameters */
arg
[
0
]
=
caml_context
;
arg
[
1
]
=
caml_base
;
arg
[
2
]
=
caml_systemId
;
arg
[
3
]
=
caml_publicId
;
callbackN
(
Field
(
*
handlers
,
EXPAT_EXTERNAL_ENTITY_REF_HANDLER
),
4
,
arg
);
CAMLreturn
(
XML_STATUS_OK
);
}
static
value
set_external_entity_ref_handler
(
value
parser
,
XML_ExternalEntityRefHandler
c_handler
,
value
ocaml_handler
)
{
CAMLparam2
(
parser
,
ocaml_handler
);
XML_Parser
xml_parser
=
XML_Parser_val
(
parser
);
value
*
handlers
=
XML_GetUserData
(
xml_parser
);
Store_field
(
*
handlers
,
EXPAT_EXTERNAL_ENTITY_REF_HANDLER
,
ocaml_handler
);
XML_SetExternalEntityRefHandler
(
xml_parser
,
c_handler
);
CAMLreturn
(
Val_unit
);
}
CAMLprim
value
expat_XML_SetExternalEntityRefHandler
(
value
parser
,
value
handler
)
{
CAMLparam2
(
parser
,
handler
);
CAMLreturn
(
set_external_entity_ref_handler
(
parser
,
external_entity_ref_handler
,
handler
));
}
CAMLprim
value
expat_XML_ResetExternalEntityRefHandler
(
value
parser
)
{
CAMLparam1
(
parser
);
CAMLreturn
(
set_external_entity_ref_handler
(
parser
,
NULL
,
Val_unit
));
}
types/builtin.ml
View file @
808e84a0
...
...
@@ -171,13 +171,19 @@ unary_op_cst "load_file" string string_latin1
Typer
.
register_unary_op
"print_xml"
(
fun
tenv
->
let
ns_table
=
Typer
.
get_ns_table
tenv
in
{
Typed
.
un_op_typer
=
(
fun
loc
arg
constr
precise
->
string_latin1
);
{
Typed
.
un_op_typer
=
(
fun
loc
arg
constr
precise
->
ignore
(
arg
Types
.
any
false
);
string_latin1
);
Typed
.
un_op_eval
=
Print_xml
.
print_xml
~
utf8
:
false
ns_table
});;
Typer
.
register_unary_op
"print_xml_utf8"
(
fun
tenv
->
let
ns_table
=
Typer
.
get_ns_table
tenv
in
{
Typed
.
un_op_typer
=
(
fun
loc
arg
constr
precise
->
string
);
{
Typed
.
un_op_typer
=
(
fun
loc
arg
constr
precise
->
ignore
(
arg
Types
.
any
false
);
string
);
Typed
.
un_op_eval
=
Print_xml
.
print_xml
~
utf8
:
true
ns_table
});;
unary_op_warning
"print"
...
...
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