diff options
| -rw-r--r-- | demo/metaform.ur | 28 | ||||
| -rw-r--r-- | demo/metaform.urs | 6 | ||||
| -rw-r--r-- | demo/metaform1.ur | 3 | ||||
| -rw-r--r-- | demo/metaform1.urp | 3 | ||||
| -rw-r--r-- | demo/metaform1.urs | 1 | ||||
| -rw-r--r-- | demo/metaform2.ur | 12 | ||||
| -rw-r--r-- | demo/metaform2.urp | 3 | ||||
| -rw-r--r-- | demo/metaform2.urs | 1 | ||||
| -rw-r--r-- | demo/prose | 4 | ||||
| -rw-r--r-- | lib/top.ur | 20 | ||||
| -rw-r--r-- | lib/top.urs | 12 | ||||
| -rw-r--r-- | src/cjr_print.sml | 3 |
12 files changed, 95 insertions, 1 deletions
diff --git a/demo/metaform.ur b/demo/metaform.ur new file mode 100644 index 00000000..ae1197f4 --- /dev/null +++ b/demo/metaform.ur @@ -0,0 +1,28 @@ +functor Make (M : sig + con fs :: {Unit} + val names : $(mapUT string fs) + end) = struct + + fun handler values = return <xml><body> + {foldURX2 [string] [string] [body] + (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] name value => <xml> + <li> {[name]} = {[value]}</li> + </xml>) + [M.fs] M.names values} + </body></xml> + + fun main () = return <xml><body> + <form> + {foldUR [string] [fn cols :: {Unit} => xml form [] (mapUT string cols)] + (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] name + (acc : xml form [] (mapUT string rest)) => <xml> + <li> {[name]}: <textbox{nm}/></li> + {useMore acc} + </xml>) + <xml/> + [M.fs] M.names} + <submit action={handler}/> + </form> + </body></xml> + +end diff --git a/demo/metaform.urs b/demo/metaform.urs new file mode 100644 index 00000000..7a3fa62e --- /dev/null +++ b/demo/metaform.urs @@ -0,0 +1,6 @@ +functor Make (M : sig + con fs :: {Unit} + val names : $(mapUT string fs) + end) : sig + val main : unit -> transaction page +end diff --git a/demo/metaform1.ur b/demo/metaform1.ur new file mode 100644 index 00000000..c6a4664d --- /dev/null +++ b/demo/metaform1.ur @@ -0,0 +1,3 @@ +open Metaform.Make(struct + val names = {A = "Tic", B = "Tac", C = "Toe"} + end) diff --git a/demo/metaform1.urp b/demo/metaform1.urp new file mode 100644 index 00000000..7f04b9b7 --- /dev/null +++ b/demo/metaform1.urp @@ -0,0 +1,3 @@ + +metaform +metaform1 diff --git a/demo/metaform1.urs b/demo/metaform1.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/demo/metaform1.urs @@ -0,0 +1 @@ +val main : unit -> transaction page diff --git a/demo/metaform2.ur b/demo/metaform2.ur new file mode 100644 index 00000000..430a42f0 --- /dev/null +++ b/demo/metaform2.ur @@ -0,0 +1,12 @@ +structure MM = Metaform.Make(struct + val names = {X = "x", Y = "y"} + end) + +fun diversion () = return <xml><body> + Welcome to the diversion. +</body></xml> + +fun main () = return <xml><body> + <li> <a link={diversion ()}>See something shiny!</a></li> + <li> <a link={MM.main ()}>Fill out a form!</a></li> +</body></xml> diff --git a/demo/metaform2.urp b/demo/metaform2.urp new file mode 100644 index 00000000..debc0448 --- /dev/null +++ b/demo/metaform2.urp @@ -0,0 +1,3 @@ + +metaform +metaform2 diff --git a/demo/metaform2.urs b/demo/metaform2.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/demo/metaform2.urs @@ -0,0 +1 @@ +val main : unit -> transaction page @@ -104,3 +104,7 @@ An unusual part of the third argument is the syntax <tt>[t1 ~ t2]</tt> within a tcSum.urp <p>It's easy to adapt the last example to use type classes, such that we can sum the fields of records based on any numeric type.</p> + +metaform1.urp + +metaform2.urp @@ -36,6 +36,26 @@ fun foldUR (tf :: Type) (tr :: {Unit} -> Type) f [nm] [rest] r.nm (acc (r -- nm))) (fn _ => i) +fun foldUR2 (tf1 :: Type) (tf2 :: Type) (tr :: {Unit} -> Type) + (f : nm :: Name -> rest :: {Unit} + -> fn [[nm] ~ rest] => + tf1 -> tf2 -> tr rest -> tr ([nm] ++ rest)) + (i : tr []) = + fold [fn r :: {Unit} => $(mapUT tf1 r) -> $(mapUT tf2 r) -> tr r] + (fn (nm :: Name) (t :: Unit) (rest :: {Unit}) acc + [[nm] ~ rest] r1 r2 => + f [nm] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm))) + (fn _ _ => i) + +fun foldURX2 (tf1 :: Type) (tf2 :: Type) (ctx :: {Unit}) + (f : nm :: Name -> rest :: {Unit} + -> fn [[nm] ~ rest] => + tf1 -> tf2 -> xml ctx [] []) = + foldUR2 [tf1] [tf2] [fn _ => xml ctx [] []] + (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] v1 v2 acc => + <xml>{f [nm] [rest] v1 v2}{acc}</xml>) + <xml/> + fun foldTR (tf :: Type -> Type) (tr :: {Type} -> Type) (f : nm :: Name -> t :: Type -> rest :: {Type} -> fn [[nm] ~ rest] => diff --git a/lib/top.urs b/lib/top.urs index abdb7477..29a1acf1 100644 --- a/lib/top.urs +++ b/lib/top.urs @@ -29,6 +29,18 @@ val foldUR : tf :: Type -> tr :: ({Unit} -> Type) tf -> tr rest -> tr ([nm] ++ rest)) -> tr [] -> r :: {Unit} -> $(mapUT tf r) -> tr r +val foldUR2 : tf1 :: Type -> tf2 :: Type -> tr :: ({Unit} -> Type) + -> (nm :: Name -> rest :: {Unit} + -> fn [[nm] ~ rest] => + tf1 -> tf2 -> tr rest -> tr ([nm] ++ rest)) + -> tr [] -> r :: {Unit} -> $(mapUT tf1 r) -> $(mapUT tf2 r) -> tr r + +val foldURX2: tf1 :: Type -> tf2 :: Type -> ctx :: {Unit} + -> (nm :: Name -> rest :: {Unit} + -> fn [[nm] ~ rest] => + tf1 -> tf2 -> xml ctx [] []) + -> r :: {Unit} -> $(mapUT tf1 r) -> $(mapUT tf2 r) -> xml ctx [] [] + val foldTR : tf :: (Type -> Type) -> tr :: ({Type} -> Type) -> (nm :: Name -> t :: Type -> rest :: {Type} -> fn [[nm] ~ rest] => diff --git a/src/cjr_print.sml b/src/cjr_print.sml index f2af999b..089f98a1 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1466,7 +1466,8 @@ fun p_file env (ds, ps) = let fun unurlify' rf t = case t of - TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") + TFfi ("Basis", "unit") => string ("uw_unit_v") + | TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") | TRecord 0 => string "uw_unit_v" | TRecord i => |