Tuesday , April 20 2021

CDuce: XML-oriented functional language, Hacker News


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       [sd ]; ;

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 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=[<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 loading="lazy" width="16" height="16" class="icon" alt="Next page:"               src="img/right.gif">[]           ''! t         ]] in  let prev=match prev with [] ->[]    |<page ..>[<title>t; _ ] & p ->      [****************************************************************************************************************************************************************************************************************************************) [           <img loading="lazy" width="16" height="16" class="icon"               alt="Previous page:" src="img/left.gif">[]           ''! t         ]] in  let navig=   if prev=[] then [] else    [ (small_box [   [ !dpath !title ]      [ !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 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 src="https://payeer.com/style/images/banner/en/728x90.gif" alt="Payeer"></a></h2></div></div></div></a>

About admin

Leave a Reply

Your email address will not be published. Required fields are marked *