Advanced examples
This page presents some advanced programming examples in CDuce.If you never saw CDuce programs before, this is the wrong pageto start with. Rather follow our (Tutorial) , or test the simple examples in ouron line demo.
(Our canonical example)
The example below is the one we use to demonstrate how overloaded functions can avoid duplicating code. Without overloaded functions, we would need to define two mutually recursive functions in order to type-check the transformation. Here, two constraints in the (highlighted) function interface can express precisely the behavior of the function. A detailed explanation of the code can be foundhere.
type Person=FPerson | MPerson type FPerson=[ Name Children ] type MPerson= [ Name Children ] type Children= [ Person* ] type Name= [ PCDATA ] type Man= [ Sons Daughters ] type Woman= [ Sons Daughters ] type Sons= [ Man* ] type Daughters= [ Woman* ] let fun split ( (MPerson ->Man; FPerson ->Woman) ) [ n [(mc::MPerson | fc::FPerson)*]] -> the above pattern collects all the MPerson in mc, and all the FPerson in fc let tag=match g with "F" ->`woman | "M" ->`man in let s=map mc with x ->split x in let d=map fc with x ->split x in [ s d ]; ;
Datatypes first-class functions
The program below shows how to simulate ML data types in CDuce. It implements a (naive backtracking) regular expression recognizer. The examples also demonstrate the use of first-class functions (used as continuations).
Exercise for the reader: show that the algorithm may not terminate for some special regular expressions.
type regexp=Char | (regexp, regexp) | (regexp, regexp) | Regexp type f=String ->Bool let loop (re: regexp, k: f): f=fun (s: String): Bool=match re with | p ->(match s with ( c, s) ->(c=p) && (ks) | _ ->`false) | (r1, r2) ->loop (r1, (loop (r2, k))) s | (R1, R2) ->loop (r1, k) s || loop (r2, k) s | (r ->loop) r, (loop (re, k))) s || k s let accept (re: regexp): f= loop (re, fun (String ->Bool) [] ->`true | _ ->` false) let re= ( 'A', 'b') let strs=[ "aaabbb" "abba" "aaab" "a" "" ] let []=print ((string_of (map strs with x ->(x, accept re x))) @ ['n'])
First-class functions and XML together
The program below illustrates the use of first-class functions stored in (pseudo) XML documents.
type Bib=[ Book* ] type Book=[ Title Subtitle? Author ] type Title= [ PCDATA ] type Subtitle=<subtitle>[ PCDATA ] type Author=<author>[ PCDATA ] let title (Book ->String)<book>[<title>x _* ] ->x let author (Book ->[Author ]) x ->x // Author We annotate each book with a printing function for it type FBook=Book ->String type ABook=<book print="FBook">[ Title Subtitle? Author ] type ABib=[ ABook* ] Note that: ABook c: Book) (f: FBook): ABook=<book print="f">c let prepare (b: Bib): ABib=map b with x ->set x title We display the annotated bibliography type Ul=<ul>[ Li ] type Li=[ PCDATA ] let display (ABib ->Ul; ABook ->Li) |<book print="f">_ & x -><li>(fx) | [] ->raise "Empty bibliography" | p -><ul>(map p with z ->display z) We change the dispay function for some books let change (p: Book ->Bool) (f: FBook) (b: ABib): ABib= map b with x ->if (p x) then set x f else x type HasSub=<_>[ _* Subtitle _* ] let change_if_sub= change (fun (Book ->Bool) HasSub ->`true | _ ->` false)</_></ul></li></book></ul></book></book>
(CDuce quine)
A quine (a.k.a. self-rep) is a program that produces its own source code. Here is an example of a quine written in CDuce.
let data=" print ['let data=##' !data '## in']; let fun f (Latin1 ->Latin1) | [ '#' '#'; s ] ->[ '##'; f s ] | [ c; s ] ->[ c; f s ] | [] ->[] in print (f data) "in print ['let data="' !data '" in']; let fun f (Latin1 ->Latin1) | [ '#' '#'; s ] ->[ '"'; f s ] | [ c; s ] ->[ c; f s ] | [] ->[] in print (f data)
The script that generates this site
The script below is one of the longest CDuce application ever written 😉 It is used to produce all the pages of this web site (except Theweb prototypewhich is a CGI script written in OCaml). CDuce type system ensures that produced pages are valid w.r.t XHTML 1.0 Strict.
This program features both XML and text-content manipulation. It also demonstrates the use of non-XML internal data structures. Here, a tree represents internally the site structure, and a list represents the path from the root to the current page (in order to display the “You’re here” line).
This CDuce script produces CDuce web site. The types include "siteTypes.cd" ;; Command line let (input, outdir)= match argv [] with | [ s ("-o" o | /(o :="www")) ] ->(s, o) | _ ->raise "Please use --arg to specify an input file on the command line" Generic purpose functions Recursive inclusion of XML files and verbatim text files let load_include (Latin1 ->[Any*]) name ->let _=print [ 'Loading ' !name '... n' ] in xtransform [ (load_xml name) ] with |[] ->load_include s |[] ->load_file s | [] -> match load_xml ("string:"@ (load_file s) @" ") with x ->x | _ ->raise "Uhh?" Loading let [[site (<header>header | / (header:=[])) (<footer>footer | / (footer:=[])) extra_head :: H.script * main_page]]=match load_include input with [ Site ] & x ->x | _ ->exit 2 try (load_include input:? [ Site ]) with err & Latin1 -> print ['Invalid input document:n' !err 'n']; exit 2 Highlighting text between {{...}} let highlight (String ->[ (Char | H.strong | H.i)* ]) | [ '{{ON}}'; rest ] ->xhighlight rest | [ '{{%%' h ::(Char *?) '%%}}' ; rest ] -> [<strong class="highlight">[<i>h]; highlight rest] | [ '{{' h ::(Char *?) '}}' ; rest ] -> [<strong class="highlight">h; highlight rest ] | [ '$$%%' h ::(Char *?) '%%$$' ; rest ] -> [<strong class="ocaml">[<i>h]; highlight rest] | [ '$$' h ::(Char *?) '$$' ; rest ] -> [<strong class="ocaml">h; highlight rest ] | [ '%%' h ::(Char *?) '%%' ; rest ] -> [<i>h; highlight rest ] | [ c; rest ] ->[ c; highlight rest ] | [] ->[] let xhighlight (String ->[ (Char | H.strong | H.i)* ]) | [ x::('}}' | ':}' | '{{' | '{:') h::Char*? y::('}}' | ':}' | '{:' | '{{'); rest ] -> [ !x<strong class="highlight">h !y; xhighlight rest ] | [ c; rest ] ->[ c; xhighlight rest ] | [] ->[] Split a comma-separated string let split_comma (String ->[String*]) | [ x::(Char*?) ',' ; rest ] ->(x, split_comma rest) | s ->[ s ] type wschar='' | ' n' | ' t' | ' r' let split_thumbnails (String ->[(String,String)*]) | [ wschar* x::(Charwschar':') ':' y::_*? '.'; rest ] -> ((x, y), split_thumbnails rest) | [ wschar* x::(Charwschar) ; rest ] -> ((x, ""), split_thumbnails rest) | [ wschar* ] ->[] Internal types 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" 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>a ] ->render ap | [<author>a1<author>a2 ] -> (render a1 p1) @ ", and" @ (render a2 p2) | [<author>a; rem ] ->(render ap) @ "," @ authors rem let find_local_link (sitemap: [Tree*], l: String): Tree=match sitemap with | (h, t) -> if (h. name=l) then h else (try find_local_link (t, l) with `Not_found -> find_local_link (h. children, l)) | [] ->raise `Not_found let local_link (sitemap: Tree, l: String, txt: String): [H.Inline?]= try let h=find_local_link ([sitemap], l) in let txt=if txt="" then h. title else txt in [<a href="(h" . url>txt ] with `Not_found -> print [ 'Warning. Local link not found: ' !(string_of l) 'n' ]; [] let compute_sitemap ((Page | External) ->Tree) |<page name="name" ..>[<title>title (c::(Page|External) | _)* ] & p -> let children=map c with p ->compute_sitemap p in {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.li*] ->[H.ul?]) [] ->[] l ->[<ul>l ] let ol (([H.li*], {style=? String}) ->[H.ol?]) | ([], _) ->[] | (l, s) ->[</ul><ol>l ] 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.ul?])<page ..>[ (items::Item | _)*] & p -> let toc=transform items with |<box title="t" link="l" ..>_ |<halfwidth_box title="t" link="l" ..>_ -> [<li>[<a href="%5B" p>t]] in ul toc let link_to (<page>[<title>t _* ] & p: Page): Ha= let t=match r with | {new="" ..} ->t @ [<img data-expand="600" class="lazyload" src="data:image/svg+xml;charset=utf-8,%3Csvg xmlns%3D'http%3A%2F%2Fwww.w3.org%2F2000%2Fsvg' viewBox%3D'0 0 1 1'%2F%3E" data-src="http://www.cduce.org/img/new.gif" alt="(new)" style="border:0">[]] | _ ->t in <a href="(url_of_page" p>t let small_box (x: H.Flow): H.Block=<div class="smallbox">x let meta (x: H.Flow): H.Block=<div class="meta">x let box_title (x: H.Flow, a: String, t: String): H.Block= <div id="box" class="span-20">[<h2>[<a name="a">t ]! x] let box (x: H.Flow): H.Block=<div id="box" class="span-20">[ !x ] let hwbox_title (x: H.Flow, a: String, t: String, pos: ("left" | "right")) : H.Block= let class_css=(match pos with "left" ->"span - 10 border "|" right "-> "span - 10 last ") in <div class='("hwbox' class_css>[<h2>[<a name="a">t ]! x] let hwbox (x: H.Flow, pos: ("left" | "right")): H.Block= let class_css=(match pos with "left" ->"span - 10 border "|" right "-> "span - 10 last ") in <div id="hwbox" class="class_css">[ !x ] type PageO=Page | [] let button (title: String) (onclick: String): H.Inline= <input type="submit" style="font-size:8px;" value="title" onclick="onclick">[] let button_id (id: String) (title: String) (onclick: String) (style: String) : H.Inline= <input type="submit" id="id" style='("font-size:8px;"@style)' value="title" onclick="onclick">[] let demo (no: Int) (name: String) (prefix: String) (txt: String): H.Flow= let n=[ 'a' !name '_' ] in let prefix=if prefix="" then "" else [ 'a' !prefix '_' ] in [ !(if (no=1) then [<script src="demo.js" type="text/javascript">" "] else []) <table style="width:100%">[ <tr>[ <td style="width:50%">[ (button_id (n@"btn") "Edit" ("editable('"@n@"','');") "") (button "Evaluate" ("submit('"@n@"');")) (button "Default" ("defreq('"@n@"');")) (button_id (n@"btnclear") "Clear" ("clearreq('"@n@"');") "visibility:hidden;") ] <td style="width:50%">[ <input id=(n@"def") type="hidden" value=txt>[] <input id=(n@"prefix") type="hidden" value=prefix>[] (button "Clear" ("clearres ('" @ n @ "');")) ]] <tr>[ <td valign="top">[ <div id=(n@"container")>[ <pre id=(n@"req")>txt <textarea id=(n@"edit") cols="50" rows="25" style="display:none;border:1px solid #CCCCCC; background-color:#F0F0F0;"> txt ] ] <td valign="top">[<div id=(n@"res")>[]]]] ] Main transformation function returns the last page of the descendance let thumbnail (w: String, h: String) (url: String) (title: String): H.Inlines= [************************************************************************************************************************************************************************************************************************************************************) [ <img src=url width=w height=h alt="Click to enlarge" title=title>[]]] 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 (match h with | 0 ->raise "Thumbnail height=0" | h ->let w=string_of ((w * 200) div h) in thumbnail (w, "200 ")) | _ ->thumbnail ("266 "," 200 ") let gen_page (site: String, prev: PageO, page: Page, next: PageO, path: Path, sitemap: Tree): PageO=match page with<page name=name vertbar="false"&(vertbar:=`false) else (vertbar:=`true) ..>[ <title>title (<banner>banner | / (banner:=[])) (<page_header>page_header | / (page_header:=[])) (<page_footer>page_footer | / (page_footer:=[])) items :: _ *] -> let items=header @ items @ footer in let footnote_counter=ref Int 0 in let footnotes=ref H.Flow [] in let demo_no=ref Int 0 in let last_demo=ref String "" in let text (t: [InlineText*]): H. Inlines= transform t 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="true">_ -> let n=string_of! footnote_counter in [<a name=[ 'bnote' !n ]>[] <a href=[ '#note' !n ]>[ '[' !n '] ']] |<footnote>c -> footnote_counter:=! footnote_counter 1; let n=string_of! footnote_counter in let fn=! footnotes in footnotes:=[]; let c=<p>[<a name=[ 'note' !n ]>[] <a href=[ '#bnote' !n ]>[ '[' !n '] ' ] ''; text c] in footnotes:=fn @ [ c ] @! footnotes; [<a name=[ 'bnote' !n ]>[] <a href=[ '#note' !n ]>[ '[' !n '] ']] |<thumbnail ({href=url ..} & r)>[] -> thumbwh r url "" |<thumbnails ({href=url ..} & r)>l -> let l=split_thumbnails l in let f=thumbwh r in let c=ref Int 0 in (transform l with (x, y) -> let t=f (url @ x) y in if (! c=4) then (c:=1; [<br>[]] @ t) else (c:=! c 1; t)) | z ->[ z ] in let content (t: Content): H.Flow= transform t with |<section title=title>c -> [<h3>title !(content c) ] |<paper (r)>[<title>tit aut::Author*<comment>com<abstract>ab ] -> [ (match r with | { file=f; old="" } -><a class="old" href=f>tit | { file=f } -><a href=f>tit | _ -><b>tit) '. ' !(authors aut) '. ' !(text com) <div class="abstract">[ 'Abstract:' !(content ab) ] ] |<slides file=f>[<title>tit aut::Author*<comment>com ] -> [<a href=f>tit '. ' !(authors aut) '. ' !(text com) ] |<sample highlight="false">s -> [<div class="code">[<pre>s ]] |<sample ..>s -> [<div class="code">[<pre>(highlight s) ]] |<xmlsample highlight="false">s -> [<div class="xmlcode">[<pre>s ]] |<xmlsample ..>s -> [<div class="xmlcode">[<pre>(highlight s) ]] |<sessionsample highlight="false">-> [<div class="session">[<pre>s ]] |<sessionsample ..>-> [<div class="session">[<pre>(highlight s) ]] |<link url=url title=title>com -> [<ul>[<li>[<a href=url>title '. ' !(text com) ]]] |<ul>lis -> ul (map lis with<li>x -><li>(content x)) |<ol (attr)>lis -> ol ((map lis with<li>x -><li>(content x)), (attr)) | H.table & x -> [<table width="100%">[<tr>[<td align="center">[x]]]] | (x ->) |<pages-toc (a)>[] -> let toc=transform items with | Page & p -> let sects=match a with {sections=_ ..} ->boxes_of p | _ ->[] in [<li>[ (link_to p) ; sects ]] |<external href title=t ..>[] ->[<li>[<a href>t ]] in ul toc |<boxes-toc (a)>[] -> let sections=match a with {sections=_ ..} ->`true | _ ->`false in let short=match a with {short=_ ..} ->`true | _ ->`false in let toc=transform items with | b |<halfwidth_box ({title=t link=l ..} & ({short=s ..} | {title=s ..}))>b -> let t=if short then s else t in let sects= if sections then (transform b with<section title=t>_ ->[<br>[] '-'! t ]) else [] in [<li>[<a href=('#',l)>t !sects ]] in ul toc |<site-toc>[] -> [<ul>[ (display_sitemap sitemap) ]] |<local-links href=s>[] -> ul (transform (split_comma s) with x -> match local_link (sitemap, x, "") with [] ->[] | x ->[<li>x]) |<two-columns>[<left>x<right>y ] ->[<table width="100%">[ <tr>[ <td valign="top">(content x) <td valign="top">(content y) ]]] |<note title=t>c ->[<div class="note">[<b>[!t ': ']! (content c)]] |<note>c ->[<div class="note">[<b>"Note: " !(content c) ]] |<footnotes>[] -> (match! footnotes with | [] ->[] | n ->footnotes:=[]; [*******************************************************************************************************************************************************************************************************************************************************************************) [] (meta n)]) |<xhtml>i ->i |<demo (r)>s -> demo_no:=! demo_no 1; let name=match r with {label ..} ->label | _ -> string_of! demo_no in let prefix= match r with {prefix="last" ..} ->! last_demo | {prefix ..} ->prefix | _ ->"" in last_demo:=name; demo! demo_no name prefix s | t ->text [ t ] in Preparing left panel let vertical= if vertbar then let navig=transform items with<left>c ->[ c ] in let vert=match navig with [] ->[[<boxes-toc>[]]] | n ->n in [ <div class="span-4 small last" id="vertical_bar">[ <div class="box">[!(map vert with x ->small_box ( content x ) ) ] ] ] else [] in let dpath: H.Inlines=transform path with | {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 -> [****************************************************************************************************************************************************************************************************************************************) [ <img data-expand="600" loading="lazy" width="16" height="16" class="lazyload icon" alt="Next page:" src="data:image/svg+xml;charset=utf-8,%3Csvg xmlns%3D'http%3A%2F%2Fwww.w3.org%2F2000%2Fsvg' viewBox%3D'0 0 16 16'%2F%3E" data-src="img/right.gif">[] ''! t ]] in let prev=match prev with [] ->[] |<page ..>[<title>t; _ ] & p -> [****************************************************************************************************************************************************************************************************************************************) [ <img data-expand="600" loading="lazy" width="16" height="16" class="lazyload icon" alt="Previous page:" src="data:image/svg+xml;charset=utf-8,%3Csvg xmlns%3D'http%3A%2F%2Fwww.w3.org%2F2000%2Fsvg' viewBox%3D'0 0 16 16'%2F%3E" data-src="img/left.gif">[] ''! t ]] in let navig= if prev=[] then [] else [ (small_box [ <p>[ !dpath !title ] <p>[ !prev ' ' !next ]])] in Preparing main panel let main=transform items with |<box title=t link=l ..>c ->[ (box_title (content c, l, t)) ] | (c ->[ (box (content c)) ] |<halfwidth_box title=t link=l position=p ..>c ->[ (hwbox_title (content c, l, t, p)) ] |<halfwidth_box position=p>c ->[ (hwbox (content c, p)) ] |<footnotes>[] -> (match! footnotes with | [] ->[] | n ->footnotes:=[]; [ (meta n) ]) |<meta>c ->[ (meta (content c)) ] in let notes=match! footnotes with | [] ->[] | n ->[ (meta n) ] in let main=match (navig @ main @ notes @ navig) with | [] ->raise "Empty page!" | x ->x in let right= [<h1>(text banner) <div class="mainpanel">[ !main ]] in let center=[ !main ] in let global_header=transform header with |<global_header>g ->(content g) in let top_header= match page_header with [] ->[<div id="header" class="span-24 last">[ <div id="title" class="span-24 last">[ <h1>title ]<div id="global_bar" class="span-24 last meta">[ !global_header ] ] ] | _ ->[<div id="header" class="span-24 last">[ <div id="title" class="span-12 append-1">[ <h1>title ]<div id="page_header" class="span-11 last">[ !page_header ]<div id="global_bar" class="span-24 last meta">[ !global_header ] ] ] in let html: H.html= <html xmlns="http://www.w3.org/1999/xhtml">[<head>[ <title>[ !site ': ' !title ] <meta content="text/html; charset=UTF-8" http-equiv="Content-Type">[] <link rel="stylesheet" href="css/screen.css" type="text/css" media="screen, projection">[]<link rel="stylesheet" href="css/print.css" type="text/css" media="print">[] <link rel="stylesheet" href="css/screen.css" type="text/css" media="screen, projection">[] <link rel="stylesheet" href="cduce.css" type="text/css">[] ! extra_head <script type="text/javascript"> "var _gaq=_gaq || []; _gaq.push (['_setAccount', 'UA-15579826-1']); _gaq.push (['_trackPageview']); (function () { var ga=document.createElement ('script'); ga.type='text / javascript'; ga.async=true; ga.src=('https:'==document.location.protocol? 'https: // ssl': 'http: // www') '.google-analytics.com / ga.js'; var s=document.getElementsByTagName ('script') [0]; s.parentNode.insertBefore (ga, s); }) (); " ] <body>[ <div class="container">[ !top_header <div id="main" class="span-20">[ !center ] ! vertical<div id="page_footer" class="span-20">[ !page_footer ] ] ] ] <body style="margin: 0; padding : 0;">[ <table cellspacing="10" cellpadding="0" width="100%" border="0">[<tr>[ !left<td>right ] ] ] ] in let txt: Latin1= [ '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"' ' "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">' !(print_xml html) ] in let fn=outdir @ "/" @ name @ ".html" in dump_to_file fn txt; last let gen_page_seq (site: String, prev: PageO, pages: [Page*], next: PageO, path: Path, sitemap: Tree): (PageO, PageO)= match pages with | [ p1 p2 ; _ ] & [ _; rest ] -> let last=gen_page (site, prev, p1, p2, path, sitemap) in let (_, last)=gen_page_seq (site, last, rest, next, path, sitemap) in (p1, last) | [ p ] -> let last=gen_page (site, prev, p, next, path, sitemap) in (p, last) | [] ->(next, prev) ;; gen_page (site, [], main_page, [], [], compute_sitemap main_page)</script></div></a></h2></div></div><br></a><a href="https://brave.com/air823" target="_blank" rel="noopener noreferrer"><img data-expand="600" class="lazyload" src="data:image/svg+xml;charset=utf-8,%3Csvg xmlns%3D'http%3A%2F%2Fwww.w3.org%2F2000%2Fsvg' viewBox%3D'0 0 1 1'%2F%3E" data-src="http://www.airdropads.com/wp-content/uploads/2019/06/brave-browser.gif" alt="Brave Browser"></a><br>(Read More)<br><a href="https://payeer.com/01575879" target="_blank" rel="noopener noreferrer"><img data-expand="600" class="lazyload" src="data:image/svg+xml;charset=utf-8,%3Csvg xmlns%3D'http%3A%2F%2Fwww.w3.org%2F2000%2Fsvg' viewBox%3D'0 0 1 1'%2F%3E" data-src="https://payeer.com/style/images/banner/en/728x90.gif" alt="Payeer"></a></h2></div></div></div></a>
GIPHY App Key not set. Please check settings