summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-11-04 09:33:35 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-11-04 09:33:35 -0500
commiteaa8aa9f310d95a31747ea4c81ee1013c1734a7d (patch)
treee40f2a8767966c59e146479de02ec297958fc3c3
parenteb3c0058fd7e3b763d20fa25104493fe9dfb2d18 (diff)
Nested demo
-rw-r--r--demo/crud.ur8
-rw-r--r--demo/nested.ur62
-rw-r--r--demo/nested.urp2
-rw-r--r--demo/nested.urs1
-rw-r--r--demo/prose4
-rw-r--r--src/core_untangle.sml36
-rw-r--r--src/unnest.sml13
7 files changed, 113 insertions, 13 deletions
diff --git a/demo/crud.ur b/demo/crud.ur
index 77fccf16..ee6a95f6 100644
--- a/demo/crud.ur
+++ b/demo/crud.ur
@@ -100,9 +100,9 @@ functor Make(M : sig
sql_exp [] [] [] t.1) cols)]
(fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
[[nm] ~ rest] =>
- fn input col acc => acc with nm = @sql_inject col.Inject (col.Parse input))
+ fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)})
{} [M.cols] inputs M.cols
- with #Id = (SQL {id})));
+ ++ {Id = (SQL {id})}));
ls <- list ();
return <xml><body>
<p>Inserted with ID {[id]}.</p>
@@ -119,8 +119,8 @@ functor Make(M : sig
[] [] t.1) cols)]
(fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
[[nm] ~ rest] =>
- fn input col acc => acc with nm =
- @sql_inject col.Inject (col.Parse input))
+ fn input col acc => acc ++ {nm =
+ @sql_inject col.Inject (col.Parse input)})
{} [M.cols] inputs M.cols)
tab (WHERE T.Id = {id}));
ls <- list ();
diff --git a/demo/nested.ur b/demo/nested.ur
new file mode 100644
index 00000000..31c9e1e8
--- /dev/null
+++ b/demo/nested.ur
@@ -0,0 +1,62 @@
+fun pageA () = return <xml>
+ <head>
+ <title>A</title>
+ </head>
+ <body>
+ <form>
+ <table>
+ <tr>
+ <td>Forename:</td>
+ <td><textbox{#Forename}/></td>
+ </tr>
+ <tr>
+ <td>Enter a Surname?</td>
+ <td><checkbox{#EnterSurname}/></td>
+ </tr>
+ </table>
+ <submit action={fromA} />
+ </form>
+ </body>
+</xml>
+
+and fromA r =
+ let
+ val forename = r.Forename
+
+ fun pageB () = return <xml>
+ <head>
+ <title>B</title>
+ </head>
+ <body>
+ <form>
+ Surname:
+ <textbox{#Surname}/>
+ <submit action={pageC'} />
+ </form>
+ <a link={pageA ()}>Previous</a>
+ </body>
+ </xml>
+
+ and pageC' r = pageC (Some r.Surname)
+
+ and pageC surname = return <xml>
+ <head>
+ <title>C</title>
+ </head>
+ <body>
+ <p>Hello {[forename]}{case surname of
+ None => <xml/>
+ | Some s => <xml> {[s]}</xml>}</p>
+ {case surname of
+ None => <xml><a link={pageA ()}>Previous</a></xml>
+ | Some _ => <xml><a link={pageB ()}>Previous</a></xml>}
+ </body>
+ </xml>
+ in
+ if r.EnterSurname then
+ pageB ()
+ else
+ pageC None
+ end
+
+val main = pageA
diff --git a/demo/nested.urp b/demo/nested.urp
new file mode 100644
index 00000000..179014dc
--- /dev/null
+++ b/demo/nested.urp
@@ -0,0 +1,2 @@
+
+nested
diff --git a/demo/nested.urs b/demo/nested.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/demo/nested.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
diff --git a/demo/prose b/demo/prose
index 3b9d9ebb..06c47722 100644
--- a/demo/prose
+++ b/demo/prose
@@ -54,6 +54,10 @@ form.urp
<p>Here we see a basic form. The type system tracks which form inputs we include, and it enforces that the form handler function expects a record containing exactly those fields, with exactly the proper types.</p>
+nested.urp
+
+<p>Here is an implementation of the tiny challenge problem from <a href="http://www.accursoft.co.uk/web/">this web framework comparison</a>. Using nested function definitions, it is easy to persist state across clicks.</p>
+
listShop.urp
<p>This example shows off algebraic datatypes, parametric polymorphism, and functors.</p>
diff --git a/src/core_untangle.sml b/src/core_untangle.sml
index 6f424614..ededded0 100644
--- a/src/core_untangle.sml
+++ b/src/core_untangle.sml
@@ -45,6 +45,15 @@ fun exp (e, s) =
fun untangle file =
let
+ val edefs = foldl (fn ((d, _), edefs) =>
+ case d of
+ DVal (_, n, _, e, _) => IM.insert (edefs, n, e)
+ | DValRec vis =>
+ foldl (fn ((_, n, _, e, _), edefs) =>
+ IM.insert (edefs, n, e)) edefs vis
+ | _ => edefs)
+ IM.empty file
+
fun decl (dAll as (d, loc)) =
case d of
DValRec vis =>
@@ -52,16 +61,35 @@ fun untangle file =
val thisGroup = foldl (fn ((_, n, _, _, _), thisGroup) =>
IS.add (thisGroup, n)) IS.empty vis
+ val expUsed = U.Exp.fold {con = default,
+ kind = default,
+ exp = exp} IS.empty
+
val used = foldl (fn ((_, n, _, e, _), used) =>
let
- val usedHere = U.Exp.fold {con = default,
- kind = default,
- exp = exp} IS.empty e
+ val usedHere = expUsed e
in
- IM.insert (used, n, IS.intersection (usedHere, thisGroup))
+ IM.insert (used, n, usedHere)
end)
IM.empty vis
+ fun expand used =
+ IS.foldl (fn (n, used) =>
+ case IM.find (edefs, n) of
+ NONE => used
+ | SOME e =>
+ let
+ val usedHere = expUsed e
+ in
+ if IS.isEmpty (IS.difference (usedHere, used)) then
+ used
+ else
+ expand (IS.union (usedHere, used))
+ end)
+ used used
+
+ val used = IM.map (fn s => IS.intersection (expand s, thisGroup)) used
+
fun p_graph reachable =
IM.appi (fn (n, reachableHere) =>
(print (Int.toString n);
diff --git a/src/unnest.sml b/src/unnest.sml
index f226a678..b56daf8a 100644
--- a/src/unnest.sml
+++ b/src/unnest.sml
@@ -137,7 +137,7 @@ fun squishExp (nr, cfv, efv) =
type state = {
maxName : int,
- decls : decl list
+ decls : (string * int * con * exp) list
}
fun kind (k, st) = (k, st)
@@ -278,11 +278,9 @@ fun exp ((ks, ts), e as old, st : state) =
end)
vis
- val d = (DValRec vis, #2 ed)
-
val ts = map (fn (x, _, t, _) => (x, t)) vis @ ts
in
- ([], (ts, maxName, d :: ds, subs))
+ ([], (ts, maxName, vis @ ds, subs))
end)
(ts, #maxName st, #decls st, []) eds
in
@@ -319,8 +317,13 @@ fun unnest file =
fun explore () =
let
val (d, st) = unnestDecl st all
+
+ val ds =
+ case #1 d of
+ DValRec vis => [(DValRec (vis @ #decls st), #2 d)]
+ | _ => [(DValRec (#decls st), #2 d), d]
in
- (rev (d :: #decls st),
+ (ds,
{maxName = #maxName st,
decls = []})
end