[r2005-01-06 17:09:37 by afrisch] Demo

Original author: afrisch
Date: 2005-01-06 17:09:38+00:00

driver/evaluator.ml

@@ -39,7 +39,7 @@ let () =
     let v = Location.get_viewport () in
     let ppf = Html.ppf v 
     and input = Stream.of_string src in
-    Format.pp_set_margin ppf 50;
+    Format.pp_set_margin ppf 60;
     Location.push_source (`String src);
     Location.set_protected true;
     Config.init_all ();

types/types.ml

@@ -1522,13 +1522,13 @@ struct
   and do_print_slot_real pri ppf def =
     let rec aux ppf = function
       | [] -> Format.fprintf ppf "Empty"
-      | [ h ] -> do_print ppf h
-      | h :: t -> Format.fprintf ppf "%a |@ %a" do_print h aux t
+      | [ h ] -> (do_print pri) ppf h
+      | h :: t -> Format.fprintf ppf "%a |@ %a" (do_print pri) h aux t
     in
     if (pri >= 2) && (List.length def >= 2) 
     then Format.fprintf ppf "@[(%a)@]" aux def
     else aux ppf def
-  and do_print ppf = function
+  and do_print pri ppf = function
 (*    | Neg { def = [] } -> Format.fprintf ppf "Any" *)
     | Neg t -> Format.fprintf ppf "Any \\ (@[%a@])" (do_print_slot 0) t
     | Abs t -> Format.fprintf ppf "?(@[%a@])" (do_print_slot 0) t
@@ -1556,19 +1556,21 @@ struct
 	(match p with
 	   | [] -> Format.fprintf ppf "Arrow"
 	   | (t,s)::l ->
-	       Format.fprintf ppf "%a" do_print_arrow (t,s);
+	       Format.fprintf ppf "%a" (do_print_arrow pri) (t,s);
 	       List.iter 
 		 (fun (t,s) ->
-		    Format.fprintf ppf " &@ %a" do_print_arrow (t,s)
+		    Format.fprintf ppf " &@ %a" (do_print_arrow pri) (t,s)
 		 ) l);
 	List.iter 
 	  (fun (t,s) ->
-	     Format.fprintf ppf " \\@ %a" do_print_arrow (t,s)
+	     Format.fprintf ppf " \\@ %a" (do_print_arrow pri) (t,s)
 	  ) n
-  and do_print_arrow ppf (t,s) =
+  and do_print_arrow pri ppf (t,s) =
+    if (pri = 3) then Format.fprintf ppf "(";
     Format.fprintf ppf "%a -> %a"
-      (do_print_slot 0) t
-      (do_print_slot 0) s
+      (do_print_slot 3) t
+      (do_print_slot 2) s;
+    if (pri = 3) then Format.fprintf ppf ")"
   and do_print_tag ppf = function
     | `Tag s -> s ppf
     | `Type t -> Format.fprintf ppf "(%a)" (do_print_slot 0) t

typing/typer.ml

@@ -1191,7 +1191,7 @@ and type_check' loc env e constr precise = match e with
   | Check (t0,e,t) ->
       let te = type_check env e Types.any true in
       t0 := Types.cup !t0 te;
-      verify loc (Types.descr t) constr
+      verify loc (Types.cap te (Types.descr t)) constr
 
   | Abstraction a ->
       let t =

web/demo.xml

@@ -6,7 +6,13 @@
 <title>CDuce demo</title>
 
 <box title="Types, pattern matching" link="typpm">
-<demo><include-verbatim file="funxml_types.cd"/><![CDATA[
+<demo><![CDATA[
+type Bib = [ Book* ]
+type Book = <book>[ Title Subtitle? Author+ ]
+type Title = <title>[ PCDATA ]
+type Subtitle = <subtitle>[ PCDATA ]
+type Author = <author>[ PCDATA ]
+
 let title(Book -> String)  <book>[ <title>x _* ] -> x
 let authors(Book -> [Author+]) <_>[ (x::Author|_)* ] -> x
 ]]></demo></box>
@@ -21,7 +27,7 @@ let b2 : Book = <book>[
             <author>[ 'Atkinson' ]
             <author>[ 'Benzaken' ]
             <author>[ 'Maier' ] ]
-let v : Bib = [ b1 b2 ]
+let bib : Bib = [ b1 b2 ]
 ]]></demo></box>
 
 <box title="Printing functions" link="printfun"><demo prefix="last"><![CDATA[
@@ -33,23 +39,40 @@ type ABib = [ ABook* ]
 let set(<book>c : Book)(f : FBook) : ABook = <book print=f>c
 let prepare(b : Bib) : ABib = map b with x -> set x title
 
-let b : Bib = 
- [ <book>[ <title>"T" <subtitle>"S" <author>"A" ] ]
+let abib = prepare bib
+]]></demo></box>
+
+<box title="Display" link="display"><demo prefix="last"><![CDATA[
+type Ul = <ul>[ Li+ ]
+type Li = <li>[ PCDATA ]
 
-let ab = prepare b
+let display (ABib -> Ul; ABook -> Li)
+ | <book print=f>_ & x -> <li>(f x)
+ | [] -> raise "Empty bibliography"
+ | p -> <ul>(map p with z -> display z)
+
+let d = display abib
 ]]></demo></box>
 
+<box title="Changing the style" link="style"><demo prefix="last"><![CDATA[
+let change(p : Book -> Bool)(f : FBook)(b : ABib) : ABib =
+ map b with x -> if (p x) then set x f else x
 
-<!--
-#silent
+type HasSub = <_>[ _* Subtitle _* ]
 
-#verbose
+let subtitle(Book & HasSub -> String) 
+  <book>[ _* <subtitle>x _* ] -> x
 
-let z = authors b1
-]]>
-</demo>
-</box>
--->
+let change_sub = 
+change 
+ (fun (Book -> Bool) HasSub -> `true | _ -> `false)
+ (fun (b : Book) : String = 
+   title b @ ": " @ subtitle (b :? HasSub))
+
+
+
+
+]]></demo></box>
 
 <!--
 <box title="XML elements" link="xml">

web/site.cd

@@ -250,8 +250,13 @@ div.abstract p { font: sans-serif; }
 type PageO = Page | []
 
 
-let button(title : String)(onclick : String) : H:Xinput =
-  <input type="submit" value=title onclick=onclick>[]
+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
@@ -261,10 +266,10 @@ let demo(no : Int)(name : String)(prefix : String)(txt : String) : H:Flow =
   <table style="width:100%">[
    <tr>[ 
     <td style="width:50%">[
-     <input type="button" id=(n@"btn") value="Edit" onclick=("editable('"@n@"','');")>[]
+     (button_id (n@"btn") "Edit" ("editable('"@n@"','');") "")
      (button "Evaluate" ("submit('"@n@"');"))
      (button "Default" ("defreq('"@n@"');"))
-     <input type="button" id=(n@"btnclear") value="Clear" onclick=("clearreq('"@n@"');") style="visibility:hidden;">[]
+     (button_id (n@"btnclear") "Clear" ("clearreq('"@n@"');") "visibility:hidden;")
     ]
     <td style="width:50%">[
      <input id=(n@"def") type="hidden" value=txt>[]