summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-10-25 13:02:13 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-10-25 13:02:13 -0400
commit0bdf754b0c5c1ad18b28b4f28c6f90daac1a9994 (patch)
tree47db73312953aa19b756247c6bee8e5888a616e5
parent8d179338f320dfc2b7d6a23204cf1ae90f4898ba (diff)
Extend Fuse to work on non-recursive functions
-rw-r--r--demo/more/conference1.ur2
-rw-r--r--src/fuse.sml78
2 files changed, 51 insertions, 29 deletions
diff --git a/demo/more/conference1.ur b/demo/more/conference1.ur
index b6867728..4cf2ae92 100644
--- a/demo/more/conference1.ur
+++ b/demo/more/conference1.ur
@@ -5,7 +5,7 @@ open Conference.Make(struct
Abstract = abstract}
val review = {Rating = dropdown "Rating" (#"A" :: #"B" :: #"C" :: #"D" :: [])}
- val submissionDeadline = readError "2009-10-22 23:59:59"
+ val submissionDeadline = readError "2009-11-22 23:59:59"
fun summarizePaper r = cdata r.Title
end)
diff --git a/src/fuse.sml b/src/fuse.sml
index ad1958f7..565fc591 100644
--- a/src/fuse.sml
+++ b/src/fuse.sml
@@ -55,38 +55,60 @@ fun fuse file =
let
fun doDecl (d as (_, loc), (funcs, maxName)) =
let
+ exception GetBody
+
+ fun doVi ((x, n, t, e, s), funcs, maxName) =
+ case returnsString t of
+ NONE => (NONE, funcs, maxName)
+ | SOME (args, t') =>
+ let
+ fun getBody (e, args) =
+ case (#1 e, args) of
+ (_, []) => (e, [])
+ | (EAbs (x, t, _, e), _ :: args) =>
+ let
+ val (body, args') = getBody (e, args)
+ in
+ (body, (x, t) :: args')
+ end
+ | _ => raise GetBody
+
+ val (body, args) = getBody (e, args)
+ val body = MonoOpt.optExp (EWrite body, loc)
+ val (body, _) = foldr (fn ((x, dom), (body, ran)) =>
+ ((EAbs (x, dom, ran, body), loc),
+ (TFun (dom, ran), loc)))
+ (body, (TRecord [], loc)) args
+ in
+ (SOME (x, maxName, t', body, s),
+ IM.insert (funcs, n, maxName),
+ maxName + 1)
+ end
+ handle GetBody => (NONE, funcs, maxName)
+
val (d, funcs, maxName) =
case #1 d of
- DValRec vis =>
+ DVal vi =>
+ let
+ val (vi', funcs, maxName) = doVi (vi, funcs, maxName)
+ in
+ (case vi' of
+ NONE => d
+ | SOME vi' => (DValRec [vi, vi'], loc),
+ funcs, maxName)
+ end
+ | DValRec vis =>
let
val (vis', funcs, maxName) =
- foldl (fn ((x, n, t, e, s), (vis', funcs, maxName)) =>
- case returnsString t of
- NONE => (vis', funcs, maxName)
- | SOME (args, t') =>
- let
- fun getBody (e, args) =
- case (#1 e, args) of
- (_, []) => (e, [])
- | (EAbs (x, t, _, e), _ :: args) =>
- let
- val (body, args') = getBody (e, args)
- in
- (body, (x, t) :: args')
- end
- | _ => raise Fail "Fuse: getBody"
-
- val (body, args) = getBody (e, args)
- val body = MonoOpt.optExp (EWrite body, loc)
- val (body, _) = foldr (fn ((x, dom), (body, ran)) =>
- ((EAbs (x, dom, ran, body), loc),
- (TFun (dom, ran), loc)))
- (body, (TRecord [], loc)) args
- in
- ((x, maxName, t', body, s) :: vis',
- IM.insert (funcs, n, maxName),
- maxName + 1)
- end)
+ foldl (fn (vi, (vis', funcs, maxName)) =>
+ let
+ val (vi', funcs, maxName) = doVi (vi, funcs, maxName)
+ in
+ (case vi' of
+ NONE => vis'
+ | SOME vi' => vi' :: vis',
+ funcs, maxName)
+ end)
([], funcs, maxName) vis
in
((DValRec (vis @ vis'), loc), funcs, maxName)