diff options
| -rw-r--r-- | demo/crud.ur | 8 | ||||
| -rw-r--r-- | demo/nested.ur | 62 | ||||
| -rw-r--r-- | demo/nested.urp | 2 | ||||
| -rw-r--r-- | demo/nested.urs | 1 | ||||
| -rw-r--r-- | demo/prose | 4 | ||||
| -rw-r--r-- | src/core_untangle.sml | 36 | ||||
| -rw-r--r-- | src/unnest.sml | 13 |
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 @@ -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 |