Commit 8dd78b58 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-11-16 13:27:50 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-16 13:27:50+00:00
parent 6354aff8
......@@ -7,13 +7,17 @@ open Pxp_lexer_types
open Pxp_types
open Value
let is_ws s =
let rec check i =
(i < 0) ||
(match s.[i] with
| ' ' | '\t' | '\n' | '\r' -> check (i - 1)
| _ -> false) in
check (String.length s - 1)
let string s q =
let rec check_ws i = (i < 0) ||
(match s.[i] with
| ' ' | '\t' | '\n' | '\r' -> check_ws (i - 1)
| _ -> false) in
if check_ws (String.length s - 1) then q
else String (0,String.length s,s,q)
String (0,String.length s,s,q)
let run s =
let config = { default_config with
......@@ -35,7 +39,7 @@ let run s =
let rec parse_elt name att =
let att = List.map (fun (l,v) -> Types.LabelPool.mk l, string v nil) att in
let att = SortedMap.from_list (fun _ _ -> assert false) att in
let child = parse_seq () in
let child = parse_seq true in
let elt = Xml
(Atom (Types.AtomPool.mk name),
......@@ -47,17 +51,18 @@ let run s =
elt
and parse_seq () =
and parse_seq dropws =
match !curr with
| E_start_tag (name,att,_) ->
get ();
let e1 = parse_elt name att in
let rest = parse_seq () in
let rest = parse_seq true in
Pair (e1, rest)
| E_char_data data ->
get ();
let rest = parse_seq () in
string data rest
if dropws && (is_ws data)
then parse_seq true
else string data (parse_seq false)
| E_end_tag (_,_) ->
nil
| _ -> failwith "Expect start_tag, char_data, or end_tag"
......
(* An approximation of HTML *)
type Flow = Char | Block | Inline | Misc;;
type Block = P | Heading | Div | Lists | Table | Blocktext;;
type Lists = Ul;;
type Blocktext = Pre | Hr | Blockquote | Address;;
type Inline = Char | A | Special | Fontstyle | Phrase;;
type Fontstyle = Tt | I | B | Big | Small;;
type Phrase = Em | Strong | Code;;
type Special = Br;;
type Misc = Empty;;
type Html = <html>[ Head Body ];;
type Head = <head>[ Title ];;
type Title = <title>[ PCDATA ];;
type Body = <body>[ Block* ];;
type Div = <div>[ Flow* ];;
type P = <p>[ Inline* ];;
type Heading = <(`h1 | `h2)>[ Inline* ];;
type Ul = <ul>[Li+];;
type Li = <li>[ Flow* ];;
type Address = <address>[ Inline* ];;
type Hr = <hr>[];;
type Pre = <pre>[ (PCDATA | A | Fontstyle | Phrase | Br)* ];;
type Blockquote = <blockquote>[ Block* ];;
type A = <a ({ name = String } | { href = String })>[ (Inline \ A)* ];;
type Br = <br>[];;
type Em = <em>[ Inline* ];;
type Code = <code>[ Inline* ];;
type Strong = <strong>[ Inline* ];;
type Tt = <tt>[ Inline* ];;
type I = <i>[ Inline* ];;
type B = <b>[ Inline* ];;
type Big = <big>[ Inline* ];;
type Small = <small>[ Inline* ];;
type Table = Empty;;
(* Input document *)
type Page = <page filename=String>[ <title>String; Content ];;
type Content = [ (Box | Section)* ];;
type Box = <box>Text;;
type Section = <section>[ <title>String ; Text ];;
type Text = [ (Char | <duce>String | <ul>[<li>Text +])* ];;
let (fname, title, content) =
match load_xml "tests/memento.xml" with
| <page filename=x>[ <title>x ; x ] & Page -> x
| _ -> raise "Invalid input document!";;
let fun box(c : [Flow*]) : Block = <div>c;;
let fun format (Box | Section -> Block; Text -> [Flow*]; Content -> [Block*] )
| <box>s -> box (format s)
| <section>[ <title>t ; s ] -> box [ <h2>t; format s ]
| txt & Text -> (map txt with
| <duce>c -> <b>[<tt>c]
| <ul>l -> <ul>(map l with <li>c -> <li>(format c) )
| c -> c)
| c & Content -> (map c with x -> format x);;
let out : Html =
<html>[
<head>[ <title>title ]
<body>[ (box [<h1>title]) !(format content) ]
];;
dump_to_file fname (print_xml out);;
<page filename="memento.html">
<title>CDuce memento</title>
<box>
This page briefly presents the syntax of the CDuce language.
You can experiment with the online demo, which includes a few built-in
examples.
</box>
<section>
<title>Scalars</title>
<ul>
<li>Large integers:
<ul>
<li>Values: <duce>0,1,2,3,...</duce> </li>
<li>Types: intervals <duce>-*--10, 20--30, 50--*, ...</duce>,
singletons <duce>0,1,2,3,...</duce> </li>
</ul>
</li>
<li>Unicode characters:
<ul>
<li>Values: <duce>'a','b','c'...</duce> </li>
<li>Types: intervals <duce>'a'--'z', '0'--'9'</duce>,
singletons <duce>'a','b','c',...</duce> </li>
</ul>
</li>
<li>Symbolic atoms:
<ul>
<li>Values: <duce>`A, `B, `a, `b, ...</duce> </li>
<li>Types: singletons <duce>`A, `B, ...</duce> </li>
</ul>
</li>
</ul>
</section>
<section>
<title>Pairs</title>
<ul>
<li>Expressions: <duce>(e1,e2)</duce> </li>
<li>Types and patterns: <duce>(t1,t2)</duce> </li>
<li>Note: tuples are right-associative pairs; e.g.:
<duce>(1,2,3)=(1,(2,3))</duce> </li>
<li>When a capture variable appears on both side of a pair pattern,
the two captured values are paired
together (e.g. <duce>match (1,2,3) with (x,(_,x)) -> x ==>
(1,3)</duce>). </li>
</ul>
</section>
<section>
<title>Sequences</title>
<ul>
<li>Expressions: <duce>[ 1 2 3 ]</duce>,
which is syntactic sugar for <duce>(1,(2,(3,`nil)))</duce> </li>
<li>A sub-sequence can be escaped by !: <duce>[ 1 2 ![ 3 4 ] 5 ]</duce>. </li>
<li>Types and patterns : <duce>[ R ]</duce> where <duce>R</duce> is
a regular expression built on types and patterns:
<ul>
<li>A type or a pattern is a regexp by itself, matching a single
element of the sequence </li>
<li>Postfix repetition operators: <duce>*,+,?</duce>
and the ungreedy variants (for patterns) <duce>*?, +?
,??</duce></li>
<li>Concatenation of regexps</li>
<li>For patterns, sequence capture variable <duce>x::R</duce> </li>
</ul>
</li>
<li>It is possible to specify a tail, for expressions, types, and patterns;
e.g.: <duce>[ x::Int*; q ]</duce> </li>
</ul>
</section>
</page>
......@@ -18,6 +18,7 @@ let fun sort (MPerson -> Man ; FPerson -> Woman)
let d = map fc with x -> sort x in
<(tag) name=n>[ <sons>s <daughters>d ]
;;
let base : Person =
<person gender="M">[
<name>"Claude"
......@@ -32,21 +33,7 @@ let base : Person =
]
<tel> "314-1592654"
]
]
<tel kind="home"> "271-828182"
<children>[
<person gender="F">[
<name>"Ilaria"
<children>[]
]
]
<tel> "314-1592654"
]
]
<tel kind="home"> "271-828182"
]
;;
]
]
;;
......
......@@ -148,6 +148,8 @@ module DescrHash =
end
)
let print_descr = ref (fun _ _ -> assert false)
(*
let define n d = check d; define n d
*)
......@@ -252,22 +254,50 @@ and empty_rec_times c =
and empty_rec_times_aux (left,right) =
let rec aux accu1 accu2 = function
| (t1,t2)::right ->
let accu1' = diff_t accu1 t1 in
if not (empty_rec accu1') then aux accu1' accu2 right;
let accu2' = diff_t accu2 t2 in
if not (empty_rec accu2') then aux accu1 accu2' right
(* This may avoid explosion with huge rhs ...
May be slower when List.length right is small; could optimize
this case... *)
if empty_rec (cap_t accu1 t1) || empty_rec (cap_t accu2 t2) then
aux accu1 accu2 right
else
let accu1' = diff_t accu1 t1 in
if not (empty_rec accu1') then aux accu1' accu2 right;
let accu2' = diff_t accu2 t2 in
if not (empty_rec accu2') then aux accu1 accu2' right
| [] -> raise NotEmpty
in
let (accu1,accu2) = cap_product left in
(*
let right' = List.filter
(fun (t1,t2) ->
not
(empty_rec (cap_t accu1 t1) || empty_rec (cap_t accu2 t2)
)
) right in
if List.length right > 15 then (
Format.fprintf Format.std_formatter "[%i=>%i]@."
(List.length right) (List.length right');
Format.fprintf Format.std_formatter "(%a,%a)@."
!print_descr accu1
!print_descr accu2;
List.iter (fun (t1,t2) ->
Format.fprintf Format.std_formatter "\ (%a,%a)@."
!print_descr (descr t1)
!print_descr (descr t2);
) right
);
let right = right' in
*)
(empty_rec accu1) || (empty_rec accu2) ||
(* OPT? It does'nt seem so ... The hope was to return false quickly
for large right hand-side *)
(
((*if (List length right > 2) then
(* (if (List.length right > 2) then
let (cup1,cup2) = cup_product right in
(empty_rec (diff accu1 cup1)) && (empty_rec (diff accu2 cup2))
else*) true)
&&
else true)
&& *)
(try aux accu1 accu2 right; true with NotEmpty -> false)
)
......@@ -295,10 +325,12 @@ and empty_rec_record c =
List.for_all aux (get_record c)
let is_empty d =
(* Printf.eprintf "+"; flush stderr; *)
let old = !memo in
let r = empty_rec d in
if not r then memo := old;
(* cache_false := Assumptions.empty; *)
(* Printf.eprintf "-\n"; flush stderr; *)
r
let non_empty d =
......@@ -589,7 +621,7 @@ struct
end
let () = print_descr := Print.print_descr
module Positive =
struct
......
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