Skip to content

GitLab

Commit 1838587d authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-03-06 15:52:10 by afrisch] New syntax for record types/patterns 

Original author: afrisch
Date: 2005-03-06 15:52:11+00:00
parent 696c5050
Expand all Hide whitespace changes
Inline Side-by-side
CHANGES
View file @ 1838587d
......@@ -19,6 +19,12 @@ Since 0.2.2
A dot in an identifier must now be escaped with a backslash, e.g. x\.y
* Identifiers (for types, values) are now qualified names.
* float_of: String -> Float
* Syntax modifications for records and attributes:
- ".." to denote open record types/patterns:
open record: { l1=t1 l2=t2 .. }
closed record: { l1=t1 l2=t2 }
- the ";" between fields is optional even for records
(used to be optional only for attributes)
- Tools:
* A new tool cduce_mktop produces customized CDuce toplevels with embedded
......
parser/parser.ml
View file @ 1838587d
......@@ -354,7 +354,7 @@ EXTEND
];
a = expr_attrib_spec; ">"; c = expr ->
exp loc (Xml (t, Pair (a,c)))
| "{"; r = [ expr_record_spec | -> exp loc (RecordLitt []) ]; "}" -> r
| "{"; r = expr_record_spec; "}" -> r
| s = STRING2 ->
let s = U.mk s in
exp loc (String (U.start_index s, U.end_index s, s, cst_nil))
......@@ -546,7 +546,7 @@ EXTEND
]
];
located_ident: [ [ a = IDENT -> (lop loc,ident a) ] ];
located_ident: [ [ a = [IDENT|keyword] -> (lop loc,ident a) ] ];
pat: [
[ x = pat; "where";
......@@ -558,8 +558,7 @@ EXTEND
| "simple" [ x = pat; "&"; y = pat -> mk loc (And (x,y))
| x = pat; "\\"; y = pat -> mk loc (Diff (x,y)) ]
|
[ "{"; r = record_spec; "}" -> mk loc (Record (true,r))
| "{|"; r = record_spec; "|}" -> mk loc (Record (false,r))
[ "{"; r = record_spec; "}" -> r
| "ref"; p = pat ->
let get_fun = mk loc (Arrow (pat_nil, p))
and set_fun = mk loc (Arrow (p, pat_nil))in
......@@ -571,7 +570,7 @@ EXTEND
mk loc (Constant (ident a,c))
| "!"; a = IDENT ->
mk loc (Internal (Types.abstract (Types.Abstract.atom a)))
| cu = OPT [ cu = IDENT; "." -> U.mk cu ]; a = IDENT ->
| cu = OPT [ cu = IDENT; "." -> U.mk cu ]; a = [ IDENT | keyword ] ->
mk loc (PatVar (cu, ident a))
| i = INT ; "--"; j = INT ->
let i = Intervals.V.mk i
......@@ -630,7 +629,7 @@ EXTEND
x = pat; y = or_else -> (o,x,y) ] ] ];
record_spec:
[ [ r = LIST0 [ l = [IDENT | keyword ]; f = opt_field_pat ->
[ [ r = LIST0 [ l = [IDENT | keyword ]; f = opt_field_pat; OPT ";" ->
let (o,x,y) =
match f with
| None -> (false, mknoloc (PatVar (None,ident l)), None)
......@@ -638,8 +637,8 @@ EXTEND
in
let x = if o then mk loc (Optional x) else x in
(label l, (x,y))
] SEP ";" ->
r
]; op = [ ".." -> true | -> false ] ->
mk loc (Record (op,r))
] ];
char:
......@@ -648,46 +647,27 @@ EXTEND
];
attrib_spec:
[ [ r = LIST0 [ l = [IDENT | keyword ]; f = opt_field_pat; OPT ";" ->
let (o,x,y) =
match f with
| None -> (false, mknoloc (PatVar (None,ident l)), None)
| Some z -> z
in
let x = if o then mk loc (Optional x) else x in
(label l, (x, y))
] ->
mk loc (Record (true,r))
| "("; t = pat; ")" -> t
| "{"; r = record_spec; "}" -> mk loc (Record (true,r))
| "{|"; r = record_spec; "|}" -> mk loc (Record (false,r))
] ];
attrib_spec: [
[ r = record_spec -> r
| "("; t = pat; ")" -> t
] ];
opt_field_expr: [ [ OPT [ "="; x = expr LEVEL "no_appl" -> x ] ] ];
expr_record_spec:
[ [ r = LIST1
[ [ r = LIST0
[ l = [IDENT | keyword ];
x = opt_field_expr ->
x = opt_field_expr; OPT ";" ->
let x = match x with Some x -> x | None -> Var (ident l) in
(label l,x) ]
SEP ";" ->
->
exp loc (RecordLitt r)
] ];
expr_attrib_spec:
[ [ r = LIST1
[ l = [IDENT | keyword ];
x = opt_field_expr; OPT ";" ->
let x = match x with Some x -> x | None -> Var (ident l) in
(label l,x) ] ->
exp loc (RecordLitt r)
]
| [ e = expr LEVEL "no_appl" -> e
| -> exp loc (RecordLitt [])
]
];
expr_attrib_spec: [
[ e = expr_record_spec -> e
| "("; e = expr; ")" -> e
] ];
END
module Hook = struct
......
parser/ulexer.ml
View file @ 1838587d
......@@ -75,6 +75,7 @@ let rec token = lexer
| [ "<>=.,:;+-*/@&{}[]()|?`!" ]
| "->" | "::" | ";;" | "--" | "//" | "/@" | ":=" | "\\" | "++"
| "{|" | "|}" | "<=" | ">=" | "<<" | ">>" | "||" | "&&" | "**"
| ".."
| ["?+*"] "?" | "#" ->
return lexbuf ("", L.utf8_lexeme lexbuf)
| '"' | "'" ->
......
runtime/value.ml
View file @ 1838587d
......@@ -324,8 +324,7 @@ and print_attr ppf = function
and print_record ppf = function
| [] -> ()
| [f] -> Format.fprintf ppf " %a" print_field f
| f :: rem -> Format.fprintf ppf " %a;%a" print_field f print_record rem
| f :: rem -> Format.fprintf ppf " %a" print_field f; print_record ppf rem
and print_field ppf (l,v) =
Format.fprintf ppf "%a=%a" Label.print (LabelPool.value l) print v
......
tools/dtd2cduce.ml
View file @ 1838587d
......@@ -62,25 +62,21 @@ let import_dtd ppf name filename =
| _ -> Format.fprintf ppf "String"
in
let attrib ppf e =
ignore
(List.fold_left
(fun first a ->
let (at,ad) = e # attribute a in
match ad with
| D_fixed _ -> first
| _ ->
Format.fprintf ppf "%s%s=%s%a"
(if first then "" else "; ")
a
(if ad = D_required then "" else "?")
att_type at;
false
)
true (e # attribute_names)
List.iter
(fun a ->
let (at,ad) = e # attribute a in
match ad with
| D_fixed _ -> ()
| _ ->
Format.fprintf ppf " %s=%s%a"
a
(if ad = D_required then "" else "?")
att_type at;
)
(e # attribute_names)
in
let elt ppf e =
Format.fprintf ppf "type @[<2>%s =@ @[<3><%s {|%a|}>[@ @[%a@]@ ]@]@];;@\n"
Format.fprintf ppf "type @[<2>%s =@ @[<3><%s%a>[@ @[%a@]@ ]@]@];;@\n"
(name (e # name))
(e # name)
attrib e
......
types/types.ml
View file @ 1838587d
......@@ -1581,12 +1581,9 @@ struct
do_print_attr attr
(do_print_slot 2) t
| Record (r,some,none) ->
if some then Format.fprintf ppf "@[{"
else Format.fprintf ppf "@[{|";
do_print_record ppf r;
if not none then Format.fprintf ppf ";@ ...";
if some then Format.fprintf ppf " }@]"
else Format.fprintf ppf " |}@]"
Format.fprintf ppf "@[{";
do_print_record ppf (r,some,none);
Format.fprintf ppf " }@]"
| Arrows (p,n) ->
(match p with
| [] -> Format.fprintf ppf "Arrow"
......@@ -1610,18 +1607,18 @@ struct
| `Tag s -> s ppf
| `Type t -> Format.fprintf ppf "(%a)" (do_print_slot 0) t
and do_print_attr ppf = function
| { state = `Marked|`Expand;
def = [ Record (r,true,true) ] } -> do_print_record ppf r
| t -> Format.fprintf ppf " %a" (do_print_slot 2) t
and do_print_record ppf r =
let first = ref true in
| { state = `Marked|`Expand|`None;
def = [ Record (r,some,none) ] } -> do_print_record ppf (r,some,none)
| t -> Format.fprintf ppf " (%a)" (do_print_slot 2) t
and do_print_record ppf (r,some,none) =
List.iter
(fun (l,(o,t)) ->
let sep = if !first then (first := false; "") else ";" in
let opt = if o then "?" else "" in
Format.fprintf ppf "%s@ @[%a =%s@] %a" sep
Format.fprintf ppf "@ @[%a=%s@]%a"
Label.print (LabelPool.value l) opt (do_print_slot 0) t
) (LabelMap.get r)
) (LabelMap.get r);
if not none then Format.fprintf ppf "@ (+others)";
if some then Format.fprintf ppf " ..";
and do_print_regexp pri ppf = function
| Pretty.Empty -> Format.fprintf ppf "Empty" (*assert false *)
| Pretty.Epsilon -> ()
......
web/site.cd
View file @ 1838587d
......@@ -18,10 +18,10 @@ using H = "xhtml"
type Site = <site>[ <title>String Footer? Page ]
type Footer = <footer>[ Item* ]
type Page = <page name=Latin1 url=?String new=?"" leftbar=?("true"|"false")>[ <title>String <banner>[InlineText*]? Item* ]
type External = <external {|href=String; title=String; name=String |}>[]
type External = <external href=String title=String name=String>[]
type Item =
<box ({| title=String; link=String; short=?String |} | {| |})>Content
<box ({title=String; link=String; short=?String} | {})>Content
| <meta>Content
| <left>Content
| <footnotes>[]
......@@ -40,14 +40,14 @@ type Link =
<link url=String title=String>[ InlineText* ]
type Content =
[ ( <p {|style=?String|}>[InlineText*]
| <ul {||}>[<li {||}>Content *]
| <ol {|style=?String|}>[<li {||}>Content *]
[ ( <p style=?String>[InlineText*]
| <ul>[<li>Content *]
| <ol style=?String>[<li>Content *]
| <section title=String>Content
| <sample highlight=?"true"|"false">String
| <xmlsample highlight=?"true"|"false">String
| <sessionsample highlight=?"true"|"false">String
| H.Xtable
| H.table
| Paper | Slides | Link
| <boxes-toc short=?"" sections=?"">[]
| <pages-toc sections=?"">[]
......@@ -63,11 +63,11 @@ type Content =
type InlineText =
Char
| <(`b|`i|`tt|`em) {| style=?String |}>[InlineText*]
| <(`b|`i|`tt|`em) style=?String>[InlineText*]
| <code>String
| <local href=String>String
| <footnote>[InlineText*]
| H.Xa | H.Ximg | H.Xbr
| <footnote nocount=?"true">[InlineText*]
| H.a | H.img | H.br
| <thumbnail href=String width=?IntStr height=?IntStr>[]
| <thumbnails href=String width=?IntStr height=?IntStr>[ PCDATA ]
......@@ -95,7 +95,7 @@ let [<site>[ <title>site (<footer>footer | /(footer:=[])) main_page ] ] =
(* Highlighting text between {{...}} *)
let highlight (String -> [ (Char | H.Xstrong | H.Xi)* ] )
let highlight (String -> [ (Char | H.strong | H.i)* ] )
| [ '{{%%' h ::(Char *?) '%%}}' ; rest ] ->
[ <strong class="highlight">[<i>h]; highlight rest ]
| [ '{{' h ::(Char *?) '}}' ; rest ] ->
......@@ -126,16 +126,18 @@ let split_thumbnails (String -> [(String,String)*])
(** Internal types **)
type Path = [ { url = String; title = String }* ]
type Tree = { name = String; url = String; title = String;
children = [Tree*]; boxes = [H.Xul?] }
type Path = [ { url=String title=String }* ]
type Tree = { name=String url=String title=String
children=[Tree*] boxes=[H.ul?] }
let url_of_page (Page -> String)
| <page url=u>_ -> u
| <page name=n>_ -> n @ ".html"
| <page url=u ..>_ -> u
| <page name=n ..>_ -> n @ ".html"
let render(a : String)(p : {presenter=?"yes"|"no"}) : H.Flow =
(match p with {presenter="yes"} -> [<strong class="ocaml">a] | _ -> a)
let render(a : String)(p : {presenter=?"yes"|"no" ..}) : H.Flow =
match p with
| {presenter="yes" ..} -> [<strong class="ocaml">a]
| _ -> a
let authors ([Author+] -> H.Flow)
| [ <author (p)>a ] -> render a p
......@@ -161,36 +163,33 @@ let local_link (sitemap : Tree, l : String, txt : String) : [H.Inline?] =
[]
let compute_sitemap ((Page|External) -> Tree)
| <page name=name>[ <title>title (c::(Page|External) | _)* ] & p ->
| <page name=name ..>[ <title>title (c::(Page|External) | _)* ] & p ->
let children = map c with p -> compute_sitemap p in
{ name = name; url = (url_of_page p); title = title;
children = children; boxes = (boxes_of p) }
| <external name=name href=h title=t>[] ->
{ name = name; url = h; title = t; children = []; boxes = [] }
{ name url=(url_of_page p) title children boxes=(boxes_of p) }
| <external name=name href=h title>[] ->
{ name url=h title children=[] boxes=[] }
let ul([H.Xli*] -> [H.Xul?]) [] -> [] | l -> [ <ul>l ]
let ul([H.li*] -> [H.ul?]) [] -> [] | l -> [ <ul>l ]
let ol(([H.Xli*],{|style=?String|}) -> [H.Xol?])
([],_) -> []
| (l,s&{|style=?String|}) -> [ <ol (s)>l ]
let ol(([H.li*],{style=?String}) -> [H.ol?])
| ([],_) -> []
| (l,s) -> [ <ol (s)>l ]
let display_sitemap (h : Tree) : H.Xli =
let display_sitemap (h : Tree) : H.li =
let ch = map h . children with x -> display_sitemap x in
<li>[ <a href=(h . url)>[ '[' !(h . title) ']' ] !(h . boxes); (ul ch) ]
let boxes_of (Page -> [H.Xul?])
<page>[ (items::Item | _)*] & p ->
let boxes_of (Page -> [H.ul?])
<page ..>[ (items::Item | _)*] & p ->
let toc = transform items with
| <box title=t link=l>_ -> [ <li>[ <a href=[ !(url_of_page p) '#' !l ]>t ] ]
in
ul toc
let link_to (<page>[<title>t ; _ ] & p : Page) : H.Xa =
let t = match p with
| <_ new="">_ -> t @ [ <img src="img/new.gif" alt="(new)" style="border:0">[]]
let link_to (<page (r)>[<title>t _* ] & p : Page) : H.a =
let t = match r with
| {new="" ..} -> t @ [ <img src="img/new.gif" alt="(new)" style="border:0">[]]
| _ -> t in
<a href=(url_of_page p)>t
......@@ -306,7 +305,7 @@ let thumbnail(w : String, h : String)
[ <a href=url>[
<img src=url width=w height=h alt="Click to enlarge" title=title>[] ] ]
let thumbwh({ width =? IntStr; height =? IntStr} ->
let thumbwh({ width=?IntStr height=?IntStr ..} ->
(String -> String ->H.Inlines))
| { width = w; height = h } ->
let w = int_of w in let h = int_of h in
......@@ -319,7 +318,7 @@ let gen_page (site : String,
prev : PageO, page : Page, next : PageO,
path : Path, sitemap : Tree) : PageO =
match page with
<page name=name leftbar="false"&(leftbar:=`false) else (leftbar:=`true)>[
<page name=name leftbar="false"&(leftbar:=`false) else (leftbar:=`true) ..>[
(<title>title <banner>banner | <title>(title & banner))
items::_* ] ->
......@@ -335,7 +334,7 @@ match page with
| <code>x -> [ <b>[ <tt>(highlight x) ] ]
| <local href=l>txt -> local_link (sitemap,l,txt)
| <(tag & (`b|`i|`tt|`em)) (attr)>x -> [ <(tag) (attr)>(text x) ]
| <footnote nocount=_>_ ->
| <footnote nocount="true">_ ->
let n = string_of !footnote_counter in
[ <a name=[ 'bnote' !n ]>[]
<a href=[ '#note' !n ]>[ '[' !n ']' ] ]
......@@ -351,9 +350,9 @@ match page with
footnotes := fn @ [ c ] @ !footnotes;
[ <a name=[ 'bnote' !n ]>[]
<a href=[ '#note' !n ]>[ '[' !n ']' ] ]
| <thumbnail ({href=url} & r)>[] ->
| <thumbnail ({href=url ..} & r)>[] ->
thumbwh r url ""
| <thumbnails ({href=url} & r)>l ->
| <thumbnails ({href=url ..} & r)>l ->
let l = split_thumbnails l in
let f = thumbwh r in
let c = ref Int 0 in
......@@ -381,15 +380,15 @@ match page with
[ <a href=f>tit '. ' !(authors aut) '. ' !(text com) ]
| <sample highlight="false">s ->
[ <div class="code">[ <pre>s ] ]
| <sample>s ->
| <sample ..>s ->
[ <div class="code">[ <pre>(highlight s) ] ]
| <xmlsample highlight="false">s ->
[ <div class="xmlcode">[ <pre>s ] ]
| <xmlsample>s ->
| <xmlsample ..>s ->
[ <div class="xmlcode">[ <pre>(highlight s) ] ]
| <sessionsample highlight="false">s ->
[ <div class="session">[ <pre>s ] ]
| <sessionsample>s ->
| <sessionsample ..>s ->
[ <div class="session">[ <pre>(highlight s) ] ]
| <link url=url title=title>com ->
[ <ul>[ <li>[ <a href=url>title '. ' !(text com) ] ] ]
......@@ -397,21 +396,21 @@ match page with
ul (map lis with <li>x -> <li>(content x))
| <ol (attr) >lis ->
ol ((map lis with <li>x -> <li>(content x) ),(attr))
| H.Xtable & x ->
| H.table & x ->
[ <table width="100%">[<tr>[<td align="center">[x]]] ]
| <p (attr)>x -> [ <p (attr)>(text x) ]
| <pages-toc (a)>[] ->
let toc = transform items with
| Page & p ->
let sects = match a with {|sections=_|} -> boxes_of p | _ -> [] in
let sects = match a with {sections=_ ..} -> boxes_of p | _ -> [] in
[ <li>[ (link_to p) ; sects ] ]
| <external href=l title=t>[] -> [ <li>[ <a href=l>t ] ] in
| <external href title=t ..>[] -> [ <li>[ <a href>t ] ] in
ul toc
| <boxes-toc (a)>[] ->
let sections = match a with { section=_ } -> `true | _ -> `false in
let short = match a with { short=_ } -> `true | _ -> `false in
let sections = match a with { sections=_ ..} -> `true | _ -> `false in
let short = match a with { short=_ ..} -> `true | _ -> `false in
let toc = transform items with
| <box ({title=t; link=l} & ({short=s} | {title=s}))>b ->
| <box ({title=t link=l ..} & ({short=s ..} | {title=s ..}))>b ->
let t = if short then s else t in
let sects =
if sections then
......@@ -438,10 +437,10 @@ match page with
| <xhtml>i -> i
| <demo (r)>s ->
demo_no := !demo_no + 1;
let name = match r with { label } -> label | _ -> string_of !demo_no in
let name = match r with { label .. } -> label | _ -> string_of !demo_no in
let prefix =
match r with { prefix = "last" } -> !last_demo
| { prefix } -> prefix
match r with { prefix = "last" .. } -> !last_demo
| { prefix .. } -> prefix
| _ -> "" in
last_demo := name;
demo !demo_no name prefix s
......@@ -466,20 +465,20 @@ match page with
else [] in
let dpath : H.Inlines = transform path with
| { url = f; title = t } -> [ <a href=f>t ': ']
| { url = f title = t } -> [ <a href=f>t ': ']
in
let npath = path @ [ { url = (url_of_page page); title = title } ] in
let subpages = transform items with p & Page -> [ p ] in
let (next,last) = gen_page_seq (site,page, subpages, next, npath, sitemap) in
let next = match next with [] -> []
| <page>[ <title>t; _ ] & p ->
| <page ..>[ <title>t; _ ] & p ->
[ <a href=(url_of_page p)>[
<img width="16" height="16" class="icon" alt="Next page:"
src="img/right.gif">[]
' ' !t
] ] in
let prev = match prev with [] -> []
| <page>[ <title>t; _ ] & p ->
| <page ..>[ <title>t; _ ] & p ->
[ <a href=(url_of_page p)>[
<img width="16" height="16" class="icon"
alt="Previous page:" src="img/left.gif">[]
......@@ -508,7 +507,7 @@ match page with
| [] -> raise "Empty page !"
| x -> x in
let right : H.Xtd =
let right : H.td =
<td valign="top" align="left" style="width:100%">[
<table width="100%">[
<tr>[ <td valign="top" align="left"
......@@ -525,7 +524,7 @@ text-align:center; color: #aa0000; font: bold 200% helvetica" >
] ]
] ] in
let html : H.Xhtml =
let html : H.html =
<html>[
<head>[
<title>[ !site ': ' !title ]
......
web/xhtml-categ.cd
View file @ 1838587d
type Special = Xbr | Xspan | Xbdo | Xmap | Xobject | Ximg;;
type Fontstyle = Xtt | Xi | Xb | Xbig | Xsmall;;
type Phrase = Xem | Xstrong | Xdfn | Xcode | Xq |
Xsamp | Xkbd | Xvar | Xcite | Xabbr | Xacronym | Xsub | Xsup;;
type InlineForms = Xinput | Xselect | Xtextarea | Xlabel | Xbutton;;
type MiscInline = Xins | Xdel | Xscript;;
type Misc = Xnoscript | MiscInline;;
type Inline = Xa | Special | Fontstyle | Phrase | InlineForms;;
type Special = br | span | bdo | map | object | img;;
type Fontstyle = tt | i | b | big | small;;
type Phrase = em | strong | dfn | code | q |
samp | kbd | var | cite | abbr | acronym | sub | sup;;
type InlineForms = input | select | textarea | label | button;;
type MiscInline = ins | del | script;;
type Misc = noscript | MiscInline;;
type Inline = a | Special | Fontstyle | Phrase | InlineForms;;
type Inlines = [ (Char | Inline | MiscInline)* ];;
type Heading = Xh1 | Xh2 | Xh3 | Xh4 | Xh5 | Xh6;;
type Lists = Xul | Xol | Xdl;;
type Blocktext = Xpre | Xhr | Xblockquote | Xaddress;;
type Block = Xp | Heading | Xdiv | Lists | Blocktext | Xfieldset | Xtable;;
type Blocks = [ (Block | Xform | Misc)* ];;
type Heading = h1 | h2 | h3 | h4 | h5 | h6;;
type Lists = ul | ol | dl;;
type Blocktext = pre | hr | blockquote | address;;
type Block = p | Heading | div | Lists | Blocktext | fieldset | table;;
type Blocks = [ (Block | form | Misc)* ];;
type Flow = [ (Char | Block | Xform | Inline | Misc)* ];;
type Flow = [ (Char | Block | form | Inline | Misc)* ];;
web/xhtml-strict.cd
View file @ 1838587d
This diff is collapsed.
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