diff options
-rw-r--r-- | demo/batchFun.ur | 1 | ||||
-rw-r--r-- | demo/crud.ur | 1 | ||||
-rw-r--r-- | lib/ur/monad.ur | 7 | ||||
-rw-r--r-- | lib/ur/monad.urs | 2 | ||||
-rw-r--r-- | src/compiler.sml | 10 | ||||
-rw-r--r-- | src/elaborate.sml | 11 | ||||
-rw-r--r-- | src/jscomp.sml | 6 | ||||
-rw-r--r-- | src/monoize.sml | 9 |
8 files changed, 35 insertions, 12 deletions
diff --git a/demo/batchFun.ur b/demo/batchFun.ur index 4243970a..560c0c55 100644 --- a/demo/batchFun.ur +++ b/demo/batchFun.ur @@ -34,7 +34,6 @@ functor Make(M : sig val cols : colsMeta cols end) = struct - open constraints M val t = M.tab datatype list t = Nil | Cons of t * list t diff --git a/demo/crud.ur b/demo/crud.ur index baf157e5..72523a9d 100644 --- a/demo/crud.ur +++ b/demo/crud.ur @@ -42,7 +42,6 @@ functor Make(M : sig val cols : colsMeta cols end) = struct - open constraints M val tab = M.tab sequence seq diff --git a/lib/ur/monad.ur b/lib/ur/monad.ur new file mode 100644 index 00000000..41f44d3a --- /dev/null +++ b/lib/ur/monad.ur @@ -0,0 +1,7 @@ +fun exec [m ::: Type -> Type] (_ : monad m) [ts ::: {Type}] r (fd : folder ts) = + foldR [m] [fn ts => m $ts] + (fn [nm :: Name] [v :: Type] [rest :: {Type}] [[nm] ~ rest] action acc => + this <- action; + others <- acc; + return ({nm = this} ++ others)) + (return {}) [ts] fd r diff --git a/lib/ur/monad.urs b/lib/ur/monad.urs new file mode 100644 index 00000000..cfe0ef8e --- /dev/null +++ b/lib/ur/monad.urs @@ -0,0 +1,2 @@ +val exec : m ::: (Type -> Type) -> monad m -> ts ::: {Type} + -> $(map m ts) -> folder ts -> m $ts diff --git a/src/compiler.sml b/src/compiler.sml index fb5ed0e0..4209426f 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -589,6 +589,8 @@ fun capitalize "" = "" val parse = { func = fn {database, sources = fnames, ffi, ...} : job => let + val anyErrors = ref false + fun checkErrors () = anyErrors := (!anyErrors orelse ErrorMsg.anyErrors ()) fun nameOf fname = capitalize (OS.Path.file fname) fun parseFfi fname = @@ -602,6 +604,7 @@ val parse = { val sgn = (Source.SgnConst (#func parseUrs urs), loc) in + checkErrors (); (Source.DFfiStr (mname, sgn), loc) end @@ -617,6 +620,7 @@ val parse = { {file = urs, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) + before checkErrors () else NONE @@ -626,12 +630,18 @@ val parse = { val ds = #func parseUr ur in + checkErrors (); (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc) end val dsFfi = map parseFfi ffi val ds = map parseOne fnames in + if !anyErrors then + ErrorMsg.error "Parse failure" + else + (); + let val final = nameOf (List.last fnames) diff --git a/src/elaborate.sml b/src/elaborate.sml index 62d99bf3..87c1eb27 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -3355,6 +3355,10 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = end val (env', n) = E.pushStrNamed env x sgn' + val denv' = + case #1 str' of + L'.StrConst _ => dopenConstraints (loc, env', denv) {str = x, strs = []} + | _ => denv in case #1 (hnormSgn env sgn') of L'.SgnFun _ => @@ -3363,7 +3367,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = | _ => strError env (FunctorRebind loc)) | _ => (); - ([(L'.DStr (x, n, sgn', str'), loc)], (env', denv, gs' @ gs)) + ([(L'.DStr (x, n, sgn', str'), loc)], (env', denv', gs' @ gs)) end | L.DFfiStr (x, sgn) => @@ -3721,14 +3725,15 @@ and elabStr (env, denv) (str, loc) = let val (dom', gs1) = elabSgn (env, denv) dom val (env', n) = E.pushStrNamed env m dom' - val (str', actual, gs2) = elabStr (env', denv) str + val denv' = dopenConstraints (loc, env', denv) {str = m, strs = []} + val (str', actual, gs2) = elabStr (env', denv') str val (formal, gs3) = case ranO of NONE => (actual, []) | SOME ran => let - val (ran', gs) = elabSgn (env', denv) ran + val (ran', gs) = elabSgn (env', denv') ran in subSgn env' actual ran'; (ran', gs) diff --git a/src/jscomp.sml b/src/jscomp.sml index e162aa7f..f197ce13 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -374,10 +374,8 @@ fun process file = ((EApp ((ENamed n', loc), e), loc), st) end) - | _ => raise CantEmbed t - (*(EM.errorAt loc "Don't know how to embed type in JavaScript"; - Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)]; - (str loc "ERROR", st))*) + | _ => ((*Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];*) + raise CantEmbed t) fun unurlifyExp loc (t : typ, st) = case #1 t of diff --git a/src/monoize.sml b/src/monoize.sml index 4d7a666e..9654fd53 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2716,11 +2716,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (case List.find (fn ("Source", _, _) => true | _ => false) attrs of NONE => let + val (xml, fm) = monoExp (env, st, fm) xml val (ts, fm) = tagStart "select" in - ((L'.EStrcat (ts, - (L'.EPrim (Prim.String " />"), loc)), - loc), fm) + (strcat [ts, + str ">", + xml, + str "</select>"], + fm) end | SOME (_, src, _) => let |