From da7b52ba28367cf2b31476e77e1a26e53e4765e4 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 23 Oct 2008 17:35:10 -0400 Subject: Fix bug with bringing functor argument instances into scope; Ref demo, minus prose --- src/elab_env.sml | 105 ++++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 73 insertions(+), 32 deletions(-) (limited to 'src/elab_env.sml') diff --git a/src/elab_env.sml b/src/elab_env.sml index 958d369c..edda9f38 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -159,10 +159,11 @@ val empty_class = { ground = KM.empty } -fun printClasses cs = CM.appi (fn (cn, {ground = km}) => - (print (cn2s cn ^ ":"); - KM.appi (fn (ck, _) => print (" " ^ ck2s ck)) km; - print "\n")) cs +fun printClasses cs = (print "Classes:\n"; + CM.appi (fn (cn, {ground = km}) => + (print (cn2s cn ^ ":"); + KM.appi (fn (ck, _) => print (" " ^ ck2s ck)) km; + print "\n")) cs) type env = { renameC : kind var' SM.map, @@ -743,34 +744,74 @@ fun enrichClasses env classes (m1, ms) sgn = | SgiClassAbs xn => found xn | SgiClass (x, n, _) => found (x, n) - | SgiVal (x, n, (CApp ((CNamed f, _), a), _)) => - (case IM.find (newClasses, f) of - NONE => default () - | SOME fx => - case class_key_in (sgnS_con' (m1, ms, fmap) (#1 a), #2 a) of - NONE => default () - | SOME ck => - let - val cn = ClProj (m1, ms, fx) - - val classes = - case CM.find (classes, cn) of - NONE => classes - | SOME class => - let - val class = { - ground = KM.insert (#ground class, ck, - (EModProj (m1, ms, x), #2 sgn)) - } - in - CM.insert (classes, cn, class) - end - in - (classes, - newClasses, - fmap, - env) - end) + | SgiVal (x, n, (CApp (f, a), _)) => + let + fun unravel c = + case #1 c of + CUnif (_, _, _, ref (SOME c)) => unravel c + | CNamed n => + ((case lookupCNamed env n of + (_, _, SOME c) => unravel c + | _ => c) + handle UnboundNamed _ => c) + | _ => c + + val nc = + case f of + (CNamed f, _) => IM.find (newClasses, f) + | _ => NONE + in + case nc of + NONE => + (case (class_name_in (unravel f), + class_key_in (sgnS_con' (m1, ms, fmap) (#1 a), #2 a)) of + (SOME cn, SOME ck) => + let + val classes = + case CM.find (classes, cn) of + NONE => classes + | SOME class => + let + val class = { + ground = KM.insert (#ground class, ck, + (EModProj (m1, ms, x), #2 sgn)) + } + in + CM.insert (classes, cn, class) + end + in + (classes, + newClasses, + fmap, + env) + end + | _ => default ()) + | SOME fx => + case class_key_in (sgnS_con' (m1, ms, fmap) (#1 a), #2 a) of + NONE => default () + | SOME ck => + let + val cn = ClProj (m1, ms, fx) + + val classes = + case CM.find (classes, cn) of + NONE => classes + | SOME class => + let + val class = { + ground = KM.insert (#ground class, ck, + (EModProj (m1, ms, x), #2 sgn)) + } + in + CM.insert (classes, cn, class) + end + in + (classes, + newClasses, + fmap, + env) + end + end | SgiVal _ => default () | _ => default () end) -- cgit v1.2.3 From 3f497272d327fea2638006c751d812dbbc449c78 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 1 Nov 2008 11:17:29 -0400 Subject: Elaborating 'let' --- src/elab.sml | 7 +++++ src/elab_env.sig | 1 + src/elab_env.sml | 5 +++ src/elab_print.sml | 61 +++++++++++++++++++++++++++++++----- src/elab_util.sml | 42 +++++++++++++++++++++++++ src/elaborate.sml | 91 +++++++++++++++++++++++++++++++++++++++++++++++------- tests/let.ur | 4 ++- 7 files changed, 192 insertions(+), 19 deletions(-) (limited to 'src/elab_env.sml') diff --git a/src/elab.sml b/src/elab.sml index 4202d367..b5350c2a 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -117,7 +117,14 @@ datatype exp' = | EError | EUnif of exp option ref + | ELet of edecl list * exp + +and edecl' = + EDVal of string * con * exp + | EDValRec of (string * con * exp) list + withtype exp = exp' located + and edecl = edecl' located datatype sgn_item' = SgiConAbs of string * int * kind diff --git a/src/elab_env.sig b/src/elab_env.sig index 363cbe26..727ee259 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -85,6 +85,7 @@ signature ELAB_ENV = sig val lookupStr : env -> string -> (int * Elab.sgn) option + val edeclBinds : env -> Elab.edecl -> env val declBinds : env -> Elab.decl -> env val sgiBinds : env -> Elab.sgn_item -> env diff --git a/src/elab_env.sml b/src/elab_env.sml index edda9f38..f4f5d2cb 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1075,6 +1075,11 @@ fun projectConstraints env {sgn, str} = | SgnError => SOME [] | _ => NONE +fun edeclBinds env (d, loc) = + case d of + EDVal (x, t, _) => pushERel env x t + | EDValRec vis => foldl (fn ((x, t, _), env) => pushERel env x t) env vis + fun declBinds env (d, loc) = case d of DCon (x, n, k, c) => pushCNamedAs env x n k (SOME c) diff --git a/src/elab_print.sml b/src/elab_print.sml index 8c0b41f7..3d7ce625 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -378,15 +378,52 @@ fun p_exp' par env (e, _) = | EUnif (ref (SOME e)) => p_exp env e | EUnif _ => string "_" + | ELet (ds, e) => + let + val (dsp, env) = ListUtil.foldlMap + (fn (d, env) => + (p_edecl env d, + E.edeclBinds env d)) + env ds + in + box [string "let", + newline, + box [p_list_sep newline (fn x => x) dsp], + newline, + string "in", + newline, + box [p_exp env e], + newline, + string "end"] + end + and p_exp env = p_exp' false env -fun p_named x n = - if !debug then - box [string x, - string "__", - string (Int.toString n)] - else - string x +and p_edecl env (dAll as (d, _)) = + case d of + EDVal vi => box [string "val", + space, + p_evali env vi] + | EDValRec vis => + let + val env = E.edeclBinds env dAll + in + box [string "val", + space, + string "rec", + space, + p_list_sep (box [newline, string "and", space]) (p_evali env) vis] + end + +and p_evali env (x, t, e) = box [string x, + space, + string ":", + space, + p_con env t, + space, + string "=", + space, + p_exp env e] fun p_datatype env (x, n, xs, cons) = let @@ -407,6 +444,14 @@ fun p_datatype env (x, n, xs, cons) = cons] end +fun p_named x n = + if !debug then + box [string x, + string "__", + string (Int.toString n)] + else + string x + fun p_sgn_item env (sgi, _) = case sgi of SgiConAbs (x, n, k) => box [string "con", @@ -556,6 +601,8 @@ fun p_vali env (x, n, t, e) = box [p_named x n, space, p_exp env e] + + fun p_decl env (dAll as (d, _) : decl) = case d of DCon (x, n, k, c) => box [string "con", diff --git a/src/elab_util.sml b/src/elab_util.sml index 247e2b3a..28fe8f22 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -352,6 +352,48 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = | EError => S.return2 eAll | EUnif (ref (SOME e)) => mfe ctx e | EUnif _ => S.return2 eAll + + | ELet (des, e) => + let + val (des, ctx) = foldl (fn (ed, (des, ctx)) => + (S.bind2 (des, + fn des' => + S.map2 (mfed ctx ed, + fn ed' => des' @ [ed'])), + case #1 ed of + EDVal (x, t, _) => bind (ctx, RelE (x, t)) + | EDValRec vis => + foldl (fn ((x, t, _), env) => bind (ctx, RelE (x, t))) ctx vis)) + (S.return2 [], ctx) des + in + S.bind2 (des, + fn des' => + S.map2 (mfe ctx e, + fn e' => + (ELet (des', e'), loc))) + end + + and mfed ctx (dAll as (d, loc)) = + case d of + EDVal vi => + S.map2 (mfvi ctx vi, + fn vi' => + (EDVal vi', loc)) + | EDValRec vis => + let + val ctx = foldl (fn ((x, t, _), env) => bind (ctx, RelE (x, t))) ctx vis + in + S.map2 (ListUtil.mapfold (mfvi ctx) vis, + fn vis' => + (EDValRec vis', loc)) + end + + and mfvi ctx (x, c, e) = + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfe ctx e, + fn e' => + (x, c', e'))) in mfe end diff --git a/src/elaborate.sml b/src/elaborate.sml index 4927e37d..38c03f6e 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1400,6 +1400,18 @@ fun normClassConstraint envs (c, loc) = end | _ => ((c, loc), []) + +val makeInstantiable = + let + fun kind k = k + fun con c = + case c of + L'.CDisjoint (L'.LeaveAlone, c1, c2, c) => L'.CDisjoint (L'.Instantiate, c1, c2, c) + | _ => c + in + U.Con.map {kind = kind, con = con} + end + fun elabExp (env, denv) (eAll as (e, loc)) = let (*val () = eprefaces "elabExp" [("eAll", SourcePrint.p_exp eAll)];*) @@ -1670,11 +1682,79 @@ fun elabExp (env, denv) (eAll as (e, loc)) = ((L'.ECase (e', pes', {disc = et, result = result}), loc), result, enD gs' @ gs) end + + | L.ELet (eds, e) => + let + val (eds, (env, gs1)) = ListUtil.foldlMap (elabEdecl denv) (env, []) eds + val (e, t, gs2) = elabExp (env, denv) e + in + ((L'.ELet (eds, e), loc), t, gs1 @ gs2) + end in (*prefaces "/elabExp" [("e", SourcePrint.p_exp eAll)];*) r end +and elabEdecl denv (dAll as (d, loc), (env, gs : constraint list)) = + let + val r = + case d of + L.EDVal (x, co, e) => + let + val (c', _, gs1) = case co of + NONE => (cunif (loc, ktype), ktype, []) + | SOME c => elabCon (env, denv) c + + val (e', et, gs2) = elabExp (env, denv) e + val gs3 = checkCon (env, denv) e' et c' + val (c', gs4) = normClassConstraint (env, denv) c' + val env' = E.pushERel env x c' + val c' = makeInstantiable c' + in + ((L'.EDVal (x, c', e'), loc), (env', enD gs1 @ gs2 @ enD gs3 @ enD gs4 @ gs)) + end + | L.EDValRec vis => + let + fun allowable (e, _) = + case e of + L.EAbs _ => true + | L.ECAbs (_, _, _, e) => allowable e + | L.EDisjoint (_, _, e) => allowable e + | _ => false + + val (vis, gs) = ListUtil.foldlMap + (fn ((x, co, e), gs) => + let + val (c', _, gs1) = case co of + NONE => (cunif (loc, ktype), ktype, []) + | SOME c => elabCon (env, denv) c + in + ((x, c', e), enD gs1 @ gs) + end) gs vis + + val env = foldl (fn ((x, c', _), env) => E.pushERel env x c') env vis + + val (vis, gs) = ListUtil.foldlMap (fn ((x, c', e), gs) => + let + val (e', et, gs1) = elabExp (env, denv) e + + val gs2 = checkCon (env, denv) e' et c' + + val c' = makeInstantiable c' + in + if allowable e then + () + else + expError env (IllegalRec (x, e')); + ((x, c', e'), gs1 @ enD gs2 @ gs) + end) gs vis + in + ((L'.EDValRec vis, loc), (env, gs)) + end + in + r + end + val hnormSgn = E.hnormSgn fun tableOf () = (L'.CModProj (!basis_r, [], "sql_table"), ErrorMsg.dummySpan) @@ -2742,17 +2822,6 @@ fun wildifyStr env (str, sgn) = | _ => str) | _ => str -val makeInstantiable = - let - fun kind k = k - fun con c = - case c of - L'.CDisjoint (L'.LeaveAlone, c1, c2, c) => L'.CDisjoint (L'.Instantiate, c1, c2, c) - | _ => c - in - U.Con.map {kind = kind, con = con} - end - fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = let (*val () = preface ("elabDecl", SourcePrint.p_decl (d, loc))*) diff --git a/tests/let.ur b/tests/let.ur index 45d52ded..14dc936c 100644 --- a/tests/let.ur +++ b/tests/let.ur @@ -1,6 +1,8 @@ fun main () : transaction page = let val x = 1 + val y = "Hello" + val z = 3.45 in - return {[x]} + return {[x]}, {[y]}, {[z]} end -- cgit v1.2.3 From cfb8ffaf94885d8dc1b492a050830a9b4ffc3d04 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 1 Nov 2008 15:58:55 -0400 Subject: First Unnest tests working --- src/compiler.sig | 2 + src/compiler.sml | 9 +- src/elab_env.sig | 4 + src/elab_env.sml | 29 +++++ src/elab_print.sml | 4 +- src/elab_util.sig | 25 ++++ src/elab_util.sml | 107 ++++++++++++++- src/sources | 3 + src/termination.sml | 2 + src/unnest.sig | 34 +++++ src/unnest.sml | 369 ++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/nest.ur | 41 ++++++ tests/nest.urp | 3 + 13 files changed, 627 insertions(+), 5 deletions(-) create mode 100644 src/unnest.sig create mode 100644 src/unnest.sml create mode 100644 tests/nest.ur create mode 100644 tests/nest.urp (limited to 'src/elab_env.sml') diff --git a/src/compiler.sig b/src/compiler.sig index e26ec13c..bc1974a1 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -58,6 +58,7 @@ signature COMPILER = sig val parse : (job, Source.file) phase val elaborate : (Source.file, Elab.file) phase + val unnest : (Elab.file, Elab.file) phase val termination : (Elab.file, Elab.file) phase val explify : (Elab.file, Expl.file) phase val corify : (Expl.file, Core.file) phase @@ -80,6 +81,7 @@ signature COMPILER = sig val toParseJob : (string, job) transform val toParse : (string, Source.file) transform val toElaborate : (string, Elab.file) transform + val toUnnest : (string, Elab.file) transform val toTermination : (string, Elab.file) transform val toExplify : (string, Expl.file) transform val toCorify : (string, Core.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 4f1bce11..e92f86c3 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -383,12 +383,19 @@ val elaborate = { val toElaborate = transform elaborate "elaborate" o toParse +val unnest = { + func = Unnest.unnest, + print = ElabPrint.p_file ElabEnv.empty +} + +val toUnnest = transform unnest "unnest" o toElaborate + val termination = { func = (fn file => (Termination.check file; file)), print = ElabPrint.p_file ElabEnv.empty } -val toTermination = transform termination "termination" o toElaborate +val toTermination = transform termination "termination" o toUnnest val explify = { func = Explify.explify, diff --git a/src/elab_env.sig b/src/elab_env.sig index 727ee259..90cf8153 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -30,6 +30,10 @@ signature ELAB_ENV = sig exception SynUnif val liftConInCon : int -> Elab.con -> Elab.con + val liftExpInExp : int -> Elab.exp -> Elab.exp + + val subExpInExp : (int * Elab.exp) -> Elab.exp -> Elab.exp + type env val empty : env diff --git a/src/elab_env.sml b/src/elab_env.sml index f4f5d2cb..2732de13 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -61,6 +61,20 @@ val liftConInCon = val lift = liftConInCon 0 +val liftConInExp = + U.Exp.mapB {kind = fn k => k, + con = fn bound => fn c => + case c of + CRel xn => + if xn < bound then + c + else + CRel (xn + 1) + | _ => c, + exp = fn _ => fn e => e, + bind = fn (bound, U.Exp.RelC _) => bound + 1 + | (bound, _) => bound} + val liftExpInExp = U.Exp.mapB {kind = fn k => k, con = fn _ => fn c => c, @@ -78,6 +92,21 @@ val liftExpInExp = val liftExp = liftExpInExp 0 +val subExpInExp = + U.Exp.mapB {kind = fn k => k, + con = fn _ => fn c => c, + exp = fn (xn, rep) => fn e => + case e of + ERel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 rep + | GREATER=> ERel (xn' - 1) + | LESS => e) + | _ => e, + bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep) + | ((xn, rep), U.Exp.RelC _) => (xn, liftConInExp 0 rep) + | (ctx, _) => ctx} + (* Back to environments *) datatype 'a var' = diff --git a/src/elab_print.sml b/src/elab_print.sml index 3d7ce625..b236954e 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -198,7 +198,7 @@ fun p_patCon env pc = string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) else string (#1 (E.lookupENamed env n))) - handle E.UnboundRel _ => string ("UNBOUND_NAMED" ^ Int.toString n)) + handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n)) | PConProj (m1, ms, x) => let val m1x = #1 (E.lookupStrNamed env m1) @@ -247,7 +247,7 @@ fun p_exp' par env (e, _) = string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) else string (#1 (E.lookupENamed env n))) - handle E.UnboundRel _ => string ("UNBOUND_NAMED" ^ Int.toString n)) + handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n)) | EModProj (m1, ms, x) => let val m1x = #1 (E.lookupStrNamed env m1) diff --git a/src/elab_util.sig b/src/elab_util.sig index f4edd972..f9988981 100644 --- a/src/elab_util.sig +++ b/src/elab_util.sig @@ -57,6 +57,11 @@ structure Con : sig -> Elab.con -> Elab.con val exists : {kind : Elab.kind' -> bool, con : Elab.con' -> bool} -> Elab.con -> bool + + val foldB : {kind : Elab.kind' * 'state -> 'state, + con : 'context * Elab.con' * 'state -> 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Elab.con -> 'state end structure Exp : sig @@ -83,6 +88,12 @@ structure Exp : sig val exists : {kind : Elab.kind' -> bool, con : Elab.con' -> bool, exp : Elab.exp' -> bool} -> Elab.exp -> bool + + val foldB : {kind : Elab.kind' * 'state -> 'state, + con : 'context * Elab.con' * 'state -> 'state, + exp : 'context * Elab.exp' * 'state -> 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Elab.exp -> 'state end structure Sgn : sig @@ -156,6 +167,20 @@ structure Decl : sig str : Elab.str' -> 'a option, decl : Elab.decl' -> 'a option} -> Elab.decl -> 'a option + + val foldMapB : {kind : Elab.kind' * 'state -> Elab.kind' * 'state, + con : 'context * Elab.con' * 'state -> Elab.con' * 'state, + exp : 'context * Elab.exp' * 'state -> Elab.exp' * 'state, + sgn_item : 'context * Elab.sgn_item' * 'state -> Elab.sgn_item' * 'state, + sgn : 'context * Elab.sgn' * 'state -> Elab.sgn' * 'state, + str : 'context * Elab.str' * 'state -> Elab.str' * 'state, + decl : 'context * Elab.decl' * 'state -> Elab.decl' * 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Elab.decl -> Elab.decl * 'state +end + +structure File : sig + val maxName : Elab.file -> int end end diff --git a/src/elab_util.sml b/src/elab_util.sml index 28fe8f22..2e190d1e 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -226,6 +226,13 @@ fun exists {kind, con} k = S.Return _ => true | S.Continue _ => false +fun foldB {kind, con, bind} ctx st c = + case mapfoldB {kind = fn k => fn st => S.Continue (k, kind (k, st)), + con = fn ctx => fn c => fn st => S.Continue (c, con (ctx, c, st)), + bind = bind} ctx c st of + S.Continue (_, st) => st + | S.Return _ => raise Fail "ElabUtil.Con.foldB: Impossible" + end structure Exp = struct @@ -340,8 +347,20 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = S.bind2 (mfe ctx e, fn e' => S.bind2 (ListUtil.mapfold (fn (p, e) => - S.map2 (mfe ctx e, - fn e' => (p, e'))) pes, + let + fun pb ((p, _), ctx) = + case p of + PWild => ctx + | PVar (x, t) => bind (ctx, RelE (x, t)) + | PPrim _ => ctx + | PCon (_, _, _, NONE) => ctx + | PCon (_, _, _, SOME p) => pb (p, ctx) + | PRecord xps => foldl (fn ((_, p, _), ctx) => + pb (p, ctx)) ctx xps + in + S.map2 (mfe (pb (p, ctx)) e, + fn e' => (p, e')) + end) pes, fn pes' => S.bind2 (mfc ctx disc, fn disc' => @@ -431,6 +450,14 @@ fun mapB {kind, con, exp, bind} ctx e = S.Continue (e, ()) => e | S.Return _ => raise Fail "ElabUtil.Exp.mapB: Impossible" +fun foldB {kind, con, exp, bind} ctx st e = + case mapfoldB {kind = fn k => fn st => S.Continue (k, kind (k, st)), + con = fn ctx => fn c => fn st => S.Continue (c, con (ctx, c, st)), + exp = fn ctx => fn e => fn st => S.Continue (e, exp (ctx, e, st)), + bind = bind} ctx e st of + S.Continue (_, st) => st + | S.Return _ => raise Fail "ElabUtil.Exp.foldB: Impossible" + end structure Sgn = struct @@ -888,6 +915,82 @@ fun search {kind, con, exp, sgn_item, sgn, str, decl} k = S.Return x => SOME x | S.Continue _ => NONE +fun foldMapB {kind, con, exp, sgn_item, sgn, str, decl, bind} ctx st d = + case mapfoldB {kind = fn x => fn st => S.Continue (kind (x, st)), + con = fn ctx => fn x => fn st => S.Continue (con (ctx, x, st)), + exp = fn ctx => fn x => fn st => S.Continue (exp (ctx, x, st)), + sgn_item = fn ctx => fn x => fn st => S.Continue (sgn_item (ctx, x, st)), + sgn = fn ctx => fn x => fn st => S.Continue (sgn (ctx, x, st)), + str = fn ctx => fn x => fn st => S.Continue (str (ctx, x, st)), + decl = fn ctx => fn x => fn st => S.Continue (decl (ctx, x, st)), + bind = bind} ctx d st of + S.Continue x => x + | S.Return _ => raise Fail "ElabUtil.Decl.foldMapB: Impossible" + +end + +structure File = struct + +fun maxName ds = foldl (fn (d, count) => Int.max (maxNameDecl d, count)) 0 ds + +and maxNameDecl (d, _) = + case d of + DCon (_, n, _, _) => n + | DDatatype (_, n, _, ns) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + n ns + | DDatatypeImp (_, n1, n2, _, _, _, ns) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + (Int.max (n1, n2)) ns + | DVal (_, n, _, _) => n + | DValRec vis => foldl (fn ((_, n, _, _), count) => Int.max (n, count)) 0 vis + | DStr (_, n, sgn, str) => Int.max (n, Int.max (maxNameSgn sgn, maxNameStr str)) + | DSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn) + | DFfiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn) + | DConstraint _ => 0 + | DClass (_, n, _) => n + | DExport _ => 0 + | DTable (n, _, _, _) => n + | DSequence (n, _, _) => n + | DDatabase _ => 0 + +and maxNameStr (str, _) = + case str of + StrConst ds => maxName ds + | StrVar n => n + | StrProj (str, _) => maxNameStr str + | StrFun (_, n, dom, ran, str) => foldl Int.max n [maxNameSgn dom, maxNameSgn ran, maxNameStr str] + | StrApp (str1, str2) => Int.max (maxNameStr str1, maxNameStr str2) + | StrError => 0 + +and maxNameSgn (sgn, _) = + case sgn of + SgnConst sgis => foldl (fn (sgi, count) => Int.max (maxNameSgi sgi, count)) 0 sgis + | SgnVar n => n + | SgnFun (_, n, dom, ran) => Int.max (n, Int.max (maxNameSgn dom, maxNameSgn ran)) + | SgnWhere (sgn, _, _) => maxNameSgn sgn + | SgnProj (n, _, _) => n + | SgnError => 0 + +and maxNameSgi (sgi, _) = + case sgi of + SgiConAbs (_, n, _) => n + | SgiCon (_, n, _, _) => n + | SgiDatatype (_, n, _, ns) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + n ns + | SgiDatatypeImp (_, n1, n2, _, _, _, ns) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + (Int.max (n1, n2)) ns + | SgiVal (_, n, _) => n + | SgiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn) + | SgiSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn) + | SgiConstraint _ => 0 + | SgiTable (n, _, _, _) => n + | SgiSequence (n, _, _) => n + | SgiClassAbs (_, n) => n + | SgiClass (_, n, _) => n + end end diff --git a/src/sources b/src/sources index ebf71d9e..984b5e23 100644 --- a/src/sources +++ b/src/sources @@ -50,6 +50,9 @@ elab_err.sml elaborate.sig elaborate.sml +unnest.sig +unnest.sml + termination.sig termination.sml diff --git a/src/termination.sml b/src/termination.sml index b0716eca..6ed4d92f 100644 --- a/src/termination.sml +++ b/src/termination.sml @@ -292,6 +292,8 @@ fun declOk' env (d, loc) = | EError => (Rabble, calls) | EUnif (ref (SOME e)) => exp parent (penv, calls) e | EUnif (ref NONE) => (Rabble, calls) + + | ELet (_, e) => exp parent (penv, calls) e end fun doVali (i, (_, f, _, e), calls) = diff --git a/src/unnest.sig b/src/unnest.sig new file mode 100644 index 00000000..6508a781 --- /dev/null +++ b/src/unnest.sig @@ -0,0 +1,34 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +(* Remove nested function definitions *) + +signature UNNEST = sig + + val unnest : Elab.file -> Elab.file + +end diff --git a/src/unnest.sml b/src/unnest.sml new file mode 100644 index 00000000..e5eddc42 --- /dev/null +++ b/src/unnest.sml @@ -0,0 +1,369 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +(* Remove nested function definitions *) + +structure Unnest :> UNNEST = struct + +open Elab + +structure E = ElabEnv +structure U = ElabUtil + +structure IS = IntBinarySet + +val fvsCon = U.Con.foldB {kind = fn (_, st) => st, + con = fn (cb, c, cvs) => + case c of + CRel n => + if n >= cb then + IS.add (cvs, n - cb) + else + cvs + | _ => cvs, + bind = fn (cb, b) => + case b of + U.Con.Rel _ => cb + 1 + | _ => cb} + 0 IS.empty + +fun fvsExp nr = U.Exp.foldB {kind = fn (_, st) => st, + con = fn ((cb, eb), c, st as (cvs, evs)) => + case c of + CRel n => + if n >= cb then + (IS.add (cvs, n - cb), evs) + else + st + | _ => st, + exp = fn ((cb, eb), e, st as (cvs, evs)) => + case e of + ERel n => + if n >= eb then + (cvs, IS.add (evs, n - eb)) + else + st + | _ => st, + bind = fn (ctx as (cb, eb), b) => + case b of + U.Exp.RelC _ => (cb + 1, eb) + | U.Exp.RelE _ => (cb, eb + 1) + | _ => ctx} + (0, nr) (IS.empty, IS.empty) + +fun positionOf (x : int) ls = + let + fun po n ls = + case ls of + [] => raise Fail "Unnest.positionOf" + | x' :: ls' => + if x' = x then + n + else + po (n + 1) ls' + in + po 0 ls + handle Fail _ => raise Fail ("Unnset.positionOf(" + ^ Int.toString x + ^ ", " + ^ String.concatWith ";" (map Int.toString ls) + ^ ")") + end + +fun squishCon cfv = + U.Con.mapB {kind = fn k => k, + con = fn cb => fn c => + case c of + CRel n => + if n >= cb then + CRel (positionOf (n - cb) cfv + cb) + else + c + | _ => c, + bind = fn (cb, b) => + case b of + U.Con.Rel _ => cb + 1 + | _ => cb} + 0 + +fun squishExp (nr, cfv, efv) = + U.Exp.mapB {kind = fn k => k, + con = fn (cb, eb) => fn c => + case c of + CRel n => + if n >= cb then + CRel (positionOf (n - cb) cfv + cb) + else + c + | _ => c, + exp = fn (cb, eb) => fn e => + case e of + ERel n => + if n >= eb then + ERel (positionOf (n - eb) efv + eb) + else + e + | _ => e, + bind = fn (ctx as (cb, eb), b) => + case b of + U.Exp.RelC _ => (cb + 1, eb) + | U.Exp.RelE _ => (cb, eb + 1) + | _ => ctx} + (0, nr) + +type state = { + maxName : int, + decls : decl list +} + +fun kind (k, st) = (k, st) + +fun exp ((ks, ts), e, st : state) = + case e of + ELet (eds, e) => + let + val doSubst = foldl (fn (p, e) => E.subExpInExp p e) + + val (eds, (maxName, ds, subs)) = + ListUtil.foldlMapConcat + (fn (ed, (maxName, ds, subs)) => + case #1 ed of + EDVal _ => ([ed], (maxName, ds, map (fn (n, e) => (n + 1, E.liftExpInExp 0 e)) subs)) + | EDValRec vis => + let + val loc = #2 ed + + val nr = length vis + val (cfv, efv) = foldl (fn ((_, t, e), (cfv, efv)) => + let + val (cfv', efv') = fvsExp nr e + (*val () = Print.prefaces "fvsExp" + [("e", ElabPrint.p_exp E.empty e), + ("cfv", Print.PD.string + (Int.toString (IS.numItems cfv'))), + ("efv", Print.PD.string + (Int.toString (IS.numItems efv')))]*) + val cfv'' = fvsCon t + in + (IS.union (cfv, IS.union (cfv', cfv'')), + IS.union (efv, efv')) + end) + (IS.empty, IS.empty) vis + + (*val () = print ("A: " ^ Int.toString (length ts) ^ ", " ^ Int.toString (length ks) ^ "\n")*) + val cfv = IS.foldl (fn (x, cfv) => + let + (*val () = print (Int.toString x ^ "\n")*) + val (_, t) = List.nth (ts, x) + in + IS.union (cfv, fvsCon t) + end) + cfv efv + (*val () = print "B\n"*) + + val (vis, maxName) = + ListUtil.foldlMap (fn ((x, t, e), maxName) => + ((x, maxName, t, e), + maxName + 1)) + maxName vis + + fun apply e = + let + val e = IS.foldl (fn (x, e) => + (ECApp (e, (CRel x, loc)), loc)) + e cfv + in + IS.foldl (fn (x, e) => + (EApp (e, (ERel x, loc)), loc)) + e efv + end + + val subs = map (fn (n, e) => (n + nr, E.liftExpInExp nr e)) subs + + val subs' = ListUtil.mapi (fn (i, (_, n, _, _)) => + let + val e = apply (ENamed n, loc) + in + (0, E.liftExpInExp (nr - i - 1) e) + end) + vis + val subs' = rev subs' + + val cfv = IS.listItems cfv + val efv = IS.listItems efv + val efn = length efv + + (*val subsInner = subs + @ map (fn (i, e) => + (i + efn, + E.liftExpInExp efn e)) subs'*) + + val subs = subs @ subs' + + val vis = map (fn (x, n, t, e) => + let + (*val () = Print.prefaces "preSubst" + [("e", ElabPrint.p_exp E.empty e)]*) + val e = doSubst e subs(*Inner*) + + (*val () = Print.prefaces "squishCon" + [("t", ElabPrint.p_con E.empty t)]*) + val t = squishCon cfv t + (*val () = Print.prefaces "squishExp" + [("e", ElabPrint.p_exp E.empty e)]*) + val e = squishExp (nr, cfv, efv) e + + val (e, t) = foldr (fn (ex, (e, t)) => + let + val (name, t') = List.nth (ts, ex) + in + ((EAbs (name, + t', + t, + e), loc), + (TFun (t', + t), loc)) + end) + (e, t) efv + + val (e, t) = foldr (fn (cx, (e, t)) => + let + val (name, k) = List.nth (ks, cx) + in + ((ECAbs (Explicit, + name, + k, + e), loc), + (TCFun (Explicit, + name, + k, + t), loc)) + end) + (e, t) cfv + in + (x, n, t, e) + end) + vis + + val d = (DValRec vis, #2 ed) + in + ([], (maxName, d :: ds, subs)) + end) + (#maxName st, #decls st, []) eds + in + (ELet (eds, doSubst e subs), + {maxName = maxName, + decls = ds}) + end + + | _ => (e, st) + +fun default (ctx, d, st) = (d, st) + +fun bind ((ks, ts), b) = + case b of + U.Decl.RelC p => (p :: ks, map (fn (name, t) => (name, E.liftConInCon 0 t)) ts) + | U.Decl.RelE p => (ks, p :: ts) + | _ => (ks, ts) + +val unnestDecl = U.Decl.foldMapB {kind = kind, + con = default, + exp = exp, + sgn_item = default, + sgn = default, + str = default, + decl = default, + bind = bind} + ([], []) + +fun unnest file = + let + fun doDecl (all as (d, loc), st : state) = + let + fun default () = ([all], st) + fun explore () = + let + val (d, st) = unnestDecl st all + in + (rev (d :: #decls st), + {maxName = #maxName st, + decls = []}) + end + in + case d of + DCon _ => default () + | DDatatype _ => default () + | DDatatypeImp _ => default () + | DVal _ => explore () + | DValRec _ => explore () + | DSgn _ => default () + | DStr (x, n, sgn, str) => + let + val (str, st) = doStr (str, st) + in + ([(DStr (x, n, sgn, str), loc)], st) + end + | DFfiStr _ => default () + | DConstraint _ => default () + | DExport _ => default () + | DTable _ => default () + | DSequence _ => default () + | DClass _ => default () + | DDatabase _ => default () + end + + and doStr (all as (str, loc), st) = + let + fun default () = (all, st) + in + case str of + StrConst ds => + let + val (ds, st) = ListUtil.foldlMapConcat doDecl st ds + in + ((StrConst ds, loc), st) + end + | StrVar _ => default () + | StrProj _ => default () + | StrFun (x, n, dom, ran, str) => + let + val (str, st) = doStr (str, st) + in + ((StrFun (x, n, dom, ran, str), loc), st) + end + | StrApp _ => default () + | StrError => raise Fail "Unnest: StrError" + end + + val (ds, _) = ListUtil.foldlMapConcat doDecl + {maxName = U.File.maxName file + 1, + decls = []} file + in + ds + end + +end diff --git a/tests/nest.ur b/tests/nest.ur new file mode 100644 index 00000000..c136b1e6 --- /dev/null +++ b/tests/nest.ur @@ -0,0 +1,41 @@ +fun add x = + let + fun add' y = x + y + in + add' 1 + add' 2 + end + +fun f (x : int) = + let + fun page () = return + {[x]} + + in + page + end + +fun f (x : int) = + let + fun page1 () = return + {[x]} + + + and page2 () = + case Some True of + Some r => return {[r]} + | _ => return Error + in + page1 + end + +datatype list t = Nil | Cons of t * list t + +fun length (t ::: Type) (ls : list t) = + let + fun length' ls acc = + case ls of + Nil => acc + | Cons (_, ls') => length' ls' (acc + 1) + in + length' ls 0 + end diff --git a/tests/nest.urp b/tests/nest.urp new file mode 100644 index 00000000..7f8a473a --- /dev/null +++ b/tests/nest.urp @@ -0,0 +1,3 @@ +debug + +nest -- cgit v1.2.3 From 9a22207b565607db64f95dda5fdc1c9e56224ec9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 1 Nov 2008 17:19:12 -0400 Subject: Fix some type-class detection --- lib/basis.urs | 1 + src/elab_env.sml | 1 + src/elaborate.sml | 1 + src/monoize.sml | 9 +++++++++ 4 files changed, 12 insertions(+) (limited to 'src/elab_env.sml') diff --git a/lib/basis.urs b/lib/basis.urs index a344b3ce..ca81c95f 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -56,6 +56,7 @@ val show_float : show float val show_string : show string val show_bool : show bool val show_time : show time +val mkShow : t ::: Type -> (t -> string) -> show t class read val read : t ::: Type -> read t -> string -> option t diff --git a/src/elab_env.sml b/src/elab_env.sml index 2732de13..6b762abd 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -419,6 +419,7 @@ fun class_pair_in (c, _) = (case (class_name_in f, class_key_in x) of (SOME f, SOME x) => SOME (f, x) | _ => NONE) + | CUnif (_, _, _, ref (SOME c)) => class_pair_in c | _ => NONE fun resolveClass (env : env) c = diff --git a/src/elaborate.sml b/src/elaborate.sml index 38c03f6e..b0f2d331 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1398,6 +1398,7 @@ fun normClassConstraint envs (c, loc) = in ((L'.CApp (f, x), loc), gs) end + | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint envs c | _ => ((c, loc), []) diff --git a/src/monoize.sml b/src/monoize.sml index 79940842..0bdc1c70 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -844,6 +844,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EFfi ("Basis", "boolToString"), loc), fm) | L.EFfi ("Basis", "show_time") => ((L'.EFfi ("Basis", "timeToString"), loc), fm) + | L.ECApp ((L.EFfi ("Basis", "mkShow"), _), t) => + let + val t = monoType env t + val b = (L'.TFfi ("Basis", "string"), loc) + val dom = (L'.TFun (t, b), loc) + in + ((L'.EAbs ("f", dom, dom, + (L'.ERel 0, loc)), loc), fm) + end | L.ECApp ((L.EFfi ("Basis", "read"), _), t) => let -- cgit v1.2.3 From 12bb99a0ba702af12e89bfe544f2a572e5d4818d Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 10:29:55 -0500 Subject: Cookies through elaborate --- lib/basis.urs | 4 +++ src/elab.sml | 2 ++ src/elab_env.sml | 15 +++++++++++ src/elab_print.sml | 14 +++++++++++ src/elab_util.sml | 27 +++++++++++++++----- src/elaborate.sml | 66 ++++++++++++++++++++++++++++++++++++++++++++++++- src/elisp/urweb-defs.el | 6 ++--- src/elisp/urweb-mode.el | 4 +-- src/source.sml | 2 ++ src/source_print.sml | 15 +++++++++++ src/unnest.sml | 1 + src/urweb.grm | 3 +++ src/urweb.lex | 1 + tests/cookie.ur | 9 +++++++ tests/cookie.urp | 3 +++ 15 files changed, 160 insertions(+), 12 deletions(-) create mode 100644 tests/cookie.ur create mode 100644 tests/cookie.urp (limited to 'src/elab_env.sml') diff --git a/lib/basis.urs b/lib/basis.urs index 806a9623..84fb4e4c 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -84,6 +84,10 @@ val bind : t1 ::: Type -> t2 ::: Type val requestHeader : string -> transaction (option string) +con http_cookie :: Type -> Type +val getCookie : t ::: Type -> http_cookie t -> transaction (option t) +val setCookie : t ::: Type -> http_cookie t -> t -> transaction unit + (** SQL *) diff --git a/src/elab.sml b/src/elab.sml index b5350c2a..afb8f7aa 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -139,6 +139,7 @@ datatype sgn_item' = | SgiSequence of int * string * int | SgiClassAbs of string * int | SgiClass of string * int * con + | SgiCookie of int * string * int * con and sgn' = SgnConst of sgn_item list @@ -166,6 +167,7 @@ datatype decl' = | DSequence of int * string * int | DClass of string * int * con | DDatabase of string + | DCookie of int * string * int * con and str' = StrConst of decl list diff --git a/src/elab_env.sml b/src/elab_env.sml index 6b762abd..a782771a 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -592,6 +592,7 @@ fun sgiSeek (sgi, (sgns, strs, cons)) = | SgiSequence _ => (sgns, strs, cons) | SgiClassAbs (x, n) => (sgns, strs, IM.insert (cons, n, x)) | SgiClass (x, n, _) => (sgns, strs, IM.insert (cons, n, x)) + | SgiCookie _ => (sgns, strs, cons) fun sgnSeek f sgis = let @@ -945,6 +946,13 @@ fun sgiBinds env (sgi, loc) = | SgiClassAbs (x, n) => pushCNamedAs env x n (KArrow ((KType, loc), (KType, loc)), loc) NONE | SgiClass (x, n, c) => pushCNamedAs env x n (KArrow ((KType, loc), (KType, loc)), loc) (SOME c) + + | SgiCookie (tn, x, n, c) => + let + val t = (CApp ((CModProj (tn, [], "http_cookie"), loc), c), loc) + in + pushENamedAs env x n t + end fun sgnSubCon x = @@ -1095,6 +1103,7 @@ fun sgnSeekConstraints (str, sgis) = | SgiSequence _ => seek (sgis, sgns, strs, cons, acc) | SgiClassAbs (x, n) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) | SgiClass (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) + | SgiCookie _ => seek (sgis, sgns, strs, cons, acc) in seek (sgis, IM.empty, IM.empty, IM.empty, []) end @@ -1189,6 +1198,12 @@ fun declBinds env (d, loc) = pushClass env n end | DDatabase _ => env + | DCookie (tn, x, n, c) => + let + val t = (CApp ((CModProj (tn, [], "cookie"), loc), c), loc) + in + pushENamedAs env x n t + end fun patBinds env (p, loc) = case p of diff --git a/src/elab_print.sml b/src/elab_print.sml index b236954e..a686abe5 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -536,6 +536,13 @@ fun p_sgn_item env (sgi, _) = string "=", space, p_con env c] + | SgiCookie (_, x, n, c) => box [string "cookie", + space, + p_named x n, + space, + string ":", + space, + p_con env c] and p_sgn env (sgn, _) = case sgn of @@ -707,6 +714,13 @@ fun p_decl env (dAll as (d, _) : decl) = | DDatabase s => box [string "database", space, string s] + | DCookie (_, x, n, c) => box [string "cookie", + space, + p_named x n, + space, + string ":", + space, + p_con env c] and p_str env (str, _) = case str of diff --git a/src/elab_util.sml b/src/elab_util.sml index 57a94486..fe75ee0d 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -548,6 +548,10 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = S.map2 (con ctx c, fn c' => (SgiClass (x, n, c'), loc)) + | SgiCookie (tn, x, n, c) => + S.map2 (con ctx c, + fn c' => + (SgiCookie (tn, x, n, c'), loc)) and sg ctx s acc = S.bindP (sg' ctx s acc, sgn ctx) @@ -576,7 +580,8 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = | SgiClassAbs (x, n) => bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))) | SgiClass (x, n, _) => - bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))), + bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))) + | SgiCookie _ => ctx, sgi ctx si)) ctx sgis, fn sgis' => (SgnConst sgis', loc)) @@ -720,7 +725,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f bind (ctx, NamedE (x, (CModProj (n, [], "sql_sequence"), loc))) | DClass (x, n, _) => bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))) - | DDatabase _ => ctx, + | DDatabase _ => ctx + | DCookie (tn, x, n, c) => + bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "cookie"), loc), + c), loc))), mfd ctx d)) ctx ds, fn ds' => (StrConst ds', loc)) | StrVar _ => S.return2 strAll @@ -821,6 +829,11 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f | DDatabase _ => S.return2 dAll + | DCookie (tn, x, n, c) => + S.map2 (mfc ctx c, + fn c' => + (DCookie (tn, x, n, c'), loc)) + and mfvi ctx (x, n, c, e) = S.bind2 (mfc ctx c, fn c' => @@ -955,9 +968,10 @@ and maxNameDecl (d, _) = | DConstraint _ => 0 | DClass (_, n, _) => n | DExport _ => 0 - | DTable (n, _, _, _) => n - | DSequence (n, _, _) => n + | DTable (n1, _, n2, _) => Int.max (n1, n2) + | DSequence (n1, _, n2) => Int.max (n1, n2) | DDatabase _ => 0 + | DCookie (n1, _, n2, _) => Int.max (n1, n2) and maxNameStr (str, _) = case str of @@ -991,10 +1005,11 @@ and maxNameSgi (sgi, _) = | SgiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn) | SgiSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn) | SgiConstraint _ => 0 - | SgiTable (n, _, _, _) => n - | SgiSequence (n, _, _) => n + | SgiTable (n1, _, n2, _) => Int.max (n1, n2) + | SgiSequence (n1, _, n2) => Int.max (n1, n2) | SgiClassAbs (_, n) => n | SgiClass (_, n, _) => n + | SgiCookie (n1, _, n2, _) => Int.max (n1, n2) end diff --git a/src/elaborate.sml b/src/elaborate.sml index b0f2d331..3a966eaf 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1760,6 +1760,7 @@ val hnormSgn = E.hnormSgn fun tableOf () = (L'.CModProj (!basis_r, [], "sql_table"), ErrorMsg.dummySpan) fun sequenceOf () = (L'.CModProj (!basis_r, [], "sql_sequence"), ErrorMsg.dummySpan) +fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan) fun elabSgn_item ((sgi, loc), (env, denv, gs)) = case sgi of @@ -1967,6 +1968,15 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = ([(L'.SgiClass (x, n, c'), loc)], (env, denv, [])) end + | L.SgiCookie (x, c) => + let + val (c', k, gs) = elabCon (env, denv) c + val (env, n) = E.pushENamed env x (L'.CApp (cookieOf (), c'), loc) + in + checkKind env c' k (L'.KType, loc); + ([(L'.SgiCookie (!basis_r, x, n, c'), loc)], (env, denv, gs)) + end + and elabSgn (env, denv) (sgn, loc) = case sgn of L.SgnConst sgis => @@ -2051,7 +2061,13 @@ and elabSgn (env, denv) (sgn, loc) = sgnError env (DuplicateCon (loc, x)) else (); - (SS.add (cons, x), vals, sgns, strs))) + (SS.add (cons, x), vals, sgns, strs)) + | L'.SgiCookie (_, x, _, _) => + (if SS.member (vals, x) then + sgnError env (DuplicateVal (loc, x)) + else + (); + (cons, SS.add (vals, x), sgns, strs))) (SS.empty, SS.empty, SS.empty, SS.empty) sgis' in ((L'.SgnConst sgis', loc), gs) @@ -2203,6 +2219,9 @@ fun dopen (env, denv) {str, strs, sgn} = in (L'.DCon (x, n, k, c), loc) end + | L'.SgiCookie (_, x, n, c) => + (L'.DVal (x, n, (L'.CApp (cookieOf (), c), loc), + (L'.EModProj (str, strs, x), loc)), loc) in (d, (E.declBinds env' d, denv')) end) @@ -2259,6 +2278,7 @@ fun sgiOfDecl (d, loc) = | L'.DSequence (tn, x, n) => [(L'.SgiSequence (tn, x, n), loc)] | L'.DClass (x, n, c) => [(L'.SgiClass (x, n, c), loc)] | L'.DDatabase _ => [] + | L'.DCookie (tn, x, n, c) => [(L'.SgiCookie (tn, x, n, c), loc)] fun sgiBindsD (env, denv) (sgi, _) = case sgi of @@ -2508,6 +2528,16 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = SOME (env, denv)) else NONE + | L'.SgiCookie (_, x', n1, c1) => + if x = x' then + (case unifyCons (env, denv) (L'.CApp (cookieOf (), c1), loc) c2 of + [] => SOME (env, denv) + | _ => NONE) + handle CUnify (c1, c2, err) => + (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); + SOME (env, denv)) + else + NONE | _ => NONE) | L'.SgiStr (x, n2, sgn2) => @@ -2651,6 +2681,21 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = L'.SgiClass (x', n1, c1) => found (x', n1, c1) | _ => NONE end) + + | L'.SgiCookie (_, x, n2, c2) => + seek (fn sgi1All as (sgi1, _) => + case sgi1 of + L'.SgiCookie (_, x', n1, c1) => + if x = x' then + (case unifyCons (env, denv) c1 c2 of + [] => SOME (env, denv) + | _ => NONE) + handle CUnify (c1, c2, err) => + (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); + SOME (env, denv)) + else + NONE + | _ => NONE) end in ignore (foldl folder (env, denv) sgis2) @@ -3194,6 +3239,15 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = | L.DDatabase s => ([(L'.DDatabase s, loc)], (env, denv, gs)) + | L.DCookie (x, c) => + let + val (c', k, gs') = elabCon (env, denv) c + val (env, n) = E.pushENamed env x (L'.CApp (cookieOf (), c'), loc) + in + checkKind env c' k (L'.KType, loc); + ([(L'.DCookie (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs)) + end + (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) in (*prefaces "elabDecl" [("e", SourcePrint.p_decl dAll), @@ -3336,6 +3390,16 @@ and elabStr (env, denv) (str, loc) = (SS.add (cons, x), x) in ((L'.SgiClass (x, n, c), loc) :: sgis, cons, vals, sgns, strs) + end + | L'.SgiCookie (tn, x, n, c) => + let + val (vals, x) = + if SS.member (vals, x) then + (vals, "?" ^ x) + else + (SS.add (vals, x), x) + in + ((L'.SgiCookie (tn, x, n, c), loc) :: sgis, cons, vals, sgns, strs) end) ([], SS.empty, SS.empty, SS.empty, SS.empty) sgis diff --git a/src/elisp/urweb-defs.el b/src/elisp/urweb-defs.el index fe4da2e4..5551b7a2 100644 --- a/src/elisp/urweb-defs.el +++ b/src/elisp/urweb-defs.el @@ -108,7 +108,7 @@ notion of \"the end of an outline\".") "datatype" "type" "open" "include" urweb-module-head-syms "con" "fold" "where" "extern" "constraint" "constraints" - "table" "sequence" "class") + "table" "sequence" "class" "cookie") "Symbols starting an sexp.") ;; (defconst urweb-not-arg-start-re @@ -134,7 +134,7 @@ notion of \"the end of an outline\".") (,urweb-=-starter-syms nil) (("case" "datatype" "if" "then" "else" "let" "open" "sig" "struct" "type" "val" - "con" "constraint" "table" "sequence" "class"))))) + "con" "constraint" "table" "sequence" "class" "cookie"))))) (defconst urweb-starters-indent-after (urweb-syms-re "let" "in" "struct" "sig") @@ -188,7 +188,7 @@ for all symbols and in all lines starting with the given symbol." (append urweb-module-head-syms '("datatype" "fun" "open" "type" "val" "and" - "con" "constraint" "table" "sequence" "class")) + "con" "constraint" "table" "sequence" "class" "cookie")) "The starters of new expressions.") (defconst urweb-exptrail-syms diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index 1a578cf9..223006fc 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -136,7 +136,7 @@ See doc for the variable `urweb-mode-info'." "datatype" "else" "end" "extern" "fn" "fold" "fun" "functor" "if" "include" "of" "open" "let" "in" - "rec" "sequence" "sig" "signature" + "rec" "sequence" "sig" "signature" "cookie" "struct" "structure" "table" "then" "type" "val" "where" "with" @@ -223,7 +223,7 @@ See doc for the variable `urweb-mode-info'." ("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)" (1 font-lock-keyword-face) (3 (amAttribute font-lock-type-def-face))) - ("\\<\\(val\\|table\\|sequence\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]" + ("\\<\\(val\\|table\\|sequence\\|cookie\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]" (1 font-lock-keyword-face) (3 (amAttribute font-lock-variable-name-face))) ("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)" diff --git a/src/source.sml b/src/source.sml index 7e204390..a0591afb 100644 --- a/src/source.sml +++ b/src/source.sml @@ -85,6 +85,7 @@ datatype sgn_item' = | SgiSequence of string | SgiClassAbs of string | SgiClass of string * con + | SgiCookie of string * con and sgn' = SgnConst of sgn_item list @@ -157,6 +158,7 @@ datatype decl' = | DSequence of string | DClass of string * con | DDatabase of string + | DCookie of string * con and str' = StrConst of decl list diff --git a/src/source_print.sml b/src/source_print.sml index 9e6608df..d33fb38d 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -428,6 +428,13 @@ fun p_sgn_item (sgi, _) = string "=", space, p_con c] + | SgiCookie (x, c) => box [string "cookie", + space, + string x, + space, + string ":", + space, + p_con c] and p_sgn (sgn, _) = case sgn of @@ -579,6 +586,14 @@ fun p_decl ((d, _) : decl) = space, string s] + | DCookie (x, c) => box [string "cookie", + space, + string x, + space, + string ":", + space, + p_con c] + and p_str (str, _) = case str of StrConst ds => box [string "struct", diff --git a/src/unnest.sml b/src/unnest.sml index b56daf8a..6a37d484 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -348,6 +348,7 @@ fun unnest file = | DSequence _ => default () | DClass _ => default () | DDatabase _ => default () + | DCookie _ => default () end and doStr (all as (str, loc), st) = diff --git a/src/urweb.grm b/src/urweb.grm index 1555dc37..879afb9c 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -201,6 +201,7 @@ fun tagIn bt = | LET | IN | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE + | COOKIE | CASE | IF | THEN | ELSE | XML_BEGIN of string | XML_END | XML_BEGIN_END of string @@ -426,6 +427,7 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let in [(DClass (SYMBOL1, c), s (CLASSleft, cexpright))] end) + | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))]) kopt : (NONE) | DCOLON kind (SOME kind) @@ -506,6 +508,7 @@ sgi : CON SYMBOL DCOLON kind (SgiConAbs (SYMBOL, kind), s (CONleft, k in (SgiClass (SYMBOL1, c), s (CLASSleft, cexpright)) end) + | COOKIE SYMBOL COLON cexp (SgiCookie (SYMBOL, cexp), s (COOKIEleft, cexpright)) sgis : ([]) | sgi sgis (sgi :: sgis) diff --git a/src/urweb.lex b/src/urweb.lex index d5393e7d..f5ea558a 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -313,6 +313,7 @@ notags = [^<{\n]+; "table" => (Tokens.TABLE (pos yypos, pos yypos + size yytext)); "sequence" => (Tokens.SEQUENCE (pos yypos, pos yypos + size yytext)); "class" => (Tokens.CLASS (pos yypos, pos yypos + size yytext)); + "cookie" => (Tokens.COOKIE (pos yypos, pos yypos + size yytext)); "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext)); "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext)); diff --git a/tests/cookie.ur b/tests/cookie.ur new file mode 100644 index 00000000..b2bca580 --- /dev/null +++ b/tests/cookie.ur @@ -0,0 +1,9 @@ +cookie c : string + +fun main () : transaction page = + setCookie c "Hi"; + so <- getCookie c; + case so of + None => return No cookie + | Some s => return Cookie: {[s]} + diff --git a/tests/cookie.urp b/tests/cookie.urp new file mode 100644 index 00000000..61a1a1e0 --- /dev/null +++ b/tests/cookie.urp @@ -0,0 +1,3 @@ +debug + +cookie -- cgit v1.2.3 From ea5a24773259c147e806960843d3305a3c72067b Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 10:43:48 -0500 Subject: Cookies through explify --- src/elab.sml | 3 - src/elab_env.sml | 27 --------- src/elab_print.sml | 17 ------ src/elab_util.sml | 17 +----- src/elaborate.sml | 160 ++------------------------------------------------- src/expl.sml | 3 +- src/expl_env.sml | 19 ++---- src/expl_print.sml | 17 +++--- src/expl_util.sml | 9 +-- src/explify.sml | 3 +- src/source.sml | 3 - src/source_print.sml | 17 ------ src/urweb.grm | 23 +++++++- 13 files changed, 41 insertions(+), 277 deletions(-) (limited to 'src/elab_env.sml') diff --git a/src/elab.sml b/src/elab.sml index afb8f7aa..d00d1f1a 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -135,11 +135,8 @@ datatype sgn_item' = | SgiStr of string * int * sgn | SgiSgn of string * int * sgn | SgiConstraint of con * con - | SgiTable of int * string * int * con - | SgiSequence of int * string * int | SgiClassAbs of string * int | SgiClass of string * int * con - | SgiCookie of int * string * int * con and sgn' = SgnConst of sgn_item list diff --git a/src/elab_env.sml b/src/elab_env.sml index a782771a..b14cd06c 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -588,11 +588,8 @@ fun sgiSeek (sgi, (sgns, strs, cons)) = | SgiSgn (x, n, _) => (IM.insert (sgns, n, x), strs, cons) | SgiStr (x, n, _) => (sgns, IM.insert (strs, n, x), cons) | SgiConstraint _ => (sgns, strs, cons) - | SgiTable _ => (sgns, strs, cons) - | SgiSequence _ => (sgns, strs, cons) | SgiClassAbs (x, n) => (sgns, strs, IM.insert (cons, n, x)) | SgiClass (x, n, _) => (sgns, strs, IM.insert (cons, n, x)) - | SgiCookie _ => (sgns, strs, cons) fun sgnSeek f sgis = let @@ -931,30 +928,9 @@ fun sgiBinds env (sgi, loc) = | SgiSgn (x, n, sgn) => pushSgnNamedAs env x n sgn | SgiConstraint _ => env - | SgiTable (tn, x, n, c) => - let - val t = (CApp ((CModProj (tn, [], "sql_table"), loc), c), loc) - in - pushENamedAs env x n t - end - | SgiSequence (tn, x, n) => - let - val t = (CModProj (tn, [], "sql_sequence"), loc) - in - pushENamedAs env x n t - end - | SgiClassAbs (x, n) => pushCNamedAs env x n (KArrow ((KType, loc), (KType, loc)), loc) NONE | SgiClass (x, n, c) => pushCNamedAs env x n (KArrow ((KType, loc), (KType, loc)), loc) (SOME c) - | SgiCookie (tn, x, n, c) => - let - val t = (CApp ((CModProj (tn, [], "http_cookie"), loc), c), loc) - in - pushENamedAs env x n t - end - - fun sgnSubCon x = ElabUtil.Con.map {kind = id, con = sgnS_con x} @@ -1099,11 +1075,8 @@ fun sgnSeekConstraints (str, sgis) = | SgiVal _ => seek (sgis, sgns, strs, cons, acc) | SgiSgn (x, n, _) => seek (sgis, IM.insert (sgns, n, x), strs, cons, acc) | SgiStr (x, n, _) => seek (sgis, sgns, IM.insert (strs, n, x), cons, acc) - | SgiTable _ => seek (sgis, sgns, strs, cons, acc) - | SgiSequence _ => seek (sgis, sgns, strs, cons, acc) | SgiClassAbs (x, n) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) | SgiClass (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) - | SgiCookie _ => seek (sgis, sgns, strs, cons, acc) in seek (sgis, IM.empty, IM.empty, IM.empty, []) end diff --git a/src/elab_print.sml b/src/elab_print.sml index a686abe5..2afedef1 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -516,16 +516,6 @@ fun p_sgn_item env (sgi, _) = string "~", space, p_con env c2] - | SgiTable (_, x, n, c) => box [string "table", - space, - p_named x n, - space, - string ":", - space, - p_con env c] - | SgiSequence (_, x, n) => box [string "sequence", - space, - p_named x n] | SgiClassAbs (x, n) => box [string "class", space, p_named x n] @@ -536,13 +526,6 @@ fun p_sgn_item env (sgi, _) = string "=", space, p_con env c] - | SgiCookie (_, x, n, c) => box [string "cookie", - space, - p_named x n, - space, - string ":", - space, - p_con env c] and p_sgn env (sgn, _) = case sgn of diff --git a/src/elab_util.sml b/src/elab_util.sml index fe75ee0d..9c25ae86 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -538,20 +538,11 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = S.map2 (con ctx c2, fn c2' => (SgiConstraint (c1', c2'), loc))) - | SgiTable (tn, x, n, c) => - S.map2 (con ctx c, - fn c' => - (SgiTable (tn, x, n, c'), loc)) - | SgiSequence _ => S.return2 siAll | SgiClassAbs _ => S.return2 siAll | SgiClass (x, n, c) => S.map2 (con ctx c, fn c' => (SgiClass (x, n, c'), loc)) - | SgiCookie (tn, x, n, c) => - S.map2 (con ctx c, - fn c' => - (SgiCookie (tn, x, n, c'), loc)) and sg ctx s acc = S.bindP (sg' ctx s acc, sgn ctx) @@ -575,13 +566,10 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = | SgiSgn (x, _, sgn) => bind (ctx, Sgn (x, sgn)) | SgiConstraint _ => ctx - | SgiTable _ => ctx - | SgiSequence _ => ctx | SgiClassAbs (x, n) => bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))) | SgiClass (x, n, _) => - bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))) - | SgiCookie _ => ctx, + bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))), sgi ctx si)) ctx sgis, fn sgis' => (SgnConst sgis', loc)) @@ -1005,11 +993,8 @@ and maxNameSgi (sgi, _) = | SgiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn) | SgiSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn) | SgiConstraint _ => 0 - | SgiTable (n1, _, n2, _) => Int.max (n1, n2) - | SgiSequence (n1, _, n2) => Int.max (n1, n2) | SgiClassAbs (_, n) => n | SgiClass (_, n, _) => n - | SgiCookie (n1, _, n2, _) => Int.max (n1, n2) end diff --git a/src/elaborate.sml b/src/elaborate.sml index 3a966eaf..3b70c623 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1932,22 +1932,6 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = ([(L'.SgiConstraint (c1', c2'), loc)], (env, denv, gs1 @ gs2 @ gs3)) end - | L.SgiTable (x, c) => - let - val (c', k, gs) = elabCon (env, denv) c - val (env, n) = E.pushENamed env x (L'.CApp (tableOf (), c'), loc) - in - checkKind env c' k (L'.KRecord (L'.KType, loc), loc); - ([(L'.SgiTable (!basis_r, x, n, c'), loc)], (env, denv, gs)) - end - - | L.SgiSequence x => - let - val (env, n) = E.pushENamed env x (sequenceOf ()) - in - ([(L'.SgiSequence (!basis_r, x, n), loc)], (env, denv, gs)) - end - | L.SgiClassAbs x => let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) @@ -1968,15 +1952,6 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = ([(L'.SgiClass (x, n, c'), loc)], (env, denv, [])) end - | L.SgiCookie (x, c) => - let - val (c', k, gs) = elabCon (env, denv) c - val (env, n) = E.pushENamed env x (L'.CApp (cookieOf (), c'), loc) - in - checkKind env c' k (L'.KType, loc); - ([(L'.SgiCookie (!basis_r, x, n, c'), loc)], (env, denv, gs)) - end - and elabSgn (env, denv) (sgn, loc) = case sgn of L.SgnConst sgis => @@ -2038,18 +2013,6 @@ and elabSgn (env, denv) (sgn, loc) = (); (cons, vals, sgns, SS.add (strs, x))) | L'.SgiConstraint _ => (cons, vals, sgns, strs) - | L'.SgiTable (_, x, _, _) => - (if SS.member (vals, x) then - sgnError env (DuplicateVal (loc, x)) - else - (); - (cons, SS.add (vals, x), sgns, strs)) - | L'.SgiSequence (_, x, _) => - (if SS.member (vals, x) then - sgnError env (DuplicateVal (loc, x)) - else - (); - (cons, SS.add (vals, x), sgns, strs)) | L'.SgiClassAbs (x, _) => (if SS.member (cons, x) then sgnError env (DuplicateCon (loc, x)) @@ -2061,13 +2024,7 @@ and elabSgn (env, denv) (sgn, loc) = sgnError env (DuplicateCon (loc, x)) else (); - (SS.add (cons, x), vals, sgns, strs)) - | L'.SgiCookie (_, x, _, _) => - (if SS.member (vals, x) then - sgnError env (DuplicateVal (loc, x)) - else - (); - (cons, SS.add (vals, x), sgns, strs))) + (SS.add (cons, x), vals, sgns, strs))) (SS.empty, SS.empty, SS.empty, SS.empty) sgis' in ((L'.SgnConst sgis', loc), gs) @@ -2199,12 +2156,6 @@ fun dopen (env, denv) {str, strs, sgn} = (L'.DSgn (x, n, (L'.SgnProj (str, strs, x), loc)), loc) | L'.SgiConstraint (c1, c2) => (L'.DConstraint (c1, c2), loc) - | L'.SgiTable (_, x, n, c) => - (L'.DVal (x, n, (L'.CApp (tableOf (), c), loc), - (L'.EModProj (str, strs, x), loc)), loc) - | L'.SgiSequence (_, x, n) => - (L'.DVal (x, n, sequenceOf (), - (L'.EModProj (str, strs, x), loc)), loc) | L'.SgiClassAbs (x, n) => let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) @@ -2219,9 +2170,6 @@ fun dopen (env, denv) {str, strs, sgn} = in (L'.DCon (x, n, k, c), loc) end - | L'.SgiCookie (_, x, n, c) => - (L'.DVal (x, n, (L'.CApp (cookieOf (), c), loc), - (L'.EModProj (str, strs, x), loc)), loc) in (d, (E.declBinds env' d, denv')) end) @@ -2274,11 +2222,11 @@ fun sgiOfDecl (d, loc) = | L'.DFfiStr (x, n, sgn) => [(L'.SgiStr (x, n, sgn), loc)] | L'.DConstraint cs => [(L'.SgiConstraint cs, loc)] | L'.DExport _ => [] - | L'.DTable (tn, x, n, c) => [(L'.SgiTable (tn, x, n, c), loc)] - | L'.DSequence (tn, x, n) => [(L'.SgiSequence (tn, x, n), loc)] + | L'.DTable (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (tableOf (), c), loc)), loc)] + | L'.DSequence (tn, x, n) => [(L'.SgiVal (x, n, sequenceOf ()), loc)] | L'.DClass (x, n, c) => [(L'.SgiClass (x, n, c), loc)] | L'.DDatabase _ => [] - | L'.DCookie (tn, x, n, c) => [(L'.SgiCookie (tn, x, n, c), loc)] + | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] fun sgiBindsD (env, denv) (sgi, _) = case sgi of @@ -2508,36 +2456,6 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = SOME (env, denv)) else NONE - | L'.SgiTable (_, x', n1, c1) => - if x = x' then - (case unifyCons (env, denv) (L'.CApp (tableOf (), c1), loc) c2 of - [] => SOME (env, denv) - | _ => NONE) - handle CUnify (c1, c2, err) => - (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); - SOME (env, denv)) - else - NONE - | L'.SgiSequence (_, x', n1) => - if x = x' then - (case unifyCons (env, denv) (sequenceOf ()) c2 of - [] => SOME (env, denv) - | _ => NONE) - handle CUnify (c1, c2, err) => - (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); - SOME (env, denv)) - else - NONE - | L'.SgiCookie (_, x', n1, c1) => - if x = x' then - (case unifyCons (env, denv) (L'.CApp (cookieOf (), c1), loc) c2 of - [] => SOME (env, denv) - | _ => NONE) - handle CUnify (c1, c2, err) => - (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); - SOME (env, denv)) - else - NONE | _ => NONE) | L'.SgiStr (x, n2, sgn2) => @@ -2600,31 +2518,6 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = NONE | _ => NONE) - | L'.SgiTable (_, x, n2, c2) => - seek (fn sgi1All as (sgi1, _) => - case sgi1 of - L'.SgiTable (_, x', n1, c1) => - if x = x' then - (case unifyCons (env, denv) c1 c2 of - [] => SOME (env, denv) - | _ => NONE) - handle CUnify (c1, c2, err) => - (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); - SOME (env, denv)) - else - NONE - | _ => NONE) - - | L'.SgiSequence (_, x, n2) => - seek (fn sgi1All as (sgi1, _) => - case sgi1 of - L'.SgiSequence (_, x', n1) => - if x = x' then - SOME (env, denv) - else - NONE - | _ => NONE) - | L'.SgiClassAbs (x, n2) => seek (fn sgi1All as (sgi1, _) => let @@ -2681,21 +2574,6 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = L'.SgiClass (x', n1, c1) => found (x', n1, c1) | _ => NONE end) - - | L'.SgiCookie (_, x, n2, c2) => - seek (fn sgi1All as (sgi1, _) => - case sgi1 of - L'.SgiCookie (_, x', n1, c1) => - if x = x' then - (case unifyCons (env, denv) c1 c2 of - [] => SOME (env, denv) - | _ => NONE) - handle CUnify (c1, c2, err) => - (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); - SOME (env, denv)) - else - NONE - | _ => NONE) end in ignore (foldl folder (env, denv) sgis2) @@ -3347,26 +3225,6 @@ and elabStr (env, denv) (str, loc) = ((L'.SgiStr (x, n, sgn), loc) :: sgis, cons, vals, sgns, strs) end | L'.SgiConstraint _ => ((sgi, loc) :: sgis, cons, vals, sgns, strs) - | L'.SgiTable (tn, x, n, c) => - let - val (vals, x) = - if SS.member (vals, x) then - (vals, "?" ^ x) - else - (SS.add (vals, x), x) - in - ((L'.SgiTable (tn, x, n, c), loc) :: sgis, cons, vals, sgns, strs) - end - | L'.SgiSequence (tn, x, n) => - let - val (vals, x) = - if SS.member (vals, x) then - (vals, "?" ^ x) - else - (SS.add (vals, x), x) - in - ((L'.SgiSequence (tn, x, n), loc) :: sgis, cons, vals, sgns, strs) - end | L'.SgiClassAbs (x, n) => let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) @@ -3390,16 +3248,6 @@ and elabStr (env, denv) (str, loc) = (SS.add (cons, x), x) in ((L'.SgiClass (x, n, c), loc) :: sgis, cons, vals, sgns, strs) - end - | L'.SgiCookie (tn, x, n, c) => - let - val (vals, x) = - if SS.member (vals, x) then - (vals, "?" ^ x) - else - (SS.add (vals, x), x) - in - ((L'.SgiCookie (tn, x, n, c), loc) :: sgis, cons, vals, sgns, strs) end) ([], SS.empty, SS.empty, SS.empty, SS.empty) sgis diff --git a/src/expl.sml b/src/expl.sml index 8f531516..57396684 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -110,8 +110,6 @@ datatype sgn_item' = | SgiVal of string * int * con | SgiSgn of string * int * sgn | SgiStr of string * int * sgn - | SgiTable of int * string * int * con - | SgiSequence of int * string * int and sgn' = SgnConst of sgn_item list @@ -136,6 +134,7 @@ datatype decl' = | DTable of int * string * int * con | DSequence of int * string * int | DDatabase of string + | DCookie of int * string * int * con and str' = StrConst of decl list diff --git a/src/expl_env.sml b/src/expl_env.sml index 43456c41..0fefec2d 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -295,6 +295,12 @@ fun declBinds env (d, loc) = pushENamed env x n t end | DDatabase _ => env + | DCookie (tn, x, n, c) => + let + val t = (CApp ((CModProj (tn, [], "http_cookie"), loc), c), loc) + in + pushENamed env x n t + end fun sgiBinds env (sgi, loc) = case sgi of @@ -341,17 +347,4 @@ fun sgiBinds env (sgi, loc) = | SgiSgn (x, n, sgn) => pushSgnNamed env x n sgn | SgiStr (x, n, sgn) => pushStrNamed env x n sgn - | SgiTable (tn, x, n, c) => - let - val t = (CApp ((CModProj (tn, [], "sql_table"), loc), c), loc) - in - pushENamed env x n t - end - | SgiSequence (tn, x, n) => - let - val t = (CModProj (tn, [], "sql_sequence"), loc) - in - pushENamed env x n t - end - end diff --git a/src/expl_print.sml b/src/expl_print.sml index aecc3a84..2d41ab34 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -471,16 +471,6 @@ fun p_sgn_item env (sgi, _) = string "=", space, p_sgn env sgn] - | SgiTable (_, x, n, c) => box [string "table", - space, - p_named x n, - space, - string ":", - space, - p_con env c] - | SgiSequence (_, x, n) => box [string "sequence", - space, - p_named x n] and p_sgn env (sgn, loc) = case sgn of @@ -635,6 +625,13 @@ fun p_decl env (dAll as (d, _) : decl) = | DDatabase s => box [string "database", space, string s] + | DCookie (_, x, n, c) => box [string "cookie", + space, + p_named x n, + space, + string ":", + space, + p_con env c] and p_str env (str, _) = case str of diff --git a/src/expl_util.sml b/src/expl_util.sml index 337ea8d6..2bd9eabd 100644 --- a/src/expl_util.sml +++ b/src/expl_util.sml @@ -432,11 +432,6 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = S.map2 (sg ctx s, fn s' => (SgiSgn (x, n, s'), loc)) - | SgiTable (tn, x, n, c) => - S.map2 (con ctx c, - fn c' => - (SgiTable (tn, x, n, c'), loc)) - | SgiSequence _ => S.return2 siAll and sg ctx s acc = S.bindP (sg' ctx s acc, sgn ctx) @@ -458,9 +453,7 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = | SgiStr (x, _, sgn) => bind (ctx, Str (x, sgn)) | SgiSgn (x, _, sgn) => - bind (ctx, Sgn (x, sgn)) - | SgiTable _ => ctx - | SgiSequence _ => ctx, + bind (ctx, Sgn (x, sgn)), sgi ctx si)) ctx sgis, fn sgis' => (SgnConst sgis', loc)) diff --git a/src/explify.sml b/src/explify.sml index e19bb200..4115476b 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -137,8 +137,6 @@ fun explifySgi (sgi, loc) = | L.SgiStr (x, n, sgn) => SOME (L'.SgiStr (x, n, explifySgn sgn), loc) | L.SgiSgn (x, n, sgn) => SOME (L'.SgiSgn (x, n, explifySgn sgn), loc) | L.SgiConstraint _ => NONE - | L.SgiTable (nt, x, n, c) => SOME (L'.SgiTable (nt, x, n, explifyCon c), loc) - | L.SgiSequence (nt, x, n) => SOME (L'.SgiSequence (nt, x, n), loc) | L.SgiClassAbs (x, n) => SOME (L'.SgiConAbs (x, n, (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc)), loc) | L.SgiClass (x, n, c) => SOME (L'.SgiCon (x, n, (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc), explifyCon c), loc) @@ -175,6 +173,7 @@ fun explifyDecl (d, loc : EM.span) = | L.DClass (x, n, c) => SOME (L'.DCon (x, n, (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc), explifyCon c), loc) | L.DDatabase s => SOME (L'.DDatabase s, loc) + | L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc) and explifyStr (str, loc) = case str of diff --git a/src/source.sml b/src/source.sml index a0591afb..2a348338 100644 --- a/src/source.sml +++ b/src/source.sml @@ -81,11 +81,8 @@ datatype sgn_item' = | SgiSgn of string * sgn | SgiInclude of sgn | SgiConstraint of con * con - | SgiTable of string * con - | SgiSequence of string | SgiClassAbs of string | SgiClass of string * con - | SgiCookie of string * con and sgn' = SgnConst of sgn_item list diff --git a/src/source_print.sml b/src/source_print.sml index d33fb38d..3c26812f 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -408,16 +408,6 @@ fun p_sgn_item (sgi, _) = string "~", space, p_con c2] - | SgiTable (x, c) => box [string "table", - space, - string x, - space, - string ":", - space, - p_con c] - | SgiSequence x => box [string "sequence", - space, - string x] | SgiClassAbs x => box [string "class", space, string x] @@ -428,13 +418,6 @@ fun p_sgn_item (sgi, _) = string "=", space, p_con c] - | SgiCookie (x, c) => box [string "cookie", - space, - string x, - space, - string ":", - space, - p_con c] and p_sgn (sgn, _) = case sgn of diff --git a/src/urweb.grm b/src/urweb.grm index 879afb9c..b2f2d486 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -497,8 +497,19 @@ sgi : CON SYMBOL DCOLON kind (SgiConAbs (SYMBOL, kind), s (CONleft, k s (FUNCTORleft, sgn2right)) | INCLUDE sgn (SgiInclude sgn, s (INCLUDEleft, sgnright)) | CONSTRAINT cterm TWIDDLE cterm (SgiConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright)) - | TABLE SYMBOL COLON cexp (SgiTable (SYMBOL, entable cexp), s (TABLEleft, cexpright)) - | SEQUENCE SYMBOL (SgiSequence SYMBOL, s (SEQUENCEleft, SYMBOLright)) + | TABLE SYMBOL COLON cexp (let + val loc = s (TABLEleft, cexpright) + val t = (CApp ((CVar (["Basis"], "sql_table"), loc), + entable cexp), loc) + in + (SgiVal (SYMBOL, t), loc) + end) + | SEQUENCE SYMBOL (let + val loc = s (SEQUENCEleft, SYMBOLright) + val t = (CVar (["Basis"], "sql_sequence"), loc) + in + (SgiVal (SYMBOL, t), loc) + end) | CLASS SYMBOL (SgiClassAbs SYMBOL, s (CLASSleft, SYMBOLright)) | CLASS SYMBOL EQ cexp (SgiClass (SYMBOL, cexp), s (CLASSleft, cexpright)) | CLASS SYMBOL SYMBOL EQ cexp (let @@ -508,7 +519,13 @@ sgi : CON SYMBOL DCOLON kind (SgiConAbs (SYMBOL, kind), s (CONleft, k in (SgiClass (SYMBOL1, c), s (CLASSleft, cexpright)) end) - | COOKIE SYMBOL COLON cexp (SgiCookie (SYMBOL, cexp), s (COOKIEleft, cexpright)) + | COOKIE SYMBOL COLON cexp (let + val loc = s (COOKIEleft, cexpright) + val t = (CApp ((CVar (["Basis"], "http_cookie"), loc), + entable cexp), loc) + in + (SgiVal (SYMBOL, t), loc) + end) sgis : ([]) | sgi sgis (sgi :: sgis) -- cgit v1.2.3 From 0a10b5b7d2bbdcbfec723176b2a31d6b4c6d34d1 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 15:37:38 -0500 Subject: Inserted a NULL value --- CHANGELOG | 9 +++++ include/urweb.h | 6 +++ lib/basis.urs | 5 +++ src/c/urweb.c | 35 ++++++++++++++++++ src/cjr_print.sml | 101 +++++++++++++++++++++++++++++++++++++++++---------- src/elab_env.sml | 31 ++++++++++++++-- src/elaborate.sml | 47 ++++++++++++++++-------- src/mono_opt.sml | 5 +++ src/monoize.sml | 24 ++++++++++-- src/urweb.grm | 5 ++- src/urweb.lex | 1 + tests/sql_option.ur | 22 +++++++++++ tests/sql_option.urp | 5 +++ 13 files changed, 252 insertions(+), 44 deletions(-) create mode 100644 tests/sql_option.ur create mode 100644 tests/sql_option.urp (limited to 'src/elab_env.sml') diff --git a/CHANGELOG b/CHANGELOG index aca01ea7..0f8d0f09 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,12 @@ +======== +NEXT +======== + +- Nested function definitions +- Primitive "time" type +- Nullable SQL columns (via "option") +- Cookies + ======== 20081028 ======== diff --git a/include/urweb.h b/include/urweb.h index 7db66ed4..7e16fd40 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -80,6 +80,12 @@ uw_Basis_string uw_Basis_sqlifyString(uw_context, uw_Basis_string); uw_Basis_string uw_Basis_sqlifyBool(uw_context, uw_Basis_bool); uw_Basis_string uw_Basis_sqlifyTime(uw_context, uw_Basis_time); +uw_Basis_string uw_Basis_sqlifyIntN(uw_context, uw_Basis_int*); +uw_Basis_string uw_Basis_sqlifyFloatN(uw_context, uw_Basis_float*); +uw_Basis_string uw_Basis_sqlifyStringN(uw_context, uw_Basis_string); +uw_Basis_string uw_Basis_sqlifyBoolN(uw_context, uw_Basis_bool*); +uw_Basis_string uw_Basis_sqlifyTimeN(uw_context, uw_Basis_time*); + char *uw_Basis_ensqlBool(uw_Basis_bool); uw_Basis_string uw_Basis_intToString(uw_context, uw_Basis_int); diff --git a/lib/basis.urs b/lib/basis.urs index 84fb4e4c..f68bedee 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -188,6 +188,11 @@ val sql_int : sql_injectable int val sql_float : sql_injectable float val sql_string : sql_injectable string val sql_time : sql_injectable time +val sql_option_bool : sql_injectable (option bool) +val sql_option_int : sql_injectable (option int) +val sql_option_float : sql_injectable (option float) +val sql_option_string : sql_injectable (option string) +val sql_option_time : sql_injectable (option time) val sql_inject : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type -> sql_injectable t -> t -> sql_exp tables agg exps t diff --git a/src/c/urweb.c b/src/c/urweb.c index 638fbb16..1530c138 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -872,6 +872,13 @@ char *uw_Basis_sqlifyInt(uw_context ctx, uw_Basis_int n) { return r; } +char *uw_Basis_sqlifyIntN(uw_context ctx, uw_Basis_int *n) { + if (n == NULL) + return "NULL"; + else + return uw_Basis_sqlifyInt(ctx, *n); +} + char *uw_Basis_sqlifyFloat(uw_context ctx, uw_Basis_float n) { int len; char *r; @@ -883,6 +890,13 @@ char *uw_Basis_sqlifyFloat(uw_context ctx, uw_Basis_float n) { return r; } +char *uw_Basis_sqlifyFloatN(uw_context ctx, uw_Basis_float *n) { + if (n == NULL) + return "NULL"; + else + return uw_Basis_sqlifyFloat(ctx, *n); +} + uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) { char *r, *s2; @@ -920,6 +934,13 @@ uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) { return r; } +uw_Basis_string uw_Basis_sqlifyStringN(uw_context ctx, uw_Basis_string s) { + if (s == NULL) + return "NULL"; + else + return uw_Basis_sqlifyString(ctx, s); +} + char *uw_Basis_sqlifyBool(uw_context ctx, uw_Basis_bool b) { if (b == uw_Basis_False) return "FALSE"; @@ -927,6 +948,13 @@ char *uw_Basis_sqlifyBool(uw_context ctx, uw_Basis_bool b) { return "TRUE"; } +char *uw_Basis_sqlifyBoolN(uw_context ctx, uw_Basis_bool *b) { + if (b == NULL) + return "NULL"; + else + return uw_Basis_sqlifyBool(ctx, *b); +} + char *uw_Basis_sqlifyTime(uw_context ctx, uw_Basis_time t) { size_t len; char *r; @@ -942,6 +970,13 @@ char *uw_Basis_sqlifyTime(uw_context ctx, uw_Basis_time t) { return ""; } +char *uw_Basis_sqlifyTimeN(uw_context ctx, uw_Basis_time *t) { + if (t == NULL) + return "NULL"; + else + return uw_Basis_sqlifyTime(ctx, *t); +} + char *uw_Basis_ensqlBool(uw_Basis_bool b) { static uw_Basis_int true = 1; static uw_Basis_int false = 0; diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 06154b91..d7e426c3 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -408,24 +408,61 @@ fun p_unsql wontLeakStrings env (tAll as (t, loc)) e = box [string "uw_Basis_strdup(ctx, ", e, string ")"] | TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"] | TFfi ("Basis", "time") => box [string "uw_Basis_stringToTime_error(ctx, ", e, string ")"] + | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL"; Print.eprefaces' [("Type", p_typ env tAll)]; string "ERROR") +fun p_getcol wontLeakStrings env (tAll as (t, loc)) i = + case t of + TOption t => + box [string "(PQgetisnull (res, i, ", + string (Int.toString i), + string ") ? NULL : ", + case t of + (TFfi ("Basis", "string"), _) => p_getcol wontLeakStrings env t i + | _ => box [string "({", + newline, + p_typ env t, + space, + string "*tmp = uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp = ", + p_getcol wontLeakStrings env t i, + string ";", + newline, + string "tmp;", + newline, + string "})"], + string ")"] + + | _ => + p_unsql wontLeakStrings env tAll + (box [string "PQgetvalue(res, i, ", + string (Int.toString i), + string ")"]) + datatype sql_type = Int | Float | String | Bool | Time + | Nullable of sql_type + +fun p_sql_type' t = + case t of + Int => "uw_Basis_int" + | Float => "uw_Basis_float" + | String => "uw_Basis_string" + | Bool => "uw_Basis_bool" + | Time => "uw_Basis_time" + | Nullable String => "uw_Basis_string" + | Nullable t => p_sql_type' t ^ "*" -fun p_sql_type t = - string (case t of - Int => "uw_Basis_int" - | Float => "uw_Basis_float" - | String => "uw_Basis_string" - | Bool => "uw_Basis_bool" - | Time => "uw_Basis_time") +fun p_sql_type t = string (p_sql_type' t) fun getPargs (e, _) = case e of @@ -448,6 +485,12 @@ fun p_ensql t e = | String => e | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"] | Time => box [string "uw_Basis_sqlifyTime(ctx, ", e, string ")"] + | Nullable String => e + | Nullable t => box [string "(", + e, + string " == NULL ? NULL : ", + p_ensql t (box [string "*", e]), + string ")"] fun notLeaky env allowHeapAllocated = let @@ -1169,10 +1212,7 @@ fun p_exp' par env (e, loc) = space, string "=", space, - p_unsql wontLeakStrings env t - (box [string "PQgetvalue(res, i, ", - string (Int.toString i), - string ")"]), + p_getcol wontLeakStrings env t i, string ";", newline]) outputs, @@ -1660,7 +1700,10 @@ fun p_decl env (dAll as (d, _) : decl) = string "}", newline] - | DPreparedStatements [] => box [] + | DPreparedStatements [] => + box [string "static void uw_db_prepare(uw_context ctx) {", + newline, + string "}"] | DPreparedStatements ss => box [string "static void uw_db_prepare(uw_context ctx) {", newline, @@ -1708,7 +1751,7 @@ datatype 'a search = | NotFound | Error -fun p_sqltype' env (tAll as (t, loc)) = +fun p_sqltype'' env (tAll as (t, loc)) = case t of TFfi ("Basis", "int") => "int8" | TFfi ("Basis", "float") => "float8" @@ -1719,8 +1762,25 @@ fun p_sqltype' env (tAll as (t, loc)) = Print.eprefaces' [("Type", p_typ env tAll)]; "ERROR") +fun p_sqltype' env (tAll as (t, loc)) = + case t of + (TOption t, _) => p_sqltype'' env t + | _ => p_sqltype'' env t ^ " NOT NULL" + fun p_sqltype env t = string (p_sqltype' env t) +fun p_sqltype_base' env t = + case t of + (TOption t, _) => p_sqltype'' env t + | _ => p_sqltype'' env t + +fun p_sqltype_base env t = string (p_sqltype_base' env t) + +fun is_not_null t = + case t of + (TOption _, _) => false + | _ => true + fun p_file env (ds, ps) = let val (pds, env) = ListUtil.foldlMap (fn (d, env) => @@ -1997,8 +2057,13 @@ fun p_file env (ds, ps) = Char.toLower (ident x), "' AND atttypid = (SELECT oid FROM pg_type", " WHERE typname = '", - p_sqltype' env t, - "'))"]) xts), + p_sqltype_base' env t, + "') AND attnotnull = ", + if is_not_null t then + "TRUE" + else + "FALSE", + ")"]) xts), ")"] val q'' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '", @@ -2295,11 +2360,7 @@ fun p_sql env (ds, _) = box [string "uw_", string (CharVector.map Char.toLower x), space, - p_sqltype env t, - space, - string "NOT", - space, - string "NULL"]) xts, + p_sqltype env (t, ErrorMsg.dummySpan)]) xts, string ");", newline, newline] diff --git a/src/elab_env.sml b/src/elab_env.sml index b14cd06c..46f62727 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -150,12 +150,14 @@ datatype class_key = CkNamed of int | CkRel of int | CkProj of int * string list * string + | CkApp of class_key * class_key fun ck2s ck = case ck of CkNamed n => "Named(" ^ Int.toString n ^ ")" | CkRel n => "Rel(" ^ Int.toString n ^ ")" | CkProj (m, ms, x) => "Proj(" ^ Int.toString m ^ "," ^ String.concatWith "," ms ^ "," ^ x ^ ")" + | CkApp (ck1, ck2) => "App(" ^ ck2s ck1 ^ ", " ^ ck2s ck2 ^ ")" fun cp2s (cn, ck) = "(" ^ cn2s cn ^ "," ^ ck2s ck ^ ")" @@ -176,6 +178,12 @@ fun compare x = join (Int.compare (m1, m2), fn () => join (joinL String.compare (ms1, ms2), fn () => String.compare (x1, x2))) + | (CkProj _, _) => LESS + | (_, CkProj _) => GREATER + + | (CkApp (f1, x1), CkApp (f2, x2)) => + join (compare (f1, f2), + fn () => compare (x1, x2)) end structure KM = BinaryMapFn(KK) @@ -251,6 +259,7 @@ fun liftClassKey ck = CkNamed _ => ck | CkRel n => CkRel (n + 1) | CkProj _ => ck + | CkApp (ck1, ck2) => CkApp (liftClassKey ck1, liftClassKey ck2) fun pushCRel (env : env) x k = let @@ -411,6 +420,10 @@ fun class_key_in (c, _) = | CNamed n => SOME (CkNamed n) | CModProj x => SOME (CkProj x) | CUnif (_, _, _, ref (SOME c)) => class_key_in c + | CApp (c1, c2) => + (case (class_key_in c1, class_key_in c2) of + (SOME k1, SOME k2) => SOME (CkApp (k1, k2)) + | _ => NONE) | _ => NONE fun class_pair_in (c, _) = @@ -653,7 +666,7 @@ fun sgnS_con (str, (sgns, strs, cons)) c = end) | _ => c -fun sgnS_con' (m1, ms', (sgns, strs, cons)) c = +fun sgnS_con' (arg as (m1, ms', (sgns, strs, cons))) c = case c of CModProj (m1, ms, x) => (case IM.find (strs, m1) of @@ -663,6 +676,8 @@ fun sgnS_con' (m1, ms', (sgns, strs, cons)) c = (case IM.find (cons, n) of NONE => c | SOME nx => CModProj (m1, ms', nx)) + | CApp (c1, c2) => CApp ((sgnS_con' arg (#1 c1), #2 c1), + (sgnS_con' arg (#1 c2), #2 c2)) | _ => c fun sgnS_sgn (str, (sgns, strs, cons)) sgn = @@ -1033,13 +1048,21 @@ fun projectVal env {sgn, str, field} = ListUtil.search (fn (x, _, to) => if x = field then SOME (let + val base = (CNamed n, #2 sgn) + val nxs = length xs + val base = ListUtil.foldli (fn (i, _, base) => + (CApp (base, + (CRel (nxs - i - 1), #2 sgn)), + #2 sgn)) + base xs + val t = case to of - NONE => (CNamed n, #2 sgn) - | SOME t => (TFun (t, (CNamed n, #2 sgn)), #2 sgn) + NONE => base + | SOME t => (TFun (t, base), #2 sgn) val k = (KType, #2 sgn) in - foldr (fn (x, t) => (TCFun (Explicit, x, k, t), #2 sgn)) + foldr (fn (x, t) => (TCFun (Implicit, x, k, t), #2 sgn)) t xs end) else diff --git a/src/elaborate.sml b/src/elaborate.sml index 3b70c623..a6edc0ed 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1389,17 +1389,32 @@ fun unmodCon env (c, loc) = end | _ => (c, loc) -fun normClassConstraint envs (c, loc) = +fun normClassKey envs c = + let + val c = ElabOps.hnormCon envs c + in + case #1 c of + L'.CApp (c1, c2) => + let + val c1 = normClassKey envs c1 + val c2 = normClassKey envs c2 + in + (L'.CApp (c1, c2), #2 c) + end + | _ => c + end + +fun normClassConstraint env (c, loc) = case c of L'.CApp (f, x) => let - val f = unmodCon (#1 envs) f - val (x, gs) = hnormCon envs x + val f = unmodCon env f + val x = normClassKey env x in - ((L'.CApp (f, x), loc), gs) + (L'.CApp (f, x), loc) end - | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint envs c - | _ => ((c, loc), []) + | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint env c + | _ => (c, loc) val makeInstantiable = @@ -1491,12 +1506,12 @@ fun elabExp (env, denv) (eAll as (e, loc)) = checkKind env t' tk ktype; (t', gs) end - val (dom, gs2) = normClassConstraint (env, denv) t' - val (e', et, gs3) = elabExp (E.pushERel env x dom, denv) e + val dom = normClassConstraint env t' + val (e', et, gs2) = elabExp (E.pushERel env x dom, denv) e in ((L'.EAbs (x, t', et, e'), loc), (L'.TFun (t', et), loc), - enD gs1 @ enD gs2 @ gs3) + enD gs1 @ gs2) end | L.ECApp (e, c) => let @@ -1708,11 +1723,11 @@ and elabEdecl denv (dAll as (d, loc), (env, gs : constraint list)) = val (e', et, gs2) = elabExp (env, denv) e val gs3 = checkCon (env, denv) e' et c' - val (c', gs4) = normClassConstraint (env, denv) c' + val c' = normClassConstraint env c' val env' = E.pushERel env x c' val c' = makeInstantiable c' in - ((L'.EDVal (x, c', e'), loc), (env', enD gs1 @ gs2 @ enD gs3 @ enD gs4 @ gs)) + ((L'.EDVal (x, c', e'), loc), (env', enD gs1 @ gs2 @ enD gs3 @ gs)) end | L.EDValRec vis => let @@ -1884,12 +1899,12 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = val (c', ck, gs') = elabCon (env, denv) c val (env', n) = E.pushENamed env x c' - val (c', gs'') = normClassConstraint (env, denv) c' + val c' = normClassConstraint env c' in (unifyKinds ck ktype handle KUnify ue => strError env (NotType (ck, ue))); - ([(L'.SgiVal (x, n, c'), loc)], (env', denv, gs' @ gs'' @ gs)) + ([(L'.SgiVal (x, n, c'), loc)], (env', denv, gs' @ gs)) end | L.SgiStr (x, sgn) => @@ -2875,13 +2890,13 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = val (e', et, gs2) = elabExp (env, denv) e val gs3 = checkCon (env, denv) e' et c' - val (c', gs4) = normClassConstraint (env, denv) c' + val c = normClassConstraint env c' val (env', n) = E.pushENamed env x c' val c' = makeInstantiable c' in (*prefaces "DVal" [("x", Print.PD.string x), ("c'", p_con env c')];*) - ([(L'.DVal (x, n, c', e'), loc)], (env', denv, enD gs1 @ gs2 @ enD gs3 @ enD gs4 @ gs)) + ([(L'.DVal (x, n, c', e'), loc)], (env', denv, enD gs1 @ gs2 @ enD gs3 @ gs)) end | L.DValRec vis => let @@ -3404,7 +3419,7 @@ fun elabFile basis topStr topSgn env file = ("Hnormed 2", p_con env (ElabOps.hnormCon env c2))])) | TypeClass (env, c, r, loc) => let - val c = ElabOps.hnormCon env c + val c = normClassKey env c in case E.resolveClass env c of SOME e => r := SOME e diff --git a/src/mono_opt.sml b/src/mono_opt.sml index b22f053b..93cb888b 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -268,6 +268,11 @@ fun exp e = | EFfiApp ("Basis", "sqlifyInt", [(EPrim (Prim.Int n), _)]) => EPrim (Prim.String (sqlifyInt n)) + | EFfiApp ("Basis", "sqlifyIntN", [(ENone _, _)]) => + EPrim (Prim.String "NULL") + | EFfiApp ("Basis", "sqlifyIntN", [(ESome (_, (EPrim (Prim.Int n), _)), _)]) => + EPrim (Prim.String (sqlifyInt n)) + | EFfiApp ("Basis", "sqlifyFloat", [(EPrim (Prim.Float n), _)]) => EPrim (Prim.String (sqlifyFloat n)) | EFfiApp ("Basis", "sqlifyBool", [b as (_, loc)]) => diff --git a/src/monoize.sml b/src/monoize.sml index c4c296bd..83da382b 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -982,10 +982,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EFfiApp ("Basis", "dml", [e]) => let val (e, fm) = monoExp (env, st, fm) e - val un = (L'.TRecord [], loc) in - ((L'.EAbs ("_", un, un, - (L'.EDml (liftExpInExp 0 e), loc)), loc), + ((L'.EDml (liftExpInExp 0 e), loc), fm) end @@ -1274,6 +1272,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc), (L'.EFfiApp ("Basis", "sqlifyTime", [(L'.ERel 0, loc)]), loc)), loc), fm) + | L.EFfi ("Basis", "sql_option_int") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "int"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyIntN", [(L'.ERel 0, loc)]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_option_float") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "float"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyFloatN", [(L'.ERel 0, loc)]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_option_bool") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "bool"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyBoolN", [(L'.ERel 0, loc)]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_option_string") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "string"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyStringN", [(L'.ERel 0, loc)]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_option_time") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "time"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyTimeN", [(L'.ERel 0, loc)]), loc)), loc), + fm) | L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) => ((L'.ERecord [], loc), fm) diff --git a/src/urweb.grm b/src/urweb.grm index b2f2d486..2482be1b 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -214,7 +214,7 @@ fun tagIn bt = | TRUE | FALSE | CAND | OR | NOT | COUNT | AVG | SUM | MIN | MAX | ASC | DESC - | INSERT | INTO | VALUES | UPDATE | SET | DELETE + | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | CURRENT_TIMESTAMP | NE | LT | LE | GT | GE @@ -1251,6 +1251,9 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In s (LBRACEleft, RBRACEright))) | LPAREN sqlexp RPAREN (sqlexp) + | NULL (sql_inject ((EVar (["Basis"], "None", Infer), + s (NULLleft, NULLright)))) + | COUNT LPAREN STAR RPAREN (let val loc = s (COUNTleft, RPARENright) in diff --git a/src/urweb.lex b/src/urweb.lex index f5ea558a..f4ae3a85 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -357,6 +357,7 @@ notags = [^<{\n]+; "UPDATE" => (Tokens.UPDATE (pos yypos, pos yypos + size yytext)); "SET" => (Tokens.SET (pos yypos, pos yypos + size yytext)); "DELETE" => (Tokens.DELETE (pos yypos, pos yypos + size yytext)); + "NULL" => (Tokens.NULL (pos yypos, pos yypos + size yytext)); "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext)); diff --git a/tests/sql_option.ur b/tests/sql_option.ur new file mode 100644 index 00000000..257f8c55 --- /dev/null +++ b/tests/sql_option.ur @@ -0,0 +1,22 @@ +table t : { O : option int } + +fun addNull () = + dml (INSERT INTO t (O) VALUES (NULL)); + return Done + +(*fun add42 () = + dml (INSERT INTO t (O) VALUES (42)); + return Done*) + +fun main () : transaction page = + xml <- queryX (SELECT * FROM t) + (fn r => case r.T.O of + None => Nada
 + | Some n => Num: {[n]}
); + return + {xml} + + Add a null
+ + +(* Add a 42
*) diff --git a/tests/sql_option.urp b/tests/sql_option.urp new file mode 100644 index 00000000..543c32a8 --- /dev/null +++ b/tests/sql_option.urp @@ -0,0 +1,5 @@ +debug +database dbname=option +sql option.sql + +sql_option -- cgit v1.2.3 From 24b68e6d7408f50023272e765687eab777596363 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 19:43:48 -0500 Subject: Tree demo working (and other assorted regressions fixed) --- demo/crud.ur | 8 ++++---- demo/prose | 4 ++++ demo/refFun.ur | 8 ++++---- demo/sql.ur | 4 ++-- demo/tree.ur | 22 ++++++++++++++++++++-- demo/tree.urp | 2 +- demo/treeFun.ur | 2 +- lib/top.ur | 4 ++-- src/cjr_print.sml | 37 +++++++++++++++++++++++++++++++++++++ src/elab_env.sig | 1 + src/elab_env.sml | 3 +++ src/elaborate.sml | 16 +++++++++++----- src/monoize.sml | 16 ++++++++++++++++ src/urweb.grm | 6 +++--- 14 files changed, 109 insertions(+), 24 deletions(-) (limited to 'src/elab_env.sml') diff --git a/demo/crud.ur b/demo/crud.ur index ee6a95f6..a120cb2a 100644 --- a/demo/crud.ur +++ b/demo/crud.ur @@ -102,7 +102,7 @@ functor Make(M : sig [[nm] ~ rest] => fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)}) {} [M.cols] inputs M.cols - ++ {Id = (SQL {id})})); + ++ {Id = (SQL {[id]})})); ls <- list (); return

Inserted with ID {[id]}.

@@ -122,7 +122,7 @@ functor Make(M : sig fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)}) {} [M.cols] inputs M.cols) - tab (WHERE T.Id = {id})); + tab (WHERE T.Id = {[id]})); ls <- list (); return

Saved!

@@ -131,7 +131,7 @@ functor Make(M : sig and upd (id : int) = - fso <- oneOrNoRows (SELECT tab.{{mapT2T fstTT M.cols}} FROM tab WHERE tab.Id = {id}); + fso <- oneOrNoRows (SELECT tab.{{mapT2T fstTT M.cols}} FROM tab WHERE tab.Id = {[id]}); case fso : (Basis.option {Tab : $(mapT2T fstTT M.cols)}) of None => return Not found! | Some fs => return
@@ -150,7 +150,7 @@ functor Make(M : sig
and delete (id : int) = - dml (DELETE FROM tab WHERE Id = {id}); + dml (DELETE FROM tab WHERE Id = {[id]}); ls <- list (); return

The deed is done.

diff --git a/demo/prose b/demo/prose index fad98e26..11661211 100644 --- a/demo/prose +++ b/demo/prose @@ -132,6 +132,10 @@ metaform2.urp

This example showcases code reuse by applying the same functor as in the last example. The Metaform2 module mixes pages from the functor with some new pages of its own.

+tree.urp + +

Here we see how we can abstract over common patterns of SQL queries. In particular, since standard SQL does not help much with queries over trees, we write a function for traversing an SQL tree, building an HTML representation, based on a user-provided function for rendering individual rows.

+ crud1.urp

This example pulls together much of what we have seen so far. It involves a generic "admin interface" builder. That is, we have the Crud.Make functor, which takes in a description of a table and outputs a sub-application for viewing and editing that table.

diff --git a/demo/refFun.ur b/demo/refFun.ur index d648f31e..e523bac7 100644 --- a/demo/refFun.ur +++ b/demo/refFun.ur @@ -10,19 +10,19 @@ functor Make(M : sig fun new d = id <- nextval s; - dml (INSERT INTO t (Id, Data) VALUES ({id}, {d})); + dml (INSERT INTO t (Id, Data) VALUES ({[id]}, {[d]})); return id fun read r = - o <- oneOrNoRows (SELECT t.Data FROM t WHERE t.Id = {r}); + o <- oneOrNoRows (SELECT t.Data FROM t WHERE t.Id = {[r]}); return (case o of None => error You already deleted that ref! | Some r => r.T.Data) fun write r d = - dml (UPDATE t SET Data = {d} WHERE Id = {r}) + dml (UPDATE t SET Data = {[d]} WHERE Id = {[r]}) fun delete r = - dml (DELETE FROM t WHERE Id = {r}) + dml (DELETE FROM t WHERE Id = {[r]}) end diff --git a/demo/sql.ur b/demo/sql.ur index 43a69573..44ff478f 100644 --- a/demo/sql.ur +++ b/demo/sql.ur @@ -27,7 +27,7 @@ fun list () = and add r = dml (INSERT INTO t (A, B, C, D) - VALUES ({readError r.A}, {readError r.B}, {r.C}, {r.D})); + VALUES ({[readError r.A]}, {[readError r.B]}, {[r.C]}, {[r.D]})); xml <- list (); return

Row added.

@@ -37,7 +37,7 @@ and add r = and delete a = dml (DELETE FROM t - WHERE t.A = {a}); + WHERE t.A = {[a]}); xml <- list (); return

Row deleted.

diff --git a/demo/tree.ur b/demo/tree.ur index 06a30cf9..27e9aa21 100644 --- a/demo/tree.ur +++ b/demo/tree.ur @@ -1,3 +1,4 @@ +sequence s table t : { Id : int, Parent : option int, Nam : string } open TreeFun.Make(struct @@ -5,11 +6,28 @@ open TreeFun.Make(struct end) fun row r = - #{[r.Id]}: {[r.Nam]} + #{[r.Id]}: {[r.Nam]} [Delete] + +
+ Add child: +
-fun main () = +and main () = xml <- tree row None; return {xml} + +
+ Add a top-level node: +
+ +and add parent r = + id <- nextval s; + dml (INSERT INTO t (Id, Parent, Nam) VALUES ({[id]}, {[parent]}, {[r.Nam]})); + main () + +and del id = + dml (DELETE FROM t WHERE Id = {[id]}); + main () diff --git a/demo/tree.urp b/demo/tree.urp index 2270dd06..880a7ab4 100644 --- a/demo/tree.urp +++ b/demo/tree.urp @@ -1,5 +1,5 @@ debug -database dbname=tree +database dbname=test sql tree.sql treeFun diff --git a/demo/treeFun.ur b/demo/treeFun.ur index 236f354c..15fe60f5 100644 --- a/demo/treeFun.ur +++ b/demo/treeFun.ur @@ -18,7 +18,7 @@ functor Make(M : sig (root : option M.key) = let fun recurse (root : option key) = - queryX' (SELECT * FROM tab WHERE {[eqNullable' (SQL tab.{parent}) root]}) + queryX' (SELECT * FROM tab WHERE {eqNullable' (SQL tab.{parent}) root}) (fn r => children <- recurse (Some r.Tab.id); return diff --git a/lib/top.ur b/lib/top.ur index 5d00282c..76fe73c1 100644 --- a/lib/top.ur +++ b/lib/top.ur @@ -230,12 +230,12 @@ fun eqNullable (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type}) (t ::: Type) (_ : sql_injectable (option t)) (e1 : sql_exp tables agg exps (option t)) (e2 : sql_exp tables agg exps (option t)) = - (SQL ({[e1]} IS NULL AND {[e2]} IS NULL) OR {[e1]} = {[e2]}) + (SQL ({e1} IS NULL AND {e2} IS NULL) OR {e1} = {e2}) fun eqNullable' (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type}) (t ::: Type) (inj : sql_injectable (option t)) (e1 : sql_exp tables agg exps (option t)) (e2 : option t) = case e2 of - None => (SQL {[e1]} IS NULL) + None => (SQL {e1} IS NULL) | Some _ => sql_comparison sql_eq e1 (@sql_inject inj e2) diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 2485e317..3941fdd9 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -799,6 +799,43 @@ fun unurlify env (t, loc) = string "})"] end + | TOption t => + box [string "(request[0] == '/' ? ++request : request, ", + string "((!strncmp(request, \"None\", 4) ", + string "&& (request[4] == 0 || request[4] == '/')) ", + string "? (request += 4, NULL) ", + string ": ((!strncmp(request, \"Some\", 4) ", + string "&& request[4] == '/') ", + string "? (request += 5, ", + if isUnboxable t then + unurlify' rf (#1 t) + else + box [string "({", + newline, + p_typ env t, + space, + string "*tmp", + space, + string "=", + space, + string "uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp", + space, + string "=", + space, + unurlify' rf (#1 t), + string ";", + newline, + string "tmp;", + newline, + string "})"], + string ") :", + space, + string "(uw_error(ctx, FATAL, \"Error unurlifying option type\"), NULL))))"] + | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function"; space) in diff --git a/src/elab_env.sig b/src/elab_env.sig index 90cf8153..926837e1 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -74,6 +74,7 @@ signature ELAB_ENV = sig val pushENamed : env -> string -> Elab.con -> env * int val pushENamedAs : env -> string -> int -> Elab.con -> env val lookupENamed : env -> int -> string * Elab.con + val checkENamed : env -> int -> bool val lookupE : env -> string -> Elab.con var diff --git a/src/elab_env.sml b/src/elab_env.sml index 46f62727..05da56db 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -542,6 +542,9 @@ fun lookupENamed (env : env) n = NONE => raise UnboundNamed n | SOME x => x +fun checkENamed (env : env) n = + Option.isSome (IM.find (#namedE env, n)) + fun lookupE (env : env) x = case SM.find (#renameE env, x) of NONE => NotBound diff --git a/src/elaborate.sml b/src/elaborate.sml index f0beecdd..e84f5307 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2282,9 +2282,15 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = let val env = case #1 h of L'.SgiCon (x, n, k, c) => - E.pushCNamedAs env x n k (SOME c) + if E.checkENamed env n then + env + else + E.pushCNamedAs env x n k (SOME c) | L'.SgiConAbs (x, n, k) => - E.pushCNamedAs env x n k NONE + if E.checkENamed env n then + env + else + E.pushCNamedAs env x n k NONE | _ => env in seek (E.sgiBinds env h, sgiBindsD (env, denv) h) t @@ -2391,12 +2397,12 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = fun good () = let - val env = E.sgiBinds env sgi2All + val env = E.sgiBinds env sgi1All val env = if n1 = n2 then env else - E.pushCNamedAs env x n1 k' - (SOME (L'.CNamed n2, loc)) + E.pushCNamedAs env x n2 k' + (SOME (L'.CNamed n1, loc)) in SOME (env, denv) end diff --git a/src/monoize.sml b/src/monoize.sml index 9e1a4d22..ee509f52 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -390,6 +390,22 @@ fun fooifyExp fk env = ((L'.EApp ((L'.ENamed n, loc), e), loc), fm) end + | L'.TOption t => + let + val (body, fm) = fooify fm ((L'.ERel 0, loc), t) + in + ((L'.ECase (e, + [((L'.PNone t, loc), + (L'.EPrim (Prim.String "None"), loc)), + + ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc), + (L'.EStrcat ((L'.EPrim (Prim.String "Some/"), loc), + body), loc))], + {disc = tAll, + result = (L'.TFfi ("Basis", "string"), loc)}), loc), + fm) + end + | _ => (E.errorAt loc "Don't know how to encode attribute type"; Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]; (dummyExp, fm)) diff --git a/src/urweb.grm b/src/urweb.grm index 4ac14450..b49cd793 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -1236,7 +1236,7 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In end end) - | LBRACE LBRACK eexp RBRACK RBRACE (eexp) + | LBRACE eexp RBRACE (eexp) | sqlexp EQ sqlexp (sql_compare ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) | sqlexp NE sqlexp (sql_compare ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) @@ -1256,8 +1256,8 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In sqlexp), loc) end) - | LBRACE eexp RBRACE (sql_inject (#1 eexp, - s (LBRACEleft, RBRACEright))) + | LBRACE LBRACK eexp RBRACK RBRACE (sql_inject (#1 eexp, + s (LBRACEleft, RBRACEright))) | LPAREN sqlexp RPAREN (sqlexp) | NULL (sql_inject ((EVar (["Basis"], "None", Infer), -- cgit v1.2.3 From 59bc998793e4c715d038555143ac3d83f2b3bc42 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 10:40:29 -0500 Subject: Remove unnecessary lifts in ElabEnv.pushCRel --- src/elab_env.sml | 4 ++-- src/elaborate.sml | 26 ++++++++++++++++++++++---- 2 files changed, 24 insertions(+), 6 deletions(-) (limited to 'src/elab_env.sml') diff --git a/src/elab_env.sml b/src/elab_env.sml index 05da56db..3acb855d 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -268,7 +268,7 @@ fun pushCRel (env : env) x k = in {renameC = SM.insert (renameC, x, Rel' (0, k)), relC = (x, k) :: #relC env, - namedC = IM.map (fn (x, k, co) => (x, k, Option.map lift co)) (#namedC env), + namedC = #namedC env, datatypes = #datatypes env, constructors = #constructors env, @@ -283,7 +283,7 @@ fun pushCRel (env : env) x k = renameE = SM.map (fn Rel' (n, c) => Rel' (n, lift c) | Named' (n, c) => Named' (n, lift c)) (#renameE env), relE = map (fn (x, c) => (x, lift c)) (#relE env), - namedE = IM.map (fn (x, c) => (x, lift c)) (#namedE env), + namedE = #namedE env, renameSgn = #renameSgn env, sgn = #sgn env, diff --git a/src/elaborate.sml b/src/elaborate.sml index e3d76ed6..86ae6067 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -875,12 +875,19 @@ [] else let + (*val befor = Time.now () + val old1 = c1 + val old2 = c2*) val (c1, gs1) = hnormCon (env, denv) c1 val (c2, gs2) = hnormCon (env, denv) c2 in let val gs3 = unifyCons'' (env, denv) c1 c2 in + (*prefaces "unifyCons'" [("c1", p_con env old1), + ("c2", p_con env old2), + ("t", PD.string (LargeReal.toString (Time.toReal + (Time.- (Time.now (), befor)))))];*) gs1 @ gs2 @ gs3 end handle ex => guessFold (env, denv) (c1, c2, gs1 @ gs2, ex) @@ -906,7 +913,16 @@ err CExplicitness else (unifyKinds d1 d2; - unifyCons' (E.pushCRel env x1 d1, D.enter denv) r1 r2) + let + val denv' = D.enter denv + (*val befor = Time.now ()*) + val env' = E.pushCRel env x1 d1 + in + (*TextIO.print ("E.pushCRel: " + ^ LargeReal.toString (Time.toReal (Time.- (Time.now (), befor))) + ^ "\n");*) + unifyCons' (env', denv') r1 r2 + end) | (L'.TRecord r1, L'.TRecord r2) => unifyCons' (env, denv) r1 r2 | (L'.CRel n1, L'.CRel n2) => @@ -1478,6 +1494,7 @@ val makeInstantiable = fun elabExp (env, denv) (eAll as (e, loc)) = let (*val () = eprefaces "elabExp" [("eAll", SourcePrint.p_exp eAll)];*) + (*val befor = Time.now ()*) val r = case e of L.EAnnot (e, t) => @@ -1770,7 +1787,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) = end in (*prefaces "elabExp" [("e", SourcePrint.p_exp eAll), - ("t", PD.string (LargeInt.toString (Time.toMilliseconds (Time.- (Time.now (), befor)))))];*) + ("t", PD.string (LargeReal.toString (Time.toReal (Time.- (Time.now (), befor)))))];*) r end @@ -2913,6 +2930,7 @@ fun wildifyStr env (str, sgn) = fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = let (*val () = preface ("elabDecl", SourcePrint.p_decl (d, loc))*) + (*val befor = Time.now ()*) val r = case d of @@ -3293,8 +3311,8 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) in (*prefaces "elabDecl" [("e", SourcePrint.p_decl dAll), - ("t", PD.string (LargeInt.toString (Time.toMilliseconds - (Time.- (Time.now (), befor)))))];*) + ("t", PD.string (LargeReal.toString (Time.toReal + (Time.- (Time.now (), befor)))))];*) r end -- cgit v1.2.3 From efa3df8ba3084f1b494e2ce6ba4a355c00ee9d8c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 11:06:10 -0500 Subject: Catch another unneeded lift in ElabEnv.pushCRel --- src/elab_env.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/elab_env.sml') diff --git a/src/elab_env.sml b/src/elab_env.sml index 3acb855d..d1084d0c 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -281,7 +281,7 @@ fun pushCRel (env : env) x k = (#classes env), renameE = SM.map (fn Rel' (n, c) => Rel' (n, lift c) - | Named' (n, c) => Named' (n, lift c)) (#renameE env), + | Named' (n, c) => Named' (n, c)) (#renameE env), relE = map (fn (x, c) => (x, lift c)) (#relE env), namedE = #namedE env, -- cgit v1.2.3 From ba83ee9a9b3d2539b820c9fcb1cb7cd42226da6c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 19 Dec 2008 10:03:31 -0500 Subject: Initial conversion to arbitrary-kind classes --- src/elab.sml | 6 +-- src/elab_env.sml | 36 ++++++++-------- src/elab_print.sml | 46 +++++++++++++-------- src/elab_util.sml | 43 +++++++++++-------- src/elaborate.sml | 115 +++++++++++++++++++++++++++------------------------ src/explify.sml | 10 ++--- src/source.sml | 6 +-- src/source_print.sml | 44 ++++++++++++-------- src/urweb.grm | 49 ++++++++++++++++++---- 9 files changed, 212 insertions(+), 143 deletions(-) (limited to 'src/elab_env.sml') diff --git a/src/elab.sml b/src/elab.sml index d997b7ec..8e44c43c 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -136,8 +136,8 @@ datatype sgn_item' = | SgiStr of string * int * sgn | SgiSgn of string * int * sgn | SgiConstraint of con * con - | SgiClassAbs of string * int - | SgiClass of string * int * con + | SgiClassAbs of string * int * kind + | SgiClass of string * int * kind * con and sgn' = SgnConst of sgn_item list @@ -163,7 +163,7 @@ datatype decl' = | DExport of int * sgn * str | DTable of int * string * int * con | DSequence of int * string * int - | DClass of string * int * con + | DClass of string * int * kind * con | DDatabase of string | DCookie of int * string * int * con diff --git a/src/elab_env.sml b/src/elab_env.sml index d1084d0c..53c934dd 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -604,8 +604,8 @@ fun sgiSeek (sgi, (sgns, strs, cons)) = | SgiSgn (x, n, _) => (IM.insert (sgns, n, x), strs, cons) | SgiStr (x, n, _) => (sgns, IM.insert (strs, n, x), cons) | SgiConstraint _ => (sgns, strs, cons) - | SgiClassAbs (x, n) => (sgns, strs, IM.insert (cons, n, x)) - | SgiClass (x, n, _) => (sgns, strs, IM.insert (cons, n, x)) + | SgiClassAbs (x, n, _) => (sgns, strs, IM.insert (cons, n, x)) + | SgiClass (x, n, _, _) => (sgns, strs, IM.insert (cons, n, x)) fun sgnSeek f sgis = let @@ -788,8 +788,8 @@ fun enrichClasses env classes (m1, ms) sgn = fmap, pushSgnNamedAs env x n sgn) - | SgiClassAbs xn => found xn - | SgiClass (x, n, _) => found (x, n) + | SgiClassAbs (x, n, _) => found (x, n) + | SgiClass (x, n, _, _) => found (x, n) | SgiVal (x, n, (CApp (f, a), _)) => let fun unravel c = @@ -946,8 +946,8 @@ fun sgiBinds env (sgi, loc) = | SgiSgn (x, n, sgn) => pushSgnNamedAs env x n sgn | SgiConstraint _ => env - | SgiClassAbs (x, n) => pushCNamedAs env x n (KArrow ((KType, loc), (KType, loc)), loc) NONE - | SgiClass (x, n, c) => pushCNamedAs env x n (KArrow ((KType, loc), (KType, loc)), loc) (SOME c) + | SgiClassAbs (x, n, k) => pushCNamedAs env x n (KArrow (k, (KType, loc)), loc) NONE + | SgiClass (x, n, k, c) => pushCNamedAs env x n (KArrow (k, (KType, loc)), loc) (SOME c) fun sgnSubCon x = ElabUtil.Con.map {kind = id, @@ -998,14 +998,14 @@ fun projectCon env {sgn, str, field} = end else NONE - | SgiClassAbs (x, _) => if x = field then - SOME ((KArrow ((KType, #2 sgn), (KType, #2 sgn)), #2 sgn), NONE) - else - NONE - | SgiClass (x, _, c) => if x = field then - SOME ((KArrow ((KType, #2 sgn), (KType, #2 sgn)), #2 sgn), SOME c) - else - NONE + | SgiClassAbs (x, _, k) => if x = field then + SOME ((KArrow (k, (KType, #2 sgn)), #2 sgn), NONE) + else + NONE + | SgiClass (x, _, k, c) => if x = field then + SOME ((KArrow (k, (KType, #2 sgn)), #2 sgn), SOME c) + else + NONE | _ => NONE) sgis of NONE => NONE | SOME ((k, co), subs) => SOME (k, Option.map (sgnSubCon (str, subs)) co)) @@ -1101,8 +1101,8 @@ fun sgnSeekConstraints (str, sgis) = | SgiVal _ => seek (sgis, sgns, strs, cons, acc) | SgiSgn (x, n, _) => seek (sgis, IM.insert (sgns, n, x), strs, cons, acc) | SgiStr (x, n, _) => seek (sgis, sgns, IM.insert (strs, n, x), cons, acc) - | SgiClassAbs (x, n) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) - | SgiClass (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) + | SgiClassAbs (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) + | SgiClass (x, n, _, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) in seek (sgis, IM.empty, IM.empty, IM.empty, []) end @@ -1189,9 +1189,9 @@ fun declBinds env (d, loc) = in pushENamedAs env x n t end - | DClass (x, n, c) => + | DClass (x, n, k, c) => let - val k = (KArrow ((KType, loc), (KType, loc)), loc) + val k = (KArrow (k, (KType, loc)), loc) val env = pushCNamedAs env x n k (SOME c) in pushClass env n diff --git a/src/elab_print.sml b/src/elab_print.sml index 2f652737..0e6c9767 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -534,16 +534,24 @@ fun p_sgn_item env (sgi, _) = string "~", space, p_con env c2] - | SgiClassAbs (x, n) => box [string "class", - space, - p_named x n] - | SgiClass (x, n, c) => box [string "class", - space, - p_named x n, - space, - string "=", - space, - p_con env c] + | SgiClassAbs (x, n, k) => box [string "class", + space, + p_named x n, + space, + string "::", + space, + p_kind k] + | SgiClass (x, n, k, c) => box [string "class", + space, + p_named x n, + space, + string "::", + space, + p_kind k, + space, + string "=", + space, + p_con env c] and p_sgn env (sgn, _) = case sgn of @@ -705,13 +713,17 @@ fun p_decl env (dAll as (d, _) : decl) = | DSequence (_, x, n) => box [string "sequence", space, p_named x n] - | DClass (x, n, c) => box [string "class", - space, - p_named x n, - space, - string "=", - space, - p_con env c] + | DClass (x, n, k, c) => box [string "class", + space, + p_named x n, + space, + string "::", + space, + p_kind k, + space, + string "=", + space, + p_con env c] | DDatabase s => box [string "database", space, string s] diff --git a/src/elab_util.sml b/src/elab_util.sml index 6e2c76f6..6e78907d 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -547,11 +547,16 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = S.map2 (con ctx c2, fn c2' => (SgiConstraint (c1', c2'), loc))) - | SgiClassAbs _ => S.return2 siAll - | SgiClass (x, n, c) => - S.map2 (con ctx c, - fn c' => - (SgiClass (x, n, c'), loc)) + | SgiClassAbs (x, n, k) => + S.map2 (kind k, + fn k' => + (SgiClassAbs (x, n, k'), loc)) + | SgiClass (x, n, k, c) => + S.bind2 (kind k, + fn k' => + S.map2 (con ctx c, + fn c' => + (SgiClass (x, n, k', c'), loc))) and sg ctx s acc = S.bindP (sg' ctx s acc, sgn ctx) @@ -575,10 +580,10 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = | SgiSgn (x, _, sgn) => bind (ctx, Sgn (x, sgn)) | SgiConstraint _ => ctx - | SgiClassAbs (x, n) => - bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))) - | SgiClass (x, n, _) => - bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))), + | SgiClassAbs (x, n, k) => + bind (ctx, NamedC (x, n, (KArrow (k, (KType, loc)), loc))) + | SgiClass (x, n, k, _) => + bind (ctx, NamedC (x, n, (KArrow (k, (KType, loc)), loc))), sgi ctx si)) ctx sgis, fn sgis' => (SgnConst sgis', loc)) @@ -720,8 +725,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f c), loc))) | DSequence (tn, x, n) => bind (ctx, NamedE (x, (CModProj (n, [], "sql_sequence"), loc))) - | DClass (x, n, _) => - bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))) + | DClass (x, n, k, _) => + bind (ctx, NamedC (x, n, (KArrow (k, (KType, loc)), loc))) | DDatabase _ => ctx | DCookie (tn, x, n, c) => bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "cookie"), loc), @@ -819,10 +824,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f (DTable (tn, x, n, c'), loc)) | DSequence _ => S.return2 dAll - | DClass (x, n, c) => - S.map2 (mfc ctx c, - fn c' => - (DClass (x, n, c'), loc)) + | DClass (x, n, k, c) => + S.bind2 (mfk k, + fn k' => + S.map2 (mfc ctx c, + fn c' => + (DClass (x, n, k', c'), loc))) | DDatabase _ => S.return2 dAll @@ -963,7 +970,7 @@ and maxNameDecl (d, _) = | DSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn) | DFfiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn) | DConstraint _ => 0 - | DClass (_, n, _) => n + | DClass (_, n, _, _) => n | DExport _ => 0 | DTable (n1, _, n2, _) => Int.max (n1, n2) | DSequence (n1, _, n2) => Int.max (n1, n2) @@ -1002,8 +1009,8 @@ and maxNameSgi (sgi, _) = | SgiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn) | SgiSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn) | SgiConstraint _ => 0 - | SgiClassAbs (_, n) => n - | SgiClass (_, n, _) => n + | SgiClassAbs (_, n, _) => n + | SgiClass (_, n, _, _) => n end diff --git a/src/elaborate.sml b/src/elaborate.sml index d42175ce..05e08c81 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2059,24 +2059,26 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = ([(L'.SgiConstraint (c1', c2'), loc)], (env, denv, gs1 @ gs2 @ gs3)) end - | L.SgiClassAbs x => + | L.SgiClassAbs (x, k) => let - val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) - val (env, n) = E.pushCNamed env x k NONE + val k = elabKind k + val k' = (L'.KArrow (k, (L'.KType, loc)), loc) + val (env, n) = E.pushCNamed env x k' NONE val env = E.pushClass env n in - ([(L'.SgiClassAbs (x, n), loc)], (env, denv, [])) + ([(L'.SgiClassAbs (x, n, k), loc)], (env, denv, [])) end - | L.SgiClass (x, c) => + | L.SgiClass (x, k, c) => let - val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) + val k = elabKind k + val k' = (L'.KArrow (k, (L'.KType, loc)), loc) val (c', ck, gs) = elabCon (env, denv) c - val (env, n) = E.pushCNamed env x k (SOME c') + val (env, n) = E.pushCNamed env x k' (SOME c') val env = E.pushClass env n in - checkKind env c' ck k; - ([(L'.SgiClass (x, n, c'), loc)], (env, denv, [])) + checkKind env c' ck k'; + ([(L'.SgiClass (x, n, k, c'), loc)], (env, denv, [])) end and elabSgn (env, denv) (sgn, loc) = @@ -2140,13 +2142,13 @@ and elabSgn (env, denv) (sgn, loc) = (); (cons, vals, sgns, SS.add (strs, x))) | L'.SgiConstraint _ => (cons, vals, sgns, strs) - | L'.SgiClassAbs (x, _) => + | L'.SgiClassAbs (x, _, _) => (if SS.member (cons, x) then sgnError env (DuplicateCon (loc, x)) else (); (SS.add (cons, x), vals, sgns, strs)) - | L'.SgiClass (x, _, _) => + | L'.SgiClass (x, _, _, _) => (if SS.member (cons, x) then sgnError env (DuplicateCon (loc, x)) else @@ -2222,8 +2224,8 @@ fun selfify env {str, strs, sgn} = (L'.SgiCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc) | (L'.SgiDatatype (x, n, xs, xncs), loc) => (L'.SgiDatatypeImp (x, n, str, strs, x, xs, xncs), loc) - | (L'.SgiClassAbs (x, n), loc) => - (L'.SgiClass (x, n, (L'.CModProj (str, strs, x), loc)), loc) + | (L'.SgiClassAbs (x, n, k), loc) => + (L'.SgiClass (x, n, k, (L'.CModProj (str, strs, x), loc)), loc) | (L'.SgiStr (x, n, sgn), loc) => (L'.SgiStr (x, n, selfify env {str = str, strs = strs @ [x], sgn = sgn}), loc) | x => x) sgis), #2 sgn) @@ -2284,19 +2286,19 @@ fun dopen (env, denv) {str, strs, sgn} = (L'.DSgn (x, n, (L'.SgnProj (str, strs, x), loc)), loc) | L'.SgiConstraint (c1, c2) => (L'.DConstraint (c1, c2), loc) - | L'.SgiClassAbs (x, n) => + | L'.SgiClassAbs (x, n, k) => let - val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) + val k' = (L'.KArrow (k, (L'.KType, loc)), loc) val c = (L'.CModProj (str, strs, x), loc) in - (L'.DCon (x, n, k, c), loc) + (L'.DCon (x, n, k', c), loc) end - | L'.SgiClass (x, n, _) => + | L'.SgiClass (x, n, k, _) => let - val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) + val k' = (L'.KArrow (k, (L'.KType, loc)), loc) val c = (L'.CModProj (str, strs, x), loc) in - (L'.DCon (x, n, k, c), loc) + (L'.DCon (x, n, k', c), loc) end in (d, (E.declBinds env' d, denv')) @@ -2320,7 +2322,7 @@ fun sgiOfDecl (d, loc) = | L'.DExport _ => [] | L'.DTable (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (tableOf (), c), loc)), loc)] | L'.DSequence (tn, x, n) => [(L'.SgiVal (x, n, sequenceOf ()), loc)] - | L'.DClass (x, n, c) => [(L'.SgiClass (x, n, c), loc)] + | L'.DClass (x, n, k, c) => [(L'.SgiClass (x, n, k, c), loc)] | L'.DDatabase _ => [] | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] @@ -2418,14 +2420,14 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = in found (x', n1, k', SOME (L'.CModProj (m1, ms, s), loc)) end - | L'.SgiClassAbs (x', n1) => found (x', n1, - (L'.KArrow ((L'.KType, loc), - (L'.KType, loc)), loc), - NONE) - | L'.SgiClass (x', n1, c) => found (x', n1, - (L'.KArrow ((L'.KType, loc), - (L'.KType, loc)), loc), - SOME c) + | L'.SgiClassAbs (x', n1, k) => found (x', n1, + (L'.KArrow (k, + (L'.KType, loc)), loc), + NONE) + | L'.SgiClass (x', n1, k, c) => found (x', n1, + (L'.KArrow (k, + (L'.KType, loc)), loc), + SOME c) | _ => NONE end) @@ -2458,8 +2460,8 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = in case sgi1 of L'.SgiCon (x', n1, k1, c1) => found (x', n1, k1, c1) - | L'.SgiClass (x', n1, c1) => - found (x', n1, (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc), c1) + | L'.SgiClass (x', n1, k1, c1) => + found (x', n1, (L'.KArrow (k1, (L'.KType, loc)), loc), c1) | _ => NONE end) @@ -2632,13 +2634,17 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = NONE | _ => NONE) - | L'.SgiClassAbs (x, n2) => + | L'.SgiClassAbs (x, n2, k2) => seek (fn (env, sgi1All as (sgi1, _)) => let - fun found (x', n1, co) = + fun found (x', n1, k1, co) = if x = x' then let - val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) + val () = unifyKinds k1 k2 + handle KUnify (k1, k2, err) => + sgnError env (SgiWrongKind (sgi1All, k1, sgi2All, k2, err)) + + val k = (L'.KArrow (k1, (L'.KType, loc)), loc) val env = E.pushCNamedAs env x n1 k co in SOME (if n1 = n2 then @@ -2651,18 +2657,22 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = NONE in case sgi1 of - L'.SgiClassAbs (x', n1) => found (x', n1, NONE) - | L'.SgiClass (x', n1, c) => found (x', n1, SOME c) + L'.SgiClassAbs (x', n1, k1) => found (x', n1, k1, NONE) + | L'.SgiClass (x', n1, k1, c) => found (x', n1, k1, SOME c) | _ => NONE end) - | L'.SgiClass (x, n2, c2) => + | L'.SgiClass (x, n2, k2, c2) => seek (fn (env, sgi1All as (sgi1, _)) => let - val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) + val k = (L'.KArrow (k2, (L'.KType, loc)), loc) - fun found (x', n1, c1) = + fun found (x', n1, k1, c1) = if x = x' then let + val () = unifyKinds k1 k2 + handle KUnify (k1, k2, err) => + sgnError env (SgiWrongKind (sgi1All, k1, sgi2All, k2, err)) + fun good () = let val env = E.pushCNamedAs env x n2 k (SOME c2) @@ -2685,7 +2695,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = NONE in case sgi1 of - L'.SgiClass (x', n1, c1) => found (x', n1, c1) + L'.SgiClass (x', n1, k1, c1) => found (x', n1, k1, c1) | _ => NONE end) end @@ -2878,8 +2888,8 @@ fun wildifyStr env (str, sgn) = L.DCon (x, _, _) => ((#1 (SM.remove (neededC, x)), neededV) handle NotFound => needed) - | L.DClass (x, _) => ((#1 (SM.remove (neededC, x)), neededV) - handle NotFound => needed) + | L.DClass (x, _, _) => ((#1 (SM.remove (neededC, x)), neededV) + handle NotFound => needed) | L.DVal (x, _, _) => ((neededC, SS.delete (neededV, x)) handle NotFound => needed) | L.DOpen _ => (SM.empty, SS.empty) @@ -3286,15 +3296,16 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = ([(L'.DSequence (!basis_r, x, n), loc)], (env, denv, gs)) end - | L.DClass (x, c) => + | L.DClass (x, k, c) => let - val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) + val k = elabKind k + val k' = (L'.KArrow (k, (L'.KType, loc)), loc) val (c', ck, gs') = elabCon (env, denv) c - val (env, n) = E.pushCNamed env x k (SOME c') + val (env, n) = E.pushCNamed env x k' (SOME c') val env = E.pushClass env n in - checkKind env c' ck k; - ([(L'.DClass (x, n, c'), loc)], (env, denv, enD gs' @ gs)) + checkKind env c' ck k'; + ([(L'.DClass (x, n, k, c'), loc)], (env, denv, enD gs' @ gs)) end | L.DDatabase s => ([(L'.DDatabase s, loc)], (env, denv, gs)) @@ -3408,29 +3419,25 @@ and elabStr (env, denv) (str, loc) = ((L'.SgiStr (x, n, sgn), loc) :: sgis, cons, vals, sgns, strs) end | L'.SgiConstraint _ => ((sgi, loc) :: sgis, cons, vals, sgns, strs) - | L'.SgiClassAbs (x, n) => + | L'.SgiClassAbs (x, n, k) => let - val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) - val (cons, x) = if SS.member (cons, x) then (cons, "?" ^ x) else (SS.add (cons, x), x) in - ((L'.SgiClassAbs (x, n), loc) :: sgis, cons, vals, sgns, strs) + ((L'.SgiClassAbs (x, n, k), loc) :: sgis, cons, vals, sgns, strs) end - | L'.SgiClass (x, n, c) => + | L'.SgiClass (x, n, k, c) => let - val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) - val (cons, x) = if SS.member (cons, x) then (cons, "?" ^ x) else (SS.add (cons, x), x) in - ((L'.SgiClass (x, n, c), loc) :: sgis, cons, vals, sgns, strs) + ((L'.SgiClass (x, n, k, c), loc) :: sgis, cons, vals, sgns, strs) end) ([], SS.empty, SS.empty, SS.empty, SS.empty) sgis diff --git a/src/explify.sml b/src/explify.sml index e3c22f20..a10037ef 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -139,9 +139,9 @@ fun explifySgi (sgi, loc) = | L.SgiStr (x, n, sgn) => SOME (L'.SgiStr (x, n, explifySgn sgn), loc) | L.SgiSgn (x, n, sgn) => SOME (L'.SgiSgn (x, n, explifySgn sgn), loc) | L.SgiConstraint _ => NONE - | L.SgiClassAbs (x, n) => SOME (L'.SgiConAbs (x, n, (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc)), loc) - | L.SgiClass (x, n, c) => SOME (L'.SgiCon (x, n, (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc), - explifyCon c), loc) + | L.SgiClassAbs (x, n, k) => SOME (L'.SgiConAbs (x, n, (L'.KArrow (explifyKind k, (L'.KType, loc)), loc)), loc) + | L.SgiClass (x, n, k, c) => SOME (L'.SgiCon (x, n, (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), + explifyCon c), loc) and explifySgn (sgn, loc) = case sgn of @@ -172,8 +172,8 @@ fun explifyDecl (d, loc : EM.span) = | L.DExport (en, sgn, str) => SOME (L'.DExport (en, explifySgn sgn, explifyStr str), loc) | L.DTable (nt, x, n, c) => SOME (L'.DTable (nt, x, n, explifyCon c), loc) | L.DSequence (nt, x, n) => SOME (L'.DSequence (nt, x, n), loc) - | L.DClass (x, n, c) => SOME (L'.DCon (x, n, - (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc), explifyCon c), loc) + | L.DClass (x, n, k, c) => SOME (L'.DCon (x, n, + (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), explifyCon c), loc) | L.DDatabase s => SOME (L'.DDatabase s, loc) | L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc) diff --git a/src/source.sml b/src/source.sml index 7685bb2f..a5c86f66 100644 --- a/src/source.sml +++ b/src/source.sml @@ -81,8 +81,8 @@ datatype sgn_item' = | SgiSgn of string * sgn | SgiInclude of sgn | SgiConstraint of con * con - | SgiClassAbs of string - | SgiClass of string * con + | SgiClassAbs of string * kind + | SgiClass of string * kind * con and sgn' = SgnConst of sgn_item list @@ -154,7 +154,7 @@ datatype decl' = | DExport of str | DTable of string * con | DSequence of string - | DClass of string * con + | DClass of string * kind * con | DDatabase of string | DCookie of string * con diff --git a/src/source_print.sml b/src/source_print.sml index 77f2d749..d6568efe 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -413,17 +413,25 @@ fun p_sgn_item (sgi, _) = string "~", space, p_con c2] - | SgiClassAbs x => box [string "class", - space, - string x] - | SgiClass (x, c) => box [string "class", - space, - string x, - space, - string "=", - space, - p_con c] - + | SgiClassAbs (x, k) => box [string "class", + space, + string x, + space, + string "::", + space, + p_kind k] + | SgiClass (x, k, c) => box [string "class", + space, + string x, + space, + string "::", + space, + p_kind k, + space, + string "=", + space, + p_con c] + and p_sgn (sgn, _) = case sgn of SgnConst sgis => box [string "sig", @@ -562,13 +570,13 @@ fun p_decl ((d, _) : decl) = | DSequence x => box [string "sequence", space, string x] - | DClass (x, c) => box [string "class", - space, - string x, - space, - string "=", - space, - p_con c] + | DClass (x, k, c) => box [string "class", + space, + string x, + space, + string "=", + space, + p_con c] | DDatabase s => box [string "database", space, diff --git a/src/urweb.grm b/src/urweb.grm index 7798b018..5f2c0575 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -410,13 +410,24 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let | EXPORT spath ([(DExport spath, s (EXPORTleft, spathright))]) | TABLE SYMBOL COLON cexp ([(DTable (SYMBOL, entable cexp), s (TABLEleft, cexpright))]) | SEQUENCE SYMBOL ([(DSequence SYMBOL, s (SEQUENCEleft, SYMBOLright))]) - | CLASS SYMBOL EQ cexp ([(DClass (SYMBOL, cexp), s (CLASSleft, cexpright))]) + | CLASS SYMBOL EQ cexp (let + val loc = s (CLASSleft, cexpright) + in + [(DClass (SYMBOL, (KWild, loc), cexp), loc)] + end) + | CLASS SYMBOL DCOLON kind EQ cexp ([(DClass (SYMBOL, kind, cexp), s (CLASSleft, cexpright))]) | CLASS SYMBOL SYMBOL EQ cexp (let val loc = s (CLASSleft, cexpright) - val k = (KType, loc) + val k = (KWild, loc) val c = (CAbs (SYMBOL2, SOME k, cexp), loc) in - [(DClass (SYMBOL1, c), s (CLASSleft, cexpright))] + [(DClass (SYMBOL1, k, c), s (CLASSleft, cexpright))] + end) + | CLASS SYMBOL LPAREN SYMBOL DCOLON kind RPAREN EQ cexp (let + val loc = s (CLASSleft, cexpright) + val c = (CAbs (SYMBOL2, SOME kind, cexp), loc) + in + [(DClass (SYMBOL1, kind, c), s (CLASSleft, cexpright))] end) | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))]) @@ -501,14 +512,38 @@ sgi : CON SYMBOL DCOLON kind (SgiConAbs (SYMBOL, kind), s (CONleft, k in (SgiVal (SYMBOL, t), loc) end) - | CLASS SYMBOL (SgiClassAbs SYMBOL, s (CLASSleft, SYMBOLright)) - | CLASS SYMBOL EQ cexp (SgiClass (SYMBOL, cexp), s (CLASSleft, cexpright)) + | CLASS SYMBOL (let + val loc = s (CLASSleft, SYMBOLright) + in + (SgiClassAbs (SYMBOL, (KWild, loc)), loc) + end) + | CLASS SYMBOL DCOLON kind (let + val loc = s (CLASSleft, kindright) + in + (SgiClassAbs (SYMBOL, kind), loc) + end) + | CLASS SYMBOL EQ cexp (let + val loc = s (CLASSleft, cexpright) + in + (SgiClass (SYMBOL, (KWild, loc), cexp), loc) + end) + | CLASS SYMBOL DCOLON kind EQ cexp (let + val loc = s (CLASSleft, cexpright) + in + (SgiClass (SYMBOL, kind, cexp), loc) + end) | CLASS SYMBOL SYMBOL EQ cexp (let val loc = s (CLASSleft, cexpright) - val k = (KType, loc) + val k = (KWild, loc) val c = (CAbs (SYMBOL2, SOME k, cexp), loc) in - (SgiClass (SYMBOL1, c), s (CLASSleft, cexpright)) + (SgiClass (SYMBOL1, k, c), s (CLASSleft, cexpright)) + end) + | CLASS SYMBOL LPAREN SYMBOL DCOLON kind RPAREN EQ cexp (let + val loc = s (CLASSleft, cexpright) + val c = (CAbs (SYMBOL2, SOME kind, cexp), loc) + in + (SgiClass (SYMBOL1, kind, c), s (CLASSleft, cexpright)) end) | COOKIE SYMBOL COLON cexp (let val loc = s (COOKIEleft, cexpright) -- cgit v1.2.3 From 85cf99a95c910841f197ca911bb13d044456de7f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 22 Feb 2009 16:10:25 -0500 Subject: Start of kind polymorphism, up to the point where demo/hello elaborates with updated Basis/Top --- lib/ur/top.ur | 171 ++++++++++-------------------------- lib/ur/top.urs | 112 +++++++----------------- src/core.sml | 1 - src/core_print.sml | 1 - src/core_util.sml | 8 -- src/corify.sml | 1 - src/elab.sml | 11 ++- src/elab_env.sig | 4 + src/elab_env.sml | 130 ++++++++++++++++++++++++--- src/elab_err.sig | 7 +- src/elab_err.sml | 61 +++++++------ src/elab_ops.sig | 6 ++ src/elab_ops.sml | 69 ++++++++++++++- src/elab_print.sig | 2 +- src/elab_print.sml | 95 +++++++++++++------- src/elab_util.sig | 38 +++++--- src/elab_util.sml | 154 ++++++++++++++++++++------------ src/elaborate.sml | 241 +++++++++++++++++++++++++++++++++------------------ src/expl.sml | 1 - src/expl_print.sml | 1 - src/expl_util.sml | 4 - src/explify.sml | 2 - src/monoize.sml | 1 - src/reduce.sml | 16 ---- src/reduce_local.sml | 2 - src/source.sml | 9 +- src/source_print.sml | 26 +++++- src/termination.sml | 9 +- src/unnest.sml | 18 ++-- src/urweb.grm | 23 +++-- src/urweb.lex | 3 +- 31 files changed, 736 insertions(+), 491 deletions(-) (limited to 'src/elab_env.sml') diff --git a/lib/ur/top.ur b/lib/ur/top.ur index 58e99f3c..9016fd27 100644 --- a/lib/ur/top.ur +++ b/lib/ur/top.ur @@ -1,3 +1,12 @@ +(** Row folding *) + +con folder = K ==> fn r :: {K} => + tf :: ({K} -> Type) + -> (nm :: Name -> v :: K -> r :: {K} -> tf r + -> fn [[nm] ~ r] => tf ([nm = v] ++ r)) + -> tf [] -> tf r + + fun not b = if b then False else True con idT (t :: Type) = t @@ -27,23 +36,23 @@ fun foldUR (tf :: Type) (tr :: {Unit} -> Type) (f : nm :: Name -> rest :: {Unit} -> fn [[nm] ~ rest] => tf -> tr rest -> tr ([nm] ++ rest)) - (i : tr []) = + (i : tr []) (r ::: {Unit}) (fold : folder r)= fold [fn r :: {Unit} => $(mapUT tf r) -> tr r] - (fn (nm :: Name) (t :: Unit) (rest :: {Unit}) acc - [[nm] ~ rest] r => - f [nm] [rest] r.nm (acc (r -- nm))) - (fn _ => i) + (fn (nm :: Name) (t :: Unit) (rest :: {Unit}) acc + [[nm] ~ rest] r => + 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 []) = + (i : tr []) (r ::: {Unit}) (fold : folder r) = 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) + (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} @@ -54,134 +63,46 @@ fun foldURX2 (tf1 :: Type) (tf2 :: Type) (ctx :: {Unit}) {f [nm] [rest] v1 v2}{acc}) -fun foldTR (tf :: Type -> Type) (tr :: {Type} -> Type) - (f : nm :: Name -> t :: Type -> rest :: {Type} +fun foldR K (tf :: K -> Type) (tr :: {K} -> Type) + (f : nm :: Name -> t :: K -> rest :: {K} -> fn [[nm] ~ rest] => tf t -> tr rest -> tr ([nm = t] ++ rest)) - (i : tr []) = - fold [fn r :: {Type} => $(map tf r) -> tr r] - (fn (nm :: Name) (t :: Type) (rest :: {Type}) (acc : _ -> tr rest) + (i : tr []) (r ::: {K}) (fold : folder r) = + fold [fn r :: {K} => $(map tf r) -> tr r] + (fn (nm :: Name) (t :: K) (rest :: {K}) (acc : _ -> tr rest) [[nm] ~ rest] r => f [nm] [t] [rest] r.nm (acc (r -- nm))) (fn _ => i) -fun foldT2R (tf :: (Type * Type) -> Type) (tr :: {(Type * Type)} -> Type) - (f : nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)} - -> fn [[nm] ~ rest] => - tf t -> tr rest -> tr ([nm = t] ++ rest)) - (i : tr []) = - fold [fn r :: {(Type * Type)} => $(map tf r) -> tr r] - (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) - (acc : _ -> tr rest) [[nm] ~ rest] r => - f [nm] [t] [rest] r.nm (acc (r -- nm))) - (fn _ => i) - -fun foldT3R (tf :: (Type * Type * Type) -> Type) (tr :: {(Type * Type * Type)} -> Type) - (f : nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)} - -> fn [[nm] ~ rest] => - tf t -> tr rest -> tr ([nm = t] ++ rest)) - (i : tr []) = - fold [fn r :: {(Type * Type * Type)} => $(map tf r) -> tr r] - (fn (nm :: Name) (t :: (Type * Type * Type)) (rest :: {(Type * Type * Type)}) - (acc : _ -> tr rest) [[nm] ~ rest] r => - f [nm] [t] [rest] r.nm (acc (r -- nm))) - (fn _ => i) - -fun foldTR2 (tf1 :: Type -> Type) (tf2 :: Type -> Type) (tr :: {Type} -> Type) - (f : nm :: Name -> t :: Type -> rest :: {Type} +fun foldR2 K (tf1 :: K -> Type) (tf2 :: K -> Type) (tr :: {K} -> Type) + (f : nm :: Name -> t :: K -> rest :: {K} -> fn [[nm] ~ rest] => tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest)) - (i : tr []) = - fold [fn r :: {Type} => $(map tf1 r) -> $(map tf2 r) -> tr r] - (fn (nm :: Name) (t :: Type) (rest :: {Type}) - (acc : _ -> _ -> tr rest) [[nm] ~ rest] r1 r2 => - f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm))) - (fn _ _ => i) - -fun foldT2R2 (tf1 :: (Type * Type) -> Type) (tf2 :: (Type * Type) -> Type) - (tr :: {(Type * Type)} -> Type) - (f : nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)} - -> fn [[nm] ~ rest] => - tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest)) - (i : tr []) = - fold [fn r :: {(Type * Type)} => $(map tf1 r) -> $(map tf2 r) -> tr r] - (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) - (acc : _ -> _ -> tr rest) [[nm] ~ rest] r1 r2 => - f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm))) - (fn _ _ => i) - -fun foldT3R2 (tf1 :: (Type * Type * Type) -> Type) (tf2 :: (Type * Type * Type) -> Type) - (tr :: {(Type * Type * Type)} -> Type) - (f : nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)} - -> fn [[nm] ~ rest] => - tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest)) - (i : tr []) = - fold [fn r :: {(Type * Type * Type)} => $(map tf1 r) -> $(map tf2 r) -> tr r] - (fn (nm :: Name) (t :: (Type * Type * Type)) (rest :: {(Type * Type * Type)}) - (acc : _ -> _ -> tr rest) [[nm] ~ rest] r1 r2 => - f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm))) - (fn _ _ => i) - -fun foldTRX (tf :: Type -> Type) (ctx :: {Unit}) - (f : nm :: Name -> t :: Type -> rest :: {Type} + (i : tr []) (r ::: {K}) (fold : folder r) = + fold [fn r :: {K} => $(map tf1 r) -> $(map tf2 r) -> tr r] + (fn (nm :: Name) (t :: K) (rest :: {K}) + (acc : _ -> _ -> tr rest) [[nm] ~ rest] r1 r2 => + f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm))) + (fn _ _ => i) + +fun foldRX K (tf :: K -> Type) (ctx :: {Unit}) + (f : nm :: Name -> t :: K -> rest :: {K} -> fn [[nm] ~ rest] => tf t -> xml ctx [] []) = - foldTR [tf] [fn _ => xml ctx [] []] - (fn (nm :: Name) (t :: Type) (rest :: {Type}) [[nm] ~ rest] r acc => - {f [nm] [t] [rest] r}{acc}) - - -fun foldT2RX (tf :: (Type * Type) -> Type) (ctx :: {Unit}) - (f : nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)} - -> fn [[nm] ~ rest] => - tf t -> xml ctx [] []) = - foldT2R [tf] [fn _ => xml ctx [] []] - (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) - [[nm] ~ rest] r acc => - {f [nm] [t] [rest] r}{acc}) - - -fun foldT3RX (tf :: (Type * Type * Type) -> Type) (ctx :: {Unit}) - (f : nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)} - -> fn [[nm] ~ rest] => - tf t -> xml ctx [] []) = - foldT3R [tf] [fn _ => xml ctx [] []] - (fn (nm :: Name) (t :: (Type * Type * Type)) (rest :: {(Type * Type * Type)}) - [[nm] ~ rest] r acc => - {f [nm] [t] [rest] r}{acc}) - + foldR [tf] [fn _ => xml ctx [] []] + (fn (nm :: Name) (t :: K) (rest :: {K}) [[nm] ~ rest] r acc => + {f [nm] [t] [rest] r}{acc}) + -fun foldTRX2 (tf1 :: Type -> Type) (tf2 :: Type -> Type) (ctx :: {Unit}) - (f : nm :: Name -> t :: Type -> rest :: {Type} +fun foldRX2 K (tf1 :: K -> Type) (tf2 :: K -> Type) (ctx :: {Unit}) + (f : nm :: Name -> t :: K -> rest :: {K} -> fn [[nm] ~ rest] => tf1 t -> tf2 t -> xml ctx [] []) = - foldTR2 [tf1] [tf2] [fn _ => xml ctx [] []] - (fn (nm :: Name) (t :: Type) (rest :: {Type}) [[nm] ~ rest] - r1 r2 acc => - {f [nm] [t] [rest] r1 r2}{acc}) - - -fun foldT2RX2 (tf1 :: (Type * Type) -> Type) (tf2 :: (Type * Type) -> Type) - (ctx :: {Unit}) - (f : nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)} - -> fn [[nm] ~ rest] => - tf1 t -> tf2 t -> xml ctx [] []) = - foldT2R2 [tf1] [tf2] [fn _ => xml ctx [] []] - (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) - [[nm] ~ rest] r1 r2 acc => - {f [nm] [t] [rest] r1 r2}{acc}) - - -fun foldT3RX2 (tf1 :: (Type * Type * Type) -> Type) (tf2 :: (Type * Type * Type) -> Type) - (ctx :: {Unit}) - (f : nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)} - -> fn [[nm] ~ rest] => - tf1 t -> tf2 t -> xml ctx [] []) = - foldT3R2 [tf1] [tf2] [fn _ => xml ctx [] []] - (fn (nm :: Name) (t :: (Type * Type * Type)) (rest :: {(Type * Type * Type)}) - [[nm] ~ rest] r1 r2 acc => - {f [nm] [t] [rest] r1 r2}{acc}) - + foldR2 [tf1] [tf2] [fn _ => xml ctx [] []] + (fn (nm :: Name) (t :: K) (rest :: {K}) [[nm] ~ rest] + r1 r2 acc => + {f [nm] [t] [rest] r1 r2}{acc}) + fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit}) (q : sql_query tables exps) [tables ~ exps] diff --git a/lib/ur/top.urs b/lib/ur/top.urs index 49aad50c..d891c80d 100644 --- a/lib/ur/top.urs +++ b/lib/ur/top.urs @@ -1,3 +1,12 @@ +(** Row folding *) + +con folder = K ==> fn r :: {K} => + tf :: ({K} -> Type) + -> (nm :: Name -> v :: K -> r :: {K} -> tf r + -> fn [[nm] ~ r] => tf ([nm = v] ++ r)) + -> tf [] -> tf r + + val not : bool -> bool con idT = fn t :: Type => t @@ -25,103 +34,46 @@ val foldUR : tf :: Type -> tr :: ({Unit} -> Type) -> (nm :: Name -> rest :: {Unit} -> fn [[nm] ~ rest] => tf -> tr rest -> tr ([nm] ++ rest)) - -> tr [] -> r :: {Unit} -> $(mapUT tf r) -> tr r + -> tr [] -> r ::: {Unit} -> folder r -> $(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 + -> tr [] -> r ::: {Unit} -> folder r -> $(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 [] [] + -> r ::: {Unit} -> folder r -> $(mapUT tf1 r) -> $(mapUT tf2 r) -> xml ctx [] [] -val foldTR : tf :: (Type -> Type) -> tr :: ({Type} -> Type) - -> (nm :: Name -> t :: Type -> rest :: {Type} +val foldR : K --> tf :: (K -> Type) -> tr :: ({K} -> Type) + -> (nm :: Name -> t :: K -> rest :: {K} -> fn [[nm] ~ rest] => tf t -> tr rest -> tr ([nm = t] ++ rest)) - -> tr [] -> r :: {Type} -> $(map tf r) -> tr r + -> tr [] -> r ::: {K} -> folder r -> $(map tf r) -> tr r -val foldT2R : tf :: ((Type * Type) -> Type) -> tr :: ({(Type * Type)} -> Type) - -> (nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)} - -> fn [[nm] ~ rest] => - tf t -> tr rest -> tr ([nm = t] ++ rest)) - -> tr [] -> r :: {(Type * Type)} -> $(map tf r) -> tr r +val foldR2 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) + -> tr :: ({K} -> Type) + -> (nm :: Name -> t :: K -> rest :: {K} + -> fn [[nm] ~ rest] => + tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest)) + -> tr [] + -> r ::: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> tr r -val foldT3R : tf :: ((Type * Type * Type) -> Type) -> tr :: ({(Type * Type * Type)} -> Type) - -> (nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)} - -> fn [[nm] ~ rest] => - tf t -> tr rest -> tr ([nm = t] ++ rest)) - -> tr [] -> r :: {(Type * Type * Type)} -> $(map tf r) -> tr r +val foldRX : K --> tf :: (K -> Type) -> ctx :: {Unit} + -> (nm :: Name -> t :: K -> rest :: {K} + -> fn [[nm] ~ rest] => + tf t -> xml ctx [] []) + -> r ::: {K} -> folder r -> $(map tf r) -> xml ctx [] [] -val foldTR2 : tf1 :: (Type -> Type) -> tf2 :: (Type -> Type) - -> tr :: ({Type} -> Type) - -> (nm :: Name -> t :: Type -> rest :: {Type} - -> fn [[nm] ~ rest] => - tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest)) - -> tr [] - -> r :: {Type} -> $(map tf1 r) -> $(map tf2 r) -> tr r - -val foldT2R2 : tf1 :: ((Type * Type) -> Type) -> tf2 :: ((Type * Type) -> Type) - -> tr :: ({(Type * Type)} -> Type) - -> (nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)} - -> fn [[nm] ~ rest] => - tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest)) - -> tr [] -> r :: {(Type * Type)} - -> $(map tf1 r) -> $(map tf2 r) -> tr r - -val foldT3R2 : tf1 :: ((Type * Type * Type) -> Type) -> tf2 :: ((Type * Type * Type) -> Type) - -> tr :: ({(Type * Type * Type)} -> Type) - -> (nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)} - -> fn [[nm] ~ rest] => - tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest)) - -> tr [] -> r :: {(Type * Type * Type)} - -> $(map tf1 r) -> $(map tf2 r) -> tr r - -val foldTRX : tf :: (Type -> Type) -> ctx :: {Unit} - -> (nm :: Name -> t :: Type -> rest :: {Type} +val foldRX2 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> ctx :: {Unit} + -> (nm :: Name -> t :: K -> rest :: {K} -> fn [[nm] ~ rest] => - tf t -> xml ctx [] []) - -> r :: {Type} -> $(map tf r) -> xml ctx [] [] - -val foldT2RX : tf :: ((Type * Type) -> Type) -> ctx :: {Unit} - -> (nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)} - -> fn [[nm] ~ rest] => - tf t -> xml ctx [] []) - -> r :: {(Type * Type)} -> $(map tf r) -> xml ctx [] [] - -val foldT3RX : tf :: ((Type * Type * Type) -> Type) -> ctx :: {Unit} - -> (nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)} - -> fn [[nm] ~ rest] => - tf t -> xml ctx [] []) - -> r :: {(Type * Type * Type)} -> $(map tf r) -> xml ctx [] [] - -val foldTRX2 : tf1 :: (Type -> Type) -> tf2 :: (Type -> Type) -> ctx :: {Unit} - -> (nm :: Name -> t :: Type -> rest :: {Type} - -> fn [[nm] ~ rest] => - tf1 t -> tf2 t -> xml ctx [] []) - -> r :: {Type} - -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] [] - -val foldT2RX2 : tf1 :: ((Type * Type) -> Type) -> tf2 :: ((Type * Type) -> Type) - -> ctx :: {Unit} - -> (nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)} - -> fn [[nm] ~ rest] => - tf1 t -> tf2 t -> xml ctx [] []) - -> r :: {(Type * Type)} - -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] [] - - -val foldT3RX2 : tf1 :: ((Type * Type * Type) -> Type) -> tf2 :: ((Type * Type * Type) -> Type) - -> ctx :: {Unit} - -> (nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)} - -> fn [[nm] ~ rest] => - tf1 t -> tf2 t -> xml ctx [] []) - -> r :: {(Type * Type * Type)} - -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] [] + tf1 t -> tf2 t -> xml ctx [] []) + -> r ::: {K} -> folder r + -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] [] val queryX : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> sql_query tables exps diff --git a/src/core.sml b/src/core.sml index d7a57493..a28d93dd 100644 --- a/src/core.sml +++ b/src/core.sml @@ -96,7 +96,6 @@ datatype exp' = | EConcat of exp * con * exp * con | ECut of exp * con * { field : con, rest : con } | ECutMulti of exp * con * { rest : con } - | EFold of kind | ECase of exp * (pat * exp) list * { disc : con, result : con } diff --git a/src/core_print.sml b/src/core_print.sml index db8c3907..504773ab 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -342,7 +342,6 @@ fun p_exp' par env (e, _) = string "---", space, p_con' true env c]) - | EFold _ => string "fold" | ECase (e, pes, {disc, result}) => parenIf par (box [string "case", diff --git a/src/core_util.sml b/src/core_util.sml index e76da387..d5f8dd05 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -454,10 +454,6 @@ fun compare ((e1, _), (e2, _)) = | (ECutMulti _, _) => LESS | (_, ECutMulti _) => GREATER - | (EFold _, EFold _) => EQUAL - | (EFold _, _) => LESS - | (_, EFold _) => GREATER - | (ECase (e1, pes1, _), ECase (e2, pes2, _)) => join (compare (e1, e2), fn () => joinL (fn ((p1, e1), (p2, e2)) => @@ -609,10 +605,6 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = S.map2 (mfc ctx rest, fn rest' => (ECutMulti (e', c', {rest = rest'}), loc)))) - | EFold k => - S.map2 (mfk k, - fn k' => - (EFold k', loc)) | ECase (e, pes, {disc, result}) => S.bind2 (mfe ctx e, diff --git a/src/corify.sml b/src/corify.sml index c464e5a5..802baf66 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -592,7 +592,6 @@ fun corifyExp st (e, loc) = {field = corifyCon st field, rest = corifyCon st rest}), loc) | L.ECutMulti (e1, c, {rest}) => (L'.ECutMulti (corifyExp st e1, corifyCon st c, {rest = corifyCon st rest}), loc) - | L.EFold k => (L'.EFold (corifyKind k), loc) | L.ECase (e, pes, {disc, result}) => (L'.ECase (corifyExp st e, diff --git a/src/elab.sml b/src/elab.sml index ec8a910a..9ec3793e 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -40,6 +40,9 @@ datatype kind' = | KError | KUnif of ErrorMsg.span * string * kind option ref + | KRel of int + | KFun of string * kind + withtype kind = kind' located datatype explicitness = @@ -62,6 +65,10 @@ datatype con' = | CAbs of string * kind * con | CDisjoint of auto_instantiate * con * con * con + | CKAbs of string * con + | CKApp of con * kind + | TKFun of string * con + | CName of string | CRecord of kind * (con * con) list @@ -106,12 +113,14 @@ datatype exp' = | ECApp of exp * con | ECAbs of explicitness * string * kind * exp + | EKAbs of string * exp + | EKApp of exp * kind + | ERecord of (con * exp * con) list | EField of exp * con * { field : con, rest : con } | EConcat of exp * con * exp * con | ECut of exp * con * { field : con, rest : con } | ECutMulti of exp * con * { rest : con } - | EFold of kind | ECase of exp * (pat * exp) list * { disc : con, result : con } diff --git a/src/elab_env.sig b/src/elab_env.sig index 0b436106..10d11e3b 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -47,6 +47,10 @@ signature ELAB_ENV = sig | Rel of int * 'a | Named of int * 'a + val pushKRel : env -> string -> env + val lookupKRel : env -> int -> string + val lookupK : env -> string -> int option + val pushCRel : env -> string -> Elab.kind -> env val lookupCRel : env -> int -> string * Elab.kind diff --git a/src/elab_env.sml b/src/elab_env.sml index 53c934dd..083e7d55 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -45,8 +45,32 @@ exception UnboundNamed of int exception SynUnif +val liftKindInKind = + U.Kind.mapB {kind = fn bound => fn k => + case k of + KRel xn => + if xn < bound then + k + else + KRel (xn + 1) + | _ => k, + bind = fn (bound, _) => bound + 1} + +val liftKindInCon = + U.Con.mapB {kind = fn bound => fn k => + case k of + KRel xn => + if xn < bound then + k + else + KRel (xn + 1) + | _ => k, + con = fn _ => fn c => c, + bind = fn (bound, U.Con.RelK _) => bound + 1 + | (bound, _) => bound} + val liftConInCon = - U.Con.mapB {kind = fn k => k, + U.Con.mapB {kind = fn _ => fn k => k, con = fn bound => fn c => case c of CRel xn => @@ -56,13 +80,27 @@ val liftConInCon = CRel (xn + 1) (*| CUnif _ => raise SynUnif*) | _ => c, - bind = fn (bound, U.Con.Rel _) => bound + 1 + bind = fn (bound, U.Con.RelC _) => bound + 1 | (bound, _) => bound} val lift = liftConInCon 0 +val liftKindInExp = + U.Exp.mapB {kind = fn bound => fn k => + case k of + KRel xn => + if xn < bound then + k + else + KRel (xn + 1) + | _ => k, + con = fn _ => fn c => c, + exp = fn _ => fn e => e, + bind = fn (bound, U.Exp.RelK _) => bound + 1 + | (bound, _) => bound} + val liftConInExp = - U.Exp.mapB {kind = fn k => k, + U.Exp.mapB {kind = fn _ => fn k => k, con = fn bound => fn c => case c of CRel xn => @@ -76,7 +114,7 @@ val liftConInExp = | (bound, _) => bound} val liftExpInExp = - U.Exp.mapB {kind = fn k => k, + U.Exp.mapB {kind = fn _ => fn k => k, con = fn _ => fn c => c, exp = fn bound => fn e => case e of @@ -93,7 +131,7 @@ val liftExpInExp = val liftExp = liftExpInExp 0 val subExpInExp = - U.Exp.mapB {kind = fn k => k, + U.Exp.mapB {kind = fn _ => fn k => k, con = fn _ => fn c => c, exp = fn (xn, rep) => fn e => case e of @@ -203,6 +241,9 @@ fun printClasses cs = (print "Classes:\n"; print "\n")) cs) type env = { + renameK : int SM.map, + relK : string list, + renameC : kind var' SM.map, relC : (string * kind) list, namedC : (string * kind * con option) IM.map, @@ -234,6 +275,9 @@ fun newNamed () = end val empty = { + renameK = SM.empty, + relK = [], + renameC = SM.empty, relC = [], namedC = IM.empty, @@ -261,12 +305,51 @@ fun liftClassKey ck = | CkProj _ => ck | CkApp (ck1, ck2) => CkApp (liftClassKey ck1, liftClassKey ck2) +fun pushKRel (env : env) x = + let + val renameK = SM.map (fn n => n+1) (#renameK env) + in + {renameK = SM.insert (renameK, x, 0), + relK = x :: #relK env, + + renameC = SM.map (fn Rel' (n, k) => Rel' (n, liftKindInKind 0 k) + | x => x) (#renameC env), + relC = map (fn (x, k) => (x, liftKindInKind 0 k)) (#relC env), + namedC = #namedC env, + + datatypes = #datatypes env, + constructors = #constructors env, + + classes = #classes env, + + renameE = SM.map (fn Rel' (n, c) => Rel' (n, liftKindInCon 0 c) + | Named' (n, c) => Named' (n, c)) (#renameE env), + relE = map (fn (x, c) => (x, liftKindInCon 0 c)) (#relE env), + namedE = #namedE env, + + renameSgn = #renameSgn env, + sgn = #sgn env, + + renameStr = #renameStr env, + str = #str env + } + end + +fun lookupKRel (env : env) n = + (List.nth (#relK env, n)) + handle Subscript => raise UnboundRel n + +fun lookupK (env : env) x = SM.find (#renameK env, x) + fun pushCRel (env : env) x k = let val renameC = SM.map (fn Rel' (n, k) => Rel' (n+1, k) | x => x) (#renameC env) in - {renameC = SM.insert (renameC, x, Rel' (0, k)), + {renameK = #renameK env, + relK = #relK env, + + renameC = SM.insert (renameC, x, Rel' (0, k)), relC = (x, k) :: #relC env, namedC = #namedC env, @@ -298,7 +381,10 @@ fun lookupCRel (env : env) n = handle Subscript => raise UnboundRel n fun pushCNamedAs (env : env) x n k co = - {renameC = SM.insert (#renameC env, x, Named' (n, k)), + {renameK = #renameK env, + relK = #relK env, + + renameC = SM.insert (#renameC env, x, Named' (n, k)), relC = #relC env, namedC = IM.insert (#namedC env, n, (x, k, co)), @@ -340,7 +426,10 @@ fun pushDatatype (env : env) n xs xncs = let val dk = U.classifyDatatype xncs in - {renameC = #renameC env, + {renameK = #renameK env, + relK = #relK env, + + renameC = #renameC env, relC = #relC env, namedC = #namedC env, @@ -380,7 +469,10 @@ fun datatypeArgs (xs, _) = xs fun constructors (_, dt) = IM.foldri (fn (n, (x, to), ls) => (x, n, to) :: ls) [] dt fun pushClass (env : env) n = - {renameC = #renameC env, + {renameK = #renameK env, + relK = #relK env, + + renameC = #renameC env, relC = #relC env, namedC = #namedC env, @@ -468,7 +560,10 @@ fun pushERel (env : env) x t = CM.insert (classes, f, class) end in - {renameC = #renameC env, + {renameK = #renameK env, + relK = #relK env, + + renameC = #renameC env, relC = #relC env, namedC = #namedC env, @@ -509,7 +604,10 @@ fun pushENamedAs (env : env) x n t = CM.insert (classes, f, class) end in - {renameC = #renameC env, + {renameK = #renameK env, + relK = #relK env, + + renameC = #renameC env, relC = #relC env, namedC = #namedC env, @@ -552,7 +650,10 @@ fun lookupE (env : env) x = | SOME (Named' x) => Named x fun pushSgnNamedAs (env : env) x n sgis = - {renameC = #renameC env, + {renameK = #renameK env, + relK = #relK env, + + renameC = #renameC env, relC = #relC env, namedC = #namedC env, @@ -868,7 +969,10 @@ fun enrichClasses env classes (m1, ms) sgn = | _ => classes fun pushStrNamedAs (env : env) x n sgn = - {renameC = #renameC env, + {renameK = #renameK env, + relK = #relK env, + + renameC = #renameC env, relC = #relC env, namedC = #namedC env, diff --git a/src/elab_err.sig b/src/elab_err.sig index d757572f..3b14406b 100644 --- a/src/elab_err.sig +++ b/src/elab_err.sig @@ -27,11 +27,16 @@ signature ELAB_ERR = sig + datatype kind_error = + UnboundKind of ErrorMsg.span * string + + val kindError : ElabEnv.env -> kind_error -> unit + datatype kunify_error = KOccursCheckFailed of Elab.kind * Elab.kind | KIncompatible of Elab.kind * Elab.kind - val kunifyError : kunify_error -> unit + val kunifyError : ElabEnv.env -> kunify_error -> unit datatype con_error = UnboundCon of ErrorMsg.span * string diff --git a/src/elab_err.sml b/src/elab_err.sml index e8d7ff68..8892674c 100644 --- a/src/elab_err.sml +++ b/src/elab_err.sml @@ -36,7 +36,7 @@ structure U = ElabUtil open Print structure P = ElabPrint -val simplCon = U.Con.mapB {kind = fn k => k, +val simplCon = U.Con.mapB {kind = fn _ => fn k => k, con = fn env => fn c => let val c = (c, ErrorMsg.dummySpan) @@ -46,25 +46,34 @@ val simplCon = U.Con.mapB {kind = fn k => k, ("c'", P.p_con env c')];*) #1 c' end, - bind = fn (env, U.Con.Rel (x, k)) => E.pushCRel env x k - | (env, U.Con.Named (x, n, k)) => E.pushCNamedAs env x n k NONE} + bind = fn (env, U.Con.RelC (x, k)) => E.pushCRel env x k + | (env, U.Con.NamedC (x, n, k)) => E.pushCNamedAs env x n k NONE + | (env, _) => env} val p_kind = P.p_kind + +datatype kind_error = + UnboundKind of ErrorMsg.span * string + +fun kindError env err = + case err of + UnboundKind (loc, s) => + ErrorMsg.errorAt loc ("Unbound kind variable " ^ s) datatype kunify_error = KOccursCheckFailed of kind * kind | KIncompatible of kind * kind -fun kunifyError err = +fun kunifyError env err = case err of KOccursCheckFailed (k1, k2) => eprefaces "Kind occurs check failed" - [("Kind 1", p_kind k1), - ("Kind 2", p_kind k2)] + [("Kind 1", p_kind env k1), + ("Kind 2", p_kind env k2)] | KIncompatible (k1, k2) => eprefaces "Incompatible kinds" - [("Kind 1", p_kind k1), - ("Kind 2", p_kind k2)] + [("Kind 1", p_kind env k1), + ("Kind 2", p_kind env k2)] fun p_con env c = P.p_con env (simplCon env c) @@ -89,9 +98,9 @@ fun conError env err = | WrongKind (c, k1, k2, kerr) => (ErrorMsg.errorAt (#2 c) "Wrong kind"; eprefaces' [("Constructor", p_con env c), - ("Have kind", p_kind k1), - ("Need kind", p_kind k2)]; - kunifyError kerr) + ("Have kind", p_kind env k1), + ("Need kind", p_kind env k2)]; + kunifyError env kerr) | DuplicateField (loc, s) => ErrorMsg.errorAt loc ("Duplicate record field " ^ s) | ProjBounds (c, n) => @@ -101,7 +110,7 @@ fun conError env err = | ProjMismatch (c, k) => (ErrorMsg.errorAt (#2 c) "Projection from non-tuple constructor"; eprefaces' [("Constructor", p_con env c), - ("Kind", p_kind k)]) + ("Kind", p_kind env k)]) datatype cunify_error = @@ -116,9 +125,9 @@ fun cunifyError env err = case err of CKind (k1, k2, kerr) => (eprefaces "Kind unification failure" - [("Kind 1", p_kind k1), - ("Kind 2", p_kind k2)]; - kunifyError kerr) + [("Kind 1", p_kind env k1), + ("Kind 2", p_kind env k2)]; + kunifyError env kerr) | COccursCheckFailed (c1, c2) => eprefaces "Constructor occurs check failed" [("Con 1", p_con env c1), @@ -133,7 +142,7 @@ fun cunifyError env err = ("Con 2", p_con env c2)] | CKindof (k, c, expected) => eprefaces ("Unexpected kind for kindof calculation (expecting " ^ expected ^ ")") - [("Kind", p_kind k), + [("Kind", p_kind env k), ("Con", p_con env c)] | CRecordFailure (c1, c2) => eprefaces "Can't unify record constructors" @@ -267,9 +276,9 @@ fun sgnError env err = (ErrorMsg.errorAt (#2 sgi1) "Kind unification failure in signature matching:"; eprefaces' [("Have", p_sgn_item env sgi1), ("Need", p_sgn_item env sgi2), - ("Kind 1", p_kind k1), - ("Kind 2", p_kind k2)]; - kunifyError kerr) + ("Kind 1", p_kind env k1), + ("Kind 2", p_kind env k2)]; + kunifyError env kerr) | SgiWrongCon (sgi1, c1, sgi2, c2, cerr) => (ErrorMsg.errorAt (#2 sgi1) "Constructor unification failure in signature matching:"; eprefaces' [("Have", p_sgn_item env sgi1), @@ -296,9 +305,9 @@ fun sgnError env err = ("Field", PD.string x)]) | WhereWrongKind (k1, k2, kerr) => (ErrorMsg.errorAt (#2 k1) "Wrong kind for 'where'"; - eprefaces' [("Have", p_kind k1), - ("Need", p_kind k2)]; - kunifyError kerr) + eprefaces' [("Have", p_kind env k1), + ("Need", p_kind env k2)]; + kunifyError env kerr) | NotIncludable sgn => (ErrorMsg.errorAt (#2 sgn) "Invalid signature to 'include'"; eprefaces' [("Signature", p_sgn env sgn)]) @@ -337,10 +346,10 @@ fun strError env err = eprefaces' [("Signature", p_sgn env sgn)]) | NotType (k, (k1, k2, ue)) => (ErrorMsg.errorAt (#2 k) "'val' type kind is not 'Type'"; - eprefaces' [("Kind", p_kind k), - ("Subkind 1", p_kind k1), - ("Subkind 2", p_kind k2)]; - kunifyError ue) + eprefaces' [("Kind", p_kind env k), + ("Subkind 1", p_kind env k1), + ("Subkind 2", p_kind env k2)]; + kunifyError env ue) | DuplicateConstructor (x, loc) => ErrorMsg.errorAt loc ("Duplicate datatype constructor " ^ x) | NotDatatype loc => diff --git a/src/elab_ops.sig b/src/elab_ops.sig index 62af9638..7088bf06 100644 --- a/src/elab_ops.sig +++ b/src/elab_ops.sig @@ -27,6 +27,12 @@ signature ELAB_OPS = sig + val liftKindInKind : int -> Elab.kind -> Elab.kind + val subKindInKind : int * Elab.kind -> Elab.kind -> Elab.kind + + val liftKindInCon : int -> Elab.con -> Elab.con + val subKindInCon : int * Elab.kind -> Elab.con -> Elab.con + val liftConInCon : int -> Elab.con -> Elab.con val subConInCon : int * Elab.con -> Elab.con -> Elab.con val subStrInSgn : int * int -> Elab.sgn -> Elab.sgn diff --git a/src/elab_ops.sml b/src/elab_ops.sml index c3e9274c..60a7639d 100644 --- a/src/elab_ops.sml +++ b/src/elab_ops.sml @@ -32,8 +32,64 @@ open Elab structure E = ElabEnv structure U = ElabUtil +fun liftKindInKind' by = + U.Kind.mapB {kind = fn bound => fn k => + case k of + KRel xn => + if xn < bound then + k + else + KRel (xn + by) + | _ => k, + bind = fn (bound, _) => bound + 1} + +fun subKindInKind' rep = + U.Kind.mapB {kind = fn (by, xn) => fn k => + case k of + KRel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 (liftKindInKind' by 0 rep) + | GREATER => KRel (xn' - 1) + | LESS => k) + | _ => k, + bind = fn ((by, xn), _) => (by+1, xn+1)} + +val liftKindInKind = liftKindInKind' 1 + +fun subKindInKind (xn, rep) = subKindInKind' rep (0, xn) + +fun liftKindInCon by = + U.Con.mapB {kind = fn bound => fn k => + case k of + KRel xn => + if xn < bound then + k + else + KRel (xn + by) + | _ => k, + con = fn _ => fn c => c, + bind = fn (bound, U.Con.RelK _) => bound + 1 + | (bound, _) => bound} + +fun subKindInCon' rep = + U.Con.mapB {kind = fn (by, xn) => fn k => + case k of + KRel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 (liftKindInKind' by 0 rep) + | GREATER => KRel (xn' - 1) + | LESS => k) + | _ => k, + con = fn _ => fn c => c, + bind = fn ((by, xn), U.Con.RelK _) => (by+1, xn+1) + | (st, _) => st} + +val liftKindInCon = liftKindInCon 1 + +fun subKindInCon (xn, rep) = subKindInCon' rep (0, xn) + fun liftConInCon by = - U.Con.mapB {kind = fn k => k, + U.Con.mapB {kind = fn _ => fn k => k, con = fn bound => fn c => case c of CRel xn => @@ -43,11 +99,11 @@ fun liftConInCon by = CRel (xn + by) (*| CUnif _ => raise SynUnif*) | _ => c, - bind = fn (bound, U.Con.Rel _) => bound + 1 + bind = fn (bound, U.Con.RelC _) => bound + 1 | (bound, _) => bound} fun subConInCon' rep = - U.Con.mapB {kind = fn k => k, + U.Con.mapB {kind = fn _ => fn k => k, con = fn (by, xn) => fn c => case c of CRel xn' => @@ -57,7 +113,7 @@ fun subConInCon' rep = | LESS => c) (*| CUnif _ => raise SynUnif*) | _ => c, - bind = fn ((by, xn), U.Con.Rel _) => (by+1, xn+1) + bind = fn ((by, xn), U.Con.RelC _) => (by+1, xn+1) | (ctx, _) => ctx} val liftConInCon = liftConInCon 1 @@ -205,6 +261,11 @@ fun hnormCon env (cAll as (c, loc)) = | _ => default () end | c1' => (CApp ((c1', loc), hnormCon env c2), loc)) + + | CKApp (c1, k) => + (case hnormCon env c1 of + (CKAbs (_, body), _) => hnormCon env (subKindInCon (0, k) body) + | _ => cAll) | CConcat (c1, c2) => (case (hnormCon env c1, hnormCon env c2) of diff --git a/src/elab_print.sig b/src/elab_print.sig index 3d078576..41d72ca7 100644 --- a/src/elab_print.sig +++ b/src/elab_print.sig @@ -28,7 +28,7 @@ (* Pretty-printing Ur/Web *) signature ELAB_PRINT = sig - val p_kind : Elab.kind Print.printer + val p_kind : ElabEnv.env -> Elab.kind Print.printer val p_explicitness : Elab.explicitness Print.printer val p_con : ElabEnv.env -> Elab.con Print.printer val p_pat : ElabEnv.env -> Elab.pat Print.printer diff --git a/src/elab_print.sml b/src/elab_print.sml index 098c9259..a0e1a54a 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -38,25 +38,36 @@ structure E = ElabEnv val debug = ref false -fun p_kind' par (k, _) = +fun p_kind' par env (k, _) = case k of KType => string "Type" - | KArrow (k1, k2) => parenIf par (box [p_kind' true k1, + | KArrow (k1, k2) => parenIf par (box [p_kind' true env k1, space, string "->", space, - p_kind k2]) + p_kind env k2]) | KName => string "Name" - | KRecord k => box [string "{", p_kind k, string "}"] + | KRecord k => box [string "{", p_kind env k, string "}"] | KUnit => string "Unit" | KTuple ks => box [string "(", - p_list_sep (box [space, string "*", space]) p_kind ks, + p_list_sep (box [space, string "*", space]) (p_kind env) ks, string ")"] | KError => string "" - | KUnif (_, _, ref (SOME k)) => p_kind' par k + | KUnif (_, _, ref (SOME k)) => p_kind' par env k | KUnif (_, s, _) => string ("") + | KRel n => ((if !debug then + string (E.lookupKRel env n ^ "_" ^ Int.toString n) + else + string (E.lookupKRel env n)) + handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n)) + | KFun (x, k) => box [string x, + space, + string "-->", + space, + p_kind (E.pushKRel env x) k] + and p_kind k = p_kind' false k fun p_explicitness e = @@ -66,7 +77,7 @@ fun p_explicitness e = fun p_con' par env (c, _) = case c of - TFun (t1, t2) => parenIf par (box [p_con' true env t1, + TFun (t1, t2) => parenIf true (box [p_con' true env t1, space, string "->", space, @@ -75,20 +86,22 @@ fun p_con' par env (c, _) = space, p_explicitness e, space, - p_kind k, + p_kind env k, space, string "->", space, p_con (E.pushCRel env x k) c]) - | CDisjoint (_, c1, c2, c3) => parenIf par (box [p_con env c1, - space, - string "~", - space, - p_con env c2, - space, - string "=>", - space, - p_con env c3]) + | CDisjoint (ai, c1, c2, c3) => parenIf par (box [p_con env c1, + space, + string (case ai of + Instantiate => "~" + | LeaveAlone => "~~"), + space, + p_con env c2, + space, + string "=>", + space, + p_con env c3]) | TRecord (CRecord (_, xcs), _) => box [string "{", p_list (fn (x, c) => box [p_name env x, @@ -134,7 +147,7 @@ fun p_con' par env (c, _) = space, string "::", space, - p_kind k, + p_kind env k, space, string "=>", space, @@ -152,7 +165,7 @@ fun p_con' par env (c, _) = space, p_con env c]) xcs, string "]::", - p_kind k]) + p_kind env k]) else parenIf par (box [string "[", p_list (fn (x, c) => @@ -181,8 +194,24 @@ fun p_con' par env (c, _) = | CError => string "" | CUnif (_, _, _, ref (SOME c)) => p_con' par env c | CUnif (_, k, s, _) => box [string (""] + + | CKAbs (x, c) => box [string x, + space, + string "==>", + space, + p_con (E.pushKRel env x) c] + | CKApp (c, k) => box [p_con env c, + string "[[", + p_kind env k, + string "]]"] + | TKFun (x, c) => box [string x, + space, + string "-->", + space, + p_con (E.pushKRel env x) c] + and p_con env = p_con' false env @@ -286,7 +315,7 @@ fun p_exp' par env (e, _) = space, p_explicitness exp, space, - p_kind k, + p_kind env k, space, string "=>", space, @@ -377,8 +406,6 @@ fun p_exp' par env (e, _) = space, p_con' true env c]) - | EFold _ => string "fold" - | ECase (e, pes, _) => parenIf par (box [string "case", space, p_exp env e, @@ -415,6 +442,16 @@ fun p_exp' par env (e, _) = string "end"] end + | EKAbs (x, e) => box [string x, + space, + string "==>", + space, + p_exp (E.pushKRel env x) e] + | EKApp (e, k) => box [p_exp env e, + string "[[", + p_kind env k, + string "]]"] + and p_exp env = p_exp' false env and p_edecl env (dAll as (d, _)) = @@ -478,14 +515,14 @@ fun p_sgn_item env (sgi, _) = space, string "::", space, - p_kind k] + p_kind env k] | SgiCon (x, n, k, c) => box [string "con", space, p_named x n, space, string "::", space, - p_kind k, + p_kind env k, space, string "=", space, @@ -540,14 +577,14 @@ fun p_sgn_item env (sgi, _) = space, string "::", space, - p_kind k] + p_kind env k] | SgiClass (x, n, k, c) => box [string "class", space, p_named x n, space, string "::", space, - p_kind k, + p_kind env k, space, string "=", space, @@ -627,7 +664,7 @@ fun p_decl env (dAll as (d, _) : decl) = space, string "::", space, - p_kind k, + p_kind env k, space, string "=", space, @@ -719,7 +756,7 @@ fun p_decl env (dAll as (d, _) : decl) = space, string "::", space, - p_kind k, + p_kind env k, space, string "=", space, diff --git a/src/elab_util.sig b/src/elab_util.sig index f9988981..817f885f 100644 --- a/src/elab_util.sig +++ b/src/elab_util.sig @@ -30,17 +30,24 @@ signature ELAB_UTIL = sig val classifyDatatype : (string * int * 'a option) list -> Elab.datatype_kind structure Kind : sig + val mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB, + bind : 'context * string -> 'context} + -> ('context, Elab.kind, 'state, 'abort) Search.mapfolderB val mapfold : (Elab.kind', 'state, 'abort) Search.mapfolder -> (Elab.kind, 'state, 'abort) Search.mapfolder val exists : (Elab.kind' -> bool) -> Elab.kind -> bool + val mapB : {kind : 'context -> Elab.kind' -> Elab.kind', + bind : 'context * string -> 'context} + -> 'context -> (Elab.kind -> Elab.kind) end structure Con : sig datatype binder = - Rel of string * Elab.kind - | Named of string * int * Elab.kind + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind - val mapfoldB : {kind : (Elab.kind', 'state, 'abort) Search.mapfolder, + val mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB, con : ('context, Elab.con', 'state, 'abort) Search.mapfolderB, bind : 'context * binder -> 'context} -> ('context, Elab.con, 'state, 'abort) Search.mapfolderB @@ -48,7 +55,7 @@ structure Con : sig con : (Elab.con', 'state, 'abort) Search.mapfolder} -> (Elab.con, 'state, 'abort) Search.mapfolder - val mapB : {kind : Elab.kind' -> Elab.kind', + val mapB : {kind : 'context -> Elab.kind' -> Elab.kind', con : 'context -> Elab.con' -> Elab.con', bind : 'context * binder -> 'context} -> 'context -> (Elab.con -> Elab.con) @@ -58,7 +65,7 @@ structure Con : sig val exists : {kind : Elab.kind' -> bool, con : Elab.con' -> bool} -> Elab.con -> bool - val foldB : {kind : Elab.kind' * 'state -> 'state, + val foldB : {kind : 'context * Elab.kind' * 'state -> 'state, con : 'context * Elab.con' * 'state -> 'state, bind : 'context * binder -> 'context} -> 'context -> 'state -> Elab.con -> 'state @@ -66,12 +73,13 @@ end structure Exp : sig datatype binder = - RelC of string * Elab.kind + RelK of string + | RelC of string * Elab.kind | NamedC of string * int * Elab.kind | RelE of string * Elab.con | NamedE of string * Elab.con - val mapfoldB : {kind : (Elab.kind', 'state, 'abort) Search.mapfolder, + val mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB, con : ('context, Elab.con', 'state, 'abort) Search.mapfolderB, exp : ('context, Elab.exp', 'state, 'abort) Search.mapfolderB, bind : 'context * binder -> 'context} @@ -80,7 +88,7 @@ structure Exp : sig con : (Elab.con', 'state, 'abort) Search.mapfolder, exp : (Elab.exp', 'state, 'abort) Search.mapfolder} -> (Elab.exp, 'state, 'abort) Search.mapfolder - val mapB : {kind : Elab.kind' -> Elab.kind', + val mapB : {kind : 'context -> Elab.kind' -> Elab.kind', con : 'context -> Elab.con' -> Elab.con', exp : 'context -> Elab.exp' -> Elab.exp', bind : 'context * binder -> 'context} @@ -89,7 +97,7 @@ structure Exp : sig con : Elab.con' -> bool, exp : Elab.exp' -> bool} -> Elab.exp -> bool - val foldB : {kind : Elab.kind' * 'state -> 'state, + val foldB : {kind : 'context * Elab.kind' * 'state -> 'state, con : 'context * Elab.con' * 'state -> 'state, exp : 'context * Elab.exp' * 'state -> 'state, bind : 'context * binder -> 'context} @@ -98,12 +106,13 @@ end structure Sgn : sig datatype binder = - RelC of string * Elab.kind + RelK of string + | RelC of string * Elab.kind | NamedC of string * int * Elab.kind | Str of string * Elab.sgn | Sgn of string * Elab.sgn - val mapfoldB : {kind : (Elab.kind', 'state, 'abort) Search.mapfolder, + val mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB, con : ('context, Elab.con', 'state, 'abort) Search.mapfolderB, sgn_item : ('context, Elab.sgn_item', 'state, 'abort) Search.mapfolderB, sgn : ('context, Elab.sgn', 'state, 'abort) Search.mapfolderB, @@ -127,14 +136,15 @@ end structure Decl : sig datatype binder = - RelC of string * Elab.kind + RelK of string + | RelC of string * Elab.kind | NamedC of string * int * Elab.kind | RelE of string * Elab.con | NamedE of string * Elab.con | Str of string * Elab.sgn | Sgn of string * Elab.sgn - val mapfoldB : {kind : (Elab.kind', 'state, 'abort) Search.mapfolder, + val mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB, con : ('context, Elab.con', 'state, 'abort) Search.mapfolderB, exp : ('context, Elab.exp', 'state, 'abort) Search.mapfolderB, sgn_item : ('context, Elab.sgn_item', 'state, 'abort) Search.mapfolderB, @@ -168,7 +178,7 @@ structure Decl : sig decl : Elab.decl' -> 'a option} -> Elab.decl -> 'a option - val foldMapB : {kind : Elab.kind' * 'state -> Elab.kind' * 'state, + val foldMapB : {kind : 'context * Elab.kind' * 'state -> Elab.kind' * 'state, con : 'context * Elab.con' * 'state -> Elab.con' * 'state, exp : 'context * Elab.exp' * 'state -> Elab.exp' * 'state, sgn_item : 'context * Elab.sgn_item' * 'state -> Elab.sgn_item' * 'state, diff --git a/src/elab_util.sml b/src/elab_util.sml index f052a06d..be1c9459 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -43,44 +43,60 @@ structure S = Search structure Kind = struct -fun mapfold f = +fun mapfoldB {kind, bind} = let - fun mfk k acc = - S.bindP (mfk' k acc, f) + fun mfk ctx k acc = + S.bindP (mfk' ctx k acc, kind ctx) - and mfk' (kAll as (k, loc)) = + and mfk' ctx (kAll as (k, loc)) = case k of KType => S.return2 kAll | KArrow (k1, k2) => - S.bind2 (mfk k1, + S.bind2 (mfk ctx k1, fn k1' => - S.map2 (mfk k2, + S.map2 (mfk ctx k2, fn k2' => (KArrow (k1', k2'), loc))) | KName => S.return2 kAll | KRecord k => - S.map2 (mfk k, + S.map2 (mfk ctx k, fn k' => (KRecord k', loc)) | KUnit => S.return2 kAll | KTuple ks => - S.map2 (ListUtil.mapfold mfk ks, + S.map2 (ListUtil.mapfold (mfk ctx) ks, fn ks' => (KTuple ks', loc)) | KError => S.return2 kAll - | KUnif (_, _, ref (SOME k)) => mfk' k + | KUnif (_, _, ref (SOME k)) => mfk' ctx k | KUnif _ => S.return2 kAll + + | KRel _ => S.return2 kAll + | KFun (x, k) => + S.map2 (mfk (bind (ctx, x)) k, + fn k' => + (KFun (x, k'), loc)) in mfk end +fun mapfold fk = + mapfoldB {kind = fn () => fk, + bind = fn ((), _) => ()} () + +fun mapB {kind, bind} ctx k = + case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()), + bind = bind} ctx k () of + S.Continue (k, ()) => k + | S.Return _ => raise Fail "ElabUtil.Kind.mapB: Impossible" + fun exists f k = case mapfold (fn k => fn () => if f k then @@ -95,12 +111,13 @@ end structure Con = struct datatype binder = - Rel of string * Elab.kind - | Named of string * int * Elab.kind + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind fun mapfoldB {kind = fk, con = fc, bind} = let - val mfk = Kind.mapfold fk + val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, s) => bind (ctx, RelK s)} fun mfc ctx c acc = S.bindP (mfc' ctx c acc, fc ctx) @@ -114,9 +131,9 @@ fun mapfoldB {kind = fk, con = fc, bind} = fn c2' => (TFun (c1', c2'), loc))) | TCFun (e, x, k, c) => - S.bind2 (mfk k, + S.bind2 (mfk ctx k, fn k' => - S.map2 (mfc (bind (ctx, Rel (x, k))) c, + S.map2 (mfc (bind (ctx, RelC (x, k))) c, fn c' => (TCFun (e, x, k', c'), loc))) | CDisjoint (ai, c1, c2, c3) => @@ -142,16 +159,16 @@ fun mapfoldB {kind = fk, con = fc, bind} = fn c2' => (CApp (c1', c2'), loc))) | CAbs (x, k, c) => - S.bind2 (mfk k, + S.bind2 (mfk ctx k, fn k' => - S.map2 (mfc (bind (ctx, Rel (x, k))) c, + S.map2 (mfc (bind (ctx, RelC (x, k))) c, fn c' => (CAbs (x, k', c'), loc))) | CName _ => S.return2 cAll | CRecord (k, xcs) => - S.bind2 (mfk k, + S.bind2 (mfk ctx k, fn k' => S.map2 (ListUtil.mapfold (fn (x, c) => S.bind2 (mfc ctx x, @@ -169,9 +186,9 @@ fun mapfoldB {kind = fk, con = fc, bind} = fn c2' => (CConcat (c1', c2'), loc))) | CMap (k1, k2) => - S.bind2 (mfk k1, + S.bind2 (mfk ctx k1, fn k1' => - S.map2 (mfk k2, + S.map2 (mfk ctx k2, fn k2' => (CMap (k1', k2'), loc))) @@ -190,17 +207,32 @@ fun mapfoldB {kind = fk, con = fc, bind} = | CError => S.return2 cAll | CUnif (_, _, _, ref (SOME c)) => mfc' ctx c | CUnif _ => S.return2 cAll + + | CKAbs (x, c) => + S.map2 (mfc (bind (ctx, RelK x)) c, + fn c' => + (CKAbs (x, c'), loc)) + | CKApp (c, k) => + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfk ctx k, + fn k' => + (CKApp (c', k'), loc))) + | TKFun (x, c) => + S.map2 (mfc (bind (ctx, RelK x)) c, + fn c' => + (TKFun (x, c'), loc)) in mfc end fun mapfold {kind = fk, con = fc} = - mapfoldB {kind = fk, + mapfoldB {kind = fn () => fk, con = fn () => fc, bind = fn ((), _) => ()} () fun mapB {kind, con, bind} ctx c = - case mapfoldB {kind = fn k => fn () => S.Continue (kind k, ()), + case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()), con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()), bind = bind} ctx c () of S.Continue (c, ()) => c @@ -227,7 +259,7 @@ fun exists {kind, con} k = | S.Continue _ => false fun foldB {kind, con, bind} ctx st c = - case mapfoldB {kind = fn k => fn st => S.Continue (k, kind (k, st)), + case mapfoldB {kind = fn ctx => fn k => fn st => S.Continue (k, kind (ctx, k, st)), con = fn ctx => fn c => fn st => S.Continue (c, con (ctx, c, st)), bind = bind} ctx c st of S.Continue (_, st) => st @@ -238,20 +270,22 @@ end structure Exp = struct datatype binder = - RelC of string * Elab.kind + RelK of string + | RelC of string * Elab.kind | NamedC of string * int * Elab.kind | RelE of string * Elab.con | NamedE of string * Elab.con fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = let - val mfk = Kind.mapfold fk + val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, x) => bind (ctx, RelK x)} fun bind' (ctx, b) = let val b' = case b of - Con.Rel x => RelC x - | Con.Named x => NamedC x + Con.RelK x => RelK x + | Con.RelC x => RelC x + | Con.NamedC x => NamedC x in bind (ctx, b') end @@ -288,7 +322,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = fn c' => (ECApp (e', c'), loc))) | ECAbs (expl, x, k, e) => - S.bind2 (mfk k, + S.bind2 (mfk ctx k, fn k' => S.map2 (mfe (bind (ctx, RelC (x, k))) e, fn e' => @@ -347,11 +381,6 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = fn rest' => (ECutMulti (e', c', {rest = rest'}), loc)))) - | EFold k => - S.map2 (mfk k, - fn k' => - (EFold k', loc)) - | ECase (e, pes, {disc, result}) => S.bind2 (mfe ctx e, fn e' => @@ -406,6 +435,17 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = (ELet (des', e'), loc))) end + | EKAbs (x, e) => + S.map2 (mfe (bind (ctx, RelK x)) e, + fn e' => + (EKAbs (x, e'), loc)) + | EKApp (e, k) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfk ctx k, + fn k' => + (EKApp (e', k'), loc))) + and mfed ctx (dAll as (d, loc)) = case d of EDVal vi => @@ -432,7 +472,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = end fun mapfold {kind = fk, con = fc, exp = fe} = - mapfoldB {kind = fk, + mapfoldB {kind = fn () => fk, con = fn () => fc, exp = fn () => fe, bind = fn ((), _) => ()} () @@ -457,7 +497,7 @@ fun exists {kind, con, exp} k = | S.Continue _ => false fun mapB {kind, con, exp, bind} ctx e = - case mapfoldB {kind = fn k => fn () => S.Continue (kind k, ()), + case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()), con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()), exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()), bind = bind} ctx e () of @@ -465,7 +505,7 @@ fun mapB {kind, con, exp, bind} ctx e = | S.Return _ => raise Fail "ElabUtil.Exp.mapB: Impossible" fun foldB {kind, con, exp, bind} ctx st e = - case mapfoldB {kind = fn k => fn st => S.Continue (k, kind (k, st)), + case mapfoldB {kind = fn ctx => fn k => fn st => S.Continue (k, kind (ctx, k, st)), con = fn ctx => fn c => fn st => S.Continue (c, con (ctx, c, st)), exp = fn ctx => fn e => fn st => S.Continue (e, exp (ctx, e, st)), bind = bind} ctx e st of @@ -477,7 +517,8 @@ end structure Sgn = struct datatype binder = - RelC of string * Elab.kind + RelK of string + | RelC of string * Elab.kind | NamedC of string * int * Elab.kind | Str of string * Elab.sgn | Sgn of string * Elab.sgn @@ -487,14 +528,15 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = fun bind' (ctx, b) = let val b' = case b of - Con.Rel x => RelC x - | Con.Named x => NamedC x + Con.RelK x => RelK x + | Con.RelC x => RelC x + | Con.NamedC x => NamedC x in bind (ctx, b') end val con = Con.mapfoldB {kind = kind, con = con, bind = bind'} - val kind = Kind.mapfold kind + val kind = Kind.mapfoldB {kind = kind, bind = fn (ctx, x) => bind (ctx, RelK x)} fun sgi ctx si acc = S.bindP (sgi' ctx si acc, sgn_item ctx) @@ -502,11 +544,11 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = and sgi' ctx (siAll as (si, loc)) = case si of SgiConAbs (x, n, k) => - S.map2 (kind k, + S.map2 (kind ctx k, fn k' => (SgiConAbs (x, n, k'), loc)) | SgiCon (x, n, k, c) => - S.bind2 (kind k, + S.bind2 (kind ctx k, fn k' => S.map2 (con ctx c, fn c' => @@ -548,11 +590,11 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = fn c2' => (SgiConstraint (c1', c2'), loc))) | SgiClassAbs (x, n, k) => - S.map2 (kind k, + S.map2 (kind ctx k, fn k' => (SgiClassAbs (x, n, k'), loc)) | SgiClass (x, n, k, c) => - S.bind2 (kind k, + S.bind2 (kind ctx k, fn k' => S.map2 (con ctx c, fn c' => @@ -608,7 +650,7 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = end fun mapfold {kind, con, sgn_item, sgn} = - mapfoldB {kind = kind, + mapfoldB {kind = fn () => kind, con = fn () => con, sgn_item = fn () => sgn_item, sgn = fn () => sgn, @@ -627,7 +669,8 @@ end structure Decl = struct datatype binder = - RelC of string * Elab.kind + RelK of string + | RelC of string * Elab.kind | NamedC of string * int * Elab.kind | RelE of string * Elab.con | NamedE of string * Elab.con @@ -636,13 +679,14 @@ datatype binder = fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = fst, decl = fd, bind} = let - val mfk = Kind.mapfold fk + val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, x) => bind (ctx, RelK x)} fun bind' (ctx, b) = let val b' = case b of - Con.Rel x => RelC x - | Con.Named x => NamedC x + Con.RelK x => RelK x + | Con.RelC x => RelC x + | Con.NamedC x => NamedC x in bind (ctx, b') end @@ -651,7 +695,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f fun bind' (ctx, b) = let val b' = case b of - Exp.RelC x => RelC x + Exp.RelK x => RelK x + | Exp.RelC x => RelC x | Exp.NamedC x => NamedC x | Exp.RelE x => RelE x | Exp.NamedE x => NamedE x @@ -663,7 +708,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f fun bind' (ctx, b) = let val b' = case b of - Sgn.RelC x => RelC x + Sgn.RelK x => RelK x + | Sgn.RelC x => RelC x | Sgn.NamedC x => NamedC x | Sgn.Sgn x => Sgn x | Sgn.Str x => Str x @@ -760,7 +806,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f and mfd' ctx (dAll as (d, loc)) = case d of DCon (x, n, k, c) => - S.bind2 (mfk k, + S.bind2 (mfk ctx k, fn k' => S.map2 (mfc ctx c, fn c' => @@ -825,7 +871,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f | DSequence _ => S.return2 dAll | DClass (x, n, k, c) => - S.bind2 (mfk k, + S.bind2 (mfk ctx k, fn k' => S.map2 (mfc ctx c, fn c' => @@ -849,7 +895,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f end fun mapfold {kind, con, exp, sgn_item, sgn, str, decl} = - mapfoldB {kind = kind, + mapfoldB {kind = fn () => kind, con = fn () => con, exp = fn () => exp, sgn_item = fn () => sgn_item, @@ -938,7 +984,7 @@ fun search {kind, con, exp, sgn_item, sgn, str, decl} k = | S.Continue _ => NONE fun foldMapB {kind, con, exp, sgn_item, sgn, str, decl, bind} ctx st d = - case mapfoldB {kind = fn x => fn st => S.Continue (kind (x, st)), + case mapfoldB {kind = fn ctx => fn x => fn st => S.Continue (kind (ctx, x, st)), con = fn ctx => fn x => fn st => S.Continue (con (ctx, x, st)), exp = fn ctx => fn x => fn st => S.Continue (exp (ctx, x, st)), sgn_item = fn ctx => fn x => fn st => S.Continue (sgn_item (ctx, x, st)), diff --git a/src/elaborate.sml b/src/elaborate.sml index 0c335603..54543ae9 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -61,7 +61,7 @@ exception KUnify' of kunify_error - fun unifyKinds' (k1All as (k1, _)) (k2All as (k2, _)) = + fun unifyKinds' env (k1All as (k1, _)) (k2All as (k2, _)) = let fun err f = raise KUnify' (f (k1All, k2All)) in @@ -70,19 +70,27 @@ | (L'.KUnit, L'.KUnit) => () | (L'.KArrow (d1, r1), L'.KArrow (d2, r2)) => - (unifyKinds' d1 d2; - unifyKinds' r1 r2) + (unifyKinds' env d1 d2; + unifyKinds' env r1 r2) | (L'.KName, L'.KName) => () - | (L'.KRecord k1, L'.KRecord k2) => unifyKinds' k1 k2 + | (L'.KRecord k1, L'.KRecord k2) => unifyKinds' env k1 k2 | (L'.KTuple ks1, L'.KTuple ks2) => - ((ListPair.appEq (fn (k1, k2) => unifyKinds' k1 k2) (ks1, ks2)) + ((ListPair.appEq (fn (k1, k2) => unifyKinds' env k1 k2) (ks1, ks2)) handle ListPair.UnequalLengths => err KIncompatible) + | (L'.KRel n1, L'.KRel n2) => + if n1 = n2 then + () + else + err KIncompatible + | (L'.KFun (x, k1), L'.KFun (_, k2)) => + unifyKinds' (E.pushKRel env x) k1 k2 + | (L'.KError, _) => () | (_, L'.KError) => () - | (L'.KUnif (_, _, ref (SOME k1All)), _) => unifyKinds' k1All k2All - | (_, L'.KUnif (_, _, ref (SOME k2All))) => unifyKinds' k1All k2All + | (L'.KUnif (_, _, ref (SOME k1All)), _) => unifyKinds' env k1All k2All + | (_, L'.KUnif (_, _, ref (SOME k2All))) => unifyKinds' env k1All k2All | (L'.KUnif (_, _, r1), L'.KUnif (_, _, r2)) => if r1 = r2 then @@ -106,12 +114,12 @@ exception KUnify of L'.kind * L'.kind * kunify_error - fun unifyKinds k1 k2 = - unifyKinds' k1 k2 + fun unifyKinds env k1 k2 = + unifyKinds' env k1 k2 handle KUnify' err => raise KUnify (k1, k2, err) fun checkKind env c k1 k2 = - unifyKinds k1 k2 + unifyKinds env k1 k2 handle KUnify (k1, k2, err) => conError env (WrongKind (c, k1, k2, err)) @@ -172,16 +180,23 @@ end - fun elabKind (k, loc) = + fun elabKind env (k, loc) = case k of L.KType => (L'.KType, loc) - | L.KArrow (k1, k2) => (L'.KArrow (elabKind k1, elabKind k2), loc) + | L.KArrow (k1, k2) => (L'.KArrow (elabKind env k1, elabKind env k2), loc) | L.KName => (L'.KName, loc) - | L.KRecord k => (L'.KRecord (elabKind k), loc) + | L.KRecord k => (L'.KRecord (elabKind env k), loc) | L.KUnit => (L'.KUnit, loc) - | L.KTuple ks => (L'.KTuple (map elabKind ks), loc) + | L.KTuple ks => (L'.KTuple (map (elabKind env) ks), loc) | L.KWild => kunif loc + | L.KVar s => (case E.lookupK env s of + NONE => + (kindError env (UnboundKind (loc, s)); + kerror) + | SOME n => (L'.KRel n, loc)) + | L.KFun (x, k) => (L'.KFun (x, elabKind (E.pushKRel env x) k), loc) + fun mapKind (dom, ran, loc)= (L'.KArrow ((L'.KArrow (dom, ran), loc), (L'.KArrow ((L'.KRecord dom, loc), @@ -192,11 +207,31 @@ L'.KUnif (_, _, ref (SOME k)) => hnormKind k | _ => kAll + open ElabOps + val hnormCon = D.hnormCon + + fun elabConHead (c as (_, loc)) k = + let + fun unravel (k, c) = + case hnormKind k of + (L'.KFun (x, k'), _) => + let + val u = kunif loc + + val k'' = subKindInKind (0, u) k' + in + unravel (k'', (L'.CKApp (c, u), loc)) + end + | _ => (c, k) + in + unravel (k, c) + end + fun elabCon (env, denv) (c, loc) = case c of L.CAnnot (c, k) => let - val k' = elabKind k + val k' = elabKind env k val (c', ck, gs) = elabCon (env, denv) c in checkKind env c' ck k'; @@ -215,13 +250,21 @@ | L.TCFun (e, x, k, t) => let val e' = elabExplicitness e - val k' = elabKind k + val k' = elabKind env k val env' = E.pushCRel env x k' val (t', tk, gs) = elabCon (env', D.enter denv) t in checkKind env t' tk ktype; ((L'.TCFun (e', x, k', t'), loc), ktype, gs) end + | L.TKFun (x, t) => + let + val env' = E.pushKRel env x + val (t', tk, gs) = elabCon (env', denv) t + in + checkKind env t' tk ktype; + ((L'.TKFun (x, t'), loc), ktype, gs) + end | L.CDisjoint (c1, c2, c) => let val (c1', k1, gs1) = elabCon (env, denv) c1 @@ -253,9 +296,17 @@ (conError env (UnboundCon (loc, s)); (cerror, kerror, [])) | E.Rel (n, k) => - ((L'.CRel n, loc), k, []) + let + val (c, k) = elabConHead (L'.CRel n, loc) k + in + (c, k, []) + end | E.Named (n, k) => - ((L'.CNamed n, loc), k, [])) + let + val (c, k) = elabConHead (L'.CNamed n, loc) k + in + (c, k, []) + end) | L.CVar (m1 :: ms, s) => (case E.lookupStr env m1 of NONE => (conError env (UnboundStrInCon (loc, m1)); @@ -292,7 +343,7 @@ let val k' = case ko of NONE => kunif loc - | SOME k => elabKind k + | SOME k => elabKind env k val env' = E.pushCRel env x k' val (t', tk, gs) = elabCon (env', D.enter denv) t in @@ -300,6 +351,15 @@ (L'.KArrow (k', tk), loc), gs) end + | L.CKAbs (x, t) => + let + val env' = E.pushKRel env x + val (t', tk, gs) = elabCon (env', denv) t + in + ((L'.CKAbs (x, t'), loc), + (L'.KFun (x, tk), loc), + gs) + end | L.CName s => ((L'.CName s, loc), kname, []) @@ -392,7 +452,7 @@ | L.CWild k => let - val k' = elabKind k + val k' = elabKind env k in (cunif (loc, k'), k', []) end @@ -431,8 +491,6 @@ exception SynUnif = E.SynUnif - open ElabOps - type record_summary = { fields : (L'.con * L'.con) list, unifs : (L'.con * L'.con option ref) list, @@ -499,7 +557,12 @@ | L'.CError => kerror | L'.CUnif (_, k, _, _) => k - val hnormCon = D.hnormCon + | L'.CKAbs (x, c) => (L'.KFun (x, kindof (E.pushKRel env x) c), loc) + | L'.CKApp (c, k) => + (case hnormKind (kindof env c) of + (L'.KFun (_, k'), _) => subKindInKind (0, k) k' + | k => raise CUnify' (CKindof (k, c, "kapp"))) + | L'.TKFun _ => ktype fun deConstraintCon (env, denv) c = let @@ -564,6 +627,10 @@ | L'.CError => false | L'.CUnif (_, k, _, _) => #1 k = L'.KUnit + | L'.CKAbs _ => false + | L'.CKApp _ => false + | L'.TKFun _ => false + fun unifyRecordCons (env, denv) (c1, c2) = let fun rkindof c = @@ -578,7 +645,7 @@ val (r1, gs1) = recordSummary (env, denv) c1 val (r2, gs2) = recordSummary (env, denv) c2 in - unifyKinds k1 k2; + unifyKinds env k1 k2; unifySummaries (env, denv) (k1, r1, r2); gs1 @ gs2 end @@ -848,12 +915,13 @@ val (c2, gs2) = hnormCon (env, denv) c2 in let + (*val () = prefaces "unifyCons'" [("old1", p_con env old1), + ("old2", p_con env old2), + ("c1", p_con env c1), + ("c2", p_con env c2)]*) + val gs3 = unifyCons'' (env, denv) c1 c2 in - (*prefaces "unifyCons'" [("c1", p_con env old1), - ("c2", p_con env old2), - ("t", PD.string (LargeReal.toString (Time.toReal - (Time.- (Time.now (), befor)))))];*) gs1 @ gs2 @ gs3 end handle ex => guessMap (env, denv) (c1, c2, gs1 @ gs2, ex) @@ -878,7 +946,7 @@ if expl1 <> expl2 then err CExplicitness else - (unifyKinds d1 d2; + (unifyKinds env d1 d2; let val denv' = D.enter denv (*val befor = Time.now ()*) @@ -906,7 +974,7 @@ (unifyCons' (env, denv) d1 d2; unifyCons' (env, denv) r1 r2) | (L'.CAbs (x1, k1, c1), L'.CAbs (_, k2, c2)) => - (unifyKinds k1 k2; + (unifyKinds env k1 k2; unifyCons' (E.pushCRel env x1 k1, D.enter denv) c1 c2) | (L'.CName n1, L'.CName n2) => @@ -954,6 +1022,19 @@ else err CIncompatible + | (L'.CMap (dom1, ran1), L'.CMap (dom2, ran2)) => + (unifyKinds env dom1 dom2; + unifyKinds env ran1 ran2; + []) + + | (L'.CKAbs (x, c1), L'.CKAbs (_, c2)) => + unifyCons' (E.pushKRel env x, denv) c1 c2 + | (L'.CKApp (c1, k1), L'.CKApp (c2, k2)) => + (unifyKinds env k1 k2; + unifyCons' (env, denv) c1 c2) + | (L'.TKFun (x, c1), L'.TKFun (_, c2)) => + unifyCons' (E.pushKRel env x, denv) c1 c2 + | (L'.CError, _) => [] | (_, L'.CError) => [] @@ -966,7 +1047,7 @@ if r1 = r2 then [] else - (unifyKinds k1 k2; + (unifyKinds env k1 k2; r1 := SOME c2All; []) @@ -983,11 +1064,6 @@ (r := SOME c1All; []) - | (L'.CMap (dom1, ran1), L'.CMap (dom2, ran2)) => - (unifyKinds dom1 dom2; - unifyKinds ran1 ran2; - []) - | _ => err CIncompatible end @@ -1013,36 +1089,7 @@ P.Int _ => !int | P.Float _ => !float | P.String _ => !string - - fun recCons (k, nm, v, rest, loc) = - (L'.CConcat ((L'.CRecord (k, [(nm, v)]), loc), - rest), loc) - - fun foldType (dom, loc) = - (L'.TCFun (L'.Explicit, "ran", (L'.KArrow ((L'.KRecord dom, loc), (L'.KType, loc)), loc), - (L'.TFun ((L'.TCFun (L'.Explicit, "nm", (L'.KName, loc), - (L'.TCFun (L'.Explicit, "v", dom, - (L'.TCFun (L'.Explicit, "rest", (L'.KRecord dom, loc), - (L'.TFun ((L'.CApp ((L'.CRel 3, loc), (L'.CRel 0, loc)), loc), - (L'.CDisjoint (L'.Instantiate, - (L'.CRecord - ((L'.KUnit, loc), - [((L'.CRel 2, loc), - (L'.CUnit, loc))]), loc), - (L'.CRel 0, loc), - (L'.CApp ((L'.CRel 3, loc), - recCons (dom, - (L'.CRel 2, loc), - (L'.CRel 1, loc), - (L'.CRel 0, loc), - loc)), loc)), - loc)), loc)), - loc)), loc)), loc), - (L'.TFun ((L'.CApp ((L'.CRel 0, loc), (L'.CRecord (dom, []), loc)), loc), - (L'.TCFun (L'.Explicit, "r", (L'.KRecord dom, loc), - (L'.CApp ((L'.CRel 1, loc), (L'.CRel 0, loc)), loc)), loc)), - loc)), loc)), loc) - + datatype constraint = Disjoint of D.goal | TypeClass of E.env * L'.con * L'.exp option ref * ErrorMsg.span @@ -1056,7 +1103,16 @@ val (t, gs) = hnormCon (env, denv) t in case t of - (L'.TCFun (L'.Implicit, x, k, t'), _) => + (L'.TKFun (x, t'), _) => + let + val u = kunif loc + + val t'' = subKindInCon (0, u) t' + val (e, t, gs') = unravel (t'', (L'.EKApp (e, u), loc)) + in + (e, t, enD gs @ gs') + end + | (L'.TCFun (L'.Implicit, x, k, t'), _) => let val u = cunif (loc, k) @@ -1575,7 +1631,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) = | L.ECAbs (expl, x, k, e) => let val expl' = elabExplicitness expl - val k' = elabKind k + val k' = elabKind env k val env' = E.pushCRel env x k' val (e', et, gs) = elabExp (env', D.enter denv) e @@ -1584,6 +1640,15 @@ fun elabExp (env, denv) (eAll as (e, loc)) = (L'.TCFun (expl', x, k', et), loc), gs) end + | L.EKAbs (x, e) => + let + val env' = E.pushKRel env x + val (e', et, gs) = elabExp (env', denv) e + in + ((L'.EKAbs (x, e'), loc), + (L'.TKFun (x, et), loc), + gs) + end | L.EDisjoint (c1, c2, e) => let @@ -1710,13 +1775,6 @@ fun elabExp (env, denv) (eAll as (e, loc)) = gs1 @ enD gs2 @ enD gs3 @ enD gs4) end - | L.EFold => - let - val dom = kunif loc - in - ((L'.EFold dom, loc), foldType (dom, loc), []) - end - | L.ECase (e, pes) => let val (e', et, gs1) = elabExp (env, denv) e @@ -1781,6 +1839,7 @@ and elabEdecl denv (dAll as (d, loc), (env, gs : constraint list)) = case e of L.EAbs _ => true | L.ECAbs (_, _, _, e) => allowable e + | L.EKAbs (_, e) => allowable e | L.EDisjoint (_, _, e) => allowable e | _ => false @@ -1859,7 +1918,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = case sgi of L.SgiConAbs (x, k) => let - val k' = elabKind k + val k' = elabKind env k val (env', n) = E.pushCNamed env x k' NONE in @@ -1870,7 +1929,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = let val k' = case ko of NONE => kunif loc - | SOME k => elabKind k + | SOME k => elabKind env k val (c', ck, gs') = elabCon (env, denv) c val (env', n) = E.pushCNamed env x k' (SOME c') @@ -1979,7 +2038,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = val (env', n) = E.pushENamed env x c' val c' = normClassConstraint env c' in - (unifyKinds ck ktype + (unifyKinds env ck ktype handle KUnify ue => strError env (NotType (ck, ue))); ([(L'.SgiVal (x, n, c'), loc)], (env', denv, gs' @ gs)) @@ -2027,7 +2086,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = | L.SgiClassAbs (x, k) => let - val k = elabKind k + val k = elabKind env k val k' = (L'.KArrow (k, (L'.KType, loc)), loc) val (env, n) = E.pushCNamed env x k' NONE val env = E.pushClass env n @@ -2037,7 +2096,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = | L.SgiClass (x, k, c) => let - val k = elabKind k + val k = elabKind env k val k' = (L'.KArrow (k, (L'.KType, loc)), loc) val (c', ck, gs) = elabCon (env, denv) c val (env, n) = E.pushCNamed env x k' (SOME c') @@ -2149,7 +2208,7 @@ and elabSgn (env, denv) (sgn, loc) = | L'.SgnConst sgis => if List.exists (fn (L'.SgiConAbs (x', _, k), _) => x' = x andalso - (unifyKinds k ck + (unifyKinds env k ck handle KUnify x => sgnError env (WhereWrongKind x); true) | _ => false) sgis then @@ -2355,7 +2414,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = fun found (x', n1, k1, co1) = if x = x' then let - val () = unifyKinds k1 k2 + val () = unifyKinds env k1 k2 handle KUnify (k1, k2, err) => sgnError env (SgiWrongKind (sgi1All, k1, sgi2All, k2, err)) val env = E.pushCNamedAs env x n1 k1 co1 @@ -2606,7 +2665,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = fun found (x', n1, k1, co) = if x = x' then let - val () = unifyKinds k1 k2 + val () = unifyKinds env k1 k2 handle KUnify (k1, k2, err) => sgnError env (SgiWrongKind (sgi1All, k1, sgi2All, k2, err)) @@ -2635,7 +2694,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = fun found (x', n1, k1, c1) = if x = x' then let - val () = unifyKinds k1 k2 + val () = unifyKinds env k1 k2 handle KUnify (k1, k2, err) => sgnError env (SgiWrongKind (sgi1All, k1, sgi2All, k2, err)) @@ -2702,6 +2761,9 @@ fun positive self = | CAbs _ => false | CDisjoint (c1, c2, c3) => none c1 andalso none c2 andalso none c3 + | CKAbs _ => false + | TKFun _ => false + | CName _ => true | CRecord xcs => List.all (fn (c1, c2) => none c1 andalso none c2) xcs @@ -2728,6 +2790,9 @@ fun positive self = | CAbs _ => false | CDisjoint (c1, c2, c3) => none c1 andalso none c2 andalso none c3 + | CKAbs _ => false + | TKFun _ => false + | CName _ => true | CRecord xcs => List.all (fn (c1, c2) => none c1 andalso pos c2) xcs @@ -2777,6 +2842,9 @@ fun wildifyStr env (str, sgn) = | L'.KUnif (_, _, ref (SOME k)) => decompileKind k | L'.KUnif _ => NONE + | L'.KRel _ => NONE + | L'.KFun _ => NONE + fun decompileCon env (c, loc) = case c of L'.CRel i => @@ -2914,7 +2982,7 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = let val k' = case ko of NONE => kunif loc - | SOME k => elabKind k + | SOME k => elabKind env k val (c', ck, gs') = elabCon (env, denv) c val (env', n) = E.pushCNamed env x k' (SOME c') @@ -3047,6 +3115,7 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = case e of L.EAbs _ => true | L.ECAbs (_, _, _, e) => allowable e + | L.EKAbs (_, e) => allowable e | L.EDisjoint (_, _, e) => allowable e | _ => false @@ -3264,7 +3333,7 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = | L.DClass (x, k, c) => let - val k = elabKind k + val k = elabKind env k val k' = (L'.KArrow (k, (L'.KType, loc)), loc) val (c', ck, gs') = elabCon (env, denv) c val (env, n) = E.pushCNamed env x k' (SOME c') diff --git a/src/expl.sml b/src/expl.sml index c0d291b5..0101dd1f 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -93,7 +93,6 @@ datatype exp' = | EConcat of exp * con * exp * con | ECut of exp * con * { field : con, rest : con } | ECutMulti of exp * con * { rest : con } - | EFold of kind | ECase of exp * (pat * exp) list * { disc : con, result : con } diff --git a/src/expl_print.sml b/src/expl_print.sml index 7044bfa2..313fef5c 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -351,7 +351,6 @@ fun p_exp' par env (e, loc) = string "---", space, p_con' true env c]) - | EFold _ => string "fold" | EWrite e => box [string "write(", p_exp env e, diff --git a/src/expl_util.sml b/src/expl_util.sml index a2b5f2f6..febf3586 100644 --- a/src/expl_util.sml +++ b/src/expl_util.sml @@ -311,10 +311,6 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = S.map2 (mfc ctx rest, fn rest' => (ECutMulti (e', c', {rest = rest'}), loc)))) - | EFold k => - S.map2 (mfk k, - fn k' => - (EFold k', loc)) | EWrite e => S.map2 (mfe ctx e, diff --git a/src/explify.sml b/src/explify.sml index a4eab0ba..5bce9268 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -107,8 +107,6 @@ fun explifyExp (e, loc) = {field = explifyCon field, rest = explifyCon rest}), loc) | L.ECutMulti (e1, c, {rest}) => (L'.ECutMulti (explifyExp e1, explifyCon c, {rest = explifyCon rest}), loc) - | L.EFold k => (L'.EFold (explifyKind k), loc) - | L.ECase (e, pes, {disc, result}) => (L'.ECase (explifyExp e, map (fn (p, e) => (explifyPat p, explifyExp e)) pes, diff --git a/src/monoize.sml b/src/monoize.sml index 898d3e61..96ef2c6a 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2183,7 +2183,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EConcat _ => poly () | L.ECut _ => poly () | L.ECutMulti _ => poly () - | L.EFold _ => poly () | L.ECase (e, pes, {disc, result}) => let diff --git a/src/reduce.sml b/src/reduce.sml index 949b2a6d..77718b66 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -214,20 +214,6 @@ fun conAndExp (namedC, namedE) = in case #1 e of ECAbs (_, _, b) => exp (KnownC c :: deKnown env) b - - | EApp ((EApp ((ECApp ((EFold _, _), _), _), f), _), i) => - (case #1 c of - CRecord (_, []) => i - | CRecord (k, (nm, v) :: rest) => - let - val rest = (CRecord (k, rest), loc) - in - exp (deKnown env) - (EApp ((ECApp ((ECApp ((ECApp (f, nm), loc), v), loc), rest), loc), - (ECApp (e, rest), loc)), loc) - end - | _ => (ECApp (e, c), loc)) - | _ => (ECApp (e, c), loc) end @@ -334,8 +320,6 @@ fun conAndExp (namedC, namedE) = | _ => default () end - | EFold _ => all - | ECase (e, pes, {disc, result}) => let fun patBinds (p, _) = diff --git a/src/reduce_local.sml b/src/reduce_local.sml index 7de7d799..25b1023a 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -107,8 +107,6 @@ fun exp env (all as (e, loc)) = | ECut (e, c, others) => (ECut (exp env e, c, others), loc) | ECutMulti (e, c, others) => (ECutMulti (exp env e, c, others), loc) - | EFold _ => all - | ECase (e, pes, others) => let fun patBinds (p, _) = diff --git a/src/source.sml b/src/source.sml index d70d0f5d..e9531245 100644 --- a/src/source.sml +++ b/src/source.sml @@ -38,6 +38,9 @@ datatype kind' = | KTuple of kind list | KWild + | KFun of string * kind + | KVar of string + withtype kind = kind' located datatype explicitness = @@ -56,6 +59,9 @@ datatype con' = | CAbs of string * kind option * con | CDisjoint of con * con * con + | CKAbs of string * con + | TKFun of string * con + | CName of string | CRecord of (con * con) list @@ -119,12 +125,13 @@ datatype exp' = | ECAbs of explicitness * string * kind * exp | EDisjoint of con * con * exp + | EKAbs of string * exp + | ERecord of (con * exp) list | EField of exp * con | EConcat of exp * exp | ECut of exp * con | ECutMulti of exp * con - | EFold | EWild diff --git a/src/source_print.sml b/src/source_print.sml index 148157c2..f2420947 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -50,6 +50,13 @@ fun p_kind' par (k, _) = p_list_sep (box [space, string "*", space]) p_kind ks, string ")"] + | KVar x => string x + | KFun (x, k) => box [string x, + space, + string "-->", + space, + p_kind k] + and p_kind k = p_kind' false k fun p_explicitness e = @@ -156,6 +163,17 @@ fun p_con' par (c, _) = | CProj (c, n) => box [p_con c, string ".", string (Int.toString n)] + + | CKAbs (x, c) => box [string x, + space, + string "==>", + space, + p_con c] + | TKFun (x, c) => box [string x, + space, + string "-->", + space, + p_con c] and p_con c = p_con' false c @@ -273,8 +291,6 @@ fun p_exp' par (e, _) = string "---", space, p_con' true c]) - | EFold => string "fold" - | ECase (e, pes) => parenIf par (box [string "case", space, p_exp e, @@ -300,6 +316,12 @@ fun p_exp' par (e, _) = newline, string "end"] + | EKAbs (x, e) => box [string x, + space, + string "-->", + space, + p_exp e] + and p_exp e = p_exp' false e and p_edecl (d, _) = diff --git a/src/termination.sml b/src/termination.sml index e89f329e..5dd95f46 100644 --- a/src/termination.sml +++ b/src/termination.sml @@ -190,6 +190,7 @@ fun declOk' env (d, loc) = in (p, ps, calls) end + | EKApp (e, _) => combiner calls e | _ => let val (p, calls) = exp parent (penv, calls) e @@ -239,6 +240,13 @@ fun declOk' env (d, loc) = in (Rabble, calls) end + | EKApp _ => apps () + | EKAbs (_, e) => + let + val (_, calls) = exp parent (penv, calls) e + in + (Rabble, calls) + end | ERecord xets => let @@ -278,7 +286,6 @@ fun declOk' env (d, loc) = in (Rabble, calls) end - | EFold _ => (Rabble, calls) | ECase (e, pes, _) => let diff --git a/src/unnest.sml b/src/unnest.sml index 8e363301..1d0c2388 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -37,7 +37,7 @@ structure U = ElabUtil structure IS = IntBinarySet fun liftExpInExp by = - U.Exp.mapB {kind = fn k => k, + U.Exp.mapB {kind = fn _ => fn k => k, con = fn _ => fn c => c, exp = fn bound => fn e => case e of @@ -51,7 +51,7 @@ fun liftExpInExp by = | (bound, _) => bound} val subExpInExp = - U.Exp.mapB {kind = fn k => k, + U.Exp.mapB {kind = fn _ => fn k => k, con = fn _ => fn c => c, exp = fn (xn, rep) => fn e => case e of @@ -65,7 +65,7 @@ val subExpInExp = | ((xn, rep), U.Exp.RelC _) => (xn, E.liftConInExp 0 rep) | (ctx, _) => ctx} -val fvsCon = U.Con.foldB {kind = fn (_, st) => st, +val fvsCon = U.Con.foldB {kind = fn (_, _, st) => st, con = fn (cb, c, cvs) => case c of CRel n => @@ -76,11 +76,11 @@ val fvsCon = U.Con.foldB {kind = fn (_, st) => st, | _ => cvs, bind = fn (cb, b) => case b of - U.Con.Rel _ => cb + 1 + U.Con.RelC _ => cb + 1 | _ => cb} 0 IS.empty -fun fvsExp nr = U.Exp.foldB {kind = fn (_, st) => st, +fun fvsExp nr = U.Exp.foldB {kind = fn (_, _, st) => st, con = fn ((cb, eb), c, st as (cvs, evs)) => case c of CRel n => @@ -124,7 +124,7 @@ fun positionOf (x : int) ls = end fun squishCon cfv = - U.Con.mapB {kind = fn k => k, + U.Con.mapB {kind = fn _ => fn k => k, con = fn cb => fn c => case c of CRel n => @@ -135,12 +135,12 @@ fun squishCon cfv = | _ => c, bind = fn (cb, b) => case b of - U.Con.Rel _ => cb + 1 + U.Con.RelC _ => cb + 1 | _ => cb} 0 fun squishExp (nr, cfv, efv) = - U.Exp.mapB {kind = fn k => k, + U.Exp.mapB {kind = fn _ => fn k => k, con = fn (cb, eb) => fn c => case c of CRel n => @@ -169,7 +169,7 @@ type state = { decls : (string * int * con * exp) list } -fun kind (k, st) = (k, st) +fun kind (_, k, st) = (k, st) fun exp ((ks, ts), e as old, st : state) = case e of diff --git a/src/urweb.grm b/src/urweb.grm index d425caec..b6e4ce72 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -184,10 +184,10 @@ fun tagIn bt = | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR | PLUS | MINUS | DIVIDE | DOTDOTDOT | MOD | AT - | CON | LTYPE | VAL | REC | AND | FUN | MAP | FOLD | UNIT | KUNIT | CLASS + | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS | DATATYPE | OF | TYPE | NAME - | ARROW | LARROW | DARROW | STAR | SEMI + | ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE | LET | IN | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL @@ -327,6 +327,8 @@ fun tagIn bt = %name Urweb +%right KARROW +%nonassoc DKARROW %right SEMI %nonassoc LARROW %nonassoc IF THEN ELSE @@ -575,6 +577,8 @@ kind : TYPE (KType, s (TYPEleft, TYPEright)) | KUNIT (KUnit, s (KUNITleft, KUNITright)) | UNDERUNDER (KWild, s (UNDERUNDERleft, UNDERUNDERright)) | LPAREN ktuple RPAREN (KTuple ktuple, s (LPARENleft, RPARENright)) + | CSYMBOL (KVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) + | CSYMBOL KARROW kind (KFun (CSYMBOL, kind), s (CSYMBOLleft, kindright)) ktuple : kind STAR kind ([kind1, kind2]) | kind STAR ktuple (kind :: ktuple) @@ -585,10 +589,12 @@ capps : cterm (cterm) cexp : capps (capps) | cexp ARROW cexp (TFun (cexp1, cexp2), s (cexp1left, cexp2right)) | SYMBOL kcolon kind ARROW cexp (TCFun (kcolon, SYMBOL, kind, cexp), s (SYMBOLleft, cexpright)) + | CSYMBOL KARROW cexp (TKFun (CSYMBOL, cexp), s (CSYMBOLleft, cexpright)) | cexp PLUSPLUS cexp (CConcat (cexp1, cexp2), s (cexp1left, cexp1right)) | FN cargs DARROW cexp (#1 (cargs (cexp, (KWild, s (FNleft, cexpright))))) + | CSYMBOL DKARROW cexp (CKAbs (CSYMBOL, cexp), s (CSYMBOLleft, cexpright)) | LPAREN cexp RPAREN DCOLON kind (CAnnot (cexp, kind), s (LPARENleft, kindright)) @@ -651,7 +657,7 @@ cargp : SYMBOL (fn (c, k) => ((CAbs (SYMBOL, SOME kind, c), loc), (KArrow (kind, k), loc)) end) - | LBRACK cexp TWIDDLE cexp RBRACK (fn (c, k) => + | LBRACK cexp TWIDDLE cexp RBRACK (fn (c, k) => let val loc = s (LBRACKleft, RBRACKright) in @@ -716,6 +722,7 @@ eexp : eapps (eapps) in #1 (eargs (eexp, (CWild (KType, loc), loc))) end) + | CSYMBOL DKARROW eexp (EKAbs (CSYMBOL, eexp), s (CSYMBOLleft, eexpright)) | eexp COLON cexp (EAnnot (eexp, cexp), s (eexpleft, cexpright)) | eexp MINUSMINUS cexp (ECut (eexp, cexp), s (eexpleft, cexpright)) | eexp MINUSMINUSMINUS cexp (ECutMulti (eexp, cexp), s (eexpleft, cexpright)) @@ -851,6 +858,13 @@ eargp : SYMBOL (fn (e, t) => ((EDisjoint (cexp1, cexp2, e), loc), (CDisjoint (cexp1, cexp2, t), loc)) end) + | CSYMBOL (fn (e, t) => + let + val loc = s (CSYMBOLleft, CSYMBOLright) + in + ((EKAbs (CSYMBOL, e), loc), + (TKFun (CSYMBOL, t), loc)) + end) eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) | LPAREN etuple RPAREN (let @@ -895,7 +909,6 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) (EField (e, ident), loc)) (EVar (#1 path, #2 path, DontInfer), s (pathleft, pathright)) idents end) - | FOLD (EFold, s (FOLDleft, FOLDright)) | XML_BEGIN xml XML_END (let val loc = s (XML_BEGINleft, XML_ENDright) @@ -1070,7 +1083,7 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer) () else ErrorMsg.errorAt pos "Begin and end tags don't match."; - (EFold, pos)) + (EWild, pos)) end) | LBRACE eexp RBRACE (eexp) | LBRACE LBRACK eexp RBRACK RBRACE (let diff --git a/src/urweb.lex b/src/urweb.lex index 29e07194..bb57f03d 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -247,7 +247,9 @@ notags = [^<{\n]+; "}" => (exitBrace (); Tokens.RBRACE (pos yypos, pos yypos + size yytext)); + "-->" => (Tokens.KARROW (pos yypos, pos yypos + size yytext)); "->" => (Tokens.ARROW (pos yypos, pos yypos + size yytext)); + "==>" => (Tokens.DKARROW (pos yypos, pos yypos + size yytext)); "=>" => (Tokens.DARROW (pos yypos, pos yypos + size yytext)); "++" => (Tokens.PLUSPLUS (pos yypos, pos yypos + size yytext)); "--" => (Tokens.MINUSMINUS (pos yypos, pos yypos + size yytext)); @@ -291,7 +293,6 @@ notags = [^<{\n]+; "fun" => (Tokens.FUN (pos yypos, pos yypos + size yytext)); "fn" => (Tokens.FN (pos yypos, pos yypos + size yytext)); "map" => (Tokens.MAP (pos yypos, pos yypos + size yytext)); - "fold" => (Tokens.FOLD (pos yypos, pos yypos + size yytext)); "case" => (Tokens.CASE (pos yypos, pos yypos + size yytext)); "if" => (Tokens.IF (pos yypos, pos yypos + size yytext)); "then" => (Tokens.THEN (pos yypos, pos yypos + size yytext)); -- cgit v1.2.3 From 732a583f6601793bb0ba9246649e45de89fe1067 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 26 Mar 2009 14:37:31 -0400 Subject: Type class reductions, but no inclusions yet --- src/elab_env.sml | 322 ++++++++++++++++++++++++++++++++++++--------------- src/elaborate.sml | 11 +- src/urweb.grm | 6 +- src/urweb.lex | 1 + tests/type_class.ur | 58 +++++++--- tests/type_class.urp | 3 + 6 files changed, 288 insertions(+), 113 deletions(-) create mode 100644 tests/type_class.urp (limited to 'src/elab_env.sml') diff --git a/src/elab_env.sml b/src/elab_env.sml index 083e7d55..1768ce7d 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008-2009, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -197,12 +197,16 @@ fun ck2s ck = | CkProj (m, ms, x) => "Proj(" ^ Int.toString m ^ "," ^ String.concatWith "," ms ^ "," ^ x ^ ")" | CkApp (ck1, ck2) => "App(" ^ ck2s ck1 ^ ", " ^ ck2s ck2 ^ ")" +type class_key_n = class_key * int + +fun ckn2s (ck, n) = ck2s ck ^ "[" ^ Int.toString n ^ "]" + fun cp2s (cn, ck) = "(" ^ cn2s cn ^ "," ^ ck2s ck ^ ")" structure KK = struct -type ord_key = class_key +type ord_key = class_key_n open Order -fun compare x = +fun compare' x = case x of (CkNamed n1, CkNamed n2) => Int.compare (n1, n2) | (CkNamed _, _) => LESS @@ -220,24 +224,22 @@ fun compare x = | (_, CkProj _) => GREATER | (CkApp (f1, x1), CkApp (f2, x2)) => - join (compare (f1, f2), - fn () => compare (x1, x2)) + join (compare' (f1, f2), + fn () => compare' (x1, x2)) +fun compare ((k1, n1), (k2, n2)) = + join (Int.compare (n1, n2), + fn () => compare' (k1, k2)) end structure KM = BinaryMapFn(KK) -type class = { - ground : exp KM.map -} - -val empty_class = { - ground = KM.empty -} +type class = ((class_name * class_key) list * exp) KM.map +val empty_class = KM.empty fun printClasses cs = (print "Classes:\n"; - CM.appi (fn (cn, {ground = km}) => + CM.appi (fn (cn, km) => (print (cn2s cn ^ ":"); - KM.appi (fn (ck, _) => print (" " ^ ck2s ck)) km; + KM.appi (fn (ck, _) => print (" " ^ ckn2s ck)) km; print "\n")) cs) type env = { @@ -298,12 +300,14 @@ val empty = { str = IM.empty } -fun liftClassKey ck = +fun liftClassKey' ck = case ck of CkNamed _ => ck | CkRel n => CkRel (n + 1) | CkProj _ => ck - | CkApp (ck1, ck2) => CkApp (liftClassKey ck1, liftClassKey ck2) + | CkApp (ck1, ck2) => CkApp (liftClassKey' ck1, liftClassKey' ck2) + +fun liftClassKey (ck, n) = (liftClassKey' ck, n) fun pushKRel (env : env) x = let @@ -356,11 +360,10 @@ fun pushCRel (env : env) x k = datatypes = #datatypes env, constructors = #constructors env, - classes = CM.map (fn class => { - ground = KM.foldli (fn (ck, e, km) => - KM.insert (km, liftClassKey ck, e)) - KM.empty (#ground class) - }) + classes = CM.map (fn class => + KM.foldli (fn (ck, e, km) => + KM.insert (km, liftClassKey ck, e)) + KM.empty class) (#classes env), renameE = SM.map (fn Rel' (n, c) => Rel' (n, lift c) @@ -479,7 +482,7 @@ fun pushClass (env : env) n = datatypes = #datatypes env, constructors = #constructors env, - classes = CM.insert (#classes env, ClNamed n, {ground = KM.empty}), + classes = CM.insert (#classes env, ClNamed n, KM.empty), renameE = #renameE env, relE = #relE env, @@ -518,6 +521,18 @@ fun class_key_in (c, _) = | _ => NONE) | _ => NONE +fun class_key_out loc = + let + fun cko k = + case k of + CkRel n => (CRel n, loc) + | CkNamed n => (CNamed n, loc) + | CkProj x => (CModProj x, loc) + | CkApp (k1, k2) => (CApp (cko k1, cko k2), loc) + in + cko + end + fun class_pair_in (c, _) = case c of CApp (f, x) => @@ -527,25 +542,80 @@ fun class_pair_in (c, _) = | CUnif (_, _, _, ref (SOME c)) => class_pair_in c | _ => NONE +fun sub_class_key (n, c) = + let + fun csk k = + case k of + CkRel n' => if n' = n then + c + else + k + | CkNamed _ => k + | CkProj _ => k + | CkApp (k1, k2) => CkApp (csk k1, csk k2) + in + csk + end + fun resolveClass (env : env) c = - case class_pair_in c of - SOME (f, x) => - (case CM.find (#classes env, f) of - NONE => NONE - | SOME class => - case KM.find (#ground class, x) of - NONE => NONE - | SOME e => SOME e) - | _ => NONE + let + fun doPair (f, x) = + case CM.find (#classes env, f) of + NONE => NONE + | SOME class => + let + val loc = #2 c + + fun tryRules (k, args) = + let + val len = length args + in + case KM.find (class, (k, length args)) of + SOME (cs, e) => + let + val es = map (fn (cn, ck) => + let + val ck = ListUtil.foldli (fn (i, arg, ck) => + sub_class_key (len - i - 1, + arg) + ck) + ck args + in + doPair (cn, ck) + end) cs + in + if List.exists (not o Option.isSome) es then + NONE + else + let + val e = foldl (fn (arg, e) => (ECApp (e, class_key_out loc arg), loc)) + e args + val e = foldr (fn (pf, e) => (EApp (e, pf), loc)) + e (List.mapPartial (fn x => x) es) + in + SOME e + end + end + | NONE => + case k of + CkApp (k1, k2) => tryRules (k1, k2 :: args) + | _ => NONE + end + in + tryRules (x, []) + end + in + case class_pair_in c of + SOME p => doPair p + | _ => NONE + end fun pushERel (env : env) x t = let val renameE = SM.map (fn Rel' (n, t) => Rel' (n+1, t) | x => x) (#renameE env) - val classes = CM.map (fn class => { - ground = KM.map liftExp (#ground class) - }) (#classes env) + val classes = CM.map (KM.map (fn (ps, e) => (ps, liftExp e))) (#classes env) val classes = case class_pair_in t of NONE => classes | SOME (f, x) => @@ -553,9 +623,7 @@ fun pushERel (env : env) x t = NONE => classes | SOME class => let - val class = { - ground = KM.insert (#ground class, x, (ERel 0, #2 t)) - } + val class = KM.insert (class, (x, 0), ([], (ERel 0, #2 t))) in CM.insert (classes, f, class) end @@ -587,19 +655,55 @@ fun lookupERel (env : env) n = (List.nth (#relE env, n)) handle Subscript => raise UnboundRel n +fun rule_in c = + let + fun quantifiers (c, nvars) = + case #1 c of + TCFun (_, _, _, c) => quantifiers (c, nvars + 1) + | _ => + let + fun clauses (c, hyps) = + case #1 c of + TFun (hyp, c) => + (case class_pair_in hyp of + NONE => NONE + | SOME p => clauses (c, p :: hyps)) + | _ => + case class_pair_in c of + NONE => NONE + | SOME (cn, ck) => + let + fun dearg (ck, i) = + if i >= nvars then + SOME (nvars, hyps, (cn, ck)) + else case ck of + CkApp (ck, CkRel i') => + if i' = i then + dearg (ck, i + 1) + else + NONE + | _ => NONE + in + dearg (ck, 0) + end + in + clauses (c, []) + end + in + quantifiers (c, 0) + end + fun pushENamedAs (env : env) x n t = let val classes = #classes env - val classes = case class_pair_in t of + val classes = case rule_in t of NONE => classes - | SOME (f, x) => + | SOME (nvars, hyps, (f, x)) => case CM.find (classes, f) of NONE => classes | SOME class => let - val class = { - ground = KM.insert (#ground class, x, (ENamed n, #2 t)) - } + val class = KM.insert (class, (x, nvars), (hyps, (ENamed n, #2 t))) in CM.insert (classes, f, class) end @@ -784,6 +888,31 @@ fun sgnS_con' (arg as (m1, ms', (sgns, strs, cons))) c = (sgnS_con' arg (#1 c2), #2 c2)) | _ => c +fun sgnS_class_name (arg as (m1, ms', (sgns, strs, cons))) nm = + case nm of + ClProj (m1, ms, x) => + (case IM.find (strs, m1) of + NONE => nm + | SOME m1x => ClProj (m1, ms' @ m1x :: ms, x)) + | ClNamed n => + (case IM.find (cons, n) of + NONE => nm + | SOME nx => ClProj (m1, ms', nx)) + +fun sgnS_class_key (arg as (m1, ms', (sgns, strs, cons))) k = + case k of + CkProj (m1, ms, x) => + (case IM.find (strs, m1) of + NONE => k + | SOME m1x => CkProj (m1, ms' @ m1x :: ms, x)) + | CkNamed n => + (case IM.find (cons, n) of + NONE => k + | SOME nx => CkProj (m1, ms', nx)) + | CkApp (k1, k2) => CkApp (sgnS_class_key arg k1, + sgnS_class_key arg k2) + | _ => k + fun sgnS_sgn (str, (sgns, strs, cons)) sgn = case sgn of SgnProj (m1, ms, x) => @@ -891,38 +1020,45 @@ fun enrichClasses env classes (m1, ms) sgn = | SgiClassAbs (x, n, _) => found (x, n) | SgiClass (x, n, _, _) => found (x, n) - | SgiVal (x, n, (CApp (f, a), _)) => - let - fun unravel c = - case #1 c of - CUnif (_, _, _, ref (SOME c)) => unravel c - | CNamed n => - ((case lookupCNamed env n of - (_, _, SOME c) => unravel c - | _ => c) - handle UnboundNamed _ => c) - | _ => c - - val nc = - case f of - (CNamed f, _) => IM.find (newClasses, f) - | _ => NONE - in - case nc of - NONE => - (case (class_name_in (unravel f), - class_key_in (sgnS_con' (m1, ms, fmap) (#1 a), #2 a)) of - (SOME cn, SOME ck) => + | SgiVal (x, n, c) => + (case rule_in c of + NONE => default () + | SOME (nvars, hyps, (cn, a)) => + let + val globalize = sgnS_class_key (m1, ms, fmap) + val ck = globalize a + val hyps = map (fn (n, k) => (sgnS_class_name (m1, ms, fmap) n, + globalize k)) hyps + + fun unravel c = + case c of + ClNamed n => + ((case lookupCNamed env n of + (_, _, SOME c') => + (case class_name_in c' of + NONE => c + | SOME k => unravel k) + | _ => c) + handle UnboundNamed _ => c) + | _ => c + + val nc = + case cn of + ClNamed f => IM.find (newClasses, f) + | _ => NONE + in + case nc of + NONE => let val classes = case CM.find (classes, cn) of NONE => classes | SOME class => let - val class = { - ground = KM.insert (#ground class, ck, - (EModProj (m1, ms, x), #2 sgn)) - } + val class = KM.insert (class, (ck, nvars), + (hyps, + (EModProj (m1, ms, x), + #2 sgn))) in CM.insert (classes, cn, class) end @@ -932,34 +1068,28 @@ fun enrichClasses env classes (m1, ms) sgn = fmap, env) end - | _ => default ()) - | SOME fx => - case class_key_in (sgnS_con' (m1, ms, fmap) (#1 a), #2 a) of - NONE => default () - | SOME ck => - let - val cn = ClProj (m1, ms, fx) - - val classes = - case CM.find (classes, cn) of - NONE => classes - | SOME class => - let - val class = { - ground = KM.insert (#ground class, ck, - (EModProj (m1, ms, x), #2 sgn)) - } - in - CM.insert (classes, cn, class) - end - in - (classes, - newClasses, - fmap, - env) - end - end - | SgiVal _ => default () + | SOME fx => + let + val cn = ClProj (m1, ms, fx) + + val classes = + case CM.find (classes, cn) of + NONE => classes + | SOME class => + let + val class = KM.insert (class, (ck, nvars), + (hyps, + (EModProj (m1, ms, x), #2 sgn))) + in + CM.insert (classes, cn, class) + end + in + (classes, + newClasses, + fmap, + env) + end + end) | _ => default () end) (classes, IM.empty, (IM.empty, IM.empty, IM.empty), env) sgis diff --git a/src/elaborate.sml b/src/elaborate.sml index daa6e004..81af6a79 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1480,6 +1480,14 @@ fun normClassConstraint env (c, loc) = in (L'.CApp (f, x), loc) end + | L'.TFun (c1, c2) => + let + val c1 = normClassConstraint env c1 + val c2 = normClassConstraint env c2 + in + (L'.TFun (c1, c2), loc) + end + | L'.TCFun (expl, x, k, c1) => (L'.TCFun (expl, x, k, normClassConstraint env c1), loc) | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint env c | _ => (c, loc) @@ -3045,7 +3053,7 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs)) = val () = checkCon env e' et c' - val c = normClassConstraint env c' + val c' = normClassConstraint env c' val (env', n) = E.pushENamed env x c' in (*prefaces "DVal" [("x", Print.PD.string x), @@ -3068,6 +3076,7 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs)) = val (c', _, gs1) = case co of NONE => (cunif (loc, ktype), ktype, []) | SOME c => elabCon (env, denv) c + val c' = normClassConstraint env c' in ((x, c', e), enD gs1 @ gs) end) gs vis diff --git a/src/urweb.grm b/src/urweb.grm index 1cd3e5c9..e6f0ddeb 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -188,7 +188,7 @@ fun tagIn bt = | DATATYPE | OF | TYPE | NAME | ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW | BANG - | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE + | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE | CARET | LET | IN | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE @@ -341,7 +341,7 @@ fun tagIn bt = %right CAND %nonassoc EQ NE LT LE GT GE IS %right ARROW -%right PLUSPLUS MINUSMINUS MINUSMINUSMINUS +%right CARET PLUSPLUS MINUSMINUS MINUSMINUSMINUS %left PLUS MINUS %left STAR DIVIDE MOD %left NOT @@ -753,6 +753,8 @@ eexp : eapps (eapps) | eexp PLUSPLUS eexp (EConcat (eexp1, eexp2), s (eexp1left, eexp2right)) + | eexp CARET eexp (native_op ("strcat", eexp1, eexp2, s (eexp1left, eexp2right))) + bind : SYMBOL LARROW eapps (SYMBOL, NONE, eapps) | UNIT LARROW eapps (let val loc = s (UNITleft, eappsright) diff --git a/src/urweb.lex b/src/urweb.lex index cbbf2a52..4a7ceaeb 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -254,6 +254,7 @@ notags = [^<{\n]+; "++" => (Tokens.PLUSPLUS (pos yypos, pos yypos + size yytext)); "--" => (Tokens.MINUSMINUS (pos yypos, pos yypos + size yytext)); "---" => (Tokens.MINUSMINUSMINUS (pos yypos, pos yypos + size yytext)); + "^" => (Tokens.CARET (pos yypos, pos yypos + size yytext)); "=" => (Tokens.EQ (pos yypos, pos yypos + size yytext)); "<>" => (Tokens.NE (pos yypos, pos yypos + size yytext)); diff --git a/tests/type_class.ur b/tests/type_class.ur index 0acca7cd..42cbe82f 100644 --- a/tests/type_class.ur +++ b/tests/type_class.ur @@ -1,18 +1,48 @@ -class default t = t +datatype pair a b = Pair of a * b -val string_default : default string = "Hi" -val int_default : default int = 0 +structure M : sig + class default + val get : t ::: Type -> default t -> t -val default : t :: Type -> default t -> t = - fn t :: Type => fn d : default t => d -val hi = default [string] _ -val zero = default [int] _ + val string_default : default string + val int_default : default int -val frob : t :: Type -> default t -> t = - fn t :: Type => fn _ : default t => default [t] _ -val hi_again = frob [string] _ -val zero_again = frob [int] _ + val option_default : t ::: Type -> default t -> default (option t) + val pair_default : a ::: Type -> b ::: Type -> default a -> default b -> default (pair a b) +end = struct + class default t = t + fun get (t ::: Type) (x : t) = x -val main : unit -> page = fn () => - {cdata hi_again} - + val string_default = "Hi" + val int_default = 0 + + fun option_default (t ::: Type) (x : t) = Some x + fun pair_default (a ::: Type) (b ::: Type) (x : a) (y : b) = Pair (x, y) +end + +open M + +fun default (t ::: Type) (_ : default t) : t = get +val hi : string = default +val zero : int = default +val some_zero : option int = default +val hi_zero : pair string int = default + +fun frob (t ::: Type) (_ : default t) : t = default +val hi_again : string = frob +val zero_again : int = frob + +fun show_option (t ::: Type) (_ : show t) : show (option t) = + mkShow (fn x => + case x of + None => "None" + | Some y => show y) + +fun show_pair (a ::: Type) (b ::: Type) (_ : show a) (_ : show b) : show (pair a b) = + mkShow (fn x => + case x of + Pair (y, z) => "(" ^ show y ^ "," ^ show z ^ ")") + +fun main () : transaction page = return + {[hi_again]}, {[zero_again]}, {[some_zero]}, {[hi_zero]} + diff --git a/tests/type_class.urp b/tests/type_class.urp new file mode 100644 index 00000000..1a346623 --- /dev/null +++ b/tests/type_class.urp @@ -0,0 +1,3 @@ +debug + +type_class -- cgit v1.2.3 From 17164a11b7905fda774935471215a36f3f83a820 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 26 Mar 2009 15:13:36 -0400 Subject: Type class inclusions --- src/elab_env.sml | 130 +++++++++++++++++++++++++++++++++++++++------------- tests/type_class.ur | 13 +++++- 2 files changed, 111 insertions(+), 32 deletions(-) (limited to 'src/elab_env.sml') diff --git a/src/elab_env.sml b/src/elab_env.sml index 1768ce7d..9f64a8c2 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -233,11 +233,13 @@ end structure KM = BinaryMapFn(KK) -type class = ((class_name * class_key) list * exp) KM.map -val empty_class = KM.empty +type class = {ground : ((class_name * class_key) list * exp) KM.map, + inclusions : exp CM.map} +val empty_class = {ground = KM.empty, + inclusions = CM.empty} fun printClasses cs = (print "Classes:\n"; - CM.appi (fn (cn, km) => + CM.appi (fn (cn, {ground = km, ...} : class) => (print (cn2s cn ^ ":"); KM.appi (fn (ck, _) => print (" " ^ ckn2s ck)) km; print "\n")) cs) @@ -361,9 +363,10 @@ fun pushCRel (env : env) x k = constructors = #constructors env, classes = CM.map (fn class => - KM.foldli (fn (ck, e, km) => - KM.insert (km, liftClassKey ck, e)) - KM.empty class) + {ground = KM.foldli (fn (ck, e, km) => + KM.insert (km, liftClassKey ck, e)) + KM.empty (#ground class), + inclusions = #inclusions class}) (#classes env), renameE = SM.map (fn Rel' (n, c) => Rel' (n, lift c) @@ -482,7 +485,7 @@ fun pushClass (env : env) n = datatypes = #datatypes env, constructors = #constructors env, - classes = CM.insert (#classes env, ClNamed n, KM.empty), + classes = CM.insert (#classes env, ClNamed n, empty_class), renameE = #renameE env, relE = #relE env, @@ -565,12 +568,36 @@ fun resolveClass (env : env) c = | SOME class => let val loc = #2 c - + + fun tryIncs () = + let + fun tryIncs fs = + case fs of + [] => NONE + | (f', e') :: fs => + case doPair (f', x) of + NONE => tryIncs fs + | SOME e => + let + val e' = (ECApp (e', class_key_out loc x), loc) + val e' = (EApp (e', e), loc) + in + SOME e' + end + in + tryIncs (CM.listItemsi (#inclusions class)) + end + fun tryRules (k, args) = let val len = length args + + fun tryNext () = + case k of + CkApp (k1, k2) => tryRules (k1, k2 :: args) + | _ => tryIncs () in - case KM.find (class, (k, length args)) of + case KM.find (#ground class, (k, length args)) of SOME (cs, e) => let val es = map (fn (cn, ck) => @@ -585,7 +612,7 @@ fun resolveClass (env : env) c = end) cs in if List.exists (not o Option.isSome) es then - NONE + tryNext () else let val e = foldl (fn (arg, e) => (ECApp (e, class_key_out loc arg), loc)) @@ -596,10 +623,7 @@ fun resolveClass (env : env) c = SOME e end end - | NONE => - case k of - CkApp (k1, k2) => tryRules (k1, k2 :: args) - | _ => NONE + | NONE => tryNext () end in tryRules (x, []) @@ -615,7 +639,9 @@ fun pushERel (env : env) x t = val renameE = SM.map (fn Rel' (n, t) => Rel' (n+1, t) | x => x) (#renameE env) - val classes = CM.map (KM.map (fn (ps, e) => (ps, liftExp e))) (#classes env) + val classes = CM.map (fn class => + {ground = KM.map (fn (ps, e) => (ps, liftExp e)) (#ground class), + inclusions = #inclusions class}) (#classes env) val classes = case class_pair_in t of NONE => classes | SOME (f, x) => @@ -623,7 +649,8 @@ fun pushERel (env : env) x t = NONE => classes | SOME class => let - val class = KM.insert (class, (x, 0), ([], (ERel 0, #2 t))) + val class = {ground = KM.insert (#ground class, (x, 0), ([], (ERel 0, #2 t))), + inclusions = #inclusions class} in CM.insert (classes, f, class) end @@ -655,6 +682,10 @@ fun lookupERel (env : env) n = (List.nth (#relE env, n)) handle Subscript => raise UnboundRel n +datatype rule = + Normal of int * (class_name * class_key) list * class_key + | Inclusion of class_name + fun rule_in c = let fun quantifiers (c, nvars) = @@ -675,7 +706,7 @@ fun rule_in c = let fun dearg (ck, i) = if i >= nvars then - SOME (nvars, hyps, (cn, ck)) + SOME (cn, Normal (nvars, hyps, ck)) else case ck of CkApp (ck, CkRel i') => if i' = i then @@ -690,7 +721,13 @@ fun rule_in c = clauses (c, []) end in - quantifiers (c, 0) + case #1 c of + TCFun (_, _, _, (TFun ((CApp (f1, (CRel 0, _)), _), + (CApp (f2, (CRel 0, _)), _)), _)) => + (case (class_name_in f1, class_name_in f2) of + (SOME f1, SOME f2) => SOME (f2, Inclusion f1) + | _ => NONE) + | _ => quantifiers (c, 0) end fun pushENamedAs (env : env) x n t = @@ -698,12 +735,21 @@ fun pushENamedAs (env : env) x n t = val classes = #classes env val classes = case rule_in t of NONE => classes - | SOME (nvars, hyps, (f, x)) => + | SOME (f, rule) => case CM.find (classes, f) of NONE => classes | SOME class => let - val class = KM.insert (class, (x, nvars), (hyps, (ENamed n, #2 t))) + val e = (ENamed n, #2 t) + + val class = + case rule of + Normal (nvars, hyps, x) => + {ground = KM.insert (#ground class, (x, nvars), (hyps, e)), + inclusions = #inclusions class} + | Inclusion f' => + {ground = #ground class, + inclusions = CM.insert (#inclusions class, f', e)} in CM.insert (classes, f, class) end @@ -1023,12 +1069,10 @@ fun enrichClasses env classes (m1, ms) sgn = | SgiVal (x, n, c) => (case rule_in c of NONE => default () - | SOME (nvars, hyps, (cn, a)) => + | SOME (cn, rule) => let + val globalizeN = sgnS_class_name (m1, ms, fmap) val globalize = sgnS_class_key (m1, ms, fmap) - val ck = globalize a - val hyps = map (fn (n, k) => (sgnS_class_name (m1, ms, fmap) n, - globalize k)) hyps fun unravel c = case c of @@ -1055,10 +1099,22 @@ fun enrichClasses env classes (m1, ms) sgn = NONE => classes | SOME class => let - val class = KM.insert (class, (ck, nvars), - (hyps, - (EModProj (m1, ms, x), - #2 sgn))) + val e = (EModProj (m1, ms, x), + #2 sgn) + + val class = + case rule of + Normal (nvars, hyps, a) => + {ground = + KM.insert (#ground class, (globalize a, nvars), + (map (fn (n, k) => + (globalizeN n, + globalize k)) hyps, e)), + inclusions = #inclusions class} + | Inclusion f' => + {ground = #ground class, + inclusions = CM.insert (#inclusions class, + globalizeN f', e)} in CM.insert (classes, cn, class) end @@ -1077,9 +1133,21 @@ fun enrichClasses env classes (m1, ms) sgn = NONE => classes | SOME class => let - val class = KM.insert (class, (ck, nvars), - (hyps, - (EModProj (m1, ms, x), #2 sgn))) + val e = (EModProj (m1, ms, x), #2 sgn) + + val class = + case rule of + Normal (nvars, hyps, a) => + {ground = + KM.insert (#ground class, (globalize a, nvars), + (map (fn (n, k) => + (globalizeN n, + globalize k)) hyps, e)), + inclusions = #inclusions class} + | Inclusion f' => + {ground = #ground class, + inclusions = CM.insert (#inclusions class, + globalizeN f', e)} in CM.insert (classes, cn, class) end diff --git a/tests/type_class.ur b/tests/type_class.ur index 42cbe82f..a41ccdc8 100644 --- a/tests/type_class.ur +++ b/tests/type_class.ur @@ -9,6 +9,11 @@ structure M : sig val option_default : t ::: Type -> default t -> default (option t) val pair_default : a ::: Type -> b ::: Type -> default a -> default b -> default (pair a b) + + class awesome + val awesome_default : t ::: Type -> awesome t -> default t + + val float_awesome : awesome float end = struct class default t = t fun get (t ::: Type) (x : t) = x @@ -18,6 +23,11 @@ end = struct fun option_default (t ::: Type) (x : t) = Some x fun pair_default (a ::: Type) (b ::: Type) (x : a) (y : b) = Pair (x, y) + + class awesome t = t + fun awesome_default (t ::: Type) (x : t) = x + + val float_awesome = 1.23 end open M @@ -27,6 +37,7 @@ val hi : string = default val zero : int = default val some_zero : option int = default val hi_zero : pair string int = default +val ott : float = default fun frob (t ::: Type) (_ : default t) : t = default val hi_again : string = frob @@ -44,5 +55,5 @@ fun show_pair (a ::: Type) (b ::: Type) (_ : show a) (_ : show b) : show (pair a Pair (y, z) => "(" ^ show y ^ "," ^ show z ^ ")") fun main () : transaction page = return - {[hi_again]}, {[zero_again]}, {[some_zero]}, {[hi_zero]} + {[hi_again]}, {[zero_again]}, {[some_zero]}, {[hi_zero]}, {[ott]} -- cgit v1.2.3 From 024acc734f4a323883adb5e9a68f5f4f753e60cc Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 26 Mar 2009 15:54:04 -0400 Subject: Enforce termination of type class instances --- src/elab_env.sml | 39 ++++++++++++++++++++++++++++++++++----- tests/type_class.ur | 14 ++++++++++++++ 2 files changed, 48 insertions(+), 5 deletions(-) (limited to 'src/elab_env.sml') diff --git a/src/elab_env.sml b/src/elab_env.sml index 9f64a8c2..de33ec56 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -182,6 +182,7 @@ fun compare x = fn () => String.compare (x1, x2))) end +structure CS = BinarySetFn(CK) structure CM = BinaryMapFn(CK) datatype class_key = @@ -697,8 +698,8 @@ fun rule_in c = case #1 c of TFun (hyp, c) => (case class_pair_in hyp of - NONE => NONE - | SOME p => clauses (c, p :: hyps)) + SOME (p as (_, CkRel _)) => clauses (c, p :: hyps) + | _ => NONE) | _ => case class_pair_in c of NONE => NONE @@ -730,6 +731,32 @@ fun rule_in c = | _ => quantifiers (c, 0) end +fun inclusion (classes : class CM.map, init, inclusions, f, e : exp) = + let + fun search (f, fs) = + if f = init then + NONE + else if CS.member (fs, f) then + SOME fs + else + let + val fs = CS.add (fs, f) + in + case CM.find (classes, f) of + NONE => SOME fs + | SOME {inclusions = fs', ...} => + CM.foldli (fn (f', _, fs) => + case fs of + NONE => NONE + | SOME fs => search (f', fs)) (SOME fs) fs' + end + in + case search (f, CS.empty) of + SOME _ => CM.insert (inclusions, f, e) + | NONE => (ErrorMsg.errorAt (#2 e) "Type class inclusion would create a cycle"; + inclusions) + end + fun pushENamedAs (env : env) x n t = let val classes = #classes env @@ -749,7 +776,7 @@ fun pushENamedAs (env : env) x n t = inclusions = #inclusions class} | Inclusion f' => {ground = #ground class, - inclusions = CM.insert (#inclusions class, f', e)} + inclusions = inclusion (classes, f, #inclusions class, f', e)} in CM.insert (classes, f, class) end @@ -1113,7 +1140,8 @@ fun enrichClasses env classes (m1, ms) sgn = inclusions = #inclusions class} | Inclusion f' => {ground = #ground class, - inclusions = CM.insert (#inclusions class, + inclusions = inclusion (classes, cn, + #inclusions class, globalizeN f', e)} in CM.insert (classes, cn, class) @@ -1146,7 +1174,8 @@ fun enrichClasses env classes (m1, ms) sgn = inclusions = #inclusions class} | Inclusion f' => {ground = #ground class, - inclusions = CM.insert (#inclusions class, + inclusions = inclusion (classes, cn, + #inclusions class, globalizeN f', e)} in CM.insert (classes, cn, class) diff --git a/tests/type_class.ur b/tests/type_class.ur index a41ccdc8..8c77bbad 100644 --- a/tests/type_class.ur +++ b/tests/type_class.ur @@ -10,10 +10,16 @@ structure M : sig val option_default : t ::: Type -> default t -> default (option t) val pair_default : a ::: Type -> b ::: Type -> default a -> default b -> default (pair a b) + (*val uh_oh : t ::: Type -> default t -> default t*) + class awesome val awesome_default : t ::: Type -> awesome t -> default t val float_awesome : awesome float + + val oh_my : t ::: Type -> awesome (option t) -> awesome (option t) + + val awesome : t ::: Type -> awesome t -> t end = struct class default t = t fun get (t ::: Type) (x : t) = x @@ -24,10 +30,16 @@ end = struct fun option_default (t ::: Type) (x : t) = Some x fun pair_default (a ::: Type) (b ::: Type) (x : a) (y : b) = Pair (x, y) + (*fun uh_oh (t ::: Type) (x : t) = x*) + class awesome t = t fun awesome_default (t ::: Type) (x : t) = x val float_awesome = 1.23 + + fun oh_my (t ::: Type) (x : option t) = x + + fun awesome (t ::: Type) (x : t) = x end open M @@ -49,6 +61,8 @@ fun show_option (t ::: Type) (_ : show t) : show (option t) = None => "None" | Some y => show y) +(*val x : option float = awesome*) + fun show_pair (a ::: Type) (b ::: Type) (_ : show a) (_ : show b) : show (pair a b) = mkShow (fn x => case x of -- cgit v1.2.3 From 92924ca980aa1ae361b242bbed9c6b5d4dacada3 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 29 Mar 2009 14:13:50 -0400 Subject: Expunging nullable fields --- src/c/urweb.c | 21 +++++++++++----- src/cjr_print.sml | 2 ++ src/elab_env.sml | 72 ++++++++++++++++++++++++++++++++++++------------------ src/monoize.sml | 57 +++++++++++++++++++++++++----------------- tests/whiteout.ur | 6 +++++ tests/whiteout.urp | 6 +++++ 6 files changed, 111 insertions(+), 53 deletions(-) create mode 100644 tests/whiteout.ur create mode 100644 tests/whiteout.urp (limited to 'src/elab_env.sml') diff --git a/src/c/urweb.c b/src/c/urweb.c index 8ad50711..e74474f7 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1869,8 +1869,13 @@ void uw_expunger(uw_context ctx, uw_Basis_client cli); static failure_kind uw_expunge(uw_context ctx, uw_Basis_client cli) { int r = setjmp(ctx->jmp_buf); - if (r == 0) + if (r == 0) { + if (uw_db_begin(ctx)) + uw_error(ctx, FATAL, "Error running SQL BEGIN"); uw_expunger(ctx, cli); + if (uw_db_commit(ctx)) + uw_error(ctx, FATAL, "Error running SQL COMMIT"); + } return r; } @@ -1892,16 +1897,20 @@ void uw_prune_clients(uw_context ctx) { prev->next = next; else clients_used = next; + uw_reset(ctx); while (fk == UNLIMITED_RETRY) { - uw_reset(ctx); fk = uw_expunge(ctx, c->id); - if (fk == SUCCESS) { - free_client(c); - break; + if (fk == UNLIMITED_RETRY) { + uw_db_rollback(ctx); + printf("Unlimited retry during expunge: %s\n", uw_error_message(ctx)); } } - if (fk != SUCCESS) + if (fk == SUCCESS) + free_client(c); + else { + uw_db_rollback(ctx); printf("Expunge blocked by error: %s\n", uw_error_message(ctx)); + } } else prev = c; diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 21e53a51..3b1705af 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2760,6 +2760,8 @@ fun p_file env (ds, ps) = string "int uw_db_commit(uw_context ctx) { return 0; };", newline, string "int uw_db_rollback(uw_context ctx) { return 0; };", + newline, + string "void uw_expunger(uw_context ctx, uw_Basis_client cli) { };", newline]] end diff --git a/src/elab_env.sml b/src/elab_env.sml index de33ec56..370e504f 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -190,6 +190,7 @@ datatype class_key = | CkRel of int | CkProj of int * string list * string | CkApp of class_key * class_key + | CkOther of con fun ck2s ck = case ck of @@ -197,6 +198,7 @@ fun ck2s ck = | CkRel n => "Rel(" ^ Int.toString n ^ ")" | CkProj (m, ms, x) => "Proj(" ^ Int.toString m ^ "," ^ String.concatWith "," ms ^ "," ^ x ^ ")" | CkApp (ck1, ck2) => "App(" ^ ck2s ck1 ^ ", " ^ ck2s ck2 ^ ")" + | CkOther _ => "Other" type class_key_n = class_key * int @@ -227,6 +229,10 @@ fun compare' x = | (CkApp (f1, x1), CkApp (f2, x2)) => join (compare' (f1, f2), fn () => compare' (x1, x2)) + | (CkApp _, _) => LESS + | (_, CkApp _) => GREATER + + | (CkOther _, CkOther _) => EQUAL fun compare ((k1, n1), (k2, n2)) = join (Int.compare (n1, n2), fn () => compare' (k1, k2)) @@ -309,6 +315,7 @@ fun liftClassKey' ck = | CkRel n => CkRel (n + 1) | CkProj _ => ck | CkApp (ck1, ck2) => CkApp (liftClassKey' ck1, liftClassKey' ck2) + | CkOther c => CkOther (lift c) fun liftClassKey (ck, n) = (liftClassKey' ck, n) @@ -513,17 +520,14 @@ fun isClass (env : env) c = find (class_name_in c) end -fun class_key_in (c, _) = +fun class_key_in (all as (c, _)) = case c of - CRel n => SOME (CkRel n) - | CNamed n => SOME (CkNamed n) - | CModProj x => SOME (CkProj x) + CRel n => CkRel n + | CNamed n => CkNamed n + | CModProj x => CkProj x | CUnif (_, _, _, ref (SOME c)) => class_key_in c - | CApp (c1, c2) => - (case (class_key_in c1, class_key_in c2) of - (SOME k1, SOME k2) => SOME (CkApp (k1, k2)) - | _ => NONE) - | _ => NONE + | CApp (c1, c2) => CkApp (class_key_in c1, class_key_in c2) + | _ => CkOther all fun class_key_out loc = let @@ -533,6 +537,7 @@ fun class_key_out loc = | CkNamed n => (CNamed n, loc) | CkProj x => (CModProj x, loc) | CkApp (k1, k2) => (CApp (cko k1, cko k2), loc) + | CkOther c => c in cko end @@ -540,8 +545,8 @@ fun class_key_out loc = fun class_pair_in (c, _) = case c of CApp (f, x) => - (case (class_name_in f, class_key_in x) of - (SOME f, SOME x) => SOME (f, x) + (case class_name_in f of + SOME f => SOME (f, class_key_in x) | _ => NONE) | CUnif (_, _, _, ref (SOME c)) => class_pair_in c | _ => NONE @@ -550,13 +555,17 @@ fun sub_class_key (n, c) = let fun csk k = case k of - CkRel n' => if n' = n then - c - else - k - | CkNamed _ => k - | CkProj _ => k - | CkApp (k1, k2) => CkApp (csk k1, csk k2) + CkRel n' => SOME (if n' = n then + c + else + k) + | CkNamed _ => SOME k + | CkProj _ => SOME k + | CkApp (k1, k2) => + (case (csk k1, csk k2) of + (SOME k1, SOME k2) => SOME (CkApp (k1, k2)) + | _ => NONE) + | CkOther _ => NONE in csk end @@ -604,12 +613,17 @@ fun resolveClass (env : env) c = val es = map (fn (cn, ck) => let val ck = ListUtil.foldli (fn (i, arg, ck) => - sub_class_key (len - i - 1, - arg) - ck) - ck args + case ck of + NONE => NONE + | SOME ck => + sub_class_key (len - i - 1, + arg) + ck) + (SOME ck) args in - doPair (cn, ck) + case ck of + NONE => NONE + | SOME ck => doPair (cn, ck) end) cs in if List.exists (not o Option.isSome) es then @@ -687,6 +701,12 @@ datatype rule = Normal of int * (class_name * class_key) list * class_key | Inclusion of class_name +fun containsOther k = + case k of + CkOther _ => true + | CkApp (k1, k2) => containsOther k1 orelse containsOther k2 + | _ => false + fun rule_in c = let fun quantifiers (c, nvars) = @@ -707,7 +727,11 @@ fun rule_in c = let fun dearg (ck, i) = if i >= nvars then - SOME (cn, Normal (nvars, hyps, ck)) + if containsOther ck + orelse List.exists (fn (_, k) => containsOther k) hyps then + NONE + else + SOME (cn, Normal (nvars, hyps, ck)) else case ck of CkApp (ck, CkRel i') => if i' = i then diff --git a/src/monoize.sml b/src/monoize.sml index 50678be4..361986d2 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2500,33 +2500,44 @@ fun monoize env file = | _ => st) | _ => st) ([], []) xts + fun cond (x, v) = + (L'.EStrcat ((L'.EPrim (Prim.String ("uw_" ^ x + ^ (case v of + Client => "" + | Channel => " >> 32") + ^ " = ")), loc), + target), loc) + + val e = + foldl (fn ((x, v), e) => + (L'.ESeq ( + (L'.EDml (L'.EStrcat ( + (L'.EPrim (Prim.String ("UPDATE uw_" + ^ tab + ^ " SET uw_" + ^ x + ^ " = NULL WHERE ")), loc), + cond (x, v)), loc), loc), + e), loc)) + e nullable + val e = case notNullable of [] => e | eb :: ebs => - let - fun cond (x, v) = - (L'.EStrcat ((L'.EPrim (Prim.String ("uw_" ^ x - ^ (case v of - Client => "" - | Channel => " >> 32") - ^ " = ")), loc), - target), loc) - in - (L'.ESeq ( - (L'.EDml (foldl - (fn (eb, s) => - (L'.EStrcat (s, - (L'.EStrcat ((L'.EPrim (Prim.String " AND "), - loc), - cond eb), loc)), loc)) - (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM uw_" - ^ tab - ^ " WHERE ")), loc), - cond eb), loc) - ebs), loc), - e), loc) - end + (L'.ESeq ( + (L'.EDml (foldl + (fn (eb, s) => + (L'.EStrcat (s, + (L'.EStrcat ((L'.EPrim (Prim.String " AND "), + loc), + cond eb), loc)), loc)) + (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM uw_" + ^ tab + ^ " WHERE ")), loc), + cond eb), loc) + ebs), loc), + e), loc) in e end diff --git a/tests/whiteout.ur b/tests/whiteout.ur new file mode 100644 index 00000000..5fb9d57b --- /dev/null +++ b/tests/whiteout.ur @@ -0,0 +1,6 @@ +table t : { Chan : option (channel unit) } + +fun main () : transaction page = + ch <- channel; + dml (INSERT INTO t (Chan) VALUES ({[Some ch]})); + return Did it. diff --git a/tests/whiteout.urp b/tests/whiteout.urp new file mode 100644 index 00000000..a8c3d0af --- /dev/null +++ b/tests/whiteout.urp @@ -0,0 +1,6 @@ +debug +database dbname=whiteout +sql whiteout.sql +timeout 5 + +whiteout -- cgit v1.2.3 From e52d6c0bc6e2e911515d21c6acc1e311a8e30db9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 7 Apr 2009 12:24:31 -0400 Subject: UNIQUE constraints --- lib/ur/basis.urs | 14 ++++++++++++++ src/cjr.sml | 2 +- src/cjr_print.sml | 43 +++++++++++++++++++++++++++++++++-------- src/cjrize.sml | 14 ++++++++++++-- src/core.sml | 2 +- src/core_env.sml | 2 +- src/core_print.sml | 26 ++++++++++++++----------- src/core_util.sml | 12 +++++++----- src/corify.sml | 6 +++--- src/elab.sml | 2 +- src/elab_env.sml | 2 +- src/elab_print.sml | 18 +++++++++++------- src/elab_util.sml | 12 +++++++----- src/elaborate.sml | 23 ++++++++++++++-------- src/expl.sml | 2 +- src/expl_env.sml | 2 +- src/expl_print.sml | 18 +++++++++++------- src/explify.sml | 2 +- src/mono.sml | 2 +- src/mono_print.sml | 28 +++++++++++++++------------ src/mono_util.sml | 5 ++++- src/monoize.sml | 44 ++++++++++++++++++++++++++++++++++++------ src/pathcheck.sml | 34 ++++++++++++++++++++++++++------- src/reduce.sml | 3 ++- src/shake.sml | 47 +++++++++++++++++++++++++++++---------------- src/source.sml | 2 +- src/source_print.sml | 18 +++++++++++------- src/urweb.grm | 54 +++++++++++++++++++++++++++++++++++++++++++++++++++- src/urweb.lex | 3 +++ tests/cst.ur | 13 +++++++++++++ tests/cst.urp | 5 +++++ 31 files changed, 343 insertions(+), 117 deletions(-) create mode 100644 tests/cst.ur create mode 100644 tests/cst.urp (limited to 'src/elab_env.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 1cbca61d..dcf2a13d 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -124,6 +124,20 @@ val self : transaction client con sql_table :: {Type} -> Type +(*** Constraints *) + +con sql_constraints :: {Unit} -> {Type} -> Type +con sql_constraint :: {Type} -> Type + +val no_constraint : fs ::: {Type} -> sql_constraints [] fs +val one_constraint : fs ::: {Type} -> name :: Name -> sql_constraint fs -> sql_constraints [name] fs +val join_constraints : names1 ::: {Unit} -> names2 ::: {Unit} -> fs ::: {Type} -> [names1 ~ names2] + => sql_constraints names1 fs -> sql_constraints names2 fs + -> sql_constraints (names1 ++ names2) fs + +val unique : rest ::: {Type} -> unique :: {Type} -> [unique ~ rest] => sql_constraint (unique ++ rest) + + (*** Queries *) con sql_query :: {{Type}} -> {Type} -> Type diff --git a/src/cjr.sml b/src/cjr.sml index 78c2e63b..7f8b2434 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -104,7 +104,7 @@ datatype decl' = | DFun of string * int * (string * typ) list * typ * exp | DFunRec of (string * int * (string * typ) list * typ * exp) list - | DTable of string * (string * typ) list + | DTable of string * (string * typ) list * (string * string) list | DSequence of string | DDatabase of {name : string, expunge : int, initialize : int} | DPreparedStatements of (string * int) list diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 54ec3cbf..9fc1511f 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1435,7 +1435,7 @@ fun p_exp' par env (e, loc) = val wontLeakAnything = notLeaky env false state in box [if wontLeakAnything then - string "uw_begin_region(ctx), " + string "(uw_begin_region(ctx), " else box [], string "({", @@ -1585,7 +1585,11 @@ fun p_exp' par env (e, loc) = box [], string "acc;", newline, - string "})"] + string "})", + if wontLeakAnything then + string ")" + else + box []] end | EDml {dml, prepared} => @@ -1937,10 +1941,19 @@ fun p_decl env (dAll as (d, _) : decl) = p_list_sep newline (p_fun env) vis, newline] end - | DTable (x, _) => box [string "/* SQL table ", - string x, - string " */", - newline] + | DTable (x, _, csts) => box [string "/* SQL table ", + string x, + space, + string "constraints", + space, + p_list (fn (x, v) => box [string x, + space, + string ":", + space, + string v]) csts, + space, + string " */", + newline] | DSequence x => box [string "/* SQL sequence ", string x, string " */", @@ -2454,7 +2467,7 @@ fun p_file env (ds, ps) = val pds' = map p_page ps - val tables = List.mapPartial (fn (DTable (s, xts), _) => SOME (s, xts) + val tables = List.mapPartial (fn (DTable (s, xts, _), _) => SOME (s, xts) | _ => NONE) ds val sequences = List.mapPartial (fn (DSequence s, _) => SOME s | _ => NONE) ds @@ -2798,7 +2811,7 @@ fun p_sql env (ds, _) = (fn (dAll as (d, _), env) => let val pp = case d of - DTable (s, xts) => + DTable (s, xts, csts) => box [string "CREATE TABLE ", string s, string "(", @@ -2807,6 +2820,20 @@ fun p_sql env (ds, _) = string (CharVector.map Char.toLower x), space, p_sqltype env (t, ErrorMsg.dummySpan)]) xts, + case csts of + [] => box [] + | _ => box [string ","], + cut, + p_list_sep (box [string ",", newline]) + (fn (x, c) => + box [string "CONSTRAINT", + space, + string s, + string "_", + string x, + space, + string c]) csts, + newline, string ");", newline, newline] diff --git a/src/cjrize.sml b/src/cjrize.sml index 5e4b647a..839c0c57 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -524,7 +524,7 @@ fun cifyDecl ((d, loc), sm) = (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndPullAndPush), sm) end - | L.DTable (s, xts) => + | L.DTable (s, xts, e) => let val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) => let @@ -532,8 +532,18 @@ fun cifyDecl ((d, loc), sm) = in ((x, t), sm) end) sm xts + + fun flatten e = + case #1 e of + L.ERecord [] => [] + | L.ERecord [(x, (L.EPrim (Prim.String v), _), _)] => [(x, v)] + | L.EStrcat (e1, e2) => flatten e1 @ flatten e2 + | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined"; + Print.prefaces "Undetermined constraint" + [("e", MonoPrint.p_exp MonoEnv.empty e)]; + []) in - (SOME (L'.DTable (s, xts), loc), NONE, sm) + (SOME (L'.DTable (s, xts, flatten e), loc), NONE, sm) end | L.DSequence s => (SOME (L'.DSequence s, loc), NONE, sm) diff --git a/src/core.sml b/src/core.sml index b384c576..74ef138c 100644 --- a/src/core.sml +++ b/src/core.sml @@ -130,7 +130,7 @@ datatype decl' = | DVal of string * int * con * exp * string | DValRec of (string * int * con * exp * string) list | DExport of export_kind * int - | DTable of string * int * con * string + | DTable of string * int * con * string * exp | DSequence of string * int * string | DDatabase of string | DCookie of string * int * con * string diff --git a/src/core_env.sml b/src/core_env.sml index dd77e3fb..d1e956d8 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -313,7 +313,7 @@ fun declBinds env (d, loc) = | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis | DExport _ => env - | DTable (x, n, c, s) => + | DTable (x, n, c, s, _) => let val t = (CApp ((CFfi ("Basis", "sql_table"), loc), c), loc) in diff --git a/src/core_print.sml b/src/core_print.sml index cc6e5428..d68ba288 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -546,17 +546,21 @@ fun p_decl env (dAll as (d, _) : decl) = space, (p_con env (#2 (E.lookupENamed env n)) handle E.UnboundNamed _ => string "UNBOUND")] - | DTable (x, n, c, s) => box [string "table", - space, - p_named x n, - space, - string "as", - space, - string s, - space, - string ":", - space, - p_con env c] + | DTable (x, n, c, s, e) => box [string "table", + space, + p_named x n, + space, + string "as", + space, + string s, + space, + string ":", + space, + p_con env c, + space, + string "constraints", + space, + p_exp env e] | DSequence (x, n, s) => box [string "sequence", space, p_named x n, diff --git a/src/core_util.sml b/src/core_util.sml index b1d07b79..b342f2f7 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -933,10 +933,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = (DValRec vis', loc)) end | DExport _ => S.return2 dAll - | DTable (x, n, c, s) => - S.map2 (mfc ctx c, + | DTable (x, n, c, s, e) => + S.bind2 (mfc ctx c, fn c' => - (DTable (x, n, c', s), loc)) + S.map2 (mfe ctx e, + fn e' => + (DTable (x, n, c', s, e'), loc))) | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll | DCookie (x, n, c, s) => @@ -1058,7 +1060,7 @@ fun mapfoldB (all as {bind, ...}) = foldl (fn ((x, n, t, e, s), ctx) => bind (ctx, NamedE (x, n, t, NONE, s))) ctx vis | DExport _ => ctx - | DTable (x, n, c, s) => + | DTable (x, n, c, s, _) => let val t = (CApp ((CFfi ("Basis", "sql_table"), #2 d'), c), #2 d') in @@ -1134,7 +1136,7 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DVal (_, n, _, _, _) => Int.max (n, count) | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis | DExport _ => count - | DTable (_, n, _, _) => Int.max (n, count) + | DTable (_, n, _, _, _) => Int.max (n, count) | DSequence (_, n, _) => Int.max (n, count) | DDatabase _ => count | DCookie (_, n, _, _) => Int.max (n, count)) 0 diff --git a/src/corify.sml b/src/corify.sml index 9ca6c915..fc8bb1de 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -976,12 +976,12 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = end | _ => raise Fail "Non-const signature for 'export'") - | L.DTable (_, x, n, c) => + | L.DTable (_, x, n, c, e) => let val (st, n) = St.bindVal st x n val s = relify (doRestify (mods, x)) in - ([(L'.DTable (x, n, corifyCon st c, s), loc)], st) + ([(L'.DTable (x, n, corifyCon st c, s, corifyExp st e), loc)], st) end | L.DSequence (_, x, n) => let @@ -1052,7 +1052,7 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DStr (_, n', _, str) => Int.max (n, Int.max (n', maxNameStr str)) | L.DFfiStr (_, n', _) => Int.max (n, n') | L.DExport _ => n - | L.DTable (_, _, n', _) => Int.max (n, n') + | L.DTable (_, _, n', _, _) => Int.max (n, n') | L.DSequence (_, _, n') => Int.max (n, n') | L.DDatabase _ => n | L.DCookie (_, _, n', _) => Int.max (n, n')) diff --git a/src/elab.sml b/src/elab.sml index 3fed1918..dd2952d2 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -166,7 +166,7 @@ datatype decl' = | DFfiStr of string * int * sgn | DConstraint of con * con | DExport of int * sgn * str - | DTable of int * string * int * con + | DTable of int * string * int * con * exp | DSequence of int * string * int | DClass of string * int * kind * con | DDatabase of string diff --git a/src/elab_env.sml b/src/elab_env.sml index 370e504f..7adc8dd9 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1532,7 +1532,7 @@ fun declBinds env (d, loc) = | DFfiStr (x, n, sgn) => pushStrNamedAs env x n sgn | DConstraint _ => env | DExport _ => env - | DTable (tn, x, n, c) => + | DTable (tn, x, n, c, _) => let val t = (CApp ((CModProj (tn, [], "sql_table"), loc), c), loc) in diff --git a/src/elab_print.sml b/src/elab_print.sml index 64d8cfab..f98592cc 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -740,13 +740,17 @@ fun p_decl env (dAll as (d, _) : decl) = string ":", space, p_sgn env sgn] - | DTable (_, x, n, c) => box [string "table", - space, - p_named x n, - space, - string ":", - space, - p_con env c] + | DTable (_, x, n, c, e) => box [string "table", + space, + p_named x n, + space, + string ":", + space, + p_con env c, + space, + string "constraints", + space, + p_exp env e] | DSequence (_, x, n) => box [string "sequence", space, p_named x n] diff --git a/src/elab_util.sml b/src/elab_util.sml index e2dd0ce6..6700686d 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -766,7 +766,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f bind (ctx, Str (x, sgn)) | DConstraint _ => ctx | DExport _ => ctx - | DTable (tn, x, n, c) => + | DTable (tn, x, n, c, _) => bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "sql_table"), loc), c), loc))) | DSequence (tn, x, n) => @@ -864,10 +864,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f fn str' => (DExport (en, sgn', str'), loc))) - | DTable (tn, x, n, c) => - S.map2 (mfc ctx c, + | DTable (tn, x, n, c, e) => + S.bind2 (mfc ctx c, fn c' => - (DTable (tn, x, n, c'), loc)) + S.map2 (mfe ctx e, + fn e' => + (DTable (tn, x, n, c', e'), loc))) | DSequence _ => S.return2 dAll | DClass (x, n, k, c) => @@ -1018,7 +1020,7 @@ and maxNameDecl (d, _) = | DConstraint _ => 0 | DClass (_, n, _, _) => n | DExport _ => 0 - | DTable (n1, _, n2, _) => Int.max (n1, n2) + | DTable (n1, _, n2, _, _) => Int.max (n1, n2) | DSequence (n1, _, n2) => Int.max (n1, n2) | DDatabase _ => 0 | DCookie (n1, _, n2, _) => Int.max (n1, n2) diff --git a/src/elaborate.sml b/src/elaborate.sml index 81af6a79..0beab9e7 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1126,11 +1126,11 @@ else (e, t, []) | t => (e, t, []) - in - case infer of - L.DontInfer => (e, t, []) - | _ => unravel (t, e) - end + in + case infer of + L.DontInfer => (e, t, []) + | _ => unravel (t, e) + end fun elabPat (pAll as (p, loc), (env, bound)) = let @@ -2319,7 +2319,7 @@ fun sgiOfDecl (d, loc) = | L'.DFfiStr (x, n, sgn) => [(L'.SgiStr (x, n, sgn), loc)] | L'.DConstraint cs => [(L'.SgiConstraint cs, loc)] | L'.DExport _ => [] - | L'.DTable (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (tableOf (), c), loc)), loc)] + | L'.DTable (tn, x, n, c, _) => [(L'.SgiVal (x, n, (L'.CApp (tableOf (), c), loc)), loc)] | L'.DSequence (tn, x, n) => [(L'.SgiVal (x, n, sequenceOf ()), loc)] | L'.DClass (x, n, k, c) => [(L'.SgiClass (x, n, k, c), loc)] | L'.DDatabase _ => [] @@ -3265,13 +3265,20 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs)) = ([(L'.DExport (E.newNamed (), sgn, str'), loc)], (env, denv, gs' @ gs)) end - | L.DTable (x, c) => + | L.DTable (x, c, e) => let val (c', k, gs') = elabCon (env, denv) c val (env, n) = E.pushENamed env x (L'.CApp (tableOf (), c'), loc) + val (e', et, gs'') = elabExp (env, denv) e + + val names = cunif (loc, (L'.KRecord (L'.KUnit, loc), loc)) + val cst = (L'.CModProj (!basis_r, [], "sql_constraints"), loc) + val cst = (L'.CApp (cst, names), loc) + val cst = (L'.CApp (cst, c'), loc) in checkKind env c' k (L'.KRecord (L'.KType, loc), loc); - ([(L'.DTable (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs)) + checkCon env e' et cst; + ([(L'.DTable (!basis_r, x, n, c', e'), loc)], (env, denv, gs'' @ enD gs' @ gs)) end | L.DSequence x => let diff --git a/src/expl.sml b/src/expl.sml index d7138620..a347a8e8 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -141,7 +141,7 @@ datatype decl' = | DStr of string * int * sgn * str | DFfiStr of string * int * sgn | DExport of int * sgn * str - | DTable of int * string * int * con + | DTable of int * string * int * con * exp | DSequence of int * string * int | DDatabase of string | DCookie of int * string * int * con diff --git a/src/expl_env.sml b/src/expl_env.sml index 403a826a..f4e16cb5 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -298,7 +298,7 @@ fun declBinds env (d, loc) = | DStr (x, n, sgn, _) => pushStrNamed env x n sgn | DFfiStr (x, n, sgn) => pushStrNamed env x n sgn | DExport _ => env - | DTable (tn, x, n, c) => + | DTable (tn, x, n, c, _) => let val t = (CApp ((CModProj (tn, [], "sql_table"), loc), c), loc) in diff --git a/src/expl_print.sml b/src/expl_print.sml index e7fb51f6..c7a506b1 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -663,13 +663,17 @@ fun p_decl env (dAll as (d, _) : decl) = string ":", space, p_sgn env sgn] - | DTable (_, x, n, c) => box [string "table", - space, - p_named x n, - space, - string ":", - space, - p_con env c] + | DTable (_, x, n, c, e) => box [string "table", + space, + p_named x n, + space, + string ":", + space, + p_con env c, + space, + string "constraints", + space, + p_exp env e] | DSequence (_, x, n) => box [string "sequence", space, p_named x n] diff --git a/src/explify.sml b/src/explify.sml index f9f58c65..d567bde3 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -178,7 +178,7 @@ fun explifyDecl (d, loc : EM.span) = | L.DFfiStr (x, n, sgn) => SOME (L'.DFfiStr (x, n, explifySgn sgn), loc) | L.DConstraint (c1, c2) => NONE | L.DExport (en, sgn, str) => SOME (L'.DExport (en, explifySgn sgn, explifyStr str), loc) - | L.DTable (nt, x, n, c) => SOME (L'.DTable (nt, x, n, explifyCon c), loc) + | L.DTable (nt, x, n, c, e) => SOME (L'.DTable (nt, x, n, explifyCon c, explifyExp e), loc) | L.DSequence (nt, x, n) => SOME (L'.DSequence (nt, x, n), loc) | L.DClass (x, n, k, c) => SOME (L'.DCon (x, n, (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), explifyCon c), loc) diff --git a/src/mono.sml b/src/mono.sml index 02afb2c0..5a65a9f9 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -121,7 +121,7 @@ datatype decl' = | DValRec of (string * int * typ * exp * string) list | DExport of Core.export_kind * string * int * typ list * typ - | DTable of string * (string * typ) list + | DTable of string * (string * typ) list * exp | DSequence of string | DDatabase of {name : string, expunge : int, initialize : int} diff --git a/src/mono_print.sml b/src/mono_print.sml index a8ece085..935f8368 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -403,18 +403,22 @@ fun p_decl env (dAll as (d, _) : decl) = space, p_typ env t] - | DTable (s, xts) => box [string "(* SQL table ", - string s, - space, - string ":", - space, - p_list (fn (x, t) => box [string x, - space, - string ":", - space, - p_typ env t]) xts, - space, - string "*)"] + | DTable (s, xts, e) => box [string "(* SQL table ", + string s, + space, + string ":", + space, + p_list (fn (x, t) => box [string x, + space, + string ":", + space, + p_typ env t]) xts, + space, + string "constraints", + space, + p_exp env e, + space, + string "*)"] | DSequence s => box [string "(* SQL sequence ", string s, string "*)"] diff --git a/src/mono_util.sml b/src/mono_util.sml index 9455435c..ca5cf5cb 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -465,7 +465,10 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = S.map2 (mft t, fn t' => (DExport (ek, s, n, ts', t'), loc))) - | DTable _ => S.return2 dAll + | DTable (s, xts, e) => + S.map2 (mfe ctx e, + fn e' => + (DTable (s, xts, e'), loc)) | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll | DJavaScript _ => S.return2 dAll diff --git a/src/monoize.sml b/src/monoize.sml index 620e43a5..af414c08 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -149,6 +149,10 @@ fun monoType env = (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraints"), _), _), _), _) => + (L'.TFfi ("Basis", "sql_constraints"), loc) + | L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _) => + (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_subset"), _), _), _), _) => (L'.TRecord [], loc) @@ -1155,6 +1159,32 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end + | L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) => + ((L'.ERecord [], loc), + fm) + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "one_constraint"), _), _), _), (L.CName name, _)) => + ((L'.EAbs ("c", + (L'.TFfi ("Basis", "string"), loc), + (L'.TFfi ("Basis", "sql_constraints"), loc), + (L'.ERecord [(name, (L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))], loc)), loc), + fm) + | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "join_constraints"), _), _), _), _), _), _) => + let + val constraints = (L'.TFfi ("Basis", "sql_constraints"), loc) + in + ((L'.EAbs ("cs1", constraints, (L'.TFun (constraints, constraints), loc), + (L'.EAbs ("cs2", constraints, constraints, + (L'.EStrcat ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + fm) + end + + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "unique"), _), _), _), + (L.CRecord (_, unique), _)) => + ((L'.EPrim (Prim.String ("UNIQUE (" + ^ String.concatWith ", " (map (fn (x, _) => "uw_" ^ monoName env x) unique) + ^ ")")), loc), + fm) + | L.EFfiApp ("Basis", "dml", [e]) => let val (e, fm) = monoExp (env, st, fm) e @@ -2451,19 +2481,21 @@ fun monoDecl (env, fm) (all as (d, loc)) = in SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)]) end - | L.DTable (x, n, (L.CRecord (_, xts), _), s) => + | L.DTable (x, n, (L.CRecord (_, xts), _), s, e) => let val t = (L.CFfi ("Basis", "string"), loc) val t' = (L'.TFfi ("Basis", "string"), loc) val s = "uw_" ^ s - val e = (L'.EPrim (Prim.String s), loc) + val e_name = (L'.EPrim (Prim.String s), loc) val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts + + val (e, fm) = monoExp (env, St.empty, fm) e in SOME (Env.pushENamed env x n t NONE s, fm, - [(L'.DTable (s, xts), loc), - (L'.DVal (x, n, t', e, s), loc)]) + [(L'.DTable (s, xts, e), loc), + (L'.DVal (x, n, t', e_name, s), loc)]) end | L.DTable _ => poly () | L.DSequence (x, n, s) => @@ -2583,7 +2615,7 @@ fun monoize env file = in foldl (fn ((d, _), e) => case d of - L.DTable (_, _, xts, tab) => doTable (tab, #1 xts, e) + L.DTable (_, _, xts, tab, _) => doTable (tab, #1 xts, e) | _ => e) e file end @@ -2628,7 +2660,7 @@ fun monoize env file = in foldl (fn ((d, _), e) => case d of - L.DTable (_, _, xts, tab) => doTable (tab, #1 xts, e) + L.DTable (_, _, xts, tab, _) => doTable (tab, #1 xts, e) | _ => e) e file end diff --git a/src/pathcheck.sml b/src/pathcheck.sml index 036d286f..6771e628 100644 --- a/src/pathcheck.sml +++ b/src/pathcheck.sml @@ -38,6 +38,13 @@ structure SS = BinarySetFn(struct fun checkDecl ((d, loc), (funcs, rels)) = let + fun doFunc s = + (if SS.member (funcs, s) then + E.errorAt loc ("Duplicate function path " ^ s) + else + (); + (SS.add (funcs, s), rels)) + fun doRel s = (if SS.member (rels, s) then E.errorAt loc ("Duplicate table/sequence path " ^ s) @@ -46,14 +53,27 @@ fun checkDecl ((d, loc), (funcs, rels)) = (funcs, SS.add (rels, s))) in case d of - DExport (_, s, _, _, _) => - (if SS.member (funcs, s) then - E.errorAt loc ("Duplicate function path " ^ s) - else - (); - (SS.add (funcs, s), rels)) + DExport (_, s, _, _, _) => doFunc s - | DTable (s, _) => doRel s + | DTable (s, _, e) => + let + fun constraints (e, rels) = + case #1 e of + ERecord [(s', _, _)] => + let + val s' = s ^ "_" ^ s' + in + if SS.member (rels, s') then + E.errorAt loc ("Duplicate constraint path " ^ s') + else + (); + SS.add (rels, s') + end + | EStrcat (e1, e2) => constraints (e2, constraints (e1, rels)) + | _ => rels + in + (funcs, constraints (e, #2 (doRel s))) + end | DSequence s => doRel s | _ => (funcs, rels) diff --git a/src/reduce.sml b/src/reduce.sml index 8664d38d..6754d708 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -461,7 +461,8 @@ fun reduce file = ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC [] t, exp (namedC, namedE) [] e, s)) vis), loc), st) | DExport _ => (d, st) - | DTable (s, n, c, s') => ((DTable (s, n, con namedC [] c, s'), loc), st) + | DTable (s, n, c, s', e) => ((DTable (s, n, con namedC [] c, s', + exp (namedC, namedE) [] e), loc), st) | DSequence _ => (d, st) | DDatabase _ => (d, st) | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st) diff --git a/src/shake.sml b/src/shake.sml index 4df64efa..2f873e94 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -46,11 +46,26 @@ val dummye = (EPrim (Prim.String ""), ErrorMsg.dummySpan) fun shake file = let - val (page_es, table_cs) = + val usedVars = U.Exp.fold {kind = fn (_, st) => st, + con = fn (c, st as (es, cs)) => + case c of + CNamed n => (es, IS.add (cs, n)) + | _ => st, + exp = fn (e, st as (es, cs)) => + case e of + ENamed n => (IS.add (es, n), cs) + | _ => st} + + val (usedE, usedC, table_cs) = List.foldl - (fn ((DExport (_, n), _), (page_es, table_cs)) => (n :: page_es, table_cs) - | ((DTable (_, _, c, _), _), (page_es, table_cs)) => (page_es, c :: table_cs) - | (_, acc) => acc) ([], []) file + (fn ((DExport (_, n), _), (usedE, usedC, table_cs)) => (IS.add (usedE, n), usedE, table_cs) + | ((DTable (_, _, c, _, e), _), (usedE, usedC, table_cs)) => + let + val (usedE, usedC) = usedVars (usedE, usedC) e + in + (usedE, usedC, c :: table_cs) + end + | (_, acc) => acc) (IS.empty, IS.empty, []) file val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef) | ((DDatatype (_, n, _, xncs), _), (cdef, edef)) => @@ -64,7 +79,7 @@ fun shake file = IM.insert (edef, n, (all_ns, t, e))) edef vis) end | ((DExport _, _), acc) => acc - | ((DTable (_, n, c, _), _), (cdef, edef)) => + | ((DTable (_, n, c, _, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DSequence (_, n, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], dummyt, dummye))) @@ -122,17 +137,17 @@ fun shake file = and shakeExp s = U.Exp.fold {kind = kind, con = con, exp = exp} s - val s = {con = IS.empty, exp = IS.addList (IS.empty, page_es)} - - val s = foldl (fn (n, s) => - case IM.find (edef, n) of - NONE => raise Fail "Shake: Couldn't find 'val'" - | SOME (ns, t, e) => - let - val s = shakeExp (shakeCon s t) e - in - foldl (fn (n, s) => exp (ENamed n, s)) s ns - end) s page_es + val s = {con = usedC, exp = usedE} + + val s = IS.foldl (fn (n, s) => + case IM.find (edef, n) of + NONE => raise Fail "Shake: Couldn't find 'val'" + | SOME (ns, t, e) => + let + val s = shakeExp (shakeCon s t) e + in + foldl (fn (n, s) => exp (ENamed n, s)) s ns + end) s usedE val s = foldl (fn (c, s) => shakeCon s c) s table_cs in diff --git a/src/source.sml b/src/source.sml index 9ef14fd9..42927ef3 100644 --- a/src/source.sml +++ b/src/source.sml @@ -160,7 +160,7 @@ datatype decl' = | DConstraint of con * con | DOpenConstraints of string * string list | DExport of str - | DTable of string * con + | DTable of string * con * exp | DSequence of string | DClass of string * kind * con | DDatabase of string diff --git a/src/source_print.sml b/src/source_print.sml index 8d8b28c3..d1c9b6df 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -588,13 +588,17 @@ fun p_decl ((d, _) : decl) = | DExport str => box [string "export", space, p_str str] - | DTable (x, c) => box [string "table", - space, - string x, - space, - string ":", - space, - p_con c] + | DTable (x, c, e) => box [string "table", + space, + string x, + space, + string ":", + space, + p_con c, + space, + string "constraints", + space, + p_exp e] | DSequence x => box [string "sequence", space, string x] diff --git a/src/urweb.grm b/src/urweb.grm index 98ba295a..784c62ee 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -208,6 +208,7 @@ fun tagIn bt = | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS | CURRENT_TIMESTAMP | NE | LT | LE | GT | GE + | CCONSTRAINT | UNIQUE %nonterm file of decl list @@ -222,6 +223,10 @@ fun tagIn bt = | dcons of (string * con option) list | dcon of string * con option + | cst of exp + | csts of exp + | cstopt of exp + | sgn of sgn | sgntm of sgn | sgi of sgn_item @@ -289,6 +294,9 @@ fun tagIn bt = | query1 of exp | tables of (con * exp) list | tname of con + | tnameW of (con * con) + | tnames of con + | tnames' of (con * con) list | table of con * exp | tident of con | fident of con @@ -410,7 +418,7 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let | m :: ms => [(DOpenConstraints (m, ms), s (OPENleft, mpathright))]) | CONSTRAINT cterm TWIDDLE cterm ([(DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))]) | EXPORT spath ([(DExport spath, s (EXPORTleft, spathright))]) - | TABLE SYMBOL COLON cexp ([(DTable (SYMBOL, entable cexp), s (TABLEleft, cexpright))]) + | TABLE SYMBOL COLON cterm cstopt([(DTable (SYMBOL, entable cterm, cstopt), s (TABLEleft, cstoptright))]) | SEQUENCE SYMBOL ([(DSequence SYMBOL, s (SEQUENCEleft, SYMBOLright))]) | CLASS SYMBOL EQ cexp (let val loc = s (CLASSleft, cexpright) @@ -460,6 +468,50 @@ vali : SYMBOL eargl2 copt EQ eexp (let copt : (NONE) | COLON cexp (SOME cexp) +cstopt : (EVar (["Basis"], "no_constraint", Infer), dummy) + | csts (csts) + +csts : CCONSTRAINT tname cst (let + val loc = s (CCONSTRAINTleft, cstright) + + val e = (EVar (["Basis"], "one_constraint", Infer), loc) + val e = (ECApp (e, tname), loc) + in + (EApp (e, cst), loc) + end) + | csts COMMA csts (let + val loc = s (csts1left, csts2right) + + val e = (EVar (["Basis"], "join_constraints", Infer), loc) + val e = (EApp (e, csts1), loc) + in + (EApp (e, csts2), loc) + end) + | LBRACE LBRACE eexp RBRACE RBRACE (eexp) + +cst : UNIQUE tnames (let + val loc = s (UNIQUEleft, tnamesright) + + val e = (EVar (["Basis"], "unique", Infer), loc) + val e = (ECApp (e, tnames), loc) + in + (EDisjointApp e, loc) + end) + | LBRACE eexp RBRACE (eexp) + +tnameW : tname (let + val loc = s (tnameleft, tnameright) + in + (tname, (CWild (KType, loc), loc)) + end) + +tnames : tnameW (CRecord [tnameW], s (tnameWleft, tnameWright)) + | LPAREN tnames' RPAREN (CRecord tnames', s (LPARENleft, RPARENright)) + | LBRACE LBRACE cexp RBRACE RBRACE (cexp) + +tnames': tnameW ([tnameW]) + | tnameW COMMA tnames' (tnameW :: tnames') + valis : vali ([vali]) | vali AND valis (vali :: valis) diff --git a/src/urweb.lex b/src/urweb.lex index 4a7ceaeb..735d230d 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -365,6 +365,9 @@ notags = [^<{\n]+; "NULL" => (Tokens.NULL (pos yypos, pos yypos + size yytext)); "IS" => (Tokens.IS (pos yypos, pos yypos + size yytext)); + "CONSTRAINT"=> (Tokens.CCONSTRAINT (pos yypos, pos yypos + size yytext)); + "UNIQUE" => (Tokens.UNIQUE (pos yypos, pos yypos + size yytext)); + "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext)); {id} => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext)); diff --git a/tests/cst.ur b/tests/cst.ur new file mode 100644 index 00000000..104a9f34 --- /dev/null +++ b/tests/cst.ur @@ -0,0 +1,13 @@ +table t : {A : int, B : int} + CONSTRAINT UniA UNIQUE A, + CONSTRAINT UniB UNIQUE B, + CONSTRAINT UniBoth UNIQUE (A, B), + + CONSTRAINT UniAm UNIQUE {#A}, + CONSTRAINT UniAm2 UNIQUE {{[A = _]}}, + CONSTRAINT UniAm3 {unique [[A = _]] !}, + {{one_constraint [#UniAm4] (unique [[A = _]] !)}} + +fun main () : transaction page = + queryI (SELECT * FROM t) (fn _ => return ()); + return diff --git a/tests/cst.urp b/tests/cst.urp new file mode 100644 index 00000000..b9deaa44 --- /dev/null +++ b/tests/cst.urp @@ -0,0 +1,5 @@ +debug +database dbname=cst +sql cst.sql + +cst -- cgit v1.2.3 From fd1a963a81327f7b6a20a0f2ac131d2525649400 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 7 Apr 2009 14:11:32 -0400 Subject: Track uniqueness sets in table types --- lib/ur/basis.urs | 52 ++++++----- src/core.sml | 2 +- src/core_env.sml | 8 +- src/core_print.sml | 30 +++---- src/core_util.sml | 19 ++-- src/corify.sml | 6 +- src/defunc.sig | 32 ------- src/defunc.sml | 260 ----------------------------------------------------- src/elab.sml | 2 +- src/elab_env.sml | 8 +- src/elab_print.sml | 22 ++--- src/elab_util.sml | 21 +++-- src/elaborate.sml | 132 ++++++++++++++------------- src/expl.sml | 2 +- src/expl_env.sml | 8 +- src/expl_print.sml | 22 ++--- src/explify.sml | 2 +- src/monoize.sml | 50 +++++++---- src/reduce.sml | 5 +- src/shake.sml | 4 +- src/sources | 3 - src/urweb.grm | 19 ++-- tests/cst.ur | 9 +- 23 files changed, 239 insertions(+), 479 deletions(-) delete mode 100644 src/defunc.sig delete mode 100644 src/defunc.sml (limited to 'src/elab_env.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index dcf2a13d..4e926f87 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -122,20 +122,27 @@ val self : transaction client (** SQL *) -con sql_table :: {Type} -> Type +con sql_table :: {Type} -> {{Unit}} -> Type (*** Constraints *) -con sql_constraints :: {Unit} -> {Type} -> Type -con sql_constraint :: {Type} -> Type +con sql_constraints :: {Type} -> {{Unit}} -> Type +(* Arguments: column types, uniqueness implications of constraints *) -val no_constraint : fs ::: {Type} -> sql_constraints [] fs -val one_constraint : fs ::: {Type} -> name :: Name -> sql_constraint fs -> sql_constraints [name] fs -val join_constraints : names1 ::: {Unit} -> names2 ::: {Unit} -> fs ::: {Type} -> [names1 ~ names2] - => sql_constraints names1 fs -> sql_constraints names2 fs - -> sql_constraints (names1 ++ names2) fs +con sql_constraint :: {Type} -> {Unit} -> Type -val unique : rest ::: {Type} -> unique :: {Type} -> [unique ~ rest] => sql_constraint (unique ++ rest) +val no_constraint : fs ::: {Type} -> sql_constraints fs [] +val one_constraint : fs ::: {Type} -> unique ::: {Unit} -> name :: Name + -> sql_constraint fs unique + -> sql_constraints fs [name = unique] +val join_constraints : fs ::: {Type} + -> uniques1 ::: {{Unit}} -> uniques2 ::: {{Unit}} -> [uniques1 ~ uniques2] + => sql_constraints fs uniques1 -> sql_constraints fs uniques2 + -> sql_constraints fs (uniques1 ++ uniques2) + +val unique : rest ::: {Type} -> t ::: Type -> unique1 :: Name -> unique :: {Type} + -> [[unique1] ~ unique] => [[unique1 = t] ++ unique ~ rest] + => sql_constraint ([unique1 = t] ++ unique ++ rest) ([unique1] ++ map (fn _ => ()) unique) (*** Queries *) @@ -151,17 +158,18 @@ val sql_subset : keep_drop :: {({Type} * {Type})} (map (fn fields :: ({Type} * {Type}) => fields.1) keep_drop) val sql_subset_all : tables :: {{Type}} -> sql_subset tables tables -val sql_query1 : tables ::: {{Type}} +val sql_query1 : tables ::: {({Type} * {{Unit}})} -> grouped ::: {{Type}} -> selectedFields ::: {{Type}} -> selectedExps ::: {Type} - -> {From : $(map sql_table tables), - Where : sql_exp tables [] [] bool, - GroupBy : sql_subset tables grouped, - Having : sql_exp grouped tables [] bool, + -> {From : $(map (fn p :: ({Type} * {{Unit}}) => sql_table p.1 p.2) tables), + Where : sql_exp (map (fn p :: ({Type} * {{Unit}}) => p.1) tables) [] [] bool, + GroupBy : sql_subset (map (fn p :: ({Type} * {{Unit}}) => p.1) tables) grouped, + Having : sql_exp grouped (map (fn p :: ({Type} * {{Unit}}) => p.1) tables) [] bool, SelectFields : sql_subset grouped selectedFields, - SelectExps : $(map (sql_exp grouped tables []) selectedExps) } - -> sql_query1 tables selectedFields selectedExps + SelectExps : $(map (sql_exp grouped (map (fn p :: ({Type} * {{Unit}}) => p.1) tables) []) + selectedExps) } + -> sql_query1 (map (fn p :: ({Type} * {{Unit}}) => p.1) tables) selectedFields selectedExps type sql_relop val sql_union : sql_relop @@ -321,20 +329,20 @@ val query : tables ::: {{Type}} -> exps ::: {Type} type dml val dml : dml -> transaction unit -val insert : fields ::: {Type} - -> sql_table fields +val insert : fields ::: {Type} -> uniques ::: {{Unit}} + -> sql_table fields uniques -> $(map (fn t :: Type => sql_exp [] [] [] t) fields) -> dml -val update : unchanged ::: {Type} -> changed :: {Type} -> +val update : unchanged ::: {Type} -> uniques ::: {{Unit}} -> changed :: {Type} -> [changed ~ unchanged] => $(map (fn t :: Type => sql_exp [T = changed ++ unchanged] [] [] t) changed) - -> sql_table (changed ++ unchanged) + -> sql_table (changed ++ unchanged) uniques -> sql_exp [T = changed ++ unchanged] [] [] bool -> dml -val delete : fields ::: {Type} - -> sql_table fields +val delete : fields ::: {Type} -> uniques ::: {{Unit}} + -> sql_table fields uniques -> sql_exp [T = fields] [] [] bool -> dml diff --git a/src/core.sml b/src/core.sml index 74ef138c..687b913f 100644 --- a/src/core.sml +++ b/src/core.sml @@ -130,7 +130,7 @@ datatype decl' = | DVal of string * int * con * exp * string | DValRec of (string * int * con * exp * string) list | DExport of export_kind * int - | DTable of string * int * con * string * exp + | DTable of string * int * con * string * exp * con | DSequence of string * int * string | DDatabase of string | DCookie of string * int * con * string diff --git a/src/core_env.sml b/src/core_env.sml index d1e956d8..4c4cc68f 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -313,11 +313,13 @@ fun declBinds env (d, loc) = | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis | DExport _ => env - | DTable (x, n, c, s, _) => + | DTable (x, n, c, s, _, cc) => let - val t = (CApp ((CFfi ("Basis", "sql_table"), loc), c), loc) + val ct = (CFfi ("Basis", "sql_table"), loc) + val ct = (CApp (ct, c), loc) + val ct = (CApp (ct, cc), loc) in - pushENamed env x n t NONE s + pushENamed env x n ct NONE s end | DSequence (x, n, s) => let diff --git a/src/core_print.sml b/src/core_print.sml index d68ba288..216cc8ac 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -546,21 +546,21 @@ fun p_decl env (dAll as (d, _) : decl) = space, (p_con env (#2 (E.lookupENamed env n)) handle E.UnboundNamed _ => string "UNBOUND")] - | DTable (x, n, c, s, e) => box [string "table", - space, - p_named x n, - space, - string "as", - space, - string s, - space, - string ":", - space, - p_con env c, - space, - string "constraints", - space, - p_exp env e] + | DTable (x, n, c, s, e, _) => box [string "table", + space, + p_named x n, + space, + string "as", + space, + string s, + space, + string ":", + space, + p_con env c, + space, + string "constraints", + space, + p_exp env e] | DSequence (x, n, s) => box [string "sequence", space, p_named x n, diff --git a/src/core_util.sml b/src/core_util.sml index b342f2f7..df8bb271 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -933,12 +933,14 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = (DValRec vis', loc)) end | DExport _ => S.return2 dAll - | DTable (x, n, c, s, e) => + | DTable (x, n, c, s, e, cc) => S.bind2 (mfc ctx c, fn c' => - S.map2 (mfe ctx e, + S.bind2 (mfe ctx e, fn e' => - (DTable (x, n, c', s, e'), loc))) + S.map2 (mfc ctx cc, + fn cc' => + (DTable (x, n, c', s, e', cc'), loc)))) | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll | DCookie (x, n, c, s) => @@ -1060,11 +1062,14 @@ fun mapfoldB (all as {bind, ...}) = foldl (fn ((x, n, t, e, s), ctx) => bind (ctx, NamedE (x, n, t, NONE, s))) ctx vis | DExport _ => ctx - | DTable (x, n, c, s, _) => + | DTable (x, n, c, s, _, cc) => let - val t = (CApp ((CFfi ("Basis", "sql_table"), #2 d'), c), #2 d') + val loc = #2 d' + val ct = (CFfi ("Basis", "sql_table"), loc) + val ct = (CApp (ct, c), loc) + val ct = (CApp (ct, cc), loc) in - bind (ctx, NamedE (x, n, t, NONE, s)) + bind (ctx, NamedE (x, n, ct, NONE, s)) end | DSequence (x, n, s) => let @@ -1136,7 +1141,7 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DVal (_, n, _, _, _) => Int.max (n, count) | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis | DExport _ => count - | DTable (_, n, _, _, _) => Int.max (n, count) + | DTable (_, n, _, _, _, _) => Int.max (n, count) | DSequence (_, n, _) => Int.max (n, count) | DDatabase _ => count | DCookie (_, n, _, _) => Int.max (n, count)) 0 diff --git a/src/corify.sml b/src/corify.sml index fc8bb1de..3387e73a 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -976,12 +976,12 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = end | _ => raise Fail "Non-const signature for 'export'") - | L.DTable (_, x, n, c, e) => + | L.DTable (_, x, n, c, e, cc) => let val (st, n) = St.bindVal st x n val s = relify (doRestify (mods, x)) in - ([(L'.DTable (x, n, corifyCon st c, s, corifyExp st e), loc)], st) + ([(L'.DTable (x, n, corifyCon st c, s, corifyExp st e, corifyCon st cc), loc)], st) end | L.DSequence (_, x, n) => let @@ -1052,7 +1052,7 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DStr (_, n', _, str) => Int.max (n, Int.max (n', maxNameStr str)) | L.DFfiStr (_, n', _) => Int.max (n, n') | L.DExport _ => n - | L.DTable (_, _, n', _, _) => Int.max (n, n') + | L.DTable (_, _, n', _, _, _) => Int.max (n, n') | L.DSequence (_, _, n') => Int.max (n, n') | L.DDatabase _ => n | L.DCookie (_, _, n', _) => Int.max (n, n')) diff --git a/src/defunc.sig b/src/defunc.sig deleted file mode 100644 index 6e8f2136..00000000 --- a/src/defunc.sig +++ /dev/null @@ -1,32 +0,0 @@ -(* Copyright (c) 2008, Adam Chlipala - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - The names of contributors may not be used to endorse or promote products - * derived from this software without specific prior written permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR - * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF - * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS - * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN - * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) - * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - * POSSIBILITY OF SUCH DAMAGE. - *) - -signature DEFUNC = sig - - val defunc : Core.file -> Core.file - -end diff --git a/src/defunc.sml b/src/defunc.sml deleted file mode 100644 index 7a17d1dc..00000000 --- a/src/defunc.sml +++ /dev/null @@ -1,260 +0,0 @@ -(* Copyright (c) 2008, Adam Chlipala - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - The names of contributors may not be used to endorse or promote products - * derived from this software without specific prior written permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR - * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF - * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS - * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN - * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) - * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - * POSSIBILITY OF SUCH DAMAGE. - *) - -structure Defunc :> DEFUNC = struct - -open Core - -structure E = CoreEnv -structure U = CoreUtil - -structure IS = IntBinarySet - -val functionInside = U.Con.exists {kind = fn _ => false, - con = fn TFun _ => true - | CFfi ("Basis", "transaction") => true - | _ => false} - -val freeVars = U.Exp.foldB {kind = fn (_, _, xs) => xs, - con = fn (_, _, xs) => xs, - exp = fn (bound, e, xs) => - case e of - ERel x => - if x >= bound then - IS.add (xs, x - bound) - else - xs - | _ => xs, - bind = fn (bound, b) => - case b of - U.Exp.RelE _ => bound + 1 - | _ => bound} - 0 IS.empty - -fun positionOf (v : int, ls) = - let - fun pof (pos, ls) = - case ls of - [] => raise Fail "Defunc.positionOf" - | v' :: ls' => - if v = v' then - pos - else - pof (pos + 1, ls') - in - pof (0, ls) - end - -fun squish fvs = - U.Exp.mapB {kind = fn _ => fn k => k, - con = fn _ => fn c => c, - exp = fn bound => fn e => - case e of - ERel x => - if x >= bound then - ERel (positionOf (x - bound, fvs) + bound) - else - e - | _ => e, - bind = fn (bound, b) => - case b of - U.Exp.RelE _ => bound + 1 - | _ => bound} - 0 - -fun default (_, x, st) = (x, st) - -datatype 'a search = - Yes - | No - | Maybe of 'a - -structure EK = struct -type ord_key = exp -val compare = U.Exp.compare -end - -structure EM = BinaryMapFn(EK) - -type state = { - maxName : int, - funcs : int EM.map, - vis : (string * int * con * exp * string) list -} - -fun exp (env, e, st) = - case e of - ERecord xes => - let - val (xes, st) = - ListUtil.foldlMap - (fn (tup as (fnam as (CName x, loc), e, xt), st) => - if (x <> "Link" andalso x <> "Action") - orelse case #1 e of - ENamed _ => true - | _ => false then - (tup, st) - else - let - fun needsAttention (e, _) = - case e of - ENamed f => Maybe (#2 (E.lookupENamed env f)) - | EApp (f, _) => - (case needsAttention f of - No => No - | Yes => Yes - | Maybe t => - case t of - (TFun (dom, _), _) => - if functionInside dom then - Yes - else - No - | _ => No) - | _ => No - - fun headSymbol (e, _) = - case e of - ENamed f => f - | EApp (e, _) => headSymbol e - | _ => raise Fail "Defunc: headSymbol" - - fun rtype (e, _) = - case e of - ENamed f => #2 (E.lookupENamed env f) - | EApp (f, _) => - (case rtype f of - (TFun (_, ran), _) => ran - | _ => raise Fail "Defunc: rtype [1]") - | _ => raise Fail "Defunc: rtype [2]" - in - (*Print.prefaces "Found one!" - [("e", CorePrint.p_exp env e)];*) - case needsAttention e of - Yes => - let - (*val () = print "Yes\n"*) - val f = headSymbol e - - val fvs = IS.listItems (freeVars e) - - val e = squish fvs e - val (e, t) = foldl (fn (n, (e, t)) => - let - val (x, xt) = E.lookupERel env n - in - ((EAbs (x, xt, t, e), loc), - (TFun (xt, t), loc)) - end) - (e, rtype e) fvs - - val (f', st) = - case EM.find (#funcs st, e) of - SOME f' => (f', st) - | NONE => - let - val (fx, _, _, tag) = E.lookupENamed env f - val f' = #maxName st - - val vi = (fx, f', t, e, tag) - in - (f', {maxName = f' + 1, - funcs = EM.insert (#funcs st, e, f'), - vis = vi :: #vis st}) - end - - val e = foldr (fn (n, e) => - (EApp (e, (ERel n, loc)), loc)) - (ENamed f', loc) fvs - in - (*app (fn n => Print.prefaces - "Free" - [("n", CorePrint.p_exp env (ERel n, ErrorMsg.dummySpan))]) - fvs; - Print.prefaces "Squished" - [("e", CorePrint.p_exp CoreEnv.empty e)];*) - - ((fnam, e, xt), st) - end - | _ => (tup, st) - end - | (tup, st) => (tup, st)) - st xes - in - (ERecord xes, st) - end - | _ => (e, st) - -fun bind (env, b) = - case b of - U.Decl.RelK x => E.pushKRel env x - | U.Decl.RelC (x, k) => E.pushCRel env x k - | U.Decl.NamedC (x, n, k, co) => E.pushCNamed env x n k co - | U.Decl.RelE (x, t) => E.pushERel env x t - | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s - -fun doDecl env = U.Decl.foldMapB {kind = default, - con = default, - exp = exp, - decl = default, - bind = bind} - env - -fun defunc file = - let - fun doDecl' (d, (env, st)) = - let - val env = E.declBinds env d - - val (d, st) = doDecl env st d - - val ds = - case #vis st of - [] => [d] - | vis => - case d of - (DValRec vis', loc) => [(DValRec (vis' @ vis), loc)] - | _ => [(DValRec vis, #2 d), d] - in - (ds, - (env, - {maxName = #maxName st, - funcs = #funcs st, - vis = []})) - end - - val (file, _) = ListUtil.foldlMapConcat doDecl' - (E.empty, - {maxName = U.File.maxName file + 1, - funcs = EM.empty, - vis = []}) - file - in - file - end - -end diff --git a/src/elab.sml b/src/elab.sml index dd2952d2..c31483ec 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -166,7 +166,7 @@ datatype decl' = | DFfiStr of string * int * sgn | DConstraint of con * con | DExport of int * sgn * str - | DTable of int * string * int * con * exp + | DTable of int * string * int * con * exp * con | DSequence of int * string * int | DClass of string * int * kind * con | DDatabase of string diff --git a/src/elab_env.sml b/src/elab_env.sml index 7adc8dd9..8bb769c1 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1532,11 +1532,13 @@ fun declBinds env (d, loc) = | DFfiStr (x, n, sgn) => pushStrNamedAs env x n sgn | DConstraint _ => env | DExport _ => env - | DTable (tn, x, n, c, _) => + | DTable (tn, x, n, c, _, cc) => let - val t = (CApp ((CModProj (tn, [], "sql_table"), loc), c), loc) + val ct = (CModProj (tn, [], "sql_table"), loc) + val ct = (CApp (ct, c), loc) + val ct = (CApp (ct, cc), loc) in - pushENamedAs env x n t + pushENamedAs env x n ct end | DSequence (tn, x, n) => let diff --git a/src/elab_print.sml b/src/elab_print.sml index f98592cc..b65e1bd6 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -740,17 +740,17 @@ fun p_decl env (dAll as (d, _) : decl) = string ":", space, p_sgn env sgn] - | DTable (_, x, n, c, e) => box [string "table", - space, - p_named x n, - space, - string ":", - space, - p_con env c, - space, - string "constraints", - space, - p_exp env e] + | DTable (_, x, n, c, e, _) => box [string "table", + space, + p_named x n, + space, + string ":", + space, + p_con env c, + space, + string "constraints", + space, + p_exp env e] | DSequence (_, x, n) => box [string "sequence", space, p_named x n] diff --git a/src/elab_util.sml b/src/elab_util.sml index 6700686d..32f399dc 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -766,9 +766,14 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f bind (ctx, Str (x, sgn)) | DConstraint _ => ctx | DExport _ => ctx - | DTable (tn, x, n, c, _) => - bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "sql_table"), loc), - c), loc))) + | DTable (tn, x, n, c, _, cc) => + let + val ct = (CModProj (n, [], "sql_table"), loc) + val ct = (CApp (ct, c), loc) + val ct = (CApp (ct, cc), loc) + in + bind (ctx, NamedE (x, ct)) + end | DSequence (tn, x, n) => bind (ctx, NamedE (x, (CModProj (n, [], "sql_sequence"), loc))) | DClass (x, n, k, _) => @@ -864,12 +869,14 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f fn str' => (DExport (en, sgn', str'), loc))) - | DTable (tn, x, n, c, e) => + | DTable (tn, x, n, c, e, cc) => S.bind2 (mfc ctx c, fn c' => - S.map2 (mfe ctx e, + S.bind2 (mfe ctx e, fn e' => - (DTable (tn, x, n, c', e'), loc))) + S.map2 (mfc ctx cc, + fn cc' => + (DTable (tn, x, n, c', e', cc'), loc)))) | DSequence _ => S.return2 dAll | DClass (x, n, k, c) => @@ -1020,7 +1027,7 @@ and maxNameDecl (d, _) = | DConstraint _ => 0 | DClass (_, n, _, _) => n | DExport _ => 0 - | DTable (n1, _, n2, _, _) => Int.max (n1, n2) + | DTable (n1, _, n2, _, _, _) => Int.max (n1, n2) | DSequence (n1, _, n2) => Int.max (n1, n2) | DDatabase _ => 0 | DCookie (n1, _, n2, _) => Int.max (n1, n2) diff --git a/src/elaborate.sml b/src/elaborate.sml index 0beab9e7..224c3e50 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -880,6 +880,64 @@ (L'.CError, _) => () | (_, L'.CError) => () + | (L'.CProj (c1, n1), _) => + let + fun trySnd () = + case #1 (hnormCon env c2All) of + L'.CProj (c2, n2) => + let + fun tryNormal () = + if n1 = n2 then + unifyCons' env c1 c2 + else + err CIncompatible + in + case #1 (hnormCon env c2) of + L'.CUnif (_, k, _, r) => + (case #1 (hnormKind k) of + L'.KTuple ks => + let + val loc = #2 c2 + val us = map (fn k => cunif (loc, k)) ks + in + r := SOME (L'.CTuple us, loc); + unifyCons' env c1All (List.nth (us, n2 - 1)) + end + | _ => tryNormal ()) + | _ => tryNormal () + end + | _ => err CIncompatible + in + case #1 (hnormCon env c1) of + L'.CUnif (_, k, _, r) => + (case #1 (hnormKind k) of + L'.KTuple ks => + let + val loc = #2 c1 + val us = map (fn k => cunif (loc, k)) ks + in + r := SOME (L'.CTuple us, loc); + unifyCons' env (List.nth (us, n1 - 1)) c2All + end + | _ => trySnd ()) + | _ => trySnd () + end + + | (_, L'.CProj (c2, n2)) => + (case #1 (hnormCon env c2) of + L'.CUnif (_, k, _, r) => + (case #1 (hnormKind k) of + L'.KTuple ks => + let + val loc = #2 c2 + val us = map (fn k => cunif (loc, k)) ks + in + r := SOME (L'.CTuple us, loc); + unifyCons' env c1All (List.nth (us, n2 - 1)) + end + | _ => err CIncompatible) + | _ => err CIncompatible) + | (L'.CRecord _, _) => isRecord () | (_, L'.CRecord _) => isRecord () | (L'.CConcat _, _) => isRecord () @@ -962,64 +1020,6 @@ ((ListPair.appEq (fn (c1, c2) => unifyCons' env c1 c2) (cs1, cs2)) handle ListPair.UnequalLengths => err CIncompatible) - | (L'.CProj (c1, n1), _) => - let - fun trySnd () = - case #1 (hnormCon env c2All) of - L'.CProj (c2, n2) => - let - fun tryNormal () = - if n1 = n2 then - unifyCons' env c1 c2 - else - err CIncompatible - in - case #1 (hnormCon env c2) of - L'.CUnif (_, k, _, r) => - (case #1 (hnormKind k) of - L'.KTuple ks => - let - val loc = #2 c2 - val us = map (fn k => cunif (loc, k)) ks - in - r := SOME (L'.CTuple us, loc); - unifyCons' env c1All (List.nth (us, n2 - 1)) - end - | _ => tryNormal ()) - | _ => tryNormal () - end - | _ => err CIncompatible - in - case #1 (hnormCon env c1) of - L'.CUnif (_, k, _, r) => - (case #1 (hnormKind k) of - L'.KTuple ks => - let - val loc = #2 c1 - val us = map (fn k => cunif (loc, k)) ks - in - r := SOME (L'.CTuple us, loc); - unifyCons' env (List.nth (us, n1 - 1)) c2All - end - | _ => trySnd ()) - | _ => trySnd () - end - - | (_, L'.CProj (c2, n2)) => - (case #1 (hnormCon env c2) of - L'.CUnif (_, k, _, r) => - (case #1 (hnormKind k) of - L'.KTuple ks => - let - val loc = #2 c2 - val us = map (fn k => cunif (loc, k)) ks - in - r := SOME (L'.CTuple us, loc); - unifyCons' env c1All (List.nth (us, n2 - 1)) - end - | _ => err CIncompatible) - | _ => err CIncompatible) - | (L'.CMap (dom1, ran1), L'.CMap (dom2, ran2)) => (unifyKinds env dom1 dom2; unifyKinds env ran1 ran2) @@ -2319,7 +2319,8 @@ fun sgiOfDecl (d, loc) = | L'.DFfiStr (x, n, sgn) => [(L'.SgiStr (x, n, sgn), loc)] | L'.DConstraint cs => [(L'.SgiConstraint cs, loc)] | L'.DExport _ => [] - | L'.DTable (tn, x, n, c, _) => [(L'.SgiVal (x, n, (L'.CApp (tableOf (), c), loc)), loc)] + | L'.DTable (tn, x, n, c, _, cc) => + [(L'.SgiVal (x, n, (L'.CApp ((L'.CApp (tableOf (), c), loc), cc), loc)), loc)] | L'.DSequence (tn, x, n) => [(L'.SgiVal (x, n, sequenceOf ()), loc)] | L'.DClass (x, n, k, c) => [(L'.SgiClass (x, n, k, c), loc)] | L'.DDatabase _ => [] @@ -3268,17 +3269,22 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs)) = | L.DTable (x, c, e) => let val (c', k, gs') = elabCon (env, denv) c - val (env, n) = E.pushENamed env x (L'.CApp (tableOf (), c'), loc) + val uniques = cunif (loc, (L'.KRecord (L'.KRecord (L'.KUnit, loc), loc), loc)) + + val ct = tableOf () + val ct = (L'.CApp (ct, c'), loc) + val ct = (L'.CApp (ct, uniques), loc) + + val (env, n) = E.pushENamed env x ct val (e', et, gs'') = elabExp (env, denv) e - val names = cunif (loc, (L'.KRecord (L'.KUnit, loc), loc)) val cst = (L'.CModProj (!basis_r, [], "sql_constraints"), loc) - val cst = (L'.CApp (cst, names), loc) val cst = (L'.CApp (cst, c'), loc) + val cst = (L'.CApp (cst, uniques), loc) in checkKind env c' k (L'.KRecord (L'.KType, loc), loc); checkCon env e' et cst; - ([(L'.DTable (!basis_r, x, n, c', e'), loc)], (env, denv, gs'' @ enD gs' @ gs)) + ([(L'.DTable (!basis_r, x, n, c', e', uniques), loc)], (env, denv, gs'' @ enD gs' @ gs)) end | L.DSequence x => let diff --git a/src/expl.sml b/src/expl.sml index a347a8e8..6cd9b7a8 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -141,7 +141,7 @@ datatype decl' = | DStr of string * int * sgn * str | DFfiStr of string * int * sgn | DExport of int * sgn * str - | DTable of int * string * int * con * exp + | DTable of int * string * int * con * exp * con | DSequence of int * string * int | DDatabase of string | DCookie of int * string * int * con diff --git a/src/expl_env.sml b/src/expl_env.sml index f4e16cb5..31b1c0a3 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -298,11 +298,13 @@ fun declBinds env (d, loc) = | DStr (x, n, sgn, _) => pushStrNamed env x n sgn | DFfiStr (x, n, sgn) => pushStrNamed env x n sgn | DExport _ => env - | DTable (tn, x, n, c, _) => + | DTable (tn, x, n, c, _, cc) => let - val t = (CApp ((CModProj (tn, [], "sql_table"), loc), c), loc) + val ct = (CModProj (tn, [], "sql_table"), loc) + val ct = (CApp (ct, c), loc) + val ct = (CApp (ct, cc), loc) in - pushENamed env x n t + pushENamed env x n ct end | DSequence (tn, x, n) => let diff --git a/src/expl_print.sml b/src/expl_print.sml index c7a506b1..05d68941 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -663,17 +663,17 @@ fun p_decl env (dAll as (d, _) : decl) = string ":", space, p_sgn env sgn] - | DTable (_, x, n, c, e) => box [string "table", - space, - p_named x n, - space, - string ":", - space, - p_con env c, - space, - string "constraints", - space, - p_exp env e] + | DTable (_, x, n, c, e, _) => box [string "table", + space, + p_named x n, + space, + string ":", + space, + p_con env c, + space, + string "constraints", + space, + p_exp env e] | DSequence (_, x, n) => box [string "sequence", space, p_named x n] diff --git a/src/explify.sml b/src/explify.sml index d567bde3..fa35bd0d 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -178,7 +178,7 @@ fun explifyDecl (d, loc : EM.span) = | L.DFfiStr (x, n, sgn) => SOME (L'.DFfiStr (x, n, explifySgn sgn), loc) | L.DConstraint (c1, c2) => NONE | L.DExport (en, sgn, str) => SOME (L'.DExport (en, explifySgn sgn, explifyStr str), loc) - | L.DTable (nt, x, n, c, e) => SOME (L'.DTable (nt, x, n, explifyCon c, explifyExp e), loc) + | L.DTable (nt, x, n, c, e, cc) => SOME (L'.DTable (nt, x, n, explifyCon c, explifyExp e, explifyCon cc), loc) | L.DSequence (nt, x, n) => SOME (L'.DSequence (nt, x, n), loc) | L.DClass (x, n, k, c) => SOME (L'.DCon (x, n, (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), explifyCon c), loc) diff --git a/src/monoize.sml b/src/monoize.sml index af414c08..057a9222 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -139,7 +139,7 @@ fun monoType env = (L'.TSignal (mt env dtmap t), loc) | L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) => (L'.TFfi ("Basis", "string"), loc) - | L.CApp ((L.CFfi ("Basis", "sql_table"), _), _) => + | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_table"), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "sql_sequence") => (L'.TFfi ("Basis", "string"), loc) @@ -151,7 +151,7 @@ fun monoType env = (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraints"), _), _), _), _) => (L'.TFfi ("Basis", "sql_constraints"), loc) - | L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _) => + | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_subset"), _), _), _), _) => @@ -1162,13 +1162,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) => ((L'.ERecord [], loc), fm) - | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "one_constraint"), _), _), _), (L.CName name, _)) => + | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "one_constraint"), _), _), _), _), _), (L.CName name, _)) => ((L'.EAbs ("c", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "sql_constraints"), loc), (L'.ERecord [(name, (L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))], loc)), loc), fm) - | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "join_constraints"), _), _), _), _), _), _) => + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "join_constraints"), _), + _), _), + _), _), + _) => let val constraints = (L'.TFfi ("Basis", "sql_constraints"), loc) in @@ -1178,12 +1184,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end - | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "unique"), _), _), _), - (L.CRecord (_, unique), _)) => - ((L'.EPrim (Prim.String ("UNIQUE (" - ^ String.concatWith ", " (map (fn (x, _) => "uw_" ^ monoName env x) unique) - ^ ")")), loc), - fm) + | L.ECApp ( + (L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "unique"), _), _), _), t), _), + nm), _), + (L.CRecord (_, unique), _)) => + let + val unique = (nm, t) :: unique + in + ((L'.EPrim (Prim.String ("UNIQUE (" + ^ String.concatWith ", " (map (fn (x, _) => "uw_" ^ monoName env x) unique) + ^ ")")), loc), + fm) + end | L.EFfiApp ("Basis", "dml", [e]) => let @@ -1193,7 +1205,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end - | L.ECApp ((L.EFfi ("Basis", "insert"), _), fields) => + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "insert"), _), fields), _), _) => (case monoType env (L.TRecord fields, loc) of (L'.TRecord fields, _) => let @@ -1217,7 +1229,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end | _ => poly ()) - | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "update"), _), _), _), changed) => + | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "update"), _), _), _), _), _), changed) => (case monoType env (L.TRecord changed, loc) of (L'.TRecord changed, _) => let @@ -1246,7 +1258,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end | _ => poly ()) - | L.ECApp ((L.EFfi ("Basis", "delete"), _), _) => + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "delete"), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) fun sc s = (L'.EPrim (Prim.String s), loc) @@ -1348,6 +1360,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val un = (L'.TRecord [], loc) fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc) + val tables = List.mapPartial + (fn (x, (L.CTuple [y, _], _)) => SOME (x, y) + | _ => (E.errorAt loc "Bad sql_query1 tables pair"; + NONE)) + tables + fun doTables tables = let val tables = map (fn ((L.CName x, _), xts) => @@ -2481,7 +2499,7 @@ fun monoDecl (env, fm) (all as (d, loc)) = in SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)]) end - | L.DTable (x, n, (L.CRecord (_, xts), _), s, e) => + | L.DTable (x, n, (L.CRecord (_, xts), _), s, e, _) => let val t = (L.CFfi ("Basis", "string"), loc) val t' = (L'.TFfi ("Basis", "string"), loc) @@ -2615,7 +2633,7 @@ fun monoize env file = in foldl (fn ((d, _), e) => case d of - L.DTable (_, _, xts, tab, _) => doTable (tab, #1 xts, e) + L.DTable (_, _, xts, tab, _, _) => doTable (tab, #1 xts, e) | _ => e) e file end @@ -2660,7 +2678,7 @@ fun monoize env file = in foldl (fn ((d, _), e) => case d of - L.DTable (_, _, xts, tab, _) => doTable (tab, #1 xts, e) + L.DTable (_, _, xts, tab, _, _) => doTable (tab, #1 xts, e) | _ => e) e file end diff --git a/src/reduce.sml b/src/reduce.sml index 6754d708..d6357f1b 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -461,8 +461,9 @@ fun reduce file = ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC [] t, exp (namedC, namedE) [] e, s)) vis), loc), st) | DExport _ => (d, st) - | DTable (s, n, c, s', e) => ((DTable (s, n, con namedC [] c, s', - exp (namedC, namedE) [] e), loc), st) + | DTable (s, n, c, s', e, cc) => ((DTable (s, n, con namedC [] c, s', + exp (namedC, namedE) [] e, + con namedC [] cc), loc), st) | DSequence _ => (d, st) | DDatabase _ => (d, st) | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st) diff --git a/src/shake.sml b/src/shake.sml index 2f873e94..19204ebb 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -59,7 +59,7 @@ fun shake file = val (usedE, usedC, table_cs) = List.foldl (fn ((DExport (_, n), _), (usedE, usedC, table_cs)) => (IS.add (usedE, n), usedE, table_cs) - | ((DTable (_, _, c, _, e), _), (usedE, usedC, table_cs)) => + | ((DTable (_, _, c, _, e, _), _), (usedE, usedC, table_cs)) => let val (usedE, usedC) = usedVars (usedE, usedC) e in @@ -79,7 +79,7 @@ fun shake file = IM.insert (edef, n, (all_ns, t, e))) edef vis) end | ((DExport _, _), acc) => acc - | ((DTable (_, n, c, _, _), _), (cdef, edef)) => + | ((DTable (_, n, c, _, _, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DSequence (_, n, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], dummyt, dummye))) diff --git a/src/sources b/src/sources index b2d7b855..27b6673b 100644 --- a/src/sources +++ b/src/sources @@ -105,9 +105,6 @@ core_untangle.sml especialize.sig especialize.sml -defunc.sig -defunc.sml - rpcify.sig rpcify.sml diff --git a/src/urweb.grm b/src/urweb.grm index 784c62ee..ad92ff11 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -294,9 +294,9 @@ fun tagIn bt = | query1 of exp | tables of (con * exp) list | tname of con - | tnameW of (con * con) - | tnames of con - | tnames' of (con * con) list + | tnameW of con * con + | tnames of (con * con) * (con * con) list + | tnames' of (con * con) * (con * con) list | table of con * exp | tident of con | fident of con @@ -493,7 +493,9 @@ cst : UNIQUE tnames (let val loc = s (UNIQUEleft, tnamesright) val e = (EVar (["Basis"], "unique", Infer), loc) - val e = (ECApp (e, tnames), loc) + val e = (ECApp (e, #1 (#1 tnames)), loc) + val e = (ECApp (e, (CRecord (#2 tnames), loc)), loc) + val e = (EDisjointApp e, loc) in (EDisjointApp e, loc) end) @@ -505,12 +507,11 @@ tnameW : tname (let (tname, (CWild (KType, loc), loc)) end) -tnames : tnameW (CRecord [tnameW], s (tnameWleft, tnameWright)) - | LPAREN tnames' RPAREN (CRecord tnames', s (LPARENleft, RPARENright)) - | LBRACE LBRACE cexp RBRACE RBRACE (cexp) +tnames : tnameW (tnameW, []) + | LPAREN tnames' RPAREN (tnames') -tnames': tnameW ([tnameW]) - | tnameW COMMA tnames' (tnameW :: tnames') +tnames': tnameW (tnameW, []) + | tnameW COMMA tnames' (#1 tnames', tnameW :: #2 tnames') valis : vali ([vali]) | vali AND valis (vali :: valis) diff --git a/tests/cst.ur b/tests/cst.ur index 104a9f34..0ebcc977 100644 --- a/tests/cst.ur +++ b/tests/cst.ur @@ -4,9 +4,12 @@ table t : {A : int, B : int} CONSTRAINT UniBoth UNIQUE (A, B), CONSTRAINT UniAm UNIQUE {#A}, - CONSTRAINT UniAm2 UNIQUE {{[A = _]}}, - CONSTRAINT UniAm3 {unique [[A = _]] !}, - {{one_constraint [#UniAm4] (unique [[A = _]] !)}} + CONSTRAINT UniAm2 {unique [#A] [[]] ! !}, + {{one_constraint [#UniAm3] (unique [#A] [[]] ! !)}}, + + CONSTRAINT UniBothm UNIQUE ({#A}, {#B}), + CONSTRAINT UniBothm2 {unique [#A] [[B = _]] ! !}, + {{one_constraint [#UniBothm3] (unique [#A] [[B = _]] ! !)}} fun main () : transaction page = queryI (SELECT * FROM t) (fn _ => return ()); -- cgit v1.2.3 From 26ad31287745567b98b357de9793a0e795c63334 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 7 Apr 2009 16:14:31 -0400 Subject: PRIMARY KEY --- lib/ur/basis.urs | 30 +++++++++++++++++++--------- src/cjr.sml | 2 +- src/cjr_print.sml | 55 +++++++++++++++++++++++++++++++++++----------------- src/cjrize.sml | 13 ++++++++++--- src/core.sml | 2 +- src/core_env.sml | 4 ++-- src/core_print.sml | 34 ++++++++++++++++++-------------- src/core_util.sml | 22 ++++++++++++--------- src/corify.sml | 8 +++++--- src/elab.sml | 2 +- src/elab_env.sml | 4 ++-- src/elab_print.sml | 26 ++++++++++++++----------- src/elab_util.sml | 22 ++++++++++++--------- src/elaborate.sml | 51 ++++++++++++++++++++++++++++++++++-------------- src/expl.sml | 2 +- src/expl_env.sml | 4 ++-- src/expl_print.sml | 26 ++++++++++++++----------- src/explify.sml | 5 ++++- src/mono.sml | 2 +- src/mono_print.sml | 36 +++++++++++++++++++--------------- src/mono_util.sml | 10 ++++++---- src/monoize.sml | 32 +++++++++++++++++++++++++----- src/pathcheck.sml | 18 +++++++++++++++-- src/reduce.sml | 8 +++++--- src/shake.sml | 7 ++++--- src/source.sml | 6 ++---- src/source_print.sml | 52 ++++++++++++++++++++++++++++--------------------- src/urweb.grm | 39 ++++++++++++++++++++++++++++++------- src/urweb.lex | 2 ++ tests/cst.ur | 2 ++ tests/pkey.ur | 6 ++++++ tests/pkey.urp | 5 +++++ 32 files changed, 356 insertions(+), 181 deletions(-) create mode 100644 tests/pkey.ur create mode 100644 tests/pkey.urp (limited to 'src/elab_env.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 4e926f87..997495b1 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -126,6 +126,27 @@ con sql_table :: {Type} -> {{Unit}} -> Type (*** Constraints *) +(**** Primary keys *) + +class sql_injectable_prim +val sql_bool : sql_injectable_prim bool +val sql_int : sql_injectable_prim int +val sql_float : sql_injectable_prim float +val sql_string : sql_injectable_prim string +val sql_time : sql_injectable_prim time +val sql_channel : t ::: Type -> sql_injectable_prim (channel t) +val sql_client : sql_injectable_prim client + +con primary_key :: {Type} -> {{Unit}} -> Type +val no_primary_key : fs ::: {Type} -> primary_key fs [] +val primary_key : rest ::: {Type} -> t ::: Type -> key1 :: Name -> keys :: {Type} + -> [[key1] ~ keys] => [[key1 = t] ++ keys ~ rest] + => $([key1 = sql_injectable_prim t] ++ map sql_injectable_prim keys) + -> primary_key ([key1 = t] ++ keys ++ rest) + [Pkey = [key1] ++ map (fn _ => ()) keys] + +(**** Other constraints *) + con sql_constraints :: {Type} -> {{Unit}} -> Type (* Arguments: column types, uniqueness implications of constraints *) @@ -224,15 +245,6 @@ val sql_exp : tabs ::: {{Type}} -> agg ::: {{Type}} -> t ::: Type -> rest ::: {T -> nm :: Name -> sql_exp tabs agg ([nm = t] ++ rest) t -class sql_injectable_prim -val sql_bool : sql_injectable_prim bool -val sql_int : sql_injectable_prim int -val sql_float : sql_injectable_prim float -val sql_string : sql_injectable_prim string -val sql_time : sql_injectable_prim time -val sql_channel : t ::: Type -> sql_injectable_prim (channel t) -val sql_client : sql_injectable_prim client - class sql_injectable val sql_prim : t ::: Type -> sql_injectable_prim t -> sql_injectable t val sql_option_prim : t ::: Type -> sql_injectable_prim t -> sql_injectable (option t) diff --git a/src/cjr.sml b/src/cjr.sml index 7f8b2434..33cf07c9 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -104,7 +104,7 @@ datatype decl' = | DFun of string * int * (string * typ) list * typ * exp | DFunRec of (string * int * (string * typ) list * typ * exp) list - | DTable of string * (string * typ) list * (string * string) list + | DTable of string * (string * typ) list * string * (string * string) list | DSequence of string | DDatabase of {name : string, expunge : int, initialize : int} | DPreparedStatements of (string * int) list diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 9fc1511f..f86d4928 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1941,19 +1941,25 @@ fun p_decl env (dAll as (d, _) : decl) = p_list_sep newline (p_fun env) vis, newline] end - | DTable (x, _, csts) => box [string "/* SQL table ", - string x, - space, - string "constraints", - space, - p_list (fn (x, v) => box [string x, - space, - string ":", - space, - string v]) csts, - space, - string " */", - newline] + | DTable (x, _, pk, csts) => box [string "/* SQL table ", + string x, + space, + case pk of + "" => box [] + | _ => box [string "keys", + space, + string pk, + space], + string "constraints", + space, + p_list (fn (x, v) => box [string x, + space, + string ":", + space, + string v]) csts, + space, + string " */", + newline] | DSequence x => box [string "/* SQL sequence ", string x, string " */", @@ -2467,7 +2473,7 @@ fun p_file env (ds, ps) = val pds' = map p_page ps - val tables = List.mapPartial (fn (DTable (s, xts, _), _) => SOME (s, xts) + val tables = List.mapPartial (fn (DTable (s, xts, _, _), _) => SOME (s, xts) | _ => NONE) ds val sequences = List.mapPartial (fn (DSequence s, _) => SOME s | _ => NONE) ds @@ -2811,7 +2817,7 @@ fun p_sql env (ds, _) = (fn (dAll as (d, _), env) => let val pp = case d of - DTable (s, xts, csts) => + DTable (s, xts, pk, csts) => box [string "CREATE TABLE ", string s, string "(", @@ -2820,10 +2826,23 @@ fun p_sql env (ds, _) = string (CharVector.map Char.toLower x), space, p_sqltype env (t, ErrorMsg.dummySpan)]) xts, - case csts of - [] => box [] - | _ => box [string ","], + case (pk, csts) of + ("", []) => box [] + | _ => string ",", cut, + case pk of + "" => box [] + | _ => box [string "PRIMARY", + space, + string "KEY", + space, + string "(", + string pk, + string ")", + case csts of + [] => box [] + | _ => string ",", + newline], p_list_sep (box [string ",", newline]) (fn (x, c) => box [string "CONSTRAINT", diff --git a/src/cjrize.sml b/src/cjrize.sml index 839c0c57..e0341c64 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -524,7 +524,7 @@ fun cifyDecl ((d, loc), sm) = (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndPullAndPush), sm) end - | L.DTable (s, xts, e) => + | L.DTable (s, xts, pe, ce) => let val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) => let @@ -540,10 +540,17 @@ fun cifyDecl ((d, loc), sm) = | L.EStrcat (e1, e2) => flatten e1 @ flatten e2 | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined"; Print.prefaces "Undetermined constraint" - [("e", MonoPrint.p_exp MonoEnv.empty e)]; + [("e", MonoPrint.p_exp MonoEnv.empty e)]; []) + + val pe = case #1 pe of + L.EPrim (Prim.String s) => s + | _ => (ErrorMsg.errorAt loc "Primary key has not been fully determined"; + Print.prefaces "Undetermined constraint" + [("e", MonoPrint.p_exp MonoEnv.empty pe)]; + "") in - (SOME (L'.DTable (s, xts, flatten e), loc), NONE, sm) + (SOME (L'.DTable (s, xts, pe, flatten ce), loc), NONE, sm) end | L.DSequence s => (SOME (L'.DSequence s, loc), NONE, sm) diff --git a/src/core.sml b/src/core.sml index 687b913f..a8e0de13 100644 --- a/src/core.sml +++ b/src/core.sml @@ -130,7 +130,7 @@ datatype decl' = | DVal of string * int * con * exp * string | DValRec of (string * int * con * exp * string) list | DExport of export_kind * int - | DTable of string * int * con * string * exp * con + | DTable of string * int * con * string * exp * con * exp * con | DSequence of string * int * string | DDatabase of string | DCookie of string * int * con * string diff --git a/src/core_env.sml b/src/core_env.sml index 4c4cc68f..95226bb7 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -313,11 +313,11 @@ fun declBinds env (d, loc) = | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis | DExport _ => env - | DTable (x, n, c, s, _, cc) => + | DTable (x, n, c, s, _, pc, _, cc) => let val ct = (CFfi ("Basis", "sql_table"), loc) val ct = (CApp (ct, c), loc) - val ct = (CApp (ct, cc), loc) + val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc) in pushENamed env x n ct NONE s end diff --git a/src/core_print.sml b/src/core_print.sml index 216cc8ac..ed401d29 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -546,21 +546,25 @@ fun p_decl env (dAll as (d, _) : decl) = space, (p_con env (#2 (E.lookupENamed env n)) handle E.UnboundNamed _ => string "UNBOUND")] - | DTable (x, n, c, s, e, _) => box [string "table", - space, - p_named x n, - space, - string "as", - space, - string s, - space, - string ":", - space, - p_con env c, - space, - string "constraints", - space, - p_exp env e] + | DTable (x, n, c, s, pe, _, ce, _) => box [string "table", + space, + p_named x n, + space, + string "as", + space, + string s, + space, + string ":", + space, + p_con env c, + space, + string "keys", + space, + p_exp env pe, + space, + string "constraints", + space, + p_exp env ce] | DSequence (x, n, s) => box [string "sequence", space, p_named x n, diff --git a/src/core_util.sml b/src/core_util.sml index df8bb271..320a0326 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -933,14 +933,18 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = (DValRec vis', loc)) end | DExport _ => S.return2 dAll - | DTable (x, n, c, s, e, cc) => + | DTable (x, n, c, s, pe, pc, ce, cc) => S.bind2 (mfc ctx c, fn c' => - S.bind2 (mfe ctx e, - fn e' => - S.map2 (mfc ctx cc, - fn cc' => - (DTable (x, n, c', s, e', cc'), loc)))) + S.bind2 (mfe ctx pe, + fn pe' => + S.bind2 (mfc ctx pc, + fn pc' => + S.bind2 (mfe ctx ce, + fn ce' => + S.map2 (mfc ctx cc, + fn cc' => + (DTable (x, n, c', s, pe', pc', ce', cc'), loc)))))) | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll | DCookie (x, n, c, s) => @@ -1062,11 +1066,11 @@ fun mapfoldB (all as {bind, ...}) = foldl (fn ((x, n, t, e, s), ctx) => bind (ctx, NamedE (x, n, t, NONE, s))) ctx vis | DExport _ => ctx - | DTable (x, n, c, s, _, cc) => + | DTable (x, n, c, s, _, pc, _, cc) => let val loc = #2 d' val ct = (CFfi ("Basis", "sql_table"), loc) - val ct = (CApp (ct, c), loc) + val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc) val ct = (CApp (ct, cc), loc) in bind (ctx, NamedE (x, n, ct, NONE, s)) @@ -1141,7 +1145,7 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DVal (_, n, _, _, _) => Int.max (n, count) | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis | DExport _ => count - | DTable (_, n, _, _, _, _) => Int.max (n, count) + | DTable (_, n, _, _, _, _, _, _) => Int.max (n, count) | DSequence (_, n, _) => Int.max (n, count) | DDatabase _ => count | DCookie (_, n, _, _) => Int.max (n, count)) 0 diff --git a/src/corify.sml b/src/corify.sml index 3387e73a..e3b9a365 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -976,12 +976,14 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = end | _ => raise Fail "Non-const signature for 'export'") - | L.DTable (_, x, n, c, e, cc) => + | L.DTable (_, x, n, c, pe, pc, ce, cc) => let val (st, n) = St.bindVal st x n val s = relify (doRestify (mods, x)) in - ([(L'.DTable (x, n, corifyCon st c, s, corifyExp st e, corifyCon st cc), loc)], st) + ([(L'.DTable (x, n, corifyCon st c, s, + corifyExp st pe, corifyCon st pc, + corifyExp st ce, corifyCon st cc), loc)], st) end | L.DSequence (_, x, n) => let @@ -1052,7 +1054,7 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DStr (_, n', _, str) => Int.max (n, Int.max (n', maxNameStr str)) | L.DFfiStr (_, n', _) => Int.max (n, n') | L.DExport _ => n - | L.DTable (_, _, n', _, _, _) => Int.max (n, n') + | L.DTable (_, _, n', _, _, _, _, _) => Int.max (n, n') | L.DSequence (_, _, n') => Int.max (n, n') | L.DDatabase _ => n | L.DCookie (_, _, n', _) => Int.max (n, n')) diff --git a/src/elab.sml b/src/elab.sml index c31483ec..83a7f929 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -166,7 +166,7 @@ datatype decl' = | DFfiStr of string * int * sgn | DConstraint of con * con | DExport of int * sgn * str - | DTable of int * string * int * con * exp * con + | DTable of int * string * int * con * exp * con * exp * con | DSequence of int * string * int | DClass of string * int * kind * con | DDatabase of string diff --git a/src/elab_env.sml b/src/elab_env.sml index 8bb769c1..8da78375 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1532,11 +1532,11 @@ fun declBinds env (d, loc) = | DFfiStr (x, n, sgn) => pushStrNamedAs env x n sgn | DConstraint _ => env | DExport _ => env - | DTable (tn, x, n, c, _, cc) => + | DTable (tn, x, n, c, _, pc, _, cc) => let val ct = (CModProj (tn, [], "sql_table"), loc) val ct = (CApp (ct, c), loc) - val ct = (CApp (ct, cc), loc) + val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc) in pushENamedAs env x n ct end diff --git a/src/elab_print.sml b/src/elab_print.sml index b65e1bd6..7eb853af 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -740,17 +740,21 @@ fun p_decl env (dAll as (d, _) : decl) = string ":", space, p_sgn env sgn] - | DTable (_, x, n, c, e, _) => box [string "table", - space, - p_named x n, - space, - string ":", - space, - p_con env c, - space, - string "constraints", - space, - p_exp env e] + | DTable (_, x, n, c, pe, _, ce, _) => box [string "table", + space, + p_named x n, + space, + string ":", + space, + p_con env c, + space, + string "keys", + space, + p_exp env pe, + space, + string "constraints", + space, + p_exp env ce] | DSequence (_, x, n) => box [string "sequence", space, p_named x n] diff --git a/src/elab_util.sml b/src/elab_util.sml index 32f399dc..ff4abbfb 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -766,11 +766,11 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f bind (ctx, Str (x, sgn)) | DConstraint _ => ctx | DExport _ => ctx - | DTable (tn, x, n, c, _, cc) => + | DTable (tn, x, n, c, _, pc, _, cc) => let val ct = (CModProj (n, [], "sql_table"), loc) val ct = (CApp (ct, c), loc) - val ct = (CApp (ct, cc), loc) + val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc) in bind (ctx, NamedE (x, ct)) end @@ -869,14 +869,18 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f fn str' => (DExport (en, sgn', str'), loc))) - | DTable (tn, x, n, c, e, cc) => + | DTable (tn, x, n, c, pe, pc, ce, cc) => S.bind2 (mfc ctx c, fn c' => - S.bind2 (mfe ctx e, - fn e' => - S.map2 (mfc ctx cc, - fn cc' => - (DTable (tn, x, n, c', e', cc'), loc)))) + S.bind2 (mfe ctx pe, + fn pe' => + S.bind2 (mfc ctx pc, + fn pc' => + S.bind2 (mfe ctx ce, + fn ce' => + S.map2 (mfc ctx cc, + fn cc' => + (DTable (tn, x, n, c', pe', pc', ce', cc'), loc)))))) | DSequence _ => S.return2 dAll | DClass (x, n, k, c) => @@ -1027,7 +1031,7 @@ and maxNameDecl (d, _) = | DConstraint _ => 0 | DClass (_, n, _, _) => n | DExport _ => 0 - | DTable (n1, _, n2, _, _, _) => Int.max (n1, n2) + | DTable (n1, _, n2, _, _, _, _, _) => Int.max (n1, n2) | DSequence (n1, _, n2) => Int.max (n1, n2) | DDatabase _ => 0 | DCookie (n1, _, n2, _) => Int.max (n1, n2) diff --git a/src/elaborate.sml b/src/elaborate.sml index d83af65b..c2ac31a4 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2027,7 +2027,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = ([(L'.SgiVal (x, n, c'), loc)], (env', denv, gs' @ gs)) end - | L.SgiTable (x, c, e) => + | L.SgiTable (x, c, pe, ce) => let val cstK = (L'.KRecord (L'.KRecord (L'.KUnit, loc), loc), loc) val x' = x ^ "_hidden_constraints" @@ -2035,28 +2035,38 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = val hidden = (L'.CNamed hidden_n, loc) val (c', ck, gs') = elabCon (env, denv) c + val pkey = cunif (loc, cstK) val visible = cunif (loc, cstK) val uniques = (L'.CConcat (visible, hidden), loc) val ct = tableOf () val ct = (L'.CApp (ct, c'), loc) - val ct = (L'.CApp (ct, uniques), loc) + val ct = (L'.CApp (ct, (L'.CConcat (pkey, uniques), loc)), loc) + + val (pe', pet, gs'') = elabExp (env', denv) pe + val gs'' = List.mapPartial (fn Disjoint x => SOME x + | _ => NONE) gs'' + + val pst = (L'.CModProj (!basis_r, [], "primary_key"), loc) + val pst = (L'.CApp (pst, c'), loc) + val pst = (L'.CApp (pst, pkey), loc) val (env', n) = E.pushENamed env' x ct - val (e', et, gs'') = elabExp (env, denv) e - val gs'' = List.mapPartial (fn Disjoint x => SOME x - | _ => NONE) gs'' + val (ce', cet, gs''') = elabExp (env', denv) ce + val gs''' = List.mapPartial (fn Disjoint x => SOME x + | _ => NONE) gs''' val cst = (L'.CModProj (!basis_r, [], "sql_constraints"), loc) val cst = (L'.CApp (cst, c'), loc) val cst = (L'.CApp (cst, visible), loc) in checkKind env c' ck (L'.KRecord (L'.KType, loc), loc); - checkCon env' e' et cst; + checkCon env' pe' pet pst; + checkCon env' ce' cet cst; ([(L'.SgiConAbs (x', hidden_n, cstK), loc), - (L'.SgiVal (x, n, ct), loc)], (env', denv, gs'' @ gs' @ gs)) + (L'.SgiVal (x, n, ct), loc)], (env', denv, gs''' @ gs'' @ gs' @ gs)) end | L.SgiStr (x, sgn) => @@ -2360,8 +2370,9 @@ and sgiOfDecl (d, loc) = | L'.DFfiStr (x, n, sgn) => [(L'.SgiStr (x, n, sgn), loc)] | L'.DConstraint cs => [(L'.SgiConstraint cs, loc)] | L'.DExport _ => [] - | L'.DTable (tn, x, n, c, _, cc) => - [(L'.SgiVal (x, n, (L'.CApp ((L'.CApp (tableOf (), c), loc), cc), loc)), loc)] + | L'.DTable (tn, x, n, c, _, pc, _, cc) => + [(L'.SgiVal (x, n, (L'.CApp ((L'.CApp (tableOf (), c), loc), + (L'.CConcat (pc, cc), loc)), loc)), loc)] | L'.DSequence (tn, x, n) => [(L'.SgiVal (x, n, sequenceOf ()), loc)] | L'.DClass (x, n, k, c) => [(L'.SgiClass (x, n, k, c), loc)] | L'.DDatabase _ => [] @@ -3307,25 +3318,35 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = ([(L'.DExport (E.newNamed (), sgn, str'), loc)], (env, denv, gs' @ gs)) end - | L.DTable (x, c, e) => + | L.DTable (x, c, pe, ce) => let + val cstK = (L'.KRecord (L'.KRecord (L'.KUnit, loc), loc), loc) + val (c', k, gs') = elabCon (env, denv) c - val uniques = cunif (loc, (L'.KRecord (L'.KRecord (L'.KUnit, loc), loc), loc)) + val pkey = cunif (loc, cstK) + val uniques = cunif (loc, cstK) val ct = tableOf () val ct = (L'.CApp (ct, c'), loc) - val ct = (L'.CApp (ct, uniques), loc) + val ct = (L'.CApp (ct, (L'.CConcat (pkey, uniques), loc)), loc) val (env, n) = E.pushENamed env x ct - val (e', et, gs'') = elabExp (env, denv) e + val (pe', pet, gs'') = elabExp (env, denv) pe + val (ce', cet, gs''') = elabExp (env, denv) ce + + val pst = (L'.CModProj (!basis_r, [], "primary_key"), loc) + val pst = (L'.CApp (pst, c'), loc) + val pst = (L'.CApp (pst, pkey), loc) val cst = (L'.CModProj (!basis_r, [], "sql_constraints"), loc) val cst = (L'.CApp (cst, c'), loc) val cst = (L'.CApp (cst, uniques), loc) in checkKind env c' k (L'.KRecord (L'.KType, loc), loc); - checkCon env e' et cst; - ([(L'.DTable (!basis_r, x, n, c', e', uniques), loc)], (env, denv, gs'' @ enD gs' @ gs)) + checkCon env pe' pet pst; + checkCon env ce' cet cst; + ([(L'.DTable (!basis_r, x, n, c', pe', pkey, ce', uniques), loc)], + (env, denv, gs''' @ gs'' @ enD gs' @ gs)) end | L.DSequence x => let diff --git a/src/expl.sml b/src/expl.sml index 6cd9b7a8..b9cbdaf1 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -141,7 +141,7 @@ datatype decl' = | DStr of string * int * sgn * str | DFfiStr of string * int * sgn | DExport of int * sgn * str - | DTable of int * string * int * con * exp * con + | DTable of int * string * int * con * exp * con * exp * con | DSequence of int * string * int | DDatabase of string | DCookie of int * string * int * con diff --git a/src/expl_env.sml b/src/expl_env.sml index 31b1c0a3..64f4edc4 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -298,11 +298,11 @@ fun declBinds env (d, loc) = | DStr (x, n, sgn, _) => pushStrNamed env x n sgn | DFfiStr (x, n, sgn) => pushStrNamed env x n sgn | DExport _ => env - | DTable (tn, x, n, c, _, cc) => + | DTable (tn, x, n, c, _, pc, _, cc) => let val ct = (CModProj (tn, [], "sql_table"), loc) val ct = (CApp (ct, c), loc) - val ct = (CApp (ct, cc), loc) + val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc) in pushENamed env x n ct end diff --git a/src/expl_print.sml b/src/expl_print.sml index 05d68941..84002c00 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -663,17 +663,21 @@ fun p_decl env (dAll as (d, _) : decl) = string ":", space, p_sgn env sgn] - | DTable (_, x, n, c, e, _) => box [string "table", - space, - p_named x n, - space, - string ":", - space, - p_con env c, - space, - string "constraints", - space, - p_exp env e] + | DTable (_, x, n, c, pe, _, ce, _) => box [string "table", + space, + p_named x n, + space, + string ":", + space, + p_con env c, + space, + string "keys", + space, + p_exp env pe, + space, + string "constraints", + space, + p_exp env ce] | DSequence (_, x, n) => box [string "sequence", space, p_named x n] diff --git a/src/explify.sml b/src/explify.sml index fa35bd0d..01a57d2e 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -178,7 +178,10 @@ fun explifyDecl (d, loc : EM.span) = | L.DFfiStr (x, n, sgn) => SOME (L'.DFfiStr (x, n, explifySgn sgn), loc) | L.DConstraint (c1, c2) => NONE | L.DExport (en, sgn, str) => SOME (L'.DExport (en, explifySgn sgn, explifyStr str), loc) - | L.DTable (nt, x, n, c, e, cc) => SOME (L'.DTable (nt, x, n, explifyCon c, explifyExp e, explifyCon cc), loc) + | L.DTable (nt, x, n, c, pe, pc, ce, cc) => + SOME (L'.DTable (nt, x, n, explifyCon c, + explifyExp pe, explifyCon pc, + explifyExp ce, explifyCon cc), loc) | L.DSequence (nt, x, n) => SOME (L'.DSequence (nt, x, n), loc) | L.DClass (x, n, k, c) => SOME (L'.DCon (x, n, (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), explifyCon c), loc) diff --git a/src/mono.sml b/src/mono.sml index 5a65a9f9..35db52bd 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -121,7 +121,7 @@ datatype decl' = | DValRec of (string * int * typ * exp * string) list | DExport of Core.export_kind * string * int * typ list * typ - | DTable of string * (string * typ) list * exp + | DTable of string * (string * typ) list * exp * exp | DSequence of string | DDatabase of {name : string, expunge : int, initialize : int} diff --git a/src/mono_print.sml b/src/mono_print.sml index 935f8368..c75e81ba 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -403,22 +403,26 @@ fun p_decl env (dAll as (d, _) : decl) = space, p_typ env t] - | DTable (s, xts, e) => box [string "(* SQL table ", - string s, - space, - string ":", - space, - p_list (fn (x, t) => box [string x, - space, - string ":", - space, - p_typ env t]) xts, - space, - string "constraints", - space, - p_exp env e, - space, - string "*)"] + | DTable (s, xts, pe, ce) => box [string "(* SQL table ", + string s, + space, + string ":", + space, + p_list (fn (x, t) => box [string x, + space, + string ":", + space, + p_typ env t]) xts, + space, + string "keys", + space, + p_exp env pe, + space, + string "constraints", + space, + p_exp env ce, + space, + string "*)"] | DSequence s => box [string "(* SQL sequence ", string s, string "*)"] diff --git a/src/mono_util.sml b/src/mono_util.sml index ca5cf5cb..485e64f6 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -465,10 +465,12 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = S.map2 (mft t, fn t' => (DExport (ek, s, n, ts', t'), loc))) - | DTable (s, xts, e) => - S.map2 (mfe ctx e, - fn e' => - (DTable (s, xts, e'), loc)) + | DTable (s, xts, pe, ce) => + S.bind2 (mfe ctx pe, + fn pe' => + S.map2 (mfe ctx ce, + fn ce' => + (DTable (s, xts, pe', ce'), loc))) | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll | DJavaScript _ => S.return2 dAll diff --git a/src/monoize.sml b/src/monoize.sml index 057a9222..2e514b4e 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -149,6 +149,8 @@ fun monoType env = (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "primary_key"), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraints"), _), _), _), _) => (L'.TFfi ("Basis", "sql_constraints"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _), _), _) => @@ -1159,6 +1161,25 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end + | L.ECApp ((L.EFfi ("Basis", "no_primary_key"), _), _) => + ((L'.EPrim (Prim.String ""), loc), + fm) + | L.ECApp ( + (L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "primary_key"), _), _), _), t), _), + nm), _), + (L.CRecord (_, unique), _)) => + let + val unique = (nm, t) :: unique + val witnesses = (L'.TRecord (map (fn (nm, _) => (monoName env nm, (L'.TRecord [], loc))) unique), loc) + in + ((L'.EAbs ("_", witnesses, (L'.TFfi ("Basis", "string"), loc), + (L'.EPrim (Prim.String + (String.concatWith ", " + (map (fn (x, _) => "uw_" ^ monoName env x) unique))), + loc)), loc), + fm) + end + | L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) => ((L'.ERecord [], loc), fm) @@ -2499,7 +2520,7 @@ fun monoDecl (env, fm) (all as (d, loc)) = in SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)]) end - | L.DTable (x, n, (L.CRecord (_, xts), _), s, e, _) => + | L.DTable (x, n, (L.CRecord (_, xts), _), s, pe, _, ce, _) => let val t = (L.CFfi ("Basis", "string"), loc) val t' = (L'.TFfi ("Basis", "string"), loc) @@ -2508,11 +2529,12 @@ fun monoDecl (env, fm) (all as (d, loc)) = val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts - val (e, fm) = monoExp (env, St.empty, fm) e + val (pe, fm) = monoExp (env, St.empty, fm) pe + val (ce, fm) = monoExp (env, St.empty, fm) ce in SOME (Env.pushENamed env x n t NONE s, fm, - [(L'.DTable (s, xts, e), loc), + [(L'.DTable (s, xts, pe, ce), loc), (L'.DVal (x, n, t', e_name, s), loc)]) end | L.DTable _ => poly () @@ -2633,7 +2655,7 @@ fun monoize env file = in foldl (fn ((d, _), e) => case d of - L.DTable (_, _, xts, tab, _, _) => doTable (tab, #1 xts, e) + L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e) | _ => e) e file end @@ -2678,7 +2700,7 @@ fun monoize env file = in foldl (fn ((d, _), e) => case d of - L.DTable (_, _, xts, tab, _, _) => doTable (tab, #1 xts, e) + L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e) | _ => e) e file end diff --git a/src/pathcheck.sml b/src/pathcheck.sml index 6771e628..3f4f6be4 100644 --- a/src/pathcheck.sml +++ b/src/pathcheck.sml @@ -55,7 +55,7 @@ fun checkDecl ((d, loc), (funcs, rels)) = case d of DExport (_, s, _, _, _) => doFunc s - | DTable (s, _, e) => + | DTable (s, _, pe, ce) => let fun constraints (e, rels) = case #1 e of @@ -71,8 +71,22 @@ fun checkDecl ((d, loc), (funcs, rels)) = end | EStrcat (e1, e2) => constraints (e2, constraints (e1, rels)) | _ => rels + + val rels = #2 (doRel s) + val rels = case #1 pe of + EPrim (Prim.String "") => rels + | _ => + let + val s' = s ^ "_Pkey" + in + if SS.member (rels, s') then + E.errorAt loc ("Duplicate primary key constraint path " ^ s') + else + (); + SS.add (rels, s') + end in - (funcs, constraints (e, #2 (doRel s))) + (funcs, constraints (ce, rels)) end | DSequence s => doRel s diff --git a/src/reduce.sml b/src/reduce.sml index d6357f1b..25cc6274 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -461,9 +461,11 @@ fun reduce file = ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC [] t, exp (namedC, namedE) [] e, s)) vis), loc), st) | DExport _ => (d, st) - | DTable (s, n, c, s', e, cc) => ((DTable (s, n, con namedC [] c, s', - exp (namedC, namedE) [] e, - con namedC [] cc), loc), st) + | DTable (s, n, c, s', pe, pc, ce, cc) => ((DTable (s, n, con namedC [] c, s', + exp (namedC, namedE) [] pe, + con namedC [] pc, + exp (namedC, namedE) [] ce, + con namedC [] cc), loc), st) | DSequence _ => (d, st) | DDatabase _ => (d, st) | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st) diff --git a/src/shake.sml b/src/shake.sml index 19204ebb..378e8276 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -59,9 +59,10 @@ fun shake file = val (usedE, usedC, table_cs) = List.foldl (fn ((DExport (_, n), _), (usedE, usedC, table_cs)) => (IS.add (usedE, n), usedE, table_cs) - | ((DTable (_, _, c, _, e, _), _), (usedE, usedC, table_cs)) => + | ((DTable (_, _, c, _, pe, _, ce, _), _), (usedE, usedC, table_cs)) => let - val (usedE, usedC) = usedVars (usedE, usedC) e + val (usedE, usedC) = usedVars (usedE, usedC) pe + val (usedE, usedC) = usedVars (usedE, usedC) ce in (usedE, usedC, c :: table_cs) end @@ -79,7 +80,7 @@ fun shake file = IM.insert (edef, n, (all_ns, t, e))) edef vis) end | ((DExport _, _), acc) => acc - | ((DTable (_, n, c, _, _, _), _), (cdef, edef)) => + | ((DTable (_, n, c, _, _, _, _, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DSequence (_, n, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], dummyt, dummye))) diff --git a/src/source.sml b/src/source.sml index 0dca39ab..3bd8e22a 100644 --- a/src/source.sml +++ b/src/source.sml @@ -88,7 +88,7 @@ datatype sgn_item' = | SgiDatatype of string * string list * (string * con option) list | SgiDatatypeImp of string * string list * string | SgiVal of string * con - | SgiTable of string * con * exp + | SgiTable of string * con * exp * exp | SgiStr of string * sgn | SgiSgn of string * sgn | SgiInclude of sgn @@ -146,8 +146,6 @@ and pat = pat' located and exp = exp' located and edecl = edecl' located - - datatype decl' = DCon of string * kind option * con | DDatatype of string * string list * (string * con option) list @@ -161,7 +159,7 @@ datatype decl' = | DConstraint of con * con | DOpenConstraints of string * string list | DExport of str - | DTable of string * con * exp + | DTable of string * con * exp * exp | DSequence of string | DClass of string * kind * con | DDatabase of string diff --git a/src/source_print.sml b/src/source_print.sml index c145dc63..94a175ac 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -417,17 +417,21 @@ fun p_sgn_item (sgi, _) = string ":", space, p_con c] - | SgiTable (x, c, e) => box [string "table", - space, - string x, - space, - string ":", - space, - p_con c, - space, - string "constraints", - space, - p_exp e] + | SgiTable (x, c, pe, ce) => box [string "table", + space, + string x, + space, + string ":", + space, + p_con c, + space, + string "keys", + space, + p_exp pe, + space, + string "constraints", + space, + p_exp ce] | SgiStr (x, sgn) => box [string "structure", space, string x, @@ -599,17 +603,21 @@ fun p_decl ((d, _) : decl) = | DExport str => box [string "export", space, p_str str] - | DTable (x, c, e) => box [string "table", - space, - string x, - space, - string ":", - space, - p_con c, - space, - string "constraints", - space, - p_exp e] + | DTable (x, c, pe, ce) => box [string "table", + space, + string x, + space, + string ":", + space, + p_con c, + space, + string "keys", + space, + p_exp pe, + space, + string "constraints", + space, + p_exp ce] | DSequence x => box [string "sequence", space, string x] diff --git a/src/urweb.grm b/src/urweb.grm index 0f4b58d7..a507e52e 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -208,7 +208,7 @@ fun tagIn bt = | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS | CURRENT_TIMESTAMP | NE | LT | LE | GT | GE - | CCONSTRAINT | UNIQUE + | CCONSTRAINT | UNIQUE | PRIMARY | KEY %nonterm file of decl list @@ -223,6 +223,9 @@ fun tagIn bt = | dcons of (string * con option) list | dcon of string * con option + | pkopt of exp + | commaOpt of unit + | cst of exp | csts of exp | cstopt of exp @@ -418,7 +421,8 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let | m :: ms => [(DOpenConstraints (m, ms), s (OPENleft, mpathright))]) | CONSTRAINT cterm TWIDDLE cterm ([(DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))]) | EXPORT spath ([(DExport spath, s (EXPORTleft, spathright))]) - | TABLE SYMBOL COLON cterm cstopt([(DTable (SYMBOL, entable cterm, cstopt), s (TABLEleft, cstoptright))]) + | TABLE SYMBOL COLON cterm pkopt commaOpt cstopt([(DTable (SYMBOL, entable cterm, pkopt, cstopt), + s (TABLEleft, cstoptright))]) | SEQUENCE SYMBOL ([(DSequence SYMBOL, s (SEQUENCEleft, SYMBOLright))]) | CLASS SYMBOL EQ cexp (let val loc = s (CLASSleft, cexpright) @@ -513,6 +517,27 @@ tnames : tnameW (tnameW, []) tnames': tnameW (tnameW, []) | tnameW COMMA tnames' (#1 tnames', tnameW :: #2 tnames') +commaOpt: () + | COMMA () + +pkopt : (EVar (["Basis"], "no_primary_key", Infer), ErrorMsg.dummySpan) + | PRIMARY KEY tnames (let + val loc = s (PRIMARYleft, tnamesright) + + val e = (EVar (["Basis"], "primary_key", Infer), loc) + val e = (ECApp (e, #1 (#1 tnames)), loc) + val e = (ECApp (e, (CRecord (#2 tnames), loc)), loc) + val e = (EDisjointApp e, loc) + val e = (EDisjointApp e, loc) + + val witness = map (fn (c, _) => + (c, (EWild, loc))) + (#1 tnames :: #2 tnames) + val witness = (ERecord witness, loc) + in + (EApp (e, witness), loc) + end) + valis : vali ([vali]) | vali AND valis (vali :: valis) @@ -554,11 +579,11 @@ sgi : CON SYMBOL DCOLON kind ((SgiConAbs (SYMBOL, kind), s (CONleft, s (FUNCTORleft, sgn2right))) | INCLUDE sgn ((SgiInclude sgn, s (INCLUDEleft, sgnright))) | CONSTRAINT cterm TWIDDLE cterm ((SgiConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))) - | TABLE SYMBOL COLON cterm cstopt(let - val loc = s (TABLEleft, ctermright) - in - (SgiTable (SYMBOL, entable cterm, cstopt), loc) - end) + | TABLE SYMBOL COLON cterm pkopt commaOpt cstopt (let + val loc = s (TABLEleft, ctermright) + in + (SgiTable (SYMBOL, entable cterm, pkopt, cstopt), loc) + end) | SEQUENCE SYMBOL (let val loc = s (SEQUENCEleft, SYMBOLright) val t = (CVar (["Basis"], "sql_sequence"), loc) diff --git a/src/urweb.lex b/src/urweb.lex index 735d230d..31c0a362 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -367,6 +367,8 @@ notags = [^<{\n]+; "CONSTRAINT"=> (Tokens.CCONSTRAINT (pos yypos, pos yypos + size yytext)); "UNIQUE" => (Tokens.UNIQUE (pos yypos, pos yypos + size yytext)); + "PRIMARY" => (Tokens.PRIMARY (pos yypos, pos yypos + size yytext)); + "KEY" => (Tokens.KEY (pos yypos, pos yypos + size yytext)); "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext)); diff --git a/tests/cst.ur b/tests/cst.ur index 0ebcc977..fc3b0816 100644 --- a/tests/cst.ur +++ b/tests/cst.ur @@ -1,4 +1,6 @@ table t : {A : int, B : int} + PRIMARY KEY B, + CONSTRAINT UniA UNIQUE A, CONSTRAINT UniB UNIQUE B, CONSTRAINT UniBoth UNIQUE (A, B), diff --git a/tests/pkey.ur b/tests/pkey.ur new file mode 100644 index 00000000..4efbd032 --- /dev/null +++ b/tests/pkey.ur @@ -0,0 +1,6 @@ +table t : {A : int, B : int} + PRIMARY KEY (A, B) + +fun main () : transaction page = + queryI (SELECT * FROM t) (fn _ => return ()); + return diff --git a/tests/pkey.urp b/tests/pkey.urp new file mode 100644 index 00000000..40ff2589 --- /dev/null +++ b/tests/pkey.urp @@ -0,0 +1,5 @@ +debug +database dbname=pkey +sql pkey.sql + +pkey -- cgit v1.2.3 From a75aaa90b3b827f9ef002491bc081df36260f136 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 9 Apr 2009 12:31:56 -0400 Subject: Made type class system very general; demo compiles --- lib/ur/basis.urs | 2 +- src/elab_env.sig | 1 + src/elab_env.sml | 552 +++++++++++++++++++++--------------------------------- src/elab_err.sml | 12 +- src/elab_util.sig | 4 + src/elab_util.sml | 19 +- src/elaborate.sml | 45 ++--- src/urweb.grm | 3 +- 8 files changed, 264 insertions(+), 374 deletions(-) (limited to 'src/elab_env.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index d69ddfcb..87f20d6b 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -71,7 +71,7 @@ val read_time : read time (** * Monads *) -class monad :: Type -> Type +class monad :: (Type -> Type) -> Type val return : m ::: (Type -> Type) -> t ::: Type -> monad m -> t -> m t diff --git a/src/elab_env.sig b/src/elab_env.sig index 10d11e3b..4b927a16 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -72,6 +72,7 @@ signature ELAB_ENV = sig val pushClass : env -> int -> env val isClass : env -> Elab.con -> bool val resolveClass : env -> Elab.con -> Elab.exp option + val listClasses : env -> (Elab.con * (Elab.con * Elab.exp) list) list val pushERel : env -> string -> Elab.con -> env val lookupERel : env -> int -> string * Elab.con diff --git a/src/elab_env.sml b/src/elab_env.sml index 8da78375..1c3eb62e 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -162,6 +162,11 @@ datatype class_name = ClNamed of int | ClProj of int * string list * string +fun class_name_out cn = + case cn of + ClNamed n => (CNamed n, ErrorMsg.dummySpan) + | ClProj x => (CModProj x, ErrorMsg.dummySpan) + fun cn2s cn = case cn of ClNamed n => "Named(" ^ Int.toString n ^ ")" @@ -185,71 +190,10 @@ end structure CS = BinarySetFn(CK) structure CM = BinaryMapFn(CK) -datatype class_key = - CkNamed of int - | CkRel of int - | CkProj of int * string list * string - | CkApp of class_key * class_key - | CkOther of con - -fun ck2s ck = - case ck of - CkNamed n => "Named(" ^ Int.toString n ^ ")" - | CkRel n => "Rel(" ^ Int.toString n ^ ")" - | CkProj (m, ms, x) => "Proj(" ^ Int.toString m ^ "," ^ String.concatWith "," ms ^ "," ^ x ^ ")" - | CkApp (ck1, ck2) => "App(" ^ ck2s ck1 ^ ", " ^ ck2s ck2 ^ ")" - | CkOther _ => "Other" - -type class_key_n = class_key * int - -fun ckn2s (ck, n) = ck2s ck ^ "[" ^ Int.toString n ^ "]" - -fun cp2s (cn, ck) = "(" ^ cn2s cn ^ "," ^ ck2s ck ^ ")" - -structure KK = struct -type ord_key = class_key_n -open Order -fun compare' x = - case x of - (CkNamed n1, CkNamed n2) => Int.compare (n1, n2) - | (CkNamed _, _) => LESS - | (_, CkNamed _) => GREATER - - | (CkRel n1, CkRel n2) => Int.compare (n1, n2) - | (CkRel _, _) => LESS - | (_, CkRel _) => GREATER - - | (CkProj (m1, ms1, x1), CkProj (m2, ms2, x2)) => - join (Int.compare (m1, m2), - fn () => join (joinL String.compare (ms1, ms2), - fn () => String.compare (x1, x2))) - | (CkProj _, _) => LESS - | (_, CkProj _) => GREATER - - | (CkApp (f1, x1), CkApp (f2, x2)) => - join (compare' (f1, f2), - fn () => compare' (x1, x2)) - | (CkApp _, _) => LESS - | (_, CkApp _) => GREATER - - | (CkOther _, CkOther _) => EQUAL -fun compare ((k1, n1), (k2, n2)) = - join (Int.compare (n1, n2), - fn () => compare' (k1, k2)) -end - -structure KM = BinaryMapFn(KK) - -type class = {ground : ((class_name * class_key) list * exp) KM.map, - inclusions : exp CM.map} -val empty_class = {ground = KM.empty, - inclusions = CM.empty} - -fun printClasses cs = (print "Classes:\n"; - CM.appi (fn (cn, {ground = km, ...} : class) => - (print (cn2s cn ^ ":"); - KM.appi (fn (ck, _) => print (" " ^ ckn2s ck)) km; - print "\n")) cs) +type class = {ground : (con * exp) list, + rules : (int * con list * con * exp) list} +val empty_class = {ground = [], + rules = []} type env = { renameK : int SM.map, @@ -309,16 +253,6 @@ val empty = { str = IM.empty } -fun liftClassKey' ck = - case ck of - CkNamed _ => ck - | CkRel n => CkRel (n + 1) - | CkProj _ => ck - | CkApp (ck1, ck2) => CkApp (liftClassKey' ck1, liftClassKey' ck2) - | CkOther c => CkOther (lift c) - -fun liftClassKey (ck, n) = (liftClassKey' ck, n) - fun pushKRel (env : env) x = let val renameK = SM.map (fn n => n+1) (#renameK env) @@ -334,7 +268,12 @@ fun pushKRel (env : env) x = datatypes = #datatypes env, constructors = #constructors env, - classes = #classes env, + classes = CM.map (fn cl => {ground = map (fn (c, e) => + (liftKindInCon 0 c, + e)) + (#ground cl), + rules = #rules cl}) + (#classes env), renameE = SM.map (fn Rel' (n, c) => Rel' (n, liftKindInCon 0 c) | Named' (n, c) => Named' (n, c)) (#renameE env), @@ -371,10 +310,11 @@ fun pushCRel (env : env) x k = constructors = #constructors env, classes = CM.map (fn class => - {ground = KM.foldli (fn (ck, e, km) => - KM.insert (km, liftClassKey ck, e)) - KM.empty (#ground class), - inclusions = #inclusions class}) + {ground = map (fn (c, e) => + (liftConInCon 0 c, + e)) + (#ground class), + rules = #rules class}) (#classes env), renameE = SM.map (fn Rel' (n, c) => Rel' (n, lift c) @@ -482,6 +422,23 @@ fun lookupConstructor (env : env) s = SM.find (#constructors env, s) fun datatypeArgs (xs, _) = xs fun constructors (_, dt) = IM.foldri (fn (n, (x, to), ls) => (x, n, to) :: ls) [] dt +fun listClasses (env : env) = + map (fn (cn, {ground, rules}) => + (class_name_out cn, + ground + @ map (fn (nvs, cs, c, e) => + let + val loc = #2 c + val c = foldr (fn (c', c) => (TFun (c', c), loc)) c cs + val c = ListUtil.foldli (fn (n, (), c) => (TCFun (Explicit, + "x" ^ Int.toString n, + (KError, loc), + c), loc)) + c (List.tabulate (nvs, fn _ => ())) + in + (c, e) + end) rules)) (CM.listItemsi (#classes env)) + fun pushClass (env : env) n = {renameK = #renameK env, relK = #relK env, @@ -520,133 +477,169 @@ fun isClass (env : env) c = find (class_name_in c) end -fun class_key_in (all as (c, _)) = - case c of - CRel n => CkRel n - | CNamed n => CkNamed n - | CModProj x => CkProj x - | CUnif (_, _, _, ref (SOME c)) => class_key_in c - | CApp (c1, c2) => CkApp (class_key_in c1, class_key_in c2) - | _ => CkOther all - -fun class_key_out loc = +fun class_head_in c = + case #1 c of + CApp (f, _) => class_head_in f + | CUnif (_, _, _, ref (SOME c)) => class_head_in c + | _ => class_name_in c + +exception Unify + +fun unifyKinds (k1, k2) = + case (#1 k1, #1 k2) of + (KType, KType) => () + | (KArrow (d1, r1), KArrow (d2, r2)) => (unifyKinds (d1, d2); unifyKinds (r1, r2)) + | (KName, KName) => () + | (KRecord k1, KRecord k2) => unifyKinds (k1, k2) + | (KUnit, KUnit) => () + | (KTuple ks1, KTuple ks2) => (ListPair.appEq unifyKinds (ks1, ks2) + handle ListPair.UnequalLengths => raise Unify) + | (KUnif (_, _, ref (SOME k1)), _) => unifyKinds (k1, k2) + | (_, KUnif (_, _, ref (SOME k2))) => unifyKinds (k1, k2) + | (KRel n1, KRel n2) => if n1 = n2 then () else raise Unify + | (KFun (_, k1), KFun (_, k2)) => unifyKinds (k1, k2) + | _ => raise Unify + +fun unifyCons rs = let - fun cko k = - case k of - CkRel n => (CRel n, loc) - | CkNamed n => (CNamed n, loc) - | CkProj x => (CModProj x, loc) - | CkApp (k1, k2) => (CApp (cko k1, cko k2), loc) - | CkOther c => c + fun unify d (c1, c2) = + case (#1 c1, #1 c2) of + (CUnif (_, _, _, ref (SOME c1)), _) => unify d (c1, c2) + | (_, CUnif (_, _, _, ref (SOME c2))) => unify d (c1, c2) + + | (c1', CRel n2) => + if n2 < d then + case c1' of + CRel n1 => if n1 = n2 then () else raise Unify + | _ => raise Unify + else if n2 - d >= length rs then + case c1' of + CRel n1 => if n1 = n2 - length rs then () else raise Unify + | _ => raise Unify + else + let + val r = List.nth (rs, n2 - d) + in + case !r of + NONE => r := SOME c1 + | SOME c2 => unify d (c1, c2) + end + + | (TFun (d1, r1), TFun (d2, r2)) => (unify d (d1, d2); unify d (r1, r2)) + | (TCFun (_, _, k1, r1), TCFun (_, _, k2, r2)) => (unifyKinds (k1, k2); unify (d + 1) (r1, r2)) + | (TRecord c1, TRecord c2) => unify d (c1, c2) + | (TDisjoint (a1, b1, c1), TDisjoint (a2, b2, c2)) => + (unify d (a1, a2); unify d (b1, b2); unify d (c1, c2)) + + | (CNamed n1, CNamed n2) => if n1 = n2 then () else raise Unify + | (CModProj (n1, ms1, x1), CModProj (n2, ms2, x2)) => + if n1 = n2 andalso ms1 = ms2 andalso x1 = x2 then () else raise Unify + | (CApp (f1, x1), CApp (f2, x2)) => (unify d (f1, f2); unify d (x1, x2)) + | (CAbs (_, k1, b1), CAbs (_, k2, b2)) => (unifyKinds (k1, k2); unify (d + 1) (b1, b2)) + + | (CKAbs (_, b1), CKAbs (_, b2)) => unify d (b1, b2) + | (CKApp (c1, k1), CKApp (c2, k2)) => (unify d (c1, c2); unifyKinds (k1, k2)) + | (TKFun (_, c1), TKFun (_, c2)) => unify d (c1, c2) + + | (CName s1, CName s2) => if s1 = s2 then () else raise Unify + + | (CRecord (k1, xcs1), CRecord (k2, xcs2)) => + (unifyKinds (k1, k2); + ListPair.appEq (fn ((x1, c1), (x2, c2)) => (unify d (x1, x2); unify d (c1, c2))) (xcs1, xcs2) + handle ListPair.UnequalLengths => raise Unify) + | (CConcat (f1, x1), CConcat (f2, x2)) => (unify d (f1, f2); unify d (x1, x2)) + | (CMap (d1, r1), CMap (d2, r2)) => (unifyKinds (d1, d2); unifyKinds (r1, r2)) + + | (CUnit, CUnit) => () + + | (CTuple cs1, CTuple cs2) => (ListPair.appEq (unify d) (cs1, cs2) + handle ListPair.UnequalLengths => raise Unify) + | (CProj (c1, n1), CProj (c2, n2)) => (unify d (c1, c2); + if n1 = n2 then () else raise Unify) + + | _ => raise Unify in - cko + unify end -fun class_pair_in (c, _) = - case c of - CApp (f, x) => - (case class_name_in f of - SOME f => SOME (f, class_key_in x) - | _ => NONE) - | CUnif (_, _, _, ref (SOME c)) => class_pair_in c - | _ => NONE - -fun sub_class_key (n, c) = +fun tryUnify nRs (c1, c2) = let - fun csk k = - case k of - CkRel n' => SOME (if n' = n then - c - else - k) - | CkNamed _ => SOME k - | CkProj _ => SOME k - | CkApp (k1, k2) => - (case (csk k1, csk k2) of - (SOME k1, SOME k2) => SOME (CkApp (k1, k2)) - | _ => NONE) - | CkOther _ => NONE + val rs = List.tabulate (nRs, fn _ => ref NONE) in - csk + (unifyCons rs 0 (c1, c2); + SOME (map (fn r => case !r of + NONE => raise Unify + | SOME c => c) rs)) + handle Unify => NONE end -fun resolveClass (env : env) c = +fun unifySubst (rs : con list) = + U.Con.mapB {kind = fn _ => fn k => k, + con = fn d => fn c => + case c of + CRel n => + if n < d then + c + else + #1 (List.nth (rs, n - d)) + | _ => c, + bind = fn (d, U.Con.RelC _) => d + 1 + | (d, _) => d} + 0 + +fun resolveClass (env : env) = let - fun doPair (f, x) = - case CM.find (#classes env, f) of - NONE => NONE - | SOME class => - let - val loc = #2 c - - fun tryIncs () = + fun resolve c = + let + fun doHead f = + case CM.find (#classes env, f) of + NONE => NONE + | SOME class => let - fun tryIncs fs = - case fs of + val loc = #2 c + + fun tryRules rules = + case rules of [] => NONE - | (f', e') :: fs => - case doPair (f', x) of - NONE => tryIncs fs - | SOME e => + | (nRs, cs, c', e) :: rules' => + case tryUnify nRs (c, c') of + NONE => tryRules rules' + | SOME rs => let - val e' = (ECApp (e', class_key_out loc x), loc) - val e' = (EApp (e', e), loc) + val eos = map (resolve o unifySubst rs) cs in - SOME e' + if List.exists (not o Option.isSome) eos then + tryRules rules' + else + let + val es = List.mapPartial (fn x => x) eos + + val e = foldr (fn (c, e) => (ECApp (e, c), loc)) e rs + val e = foldl (fn (e', e) => (EApp (e, e'), loc)) e es + in + SOME e + end end - in - tryIncs (CM.listItemsi (#inclusions class)) - end - fun tryRules (k, args) = - let - val len = length args - - fun tryNext () = - case k of - CkApp (k1, k2) => tryRules (k1, k2 :: args) - | _ => tryIncs () + fun rules () = tryRules (#rules class) + + fun tryGrounds ces = + case ces of + [] => rules () + | (c', e) :: ces' => + case tryUnify 0 (c, c') of + NONE => tryGrounds ces' + | SOME _ => SOME e in - case KM.find (#ground class, (k, length args)) of - SOME (cs, e) => - let - val es = map (fn (cn, ck) => - let - val ck = ListUtil.foldli (fn (i, arg, ck) => - case ck of - NONE => NONE - | SOME ck => - sub_class_key (len - i - 1, - arg) - ck) - (SOME ck) args - in - case ck of - NONE => NONE - | SOME ck => doPair (cn, ck) - end) cs - in - if List.exists (not o Option.isSome) es then - tryNext () - else - let - val e = foldl (fn (arg, e) => (ECApp (e, class_key_out loc arg), loc)) - e args - val e = foldr (fn (pf, e) => (EApp (e, pf), loc)) - e (List.mapPartial (fn x => x) es) - in - SOME e - end - end - | NONE => tryNext () + tryGrounds (#ground class) end - in - tryRules (x, []) - end + in + case class_head_in c of + SOME f => doHead f + | _ => NONE + end in - case class_pair_in c of - SOME p => doPair p - | _ => NONE + resolve end fun pushERel (env : env) x t = @@ -655,17 +648,17 @@ fun pushERel (env : env) x t = | x => x) (#renameE env) val classes = CM.map (fn class => - {ground = KM.map (fn (ps, e) => (ps, liftExp e)) (#ground class), - inclusions = #inclusions class}) (#classes env) - val classes = case class_pair_in t of + {ground = map (fn (c, e) => (c, liftExp e)) (#ground class), + rules = #rules class}) (#classes env) + val classes = case class_head_in t of NONE => classes - | SOME (f, x) => + | SOME f => case CM.find (classes, f) of NONE => classes | SOME class => let - val class = {ground = KM.insert (#ground class, (x, 0), ([], (ERel 0, #2 t))), - inclusions = #inclusions class} + val class = {ground = (t, (ERel 0, #2 t)) :: #ground class, + rules = #rules class} in CM.insert (classes, f, class) end @@ -697,16 +690,6 @@ fun lookupERel (env : env) n = (List.nth (#relE env, n)) handle Subscript => raise UnboundRel n -datatype rule = - Normal of int * (class_name * class_key) list * class_key - | Inclusion of class_name - -fun containsOther k = - case k of - CkOther _ => true - | CkApp (k1, k2) => containsOther k1 orelse containsOther k2 - | _ => false - fun rule_in c = let fun quantifiers (c, nvars) = @@ -717,68 +700,18 @@ fun rule_in c = fun clauses (c, hyps) = case #1 c of TFun (hyp, c) => - (case class_pair_in hyp of - SOME (p as (_, CkRel _)) => clauses (c, p :: hyps) - | _ => NONE) + (case class_head_in hyp of + SOME _ => clauses (c, hyp :: hyps) + | NONE => NONE) | _ => - case class_pair_in c of + case class_head_in c of NONE => NONE - | SOME (cn, ck) => - let - fun dearg (ck, i) = - if i >= nvars then - if containsOther ck - orelse List.exists (fn (_, k) => containsOther k) hyps then - NONE - else - SOME (cn, Normal (nvars, hyps, ck)) - else case ck of - CkApp (ck, CkRel i') => - if i' = i then - dearg (ck, i + 1) - else - NONE - | _ => NONE - in - dearg (ck, 0) - end + | SOME f => SOME (f, nvars, rev hyps, c) in clauses (c, []) end in - case #1 c of - TCFun (_, _, _, (TFun ((CApp (f1, (CRel 0, _)), _), - (CApp (f2, (CRel 0, _)), _)), _)) => - (case (class_name_in f1, class_name_in f2) of - (SOME f1, SOME f2) => SOME (f2, Inclusion f1) - | _ => NONE) - | _ => quantifiers (c, 0) - end - -fun inclusion (classes : class CM.map, init, inclusions, f, e : exp) = - let - fun search (f, fs) = - if f = init then - NONE - else if CS.member (fs, f) then - SOME fs - else - let - val fs = CS.add (fs, f) - in - case CM.find (classes, f) of - NONE => SOME fs - | SOME {inclusions = fs', ...} => - CM.foldli (fn (f', _, fs) => - case fs of - NONE => NONE - | SOME fs => search (f', fs)) (SOME fs) fs' - end - in - case search (f, CS.empty) of - SOME _ => CM.insert (inclusions, f, e) - | NONE => (ErrorMsg.errorAt (#2 e) "Type class inclusion would create a cycle"; - inclusions) + quantifiers (c, 0) end fun pushENamedAs (env : env) x n t = @@ -786,7 +719,7 @@ fun pushENamedAs (env : env) x n t = val classes = #classes env val classes = case rule_in t of NONE => classes - | SOME (f, rule) => + | SOME (f, nvs, cs, c) => case CM.find (classes, f) of NONE => classes | SOME class => @@ -794,13 +727,8 @@ fun pushENamedAs (env : env) x n t = val e = (ENamed n, #2 t) val class = - case rule of - Normal (nvars, hyps, x) => - {ground = KM.insert (#ground class, (x, nvars), (hyps, e)), - inclusions = #inclusions class} - | Inclusion f' => - {ground = #ground class, - inclusions = inclusion (classes, f, #inclusions class, f', e)} + {ground = #ground class, + rules = (nvs, cs, c, e) :: #rules class} in CM.insert (classes, f, class) end @@ -985,31 +913,6 @@ fun sgnS_con' (arg as (m1, ms', (sgns, strs, cons))) c = (sgnS_con' arg (#1 c2), #2 c2)) | _ => c -fun sgnS_class_name (arg as (m1, ms', (sgns, strs, cons))) nm = - case nm of - ClProj (m1, ms, x) => - (case IM.find (strs, m1) of - NONE => nm - | SOME m1x => ClProj (m1, ms' @ m1x :: ms, x)) - | ClNamed n => - (case IM.find (cons, n) of - NONE => nm - | SOME nx => ClProj (m1, ms', nx)) - -fun sgnS_class_key (arg as (m1, ms', (sgns, strs, cons))) k = - case k of - CkProj (m1, ms, x) => - (case IM.find (strs, m1) of - NONE => k - | SOME m1x => CkProj (m1, ms' @ m1x :: ms, x)) - | CkNamed n => - (case IM.find (cons, n) of - NONE => k - | SOME nx => CkProj (m1, ms', nx)) - | CkApp (k1, k2) => CkApp (sgnS_class_key arg k1, - sgnS_class_key arg k2) - | _ => k - fun sgnS_sgn (str, (sgns, strs, cons)) sgn = case sgn of SgnProj (m1, ms, x) => @@ -1120,22 +1023,10 @@ fun enrichClasses env classes (m1, ms) sgn = | SgiVal (x, n, c) => (case rule_in c of NONE => default () - | SOME (cn, rule) => + | SOME (cn, nvs, cs, c) => let - val globalizeN = sgnS_class_name (m1, ms, fmap) - val globalize = sgnS_class_key (m1, ms, fmap) - - fun unravel c = - case c of - ClNamed n => - ((case lookupCNamed env n of - (_, _, SOME c') => - (case class_name_in c' of - NONE => c - | SOME k => unravel k) - | _ => c) - handle UnboundNamed _ => c) - | _ => c + val loc = #2 c + fun globalize (c, loc) = (sgnS_con' (m1, ms, fmap) c, loc) val nc = case cn of @@ -1150,23 +1041,14 @@ fun enrichClasses env classes (m1, ms) sgn = NONE => classes | SOME class => let - val e = (EModProj (m1, ms, x), - #2 sgn) + val e = (EModProj (m1, ms, x), #2 sgn) val class = - case rule of - Normal (nvars, hyps, a) => - {ground = - KM.insert (#ground class, (globalize a, nvars), - (map (fn (n, k) => - (globalizeN n, - globalize k)) hyps, e)), - inclusions = #inclusions class} - | Inclusion f' => - {ground = #ground class, - inclusions = inclusion (classes, cn, - #inclusions class, - globalizeN f', e)} + {ground = #ground class, + rules = (nvs, + map globalize cs, + globalize c, + e) :: #rules class} in CM.insert (classes, cn, class) end @@ -1188,19 +1070,11 @@ fun enrichClasses env classes (m1, ms) sgn = val e = (EModProj (m1, ms, x), #2 sgn) val class = - case rule of - Normal (nvars, hyps, a) => - {ground = - KM.insert (#ground class, (globalize a, nvars), - (map (fn (n, k) => - (globalizeN n, - globalize k)) hyps, e)), - inclusions = #inclusions class} - | Inclusion f' => - {ground = #ground class, - inclusions = inclusion (classes, cn, - #inclusions class, - globalizeN f', e)} + {ground = #ground class, + rules = (nvs, + map globalize cs, + globalize c, + e) :: #rules class} in CM.insert (classes, cn, class) end @@ -1301,8 +1175,8 @@ fun sgiBinds env (sgi, loc) = | SgiSgn (x, n, sgn) => pushSgnNamedAs env x n sgn | SgiConstraint _ => env - | SgiClassAbs (x, n, k) => pushCNamedAs env x n (KArrow (k, (KType, loc)), loc) NONE - | SgiClass (x, n, k, c) => pushCNamedAs env x n (KArrow (k, (KType, loc)), loc) (SOME c) + | SgiClassAbs (x, n, k) => pushCNamedAs env x n k NONE + | SgiClass (x, n, k, c) => pushCNamedAs env x n k (SOME c) fun sgnSubCon x = ElabUtil.Con.map {kind = id, diff --git a/src/elab_err.sml b/src/elab_err.sml index 4f24e225..172f7d37 100644 --- a/src/elab_err.sml +++ b/src/elab_err.sml @@ -217,7 +217,17 @@ fun expError env err = ("Type", p_con env c)]) co) | Unresolvable (loc, c) => (ErrorMsg.errorAt loc "Can't resolve type class instance"; - eprefaces' [("Class constraint", p_con env c)]) + eprefaces' [("Class constraint", p_con env c), + ("Class database", p_list (fn (c, rules) => + box [P.p_con env c, + PD.string ":", + space, + p_list (fn (c, e) => + box [p_exp env e, + PD.string ":", + space, + P.p_con env c]) rules]) + (E.listClasses env))]) | IllegalRec (x, e) => (ErrorMsg.errorAt (#2 e) "Illegal 'val rec' righthand side (must be a function abstraction)"; eprefaces' [("Variable", PD.string x), diff --git a/src/elab_util.sig b/src/elab_util.sig index 817f885f..5b4bc46a 100644 --- a/src/elab_util.sig +++ b/src/elab_util.sig @@ -62,6 +62,10 @@ structure Con : sig val map : {kind : Elab.kind' -> Elab.kind', con : Elab.con' -> Elab.con'} -> Elab.con -> Elab.con + val existsB : {kind : 'context * Elab.kind' -> bool, + con : 'context * Elab.con' -> bool, + bind : 'context * binder -> 'context} + -> 'context -> Elab.con -> bool val exists : {kind : Elab.kind' -> bool, con : Elab.con' -> bool} -> Elab.con -> bool diff --git a/src/elab_util.sml b/src/elab_util.sml index ff4abbfb..17e67787 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -244,7 +244,22 @@ fun map {kind, con} s = S.Return () => raise Fail "ElabUtil.Con.map: Impossible" | S.Continue (s, ()) => s -fun exists {kind, con} k = +fun existsB {kind, con, bind} ctx c = + case mapfoldB {kind = fn ctx => fn k => fn () => + if kind (ctx, k) then + S.Return () + else + S.Continue (k, ()), + con = fn ctx => fn c => fn () => + if con (ctx, c) then + S.Return () + else + S.Continue (c, ()), + bind = bind} ctx c () of + S.Return _ => true + | S.Continue _ => false + +fun exists {kind, con} c = case mapfold {kind = fn k => fn () => if kind k then S.Return () @@ -254,7 +269,7 @@ fun exists {kind, con} k = if con c then S.Return () else - S.Continue (c, ())} k () of + S.Continue (c, ())} c () of S.Return _ => true | S.Continue _ => false diff --git a/src/elaborate.sml b/src/elaborate.sml index 874f6c82..1323086c 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2021,8 +2021,8 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = let val (c', ck, gs') = elabCon (env, denv) c - val (env', n) = E.pushENamed env x c' val c' = normClassConstraint env c' + val (env', n) = E.pushENamed env x c' in (unifyKinds env ck ktype handle KUnify ue => strError env (NotType (loc, ck, ue))); @@ -2115,8 +2115,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = | L.SgiClassAbs (x, k) => let val k = elabKind env k - val k' = (L'.KArrow (k, (L'.KType, loc)), loc) - val (env, n) = E.pushCNamed env x k' NONE + val (env, n) = E.pushCNamed env x k NONE val env = E.pushClass env n in ([(L'.SgiClassAbs (x, n, k), loc)], (env, denv, [])) @@ -2125,12 +2124,11 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = | L.SgiClass (x, k, c) => let val k = elabKind env k - val k' = (L'.KArrow (k, (L'.KType, loc)), loc) val (c', ck, gs) = elabCon (env, denv) c - val (env, n) = E.pushCNamed env x k' (SOME c') + val (env, n) = E.pushCNamed env x k (SOME c') val env = E.pushClass env n in - checkKind env c' ck k'; + checkKind env c' ck k; ([(L'.SgiClass (x, n, k, c'), loc)], (env, denv, [])) end @@ -2341,17 +2339,15 @@ and dopen env {str, strs, sgn} = (L'.DConstraint (c1, c2), loc) | L'.SgiClassAbs (x, n, k) => let - val k' = (L'.KArrow (k, (L'.KType, loc)), loc) val c = (L'.CModProj (str, strs, x), loc) in - (L'.DCon (x, n, k', c), loc) + (L'.DCon (x, n, k, c), loc) end | L'.SgiClass (x, n, k, _) => let - val k' = (L'.KArrow (k, (L'.KType, loc)), loc) val c = (L'.CModProj (str, strs, x), loc) in - (L'.DCon (x, n, k', c), loc) + (L'.DCon (x, n, k, c), loc) end in (d, E.declBinds env' d) @@ -2466,14 +2462,8 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = in found (x', n1, k', SOME (L'.CModProj (m1, ms, s), loc)) end - | L'.SgiClassAbs (x', n1, k) => found (x', n1, - (L'.KArrow (k, - (L'.KType, loc)), loc), - NONE) - | L'.SgiClass (x', n1, k, c) => found (x', n1, - (L'.KArrow (k, - (L'.KType, loc)), loc), - SOME c) + | L'.SgiClassAbs (x', n1, k) => found (x', n1, k, NONE) + | L'.SgiClass (x', n1, k, c) => found (x', n1, k, SOME c) | _ => NONE end) @@ -2505,8 +2495,7 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = in case sgi1 of L'.SgiCon (x', n1, k1, c1) => found (x', n1, k1, c1) - | L'.SgiClass (x', n1, k1, c1) => - found (x', n1, (L'.KArrow (k1, (L'.KType, loc)), loc), c1) + | L'.SgiClass (x', n1, k1, c1) => found (x', n1, k1, c1) | _ => NONE end) @@ -2677,13 +2666,12 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = handle KUnify (k1, k2, err) => sgnError env (SgiWrongKind (sgi1All, k1, sgi2All, k2, err)) - val k = (L'.KArrow (k1, (L'.KType, loc)), loc) - val env = E.pushCNamedAs env x n1 k co + val env = E.pushCNamedAs env x n1 k1 co in SOME (if n1 = n2 then env else - E.pushCNamedAs env x n2 k (SOME (L'.CNamed n1, loc2))) + E.pushCNamedAs env x n2 k1 (SOME (L'.CNamed n1, loc2))) end else NONE @@ -2696,8 +2684,6 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = | L'.SgiClass (x, n2, k2, c2) => seek (fn (env, sgi1All as (sgi1, _)) => let - val k = (L'.KArrow (k2, (L'.KType, loc)), loc) - fun found (x', n1, k1, c1) = if x = x' then let @@ -2707,11 +2693,11 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = fun good () = let - val env = E.pushCNamedAs env x n2 k (SOME c2) + val env = E.pushCNamedAs env x n2 k2 (SOME c2) val env = if n1 = n2 then env else - E.pushCNamedAs env x n1 k (SOME c1) + E.pushCNamedAs env x n1 k2 (SOME c1) in SOME env end @@ -3361,12 +3347,11 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = | L.DClass (x, k, c) => let val k = elabKind env k - val k' = (L'.KArrow (k, (L'.KType, loc)), loc) val (c', ck, gs') = elabCon (env, denv) c - val (env, n) = E.pushCNamed env x k' (SOME c') + val (env, n) = E.pushCNamed env x k (SOME c') val env = E.pushClass env n in - checkKind env c' ck k'; + checkKind env c' ck k; ([(L'.DClass (x, n, k, c'), loc)], (env, denv, enD gs' @ gs)) end diff --git a/src/urweb.grm b/src/urweb.grm index fb31bd18..16a77150 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -660,8 +660,9 @@ sgi : CON SYMBOL DCOLON kind ((SgiConAbs (SYMBOL, kind), s (CONleft, end) | CLASS SYMBOL (let val loc = s (CLASSleft, SYMBOLright) + val k = (KArrow ((KType, loc), (KType, loc)), loc) in - (SgiClassAbs (SYMBOL, (KWild, loc)), loc) + (SgiClassAbs (SYMBOL, k), loc) end) | CLASS SYMBOL DCOLON kind (let val loc = s (CLASSleft, kindright) -- cgit v1.2.3 From 30eeaff2c92fb1d0ba029a7688fc7b547a60c150 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 12 Apr 2009 10:08:11 -0400 Subject: style declarations --- lib/ur/basis.urs | 4 ++++ src/cjr.sml | 1 + src/cjr_env.sml | 2 +- src/cjr_print.sml | 11 +++++++++++ src/cjrize.sml | 1 + src/core.sml | 1 + src/core_env.sml | 6 ++++++ src/core_print.sml | 11 +++++++++++ src/core_util.sml | 13 ++++++++++++- src/corify.sml | 10 +++++++++- src/elab.sml | 1 + src/elab_env.sml | 6 ++++++ src/elab_print.sml | 7 +++++++ src/elab_util.sml | 8 ++++++++ src/elaborate.sml | 10 ++++++++++ src/elisp/urweb-mode.el | 4 ++-- src/expl.sml | 1 + src/expl_env.sml | 6 ++++++ src/expl_print.sml | 7 +++++++ src/explify.sml | 1 + src/mono.sml | 2 ++ src/mono_env.sml | 1 + src/mono_print.sml | 8 ++++++++ src/mono_shake.sml | 6 ++++-- src/mono_util.sml | 5 ++++- src/monoize.sml | 17 +++++++++++++++++ src/prepare.sml | 1 + src/reduce.sml | 1 + src/reduce_local.sml | 1 + src/shake.sml | 5 ++++- src/source.sml | 1 + src/source_print.sml | 7 +++++++ src/unnest.sml | 1 + src/urweb.grm | 10 +++++++++- src/urweb.lex | 1 + tests/style.ur | 6 ++++++ tests/style.urp | 3 +++ 37 files changed, 177 insertions(+), 10 deletions(-) create mode 100644 tests/style.ur create mode 100644 tests/style.urp (limited to 'src/elab_env.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index f2f378ee..9eeb4891 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -405,6 +405,9 @@ val nextval : sql_sequence -> transaction int (** XML *) +con css_class :: {Unit} -> Type +(* The argument lists categories of properties that this class could set usefully. *) + con tag :: {Type} -> {Unit} -> {Unit} -> {Type} -> {Type} -> Type @@ -440,6 +443,7 @@ con xbody = xml [Body] [] [] con xtr = xml [Body, Tr] [] [] con xform = xml [Body, Form] [] [] + (*** HTML details *) con html = [Html] diff --git a/src/cjr.sml b/src/cjr.sml index 33cf07c9..031a14f8 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -110,6 +110,7 @@ datatype decl' = | DPreparedStatements of (string * int) list | DJavaScript of string + | DStyle of string * string list withtype decl = decl' located diff --git a/src/cjr_env.sml b/src/cjr_env.sml index 9921ee48..cb5caee9 100644 --- a/src/cjr_env.sml +++ b/src/cjr_env.sml @@ -167,6 +167,6 @@ fun declBinds env (d, loc) = | DDatabase _ => env | DPreparedStatements _ => env | DJavaScript _ => env - + | DStyle _ => env end diff --git a/src/cjr_print.sml b/src/cjr_print.sml index f86d4928..cabfc77f 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2146,6 +2146,17 @@ fun p_decl env (dAll as (d, _) : decl) = | DJavaScript s => box [string "static char jslib[] = \"", string (String.toString s), string "\";"] + | DStyle (s, xs) => box [string "/*", + space, + string "style", + space, + string s, + space, + string ":", + space, + p_list string xs, + space, + string "*/"] datatype 'a search = Found of 'a diff --git a/src/cjrize.sml b/src/cjrize.sml index e0341c64..b432cd44 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -556,6 +556,7 @@ fun cifyDecl ((d, loc), sm) = (SOME (L'.DSequence s, loc), NONE, sm) | L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm) | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm) + | L.DStyle args => (SOME (L'.DStyle args, loc), NONE, sm) fun cjrize ds = let diff --git a/src/core.sml b/src/core.sml index a8e0de13..bbd1a9b6 100644 --- a/src/core.sml +++ b/src/core.sml @@ -134,6 +134,7 @@ datatype decl' = | DSequence of string * int * string | DDatabase of string | DCookie of string * int * con * string + | DStyle of string * int * con * string withtype decl = decl' located diff --git a/src/core_env.sml b/src/core_env.sml index 95226bb7..01a791a0 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -334,6 +334,12 @@ fun declBinds env (d, loc) = in pushENamed env x n t NONE s end + | DStyle (x, n, c, s) => + let + val t = (CApp ((CFfi ("Basis", "css_class"), loc), c), loc) + in + pushENamed env x n t NONE s + end fun patBinds env (p, loc) = case p of diff --git a/src/core_print.sml b/src/core_print.sml index ed401d29..caf55adb 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -586,6 +586,17 @@ fun p_decl env (dAll as (d, _) : decl) = string ":", space, p_con env c] + | DStyle (x, n, c, s) => box [string "style", + space, + p_named x n, + space, + string "as", + space, + string s, + space, + string ":", + space, + p_con env c] fun p_file env file = let diff --git a/src/core_util.sml b/src/core_util.sml index 320a0326..8ccd520a 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -951,6 +951,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = S.map2 (mfc ctx c, fn c' => (DCookie (x, n, c', s), loc)) + | DStyle (x, n, c, s) => + S.map2 (mfc ctx c, + fn c' => + (DStyle (x, n, c', s), loc)) and mfvi ctx (x, n, t, e, s) = S.bind2 (mfc ctx t, @@ -1088,6 +1092,12 @@ fun mapfoldB (all as {bind, ...}) = in bind (ctx, NamedE (x, n, t, NONE, s)) end + | DStyle (x, n, c, s) => + let + val t = (CApp ((CFfi ("Basis", "css_class"), #2 d'), c), #2 d') + in + bind (ctx, NamedE (x, n, t, NONE, s)) + end in S.map2 (mff ctx' ds', fn ds' => @@ -1148,7 +1158,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DTable (_, n, _, _, _, _, _, _) => Int.max (n, count) | DSequence (_, n, _) => Int.max (n, count) | DDatabase _ => count - | DCookie (_, n, _, _) => Int.max (n, count)) 0 + | DCookie (_, n, _, _) => Int.max (n, count) + | DStyle (_, n, _, _) => Int.max (n, count)) 0 end diff --git a/src/corify.sml b/src/corify.sml index e3b9a365..1a5bab06 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -1002,6 +1002,13 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = in ([(L'.DCookie (x, n, corifyCon st c, s), loc)], st) end + | L.DStyle (_, x, n, c) => + let + val (st, n) = St.bindVal st x n + val s = doRestify (mods, x) + in + ([(L'.DStyle (x, n, corifyCon st c, s), loc)], st) + end and corifyStr mods ((str, _), st) = case str of @@ -1057,7 +1064,8 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DTable (_, _, n', _, _, _, _, _) => Int.max (n, n') | L.DSequence (_, _, n') => Int.max (n, n') | L.DDatabase _ => n - | L.DCookie (_, _, n', _) => Int.max (n, n')) + | L.DCookie (_, _, n', _) => Int.max (n, n') + | L.DStyle (_, _, n', _) => Int.max (n, n')) 0 ds and maxNameStr (str, _) = diff --git a/src/elab.sml b/src/elab.sml index 83a7f929..cabe0a94 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -171,6 +171,7 @@ datatype decl' = | DClass of string * int * kind * con | DDatabase of string | DCookie of int * string * int * con + | DStyle of int * string * int * con and str' = StrConst of decl list diff --git a/src/elab_env.sml b/src/elab_env.sml index 1c3eb62e..828dface 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1434,6 +1434,12 @@ fun declBinds env (d, loc) = in pushENamedAs env x n t end + | DStyle (tn, x, n, c) => + let + val t = (CApp ((CModProj (tn, [], "css_class"), loc), c), loc) + in + pushENamedAs env x n t + end fun patBinds env (p, loc) = case p of diff --git a/src/elab_print.sml b/src/elab_print.sml index 7eb853af..5028ff44 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -779,6 +779,13 @@ fun p_decl env (dAll as (d, _) : decl) = string ":", space, p_con env c] + | DStyle (_, x, n, c) => box [string "style", + space, + p_named x n, + space, + string ":", + space, + p_con env c] and p_str env (str, _) = case str of diff --git a/src/elab_util.sml b/src/elab_util.sml index 17e67787..24a92e3f 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -796,6 +796,9 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f | DDatabase _ => ctx | DCookie (tn, x, n, c) => bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "cookie"), loc), + c), loc))) + | DStyle (tn, x, n, c) => + bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "css_class"), loc), c), loc))), mfd ctx d)) ctx ds, fn ds' => (StrConst ds', loc)) @@ -911,6 +914,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f S.map2 (mfc ctx c, fn c' => (DCookie (tn, x, n, c'), loc)) + | DStyle (tn, x, n, c) => + S.map2 (mfc ctx c, + fn c' => + (DStyle (tn, x, n, c'), loc)) and mfvi ctx (x, n, c, e) = S.bind2 (mfc ctx c, @@ -1050,6 +1057,7 @@ and maxNameDecl (d, _) = | DSequence (n1, _, n2) => Int.max (n1, n2) | DDatabase _ => 0 | DCookie (n1, _, n2, _) => Int.max (n1, n2) + | DStyle (n1, _, n2, _) => Int.max (n1, n2) and maxNameStr (str, _) = case str of diff --git a/src/elaborate.sml b/src/elaborate.sml index 21b32f40..922c9c32 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1902,6 +1902,7 @@ val hnormSgn = E.hnormSgn fun tableOf () = (L'.CModProj (!basis_r, [], "sql_table"), ErrorMsg.dummySpan) fun sequenceOf () = (L'.CModProj (!basis_r, [], "sql_sequence"), ErrorMsg.dummySpan) fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan) +fun styleOf () = (L'.CModProj (!basis_r, [], "css_class"), ErrorMsg.dummySpan) fun dopenConstraints (loc, env, denv) {str, strs} = case E.lookupStr env str of @@ -2401,6 +2402,7 @@ and sgiOfDecl (d, loc) = | L'.DClass (x, n, k, c) => [(L'.SgiClass (x, n, k, c), loc)] | L'.DDatabase _ => [] | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] + | L'.DStyle (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (styleOf (), c), loc)), loc)] and subSgn env sgn1 (sgn2 as (_, loc2)) = ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), @@ -3390,6 +3392,14 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = checkKind env c' k (L'.KType, loc); ([(L'.DCookie (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs)) end + | L.DStyle (x, c) => + let + val (c', k, gs') = elabCon (env, denv) c + val (env, n) = E.pushENamed env x (L'.CApp (styleOf (), c'), loc) + in + checkKind env c' k (L'.KRecord (L'.KUnit, loc), loc); + ([(L'.DStyle (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs)) + end (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) in diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index 1f2a52be..834c28da 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -136,7 +136,7 @@ See doc for the variable `urweb-mode-info'." "datatype" "else" "end" "extern" "fn" "map" "fun" "functor" "if" "include" "of" "open" "let" "in" - "rec" "sequence" "sig" "signature" "cookie" + "rec" "sequence" "sig" "signature" "cookie" "style" "struct" "structure" "table" "then" "type" "val" "where" "with" @@ -225,7 +225,7 @@ See doc for the variable `urweb-mode-info'." ("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)" (1 font-lock-keyword-face) (3 (amAttribute font-lock-type-def-face))) - ("\\<\\(val\\|table\\|sequence\\|cookie\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]" + ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]" (1 font-lock-keyword-face) (3 (amAttribute font-lock-variable-name-face))) ("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)" diff --git a/src/expl.sml b/src/expl.sml index b9cbdaf1..ed4de953 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -145,6 +145,7 @@ datatype decl' = | DSequence of int * string * int | DDatabase of string | DCookie of int * string * int * con + | DStyle of int * string * int * con and str' = StrConst of decl list diff --git a/src/expl_env.sml b/src/expl_env.sml index 64f4edc4..790c3aa8 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -319,6 +319,12 @@ fun declBinds env (d, loc) = in pushENamed env x n t end + | DStyle (tn, x, n, c) => + let + val t = (CApp ((CModProj (tn, [], "css_class"), loc), c), loc) + in + pushENamed env x n t + end fun sgiBinds env (sgi, loc) = case sgi of diff --git a/src/expl_print.sml b/src/expl_print.sml index 84002c00..c912bd66 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -691,6 +691,13 @@ fun p_decl env (dAll as (d, _) : decl) = string ":", space, p_con env c] + | DStyle (_, x, n, c) => box [string "style", + space, + p_named x n, + space, + string ":", + space, + p_con env c] and p_str env (str, _) = case str of diff --git a/src/explify.sml b/src/explify.sml index 01a57d2e..32983619 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -187,6 +187,7 @@ fun explifyDecl (d, loc : EM.span) = (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), explifyCon c), loc) | L.DDatabase s => SOME (L'.DDatabase s, loc) | L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc) + | L.DStyle (nt, x, n, c) => SOME (L'.DStyle (nt, x, n, explifyCon c), loc) and explifyStr (str, loc) = case str of diff --git a/src/mono.sml b/src/mono.sml index 35db52bd..4723e30a 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -127,6 +127,8 @@ datatype decl' = | DJavaScript of string + | DStyle of string * string list + withtype decl = decl' located diff --git a/src/mono_env.sml b/src/mono_env.sml index 248567de..df255325 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -111,6 +111,7 @@ fun declBinds env (d, loc) = | DSequence _ => env | DDatabase _ => env | DJavaScript _ => env + | DStyle _ => env fun patBinds env (p, loc) = case p of diff --git a/src/mono_print.sml b/src/mono_print.sml index c75e81ba..3870ce41 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -440,6 +440,14 @@ fun p_decl env (dAll as (d, _) : decl) = string s, string ")"] + | DStyle (s, xs) => box [string "style", + space, + string s, + space, + string ":", + space, + p_list string xs] + fun p_file env file = let diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 343ec728..d2426f9f 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -58,7 +58,8 @@ fun shake file = | ((DTable _, _), acc) => acc | ((DSequence _, _), acc) => acc | ((DDatabase _, _), acc) => acc - | ((DJavaScript _, _), acc) => acc) + | ((DJavaScript _, _), acc) => acc + | ((DStyle _, _), acc) => acc) (IM.empty, IM.empty) file fun typ (c, s) = @@ -115,7 +116,8 @@ fun shake file = | (DTable _, _) => true | (DSequence _, _) => true | (DDatabase _, _) => true - | (DJavaScript _, _) => true) file + | (DJavaScript _, _) => true + | (DStyle _, _) => true) file end end diff --git a/src/mono_util.sml b/src/mono_util.sml index 485e64f6..62a2dfe0 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -474,6 +474,7 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll | DJavaScript _ => S.return2 dAll + | DStyle _ => S.return2 dAll and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, @@ -555,6 +556,7 @@ fun mapfoldB (all as {bind, ...}) = | DSequence _ => ctx | DDatabase _ => ctx | DJavaScript _ => ctx + | DStyle _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -603,7 +605,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DTable _ => count | DSequence _ => count | DDatabase _ => count - | DJavaScript _ => count) 0 + | DJavaScript _ => count + | DStyle _ => count) 0 end diff --git a/src/monoize.sml b/src/monoize.sml index bf26fda2..8030b7ba 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2705,6 +2705,23 @@ fun monoDecl (env, fm) (all as (d, loc)) = fm, [(L'.DVal (x, n, t', e, s), loc)]) end + | L.DStyle (x, n, (L.CRecord (_, xcs), _), s) => + let + val xs = map (fn ((L.CName x, _), _) => x + | (x, _) => (E.errorAt (#2 x) "Undetermined style component"; + Print.eprefaces' [("Name", CorePrint.p_con env x)]; + "")) xcs + + val t = (L.CFfi ("Basis", "string"), loc) + val t' = (L'.TFfi ("Basis", "string"), loc) + val e = (L'.EPrim (Prim.String s), loc) + in + SOME (Env.pushENamed env x n t NONE s, + fm, + [(L'.DStyle (s, xs), loc), + (L'.DVal (x, n, t', e, s), loc)]) + end + | L.DStyle _ => poly () end datatype expungable = Client | Channel diff --git a/src/prepare.sml b/src/prepare.sml index 258b9dcf..8e31b73d 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -259,6 +259,7 @@ fun prepDecl (d as (_, loc), sns) = | DDatabase _ => (d, sns) | DPreparedStatements _ => (d, sns) | DJavaScript _ => (d, sns) + | DStyle _ => (d, sns) fun prepare (ds, ps) = let diff --git a/src/reduce.sml b/src/reduce.sml index 25cc6274..714b55d7 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -469,6 +469,7 @@ fun reduce file = | DSequence _ => (d, st) | DDatabase _ => (d, st) | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st) + | DStyle (s, n, c, s') => ((DStyle (s, n, con namedC [] c, s'), loc), st) val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty) file in diff --git a/src/reduce_local.sml b/src/reduce_local.sml index a49d7115..cf602406 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -152,6 +152,7 @@ fun reduce file = | DSequence _ => d | DDatabase _ => d | DCookie _ => d + | DStyle _ => d in map doDecl file end diff --git a/src/shake.sml b/src/shake.sml index 378e8276..9c95d6a3 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -86,6 +86,8 @@ fun shake file = (cdef, IM.insert (edef, n, ([], dummyt, dummye))) | ((DDatabase _, _), acc) => acc | ((DCookie (_, n, c, _), _), (cdef, edef)) => + (cdef, IM.insert (edef, n, ([], c, dummye))) + | ((DStyle (_, n, c, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], c, dummye)))) (IM.empty, IM.empty) file @@ -160,7 +162,8 @@ fun shake file = | (DTable _, _) => true | (DSequence _, _) => true | (DDatabase _, _) => true - | (DCookie _, _) => true) file + | (DCookie _, _) => true + | (DStyle _, _) => true) file end end diff --git a/src/source.sml b/src/source.sml index 3bd8e22a..a35c61be 100644 --- a/src/source.sml +++ b/src/source.sml @@ -164,6 +164,7 @@ datatype decl' = | DClass of string * kind * con | DDatabase of string | DCookie of string * con + | DStyle of string * con and str' = StrConst of decl list diff --git a/src/source_print.sml b/src/source_print.sml index 94a175ac..bc933d57 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -640,6 +640,13 @@ fun p_decl ((d, _) : decl) = string ":", space, p_con c] + | DStyle (x, c) => box [string "style", + space, + string x, + space, + string ":", + space, + p_con c] and p_str (str, _) = case str of diff --git a/src/unnest.sml b/src/unnest.sml index 1d0c2388..c321b34d 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -407,6 +407,7 @@ fun unnest file = | DClass _ => default () | DDatabase _ => default () | DCookie _ => default () + | DStyle _ => default () end and doStr (all as (str, loc), st) = diff --git a/src/urweb.grm b/src/urweb.grm index 7288359a..0d750679 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -194,7 +194,7 @@ datatype prop_kind = Delete | Update | LET | IN | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE - | COOKIE + | COOKIE | STYLE | CASE | IF | THEN | ELSE | XML_BEGIN of string | XML_END | XML_BEGIN_END of string @@ -451,6 +451,7 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let [(DClass (SYMBOL1, kind, c), s (CLASSleft, cexpright))] end) | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))]) + | STYLE SYMBOL COLON cexp ([(DStyle (SYMBOL, cexp), s (STYLEleft, cexpright))]) kopt : (NONE) | DCOLON kind (SOME kind) @@ -707,6 +708,13 @@ sgi : CON SYMBOL DCOLON kind ((SgiConAbs (SYMBOL, kind), s (CONleft, in (SgiVal (SYMBOL, t), loc) end) + | STYLE SYMBOL COLON cexp (let + val loc = s (STYLEleft, cexpright) + val t = (CApp ((CVar (["Basis"], "css_class"), loc), + cexp), loc) + in + (SgiVal (SYMBOL, t), loc) + end) sgis : ([]) | sgi sgis (sgi :: sgis) diff --git a/src/urweb.lex b/src/urweb.lex index 4b3eb2af..534d51c6 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -319,6 +319,7 @@ notags = [^<{\n]+; "sequence" => (Tokens.SEQUENCE (pos yypos, pos yypos + size yytext)); "class" => (Tokens.CLASS (pos yypos, pos yypos + size yytext)); "cookie" => (Tokens.COOKIE (pos yypos, pos yypos + size yytext)); + "style" => (Tokens.STYLE (pos yypos, pos yypos + size yytext)); "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext)); "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext)); diff --git a/tests/style.ur b/tests/style.ur new file mode 100644 index 00000000..f622ecfd --- /dev/null +++ b/tests/style.ur @@ -0,0 +1,6 @@ +style q : [] +style r : [Table, List] + +fun main () : transaction page = return + Hi. + diff --git a/tests/style.urp b/tests/style.urp new file mode 100644 index 00000000..fdb25a8b --- /dev/null +++ b/tests/style.urp @@ -0,0 +1,3 @@ +debug + +style -- cgit v1.2.3 From 84168a777e28ab53917bc3ed448cc90e6b00a4ed Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 12 Apr 2009 12:31:54 -0400 Subject: Stop tracking CSS classes in XML types --- demo/hello.urs | 2 +- lib/ur/basis.urs | 124 +++++++++++++++++++++------------------------------ lib/ur/top.ur | 28 ++++++------ lib/ur/top.urs | 34 +++++++------- src/cjr.sml | 2 +- src/cjr_print.sml | 18 +++----- src/core.sml | 2 +- src/core_env.sml | 4 +- src/core_print.sml | 18 +++----- src/core_util.sml | 11 ++--- src/corify.sml | 15 +++---- src/elab.sml | 2 +- src/elab_env.sml | 4 +- src/elab_print.sig | 1 - src/elab_print.sml | 10 ++--- src/elab_util.sml | 13 ++---- src/elaborate.sml | 75 +++++++++++-------------------- src/expl.sml | 2 +- src/expl_env.sml | 4 +- src/expl_print.sml | 10 ++--- src/explify.sml | 2 +- src/mono.sml | 2 +- src/mono_print.sml | 10 ++--- src/monoize.sml | 69 ++++++++-------------------- src/reduce.sml | 2 +- src/shake.sml | 4 +- src/source.sml | 2 +- src/source_print.sml | 10 ++--- src/urweb.grm | 31 ++++++------- tests/style.ur | 4 +- 30 files changed, 201 insertions(+), 314 deletions(-) (limited to 'src/elab_env.sml') diff --git a/demo/hello.urs b/demo/hello.urs index 8cfe27af..6ac44e0b 100644 --- a/demo/hello.urs +++ b/demo/hello.urs @@ -1 +1 @@ -val main : unit -> transaction (page []) +val main : unit -> transaction page diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 7a55d8e4..9eeb4891 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -408,64 +408,40 @@ val nextval : sql_sequence -> transaction int con css_class :: {Unit} -> Type (* The argument lists categories of properties that this class could set usefully. *) -con tag :: {Type} -> {Unit} -> {Unit} -> {Type} -> {Type} -> {Unit} -> Type -(* Arguments: - * 1. Attributes - * 2. Context for this tag - * 3. Context for inner XML - * 4. Form fields used - * 5. Form fields defined - * 6. CSS property categories that the tag might use - *) - -con xml :: {Unit} -> {Type} -> {Type} -> {Unit} -> Type -(* Arguments: - * 1. Context - * 2. Form fields used - * 3. Form fields defined - * 4. CSS property categories that this XML fragment might use - *) - -con css_subset :: {Unit} -> {Unit} -> Type -val css_subset : cs1 ::: {Unit} -> cs2 ::: {Unit} -> [cs1 ~ cs2] - => css_subset cs1 (cs1 ++ cs2) - -val cdata : ctx ::: {Unit} -> use ::: {Type} -> css ::: {Unit} -> string -> xml ctx use [] css +con tag :: {Type} -> {Unit} -> {Unit} -> {Type} -> {Type} -> Type + + +con xml :: {Unit} -> {Type} -> {Type} -> Type +val cdata : ctx ::: {Unit} -> use ::: {Type} -> string -> xml ctx use [] val tag : attrsGiven ::: {Type} -> attrsAbsent ::: {Type} -> ctxOuter ::: {Unit} -> ctxInner ::: {Unit} -> useOuter ::: {Type} -> useInner ::: {Type} -> bindOuter ::: {Type} -> bindInner ::: {Type} - -> css ::: {Unit} -> cssOuter ::: {Unit} -> cssInner ::: {Unit} -> [attrsGiven ~ attrsAbsent] => [useOuter ~ useInner] => [bindOuter ~ bindInner] => $attrsGiven -> tag (attrsGiven ++ attrsAbsent) - ctxOuter ctxInner useOuter bindOuter cssOuter - -> css_subset cssOuter css - -> css_subset cssInner css - -> xml ctxInner useInner bindInner cssInner - -> xml ctxOuter (useOuter ++ useInner) (bindOuter ++ bindInner) css + ctxOuter ctxInner useOuter bindOuter + -> xml ctxInner useInner bindInner + -> xml ctxOuter (useOuter ++ useInner) (bindOuter ++ bindInner) val join : ctx ::: {Unit} - -> use1 ::: {Type} -> bind1 ::: {Type} -> bind2 ::: {Type} - -> css ::: {Unit} -> css1 ::: {Unit} -> css2 ::: {Unit} - -> [use1 ~ bind1] => [bind1 ~ bind2] - => xml ctx use1 bind1 css1 - -> xml ctx (use1 ++ bind1) bind2 css2 - -> css_subset css1 css - -> css_subset css2 css - -> xml ctx use1 (bind1 ++ bind2) css + -> use1 ::: {Type} -> bind1 ::: {Type} -> bind2 ::: {Type} + -> [use1 ~ bind1] => [bind1 ~ bind2] => + xml ctx use1 bind1 + -> xml ctx (use1 ++ bind1) bind2 + -> xml ctx use1 (bind1 ++ bind2) val useMore : ctx ::: {Unit} -> use1 ::: {Type} -> use2 ::: {Type} - -> bind ::: {Type} -> css ::: {Unit} + -> bind ::: {Type} -> [use1 ~ use2] => - xml ctx use1 bind css - -> xml ctx (use1 ++ use2) bind css + xml ctx use1 bind + -> xml ctx (use1 ++ use2) bind con xhtml = xml [Html] con page = xhtml [] [] -con xbody = xml [Body] [] [] [] -con xtr = xml [Body, Tr] [] [] [] -con xform = xml [Body, Form] [] [] [] +con xbody = xml [Body] [] [] +con xtr = xml [Body, Tr] [] [] +con xform = xml [Body, Form] [] [] (*** HTML details *) @@ -477,21 +453,21 @@ con form = [Body, Form] con tabl = [Body, Table] con tr = [Body, Tr] -val dyn : use ::: {Type} -> bind ::: {Type} -> unit -> css ::: {Unit} - -> tag [Signal = signal (xml body use bind css)] body [] use bind css +val dyn : use ::: {Type} -> bind ::: {Type} -> unit + -> tag [Signal = signal (xml body use bind)] body [] use bind -val head : unit -> tag [] html head [] [] [] -val title : unit -> tag [] head [] [] [] [] +val head : unit -> tag [] html head [] [] +val title : unit -> tag [] head [] [] [] -val body : unit -> tag [Onload = transaction unit] html body [] [] [] +val body : unit -> tag [Onload = transaction unit] html body [] [] con bodyTag = fn (attrs :: {Type}) => ctx ::: {Unit} -> [[Body] ~ ctx] => - unit -> tag attrs ([Body] ++ ctx) ([Body] ++ ctx) [] [] [] + unit -> tag attrs ([Body] ++ ctx) ([Body] ++ ctx) [] [] con bodyTagStandalone = fn (attrs :: {Type}) => ctx ::: {Unit} -> [[Body] ~ ctx] => - unit -> tag attrs ([Body] ++ ctx) [] [] [] [] + unit -> tag attrs ([Body] ++ ctx) [] [] [] val br : bodyTagStandalone [] @@ -516,19 +492,19 @@ val hr : bodyTag [] type url val bless : string -> url -val a : css ::: {Unit} -> bodyTag [Link = transaction (page css), Href = url, Onclick = transaction unit] +val a : bodyTag [Link = transaction page, Href = url, Onclick = transaction unit] val img : bodyTag [Src = url] -val form : ctx ::: {Unit} -> bind ::: {Type} -> css ::: {Unit} +val form : ctx ::: {Unit} -> bind ::: {Type} -> [[Body] ~ ctx] => - xml form [] bind css - -> xml ([Body] ++ ctx) [] [] css + xml form [] bind + -> xml ([Body] ++ ctx) [] [] con formTag = fn (ty :: Type) (inner :: {Unit}) (attrs :: {Type}) => ctx ::: {Unit} -> [[Form] ~ ctx] => nm :: Name -> unit - -> tag attrs ([Form] ++ ctx) inner [] [nm = ty] [] + -> tag attrs ([Form] ++ ctx) inner [] [nm = ty] val textbox : formTag string [] [Value = string, Size = int, Source = source string] val password : formTag string [] [Value = string, Size = int] val textarea : formTag string [] [Rows = int, Cols = int] @@ -537,40 +513,42 @@ val checkbox : formTag bool [] [Checked = bool] con radio = [Body, Radio] val radio : formTag string radio [] -val radioOption : unit -> tag [Value = string] radio [] [] [] [] +val radioOption : unit -> tag [Value = string] radio [] [] [] con select = [Select] val select : formTag string select [] -val option : unit -> tag [Value = string, Selected = bool] select [] [] [] [] +val option : unit -> tag [Value = string, Selected = bool] select [] [] [] -val submit : ctx ::: {Unit} -> use ::: {Type} -> css ::: {Unit} +val submit : ctx ::: {Unit} -> use ::: {Type} -> [[Form] ~ ctx] => unit - -> tag [Value = string, Action = $use -> transaction (page css)] - ([Form] ++ ctx) ([Form] ++ ctx) use [] [] + -> tag [Value = string, Action = $use -> transaction page] + ([Form] ++ ctx) ([Form] ++ ctx) use [] -(*** Tables *) - -val tabl : other ::: {Unit} -> [other ~ [Body, Table]] => - unit -> tag [Border = int] ([Body] ++ other) ([Body, Table] ++ other) [] [] [Table] -val tr : other ::: {Unit} -> [other ~ [Body, Table, Tr]] => - unit -> tag [] ([Body, Table] ++ other) ([Body, Tr] ++ other) [] [] [] -val th : other ::: {Unit} -> [other ~ [Body, Tr]] => - unit -> tag [] ([Body, Tr] ++ other) ([Body] ++ other) [] [] [Cell] -val td : other ::: {Unit} -> [other ~ [Body, Tr]] => - unit -> tag [] ([Body, Tr] ++ other) ([Body] ++ other) [] [] [Cell] - (*** AJAX-oriented widgets *) con cformTag = fn (attrs :: {Type}) => ctx ::: {Unit} -> [[Body] ~ ctx] => - unit -> tag attrs ([Body] ++ ctx) [] [] [] [] + unit -> tag attrs ([Body] ++ ctx) [] [] [] val ctextbox : cformTag [Value = string, Size = int, Source = source string] val button : cformTag [Value = string, Onclick = transaction unit] +(*** Tables *) + +val tabl : other ::: {Unit} -> [other ~ [Body, Table]] => + unit -> tag [Border = int] ([Body] ++ other) ([Body, Table] ++ other) [] [] +val tr : other ::: {Unit} -> [other ~ [Body, Table, Tr]] => + unit -> tag [] ([Body, Table] ++ other) ([Body, Tr] ++ other) [] [] +val th : other ::: {Unit} -> [other ~ [Body, Tr]] => + unit -> tag [] ([Body, Tr] ++ other) ([Body] ++ other) [] [] +val td : other ::: {Unit} -> [other ~ [Body, Tr]] => + unit -> tag [] ([Body, Tr] ++ other) ([Body] ++ other) [] [] + (** Aborting *) -val error : t ::: Type -> xml [Body] [] [] [] -> t +val error : t ::: Type -> xml [Body] [] [] -> t + + diff --git a/lib/ur/top.ur b/lib/ur/top.ur index 9db8462d..b9728158 100644 --- a/lib/ur/top.ur +++ b/lib/ur/top.ur @@ -71,7 +71,7 @@ fun ex (tf :: (Type -> Type)) (choice :: Type) (body : tf choice) : ex tf = fun compose (t1 ::: Type) (t2 ::: Type) (t3 ::: Type) (f1 : t2 -> t3) (f2 : t1 -> t2) (x : t1) = f1 (f2 x) -fun txt (t ::: Type) (ctx ::: {Unit}) (use ::: {Type}) (css ::: {Unit}) (_ : show t) (v : t) = +fun txt (t ::: Type) (ctx ::: {Unit}) (use ::: {Type}) (_ : show t) (v : t) = cdata (show v) fun foldUR (tf :: Type) (tr :: {Unit} -> Type) @@ -94,11 +94,11 @@ fun foldUR2 (tf1 :: Type) (tf2 :: Type) (tr :: {Unit} -> Type) f [nm] [rest] ! r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm))) (fn _ _ => i) -fun foldURX2 (css ::: {Unit}) (tf1 :: Type) (tf2 :: Type) (ctx :: {Unit}) +fun foldURX2 (tf1 :: Type) (tf2 :: Type) (ctx :: {Unit}) (f : nm :: Name -> rest :: {Unit} -> [[nm] ~ rest] => - tf1 -> tf2 -> xml ctx [] [] css) = - foldUR2 [tf1] [tf2] [fn _ => xml ctx [] [] css] + tf1 -> tf2 -> xml ctx [] []) = + foldUR2 [tf1] [tf2] [fn _ => xml ctx [] []] (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] v1 v2 acc => {f [nm] [rest] ! v1 v2}{acc}) @@ -124,20 +124,20 @@ fun foldR2 K (tf1 :: K -> Type) (tf2 :: K -> Type) (tr :: {K} -> Type) f [nm] [t] [rest] ! r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm))) (fn _ _ => i) -fun foldRX K (css ::: {Unit}) (tf :: K -> Type) (ctx :: {Unit}) +fun foldRX K (tf :: K -> Type) (ctx :: {Unit}) (f : nm :: Name -> t :: K -> rest :: {K} -> [[nm] ~ rest] => - tf t -> xml ctx [] [] css) = - foldR [tf] [fn _ => xml ctx [] [] css] + tf t -> xml ctx [] []) = + foldR [tf] [fn _ => xml ctx [] []] (fn (nm :: Name) (t :: K) (rest :: {K}) [[nm] ~ rest] r acc => {f [nm] [t] [rest] ! r}{acc}) -fun foldRX2 K (css ::: {Unit}) (tf1 :: K -> Type) (tf2 :: K -> Type) (ctx :: {Unit}) +fun foldRX2 K (tf1 :: K -> Type) (tf2 :: K -> Type) (ctx :: {Unit}) (f : nm :: Name -> t :: K -> rest :: {K} -> [[nm] ~ rest] => - tf1 t -> tf2 t -> xml ctx [] [] css) = - foldR2 [tf1] [tf2] [fn _ => xml ctx [] [] css] + tf1 t -> tf2 t -> xml ctx [] []) = + foldR2 [tf1] [tf2] [fn _ => xml ctx [] []] (fn (nm :: Name) (t :: K) (rest :: {K}) [[nm] ~ rest] r1 r2 acc => {f [nm] [t] [rest] ! r1 r2}{acc}) @@ -151,18 +151,18 @@ fun queryI (tables ::: {{Type}}) (exps ::: {Type}) (fn fs _ => f fs) () -fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit}) (css ::: {Unit}) +fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit}) [tables ~ exps] (q : sql_query tables exps) (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) - -> xml ctx [] [] css) = + -> xml ctx [] []) = query q (fn fs acc => return {acc}{f fs}) -fun queryX' (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit}) (css ::: {Unit}) +fun queryX' (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit}) [tables ~ exps] (q : sql_query tables exps) (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) - -> transaction (xml ctx [] [] css)) = + -> transaction (xml ctx [] [])) = query q (fn fs acc => r <- f fs; diff --git a/lib/ur/top.urs b/lib/ur/top.urs index 2378e57a..60b6dac2 100644 --- a/lib/ur/top.urs +++ b/lib/ur/top.urs @@ -39,8 +39,8 @@ val ex : tf :: (Type -> Type) -> choice :: Type -> tf choice -> ex tf val compose : t1 ::: Type -> t2 ::: Type -> t3 ::: Type -> (t2 -> t3) -> (t1 -> t2) -> (t1 -> t3) -val txt : t ::: Type -> ctx ::: {Unit} -> use ::: {Type} -> css ::: {Unit} -> show t -> t - -> xml ctx use [] css +val txt : t ::: Type -> ctx ::: {Unit} -> use ::: {Type} -> show t -> t + -> xml ctx use [] val foldUR : tf :: Type -> tr :: ({Unit} -> Type) -> (nm :: Name -> rest :: {Unit} @@ -54,11 +54,11 @@ val foldUR2 : tf1 :: Type -> tf2 :: Type -> tr :: ({Unit} -> Type) tf1 -> tf2 -> tr rest -> tr ([nm] ++ rest)) -> tr [] -> r :: {Unit} -> folder r -> $(mapU tf1 r) -> $(mapU tf2 r) -> tr r -val foldURX2: css ::: {Unit} -> tf1 :: Type -> tf2 :: Type -> ctx :: {Unit} +val foldURX2: tf1 :: Type -> tf2 :: Type -> ctx :: {Unit} -> (nm :: Name -> rest :: {Unit} -> [[nm] ~ rest] => - tf1 -> tf2 -> xml ctx [] [] css) - -> r :: {Unit} -> folder r -> $(mapU tf1 r) -> $(mapU tf2 r) -> xml ctx [] [] css + tf1 -> tf2 -> xml ctx [] []) + -> r :: {Unit} -> folder r -> $(mapU tf1 r) -> $(mapU tf2 r) -> xml ctx [] [] val foldR : K --> tf :: (K -> Type) -> tr :: ({K} -> Type) -> (nm :: Name -> t :: K -> rest :: {K} @@ -74,18 +74,18 @@ val foldR2 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> tr [] -> r :: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> tr r -val foldRX : K --> css ::: {Unit} -> tf :: (K -> Type) -> ctx :: {Unit} +val foldRX : K --> tf :: (K -> Type) -> ctx :: {Unit} -> (nm :: Name -> t :: K -> rest :: {K} -> [[nm] ~ rest] => - tf t -> xml ctx [] [] css) - -> r :: {K} -> folder r -> $(map tf r) -> xml ctx [] [] css + tf t -> xml ctx [] []) + -> r :: {K} -> folder r -> $(map tf r) -> xml ctx [] [] -val foldRX2 : K --> css ::: {Unit} -> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> ctx :: {Unit} +val foldRX2 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> ctx :: {Unit} -> (nm :: Name -> t :: K -> rest :: {K} -> [[nm] ~ rest] => - tf1 t -> tf2 t -> xml ctx [] [] css) + tf1 t -> tf2 t -> xml ctx [] []) -> r :: {K} -> folder r - -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] [] css + -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] [] val queryI : tables ::: {{Type}} -> exps ::: {Type} -> [tables ~ exps] => @@ -94,19 +94,19 @@ val queryI : tables ::: {{Type}} -> exps ::: {Type} -> transaction unit) -> transaction unit -val queryX : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> css ::: {Unit} +val queryX : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> [tables ~ exps] => sql_query tables exps -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) - -> xml ctx [] [] css) - -> transaction (xml ctx [] [] css) + -> xml ctx [] []) + -> transaction (xml ctx [] []) -val queryX' : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> css ::: {Unit} +val queryX' : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> [tables ~ exps] => sql_query tables exps -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) - -> transaction (xml ctx [] [] css)) - -> transaction (xml ctx [] [] css) + -> transaction (xml ctx [] [])) + -> transaction (xml ctx [] []) val oneOrNoRows : tables ::: {{Type}} -> exps ::: {Type} -> [tables ~ exps] => diff --git a/src/cjr.sml b/src/cjr.sml index 031a14f8..23dfb900 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -110,7 +110,7 @@ datatype decl' = | DPreparedStatements of (string * int) list | DJavaScript of string - | DStyle of string * string list + | DStyle of string withtype decl = decl' located diff --git a/src/cjr_print.sml b/src/cjr_print.sml index cabfc77f..46282410 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2146,17 +2146,13 @@ fun p_decl env (dAll as (d, _) : decl) = | DJavaScript s => box [string "static char jslib[] = \"", string (String.toString s), string "\";"] - | DStyle (s, xs) => box [string "/*", - space, - string "style", - space, - string s, - space, - string ":", - space, - p_list string xs, - space, - string "*/"] + | DStyle s => box [string "/*", + space, + string "style", + space, + string s, + space, + string "*/"] datatype 'a search = Found of 'a diff --git a/src/core.sml b/src/core.sml index bbd1a9b6..d9d7f51d 100644 --- a/src/core.sml +++ b/src/core.sml @@ -134,7 +134,7 @@ datatype decl' = | DSequence of string * int * string | DDatabase of string | DCookie of string * int * con * string - | DStyle of string * int * con * string + | DStyle of string * int * string withtype decl = decl' located diff --git a/src/core_env.sml b/src/core_env.sml index 01a791a0..caf30349 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -334,9 +334,9 @@ fun declBinds env (d, loc) = in pushENamed env x n t NONE s end - | DStyle (x, n, c, s) => + | DStyle (x, n, s) => let - val t = (CApp ((CFfi ("Basis", "css_class"), loc), c), loc) + val t = (CFfi ("Basis", "css_class"), loc) in pushENamed env x n t NONE s end diff --git a/src/core_print.sml b/src/core_print.sml index caf55adb..8d8f275c 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -586,17 +586,13 @@ fun p_decl env (dAll as (d, _) : decl) = string ":", space, p_con env c] - | DStyle (x, n, c, s) => box [string "style", - space, - p_named x n, - space, - string "as", - space, - string s, - space, - string ":", - space, - p_con env c] + | DStyle (x, n, s) => box [string "style", + space, + p_named x n, + space, + string "as", + space, + string s] fun p_file env file = let diff --git a/src/core_util.sml b/src/core_util.sml index 8ccd520a..d05aaa72 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -951,10 +951,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = S.map2 (mfc ctx c, fn c' => (DCookie (x, n, c', s), loc)) - | DStyle (x, n, c, s) => - S.map2 (mfc ctx c, - fn c' => - (DStyle (x, n, c', s), loc)) + | DStyle _ => S.return2 dAll and mfvi ctx (x, n, t, e, s) = S.bind2 (mfc ctx t, @@ -1092,9 +1089,9 @@ fun mapfoldB (all as {bind, ...}) = in bind (ctx, NamedE (x, n, t, NONE, s)) end - | DStyle (x, n, c, s) => + | DStyle (x, n, s) => let - val t = (CApp ((CFfi ("Basis", "css_class"), #2 d'), c), #2 d') + val t = (CFfi ("Basis", "css_class"), #2 d') in bind (ctx, NamedE (x, n, t, NONE, s)) end @@ -1159,7 +1156,7 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DSequence (_, n, _) => Int.max (n, count) | DDatabase _ => count | DCookie (_, n, _, _) => Int.max (n, count) - | DStyle (_, n, _, _) => Int.max (n, count)) 0 + | DStyle (_, n, _) => Int.max (n, count)) 0 end diff --git a/src/corify.sml b/src/corify.sml index d0fc6200..c8da9df5 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -923,11 +923,10 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = ran' as (L.CApp ((L.CApp - ((L.CApp - ((L.CApp ((L.CModProj (basis', [], "xml"), _), - (L.CRecord (_, [((L.CName "Html", _), - _)]), _)), _), _), - _), _), _), _), _))) => + ((L.CApp ((L.CModProj (basis', [], "xml"), _), + (L.CRecord (_, [((L.CName "Html", _), + _)]), _)), _), _), + _), _), _))) => let val ran = (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) val ranT = (L.CApp ((L.CModProj (basis, [], "transaction"), loc), @@ -1003,12 +1002,12 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = in ([(L'.DCookie (x, n, corifyCon st c, s), loc)], st) end - | L.DStyle (_, x, n, c) => + | L.DStyle (_, x, n) => let val (st, n) = St.bindVal st x n val s = doRestify (mods, x) in - ([(L'.DStyle (x, n, corifyCon st c, s), loc)], st) + ([(L'.DStyle (x, n, s), loc)], st) end and corifyStr mods ((str, _), st) = @@ -1066,7 +1065,7 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DSequence (_, _, n') => Int.max (n, n') | L.DDatabase _ => n | L.DCookie (_, _, n', _) => Int.max (n, n') - | L.DStyle (_, _, n', _) => Int.max (n, n')) + | L.DStyle (_, _, n') => Int.max (n, n')) 0 ds and maxNameStr (str, _) = diff --git a/src/elab.sml b/src/elab.sml index cabe0a94..41bc85dd 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -171,7 +171,7 @@ datatype decl' = | DClass of string * int * kind * con | DDatabase of string | DCookie of int * string * int * con - | DStyle of int * string * int * con + | DStyle of int * string * int and str' = StrConst of decl list diff --git a/src/elab_env.sml b/src/elab_env.sml index 828dface..6dae1d4b 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1434,9 +1434,9 @@ fun declBinds env (d, loc) = in pushENamedAs env x n t end - | DStyle (tn, x, n, c) => + | DStyle (tn, x, n) => let - val t = (CApp ((CModProj (tn, [], "css_class"), loc), c), loc) + val t = (CModProj (tn, [], "css_class"), loc) in pushENamedAs env x n t end diff --git a/src/elab_print.sig b/src/elab_print.sig index 1eb832b3..41d72ca7 100644 --- a/src/elab_print.sig +++ b/src/elab_print.sig @@ -36,7 +36,6 @@ signature ELAB_PRINT = sig val p_decl : ElabEnv.env -> Elab.decl Print.printer val p_sgn_item : ElabEnv.env -> Elab.sgn_item Print.printer val p_sgn : ElabEnv.env -> Elab.sgn Print.printer - val p_str : ElabEnv.env -> Elab.str Print.printer val p_file : ElabEnv.env -> Elab.file Print.printer val debug : bool ref diff --git a/src/elab_print.sml b/src/elab_print.sml index 5028ff44..e6a2cccb 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -779,13 +779,9 @@ fun p_decl env (dAll as (d, _) : decl) = string ":", space, p_con env c] - | DStyle (_, x, n, c) => box [string "style", - space, - p_named x n, - space, - string ":", - space, - p_con env c] + | DStyle (_, x, n) => box [string "style", + space, + p_named x n] and p_str env (str, _) = case str of diff --git a/src/elab_util.sml b/src/elab_util.sml index 24a92e3f..0d78951b 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -797,9 +797,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f | DCookie (tn, x, n, c) => bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "cookie"), loc), c), loc))) - | DStyle (tn, x, n, c) => - bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "css_class"), loc), - c), loc))), + | DStyle (tn, x, n) => + bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))), mfd ctx d)) ctx ds, fn ds' => (StrConst ds', loc)) | StrVar _ => S.return2 strAll @@ -914,10 +913,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f S.map2 (mfc ctx c, fn c' => (DCookie (tn, x, n, c'), loc)) - | DStyle (tn, x, n, c) => - S.map2 (mfc ctx c, - fn c' => - (DStyle (tn, x, n, c'), loc)) + | DStyle _ => S.return2 dAll and mfvi ctx (x, n, c, e) = S.bind2 (mfc ctx c, @@ -1057,8 +1053,7 @@ and maxNameDecl (d, _) = | DSequence (n1, _, n2) => Int.max (n1, n2) | DDatabase _ => 0 | DCookie (n1, _, n2, _) => Int.max (n1, n2) - | DStyle (n1, _, n2, _) => Int.max (n1, n2) - + | DStyle (n1, _, n2) => Int.max (n1, n2) and maxNameStr (str, _) = case str of StrConst ds => maxName ds diff --git a/src/elaborate.sml b/src/elaborate.sml index 792ab315..72b7b8fc 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2402,7 +2402,7 @@ and sgiOfDecl (d, loc) = | L'.DClass (x, n, k, c) => [(L'.SgiClass (x, n, k, c), loc)] | L'.DDatabase _ => [] | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] - | L'.DStyle (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (styleOf (), c), loc)), loc)] + | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)] and subSgn env sgn1 (sgn2 as (_, loc2)) = ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), @@ -3284,40 +3284,30 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = (L'.CApp (tf, arg), _) => (case (hnormCon env tf, hnormCon env arg) of ((L'.CModProj (basis, [], "transaction"), _), - (L'.CApp (tf, arg4), _)) => + (L'.CApp (tf, arg3), _)) => (case (basis = !basis_r, - hnormCon env tf, hnormCon env arg4) of + hnormCon env tf, hnormCon env arg3) of (true, - (L'.CApp (tf, arg3), _), + (L'.CApp (tf, arg2), _), ((L'.CRecord (_, []), _))) => - (case hnormCon env tf of - (L'.CApp (tf, arg2), _) => - (case hnormCon env tf of - (L'.CApp (tf, arg1), _) => - (case (hnormCon env tf, - hnormCon env arg1, - hnormCon env arg2, - hnormCon env arg3, - hnormCon env arg4) of - (tf, - arg1, - (L'.CRecord (_, []), _), - arg2, - arg4) => - let - val t = (L'.CApp (tf, arg1), loc) - val t = (L'.CApp (t, arg2), loc) - val t = (L'.CApp (t, arg3), loc) - val t = (L'.CApp (t, arg4), loc) - - val t = (L'.CApp ( - (L'.CModProj - (basis, [], "transaction"), loc), + (case (hnormCon env tf) of + (L'.CApp (tf, arg1), _) => + (case (hnormCon env tf, + hnormCon env arg1, + hnormCon env arg2) of + (tf, arg1, + (L'.CRecord (_, []), _)) => + let + val t = (L'.CApp (tf, arg1), loc) + val t = (L'.CApp (t, arg2), loc) + val t = (L'.CApp (t, arg3), loc) + val t = (L'.CApp ( + (L'.CModProj + (basis, [], "transaction"), loc), t), loc) - in - (L'.SgiVal (x, n, makeRes t), loc) - end - | _ => all) + in + (L'.SgiVal (x, n, makeRes t), loc) + end | _ => all) | _ => all) | _ => all) @@ -3402,13 +3392,11 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = checkKind env c' k (L'.KType, loc); ([(L'.DCookie (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs)) end - | L.DStyle (x, c) => + | L.DStyle x => let - val (c', k, gs') = elabCon (env, denv) c - val (env, n) = E.pushENamed env x (L'.CApp (styleOf (), c'), loc) + val (env, n) = E.pushENamed env x (styleOf ()) in - checkKind env c' k (L'.KRecord (L'.KUnit, loc), loc); - ([(L'.DStyle (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs)) + ([(L'.DStyle (!basis_r, x, n), loc)], (env, denv, gs)) end (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) @@ -3632,16 +3620,6 @@ fun elabFile basis topStr topSgn env file = [] => () | _ => raise Fail "Unresolved disjointness constraints in top.urs" val (topStr, topSgn', gs) = elabStr (env', D.empty) (L.StrConst topStr, ErrorMsg.dummySpan) - - val () = subSgn env' topSgn' topSgn - - val () = app (fn (env, k, s1, s2) => - unifySummaries env (k, normalizeRecordSummary env s1, normalizeRecordSummary env s2) - handle CUnify' err => (ErrorMsg.errorAt (#2 k) "Error in Top final record unification"; - cunifyError env err)) - (!delayedUnifs) - val () = delayedUnifs := [] - val () = case gs of [] => () | _ => app (fn Disjoint (loc, env, denv, c1, c2) => @@ -3651,8 +3629,7 @@ fun elabFile basis topStr topSgn env file = (prefaces "Unresolved constraint in top.ur" [("loc", PD.string (ErrorMsg.spanToString loc)), ("c1", p_con env c1), - ("c2", p_con env c2), - ("topStr", p_str env topStr)]; + ("c2", p_con env c2)]; raise Fail "Unresolved constraint in top.ur")) | TypeClass (env, c, r, loc) => let @@ -3663,6 +3640,8 @@ fun elabFile basis topStr topSgn env file = | NONE => expError env (Unresolvable (loc, c)) end) gs + val () = subSgn env' topSgn' topSgn + val (env', top_n) = E.pushStrNamed env' "Top" topSgn val () = top_r := top_n diff --git a/src/expl.sml b/src/expl.sml index ed4de953..859e21ff 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -145,7 +145,7 @@ datatype decl' = | DSequence of int * string * int | DDatabase of string | DCookie of int * string * int * con - | DStyle of int * string * int * con + | DStyle of int * string * int and str' = StrConst of decl list diff --git a/src/expl_env.sml b/src/expl_env.sml index 790c3aa8..1e99b36b 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -319,9 +319,9 @@ fun declBinds env (d, loc) = in pushENamed env x n t end - | DStyle (tn, x, n, c) => + | DStyle (tn, x, n) => let - val t = (CApp ((CModProj (tn, [], "css_class"), loc), c), loc) + val t = (CModProj (tn, [], "css_class"), loc) in pushENamed env x n t end diff --git a/src/expl_print.sml b/src/expl_print.sml index c912bd66..167c6850 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -691,13 +691,9 @@ fun p_decl env (dAll as (d, _) : decl) = string ":", space, p_con env c] - | DStyle (_, x, n, c) => box [string "style", - space, - p_named x n, - space, - string ":", - space, - p_con env c] + | DStyle (_, x, n) => box [string "style", + space, + p_named x n] and p_str env (str, _) = case str of diff --git a/src/explify.sml b/src/explify.sml index 32983619..6a33eabc 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -187,7 +187,7 @@ fun explifyDecl (d, loc : EM.span) = (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), explifyCon c), loc) | L.DDatabase s => SOME (L'.DDatabase s, loc) | L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc) - | L.DStyle (nt, x, n, c) => SOME (L'.DStyle (nt, x, n, explifyCon c), loc) + | L.DStyle (nt, x, n) => SOME (L'.DStyle (nt, x, n), loc) and explifyStr (str, loc) = case str of diff --git a/src/mono.sml b/src/mono.sml index 4723e30a..4a4cb5da 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -127,7 +127,7 @@ datatype decl' = | DJavaScript of string - | DStyle of string * string list + | DStyle of string withtype decl = decl' located diff --git a/src/mono_print.sml b/src/mono_print.sml index 3870ce41..a9e68005 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -440,13 +440,9 @@ fun p_decl env (dAll as (d, _) : decl) = string s, string ")"] - | DStyle (s, xs) => box [string "style", - space, - string s, - space, - string ":", - space, - p_list string xs] + | DStyle s => box [string "style", + space, + string s] fun p_file env file = diff --git a/src/monoize.sml b/src/monoize.sml index e8244c9e..f14b6021 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -127,14 +127,10 @@ fun monoType env = readType (mt env dtmap t, loc) | L.CFfi ("Basis", "url") => (L'.TFfi ("Basis", "string"), loc) - | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _), _), _) => + | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) - | L.CApp ((L.CFfi ("Basis", "css_class"), _), _) => - (L'.TFfi ("Basis", "string"), loc) - | L.CApp ((L.CApp ((L.CFfi ("Basis", "css_subset"), _), _), _), _) => - (L'.TRecord [], loc) | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) => (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc) @@ -2007,9 +2003,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EApp ( (L.ECApp ( - (L.ECApp ( - (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _), - _), _), + (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _), _), _), se) => let @@ -2018,32 +2012,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EFfiApp ("Basis", "htmlifyString", [se]), loc), fm) end - | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "css_subset"), _), _), _), _) => - ((L'.ERecord [], loc), fm) - | L.EApp ( (L.EApp ( - (L.EApp ( - (L.EApp ( + (L.ECApp ( + (L.ECApp ( (L.ECApp ( (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.EFfi ("Basis", "join"), - _), _), _), - _), _), - _), _), - _), _), - _), _), - _), _), + (L.EFfi ("Basis", "join"), + _), _), _), _), _), - xml1), _), - xml2), _), - _), _), - _) => + _), _), + _), _), + xml1), _), + xml2) => let val (xml1, fm) = monoExp (env, st, fm) xml1 val (xml2, fm) = monoExp (env, st, fm) xml2 @@ -2054,26 +2035,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EApp ( (L.EApp ( (L.EApp ( - (L.EApp ( - (L.EApp ( + (L.ECApp ( + (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.EFfi ("Basis", "tag"), - _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), - _), _), _), _), _), _), - attrs), _), - tag), _), - _), _), - _), _), + (L.EFfi ("Basis", "tag"), + _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + attrs), _), + tag), _), xml) => let fun getTag' (e, _) = @@ -2732,23 +2705,17 @@ fun monoDecl (env, fm) (all as (d, loc)) = fm, [(L'.DVal (x, n, t', e, s), loc)]) end - | L.DStyle (x, n, (L.CRecord (_, xcs), _), s) => + | L.DStyle (x, n, s) => let - val xs = map (fn ((L.CName x, _), _) => x - | (x, _) => (E.errorAt (#2 x) "Undetermined style component"; - Print.eprefaces' [("Name", CorePrint.p_con env x)]; - "")) xcs - val t = (L.CFfi ("Basis", "string"), loc) val t' = (L'.TFfi ("Basis", "string"), loc) val e = (L'.EPrim (Prim.String s), loc) in SOME (Env.pushENamed env x n t NONE s, fm, - [(L'.DStyle (s, xs), loc), + [(L'.DStyle s, loc), (L'.DVal (x, n, t', e, s), loc)]) end - | L.DStyle _ => poly () end datatype expungable = Client | Channel diff --git a/src/reduce.sml b/src/reduce.sml index 714b55d7..914f26c0 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -469,7 +469,7 @@ fun reduce file = | DSequence _ => (d, st) | DDatabase _ => (d, st) | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st) - | DStyle (s, n, c, s') => ((DStyle (s, n, con namedC [] c, s'), loc), st) + | DStyle (s, n, s') => ((DStyle (s, n, s'), loc), st) val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty) file in diff --git a/src/shake.sml b/src/shake.sml index 9c95d6a3..787bfd2f 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -87,8 +87,8 @@ fun shake file = | ((DDatabase _, _), acc) => acc | ((DCookie (_, n, c, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], c, dummye))) - | ((DStyle (_, n, c, _), _), (cdef, edef)) => - (cdef, IM.insert (edef, n, ([], c, dummye)))) + | ((DStyle (_, n, _), _), (cdef, edef)) => + (cdef, IM.insert (edef, n, ([], dummyt, dummye)))) (IM.empty, IM.empty) file fun kind (_, s) = s diff --git a/src/source.sml b/src/source.sml index a35c61be..6645ae75 100644 --- a/src/source.sml +++ b/src/source.sml @@ -164,7 +164,7 @@ datatype decl' = | DClass of string * kind * con | DDatabase of string | DCookie of string * con - | DStyle of string * con + | DStyle of string and str' = StrConst of decl list diff --git a/src/source_print.sml b/src/source_print.sml index bc933d57..58867f64 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -640,13 +640,9 @@ fun p_decl ((d, _) : decl) = string ":", space, p_con c] - | DStyle (x, c) => box [string "style", - space, - string x, - space, - string ":", - space, - p_con c] + | DStyle x => box [string "style", + space, + string x] and p_str (str, _) = case str of diff --git a/src/urweb.grm b/src/urweb.grm index 675bcc72..0251d3f4 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -451,7 +451,7 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let [(DClass (SYMBOL1, kind, c), s (CLASSleft, cexpright))] end) | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))]) - | STYLE SYMBOL COLON cexp ([(DStyle (SYMBOL, cexp), s (STYLEleft, cexpright))]) + | STYLE SYMBOL ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))]) kopt : (NONE) | DCOLON kind (SOME kind) @@ -708,10 +708,9 @@ sgi : CON SYMBOL DCOLON kind ((SgiConAbs (SYMBOL, kind), s (CONleft, in (SgiVal (SYMBOL, t), loc) end) - | STYLE SYMBOL COLON cexp (let - val loc = s (STYLEleft, cexpright) - val t = (CApp ((CVar (["Basis"], "css_class"), loc), - cexp), loc) + | STYLE SYMBOL (let + val loc = s (STYLEleft, SYMBOLright) + val t = (CVar (["Basis"], "css_class"), loc) in (SgiVal (SYMBOL, t), loc) end) @@ -1208,12 +1207,11 @@ rexp : ([]) xml : xmlOne xml (let val pos = s (xmlOneleft, xmlright) - val e = (EVar (["Basis"], "join", Infer), pos) - val e = (EApp (e, xmlOne), pos) - val e = (EApp (e, xml), pos) - val e = (EApp (e, (EVar (["Basis"], "css_subset", Infer), pos)), pos) in - (EApp (e, (EVar (["Basis"], "css_subset", Infer), pos)), pos) + (EApp ((EApp ( + (EVar (["Basis"], "join", Infer), pos), + xmlOne), pos), + xml), pos) end) | xmlOne (xmlOne) @@ -1228,7 +1226,6 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer) let val e = (EVar (["Basis"], "cdata", DontInfer), pos) val e = (ECApp (e, (CWild (KWild, pos), pos)), pos) - val e = (ECApp (e, (CRecord [], pos)), pos) in (ECApp (e, (CRecord [], pos)), pos) end @@ -1269,13 +1266,13 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer) tag : tagHead attrs (let val pos = s (tagHeadleft, attrsright) - val e = (EVar (["Basis"], "tag", Infer), pos) - val e = (EApp (e, (ERecord attrs, pos)), pos) - val e = (EApp (e, (EApp (#2 tagHead, (ERecord [], pos)), pos)), pos) - val e = (EApp (e, (EVar (["Basis"], "css_subset", Infer), pos)), pos) - val e = (EApp (e, (EVar (["Basis"], "css_subset", Infer), pos)), pos) in - (#1 tagHead, e) + (#1 tagHead, + (EApp ((EApp ((EVar (["Basis"], "tag", Infer), pos), + (ERecord attrs, pos)), pos), + (EApp (#2 tagHead, + (ERecord [], pos)), pos)), + pos)) end) tagHead: BEGIN_TAG (let diff --git a/tests/style.ur b/tests/style.ur index f622ecfd..04b32a64 100644 --- a/tests/style.ur +++ b/tests/style.ur @@ -1,5 +1,5 @@ -style q : [] -style r : [Table, List] +style q +style r fun main () : transaction page = return Hi. -- cgit v1.2.3 From 2f324fc9e868e0775e1401833b74af15652c6732 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 12 Apr 2009 14:19:15 -0400 Subject: Classes as optional arguments to Basis.tag --- include/types.h | 1 + include/urweb.h | 1 + lib/ur/basis.urs | 7 +++--- src/c/urweb.c | 4 ++++ src/corify.sml | 2 +- src/elab_env.sml | 28 +++++++++++----------- src/elaborate.sml | 17 +++++++------ src/especialize.sml | 52 +++++++++++++--------------------------- src/mono_opt.sml | 7 ++++++ src/monoize.sml | 24 ++++++++++++++++--- src/reduce_local.sml | 8 +++++++ src/tag.sml | 20 +++++++++------- src/urweb.grm | 67 ++++++++++++++++++++++++++++++++++------------------ tests/style.ur | 2 +- 14 files changed, 143 insertions(+), 97 deletions(-) (limited to 'src/elab_env.sml') diff --git a/include/types.h b/include/types.h index ddbff76b..c80653d3 100644 --- a/include/types.h +++ b/include/types.h @@ -17,6 +17,7 @@ typedef struct uw_context *uw_context; typedef uw_Basis_string uw_Basis_xhtml; typedef uw_Basis_string uw_Basis_page; +typedef uw_Basis_string uw_Basis_css_class; typedef unsigned uw_Basis_client; typedef struct { diff --git a/include/urweb.h b/include/urweb.h index 2154a8ed..bbf7515a 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -74,6 +74,7 @@ char *uw_Basis_attrifyString(uw_context, uw_Basis_string); char *uw_Basis_attrifyTime(uw_context, uw_Basis_time); char *uw_Basis_attrifyChannel(uw_context, uw_Basis_channel); char *uw_Basis_attrifyClient(uw_context, uw_Basis_client); +char *uw_Basis_attrifyCss_class(uw_context, uw_Basis_css_class); uw_unit uw_Basis_attrifyInt_w(uw_context, uw_Basis_int); uw_unit uw_Basis_attrifyFloat_w(uw_context, uw_Basis_float); diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 9eeb4891..50146dde 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -405,12 +405,10 @@ val nextval : sql_sequence -> transaction int (** XML *) -con css_class :: {Unit} -> Type -(* The argument lists categories of properties that this class could set usefully. *) +type css_class con tag :: {Type} -> {Unit} -> {Unit} -> {Type} -> {Type} -> Type - con xml :: {Unit} -> {Type} -> {Type} -> Type val cdata : ctx ::: {Unit} -> use ::: {Type} -> string -> xml ctx use [] val tag : attrsGiven ::: {Type} -> attrsAbsent ::: {Type} @@ -420,7 +418,8 @@ val tag : attrsGiven ::: {Type} -> attrsAbsent ::: {Type} -> [attrsGiven ~ attrsAbsent] => [useOuter ~ useInner] => [bindOuter ~ bindInner] => - $attrsGiven + option css_class + -> $attrsGiven -> tag (attrsGiven ++ attrsAbsent) ctxOuter ctxInner useOuter bindOuter -> xml ctxInner useInner bindInner diff --git a/src/c/urweb.c b/src/c/urweb.c index 89358a06..d3a93af9 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -922,6 +922,10 @@ char *uw_Basis_attrifyString(uw_context ctx, uw_Basis_string s) { return result; } +char *uw_Basis_attrifyCss_class(uw_context ctx, uw_Basis_css_class s) { + return s; +} + static void uw_Basis_attrifyInt_w_unsafe(uw_context ctx, uw_Basis_int n) { int len; diff --git a/src/corify.sml b/src/corify.sml index c8da9df5..c1cd940e 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -1005,7 +1005,7 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = | L.DStyle (_, x, n) => let val (st, n) = St.bindVal st x n - val s = doRestify (mods, x) + val s = relify (doRestify (mods, x)) in ([(L'.DStyle (x, n, s), loc)], st) end diff --git a/src/elab_env.sml b/src/elab_env.sml index 6dae1d4b..62a310f2 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -899,19 +899,19 @@ fun sgnS_con (str, (sgns, strs, cons)) c = end) | _ => c -fun sgnS_con' (arg as (m1, ms', (sgns, strs, cons))) c = - case c of - CModProj (m1, ms, x) => - (case IM.find (strs, m1) of - NONE => c - | SOME m1x => CModProj (m1, ms' @ m1x :: ms, x)) - | CNamed n => - (case IM.find (cons, n) of - NONE => c - | SOME nx => CModProj (m1, ms', nx)) - | CApp (c1, c2) => CApp ((sgnS_con' arg (#1 c1), #2 c1), - (sgnS_con' arg (#1 c2), #2 c2)) - | _ => c +fun sgnS_con' (m1, ms', (sgns, strs, cons)) = + U.Con.map {kind = fn x => x, + con = fn c => + case c of + CModProj (m1, ms, x) => + (case IM.find (strs, m1) of + NONE => c + | SOME m1x => CModProj (m1, ms' @ m1x :: ms, x)) + | CNamed n => + (case IM.find (cons, n) of + NONE => c + | SOME nx => CModProj (m1, ms', nx)) + | _ => c} fun sgnS_sgn (str, (sgns, strs, cons)) sgn = case sgn of @@ -1026,7 +1026,7 @@ fun enrichClasses env classes (m1, ms) sgn = | SOME (cn, nvs, cs, c) => let val loc = #2 c - fun globalize (c, loc) = (sgnS_con' (m1, ms, fmap) c, loc) + val globalize = sgnS_con' (m1, ms, fmap) val nc = case cn of diff --git a/src/elaborate.sml b/src/elaborate.sml index 72b7b8fc..ea4c28bd 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1493,26 +1493,28 @@ fun unmodCon env (c, loc) = end | _ => (c, loc) -fun normClassKey envs c = +fun normClassKey env c = let - val c = hnormCon envs c + val c = hnormCon env c in case #1 c of L'.CApp (c1, c2) => let - val c1 = normClassKey envs c1 - val c2 = normClassKey envs c2 + val c1 = normClassKey env c1 + val c2 = normClassKey env c2 in (L'.CApp (c1, c2), #2 c) end - | _ => c + | L'.CRecord (k, xcs) => (L'.CRecord (k, map (fn (x, c) => (normClassKey env x, + normClassKey env c)) xcs), #2 c) + | _ => unmodCon env c end fun normClassConstraint env (c, loc) = case c of L'.CApp (f, x) => let - val f = unmodCon env f + val f = normClassKey env f val x = normClassKey env x in (L'.CApp (f, x), loc) @@ -1526,7 +1528,7 @@ fun normClassConstraint env (c, loc) = end | L'.TCFun (expl, x, k, c1) => (L'.TCFun (expl, x, k, normClassConstraint env c1), loc) | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint env c - | _ => (c, loc) + | _ => unmodCon env (c, loc) fun elabExp (env, denv) (eAll as (e, loc)) = let @@ -2047,6 +2049,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = let val (c', ck, gs') = elabCon (env, denv) c + val old = c' val c' = normClassConstraint env c' val (env', n) = E.pushENamed env x c' in diff --git a/src/especialize.sml b/src/especialize.sml index 6486842b..d1d018ee 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -114,35 +114,6 @@ fun default (_, x, st) = (x, st) fun specialize' file = let - fun default' (_, fs) = fs - - fun actionableExp (e, fs) = - case e of - ERecord xes => - foldl (fn (((CName s, _), e, _), fs) => - if s = "Action" orelse s = "Link" then - let - fun findHead (e, _) = - case e of - ENamed n => IS.add (fs, n) - | EApp (e, _) => findHead e - | _ => fs - in - findHead e - end - else - fs - | (_, fs) => fs) - fs xes - | _ => fs - - val actionable = - U.File.fold {kind = default', - con = default', - exp = actionableExp, - decl = default'} - IS.empty file - fun bind (env, b) = case b of U.Decl.RelE xt => xt :: env @@ -150,6 +121,9 @@ fun specialize' file = fun exp (env, e, st : state) = let + (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty + (e, ErrorMsg.dummySpan))]*) + fun getApp e = case e of ENamed f => SOME (f, []) @@ -160,12 +134,17 @@ fun specialize' file = | _ => NONE in case getApp e of - NONE => (e, st) + NONE => ((*Print.prefaces "No" [("e", CorePrint.p_exp CoreEnv.empty + (e, ErrorMsg.dummySpan))];*) + (e, st)) | SOME (f, xs) => case IM.find (#funcs st, f) of NONE => (e, st) | SOME {name, args, body, typ, tag} => let + (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty + (e, ErrorMsg.dummySpan))]*) + val functionInside = U.Con.exists {kind = fn _ => false, con = fn TFun _ => true | CFfi ("Basis", "transaction") => true @@ -208,7 +187,7 @@ fun specialize' file = e xs in (*Print.prefaces "Brand new (reuse)" - [("e'", CorePrint.p_exp env e)];*) + [("e'", CorePrint.p_exp CoreEnv.empty e)];*) (#1 e, st) end | NONE => @@ -267,9 +246,9 @@ fun specialize' file = val e' = foldl (fn (arg, e) => (EApp (e, arg), loc)) e' xs (*val () = Print.prefaces "Brand new" - [("e'", CorePrint.p_exp env e'), - ("e", CorePrint.p_exp env (e, loc)), - ("body'", CorePrint.p_exp env body')]*) + [("e'", CorePrint.p_exp CoreEnv.empty e'), + ("e", CorePrint.p_exp CoreEnv.empty (e, loc)), + ("body'", CorePrint.p_exp CoreEnv.empty body')]*) in (#1 e', {maxName = #maxName st, @@ -358,7 +337,8 @@ fun specialize' file = fun specialize file = let - (*val () = Print.prefaces "Intermediate" [("file", CorePrint.p_file CoreEnv.empty file)];*) + val file = ReduceLocal.reduce file + (*val () = Print.prefaces "Intermediate" [("file", CorePrint.p_file CoreEnv.empty file)]*) (*val file = ReduceLocal.reduce file*) val (changed, file) = specialize' file (*val file = ReduceLocal.reduce file @@ -368,7 +348,7 @@ fun specialize file = (*print "Round over\n";*) if changed then let - val file = ReduceLocal.reduce file + (*val file = ReduceLocal.reduce file*) val file = CoreUntangle.untangle file val file = Shake.shake file in diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 205ae3fb..670774a2 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -242,6 +242,13 @@ fun exp e = | EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) => EFfiApp ("Basis", "attrifyString_w", [e]) + | EFfiApp ("Basis", "attrifyCss_class", [(EPrim (Prim.String s), _)]) => + EPrim (Prim.String s) + | EWrite (EFfiApp ("Basis", "attrifyCss_class", [(EPrim (Prim.String s), _)]), loc) => + EWrite (EPrim (Prim.String s), loc) + | EWrite (EFfiApp ("Basis", "attrifyCss_class", [e]), _) => + EFfiApp ("Basis", "attrifyString_w", [e]) + | EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]) => EPrim (Prim.String (urlifyInt n)) | EWrite (EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]), loc) => diff --git a/src/monoize.sml b/src/monoize.sml index f14b6021..51fae113 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -131,6 +131,7 @@ fun monoType env = (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "css_class") => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) => (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc) @@ -2035,7 +2036,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EApp ( (L.EApp ( (L.EApp ( - (L.ECApp ( + (L.EApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( @@ -2043,8 +2044,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.ECApp ( (L.ECApp ( (L.ECApp ( - (L.EFfi ("Basis", "tag"), - _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + (L.ECApp ( + (L.EFfi ("Basis", "tag"), + _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + class), _), attrs), _), tag), _), xml) => @@ -2096,9 +2099,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | lowercaseFirst s = String.str (Char.toLower (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + val (class, fm) = monoExp (env, st, fm) class + fun tagStart tag = let + val t = (L'.TFfi ("Basis", "string"), loc) val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc) + + val s = (L'.ECase (class, + [((L'.PNone t, loc), + s), + ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc), + (L'.EStrcat (s, + (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc), + (L'.EStrcat ((L'.ERel 0, loc), + (L'.EPrim (Prim.String "\""), loc)), + loc)), loc)), loc))], + {disc = (L'.TOption t, loc), + result = t}), loc) in foldl (fn (("Action", _, _), acc) => acc | (("Source", _, _), acc) => acc diff --git a/src/reduce_local.sml b/src/reduce_local.sml index cf602406..265cb2a4 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -72,6 +72,11 @@ fun exp env (all as (e, loc)) = | EFfi _ => all | EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc) + | EApp ((ECApp ((ECAbs (_, _, (EAbs (_, (CRel 0, _), _, + (ECon (dk, pc, [(CRel 0, loc)], SOME (ERel 0, _)), _)), _)), _), + t), _), e) => + (ECon (dk, pc, [t], SOME (exp env e)), loc) + | EApp (e1, e2) => let val e1 = exp env e1 @@ -84,6 +89,9 @@ fun exp env (all as (e, loc)) = | EAbs (x, dom, ran, e) => (EAbs (x, dom, ran, exp (Unknown :: env) e), loc) + | ECApp ((ECAbs (_, _, (ECon (dk, pc, [(CRel 0, loc)], NONE), _)), _), t) => + (ECon (dk, pc, [t], NONE), loc) + | ECApp (e, c) => (ECApp (exp env e, c), loc) | ECAbs (x, k, e) => (ECAbs (x, k, exp env e), loc) diff --git a/src/tag.sml b/src/tag.sml index 715da9ed..7a8fe128 100644 --- a/src/tag.sml +++ b/src/tag.sml @@ -46,7 +46,7 @@ fun exp env (e, s) = EApp ( (EApp ( (EApp ( - (ECApp ( + (EApp ( (ECApp ( (ECApp ( (ECApp ( @@ -54,9 +54,11 @@ fun exp env (e, s) = (ECApp ( (ECApp ( (ECApp ( - (EFfi ("Basis", "tag"), - loc), given), _), absent), _), outer), _), inner), _), - useOuter), _), useInner), _), bindOuter), _), bindInner), _), + (ECApp ( + (EFfi ("Basis", "tag"), + loc), given), _), absent), _), outer), _), inner), _), + useOuter), _), useInner), _), bindOuter), _), bindInner), _), + class), _), attrs), _), tag), _), xml) => @@ -124,7 +126,7 @@ fun exp env (e, s) = (EApp ( (EApp ( (EApp ( - (ECApp ( + (EApp ( (ECApp ( (ECApp ( (ECApp ( @@ -132,9 +134,11 @@ fun exp env (e, s) = (ECApp ( (ECApp ( (ECApp ( - (EFfi ("Basis", "tag"), - loc), given), loc), absent), loc), outer), loc), inner), loc), - useOuter), loc), useInner), loc), bindOuter), loc), bindInner), loc), + (ECApp ( + (EFfi ("Basis", "tag"), + loc), given), loc), absent), loc), outer), loc), inner), loc), + useOuter), loc), useInner), loc), bindOuter), loc), bindInner), loc), + class), loc), (ERecord xets, loc)), loc), tag), loc), xml), s) diff --git a/src/urweb.grm b/src/urweb.grm index 0251d3f4..d47aaf47 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -176,6 +176,8 @@ fun tagIn bt = datatype prop_kind = Delete | Update +datatype attr = Class of exp | Normal of con * exp + %% %header (functor UrwebLrValsFn(structure Token : TOKEN)) @@ -296,8 +298,8 @@ datatype prop_kind = Delete | Update | rpat of (string * pat) list * bool | ptuple of pat list - | attrs of (con * exp) list - | attr of con * exp + | attrs of exp option * (con * exp) list + | attr of attr | attrv of exp | query of exp @@ -1266,13 +1268,18 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer) tag : tagHead attrs (let val pos = s (tagHeadleft, attrsright) + + val e = (EVar (["Basis"], "tag", Infer), pos) + val eo = case #1 attrs of + NONE => (EVar (["Basis"], "None", Infer), pos) + | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos), + e), pos) + val e = (EApp (e, eo), pos) + val e = (EApp (e, (ERecord (#2 attrs), pos)), pos) + val e = (EApp (e, (EApp (#2 tagHead, + (ERecord [], pos)), pos)), pos) in - (#1 tagHead, - (EApp ((EApp ((EVar (["Basis"], "tag", Infer), pos), - (ERecord attrs, pos)), pos), - (EApp (#2 tagHead, - (ERecord [], pos)), pos)), - pos)) + (#1 tagHead, e) end) tagHead: BEGIN_TAG (let @@ -1284,22 +1291,36 @@ tagHead: BEGIN_TAG (let end) | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright))) -attrs : ([]) - | attr attrs (attr :: attrs) - -attr : SYMBOL EQ attrv ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)), - if (SYMBOL = "href" orelse SYMBOL = "src") - andalso (case #1 attrv of - EPrim _ => true - | _ => false) then - let - val loc = s (attrvleft, attrvright) - in - (EApp ((EVar (["Basis"], "bless", Infer), loc), - attrv), loc) - end +attrs : (NONE, []) + | attr attrs (let + val loc = s (attrleft, attrsright) + in + case attr of + Class e => + (case #1 attrs of + NONE => () + | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag"; + (SOME e, #2 attrs)) + | Normal xe => + (#1 attrs, xe :: #2 attrs) + end) + +attr : SYMBOL EQ attrv (if SYMBOL = "class" then + Class attrv else - attrv) + Normal ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)), + if (SYMBOL = "href" orelse SYMBOL = "src") + andalso (case #1 attrv of + EPrim _ => true + | _ => false) then + let + val loc = s (attrvleft, attrvright) + in + (EApp ((EVar (["Basis"], "bless", Infer), loc), + attrv), loc) + end + else + attrv)) attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright)) | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) diff --git a/tests/style.ur b/tests/style.ur index 04b32a64..83f95594 100644 --- a/tests/style.ur +++ b/tests/style.ur @@ -2,5 +2,5 @@ style q style r fun main () : transaction page = return - Hi. + Hi. And hi again! -- cgit v1.2.3 From 008b594412606bbf78fff76daff219a102ce2daa Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 28 Apr 2009 11:05:28 -0400 Subject: LEFT JOIN --- lib/ur/basis.urs | 11 +++++++ src/elab_env.sig | 2 +- src/elab_env.sml | 87 +++++++++++++++++++++++++++++++++++++++++++++++++++---- src/elaborate.sml | 61 +++++++++++++++++++++----------------- src/monoize.sml | 37 +++++++++++++++++++++++ src/urweb.grm | 14 +++++++-- src/urweb.lex | 1 + tests/join.ur | 3 +- 8 files changed, 181 insertions(+), 35 deletions(-) (limited to 'src/elab_env.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index a81ba30a..a67d007a 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -235,6 +235,17 @@ val sql_inner_join : tabs1 ::: {{Type}} -> tabs2 ::: {{Type}} -> sql_exp (tabs1 ++ tabs2) [] [] bool -> sql_from_items (tabs1 ++ tabs2) +class nullify :: Type -> Type -> Type +val nullify_option : t ::: Type -> nullify (option t) (option t) +val nullify_prim : t ::: Type -> sql_injectable_prim t -> nullify t (option t) + +val sql_left_join : tabs1 ::: {{Type}} -> tabs2 ::: {{(Type * Type)}} + -> [tabs1 ~ tabs2] + => $(map (fn r => $(map (fn p :: (Type * Type) => nullify p.1 p.2) r)) tabs2) + -> sql_from_items tabs1 -> sql_from_items (map (map (fn p :: (Type * Type) => p.1)) tabs2) + -> sql_exp (tabs1 ++ map (map (fn p :: (Type * Type) => p.1)) tabs2) [] [] bool + -> sql_from_items (tabs1 ++ map (map (fn p :: (Type * Type) => p.2)) tabs2) + val sql_query1 : tables ::: {{Type}} -> grouped ::: {{Type}} -> selectedFields ::: {{Type}} diff --git a/src/elab_env.sig b/src/elab_env.sig index 4b927a16..1621722f 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -71,7 +71,7 @@ signature ELAB_ENV = sig val pushClass : env -> int -> env val isClass : env -> Elab.con -> bool - val resolveClass : env -> Elab.con -> Elab.exp option + val resolveClass : (Elab.con -> Elab.con) -> env -> Elab.con -> Elab.exp option val listClasses : env -> (Elab.con * (Elab.con * Elab.exp) list) list val pushERel : env -> string -> Elab.con -> env diff --git a/src/elab_env.sml b/src/elab_env.sml index 62a310f2..7b20a700 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -507,6 +507,8 @@ fun unifyCons rs = (CUnif (_, _, _, ref (SOME c1)), _) => unify d (c1, c2) | (_, CUnif (_, _, _, ref (SOME c2))) => unify d (c1, c2) + | (CUnif _, _) => () + | (c1', CRel n2) => if n2 < d then case c1' of @@ -587,7 +589,56 @@ fun unifySubst (rs : con list) = | (d, _) => d} 0 -fun resolveClass (env : env) = +fun postUnify x = + let + fun unify (c1, c2) = + case (#1 c1, #1 c2) of + (CUnif (_, _, _, ref (SOME c1)), _) => unify (c1, c2) + | (_, CUnif (_, _, _, ref (SOME c2))) => unify (c1, c2) + + | (CUnif (_, _, _, r), _) => r := SOME c2 + + | (TFun (d1, r1), TFun (d2, r2)) => (unify (d1, d2); unify (r1, r2)) + | (TCFun (_, _, k1, r1), TCFun (_, _, k2, r2)) => (unifyKinds (k1, k2); unify (r1, r2)) + | (TRecord c1, TRecord c2) => unify (c1, c2) + | (TDisjoint (a1, b1, c1), TDisjoint (a2, b2, c2)) => + (unify (a1, a2); unify (b1, b2); unify (c1, c2)) + + | (CRel n1, CRel n2) => if n1 = n2 then () else raise Unify + | (CNamed n1, CNamed n2) => if n1 = n2 then () else raise Unify + | (CModProj (n1, ms1, x1), CModProj (n2, ms2, x2)) => + if n1 = n2 andalso ms1 = ms2 andalso x1 = x2 then () else raise Unify + | (CApp (f1, x1), CApp (f2, x2)) => (unify (f1, f2); unify (x1, x2)) + | (CAbs (_, k1, b1), CAbs (_, k2, b2)) => (unifyKinds (k1, k2); unify (b1, b2)) + + | (CKAbs (_, b1), CKAbs (_, b2)) => unify (b1, b2) + | (CKApp (c1, k1), CKApp (c2, k2)) => (unify (c1, c2); unifyKinds (k1, k2)) + | (TKFun (_, c1), TKFun (_, c2)) => unify (c1, c2) + + | (CName s1, CName s2) => if s1 = s2 then () else raise Unify + + | (CRecord (k1, xcs1), CRecord (k2, xcs2)) => + (unifyKinds (k1, k2); + ListPair.appEq (fn ((x1, c1), (x2, c2)) => (unify (x1, x2); unify (c1, c2))) (xcs1, xcs2) + handle ListPair.UnequalLengths => raise Unify) + | (CConcat (f1, x1), CConcat (f2, x2)) => (unify (f1, f2); unify (x1, x2)) + | (CMap (d1, r1), CMap (d2, r2)) => (unifyKinds (d1, d2); unifyKinds (r1, r2)) + + | (CUnit, CUnit) => () + + | (CTuple cs1, CTuple cs2) => (ListPair.appEq unify (cs1, cs2) + handle ListPair.UnequalLengths => raise Unify) + | (CProj (c1, n1), CProj (c2, n2)) => (unify (c1, c2); + if n1 = n2 then () else raise Unify) + + | _ => raise Unify + in + unify x + end + +fun postUnifies x = (postUnify x; true) handle Unify => false + +fun resolveClass (hnorm : con -> con) (env : env) = let fun resolve c = let @@ -608,7 +659,8 @@ fun resolveClass (env : env) = let val eos = map (resolve o unifySubst rs) cs in - if List.exists (not o Option.isSome) eos then + if List.exists (not o Option.isSome) eos + orelse not (postUnifies (c, unifySubst rs c')) then tryRules rules' else let @@ -634,9 +686,34 @@ fun resolveClass (env : env) = tryGrounds (#ground class) end in - case class_head_in c of - SOME f => doHead f - | _ => NONE + case #1 c of + TRecord c => + (case #1 (hnorm c) of + CRecord (_, xts) => + let + fun resolver (xts, acc) = + case xts of + [] => SOME (ERecord acc, #2 c) + | (x, t) :: xts => + let + val t = hnorm t + + val t = case t of + (CApp (f, x), loc) => (CApp (hnorm f, hnorm x), loc) + | _ => t + in + case resolve t of + NONE => NONE + | SOME e => resolver (xts, (x, e, t) :: acc) + end + in + resolver (xts, []) + end + | _ => NONE) + | _ => + case class_head_in c of + SOME f => doHead f + | _ => NONE end in resolve diff --git a/src/elaborate.sml b/src/elaborate.sml index ea4c28bd..709871da 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1131,26 +1131,35 @@ | (L'.TFun (dom, ran), _) => let fun default () = (e, t, []) + + fun isInstance () = + if infer <> L.TypesOnly then + let + val r = ref NONE + val (e, t, gs) = unravel (ran, (L'.EApp (e, (L'.EUnif r, loc)), loc)) + in + (e, t, TypeClass (env, dom, r, loc) :: gs) + end + else + default () + + fun hasInstance c = + case #1 (hnormCon env c) of + L'.CApp (cl, x) => + let + val cl = hnormCon env cl + in + isClassOrFolder env cl + end + | L'.TRecord c => U.Con.exists {kind = fn _ => false, + con = fn c => + E.isClass env (hnormCon env (c, loc))} c + | _ => false in - case #1 (hnormCon env dom) of - L'.CApp (cl, x) => - let - val cl = hnormCon env cl - in - if infer <> L.TypesOnly then - if isClassOrFolder env cl then - let - val r = ref NONE - val (e, t, gs) = unravel (ran, (L'.EApp (e, (L'.EUnif r, loc)), loc)) - in - (e, t, TypeClass (env, dom, r, loc) :: gs) - end - else - default () - else - default () - end - | _ => default () + if hasInstance dom then + isInstance () + else + default () end | (L'.TDisjoint (r1, r2, t'), loc) => if infer <> L.TypesOnly then @@ -3638,7 +3647,7 @@ fun elabFile basis topStr topSgn env file = let val c = normClassKey env c in - case E.resolveClass env c of + case E.resolveClass (hnormCon env) env c of SOME e => r := SOME e | NONE => expError env (Unresolvable (loc, c)) end) gs @@ -3685,11 +3694,6 @@ fun elabFile basis topStr topSgn env file = (!delayedUnifs); delayedUnifs := []; - if ErrorMsg.anyErrors () then - () - else - app (fn f => f ()) (!checks); - if ErrorMsg.anyErrors () then () else @@ -3708,7 +3712,7 @@ fun elabFile basis topStr topSgn env file = val c = normClassKey env c in - case E.resolveClass env c of + case E.resolveClass (hnormCon env) env c of SOME e => r := SOME e | NONE => case #1 (hnormCon env c) of @@ -3747,6 +3751,11 @@ fun elabFile basis topStr topSgn env file = | _ => default () end) gs; + if ErrorMsg.anyErrors () then + () + else + app (fn f => f ()) (!checks); + (L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan) :: ds @ (L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan) diff --git a/src/monoize.sml b/src/monoize.sml index 98a32492..1a502e51 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -189,6 +189,8 @@ fun monoType env = (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc) | L.CApp ((L.CFfi ("Basis", "sql_injectable"), _), t) => (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "nullify"), _), _), _), _) => + (L'.TRecord [], loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_unary"), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_binary"), _), _), _), _), _), _) => @@ -581,6 +583,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.ERecord [("Lt", lt, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)), ("Le", le, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc))], loc), fm) + + fun outerRec xts = + (L'.TRecord (map (fn ((L.CName x, _), (L.CRecord (_, xts), _)) => + (x, (L'.TRecord (map (fn (x', _) => (x, (L'.TRecord [], loc))) xts), loc)) + | (x, all as (_, loc)) => + (E.errorAt loc "Unsupported record field constructor"; + Print.eprefaces' [("Name", CorePrint.p_con env x), + ("Constructor", CorePrint.p_con env all)]; + ("", dummyTyp))) xts), loc) in case e of L.EPrim p => ((L'.EPrim p, loc), fm) @@ -1702,6 +1713,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end + | L.ECApp ((L.EFfi ("Basis", "nullify_option"), _), _) => + ((L'.ERecord [], loc), fm) + | L.ECApp ((L.EFfi ("Basis", "nullify_prim"), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), + (L'.ERecord [], loc)), loc), + fm) + | L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) => ((L'.ERecord [], loc), fm) | L.ECApp ((L.EFfi ("Basis", "sql_subset_all"), _), _) => @@ -1744,6 +1762,25 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EPrim (Prim.String ")"), loc)]), loc)), loc)), loc), fm) end + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_left_join"), _), _), _), (L.CRecord (_, right), _)) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("_", outerRec right, + (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), + (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), + (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc), + (L'.EAbs ("on", s, s, + strcat [(L'.EPrim (Prim.String "("), loc), + (L'.ERel 2, loc), + (L'.EPrim (Prim.String " LEFT JOIN "), loc), + (L'.ERel 1, loc), + (L'.EPrim (Prim.String " ON "), loc), + (L'.ERel 0, loc), + (L'.EPrim (Prim.String ")"), loc)]), + loc)), loc)), loc)), loc), + fm) + end | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) => ((L'.EPrim (Prim.String ""), loc), fm) diff --git a/src/urweb.grm b/src/urweb.grm index 723ed8b1..c1f0b1ca 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -213,7 +213,7 @@ datatype attr = Class of exp | Normal of con * exp | CURRENT_TIMESTAMP | NE | LT | LE | GT | GE | CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES - | JOIN | INNER | CROSS + | JOIN | INNER | CROSS | LEFT %nonterm file of decl list @@ -361,7 +361,7 @@ datatype attr = Class of exp | Normal of con * exp %nonassoc DCOLON TCOLON %left UNION INTERSECT EXCEPT %right COMMA -%right JOIN INNER CROSS +%right JOIN INNER CROSS LEFT %right OR %right CAND %nonassoc EQ NE LT LE GT GE IS @@ -1468,6 +1468,16 @@ fitem : table' ([#1 table'], #2 table') (#1 fitem1 @ #1 fitem2, (EApp (e, tru), loc)) end) + | fitem LEFT JOIN fitem ON sqlexp (let + val loc = s (fitem1left, sqlexpright) + + val e = (EVar (["Basis"], "sql_left_join", Infer), loc) + val e = (EApp (e, #2 fitem1), loc) + val e = (EApp (e, #2 fitem2), loc) + in + (#1 fitem1 @ #1 fitem2, + (EApp (e, sqlexp), loc)) + end) tname : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) | LBRACE cexp RBRACE (cexp) diff --git a/src/urweb.lex b/src/urweb.lex index c20e9206..517054b3 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -341,6 +341,7 @@ notags = [^<{\n]+; "JOIN" => (Tokens.JOIN (pos yypos, pos yypos + size yytext)); "INNER" => (Tokens.INNER (pos yypos, pos yypos + size yytext)); "CROSS" => (Tokens.CROSS (pos yypos, pos yypos + size yytext)); + "LEFT" => (Tokens.LEFT (pos yypos, pos yypos + size yytext)); "UNION" => (Tokens.UNION (pos yypos, pos yypos + size yytext)); "INTERSECT" => (Tokens.INTERSECT (pos yypos, pos yypos + size yytext)); diff --git a/tests/join.ur b/tests/join.ur index 30a0e744..74f49eec 100644 --- a/tests/join.ur +++ b/tests/join.ur @@ -1,8 +1,9 @@ -table t : { A : int } +table t : { A : int, B : string, C : option string } fun main () = r <- oneRow (SELECT * FROM t); r <- oneRow (SELECT * FROM t AS T1, t AS T2); r <- oneRow (SELECT * FROM t AS T1 CROSS JOIN t AS T2); r <- oneRow (SELECT * FROM t AS T1 JOIN t AS T2 ON T1.A = T2.A); + r <- oneRow (SELECT * FROM t AS T1 LEFT JOIN t AS T2 ON T1.A = T2.A); return -- cgit v1.2.3 From caf010bca085bea65037d194c3eb21ca8b83c23b Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 28 Apr 2009 14:02:23 -0400 Subject: Preparing to allow views in SELECT FROM clauses --- lib/ur/basis.urs | 13 +++- src/elab_env.sig | 5 +- src/elab_env.sml | 85 ++++++++++------------- src/elaborate.sml | 197 ++++++++++++++++++++++++++++++++++-------------------- src/monoize.sml | 11 ++- 5 files changed, 183 insertions(+), 128 deletions(-) (limited to 'src/elab_env.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index c80dde7c..ec31e57f 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -124,6 +124,13 @@ val self : transaction client (** SQL *) con sql_table :: {Type} -> {{Unit}} -> Type +con sql_view :: {Type} -> Type + +class fieldsOf :: Type -> {Type} -> Type +val fieldsOf_table : fs ::: {Type} -> keys ::: {{Unit}} + -> fieldsOf (sql_table fs keys) fs +val fieldsOf_view : fs ::: {Type} + -> fieldsOf (sql_view fs) fs (*** Constraints *) @@ -222,9 +229,9 @@ val sql_subset_all : tables :: {{Type}} -> sql_subset tables tables con sql_from_items :: {{Type}} -> Type -val sql_from_table : cols ::: {Type} -> keys ::: {{Unit}} - -> name :: Name -> sql_table cols keys - -> sql_from_items [name = cols] +val sql_from_table : t ::: Type -> fs ::: {Type} + -> fieldsOf t fs -> name :: Name + -> t -> sql_from_items [name = fs] val sql_from_comma : tabs1 ::: {{Type}} -> tabs2 ::: {{Type}} -> [tabs1 ~ tabs2] => sql_from_items tabs1 -> sql_from_items tabs2 diff --git a/src/elab_env.sig b/src/elab_env.sig index 1621722f..a5b8751a 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -71,7 +71,8 @@ signature ELAB_ENV = sig val pushClass : env -> int -> env val isClass : env -> Elab.con -> bool - val resolveClass : (Elab.con -> Elab.con) -> env -> Elab.con -> Elab.exp option + val resolveClass : (Elab.con -> Elab.con) -> (Elab.con * Elab.con -> bool) + -> env -> Elab.con -> Elab.exp option val listClasses : env -> (Elab.con * (Elab.con * Elab.exp) list) list val pushERel : env -> string -> Elab.con -> env @@ -118,4 +119,6 @@ signature ELAB_ENV = sig val patBinds : env -> Elab.pat -> env + exception Bad of Elab.con * Elab.con + end diff --git a/src/elab_env.sml b/src/elab_env.sml index 7b20a700..0184d0b1 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -589,56 +589,9 @@ fun unifySubst (rs : con list) = | (d, _) => d} 0 -fun postUnify x = - let - fun unify (c1, c2) = - case (#1 c1, #1 c2) of - (CUnif (_, _, _, ref (SOME c1)), _) => unify (c1, c2) - | (_, CUnif (_, _, _, ref (SOME c2))) => unify (c1, c2) - - | (CUnif (_, _, _, r), _) => r := SOME c2 - - | (TFun (d1, r1), TFun (d2, r2)) => (unify (d1, d2); unify (r1, r2)) - | (TCFun (_, _, k1, r1), TCFun (_, _, k2, r2)) => (unifyKinds (k1, k2); unify (r1, r2)) - | (TRecord c1, TRecord c2) => unify (c1, c2) - | (TDisjoint (a1, b1, c1), TDisjoint (a2, b2, c2)) => - (unify (a1, a2); unify (b1, b2); unify (c1, c2)) - - | (CRel n1, CRel n2) => if n1 = n2 then () else raise Unify - | (CNamed n1, CNamed n2) => if n1 = n2 then () else raise Unify - | (CModProj (n1, ms1, x1), CModProj (n2, ms2, x2)) => - if n1 = n2 andalso ms1 = ms2 andalso x1 = x2 then () else raise Unify - | (CApp (f1, x1), CApp (f2, x2)) => (unify (f1, f2); unify (x1, x2)) - | (CAbs (_, k1, b1), CAbs (_, k2, b2)) => (unifyKinds (k1, k2); unify (b1, b2)) - - | (CKAbs (_, b1), CKAbs (_, b2)) => unify (b1, b2) - | (CKApp (c1, k1), CKApp (c2, k2)) => (unify (c1, c2); unifyKinds (k1, k2)) - | (TKFun (_, c1), TKFun (_, c2)) => unify (c1, c2) - - | (CName s1, CName s2) => if s1 = s2 then () else raise Unify - - | (CRecord (k1, xcs1), CRecord (k2, xcs2)) => - (unifyKinds (k1, k2); - ListPair.appEq (fn ((x1, c1), (x2, c2)) => (unify (x1, x2); unify (c1, c2))) (xcs1, xcs2) - handle ListPair.UnequalLengths => raise Unify) - | (CConcat (f1, x1), CConcat (f2, x2)) => (unify (f1, f2); unify (x1, x2)) - | (CMap (d1, r1), CMap (d2, r2)) => (unifyKinds (d1, d2); unifyKinds (r1, r2)) - - | (CUnit, CUnit) => () - - | (CTuple cs1, CTuple cs2) => (ListPair.appEq unify (cs1, cs2) - handle ListPair.UnequalLengths => raise Unify) - | (CProj (c1, n1), CProj (c2, n2)) => (unify (c1, c2); - if n1 = n2 then () else raise Unify) +exception Bad of con * con - | _ => raise Unify - in - unify x - end - -fun postUnifies x = (postUnify x; true) handle Unify => false - -fun resolveClass (hnorm : con -> con) (env : env) = +fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) = let fun resolve c = let @@ -649,6 +602,37 @@ fun resolveClass (hnorm : con -> con) (env : env) = let val loc = #2 c + fun generalize (c as (_, loc)) = + case #1 c of + CApp (f, x) => + let + val (f, equate) = generalize f + + fun isRecord () = + let + val rk = ref NONE + val k = (KUnif (loc, "k", rk), loc) + val r = ref NONE + val rc = (CUnif (loc, k, "x", r), loc) + in + ((CApp (f, rc), loc), + fn () => (if consEq (rc, x) then + true + else + (raise Bad (rc, x); + false)) + andalso equate ()) + end + in + case #1 x of + CConcat _ => isRecord () + | CRecord _ => isRecord () + | _ => ((CApp (f, x), loc), equate) + end + | _ => (c, fn () => true) + + val (c, equate) = generalize c + fun tryRules rules = case rules of [] => NONE @@ -660,7 +644,8 @@ fun resolveClass (hnorm : con -> con) (env : env) = val eos = map (resolve o unifySubst rs) cs in if List.exists (not o Option.isSome) eos - orelse not (postUnifies (c, unifySubst rs c')) then + orelse not (equate ()) + orelse not (consEq (c, unifySubst rs c')) then tryRules rules' else let diff --git a/src/elaborate.sml b/src/elaborate.sml index 709871da..81fcbda1 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -647,6 +647,13 @@ case hnormKind (kindof env c) of (L'.KRecord k, _) => k | (L'.KError, _) => kerror + | (L'.KUnif (_, _, r), _) => + let + val k = kunif (#2 c) + in + r := SOME (L'.KRecord k, #2 c); + k + end | k => raise CUnify' (CKindof (k, c, "record")) val k1 = rkindof c1 @@ -786,20 +793,25 @@ (*val () = eprefaces "Summaries4" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}), ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*) - fun isGuessable (other, fs) = - (guessMap env (other, (L'.CRecord (k, fs), loc), GuessFailure); - true) - handle GuessFailure => false + fun isGuessable (other, fs, unifs) = + let + val c = (L'.CRecord (k, fs), loc) + val c = foldl (fn ((c', _), c) => (L'.CConcat (c', c), loc)) c unifs + in + (guessMap env (other, c, GuessFailure); + true) + handle GuessFailure => false + end val (fs1, fs2, others1, others2) = - case (fs1, fs2, others1, others2) of - ([], _, [other1], []) => - if isGuessable (other1, fs2) then + case (fs1, fs2, others1, others2, unifs1, unifs2) of + ([], _, [other1], [], [], _) => + if isGuessable (other1, fs2, unifs2) then ([], [], [], []) else (fs1, fs2, others1, others2) - | (_, [], [], [other2]) => - if isGuessable (other2, fs1) then + | (_, [], [], [other2], _, []) => + if isGuessable (other2, fs1, unifs1) then ([], [], [], []) else (fs1, fs2, others1, others2) @@ -866,6 +878,13 @@ unfold (r2, c2'); unifyCons env r (L'.CConcat (r1, r2), loc) end + | L'.CUnif (_, _, _, ref (SOME c)) => unfold (r, c) + | L'.CUnif (_, _, _, ur as ref NONE) => + let + val ur' = cunif (loc, (L'.KRecord dom, loc)) + in + ur := SOME (L'.CApp ((L'.CApp ((L'.CMap (dom, ran), loc), f), loc), ur'), loc) + end | _ => raise ex in unfold (r, c) @@ -1144,17 +1163,21 @@ default () fun hasInstance c = - case #1 (hnormCon env c) of - L'.CApp (cl, x) => + case hnormCon env c of + (L'.TRecord c, _) => U.Con.exists {kind = fn _ => false, + con = fn c => + E.isClass env (hnormCon env (c, loc))} c + | c => let - val cl = hnormCon env cl + fun findHead c = + case #1 c of + L'.CApp (f, _) => findHead f + | _ => c + + val cl = hnormCon env (findHead c) in isClassOrFolder env cl end - | L'.TRecord c => U.Con.exists {kind = fn _ => false, - con = fn c => - E.isClass env (hnormCon env (c, loc))} c - | _ => false in if hasInstance dom then isInstance () @@ -3647,7 +3670,7 @@ fun elabFile basis topStr topSgn env file = let val c = normClassKey env c in - case E.resolveClass (hnormCon env) env c of + case E.resolveClass (hnormCon env) (consEq env) env c of SOME e => r := SOME e | NONE => expError env (Unresolvable (loc, c)) end) gs @@ -3684,72 +3707,102 @@ fun elabFile basis topStr topSgn env file = end val (file, (_, gs)) = ListUtil.foldlMapConcat elabDecl' (env', []) file - in - mayDelay := false; - app (fn (env, k, s1, s2) => - unifySummaries env (k, normalizeRecordSummary env s1, normalizeRecordSummary env s2) - handle CUnify' err => (ErrorMsg.errorAt (#2 k) "Error in final record unification"; - cunifyError env err)) - (!delayedUnifs); + val delayed = !delayedUnifs + in delayedUnifs := []; + app (fn (env, k, s1, s2) => + unifySummaries env (k, normalizeRecordSummary env s1, normalizeRecordSummary env s2)) + delayed; if ErrorMsg.anyErrors () then () else - app (fn Disjoint (loc, env, denv, c1, c2) => - (case D.prove env denv (c1, c2, loc) of - [] => () - | _ => - (ErrorMsg.errorAt loc "Couldn't prove field name disjointness"; - eprefaces' [("Con 1", p_con env c1), - ("Con 2", p_con env c2), - ("Hnormed 1", p_con env (ElabOps.hnormCon env c1)), - ("Hnormed 2", p_con env (ElabOps.hnormCon env c2))])) - | TypeClass (env, c, r, loc) => + let + fun solver gs = let - fun default () = expError env (Unresolvable (loc, c)) + val (gs, solved) = + ListUtil.foldlMapPartial + (fn (g, solved) => + case g of + Disjoint (loc, env, denv, c1, c2) => + (case D.prove env denv (c1, c2, loc) of + [] => (NONE, true) + | _ => (SOME g, solved)) + | TypeClass (env, c, r, loc) => + let + fun default () = (SOME g, solved) - val c = normClassKey env c - in - case E.resolveClass (hnormCon env) env c of - SOME e => r := SOME e - | NONE => - case #1 (hnormCon env c) of - L'.CApp (f, x) => - (case (#1 (hnormCon env f), #1 (hnormCon env x)) of - (L'.CKApp (f, _), L'.CRecord (k, xcs)) => - (case #1 (hnormCon env f) of - L'.CModProj (top_n', [], "folder") => - if top_n' = top_n then - let - val e = (L'.EModProj (top_n, ["Folder"], "nil"), loc) - val e = (L'.EKApp (e, k), loc) - - val (folder, _) = foldr (fn ((x, c), (folder, xcs)) => - let - val e = (L'.EModProj (top_n, ["Folder"], - "cons"), loc) - val e = (L'.EKApp (e, k), loc) - val e = (L'.ECApp (e, - (L'.CRecord (k, xcs), - loc)), loc) - val e = (L'.ECApp (e, x), loc) - val e = (L'.ECApp (e, c), loc) - val e = (L'.EApp (e, folder), loc) - in - (e, (x, c) :: xcs) - end) - (e, []) xcs - in - r := SOME folder - end - else - default () + val c = normClassKey env c + in + case E.resolveClass (hnormCon env) (consEq env) env c of + SOME e => (r := SOME e; + (NONE, true)) + | NONE => + case #1 (hnormCon env c) of + L'.CApp (f, x) => + (case (#1 (hnormCon env f), #1 (hnormCon env x)) of + (L'.CKApp (f, _), L'.CRecord (k, xcs)) => + (case #1 (hnormCon env f) of + L'.CModProj (top_n', [], "folder") => + if top_n' = top_n then + let + val e = (L'.EModProj (top_n, ["Folder"], "nil"), loc) + val e = (L'.EKApp (e, k), loc) + + val (folder, _) = foldr (fn ((x, c), (folder, xcs)) => + let + val e = (L'.EModProj (top_n, ["Folder"], + "cons"), loc) + val e = (L'.EKApp (e, k), loc) + val e = (L'.ECApp (e, + (L'.CRecord (k, xcs), + loc)), loc) + val e = (L'.ECApp (e, x), loc) + val e = (L'.ECApp (e, c), loc) + val e = (L'.EApp (e, folder), loc) + in + (e, (x, c) :: xcs) + end) + (e, []) xcs + in + (r := SOME folder; + (NONE, true)) + end + else + default () | _ => default ()) | _ => default ()) | _ => default () - end) gs; + end) + false gs + in + case (gs, solved) of + ([], _) => () + | (_, true) => solver gs + | _ => + app (fn Disjoint (loc, env, denv, c1, c2) => + ((ErrorMsg.errorAt loc "Couldn't prove field name disjointness"; + eprefaces' [("Con 1", p_con env c1), + ("Con 2", p_con env c2), + ("Hnormed 1", p_con env (ElabOps.hnormCon env c1)), + ("Hnormed 2", p_con env (ElabOps.hnormCon env c2))])) + | TypeClass (env, c, r, loc) => + expError env (Unresolvable (loc, c))) + gs + end + in + solver gs + end; + + mayDelay := false; + + app (fn (env, k, s1, s2) => + unifySummaries env (k, normalizeRecordSummary env s1, normalizeRecordSummary env s2) + handle CUnify' err => (ErrorMsg.errorAt (#2 k) "Error in final record unification"; + cunifyError env err)) + (!delayedUnifs); + delayedUnifs := []; if ErrorMsg.anyErrors () then () diff --git a/src/monoize.sml b/src/monoize.sml index 16839cf9..ccc5a851 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -184,6 +184,8 @@ fun monoType env = (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "sql_offset") => (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "fieldsOf"), _), _), _), _) => + (L'.TRecord [], loc) | L.CApp ((L.CFfi ("Basis", "sql_injectable_prim"), _), t) => (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc) @@ -1725,8 +1727,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.ECApp ((L.EFfi ("Basis", "sql_subset_all"), _), _) => ((L'.ERecord [], loc), fm) - | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_table"), _), _), _), _), _), - (L.CName name, _)) => + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "fieldsOf_table"), _), _), _), _) => + ((L'.ERecord [], loc), fm) + | L.ECApp ((L.EFfi ("Basis", "fieldsOf_view"), _), _) => + ((L'.ERecord [], loc), fm) + + | L.ECApp ((L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_table"), _), _), _), _), _), _), _), + (L.CName name, _)) => let val s = (L'.TFfi ("Basis", "string"), loc) in -- cgit v1.2.3 From 51f2a80dac5c3cd25a27fb5abfdfa50d813ab0b2 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 28 Apr 2009 15:04:37 -0400 Subject: A view query works --- src/cjr.sml | 1 + src/cjr_env.sml | 1 + src/cjr_print.sml | 20 ++++++++++++ src/cjrize.sml | 28 +++++++++++++++++ src/core.sml | 1 + src/core_env.sml | 7 +++++ src/core_print.sml | 7 +++++ src/core_util.sml | 15 +++++++++ src/corify.sml | 8 +++++ src/elab.sml | 1 + src/elab_env.sml | 82 ++++++++++++++++++++++++++++++++----------------- src/elab_print.sml | 7 +++++ src/elab_util.sml | 14 +++++++++ src/elaborate.sml | 47 ++++++++++++++++++++++------ src/elisp/urweb-mode.el | 2 +- src/expl.sml | 1 + src/expl_env.sml | 7 +++++ src/expl_print.sml | 7 +++++ src/explify.sml | 2 ++ src/mono.sml | 1 + src/mono_env.sml | 1 + src/mono_opt.sml | 25 +++++++++++++++ src/mono_print.sml | 7 +++++ src/mono_shake.sml | 2 ++ src/mono_util.sml | 6 ++++ src/monoize.sml | 18 +++++++++++ src/prepare.sml | 1 + src/reduce.sml | 1 + src/reduce_local.sml | 1 + src/shake.sml | 5 ++- src/source.sml | 1 + src/source_print.sml | 7 +++++ src/unnest.sml | 1 + src/urweb.grm | 13 +++++++- src/urweb.lex | 1 + tests/view.ur | 10 ++++++ tests/view.urp | 5 +++ tests/view.urs | 1 + 38 files changed, 325 insertions(+), 40 deletions(-) create mode 100644 tests/view.ur create mode 100644 tests/view.urp create mode 100644 tests/view.urs (limited to 'src/elab_env.sml') diff --git a/src/cjr.sml b/src/cjr.sml index 559b7ada..d3fdbc22 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -107,6 +107,7 @@ datatype decl' = | DTable of string * (string * typ) list * string * (string * string) list | DSequence of string + | DView of string * (string * typ) list * string | DDatabase of {name : string, expunge : int, initialize : int} | DPreparedStatements of (string * int) list diff --git a/src/cjr_env.sml b/src/cjr_env.sml index 7f02a4e9..54dbea17 100644 --- a/src/cjr_env.sml +++ b/src/cjr_env.sml @@ -164,6 +164,7 @@ fun declBinds env (d, loc) = end) env vis | DTable _ => env | DSequence _ => env + | DView _ => env | DDatabase _ => env | DPreparedStatements _ => env | DJavaScript _ => env diff --git a/src/cjr_print.sml b/src/cjr_print.sml index c870c3ed..a09dd7f6 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2069,6 +2069,15 @@ fun p_decl env (dAll as (d, _) : decl) = string x, string " */", newline] + | DView (x, _, s) => box [string "/* SQL view ", + string x, + space, + string "AS", + space, + string s, + space, + string " */", + newline] | DDatabase {name, expunge, initialize} => box [string "static void uw_db_validate(uw_context);", newline, @@ -3089,6 +3098,17 @@ fun p_sql env (ds, _) = string ";", newline, newline] + | DView (s, xts, q) => + box [string "CREATE VIEW", + space, + string s, + space, + string "AS", + space, + string q, + string ";", + newline, + newline] | _ => box [] in (pp, E.declBinds env dAll) diff --git a/src/cjrize.sml b/src/cjrize.sml index ee2ecdb6..19aeee4e 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -562,6 +562,34 @@ fun cifyDecl ((d, loc), sm) = end | L.DSequence s => (SOME (L'.DSequence s, loc), NONE, sm) + | L.DView (s, xts, e) => + let + val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) => + let + val (t, sm) = cifyTyp (t, sm) + in + ((x, t), sm) + end) sm xts + + fun flatten e = + case #1 e of + L.ERecord [] => [] + | L.ERecord [(x, (L.EPrim (Prim.String v), _), _)] => [(x, v)] + | L.EStrcat (e1, e2) => flatten e1 @ flatten e2 + | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined"; + Print.prefaces "Undetermined constraint" + [("e", MonoPrint.p_exp MonoEnv.empty e)]; + []) + + val e = case #1 e of + L.EPrim (Prim.String s) => s + | _ => (ErrorMsg.errorAt loc "VIEW query has not been fully determined"; + Print.prefaces "Undetermined VIEW query" + [("e", MonoPrint.p_exp MonoEnv.empty e)]; + "") + in + (SOME (L'.DView (s, xts, e), loc), NONE, sm) + end | L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm) | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm) | L.DCookie args => (SOME (L'.DCookie args, loc), NONE, sm) diff --git a/src/core.sml b/src/core.sml index 01cf4ec7..131bcc6f 100644 --- a/src/core.sml +++ b/src/core.sml @@ -130,6 +130,7 @@ datatype decl' = | DExport of export_kind * int | DTable of string * int * con * string * exp * con * exp * con | DSequence of string * int * string + | DView of string * int * string * exp * con | DDatabase of string | DCookie of string * int * con * string | DStyle of string * int * string diff --git a/src/core_env.sml b/src/core_env.sml index caf30349..0630fef2 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -327,6 +327,13 @@ fun declBinds env (d, loc) = in pushENamed env x n t NONE s end + | DView (x, n, s, _, c) => + let + val ct = (CFfi ("Basis", "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + pushENamed env x n ct NONE s + end | DDatabase _ => env | DCookie (x, n, c, s) => let diff --git a/src/core_print.sml b/src/core_print.sml index 9c1c72cd..f2a42a7b 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -566,6 +566,13 @@ fun p_decl env (dAll as (d, _) : decl) = string "as", space, string s] + | DView (x, n, s, e, _) => box [string "view", + space, + p_named x n, + space, + string "as", + space, + p_exp env e] | DDatabase s => box [string "database", space, string s] diff --git a/src/core_util.sml b/src/core_util.sml index d05aaa72..ae956121 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -946,6 +946,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = fn cc' => (DTable (x, n, c', s, pe', pc', ce', cc'), loc)))))) | DSequence _ => S.return2 dAll + | DView (x, n, s, e, c) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx c, + fn c' => + (DView (x, n, s, e', c'), loc))) | DDatabase _ => S.return2 dAll | DCookie (x, n, c, s) => S.map2 (mfc ctx c, @@ -1082,6 +1088,14 @@ fun mapfoldB (all as {bind, ...}) = in bind (ctx, NamedE (x, n, t, NONE, s)) end + | DView (x, n, s, _, c) => + let + val loc = #2 d' + val ct = (CFfi ("Basis", "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + bind (ctx, NamedE (x, n, ct, NONE, s)) + end | DDatabase _ => ctx | DCookie (x, n, c, s) => let @@ -1154,6 +1168,7 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DExport _ => count | DTable (_, n, _, _, _, _, _, _) => Int.max (n, count) | DSequence (_, n, _) => Int.max (n, count) + | DView (_, n, _, _, _) => Int.max (n, count) | DDatabase _ => count | DCookie (_, n, _, _) => Int.max (n, count) | DStyle (_, n, _) => Int.max (n, count)) 0 diff --git a/src/corify.sml b/src/corify.sml index c1cd940e..f1895e19 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -992,6 +992,13 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = in ([(L'.DSequence (x, n, s), loc)], st) end + | L.DView (_, x, n, e, c) => + let + val (st, n) = St.bindVal st x n + val s = relify (doRestify (mods, x)) + in + ([(L'.DView (x, n, s, corifyExp st e, corifyCon st c), loc)], st) + end | L.DDatabase s => ([(L'.DDatabase s, loc)], st) @@ -1063,6 +1070,7 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DExport _ => n | L.DTable (_, _, n', _, _, _, _, _) => Int.max (n, n') | L.DSequence (_, _, n') => Int.max (n, n') + | L.DView (_, _, n', _, _) => Int.max (n, n') | L.DDatabase _ => n | L.DCookie (_, _, n', _) => Int.max (n, n') | L.DStyle (_, _, n') => Int.max (n, n')) diff --git a/src/elab.sml b/src/elab.sml index f82a947d..555cc25c 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -165,6 +165,7 @@ datatype decl' = | DExport of int * sgn * str | DTable of int * string * int * con * exp * con * exp * con | DSequence of int * string * int + | DView of int * string * int * exp * con | DClass of string * int * kind * con | DDatabase of string | DCookie of int * string * int * con diff --git a/src/elab_env.sml b/src/elab_env.sml index 0184d0b1..efc2b74e 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -591,6 +591,22 @@ fun unifySubst (rs : con list) = exception Bad of con * con +val hasUnif = U.Con.exists {kind = fn _ => false, + con = fn CUnif (_, _, _, ref NONE) => true + | _ => false} + +fun startsWithUnif c = + let + fun firstArg (c, acc) = + case #1 c of + CApp (f, x) => firstArg (f, SOME x) + | _ => acc + in + case firstArg (c, NONE) of + NONE => false + | SOME x => hasUnif x + end + fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) = let fun resolve c = @@ -671,34 +687,37 @@ fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) = tryGrounds (#ground class) end in - case #1 c of - TRecord c => - (case #1 (hnorm c) of - CRecord (_, xts) => - let - fun resolver (xts, acc) = - case xts of - [] => SOME (ERecord acc, #2 c) - | (x, t) :: xts => - let - val t = hnorm t - - val t = case t of - (CApp (f, x), loc) => (CApp (hnorm f, hnorm x), loc) - | _ => t - in - case resolve t of - NONE => NONE - | SOME e => resolver (xts, (x, e, t) :: acc) - end - in - resolver (xts, []) - end - | _ => NONE) - | _ => - case class_head_in c of - SOME f => doHead f - | _ => NONE + if startsWithUnif c then + NONE + else + case #1 c of + TRecord c => + (case #1 (hnorm c) of + CRecord (_, xts) => + let + fun resolver (xts, acc) = + case xts of + [] => SOME (ERecord acc, #2 c) + | (x, t) :: xts => + let + val t = hnorm t + + val t = case t of + (CApp (f, x), loc) => (CApp (hnorm f, hnorm x), loc) + | _ => t + in + case resolve t of + NONE => NONE + | SOME e => resolver (xts, (x, e, t) :: acc) + end + in + resolver (xts, []) + end + | _ => NONE) + | _ => + case class_head_in c of + SOME f => doHead f + | _ => NONE end in resolve @@ -1482,6 +1501,13 @@ fun declBinds env (d, loc) = in pushENamedAs env x n t end + | DView (tn, x, n, _, c) => + let + val ct = (CModProj (tn, [], "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + pushENamedAs env x n ct + end | DClass (x, n, k, c) => let val k = (KArrow (k, (KType, loc)), loc) diff --git a/src/elab_print.sml b/src/elab_print.sml index e6a2cccb..bbbd9f8d 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -758,6 +758,13 @@ fun p_decl env (dAll as (d, _) : decl) = | DSequence (_, x, n) => box [string "sequence", space, p_named x n] + | DView (_, x, n, e, _) => box [string "view", + space, + p_named x n, + space, + string "as", + space, + p_exp env e] | DClass (x, n, k, c) => box [string "class", space, p_named x n, diff --git a/src/elab_util.sml b/src/elab_util.sml index 0d78951b..f4cbc951 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -791,6 +791,13 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f end | DSequence (tn, x, n) => bind (ctx, NamedE (x, (CModProj (n, [], "sql_sequence"), loc))) + | DView (tn, x, n, _, c) => + let + val ct = (CModProj (n, [], "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + bind (ctx, NamedE (x, ct)) + end | DClass (x, n, k, _) => bind (ctx, NamedC (x, n, (KArrow (k, (KType, loc)), loc))) | DDatabase _ => ctx @@ -899,6 +906,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f fn cc' => (DTable (tn, x, n, c', pe', pc', ce', cc'), loc)))))) | DSequence _ => S.return2 dAll + | DView (tn, x, n, e, c) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx c, + fn c' => + (DView (tn, x, n, e', c'), loc))) | DClass (x, n, k, c) => S.bind2 (mfk ctx k, @@ -1051,6 +1064,7 @@ and maxNameDecl (d, _) = | DExport _ => 0 | DTable (n1, _, n2, _, _, _, _, _) => Int.max (n1, n2) | DSequence (n1, _, n2) => Int.max (n1, n2) + | DView (n1, _, n2, _, _) => Int.max (n1, n2) | DDatabase _ => 0 | DCookie (n1, _, n2, _) => Int.max (n1, n2) | DStyle (n1, _, n2) => Int.max (n1, n2) diff --git a/src/elaborate.sml b/src/elaborate.sml index 81fcbda1..b9378e1b 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -803,19 +803,22 @@ handle GuessFailure => false end - val (fs1, fs2, others1, others2) = + val (fs1, fs2, others1, others2, unifs1, unifs2) = case (fs1, fs2, others1, others2, unifs1, unifs2) of ([], _, [other1], [], [], _) => if isGuessable (other1, fs2, unifs2) then - ([], [], [], []) + ([], [], [], [], [], []) else - (fs1, fs2, others1, others2) + (fs1, fs2, others1, others2, unifs1, unifs2) | (_, [], [], [other2], _, []) => if isGuessable (other2, fs1, unifs1) then - ([], [], [], []) + ([], [], [], [], [], []) else - (fs1, fs2, others1, others2) - | _ => (fs1, fs2, others1, others2) + (prefaces "Not guessable" [("other2", p_con env other2), + ("fs1", p_con env (L'.CRecord (k, fs1), loc)), + ("#unifs1", PD.string (Int.toString (length unifs1)))]; + (fs1, fs2, others1, others2, unifs1, unifs2)) + | _ => (fs1, fs2, others1, others2, unifs1, unifs2) (*val () = eprefaces "Summaries5" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}), ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*) @@ -849,7 +852,7 @@ fun unfold (dom, ran, f, r, c) = let fun unfold (r, c) = - case #1 c of + case #1 (hnormCon env c) of L'.CRecord (_, []) => unifyCons env r (L'.CRecord (dom, []), loc) | L'.CRecord (_, [(x, v)]) => let @@ -878,8 +881,7 @@ unfold (r2, c2'); unifyCons env r (L'.CConcat (r1, r2), loc) end - | L'.CUnif (_, _, _, ref (SOME c)) => unfold (r, c) - | L'.CUnif (_, _, _, ur as ref NONE) => + | L'.CUnif (_, _, _, ur) => let val ur' = cunif (loc, (L'.KRecord dom, loc)) in @@ -1935,6 +1937,8 @@ val hnormSgn = E.hnormSgn fun tableOf () = (L'.CModProj (!basis_r, [], "sql_table"), ErrorMsg.dummySpan) fun sequenceOf () = (L'.CModProj (!basis_r, [], "sql_sequence"), ErrorMsg.dummySpan) +fun viewOf () = (L'.CModProj (!basis_r, [], "sql_view"), ErrorMsg.dummySpan) +fun queryOf () = (L'.CModProj (!basis_r, [], "sql_query"), ErrorMsg.dummySpan) fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan) fun styleOf () = (L'.CModProj (!basis_r, [], "css_class"), ErrorMsg.dummySpan) @@ -2434,6 +2438,8 @@ and sgiOfDecl (d, loc) = [(L'.SgiVal (x, n, (L'.CApp ((L'.CApp (tableOf (), c), loc), (L'.CConcat (pc, cc), loc)), loc)), loc)] | L'.DSequence (tn, x, n) => [(L'.SgiVal (x, n, sequenceOf ()), loc)] + | L'.DView (tn, x, n, _, c) => + [(L'.SgiVal (x, n, (L'.CApp (viewOf (), c), loc)), loc)] | L'.DClass (x, n, k, c) => [(L'.SgiClass (x, n, k, c), loc)] | L'.DDatabase _ => [] | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] @@ -3405,6 +3411,29 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = in ([(L'.DSequence (!basis_r, x, n), loc)], (env, denv, gs)) end + | L.DView (x, e) => + let + val (e', t, gs') = elabExp (env, denv) e + + val k = (L'.KRecord (L'.KType, loc), loc) + val fs = cunif (loc, k) + val ts = cunif (loc, (L'.KRecord k, loc)) + val tf = (L'.CApp ((L'.CMap (k, k), loc), + (L'.CAbs ("_", k, (L'.CRecord ((L'.KType, loc), []), loc)), loc)), loc) + val ts = (L'.CApp (tf, ts), loc) + + val cv = viewOf () + val cv = (L'.CApp (cv, fs), loc) + val (env', n) = E.pushENamed env x cv + + val ct = queryOf () + val ct = (L'.CApp (ct, ts), loc) + val ct = (L'.CApp (ct, fs), loc) + in + checkCon env e' t ct; + ([(L'.DView (!basis_r, x, n, e', fs), loc)], + (env', denv, gs' @ gs)) + end | L.DClass (x, k, c) => let diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index 2cd27fcc..7f4b0dee 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -137,7 +137,7 @@ See doc for the variable `urweb-mode-info'." "fun" "functor" "if" "include" "of" "open" "let" "in" "rec" "sequence" "sig" "signature" "cookie" "style" - "struct" "structure" "table" "then" "type" "val" "where" + "struct" "structure" "table" "view" "then" "type" "val" "where" "with" "Name" "Type" "Unit") diff --git a/src/expl.sml b/src/expl.sml index e293c36b..cc40e8b4 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -143,6 +143,7 @@ datatype decl' = | DExport of int * sgn * str | DTable of int * string * int * con * exp * con * exp * con | DSequence of int * string * int + | DView of int * string * int * exp * con | DDatabase of string | DCookie of int * string * int * con | DStyle of int * string * int diff --git a/src/expl_env.sml b/src/expl_env.sml index 1e99b36b..2bb049a3 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -312,6 +312,13 @@ fun declBinds env (d, loc) = in pushENamed env x n t end + | DView (tn, x, n, _, c) => + let + val ct = (CModProj (tn, [], "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + pushENamed env x n ct + end | DDatabase _ => env | DCookie (tn, x, n, c) => let diff --git a/src/expl_print.sml b/src/expl_print.sml index 167c6850..e6b28fea 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -681,6 +681,13 @@ fun p_decl env (dAll as (d, _) : decl) = | DSequence (_, x, n) => box [string "sequence", space, p_named x n] + | DView (_, x, n, e, _) => box [string "view", + space, + p_named x n, + space, + string "as", + space, + p_exp env e] | DDatabase s => box [string "database", space, string s] diff --git a/src/explify.sml b/src/explify.sml index 6a33eabc..2e181771 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -182,6 +182,8 @@ fun explifyDecl (d, loc : EM.span) = SOME (L'.DTable (nt, x, n, explifyCon c, explifyExp pe, explifyCon pc, explifyExp ce, explifyCon cc), loc) + | L.DView (nt, x, n, e, c) => + SOME (L'.DView (nt, x, n, explifyExp e, explifyCon c), loc) | L.DSequence (nt, x, n) => SOME (L'.DSequence (nt, x, n), loc) | L.DClass (x, n, k, c) => SOME (L'.DCon (x, n, (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), explifyCon c), loc) diff --git a/src/mono.sml b/src/mono.sml index e9d30181..7a789e2c 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -127,6 +127,7 @@ datatype decl' = | DTable of string * (string * typ) list * exp * exp | DSequence of string + | DView of string * (string * typ) list * exp | DDatabase of {name : string, expunge : int, initialize : int} | DJavaScript of string diff --git a/src/mono_env.sml b/src/mono_env.sml index b3572fbe..739f2f89 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -109,6 +109,7 @@ fun declBinds env (d, loc) = | DExport _ => env | DTable _ => env | DSequence _ => env + | DView _ => env | DDatabase _ => env | DJavaScript _ => env | DCookie _ => env diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 19244e60..41724eb0 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -422,6 +422,31 @@ fun exp e = EPrim (Prim.String s) end + | EFfiApp ("Basis", "viewify", [(EPrim (Prim.String s), loc)]) => + let + fun uwify (cs, acc) = + case cs of + [] => String.concat (rev acc) + | #"A" :: #"S" :: #" " :: #"_" :: cs => uwify (cs, "AS uw_" :: acc) + | #"'" :: cs => + let + fun waitItOut (cs, acc) = + case cs of + [] => raise Fail "MonoOpt: Unterminated SQL string literal" + | #"'" :: cs => uwify (cs, "'" :: acc) + | #"\\" :: #"'" :: cs => waitItOut (cs, "\\'" :: acc) + | #"\\" :: #"\\" :: cs => waitItOut (cs, "\\\\" :: acc) + | c :: cs => waitItOut (cs, str c :: acc) + in + waitItOut (cs, "'" :: acc) + end + | c :: cs => uwify (cs, str c :: acc) + + val s = uwify (String.explode s, []) + in + EPrim (Prim.String s) + end + | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) diff --git a/src/mono_print.sml b/src/mono_print.sml index ffc1d4fe..a233b400 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -438,6 +438,13 @@ fun p_decl env (dAll as (d, _) : decl) = | DSequence s => box [string "(* SQL sequence ", string s, string "*)"] + | DView (s, _, e) => box [string "(* SQL view ", + string s, + space, + string "as", + space, + p_exp env e, + string "*)"] | DDatabase {name, expunge, initialize} => box [string "database", space, string name, diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 0060d036..4764feb7 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -57,6 +57,7 @@ fun shake file = | ((DExport _, _), acc) => acc | ((DTable _, _), acc) => acc | ((DSequence _, _), acc) => acc + | ((DView _, _), acc) => acc | ((DDatabase _, _), acc) => acc | ((DJavaScript _, _), acc) => acc | ((DCookie _, _), acc) => acc @@ -116,6 +117,7 @@ fun shake file = | (DExport _, _) => true | (DTable _, _) => true | (DSequence _, _) => true + | (DView _, _) => true | (DDatabase _, _) => true | (DJavaScript _, _) => true | (DCookie _, _) => true diff --git a/src/mono_util.sml b/src/mono_util.sml index dd848ba6..caf96ac7 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -492,6 +492,10 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = fn ce' => (DTable (s, xts, pe', ce'), loc))) | DSequence _ => S.return2 dAll + | DView (s, xts, e) => + S.map2 (mfe ctx e, + fn e' => + (DView (s, xts, e'), loc)) | DDatabase _ => S.return2 dAll | DJavaScript _ => S.return2 dAll | DCookie _ => S.return2 dAll @@ -575,6 +579,7 @@ fun mapfoldB (all as {bind, ...}) = | DExport _ => ctx | DTable _ => ctx | DSequence _ => ctx + | DView _ => ctx | DDatabase _ => ctx | DJavaScript _ => ctx | DCookie _ => ctx @@ -626,6 +631,7 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DExport _ => count | DTable _ => count | DSequence _ => count + | DView _ => count | DDatabase _ => count | DJavaScript _ => count | DCookie _ => count diff --git a/src/monoize.sml b/src/monoize.sml index ccc5a851..a2048a7d 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2938,6 +2938,24 @@ fun monoDecl (env, fm) (all as (d, loc)) = (L'.DVal (x, n, t', e_name, s), loc)]) end | L.DTable _ => poly () + | L.DView (x, n, s, e, (L.CRecord (_, xts), _)) => + let + val t = (L.CFfi ("Basis", "string"), loc) + val t' = (L'.TFfi ("Basis", "string"), loc) + val s = "uw_" ^ s + val e_name = (L'.EPrim (Prim.String s), loc) + + val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts + + val (e, fm) = monoExp (env, St.empty, fm) e + val e = (L'.EFfiApp ("Basis", "viewify", [e]), loc) + in + SOME (Env.pushENamed env x n t NONE s, + fm, + [(L'.DView (s, xts, e), loc), + (L'.DVal (x, n, t', e_name, s), loc)]) + end + | L.DView _ => poly () | L.DSequence (x, n, s) => let val t = (L.CFfi ("Basis", "string"), loc) diff --git a/src/prepare.sml b/src/prepare.sml index 25306e89..592b00bc 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -266,6 +266,7 @@ fun prepDecl (d as (_, loc), sns) = | DTable _ => (d, sns) | DSequence _ => (d, sns) + | DView _ => (d, sns) | DDatabase _ => (d, sns) | DPreparedStatements _ => (d, sns) | DJavaScript _ => (d, sns) diff --git a/src/reduce.sml b/src/reduce.sml index 914f26c0..665c10b4 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -467,6 +467,7 @@ fun reduce file = exp (namedC, namedE) [] ce, con namedC [] cc), loc), st) | DSequence _ => (d, st) + | DView (s, n, s', e, c) => ((DView (s, n, s', exp (namedC, namedE) [] e, con namedC [] c), loc), st) | DDatabase _ => (d, st) | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st) | DStyle (s, n, s') => ((DStyle (s, n, s'), loc), st) diff --git a/src/reduce_local.sml b/src/reduce_local.sml index 265cb2a4..6c25ebf3 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -158,6 +158,7 @@ fun reduce file = | DExport _ => d | DTable _ => d | DSequence _ => d + | DView _ => d | DDatabase _ => d | DCookie _ => d | DStyle _ => d diff --git a/src/shake.sml b/src/shake.sml index 787bfd2f..35af7436 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -84,6 +84,8 @@ fun shake file = (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DSequence (_, n, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], dummyt, dummye))) + | ((DView (_, n, _, _, c), _), (cdef, edef)) => + (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DDatabase _, _), acc) => acc | ((DCookie (_, n, c, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], c, dummye))) @@ -159,8 +161,9 @@ fun shake file = | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n) | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis | (DExport _, _) => true - | (DTable _, _) => true + | (DView _, _) => true | (DSequence _, _) => true + | (DTable _, _) => true | (DDatabase _, _) => true | (DCookie _, _) => true | (DStyle _, _) => true) file diff --git a/src/source.sml b/src/source.sml index 6645ae75..9d3eea79 100644 --- a/src/source.sml +++ b/src/source.sml @@ -161,6 +161,7 @@ datatype decl' = | DExport of str | DTable of string * con * exp * exp | DSequence of string + | DView of string * exp | DClass of string * kind * con | DDatabase of string | DCookie of string * con diff --git a/src/source_print.sml b/src/source_print.sml index 58867f64..0f8b093b 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -621,6 +621,13 @@ fun p_decl ((d, _) : decl) = | DSequence x => box [string "sequence", space, string x] + | DView (x, e) => box [string "view", + space, + string x, + space, + string "=", + space, + p_exp e] | DClass (x, k, c) => box [string "class", space, string x, diff --git a/src/unnest.sml b/src/unnest.sml index c321b34d..51b66aa4 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -404,6 +404,7 @@ fun unnest file = | DExport _ => default () | DTable _ => default () | DSequence _ => default () + | DView _ => default () | DClass _ => default () | DDatabase _ => default () | DCookie _ => default () diff --git a/src/urweb.grm b/src/urweb.grm index ce078279..da817ab3 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -195,7 +195,7 @@ datatype attr = Class of exp | Normal of con * exp | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE | CARET | LET | IN | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL - | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE + | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW | COOKIE | STYLE | CASE | IF | THEN | ELSE @@ -438,6 +438,10 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let | TABLE SYMBOL COLON cterm pkopt commaOpt cstopt([(DTable (SYMBOL, entable cterm, pkopt, cstopt), s (TABLEleft, cstoptright))]) | SEQUENCE SYMBOL ([(DSequence SYMBOL, s (SEQUENCEleft, SYMBOLright))]) + | VIEW SYMBOL EQ query ([(DView (SYMBOL, query), + s (VIEWleft, queryright))]) + | VIEW SYMBOL EQ LBRACE eexp RBRACE ([(DView (SYMBOL, eexp), + s (VIEWleft, RBRACEright))]) | CLASS SYMBOL EQ cexp (let val loc = s (CLASSleft, cexpright) in @@ -674,6 +678,13 @@ sgi : CON SYMBOL DCOLON kind ((SgiConAbs (SYMBOL, kind), s (CONleft, in (SgiVal (SYMBOL, t), loc) end) + | VIEW SYMBOL COLON cexp (let + val loc = s (VIEWleft, cexpright) + val t = (CVar (["Basis"], "sql_view"), loc) + val t = (CApp (t, cexp), loc) + in + (SgiVal (SYMBOL, t), loc) + end) | CLASS SYMBOL (let val loc = s (CLASSleft, SYMBOLright) val k = (KArrow ((KType, loc), (KType, loc)), loc) diff --git a/src/urweb.lex b/src/urweb.lex index bb9004a6..85cf3bcf 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -317,6 +317,7 @@ notags = [^<{\n]+; "export" => (Tokens.EXPORT (pos yypos, pos yypos + size yytext)); "table" => (Tokens.TABLE (pos yypos, pos yypos + size yytext)); "sequence" => (Tokens.SEQUENCE (pos yypos, pos yypos + size yytext)); + "view" => (Tokens.VIEW (pos yypos, pos yypos + size yytext)); "class" => (Tokens.CLASS (pos yypos, pos yypos + size yytext)); "cookie" => (Tokens.COOKIE (pos yypos, pos yypos + size yytext)); "style" => (Tokens.STYLE (pos yypos, pos yypos + size yytext)); diff --git a/tests/view.ur b/tests/view.ur new file mode 100644 index 00000000..36d77deb --- /dev/null +++ b/tests/view.ur @@ -0,0 +1,10 @@ +table t : { A : int, B : string } + +view v = SELECT t.A AS X FROM t + +fun main () = + rows <- queryX (SELECT * FROM v) + (fn r =>
  • {[r.V.X]}
    • ); + return + {rows} + diff --git a/tests/view.urp b/tests/view.urp new file mode 100644 index 00000000..3528ec9d --- /dev/null +++ b/tests/view.urp @@ -0,0 +1,5 @@ +debug +database dbname=view +sql view.sql + +view diff --git a/tests/view.urs b/tests/view.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/view.urs @@ -0,0 +1 @@ +val main : unit -> transaction page -- cgit v1.2.3 From 0159bec5067ac88f3f222595ac6f5e2f94c1d41f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 May 2009 15:14:17 -0400 Subject: Mutual datatypes through Elaborate --- src/elab.sml | 4 +- src/elab_env.sml | 144 ++++++++------ src/elab_print.sml | 14 +- src/elab_util.sml | 111 ++++++----- src/elaborate.sml | 527 +++++++++++++++++++++++++++++---------------------- src/explify.sml | 10 +- src/source.sml | 4 +- src/source_print.sml | 12 +- src/urweb.grm | 11 +- tests/mutual.ur | 2 + tests/mutual.urp | 3 + 11 files changed, 498 insertions(+), 344 deletions(-) create mode 100644 tests/mutual.ur create mode 100644 tests/mutual.urp (limited to 'src/elab_env.sml') diff --git a/src/elab.sml b/src/elab.sml index 555cc25c..de2db500 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -132,7 +132,7 @@ withtype exp = exp' located datatype sgn_item' = SgiConAbs of string * int * kind | SgiCon of string * int * kind * con - | SgiDatatype of string * int * string list * (string * int * con option) list + | SgiDatatype of (string * int * string list * (string * int * con option) list) list | SgiDatatypeImp of string * int * int * string list * string * string list * (string * int * con option) list | SgiVal of string * int * con | SgiStr of string * int * sgn @@ -154,7 +154,7 @@ and sgn = sgn' located datatype decl' = DCon of string * int * kind * con - | DDatatype of string * int * string list * (string * int * con option) list + | DDatatype of (string * int * string list * (string * int * con option) list) list | DDatatypeImp of string * int * int * string list * string * string list * (string * int * con option) list | DVal of string * int * con * exp | DValRec of (string * int * con * exp) list diff --git a/src/elab_env.sml b/src/elab_env.sml index efc2b74e..88b2554b 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -909,7 +909,7 @@ fun sgiSeek (sgi, (sgns, strs, cons)) = case sgi of SgiConAbs (x, n, _) => (sgns, strs, IM.insert (cons, n, x)) | SgiCon (x, n, _, _) => (sgns, strs, IM.insert (cons, n, x)) - | SgiDatatype (x, n, _, _) => (sgns, strs, IM.insert (cons, n, x)) + | SgiDatatype dts => (sgns, strs, foldl (fn ((x, n, _, _), cons) => IM.insert (cons, n, x)) cons dts) | SgiDatatypeImp (x, n, _, _, _, _, _) => (sgns, strs, IM.insert (cons, n, x)) | SgiVal _ => (sgns, strs, cons) | SgiSgn (x, n, _) => (IM.insert (sgns, n, x), strs, cons) @@ -929,7 +929,7 @@ fun sgnSeek f sgis = let val cons = case sgi of - SgiDatatype (x, n, _, _) => IM.insert (cons, n, x) + SgiDatatype dts => foldl (fn ((x, n, _, _), cons) => IM.insert (cons, n, x)) cons dts | SgiDatatypeImp (x, n, _, _, _, _, _) => IM.insert (cons, n, x) | _ => cons in @@ -1209,26 +1209,31 @@ fun sgiBinds env (sgi, loc) = case sgi of SgiConAbs (x, n, k) => pushCNamedAs env x n k NONE | SgiCon (x, n, k, c) => pushCNamedAs env x n k (SOME c) - | SgiDatatype (x, n, xs, xncs) => + | SgiDatatype dts => let - val k = (KType, loc) - val k' = foldr (fn (_, k') => (KArrow (k, k'), loc)) k xs + fun doOne ((x, n, xs, xncs), env) = + let + val k = (KType, loc) + val k' = foldr (fn (_, k') => (KArrow (k, k'), loc)) k xs - val env = pushCNamedAs env x n k' NONE - in - foldl (fn ((x', n', to), env) => - let - val t = - case to of - NONE => (CNamed n, loc) - | SOME t => (TFun (t, (CNamed n, loc)), loc) + val env = pushCNamedAs env x n k' NONE + in + foldl (fn ((x', n', to), env) => + let + val t = + case to of + NONE => (CNamed n, loc) + | SOME t => (TFun (t, (CNamed n, loc)), loc) - val k = (KType, loc) - val t = foldr (fn (x, t) => (TCFun (Explicit, x, k, t), loc)) t xs - in - pushENamedAs env x' n' t - end) - env xncs + val k = (KType, loc) + val t = foldr (fn (x, t) => (TCFun (Explicit, x, k, t), loc)) t xs + in + pushENamedAs env x' n' t + end) + env xncs + end + in + foldl doOne env dts end | SgiDatatypeImp (x, n, m1, ms, x', xs, xncs) => let @@ -1288,16 +1293,16 @@ fun projectCon env {sgn, str, field} = SgnConst sgis => (case sgnSeek (fn SgiConAbs (x, _, k) => if x = field then SOME (k, NONE) else NONE | SgiCon (x, _, k, c) => if x = field then SOME (k, SOME c) else NONE - | SgiDatatype (x, _, xs, _) => - if x = field then - let - val k = (KType, #2 sgn) - val k' = foldl (fn (_, k') => (KArrow (k, k'), #2 sgn)) k xs - in - SOME (k', NONE) - end - else - NONE + | SgiDatatype dts => + (case List.find (fn (x, _, xs, _) => x = field) dts of + SOME (_, _, xs, _) => + let + val k = (KType, #2 sgn) + val k' = foldl (fn (_, k') => (KArrow (k, k'), #2 sgn)) k xs + in + SOME (k', NONE) + end + | NONE => NONE) | SgiDatatypeImp (x, _, m1, ms, x', xs, _) => if x = field then let @@ -1325,7 +1330,10 @@ fun projectCon env {sgn, str, field} = fun projectDatatype env {sgn, str, field} = case #1 (hnormSgn env sgn) of SgnConst sgis => - (case sgnSeek (fn SgiDatatype (x, _, xs, xncs) => if x = field then SOME (xs, xncs) else NONE + (case sgnSeek (fn SgiDatatype dts => + (case List.find (fn (x, _, _, _) => x = field) dts of + SOME (_, _, xs, xncs) => SOME (xs, xncs) + | NONE => NONE) | SgiDatatypeImp (x, _, _, _, _, xs, xncs) => if x = field then SOME (xs, xncs) else NONE | _ => NONE) sgis of NONE => NONE @@ -1344,7 +1352,18 @@ fun projectConstructor env {sgn, str, field} = else SOME (U.classifyDatatype xncs, n', xs, to, (CNamed n, #2 str))) xncs in - case sgnSeek (fn SgiDatatype (_, n, xs, xncs) => consider (n, xs, xncs) + case sgnSeek (fn SgiDatatype dts => + let + fun search dts = + case dts of + [] => NONE + | (_, n, xs, xncs) :: dts => + case consider (n, xs, xncs) of + NONE => search dts + | v => v + in + search dts + end | SgiDatatypeImp (_, n, _, _, _, xs, xncs) => consider (n, xs, xncs) | _ => NONE) sgis of NONE => NONE @@ -1382,7 +1401,18 @@ fun projectVal env {sgn, str, field} = NONE) xncs in case sgnSeek (fn SgiVal (x, _, c) => if x = field then SOME c else NONE - | SgiDatatype (_, n, xs, xncs) => seek (n, xs, xncs) + | SgiDatatype dts => + let + fun search dts = + case dts of + [] => NONE + | (_, n, xs, xncs) :: dts => + case seek (n, xs, xncs) of + NONE => search dts + | v => v + in + search dts + end | SgiDatatypeImp (_, n, _, _, _, xs, xncs) => seek (n, xs, xncs) | _ => NONE) sgis of NONE => NONE @@ -1406,7 +1436,8 @@ fun sgnSeekConstraints (str, sgis) = end | SgiConAbs (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) | SgiCon (x, n, _, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) - | SgiDatatype (x, n, _, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) + | SgiDatatype dts => seek (sgis, sgns, strs, + foldl (fn ((x, n, _, _), cons) => IM.insert (cons, n, x)) cons dts, acc) | SgiDatatypeImp (x, n, _, _, _, _, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) | SgiVal _ => seek (sgis, sgns, strs, cons, acc) | SgiSgn (x, n, _) => seek (sgis, IM.insert (sgns, n, x), strs, cons, acc) @@ -1431,29 +1462,34 @@ fun edeclBinds env (d, loc) = fun declBinds env (d, loc) = case d of DCon (x, n, k, c) => pushCNamedAs env x n k (SOME c) - | DDatatype (x, n, xs, xncs) => + | DDatatype dts => let - val k = (KType, loc) - val nxs = length xs - val (tb, kb) = ListUtil.foldli (fn (i, x', (tb, kb)) => - ((CApp (tb, (CRel (nxs - i - 1), loc)), loc), - (KArrow (k, kb), loc))) - ((CNamed n, loc), k) xs - - val env = pushCNamedAs env x n kb NONE - val env = pushDatatype env n xs xncs + fun doOne ((x, n, xs, xncs), env) = + let + val k = (KType, loc) + val nxs = length xs + val (tb, kb) = ListUtil.foldli (fn (i, x', (tb, kb)) => + ((CApp (tb, (CRel (nxs - i - 1), loc)), loc), + (KArrow (k, kb), loc))) + ((CNamed n, loc), k) xs + + val env = pushCNamedAs env x n kb NONE + val env = pushDatatype env n xs xncs + in + foldl (fn ((x', n', to), env) => + let + val t = + case to of + NONE => tb + | SOME t => (TFun (t, tb), loc) + val t = foldr (fn (x, t) => (TCFun (Implicit, x, k, t), loc)) t xs + in + pushENamedAs env x' n' t + end) + env xncs + end in - foldl (fn ((x', n', to), env) => - let - val t = - case to of - NONE => tb - | SOME t => (TFun (t, tb), loc) - val t = foldr (fn (x, t) => (TCFun (Implicit, x, k, t), loc)) t xs - in - pushENamedAs env x' n' t - end) - env xncs + foldl doOne env dts end | DDatatypeImp (x, n, m, ms, x', xs, xncs) => let diff --git a/src/elab_print.sml b/src/elab_print.sml index bbbd9f8d..ab38c2e1 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -486,9 +486,7 @@ fun p_datatype env (x, n, xs, cons) = val env = E.pushCNamedAs env x n k NONE val env = foldl (fn (x, env) => E.pushCRel env x k) env xs in - box [string "datatype", - space, - string x, + box [string x, p_list_sep (box []) (fn x => box [space, string x]) xs, space, string "=", @@ -507,7 +505,7 @@ fun p_named x n = else string x -fun p_sgn_item env (sgi, _) = +fun p_sgn_item env (sgiAll as (sgi, _)) = case sgi of SgiConAbs (x, n, k) => box [string "con", space, @@ -527,7 +525,9 @@ fun p_sgn_item env (sgi, _) = string "=", space, p_con env c] - | SgiDatatype x => p_datatype env x + | SgiDatatype x => box [string "datatype", + space, + p_list_sep (box [space, string "and", space]) (p_datatype (E.sgiBinds env sgiAll)) x] | SgiDatatypeImp (x, _, m1, ms, x', _, _) => let val m1x = #1 (E.lookupStrNamed env m1) @@ -669,7 +669,9 @@ fun p_decl env (dAll as (d, _) : decl) = string "=", space, p_con env c] - | DDatatype x => p_datatype env x + | DDatatype x => box [string "datatype", + space, + p_list_sep (box [space, string "and", space]) (p_datatype (E.declBinds env dAll)) x] | DDatatypeImp (x, _, m1, ms, x', _, _) => let val m1x = #1 (E.lookupStrNamed env m1) diff --git a/src/elab_util.sml b/src/elab_util.sml index 51a203f2..036aa867 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -568,15 +568,17 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = S.map2 (con ctx c, fn c' => (SgiCon (x, n, k', c'), loc))) - | SgiDatatype (x, n, xs, xncs) => - S.map2 (ListUtil.mapfold (fn (x, n, c) => - case c of - NONE => S.return2 (x, n, c) - | SOME c => - S.map2 (con ctx c, - fn c' => (x, n, SOME c'))) xncs, - fn xncs' => - (SgiDatatype (x, n, xs, xncs'), loc)) + | SgiDatatype dts => + S.map2 (ListUtil.mapfold (fn (x, n, xs, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (con ctx c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => (x, n, xs, xncs'))) dts, + fn dts' => + (SgiDatatype dts', loc)) | SgiDatatypeImp (x, n, m1, ms, s, xs, xncs) => S.map2 (ListUtil.mapfold (fn (x, n, c) => case c of @@ -627,8 +629,15 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = bind (ctx, NamedC (x, n, k, NONE)) | SgiCon (x, n, k, c) => bind (ctx, NamedC (x, n, k, SOME c)) - | SgiDatatype (x, n, _, xncs) => - bind (ctx, NamedC (x, n, (KType, loc), NONE)) + | SgiDatatype dts => + foldl (fn ((x, n, ks, _), ctx) => + let + val k' = (KType, loc) + val k = foldl (fn (_, k) => (KArrow (k', k), loc)) + k' ks + in + bind (ctx, NamedC (x, n, k, NONE)) + end) ctx dts | SgiDatatypeImp (x, n, m1, ms, s, _, _) => bind (ctx, NamedC (x, n, (KType, loc), SOME (CModProj (m1, ms, s), loc))) @@ -753,29 +762,34 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f (case #1 d of DCon (x, n, k, c) => bind (ctx, NamedC (x, n, k, SOME c)) - | DDatatype (x, n, xs, xncs) => + | DDatatype dts => let - val ctx = bind (ctx, NamedC (x, n, (KType, loc), NONE)) + fun doOne ((x, n, xs, xncs), ctx) = + let + val ctx = bind (ctx, NamedC (x, n, (KType, loc), NONE)) + in + foldl (fn ((x, _, co), ctx) => + let + val t = + case co of + NONE => CNamed n + | SOME t => TFun (t, (CNamed n, loc)) + + val k = (KType, loc) + val t = (t, loc) + val t = foldr (fn (x, t) => + (TCFun (Explicit, + x, + k, + t), loc)) + t xs + in + bind (ctx, NamedE (x, t)) + end) + ctx xncs + end in - foldl (fn ((x, _, co), ctx) => - let - val t = - case co of - NONE => CNamed n - | SOME t => TFun (t, (CNamed n, loc)) - - val k = (KType, loc) - val t = (t, loc) - val t = foldr (fn (x, t) => - (TCFun (Explicit, - x, - k, - t), loc)) - t xs - in - bind (ctx, NamedE (x, t)) - end) - ctx xncs + foldl doOne ctx dts end | DDatatypeImp (x, n, m, ms, x', _, _) => bind (ctx, NamedC (x, n, (KType, loc), @@ -851,15 +865,18 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f S.map2 (mfc ctx c, fn c' => (DCon (x, n, k', c'), loc))) - | DDatatype (x, n, xs, xncs) => - S.map2 (ListUtil.mapfold (fn (x, n, c) => - case c of - NONE => S.return2 (x, n, c) - | SOME c => - S.map2 (mfc ctx c, - fn c' => (x, n, SOME c'))) xncs, - fn xncs' => - (DDatatype (x, n, xs, xncs'), loc)) + | DDatatype dts => + S.map2 (ListUtil.mapfold (fn (x, n, xs, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (mfc ctx c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => + (x, n, xs, xncs'))) dts, + fn dts' => + (DDatatype dts', loc)) | DDatatypeImp (x, n, m1, ms, s, xs, xncs) => S.map2 (ListUtil.mapfold (fn (x, n, c) => case c of @@ -1059,9 +1076,10 @@ fun maxName ds = foldl (fn (d, count) => Int.max (maxNameDecl d, count)) 0 ds and maxNameDecl (d, _) = case d of DCon (_, n, _, _) => n - | DDatatype (_, n, _, ns) => + | DDatatype dts => + foldl (fn ((_, n, _, ns), max) => foldl (fn ((_, n', _), m) => Int.max (n', m)) - n ns + (Int.max (n, max)) ns) 0 dts | DDatatypeImp (_, n1, n2, _, _, _, ns) => foldl (fn ((_, n', _), m) => Int.max (n', m)) (Int.max (n1, n2)) ns @@ -1101,9 +1119,10 @@ and maxNameSgi (sgi, _) = case sgi of SgiConAbs (_, n, _) => n | SgiCon (_, n, _, _) => n - | SgiDatatype (_, n, _, ns) => - foldl (fn ((_, n', _), m) => Int.max (n', m)) - n ns + | SgiDatatype dts => + foldl (fn ((_, n, _, ns), max) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + (Int.max (n, max)) ns) 0 dts | SgiDatatypeImp (_, n1, n2, _, _, _, ns) => foldl (fn ((_, n', _), m) => Int.max (n', m)) (Int.max (n1, n2)) ns diff --git a/src/elaborate.sml b/src/elaborate.sml index f91f83c7..8b23d91e 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1971,47 +1971,65 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = ([(L'.SgiCon (x, n, k', c'), loc)], (env', denv, gs' @ gs)) end - | L.SgiDatatype (x, xs, xcs) => + | L.SgiDatatype dts => let val k = (L'.KType, loc) - val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs - val (env, n) = E.pushCNamed env x k' NONE - val t = (L'.CNamed n, loc) - val nxs = length xs - 1 - val t = ListUtil.foldli (fn (i, _, t) => (L'.CApp (t, (L'.CRel (nxs - i), loc)), loc)) t xs - - val (env', denv') = foldl (fn (x, (env', denv')) => - (E.pushCRel env' x k, - D.enter denv')) (env, denv) xs - - val (xcs, (used, env, gs)) = - ListUtil.foldlMap - (fn ((x, to), (used, env, gs)) => - let - val (to, t, gs') = case to of - NONE => (NONE, t, gs) - | SOME t' => - let - val (t', tk, gs') = elabCon (env', denv') t' - in - checkKind env' t' tk k; - (SOME t', (L'.TFun (t', t), loc), gs' @ gs) - end - val t = foldl (fn (x, t) => (L'.TCFun (L'.Implicit, x, k, t), loc)) t xs - val (env, n') = E.pushENamed env x t - in - if SS.member (used, x) then - strError env (DuplicateConstructor (x, loc)) - else - (); - ((x, n', to), (SS.add (used, x), env, gs')) - end) - (SS.empty, env, []) xcs - - val env = E.pushDatatype env n xs xcs + val (dts, env) = ListUtil.foldlMap (fn ((x, xs, xcs), env) => + let + val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs + val (env, n) = E.pushCNamed env x k' NONE + in + ((x, n, xs, xcs), env) + end) + env dts + + val (dts, env) = ListUtil.foldlMap + (fn ((x, n, xs, xcs), env) => + let + val t = (L'.CNamed n, loc) + val nxs = length xs - 1 + val t = ListUtil.foldli (fn (i, _, t) => + (L'.CApp (t, (L'.CRel (nxs - i), loc)), loc)) t xs + + val (env', denv') = foldl (fn (x, (env', denv')) => + (E.pushCRel env' x k, + D.enter denv')) (env, denv) xs + + val (xcs, (used, env, gs)) = + ListUtil.foldlMap + (fn ((x, to), (used, env, gs)) => + let + val (to, t, gs') = case to of + NONE => (NONE, t, gs) + | SOME t' => + let + val (t', tk, gs') = + elabCon (env', denv') t' + in + checkKind env' t' tk k; + (SOME t', + (L'.TFun (t', t), loc), + gs' @ gs) + end + val t = foldl (fn (x, t) => (L'.TCFun (L'.Implicit, x, k, t), loc)) + t xs + + val (env, n') = E.pushENamed env x t + in + if SS.member (used, x) then + strError env (DuplicateConstructor (x, loc)) + else + (); + ((x, n', to), (SS.add (used, x), env, gs')) + end) + (SS.empty, env, []) xcs + in + ((x, n, xs, xcs), E.pushDatatype env n xs xcs) + end) + env dts in - ([(L'.SgiDatatype (x, n, xs, xcs), loc)], (env, denv, gs)) + ([(L'.SgiDatatype dts, loc)], (env, denv, gs)) end | L.SgiDatatypeImp (_, [], _) => raise Fail "Empty SgiDatatypeImp" @@ -2199,21 +2217,31 @@ and elabSgn (env, denv) (sgn, loc) = else (); (SS.add (cons, x), vals, sgns, strs)) - | L'.SgiDatatype (x, _, _, xncs) => + | L'.SgiDatatype dts => let - val vals = foldl (fn ((x, _, _), vals) => - (if SS.member (vals, x) then - sgnError env (DuplicateVal (loc, x)) - else - (); - SS.add (vals, x))) - vals xncs + val (cons, vals) = + let + fun doOne ((x, _, _, xncs), (cons, vals)) = + let + val vals = foldl (fn ((x, _, _), vals) => + (if SS.member (vals, x) then + sgnError env (DuplicateVal (loc, x)) + else + (); + SS.add (vals, x))) + vals xncs + in + if SS.member (cons, x) then + sgnError env (DuplicateCon (loc, x)) + else + (); + (SS.add (cons, x), vals) + end + in + foldl doOne (cons, vals) dts + end in - if SS.member (cons, x) then - sgnError env (DuplicateCon (loc, x)) - else - (); - (SS.add (cons, x), vals, sgns, strs) + (cons, vals, sgns, strs) end | L'.SgiDatatypeImp (x, _, _, _, _, _, _) => (if SS.member (cons, x) then @@ -2318,15 +2346,15 @@ and selfify env {str, strs, sgn} = | L'.SgnVar _ => sgn | L'.SgnConst sgis => - (L'.SgnConst (map (fn (L'.SgiConAbs (x, n, k), loc) => - (L'.SgiCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc) - | (L'.SgiDatatype (x, n, xs, xncs), loc) => - (L'.SgiDatatypeImp (x, n, str, strs, x, xs, xncs), loc) + (L'.SgnConst (ListUtil.mapConcat (fn (L'.SgiConAbs (x, n, k), loc) => + [(L'.SgiCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc)] + | (L'.SgiDatatype dts, loc) => + map (fn (x, n, xs, xncs) => (L'.SgiDatatypeImp (x, n, str, strs, x, xs, xncs), loc)) dts | (L'.SgiClassAbs (x, n, k), loc) => - (L'.SgiClass (x, n, k, (L'.CModProj (str, strs, x), loc)), loc) + [(L'.SgiClass (x, n, k, (L'.CModProj (str, strs, x), loc)), loc)] | (L'.SgiStr (x, n, sgn), loc) => - (L'.SgiStr (x, n, selfify env {str = str, strs = strs @ [x], sgn = sgn}), loc) - | x => x) sgis), #2 sgn) + [(L'.SgiStr (x, n, selfify env {str = str, strs = strs @ [x], sgn = sgn}), loc)] + | x => [x]) sgis), #2 sgn) | L'.SgnFun _ => sgn | L'.SgnWhere _ => sgn | L'.SgnProj (m, ms, x) => @@ -2360,46 +2388,47 @@ and dopen env {str, strs, sgn} = in case #1 (hnormSgn env sgn) of L'.SgnConst sgis => - ListUtil.foldlMap (fn ((sgi, loc), env') => - let - val d = - case sgi of - L'.SgiConAbs (x, n, k) => - let - val c = (L'.CModProj (str, strs, x), loc) - in - (L'.DCon (x, n, k, c), loc) - end - | L'.SgiCon (x, n, k, c) => - (L'.DCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc) - | L'.SgiDatatype (x, n, xs, xncs) => - (L'.DDatatypeImp (x, n, str, strs, x, xs, xncs), loc) - | L'.SgiDatatypeImp (x, n, m1, ms, x', xs, xncs) => - (L'.DDatatypeImp (x, n, m1, ms, x', xs, xncs), loc) - | L'.SgiVal (x, n, t) => - (L'.DVal (x, n, t, (L'.EModProj (str, strs, x), loc)), loc) - | L'.SgiStr (x, n, sgn) => - (L'.DStr (x, n, sgn, (L'.StrProj (m, x), loc)), loc) - | L'.SgiSgn (x, n, sgn) => - (L'.DSgn (x, n, (L'.SgnProj (str, strs, x), loc)), loc) - | L'.SgiConstraint (c1, c2) => - (L'.DConstraint (c1, c2), loc) - | L'.SgiClassAbs (x, n, k) => - let - val c = (L'.CModProj (str, strs, x), loc) - in - (L'.DCon (x, n, k, c), loc) - end - | L'.SgiClass (x, n, k, _) => - let - val c = (L'.CModProj (str, strs, x), loc) - in - (L'.DCon (x, n, k, c), loc) - end - in - (d, E.declBinds env' d) - end) - env sgis + ListUtil.foldlMapConcat + (fn ((sgi, loc), env') => + let + val d = + case sgi of + L'.SgiConAbs (x, n, k) => + let + val c = (L'.CModProj (str, strs, x), loc) + in + [(L'.DCon (x, n, k, c), loc)] + end + | L'.SgiCon (x, n, k, c) => + [(L'.DCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc)] + | L'.SgiDatatype dts => + map (fn (x, n, xs, xncs) => (L'.DDatatypeImp (x, n, str, strs, x, xs, xncs), loc)) dts + | L'.SgiDatatypeImp (x, n, m1, ms, x', xs, xncs) => + [(L'.DDatatypeImp (x, n, m1, ms, x', xs, xncs), loc)] + | L'.SgiVal (x, n, t) => + [(L'.DVal (x, n, t, (L'.EModProj (str, strs, x), loc)), loc)] + | L'.SgiStr (x, n, sgn) => + [(L'.DStr (x, n, sgn, (L'.StrProj (m, x), loc)), loc)] + | L'.SgiSgn (x, n, sgn) => + [(L'.DSgn (x, n, (L'.SgnProj (str, strs, x), loc)), loc)] + | L'.SgiConstraint (c1, c2) => + [(L'.DConstraint (c1, c2), loc)] + | L'.SgiClassAbs (x, n, k) => + let + val c = (L'.CModProj (str, strs, x), loc) + in + [(L'.DCon (x, n, k, c), loc)] + end + | L'.SgiClass (x, n, k, _) => + let + val c = (L'.CModProj (str, strs, x), loc) + in + [(L'.DCon (x, n, k, c), loc)] + end + in + (d, foldl (fn (d, env') => E.declBinds env' d) env' d) + end) + env sgis | _ => (strError env (UnOpenable sgn); ([], env)) end @@ -2445,12 +2474,11 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = let (*val () = prefaces "folder" [("sgis1", p_sgn env (L'.SgnConst sgis1, loc2))]*) - fun seek p = + fun seek' f p = let fun seek env ls = case ls of - [] => (sgnError env (UnmatchedSgi sgi2All); - env) + [] => f env | h :: t => case p (env, h) of NONE => @@ -2474,6 +2502,9 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = in seek env sgis1 end + + val seek = seek' (fn env => (sgnError env (UnmatchedSgi sgi2All); + env)) in case sgi of L'.SgiConAbs (x, n2, k2) => @@ -2498,12 +2529,23 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = case sgi1 of L'.SgiConAbs (x', n1, k1) => found (x', n1, k1, NONE) | L'.SgiCon (x', n1, k1, c1) => found (x', n1, k1, SOME c1) - | L'.SgiDatatype (x', n1, xs, _) => + | L'.SgiDatatype dts => let val k = (L'.KType, loc) - val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs + + fun search dts = + case dts of + [] => NONE + | (x', n1, xs, _) :: dts => + let + val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs + in + case found (x', n1, k', NONE) of + NONE => search dts + | x => x + end in - found (x', n1, k', NONE) + search dts end | L'.SgiDatatypeImp (x', n1, m1, ms, s, xs, _) => let @@ -2549,66 +2591,93 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = | _ => NONE end) - | L'.SgiDatatype (x, n2, xs2, xncs2) => - seek (fn (env, sgi1All as (sgi1, _)) => - let - fun found (n1, xs1, xncs1) = - let - fun mismatched ue = - (sgnError env (SgiMismatchedDatatypes (sgi1All, sgi2All, ue)); - SOME env) - - val k = (L'.KType, loc) - val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs1 + | L'.SgiDatatype dts2 => + let + fun found' (sgi1All, (x1, n1, xs1, xncs1), (x2, n2, xs2, xncs2), env) = + if x1 <> x2 then + NONE + else + let + fun mismatched ue = + (sgnError env (SgiMismatchedDatatypes (sgi1All, sgi2All, ue)); + SOME env) - fun good () = - let - val env = E.sgiBinds env sgi1All - val env = if n1 = n2 then - env - else - E.pushCNamedAs env x n2 k' - (SOME (L'.CNamed n1, loc)) - in - SOME env - end + val k = (L'.KType, loc) + val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs1 - val env = E.pushCNamedAs env x n1 k' NONE - val env = if n1 = n2 then - env - else - E.pushCNamedAs env x n2 k' (SOME (L'.CNamed n1, loc)) - val env = foldl (fn (x, env) => E.pushCRel env x k) env xs1 - fun xncBad ((x1, _, t1), (x2, _, t2)) = - String.compare (x1, x2) <> EQUAL - orelse case (t1, t2) of - (NONE, NONE) => false - | (SOME t1, SOME t2) => - (unifyCons env t1 t2; false) - | _ => true - in - (if xs1 <> xs2 - orelse length xncs1 <> length xncs2 - orelse ListPair.exists xncBad (xncs1, xncs2) then - mismatched NONE - else - good ()) - handle CUnify ue => mismatched (SOME ue) - end - in - case sgi1 of - L'.SgiDatatype (x', n1, xs, xncs1) => - if x' = x then - found (n1, xs, xncs1) - else - NONE - | L'.SgiDatatypeImp (x', n1, _, _, _, xs, xncs1) => - if x' = x then - found (n1, xs, xncs1) + fun good () = + let + val env = E.sgiBinds env sgi1All + val env = if n1 = n2 then + env + else + E.pushCNamedAs env x1 n2 k' + (SOME (L'.CNamed n1, loc)) + in + SOME env + end + + val env = E.pushCNamedAs env x1 n1 k' NONE + val env = if n1 = n2 then + env + else + E.pushCNamedAs env x1 n2 k' (SOME (L'.CNamed n1, loc)) + val env = foldl (fn (x, env) => E.pushCRel env x k) env xs1 + fun xncBad ((x1, _, t1), (x2, _, t2)) = + String.compare (x1, x2) <> EQUAL + orelse case (t1, t2) of + (NONE, NONE) => false + | (SOME t1, SOME t2) => + (unifyCons env t1 t2; false) + | _ => true + in + (if xs1 <> xs2 + orelse length xncs1 <> length xncs2 + orelse ListPair.exists xncBad (xncs1, xncs2) then + mismatched NONE else - NONE - | _ => NONE - end) + good ()) + handle CUnify ue => mismatched (SOME ue) + end + in + seek' + (fn _ => + let + fun seekOne (dt2, env) = + seek (fn (env, sgi1All as (sgi1, _)) => + case sgi1 of + L'.SgiDatatypeImp (x', n1, _, _, _, xs, xncs1) => + found' (sgi1All, (x', n1, xs, xncs1), dt2, env) + | _ => NONE) + + fun seekAll (dts, env) = + case dts of + [] => env + | dt :: dts => seekAll (dts, seekOne (dt, env)) + in + seekAll (dts2, env) + end) + (fn (env, sgi1All as (sgi1, _)) => + let + fun found dts1 = + let + fun iter (dts1, dts2, env) = + case (dts1, dts2) of + ([], []) => SOME env + | (dt1 :: dts1, dt2 :: dts2) => + (case found' (sgi1All, dt1, dt2, env) of + NONE => NONE + | SOME env => iter (dts1, dts2, env)) + | _ => NONE + in + iter (dts1, dts2, env) + end + in + case sgi1 of + L'.SgiDatatype dts1 => found dts1 + | _ => NONE + end) + end | L'.SgiDatatypeImp (x, n2, m12, ms2, s2, xs, _) => seek (fn (env, sgi1All as (sgi1, _)) => @@ -3033,58 +3102,63 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = ([(L'.DCon (x, n, k', c'), loc)], (env', denv, enD gs' @ gs)) end - | L.DDatatype (x, xs, xcs) => + | L.DDatatype dts => let - val positive = List.all (fn (_, to) => - case to of - NONE => true - | SOME t => positive x t) xcs - val k = (L'.KType, loc) - val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs - val (env, n) = E.pushCNamed env x k' NONE - val t = (L'.CNamed n, loc) - val nxs = length xs - 1 - val t = ListUtil.foldli (fn (i, _, t) => (L'.CApp (t, (L'.CRel (nxs - i), loc)), loc)) t xs - - val (env', denv') = foldl (fn (x, (env', denv')) => - (E.pushCRel env' x k, - D.enter denv')) (env, denv) xs - - val (xcs, (used, env, gs')) = - ListUtil.foldlMap - (fn ((x, to), (used, env, gs)) => - let - val (to, t, gs') = case to of - NONE => (NONE, t, gs) - | SOME t' => - let - val (t', tk, gs') = elabCon (env', denv') t' - in - checkKind env' t' tk k; - (SOME t', (L'.TFun (t', t), loc), enD gs' @ gs) - end - val t = foldr (fn (x, t) => (L'.TCFun (L'.Implicit, x, k, t), loc)) t xs - val (env, n') = E.pushENamed env x t - in - if SS.member (used, x) then - strError env (DuplicateConstructor (x, loc)) - else - (); - ((x, n', to), (SS.add (used, x), env, gs')) - end) - (SS.empty, env, []) xcs - - val env = E.pushDatatype env n xs xcs - val d' = (L'.DDatatype (x, n, xs, xcs), loc) - in - (*if positive then - () - else - declError env (Nonpositive d');*) + val (dts, env) = ListUtil.foldlMap + (fn ((x, xs, xcs), env) => + let + val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs + val (env, n) = E.pushCNamed env x k' NONE + in + ((x, n, xs, xcs), env) + end) + env dts - ([d'], (env, denv, gs' @ gs)) + val (dts, (env, gs')) = ListUtil.foldlMap + (fn ((x, n, xs, xcs), (env, gs')) => + let + val t = (L'.CNamed n, loc) + val nxs = length xs - 1 + val t = ListUtil.foldli + (fn (i, _, t) => + (L'.CApp (t, (L'.CRel (nxs - i), loc)), loc)) t xs + + val (env', denv') = foldl (fn (x, (env', denv')) => + (E.pushCRel env' x k, + D.enter denv')) (env, denv) xs + + val (xcs, (used, env, gs')) = + ListUtil.foldlMap + (fn ((x, to), (used, env, gs)) => + let + val (to, t, gs') = case to of + NONE => (NONE, t, gs) + | SOME t' => + let + val (t', tk, gs') = elabCon (env', denv') t' + in + checkKind env' t' tk k; + (SOME t', (L'.TFun (t', t), loc), enD gs' @ gs) + end + val t = foldr (fn (x, t) => (L'.TCFun (L'.Implicit, x, k, t), loc)) t xs + + val (env, n') = E.pushENamed env x t + in + if SS.member (used, x) then + strError env (DuplicateConstructor (x, loc)) + else + (); + ((x, n', to), (SS.add (used, x), env, gs')) + end) + (SS.empty, env, gs') xcs + in + ((x, n, xs, xcs), (E.pushDatatype env n xs xcs, gs')) + end) + (env, []) dts + in + ([(L'.DDatatype dts, loc)], (env, denv, gs' @ gs)) end | L.DDatatypeImp (_, [], _) => raise Fail "Empty DDatatypeImp" @@ -3484,24 +3558,31 @@ and elabStr (env, denv) (str, loc) = in ((L'.SgiCon (x, n, k, c), loc) :: sgis, cons, vals, sgns, strs) end - | L'.SgiDatatype (x, n, xs, xncs) => + | L'.SgiDatatype dts => let - val (cons, x) = - if SS.member (cons, x) then - (cons, "?" ^ x) - else - (SS.add (cons, x), x) - - val (xncs, vals) = - ListUtil.foldlMap - (fn ((x, n, t), vals) => - if SS.member (vals, x) then - (("?" ^ x, n, t), vals) + fun doOne ((x, n, xs, xncs), (cons, vals)) = + let + val (cons, x) = + if SS.member (cons, x) then + (cons, "?" ^ x) else - ((x, n, t), SS.add (vals, x))) - vals xncs + (SS.add (cons, x), x) + + val (xncs, vals) = + ListUtil.foldlMap + (fn ((x, n, t), vals) => + if SS.member (vals, x) then + (("?" ^ x, n, t), vals) + else + ((x, n, t), SS.add (vals, x))) + vals xncs + in + ((x, n, xs, xncs), (cons, vals)) + end + + val (dts, (cons, vals)) = ListUtil.foldlMap doOne (cons, vals) dts in - ((L'.SgiDatatype (x, n, xs, xncs), loc) :: sgis, cons, vals, sgns, strs) + ((L'.SgiDatatype dts, loc) :: sgis, cons, vals, sgns, strs) end | L'.SgiDatatypeImp (x, n, m1, ms, x', xs, xncs) => let diff --git a/src/explify.sml b/src/explify.sml index 2e181771..145fccd2 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -137,9 +137,10 @@ fun explifySgi (sgi, loc) = case sgi of L.SgiConAbs (x, n, k) => SOME (L'.SgiConAbs (x, n, explifyKind k), loc) | L.SgiCon (x, n, k, c) => SOME (L'.SgiCon (x, n, explifyKind k, explifyCon c), loc) - | L.SgiDatatype (x, n, xs, xncs) => SOME (L'.SgiDatatype (x, n, xs, + (*| L.SgiDatatype (x, n, xs, xncs) => SOME (L'.SgiDatatype (x, n, xs, map (fn (x, n, co) => - (x, n, Option.map explifyCon co)) xncs), loc) + (x, n, Option.map explifyCon co)) xncs), loc)*) + | L.SgiDatatype _ => raise Fail "Explify SgiDatatype" | L.SgiDatatypeImp (x, n, m1, ms, s, xs, xncs) => SOME (L'.SgiDatatypeImp (x, n, m1, ms, s, xs, map (fn (x, n, co) => (x, n, Option.map explifyCon co)) xncs), loc) @@ -163,9 +164,10 @@ and explifySgn (sgn, loc) = fun explifyDecl (d, loc : EM.span) = case d of L.DCon (x, n, k, c) => SOME (L'.DCon (x, n, explifyKind k, explifyCon c), loc) - | L.DDatatype (x, n, xs, xncs) => SOME (L'.DDatatype (x, n, xs, + (*| L.DDatatype (x, n, xs, xncs) => SOME (L'.DDatatype (x, n, xs, map (fn (x, n, co) => - (x, n, Option.map explifyCon co)) xncs), loc) + (x, n, Option.map explifyCon co)) xncs), loc)*) + | L.DDatatype _ => raise Fail "Explify DDatatype" | L.DDatatypeImp (x, n, m1, ms, s, xs, xncs) => SOME (L'.DDatatypeImp (x, n, m1, ms, s, xs, map (fn (x, n, co) => diff --git a/src/source.sml b/src/source.sml index 9d3eea79..0f62cadd 100644 --- a/src/source.sml +++ b/src/source.sml @@ -85,7 +85,7 @@ datatype inference = datatype sgn_item' = SgiConAbs of string * kind | SgiCon of string * kind option * con - | SgiDatatype of string * string list * (string * con option) list + | SgiDatatype of (string * string list * (string * con option) list) list | SgiDatatypeImp of string * string list * string | SgiVal of string * con | SgiTable of string * con * exp * exp @@ -148,7 +148,7 @@ and edecl = edecl' located datatype decl' = DCon of string * kind option * con - | DDatatype of string * string list * (string * con option) list + | DDatatype of (string * string list * (string * con option) list) list | DDatatypeImp of string * string list * string | DVal of string * con option * exp | DValRec of (string * con option * exp) list diff --git a/src/source_print.sml b/src/source_print.sml index 0f8b093b..b4f9bfd3 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -360,9 +360,7 @@ and p_vali (x, co, e) = fun p_datatype (x, xs, cons) = - box [string "datatype", - space, - string x, + box [string x, p_list_sep (box []) (fn x => box [space, string x]) xs, space, string "=", @@ -399,7 +397,9 @@ fun p_sgn_item (sgi, _) = string "=", space, p_con c] - | SgiDatatype x => p_datatype x + | SgiDatatype x => box [string "datatype", + space, + p_list_sep (box [space, string "and", space]) p_datatype x] | SgiDatatypeImp (x, ms, x') => box [string "datatype", space, @@ -530,7 +530,9 @@ fun p_decl ((d, _) : decl) = string "=", space, p_con c] - | DDatatype x => p_datatype x + | DDatatype x => box [string "datatype", + space, + p_list_sep (box [space, string "and", space]) p_datatype x] | DDatatypeImp (x, ms, x') => box [string "datatype", space, diff --git a/src/urweb.grm b/src/urweb.grm index 4697fef7..bd834b47 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -226,6 +226,8 @@ datatype attr = Class of exp | Normal of con * exp | dargs of string list | barOpt of unit | dcons of (string * con option) list + | dtype of string * string list * (string * con option) list + | dtypes of (string * string list * (string * con option) list) list | dcon of string * con option | pkopt of exp @@ -394,7 +396,7 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let end) | LTYPE SYMBOL EQ cexp ([(DCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp), s (LTYPEleft, cexpright))]) - | DATATYPE SYMBOL dargs EQ barOpt dcons([(DDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright))]) + | DATATYPE dtypes ([(DDatatype dtypes, s (DATATYPEleft, dtypesright))]) | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path (case dargs of [] => [(DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))] @@ -464,6 +466,11 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))]) | STYLE SYMBOL ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))]) +dtype : SYMBOL dargs EQ barOpt dcons (SYMBOL, dargs, dcons) + +dtypes : dtype ([dtype]) + | dtype AND dtypes (dtype :: dtypes) + kopt : (NONE) | DCOLON kind (SOME kind) @@ -652,7 +659,7 @@ sgi : CON SYMBOL DCOLON kind ((SgiConAbs (SYMBOL, kind), s (CONleft, | CON SYMBOL DCOLON kind EQ cexp ((SgiCon (SYMBOL, SOME kind, cexp), s (CONleft, cexpright))) | LTYPE SYMBOL EQ cexp ((SgiCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp), s (LTYPEleft, cexpright))) - | DATATYPE SYMBOL dargs EQ barOpt dcons((SgiDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright))) + | DATATYPE dtypes ((SgiDatatype dtypes, s (DATATYPEleft, dtypesright))) | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path (case dargs of [] => (SgiDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright)) diff --git a/tests/mutual.ur b/tests/mutual.ur new file mode 100644 index 00000000..da8eade4 --- /dev/null +++ b/tests/mutual.ur @@ -0,0 +1,2 @@ +datatype foo = A | B of bar +and bar = C | D of foo diff --git a/tests/mutual.urp b/tests/mutual.urp new file mode 100644 index 00000000..90e2a576 --- /dev/null +++ b/tests/mutual.urp @@ -0,0 +1,3 @@ +debug + +mutual -- cgit v1.2.3 From a735f6ea0ef8ec5895dfe7f895f89ee8c126de14 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 28 May 2009 12:07:05 -0400 Subject: Destructing local let, to the point where demo compiles --- src/elab.sml | 4 ++-- src/elab_env.sml | 20 ++++++++++---------- src/elab_print.sml | 16 ++++++++++++---- src/elab_util.sml | 31 +++++++++++++++++++++++-------- src/elaborate.sml | 18 +++++++----------- src/explify.sml | 7 +++++-- src/source.sml | 2 +- src/source_print.sml | 10 +++++++--- src/termination.sml | 2 +- src/unnest.sml | 21 ++++++++++++++++----- src/urweb.grm | 2 +- 11 files changed, 85 insertions(+), 48 deletions(-) (limited to 'src/elab_env.sml') diff --git a/src/elab.sml b/src/elab.sml index de2db500..76ea6725 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -120,10 +120,10 @@ datatype exp' = | EError | EUnif of exp option ref - | ELet of edecl list * exp + | ELet of edecl list * exp * con and edecl' = - EDVal of string * con * exp + EDVal of pat * con * exp | EDValRec of (string * con * exp) list withtype exp = exp' located diff --git a/src/elab_env.sml b/src/elab_env.sml index 88b2554b..2296d819 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1454,9 +1454,18 @@ fun projectConstraints env {sgn, str} = | SgnError => SOME [] | _ => NONE +fun patBinds env (p, loc) = + case p of + PWild => env + | PVar (x, t) => pushERel env x t + | PPrim _ => env + | PCon (_, _, _, NONE) => env + | PCon (_, _, _, SOME p) => patBinds env p + | PRecord xps => foldl (fn ((_, p, _), env) => patBinds env p) env xps + fun edeclBinds env (d, loc) = case d of - EDVal (x, t, _) => pushERel env x t + EDVal (p, _, _) => patBinds env p | EDValRec vis => foldl (fn ((x, t, _), env) => pushERel env x t) env vis fun declBinds env (d, loc) = @@ -1565,13 +1574,4 @@ fun declBinds env (d, loc) = pushENamedAs env x n t end -fun patBinds env (p, loc) = - case p of - PWild => env - | PVar (x, t) => pushERel env x t - | PPrim _ => env - | PCon (_, _, _, NONE) => env - | PCon (_, _, _, SOME p) => patBinds env p - | PRecord xps => foldl (fn ((_, p, _), env) => patBinds env p) env xps - end diff --git a/src/elab_print.sml b/src/elab_print.sml index ab38c2e1..3e4ea659 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -423,7 +423,7 @@ fun p_exp' par env (e, _) = | EUnif (ref (SOME e)) => p_exp env e | EUnif _ => string "_" - | ELet (ds, e) => + | ELet (ds, e, _) => let val (dsp, env) = ListUtil.foldlMap (fn (d, env) => @@ -456,9 +456,17 @@ and p_exp env = p_exp' false env and p_edecl env (dAll as (d, _)) = case d of - EDVal vi => box [string "val", - space, - p_evali env vi] + EDVal (p, t, e) => box [string "val", + space, + p_pat env p, + space, + string ":", + space, + p_con env t, + space, + string "=", + space, + p_exp env e] | EDValRec vis => let val env = E.edeclBinds env dAll diff --git a/src/elab_util.sml b/src/elab_util.sml index 036aa867..c2101ae3 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -306,6 +306,17 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = end val mfc = Con.mapfoldB {kind = fk, con = fc, bind = bind'} + fun doVars ((p, _), ctx) = + case p of + PWild => ctx + | PVar xt => bind (ctx, RelE xt) + | PPrim _ => ctx + | PCon (_, _, _, NONE) => ctx + | PCon (_, _, _, SOME p) => doVars (p, ctx) + | PRecord xpcs => + foldl (fn ((_, p, _), ctx) => doVars (p, ctx)) + ctx xpcs + fun mfe ctx e acc = S.bindP (mfe' ctx e acc, fe ctx) @@ -425,13 +436,13 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = | EUnif (ref (SOME e)) => mfe ctx e | EUnif _ => S.return2 eAll - | ELet (des, e) => + | ELet (des, e, t) => let val (des, ctx) = foldl (fn (ed, (des, ctx)) => let val ctx' = case #1 ed of - EDVal (x, t, _) => bind (ctx, RelE (x, t)) + EDVal (p, _, _) => doVars (p, ctx) | EDValRec vis => foldl (fn ((x, t, _), ctx) => bind (ctx, RelE (x, t))) ctx vis in @@ -445,9 +456,11 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = in S.bind2 (des, fn des' => - S.map2 (mfe ctx e, + S.bind2 (mfe ctx e, fn e' => - (ELet (des', e'), loc))) + S.map2 (mfc ctx t, + fn t' => + (ELet (des', e', t'), loc)))) end | EKAbs (x, e) => @@ -463,10 +476,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = and mfed ctx (dAll as (d, loc)) = case d of - EDVal vi => - S.map2 (mfvi ctx vi, - fn vi' => - (EDVal vi', loc)) + EDVal (p, t, e) => + S.bind2 (mfc ctx t, + fn t' => + S.map2 (mfe (doVars (p, ctx)) e, + fn e' => + (EDVal (p, t', e'), loc))) | EDValRec vis => let val ctx = foldl (fn ((x, t, _), ctx) => bind (ctx, RelE (x, t))) ctx vis diff --git a/src/elaborate.sml b/src/elaborate.sml index 6f8575db..b4ce1861 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2093,7 +2093,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) = val (eds, (env, gs1)) = ListUtil.foldlMap (elabEdecl denv) (env, []) eds val (e, t, gs2) = elabExp (env, denv) e in - ((L'.ELet (eds, e), loc), t, gs1 @ gs2) + ((L'.ELet (eds, e, t), loc), t, gs1 @ gs2) end in (*prefaces "/elabExp" [("e", SourcePrint.p_exp eAll)];*) @@ -2104,20 +2104,16 @@ and elabEdecl denv (dAll as (d, loc), (env, gs)) = let val r = case d of - L.EDVal (x, co, e) => + L.EDVal (p, e) => let - val (c', _, gs1) = case co of - NONE => (cunif (loc, ktype), ktype, []) - | SOME c => elabCon (env, denv) c + val ((p', pt), (env', _)) = elabPat (p, (env, SS.empty)) + val (e', et, gs1) = elabExp (env, denv) e - val (e', et, gs2) = elabExp (env, denv) e + val () = checkCon env e' et pt - val () = checkCon env e' et c' - - val c' = normClassConstraint env c' - val env' = E.pushERel env x c' + val pt = normClassConstraint env pt in - ((L'.EDVal (x, c', e'), loc), (env', enD gs1 @ gs2 @ gs)) + ((L'.EDVal (p', pt, e'), loc), (env', gs1 @ gs)) end | L.EDValRec vis => let diff --git a/src/explify.sml b/src/explify.sml index d8bd6bff..3ec588fa 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -123,11 +123,14 @@ fun explifyExp (e, loc) = | L.EUnif (ref (SOME e)) => explifyExp e | L.EUnif _ => raise Fail ("explifyExp: Undetermined EUnif at " ^ EM.spanToString loc) - | L.ELet (des, e) => + | L.ELet (des, e, t) => foldr (fn ((de, loc), e) => case de of L.EDValRec _ => raise Fail "explifyExp: Local 'val rec' remains" - | L.EDVal (x, t, e') => (L'.ELet (x, explifyCon t, explifyExp e', e), loc)) + | L.EDVal ((L.PVar (x, _), _), t', e') => (L'.ELet (x, explifyCon t', explifyExp e', e), loc) + | L.EDVal (p, t', e') => (L'.ECase (explifyExp e', + [(explifyPat p, e)], + {disc = explifyCon t', result = explifyCon t}), loc)) (explifyExp e) des | L.EKAbs (x, e) => (L'.EKAbs (x, explifyExp e), loc) diff --git a/src/source.sml b/src/source.sml index bfa270d8..c5950b36 100644 --- a/src/source.sml +++ b/src/source.sml @@ -138,7 +138,7 @@ and exp' = | ELet of edecl list * exp and edecl' = - EDVal of string * con option * exp + EDVal of pat * exp | EDValRec of (string * con option * exp) list withtype sgn_item = sgn_item' located diff --git a/src/source_print.sml b/src/source_print.sml index a16b5bb1..7ec584d7 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -338,9 +338,13 @@ and p_exp e = p_exp' false e and p_edecl (d, _) = case d of - EDVal vi => box [string "val", - space, - p_vali vi] + EDVal (p, e) => box [string "val", + space, + p_pat p, + space, + string "=", + space, + p_exp e] | EDValRec vis => box [string "val", space, string "rec", diff --git a/src/termination.sml b/src/termination.sml index 5dd95f46..f0b21d99 100644 --- a/src/termination.sml +++ b/src/termination.sml @@ -306,7 +306,7 @@ fun declOk' env (d, loc) = | EUnif (ref (SOME e)) => exp parent (penv, calls) e | EUnif (ref NONE) => (Rabble, calls) - | ELet (eds, e) => + | ELet (eds, e, _) => let fun extPenv ((ed, _), penv) = case ed of diff --git a/src/unnest.sml b/src/unnest.sml index 51b66aa4..3dfa741d 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -173,7 +173,7 @@ fun kind (_, k, st) = (k, st) fun exp ((ks, ts), e as old, st : state) = case e of - ELet (eds, e) => + ELet (eds, e, t) => let (*val () = Print.prefaces "Letto" [("e", ElabPrint.p_exp E.empty (old, ErrorMsg.dummySpan))]*) @@ -190,12 +190,23 @@ fun exp ((ks, ts), e as old, st : state) = ListUtil.foldlMapConcat (fn (ed, (ts, maxName, ds, subs, by)) => case #1 ed of - EDVal (x, t, e) => + EDVal (p, t, e) => let val e = doSubst (e, subs, by) + + fun doVars ((p, _), ts) = + case p of + PWild => ts + | PVar xt => xt :: ts + | PPrim _ => ts + | PCon (_, _, _, NONE) => ts + | PCon (_, _, _, SOME p) => doVars (p, ts) + | PRecord xpcs => + foldl (fn ((_, p, _), ts) => doVars (p, ts)) + ts xpcs in - ([(EDVal (x, t, e), #2 ed)], - ((x, t) :: ts, + ([(EDVal (p, t, e), #2 ed)], + (doVars (p, ts), maxName, ds, ((0, (ERel 0, #2 ed)) :: map (fn (n, e) => (n + 1, E.liftExpInExp 0 e)) subs), @@ -341,7 +352,7 @@ fun exp ((ks, ts), e as old, st : state) = (*Print.prefaces "Before" [("e", ElabPrint.p_exp ElabEnv.empty e), ("se", ElabPrint.p_exp ElabEnv.empty (doSubst' (e, subs))), ("e'", ElabPrint.p_exp ElabEnv.empty e')];*) - (ELet (eds, e'), + (ELet (eds, e', t), {maxName = maxName, decls = ds}) (*(ELet (eds, doSubst (liftExpInExp (~(length subs - numRemaining)) (length subs) e) subs),*) diff --git a/src/urweb.grm b/src/urweb.grm index 0d2c1d47..8cdf8063 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -1167,7 +1167,7 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) edecls : ([]) | edecl edecls (edecl :: edecls) -edecl : VAL vali ((EDVal vali, s (VALleft, valiright))) +edecl : VAL pat EQ eexp ((EDVal (pat, eexp), s (VALleft, eexpright))) | VAL REC valis ((EDValRec valis, s (VALleft, valisright))) | FUN valis ((EDValRec valis, s (FUNleft, valisright))) -- cgit v1.2.3 From 4dce690086c8d6132c22d5c47a0561a4b1261293 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 16 Jun 2009 14:38:01 -0400 Subject: Fix a bug in type class enrichment from substructures --- src/elab_env.sml | 16 ++++++++++++---- src/elab_err.sml | 4 ++-- src/elaborate.sml | 1 - src/list_util.sig | 3 +++ src/list_util.sml | 31 +++++++++++++++++++++++++++++++ tests/mproj.ur | 21 +++++++++++++++++++++ tests/mproj.urp | 3 +++ 7 files changed, 72 insertions(+), 7 deletions(-) create mode 100644 tests/mproj.ur create mode 100644 tests/mproj.urp (limited to 'src/elab_env.sml') diff --git a/src/elab_env.sml b/src/elab_env.sml index 2296d819..c7dfc0b1 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1070,6 +1070,9 @@ and hnormSgn env (all as (sgn, loc)) = end | _ => raise Fail "ElabEnv.hnormSgn: Can't reduce 'where' [2]" +fun manifest (m, ms, loc) = + foldl (fn (m, str) => (StrProj (str, m), loc)) (StrVar m, loc) ms + fun enrichClasses env classes (m1, ms) sgn = case #1 (hnormSgn env sgn) of SgnConst sgis => @@ -1089,10 +1092,15 @@ fun enrichClasses env classes (m1, ms) sgn = in case #1 sgi of SgiStr (x, _, sgn) => - (enrichClasses env classes (m1, ms @ [x]) sgn, - newClasses, - sgiSeek (#1 sgi, fmap), - env) + let + val str = manifest (m1, ms, #2 sgi) + val sgn' = sgnSubSgn (str, fmap) sgn + in + (enrichClasses env classes (m1, ms @ [x]) sgn', + newClasses, + sgiSeek (#1 sgi, fmap), + env) + end | SgiSgn (x, n, sgn) => (classes, newClasses, diff --git a/src/elab_err.sml b/src/elab_err.sml index dc34560b..f6fec25b 100644 --- a/src/elab_err.sml +++ b/src/elab_err.sml @@ -218,7 +218,7 @@ fun expError env err = ("Type", p_con env c)]) co) | Unresolvable (loc, c) => (ErrorMsg.errorAt loc "Can't resolve type class instance"; - eprefaces' [("Class constraint", p_con env c)(*, + eprefaces' [("Class constraint", p_con env c), ("Class database", p_list (fn (c, rules) => box [P.p_con env c, PD.string ":", @@ -228,7 +228,7 @@ fun expError env err = PD.string ":", space, P.p_con env c]) rules]) - (E.listClasses env))*)]) + (E.listClasses env))]) | IllegalRec (x, e) => (ErrorMsg.errorAt (#2 e) "Illegal 'val rec' righthand side (must be a function abstraction)"; eprefaces' [("Variable", PD.string x), diff --git a/src/elaborate.sml b/src/elaborate.sml index e78132c4..f0aa8d7a 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -696,7 +696,6 @@ and unifySummaries env (loc, k, s1 : record_summary, s2 : record_summary) = let - val loc = #2 k (*val () = eprefaces "Summaries" [("loc", PD.string (ErrorMsg.spanToString loc)), ("#1", p_summary env s1), ("#2", p_summary env s2)]*) diff --git a/src/list_util.sig b/src/list_util.sig index a89998b2..6e1cd5a5 100644 --- a/src/list_util.sig +++ b/src/list_util.sig @@ -36,6 +36,8 @@ signature LIST_UTIL = sig val foldlMap : ('data1 * 'state -> 'data2 * 'state) -> 'state -> 'data1 list -> 'data2 list * 'state val foldlMapPartial : ('data1 * 'state -> 'data2 option * 'state) -> 'state -> 'data1 list -> 'data2 list * 'state + val foldlMapiPartial : (int * 'data1 * 'state -> 'data2 option * 'state) + -> 'state -> 'data1 list -> 'data2 list * 'state val foldlMapConcat : ('data1 * 'state -> 'data2 list * 'state) -> 'state -> 'data1 list -> 'data2 list * 'state val foldlMapAbort : ('data1 * 'state -> ('data2 * 'state) option) -> 'state -> 'data1 list -> ('data2 list * 'state) option @@ -44,6 +46,7 @@ signature LIST_UTIL = sig val searchi : (int * 'a -> 'b option) -> 'a list -> 'b option val mapi : (int * 'a -> 'b) -> 'a list -> 'b list + val mapiPartial : (int * 'a -> 'b option) -> 'a list -> 'b list val foldli : (int * 'a * 'b -> 'b) -> 'b -> 'a list -> 'b val foldri : (int * 'a * 'b -> 'b) -> 'b -> 'a list -> 'b diff --git a/src/list_util.sml b/src/list_util.sml index 1f6b24ee..03c9549e 100644 --- a/src/list_util.sml +++ b/src/list_util.sml @@ -123,6 +123,24 @@ fun foldlMapPartial f s = fm ([], s) end +fun foldlMapiPartial f s = + let + fun fm (n, ls', s) ls = + case ls of + nil => (rev ls', s) + | h :: t => + let + val (h', s') = f (n, h, s) + val ls' = case h' of + NONE => ls' + | SOME h' => h' :: ls' + in + fm (n + 1, ls', s') t + end + in + fm (0, [], s) + end + fun foldlMapAbort f s = let fun fm (ls', s) ls = @@ -172,6 +190,19 @@ fun mapi f = m 0 [] end +fun mapiPartial f = + let + fun m i acc ls = + case ls of + [] => rev acc + | h :: t => + m (i + 1) (case f (i, h) of + NONE => acc + | SOME v => v :: acc) t + in + m 0 [] + end + fun appi f = let fun m i ls = diff --git a/tests/mproj.ur b/tests/mproj.ur new file mode 100644 index 00000000..8e4317c7 --- /dev/null +++ b/tests/mproj.ur @@ -0,0 +1,21 @@ +structure M : sig + type t + val x : t + + structure S : sig + type u = t + + val eq : eq u + end +end = struct + type t = int + val x = 0 + + structure S = struct + type u = t + + val eq = _ + end +end + +val y = M.x = M.x diff --git a/tests/mproj.urp b/tests/mproj.urp new file mode 100644 index 00000000..d222e3d6 --- /dev/null +++ b/tests/mproj.urp @@ -0,0 +1,3 @@ +debug + +mproj -- cgit v1.2.3 From c79947821b62c16f0a5a21fb5ec935c1dba00aae Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Aug 2009 15:23:04 -0400 Subject: Fix type class resolution infinite loop, discovered while meeting with Ezra --- src/elab_env.sml | 43 ++++++++++++++++++++++++++++++++++++++++++- src/elaborate.sml | 8 ++------ tests/filter.ur | 9 +++++++++ tests/filter.urp | 4 ++++ tests/filter.urs | 1 + 5 files changed, 58 insertions(+), 7 deletions(-) create mode 100644 tests/filter.ur create mode 100644 tests/filter.urp create mode 100644 tests/filter.urs (limited to 'src/elab_env.sml') diff --git a/src/elab_env.sml b/src/elab_env.sml index c7dfc0b1..1bd4e059 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -500,6 +500,47 @@ fun unifyKinds (k1, k2) = | (KFun (_, k1), KFun (_, k2)) => unifyKinds (k1, k2) | _ => raise Unify +fun eqCons (c1, c2) = + case (#1 c1, #1 c2) of + (CUnif (_, _, _, ref (SOME c1)), _) => eqCons (c1, c2) + | (_, CUnif (_, _, _, ref (SOME c2))) => eqCons (c1, c2) + + | (CRel n1, CRel n2) => if n1 = n2 then () else raise Unify + + | (TFun (d1, r1), TFun (d2, r2)) => (eqCons (d1, d2); eqCons (r1, r2)) + | (TCFun (_, _, k1, r1), TCFun (_, _, k2, r2)) => (unifyKinds (k1, k2); eqCons (r1, r2)) + | (TRecord c1, TRecord c2) => eqCons (c1, c2) + | (TDisjoint (a1, b1, c1), TDisjoint (a2, b2, c2)) => + (eqCons (a1, a2); eqCons (b1, b2); eqCons (c1, c2)) + + | (CNamed n1, CNamed n2) => if n1 = n2 then () else raise Unify + | (CModProj (n1, ms1, x1), CModProj (n2, ms2, x2)) => + if n1 = n2 andalso ms1 = ms2 andalso x1 = x2 then () else raise Unify + | (CApp (f1, x1), CApp (f2, x2)) => (eqCons (f1, f2); eqCons (x1, x2)) + | (CAbs (_, k1, b1), CAbs (_, k2, b2)) => (unifyKinds (k1, k2); eqCons (b1, b2)) + + | (CKAbs (_, b1), CKAbs (_, b2)) => eqCons (b1, b2) + | (CKApp (c1, k1), CKApp (c2, k2)) => (eqCons (c1, c2); unifyKinds (k1, k2)) + | (TKFun (_, c1), TKFun (_, c2)) => eqCons (c1, c2) + + | (CName s1, CName s2) => if s1 = s2 then () else raise Unify + + | (CRecord (k1, xcs1), CRecord (k2, xcs2)) => + (unifyKinds (k1, k2); + ListPair.appEq (fn ((x1, c1), (x2, c2)) => (eqCons (x1, x2); eqCons (c1, c2))) (xcs1, xcs2) + handle ListPair.UnequalLengths => raise Unify) + | (CConcat (f1, x1), CConcat (f2, x2)) => (eqCons (f1, f2); eqCons (x1, x2)) + | (CMap (d1, r1), CMap (d2, r2)) => (unifyKinds (d1, d2); unifyKinds (r1, r2)) + + | (CUnit, CUnit) => () + + | (CTuple cs1, CTuple cs2) => (ListPair.appEq (eqCons) (cs1, cs2) + handle ListPair.UnequalLengths => raise Unify) + | (CProj (c1, n1), CProj (c2, n2)) => (eqCons (c1, c2); + if n1 = n2 then () else raise Unify) + + | _ => raise Unify + fun unifyCons rs = let fun unify d (c1, c2) = @@ -524,7 +565,7 @@ fun unifyCons rs = in case !r of NONE => r := SOME c1 - | SOME c2 => unify d (c1, c2) + | SOME c2 => eqCons (c1, c2) end | (TFun (d1, r1), TFun (d2, r2)) => (unify d (d1, d2); unify d (r1, r2)) diff --git a/src/elaborate.sml b/src/elaborate.sml index 6b25cedb..0a15dab1 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -3175,7 +3175,7 @@ and wildifyStr env (str, sgn) = and elabDecl (dAll as (d, loc), (env, denv, gs)) = let - (*val () = preface ("elabDecl", SourcePrint.p_decl (d, loc))*) + (*val () = preface ("elabDecl", SourcePrint.p_decl dAll)*) (*val befor = Time.now ()*) val r = @@ -3410,7 +3410,6 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = L'.StrFun _ => () | _ => strError env (FunctorRebind loc)) | _ => (); - ([(L'.DStr (x, n, sgn', str'), loc)], (env', denv', gs' @ gs)) end @@ -3620,10 +3619,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) in - (*prefaces "elabDecl" [("e", SourcePrint.p_decl dAll), - ("t", PD.string (LargeReal.toString (Time.toReal - (Time.- (Time.now (), befor)))))];*) - + (*prefaces "/elabDecl" [("d", SourcePrint.p_decl dAll)];*) r end diff --git a/tests/filter.ur b/tests/filter.ur new file mode 100644 index 00000000..efd326c3 --- /dev/null +++ b/tests/filter.ur @@ -0,0 +1,9 @@ +fun filter [fs ::: {Type}] [ks] (t : sql_table fs ks) (p : sql_exp [T = fs] [] [] bool) + : sql_query [T = fs] [] = + (SELECT * FROM t WHERE {p}) + +table t : { A : int, B : float } + +fun main () = + queryX (filter t (WHERE t.A > 3)) + (fn r => {[r.T.A]}, {[r.T.B]}) diff --git a/tests/filter.urp b/tests/filter.urp new file mode 100644 index 00000000..102a1871 --- /dev/null +++ b/tests/filter.urp @@ -0,0 +1,4 @@ +debug +database dbname=filter + +filter diff --git a/tests/filter.urs b/tests/filter.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/filter.urs @@ -0,0 +1 @@ +val main : unit -> transaction page -- cgit v1.2.3 From 555989e9f85be264de04cdeb21d982d2eb1b4826 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 5 Dec 2009 14:34:44 -0500 Subject: Recursive hnormSgn for projections of signatures from modules --- src/elab_env.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/elab_env.sml') diff --git a/src/elab_env.sml b/src/elab_env.sml index 1bd4e059..4636fda8 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1088,7 +1088,7 @@ and hnormSgn env (all as (sgn, loc)) = sgn = sgn, field = x} of NONE => raise Fail "ElabEnv.hnormSgn: projectSgn failed" - | SOME sgn => sgn + | SOME sgn => hnormSgn env sgn end | SgnWhere (sgn, x, c) => case #1 (hnormSgn env sgn) of -- cgit v1.2.3 From b225596addee1a3cfd6c3189cff923e7f0e8f7c9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 13 Dec 2009 14:20:41 -0500 Subject: Initializers and setval --- CHANGELOG | 1 + lib/ur/basis.urs | 1 + src/checknest.sml | 4 ++++ src/cjr.sml | 3 +++ src/cjr_env.sml | 1 + src/cjr_print.sml | 23 ++++++++++++++++++++++- src/cjrize.sml | 17 +++++++++++++++++ src/core.sml | 1 + src/core_env.sml | 1 + src/core_print.sml | 3 +++ src/core_util.sml | 8 +++++++- src/corify.sml | 6 +++++- src/elab.sml | 1 + src/elab_env.sml | 1 + src/elab_print.sml | 3 +++ src/elab_util.sml | 8 +++++++- src/elaborate.sml | 10 ++++++++++ src/elisp/urweb-defs.el | 8 +++++--- src/elisp/urweb-mode.el | 4 ++-- src/expl.sml | 1 + src/expl_env.sml | 1 + src/expl_print.sml | 3 +++ src/explify.sml | 1 + src/jscomp.sml | 8 ++++++++ src/mono.sml | 3 +++ src/mono_env.sml | 1 + src/mono_print.sml | 9 +++++++++ src/mono_reduce.sml | 3 +++ src/mono_shake.sml | 42 +++++++++++++++++++++++++++++++----------- src/mono_util.sml | 14 +++++++++++++- src/monoize.sml | 15 +++++++++++++++ src/mysql.sml | 3 +++ src/postgres.sml | 43 +++++++++++++++++++++++++++++++++++++++++++ src/prepare.sml | 14 ++++++++++++++ src/reduce.sml | 9 +++++++++ src/reduce_local.sml | 1 + src/scriptcheck.sml | 1 + src/settings.sig | 1 + src/settings.sml | 4 ++++ src/shake.sml | 7 +++++-- src/source.sml | 1 + src/source_print.sml | 3 +++ src/sqlite.sml | 2 ++ src/unnest.sml | 1 + src/urweb.grm | 3 ++- src/urweb.lex | 1 + tests/init.ur | 6 ++++++ tests/init.urp | 5 +++++ 48 files changed, 286 insertions(+), 24 deletions(-) create mode 100644 tests/init.ur create mode 100644 tests/init.urp (limited to 'src/elab_env.sml') diff --git a/CHANGELOG b/CHANGELOG index 15e92fd5..e1e14aea 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -6,6 +6,7 @@ Next - More syntactic sugar for SQL - Typing of SQL queries no longer exposes which tables were used in joins but had none of their fields projected +- Module-level initializers ======== 20091203 diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index b9d1f55f..f7e098d4 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -523,6 +523,7 @@ val delete : fields ::: {Type} -> uniques ::: {{Unit}} type sql_sequence val nextval : sql_sequence -> transaction int +val setval : sql_sequence -> int -> transaction unit (** XML *) diff --git a/src/checknest.sml b/src/checknest.sml index 49519705..c0f843d6 100644 --- a/src/checknest.sml +++ b/src/checknest.sml @@ -87,6 +87,7 @@ fun expUses globals = SOME {id, ...} => IS.add (s, id) | _ => s end + | ESetval {seq, count} => IS.union (eu seq, eu count) | EUnurlify (e, _) => eu e in @@ -144,6 +145,9 @@ fun annotateExp globals = | ENextval {seq, prepared} => (ENextval {seq = ae seq, prepared = prepared}, loc) + | ESetval {seq, count} => + (ESetval {seq = ae seq, + count = ae count}, loc) | EUnurlify (e, t) => (EUnurlify (ae e, t), loc) in diff --git a/src/cjr.sml b/src/cjr.sml index 2b8ce6fe..9be54670 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -95,6 +95,7 @@ datatype exp' = prepared : {id : int, dml : string} option } | ENextval of { seq : exp, prepared : {id : int, query : string} option } + | ESetval of { seq : exp, count : exp } | EUnurlify of exp * typ withtype exp = exp' located @@ -117,6 +118,8 @@ datatype decl' = | DCookie of string | DStyle of string + | DInitializer of exp + withtype decl = decl' located datatype sidedness = diff --git a/src/cjr_env.sml b/src/cjr_env.sml index 217efb3a..e4d978d5 100644 --- a/src/cjr_env.sml +++ b/src/cjr_env.sml @@ -171,5 +171,6 @@ fun declBinds env (d, loc) = | DJavaScript _ => env | DCookie _ => env | DStyle _ => env + | DInitializer _ => env end diff --git a/src/cjr_print.sml b/src/cjr_print.sml index a1d5ed2c..6a5116ce 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1849,6 +1849,20 @@ fun p_exp' par env (e, loc) = newline, string "})"] + | ESetval {seq, count} => + box [string "({", + newline, + + #setval (Settings.currentDbms ()) {loc = loc, + seqE = p_exp env seq, + count = p_exp env count}, + newline, + newline, + + string "uw_unit_v;", + newline, + string "})"] + | EUnurlify (e, t) => let fun getIt () = @@ -2085,6 +2099,8 @@ fun p_decl env (dAll as (d, _) : decl) = space, string "*/"] + | DInitializer _ => box [] + datatype 'a search = Found of 'a | NotFound @@ -2716,6 +2732,8 @@ fun p_file env (ds, ps) = newline], string "}", newline] + + val initializers = List.mapPartial (fn (DInitializer e, _) => SOME e | _ => NONE) ds in box [string "#include ", newline, @@ -2849,7 +2867,10 @@ fun p_file env (ds, ps) = string "void uw_initializer(uw_context ctx) {", newline, - box [p_enamed env (!initialize), + box [p_list_sep (box []) (fn e => box [p_exp env e, + string ";", + newline]) initializers, + p_enamed env (!initialize), string "(ctx, uw_unit_v);", newline], string "}", diff --git a/src/cjrize.sml b/src/cjrize.sml index 703b9477..3936f6a5 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -468,6 +468,13 @@ fun cifyExp (eAll as (e, loc), sm) = in ((L'.ENextval {seq = e, prepared = NONE}, loc), sm) end + | L.ESetval (e1, e2) => + let + val (e1, sm) = cifyExp (e1, sm) + val (e2, sm) = cifyExp (e2, sm) + in + ((L'.ESetval {seq = e1, count = e2}, loc), sm) + end | L.EUnurlify (e, t) => let @@ -653,6 +660,16 @@ fun cifyDecl ((d, loc), sm) = | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm) | L.DCookie args => (SOME (L'.DCookie args, loc), NONE, sm) | L.DStyle args => (SOME (L'.DStyle args, loc), NONE, sm) + | L.DInitializer e => + (case #1 e of + L.EAbs (_, _, _, e) => + let + val (e, sm) = cifyExp (e, sm) + in + (SOME (L'.DInitializer e, loc), NONE, sm) + end + | _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined"; + (NONE, NONE, sm))) fun cjrize ds = let diff --git a/src/core.sml b/src/core.sml index 6bead3dc..a60bfd3b 100644 --- a/src/core.sml +++ b/src/core.sml @@ -134,6 +134,7 @@ datatype decl' = | DDatabase of string | DCookie of string * int * con * string | DStyle of string * int * string + | DInitializer of exp withtype decl = decl' located diff --git a/src/core_env.sml b/src/core_env.sml index e8cd139f..5e0af98c 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -348,6 +348,7 @@ fun declBinds env (d, loc) = in pushENamed env x n t NONE s end + | DInitializer _ => env fun patBinds env (p, loc) = case p of diff --git a/src/core_print.sml b/src/core_print.sml index 02407f01..7dd43d56 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -611,6 +611,9 @@ fun p_decl env (dAll as (d, _) : decl) = string "as", space, string s] + | DInitializer e => box [string "initializer", + space, + p_exp env e] fun p_file env file = let diff --git a/src/core_util.sml b/src/core_util.sml index cedde841..7ead1157 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -971,6 +971,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = fn c' => (DCookie (x, n, c', s), loc)) | DStyle _ => S.return2 dAll + | DInitializer e => + S.map2 (mfe ctx e, + fn e' => + (DInitializer e', loc)) and mfvi ctx (x, n, t, e, s) = S.bind2 (mfc ctx t, @@ -1125,6 +1129,7 @@ fun mapfoldB (all as {bind, ...}) = in bind (ctx, NamedE (x, n, t, NONE, s)) end + | DInitializer _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -1187,7 +1192,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DView (_, n, _, _, _) => Int.max (n, count) | DDatabase _ => count | DCookie (_, n, _, _) => Int.max (n, count) - | DStyle (_, n, _) => Int.max (n, count)) 0 + | DStyle (_, n, _) => Int.max (n, count) + | DInitializer _ => count) 0 end diff --git a/src/corify.sml b/src/corify.sml index 9bf322f3..cc0500af 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -1064,6 +1064,9 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = ([(L'.DStyle (x, n, s), loc)], st) end + | L.DInitializer e => + ([(L'.DInitializer (corifyExp st e), loc)], st) + and corifyStr mods ((str, _), st) = case str of L.StrConst ds => @@ -1120,7 +1123,8 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DView (_, _, n', _, _) => Int.max (n, n') | L.DDatabase _ => n | L.DCookie (_, _, n', _) => Int.max (n, n') - | L.DStyle (_, _, n') => Int.max (n, n')) + | L.DStyle (_, _, n') => Int.max (n, n') + | L.DInitializer _ => n) 0 ds and maxNameStr (str, _) = diff --git a/src/elab.sml b/src/elab.sml index 76ea6725..1cd7aefa 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -170,6 +170,7 @@ datatype decl' = | DDatabase of string | DCookie of int * string * int * con | DStyle of int * string * int + | DInitializer of exp and str' = StrConst of decl list diff --git a/src/elab_env.sml b/src/elab_env.sml index 4636fda8..763cf801 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1622,5 +1622,6 @@ fun declBinds env (d, loc) = in pushENamedAs env x n t end + | DInitializer _ => env end diff --git a/src/elab_print.sml b/src/elab_print.sml index 3e4ea659..906c836d 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -799,6 +799,9 @@ fun p_decl env (dAll as (d, _) : decl) = | DStyle (_, x, n) => box [string "style", space, p_named x n] + | DInitializer e => box [string "initializer", + space, + p_exp env e] and p_str env (str, _) = case str of diff --git a/src/elab_util.sml b/src/elab_util.sml index e7985026..2a044e71 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -853,7 +853,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "cookie"), loc), c), loc))) | DStyle (tn, x, n) => - bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))), + bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))) + | DInitializer _ => ctx, mfd ctx d)) ctx ds, fn ds' => (StrConst ds', loc)) | StrVar _ => S.return2 strAll @@ -978,6 +979,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f fn c' => (DCookie (tn, x, n, c'), loc)) | DStyle _ => S.return2 dAll + | DInitializer e => + S.map2 (mfe ctx e, + fn e' => + (DInitializer e', loc)) and mfvi ctx (x, n, c, e) = S.bind2 (mfc ctx c, @@ -1120,6 +1125,7 @@ and maxNameDecl (d, _) = | DDatabase _ => 0 | DCookie (n1, _, n2, _) => Int.max (n1, n2) | DStyle (n1, _, n2) => Int.max (n1, n2) + | DInitializer _ => 0 and maxNameStr (str, _) = case str of StrConst ds => maxName ds diff --git a/src/elaborate.sml b/src/elaborate.sml index 71842ec2..327004e2 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2548,6 +2548,7 @@ and sgiOfDecl (d, loc) = | L'.DDatabase _ => [] | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)] + | L'.DInitializer _ => [] and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), @@ -3668,6 +3669,15 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = in ([(L'.DStyle (!basis_r, x, n), loc)], (env, denv, gs)) end + | L.DInitializer e => + let + val (e', t, gs) = elabExp (env, denv) e + val t' = (L'.CApp ((L'.CModProj (!basis_r, [], "transaction"), loc), + (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc)), loc) + in + checkCon env e' t t'; + ([(L'.DInitializer e', loc)], (env, denv, gs)) + end (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) in diff --git a/src/elisp/urweb-defs.el b/src/elisp/urweb-defs.el index e1382692..bb0e257d 100644 --- a/src/elisp/urweb-defs.el +++ b/src/elisp/urweb-defs.el @@ -108,7 +108,7 @@ notion of \"the end of an outline\".") "datatype" "type" "open" "include" urweb-module-head-syms "con" "map" "where" "extern" "constraint" "constraints" - "table" "sequence" "class" "cookie") + "table" "sequence" "class" "cookie" "initializer") "Symbols starting an sexp.") ;; (defconst urweb-not-arg-start-re @@ -134,7 +134,8 @@ notion of \"the end of an outline\".") (,urweb-=-starter-syms nil) (("case" "datatype" "if" "then" "else" "let" "open" "sig" "struct" "type" "val" - "con" "constraint" "table" "sequence" "class" "cookie"))))) + "con" "constraint" "table" "sequence" "class" "cookie" + "initializer"))))) (defconst urweb-starters-indent-after (urweb-syms-re "let" "in" "struct" "sig") @@ -188,7 +189,8 @@ for all symbols and in all lines starting with the given symbol." (append urweb-module-head-syms '("datatype" "fun" "open" "type" "val" "and" - "con" "constraint" "table" "sequence" "class" "cookie")) + "con" "constraint" "table" "sequence" "class" "cookie" + "initializer")) "The starters of new expressions.") (defconst urweb-exptrail-syms diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index 72005af9..ab274f22 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -136,7 +136,7 @@ See doc for the variable `urweb-mode-info'." "datatype" "else" "end" "extern" "fn" "map" "fun" "functor" "if" "include" "of" "open" "let" "in" - "rec" "sequence" "sig" "signature" "cookie" "style" + "rec" "sequence" "sig" "signature" "cookie" "style" "initializer" "struct" "structure" "table" "view" "then" "type" "val" "where" "with" @@ -226,7 +226,7 @@ See doc for the variable `urweb-mode-info'." ("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)" (1 font-lock-keyword-face) (3 (amAttribute font-lock-type-def-face))) - ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]" + ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\|initializer\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]" (1 font-lock-keyword-face) (3 (amAttribute font-lock-variable-name-face))) ("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)" diff --git a/src/expl.sml b/src/expl.sml index 4a9acd8a..eb79e2b0 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -147,6 +147,7 @@ datatype decl' = | DDatabase of string | DCookie of int * string * int * con | DStyle of int * string * int + | DInitializer of exp and str' = StrConst of decl list diff --git a/src/expl_env.sml b/src/expl_env.sml index 836af42c..f16eeb8e 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -343,6 +343,7 @@ fun declBinds env (d, loc) = in pushENamed env x n t end + | DInitializer _ => env fun sgiBinds env (sgi, loc) = case sgi of diff --git a/src/expl_print.sml b/src/expl_print.sml index 0783facc..624afa63 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -713,6 +713,9 @@ fun p_decl env (dAll as (d, _) : decl) = | DStyle (_, x, n) => box [string "style", space, p_named x n] + | DInitializer e => box [string "initializer", + space, + p_exp env e] and p_str env (str, _) = case str of diff --git a/src/explify.sml b/src/explify.sml index 3ec588fa..d66b3530 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -195,6 +195,7 @@ fun explifyDecl (d, loc : EM.span) = | L.DDatabase s => SOME (L'.DDatabase s, loc) | L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc) | L.DStyle (nt, x, n) => SOME (L'.DStyle (nt, x, n), loc) + | L.DInitializer e => SOME (L'.DInitializer (explifyExp e), loc) and explifyStr (str, loc) = case str of diff --git a/src/jscomp.sml b/src/jscomp.sml index 471711d2..ca20e71d 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -868,6 +868,7 @@ fun process file = | EQuery _ => unsupported "Query" | EDml _ => unsupported "DML" | ENextval _ => unsupported "Nextval" + | ESetval _ => unsupported "Nextval" | EUnurlify _ => unsupported "EUnurlify" | EReturnBlob _ => unsupported "EUnurlify" | ERedirect _ => unsupported "ERedirect" @@ -1142,6 +1143,13 @@ fun process file = in ((ENextval e, loc), st) end + | ESetval (e1, e2) => + let + val (e1, st) = exp outer (e1, st) + val (e2, st) = exp outer (e2, st) + in + ((ESetval (e1, e2), loc), st) + end | EUnurlify (e, t) => let diff --git a/src/mono.sml b/src/mono.sml index 92424ee3..1962c6c5 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -106,6 +106,7 @@ datatype exp' = initial : exp } | EDml of exp | ENextval of exp + | ESetval of exp * exp | EUnurlify of exp * typ @@ -138,6 +139,8 @@ datatype decl' = | DCookie of string | DStyle of string + | DInitializer of exp + withtype decl = decl' located type file = decl list diff --git a/src/mono_env.sml b/src/mono_env.sml index 3114176d..6ffab153 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -129,6 +129,7 @@ fun declBinds env (d, loc) = | DJavaScript _ => env | DCookie _ => env | DStyle _ => env + | DInitializer _ => env fun patBinds env (p, loc) = case p of diff --git a/src/mono_print.sml b/src/mono_print.sml index cfaa410b..13c45329 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -320,6 +320,12 @@ fun p_exp' par env (e, _) = | ENextval e => box [string "nextval(", p_exp env e, string ")"] + | ESetval (e1, e2) => box [string "setval(", + p_exp env e1, + string ",", + space, + p_exp env e2, + string ")"] | EUnurlify (e, _) => box [string "unurlify(", p_exp env e, string ")"] @@ -485,6 +491,9 @@ fun p_decl env (dAll as (d, _) : decl) = | DStyle s => box [string "style", space, string s] + | DInitializer e => box [string "initializer", + space, + p_exp env e] fun p_file env file = diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index f29117cf..aa6b7051 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -51,6 +51,7 @@ fun simpleImpure (tsyms, syms) = | EQuery _ => true | EDml _ => true | ENextval _ => true + | ESetval _ => true | EFfiApp (m, x, _) => Settings.isEffectful (m, x) | EServerCall _ => true | ERecv _ => true @@ -75,6 +76,7 @@ fun impure (e, _) = | EQuery _ => true | EDml _ => true | ENextval _ => true + | ESetval _ => true | EUnurlify _ => true | EAbs _ => false @@ -448,6 +450,7 @@ fun reduce file = | EDml e => summarize d e @ [WriteDb] | ENextval e => summarize d e @ [WriteDb] + | ESetval (e1, e2) => summarize d e1 @ summarize d e2 @ [WriteDb] | EUnurlify (e, _) => summarize d e | EJavaScript (_, e) => summarize d e | ESignalReturn e => summarize d e diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 40b83934..fc46cf96 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -43,10 +43,22 @@ type free = { fun shake file = let - val page_es = List.foldl - (fn ((DExport (_, _, n, _, _), _), page_es) => n :: page_es - | ((DDatabase {expunge = n1, initialize = n2, ...}, _), page_es) => n1 :: n2 :: page_es - | (_, page_es) => page_es) [] file + val usedVars = U.Exp.fold {typ = fn (c, st as (cs, es)) => + case c of + TDatatype (n, _) => (IS.add (cs, n), es) + | _ => st, + exp = fn (e, st as (cs, es)) => + case e of + ENamed n => (cs, IS.add (es, n)) + | _ => st} + + val (page_cs, page_es) = + List.foldl + (fn ((DExport (_, _, n, _, _), _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n)) + | ((DDatabase {expunge = n1, initialize = n2, ...}, _), (page_cs, page_es)) => + (page_cs, IS.addList (page_es, [n1, n2])) + | ((DInitializer e, _), st) => usedVars st e + | (_, st) => st) (IS.empty, IS.empty) file val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) => (foldl (fn ((_, n, xncs), cdef) => IM.insert (cdef, n, xncs)) cdef dts, edef) @@ -61,7 +73,8 @@ fun shake file = | ((DDatabase _, _), acc) => acc | ((DJavaScript _, _), acc) => acc | ((DCookie _, _), acc) => acc - | ((DStyle _, _), acc) => acc) + | ((DStyle _, _), acc) => acc + | ((DInitializer _, _), acc) => acc) (IM.empty, IM.empty) file fun typ (c, s) = @@ -104,12 +117,18 @@ fun shake file = and shakeExp s = U.Exp.fold {typ = typ, exp = exp} s - val s = {con = IS.empty, exp = IS.addList (IS.empty, page_es)} + val s = {con = page_cs, exp = page_es} + + val s = IS.foldl (fn (n, s) => + case IM.find (cdef, n) of + NONE => raise Fail "MonoShake: Couldn't find 'datatype'" + | SOME xncs => foldl (fn ((_, _, SOME c), s) => shakeTyp s c + | _ => s) s xncs) s page_cs - val s = foldl (fn (n, s) => - case IM.find (edef, n) of - NONE => raise Fail "Shake: Couldn't find 'val'" - | SOME (t, e) => shakeExp s e) s page_es + val s = IS.foldl (fn (n, s) => + case IM.find (edef, n) of + NONE => raise Fail "MonoShake: Couldn't find 'val'" + | SOME (t, e) => shakeExp s e) s page_es in List.filter (fn (DDatatype dts, _) => List.exists (fn (_, n, _) => IS.member (#con s, n)) dts | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n) @@ -121,7 +140,8 @@ fun shake file = | (DDatabase _, _) => true | (DJavaScript _, _) => true | (DCookie _, _) => true - | (DStyle _, _) => true) file + | (DStyle _, _) => true + | (DInitializer _, _) => true) file end end diff --git a/src/mono_util.sml b/src/mono_util.sml index 91b4412e..184ce168 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -340,6 +340,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (ENextval e', loc)) + | ESetval (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (ESetval (e1', e2'), loc))) | EUnurlify (e, t) => S.bind2 (mfe ctx e, fn e' => @@ -522,6 +528,10 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = | DJavaScript _ => S.return2 dAll | DCookie _ => S.return2 dAll | DStyle _ => S.return2 dAll + | DInitializer e => + S.map2 (mfe ctx e, + fn e' => + (DInitializer e', loc)) and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, @@ -608,6 +618,7 @@ fun mapfoldB (all as {bind, ...}) = | DJavaScript _ => ctx | DCookie _ => ctx | DStyle _ => ctx + | DInitializer _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -660,7 +671,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DDatabase _ => count | DJavaScript _ => count | DCookie _ => count - | DStyle _ => count) 0 + | DStyle _ => count + | DInitializer _ => count) 0 end diff --git a/src/monoize.sml b/src/monoize.sml index b92b9c70..503fd6b3 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2475,6 +2475,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.ENextval e, loc), fm) end + | L.EFfiApp ("Basis", "setval", [e1, e2]) => + let + val (e1, fm) = monoExp (env, st, fm) e1 + val (e2, fm) = monoExp (env, st, fm) e2 + in + ((L'.ESetval (e1, e2), loc), fm) + end | L.EApp ( (L.ECApp ( @@ -3471,6 +3478,14 @@ fun monoDecl (env, fm) (all as (d, loc)) = [(L'.DStyle s, loc), (L'.DVal (x, n, t', e, s), loc)]) end + | L.DInitializer e => + let + val (e, fm) = monoExp (env, St.empty, fm) e + in + SOME (env, + fm, + [(L'.DInitializer e, loc)]) + end end datatype expungable = Client | Channel diff --git a/src/mysql.sml b/src/mysql.sml index 514a9257..40409ff0 100644 --- a/src/mysql.sml +++ b/src/mysql.sml @@ -1503,6 +1503,8 @@ fun nextval {loc, seqE, seqName} = fun nextvalPrepared _ = raise Fail "MySQL.nextvalPrepared called" +fun setval _ = raise Fail "MySQL.setval called" + fun sqlifyString s = "'" ^ String.translate (fn #"'" => "\\'" | #"\\" => "\\\\" | ch => @@ -1529,6 +1531,7 @@ val () = addDbms {name = "mysql", dmlPrepared = dmlPrepared, nextval = nextval, nextvalPrepared = nextvalPrepared, + setval = setval, sqlifyString = sqlifyString, p_cast = p_cast, p_blank = p_blank, diff --git a/src/postgres.sml b/src/postgres.sml index 51e856db..c4bbb067 100644 --- a/src/postgres.sml +++ b/src/postgres.sml @@ -867,6 +867,48 @@ fun nextvalPrepared {loc, id, query} = string (String.toString query), string "\""]}] +fun setvalCommon {loc, query} = + box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating setval result.\");", + newline, + newline, + + string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", + newline, + box [string "PQclear(res);", + newline, + string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": Query failed:\\n%s\\n%s\", ", + query, + string ", PQerrorMessage(conn));", + newline], + string "}", + newline, + newline, + + string "PQclear(res);", + newline] + +fun setval {loc, seqE, count} = + let + val query = box [string "uw_Basis_strcat(ctx, \"SELECT SETVAL('\", uw_Basis_strcat(ctx, ", + seqE, + string ", uw_Basis_strcat(ctx, \"', \", uw_Basis_strcat(ctx, uw_Basis_sqlifyInt(ctx, ", + count, + string "), \")\"))))"] + in + box [string "char *query = ", + query, + string ";", + newline, + string "PGconn *conn = uw_get_db(ctx);", + newline, + string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);", + newline, + newline, + setvalCommon {loc = loc, query = string "query"}] + end + fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'" | #"\\" => "\\\\" | ch => @@ -892,6 +934,7 @@ val () = addDbms {name = "postgres", dmlPrepared = dmlPrepared, nextval = nextval, nextvalPrepared = nextvalPrepared, + setval = setval, sqlifyString = sqlifyString, p_cast = p_cast, p_blank = p_blank, diff --git a/src/prepare.sml b/src/prepare.sml index 58344a1f..7cbd7d76 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -273,6 +273,14 @@ fun prepExp (e as (_, loc), st) = else (e, st) + | ESetval {seq = e1, count = e2} => + let + val (e1, st) = prepExp (e1, st) + val (e2, st) = prepExp (e2, st) + in + ((ESetval {seq = e1, count = e2}, loc), st) + end + | EUnurlify (e, t) => let val (e, st) = prepExp (e, st) @@ -317,6 +325,12 @@ fun prepDecl (d as (_, loc), st) = | DJavaScript _ => (d, st) | DCookie _ => (d, st) | DStyle _ => (d, st) + | DInitializer e => + let + val (e, st) = prepExp (e, st) + in + ((DInitializer e, loc), st) + end fun prepare (ds, ps) = let diff --git a/src/reduce.sml b/src/reduce.sml index 1310c7d0..cedb79fa 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -804,6 +804,15 @@ fun reduce file = | DDatabase _ => (d, st) | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st) | DStyle (s, n, s') => ((DStyle (s, n, s'), loc), st) + | DInitializer e => + let + val e = exp (namedC, namedE) [] e + in + ((DInitializer e, loc), + (polyC, + namedC, + namedE)) + end val (file, _) = ListUtil.foldlMap doDecl (IS.empty, IM.empty, IM.empty) file in diff --git a/src/reduce_local.sml b/src/reduce_local.sml index 4ddddfbf..82490118 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -251,6 +251,7 @@ fun reduce file = | DDatabase _ => d | DCookie _ => d | DStyle _ => d + | DInitializer e => (DInitializer (exp [] e), loc) in map doDecl file end diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml index 6dc11c65..5cd056d5 100644 --- a/src/scriptcheck.sml +++ b/src/scriptcheck.sml @@ -114,6 +114,7 @@ fun classify (ds, ps) = orelse hasClient initial | EDml {dml, ...} => hasClient dml | ENextval {seq, ...} => hasClient seq + | ESetval {seq, count, ...} => hasClient seq orelse hasClient count | EUnurlify (e, _) => hasClient e in hasClient diff --git a/src/settings.sig b/src/settings.sig index 61095ff8..574832a2 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -147,6 +147,7 @@ signature SETTINGS = sig inputs : sql_type list} -> Print.PD.pp_desc, nextval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, seqName : string option} -> Print.PD.pp_desc, nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc, + setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc, sqlifyString : string -> string, p_cast : string * sql_type -> string, p_blank : int * sql_type -> string (* Prepared statement input *), diff --git a/src/settings.sml b/src/settings.sml index f5d5a3ab..a7f2cc9f 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -79,6 +79,7 @@ fun mayClientToServer x = S.member (!clientToServer, x) val effectfulBase = basis ["dml", "nextval", + "setval", "set_cookie", "clear_cookie", "new_client_source", @@ -120,6 +121,7 @@ val serverBase = basis ["requestHeader", "query", "dml", "nextval", + "setval", "channel", "send"] val server = ref serverBase @@ -355,6 +357,7 @@ type dbms = { inputs : sql_type list} -> Print.PD.pp_desc, nextval : {loc : ErrorMsg.span, seqName : string option, seqE : Print.PD.pp_desc} -> Print.PD.pp_desc, nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc, + setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc, sqlifyString : string -> string, p_cast : string * sql_type -> string, p_blank : int * sql_type -> string, @@ -382,6 +385,7 @@ val curDb = ref ({name = "", dmlPrepared = fn _ => Print.box [], nextval = fn _ => Print.box [], nextvalPrepared = fn _ => Print.box [], + setval = fn _ => Print.box [], sqlifyString = fn s => s, p_cast = fn _ => "", p_blank = fn _ => "", diff --git a/src/shake.sml b/src/shake.sml index dde131fc..787500ea 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -79,6 +79,7 @@ fun shake file = in (usedE, usedC) end + | ((DInitializer e, _), st) => usedVars st e | (_, acc) => acc) (IS.empty, IS.empty) file val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef) @@ -104,7 +105,8 @@ fun shake file = | ((DCookie (_, n, c, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DStyle (_, n, _), _), (cdef, edef)) => - (cdef, IM.insert (edef, n, ([], dummyt, dummye)))) + (cdef, IM.insert (edef, n, ([], dummyt, dummye))) + | ((DInitializer _, _), acc) => acc) (IM.empty, IM.empty) file fun kind (_, s) = s @@ -183,7 +185,8 @@ fun shake file = | (DTable _, _) => true | (DDatabase _, _) => true | (DCookie _, _) => true - | (DStyle _, _) => true) file + | (DStyle _, _) => true + | (DInitializer _, _) => true) file end end diff --git a/src/source.sml b/src/source.sml index c5950b36..e52872f0 100644 --- a/src/source.sml +++ b/src/source.sml @@ -167,6 +167,7 @@ datatype decl' = | DDatabase of string | DCookie of string * con | DStyle of string + | DInitializer of exp and str' = StrConst of decl list diff --git a/src/source_print.sml b/src/source_print.sml index 7ec584d7..31fc2500 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -662,6 +662,9 @@ fun p_decl ((d, _) : decl) = | DStyle x => box [string "style", space, string x] + | DInitializer e => box [string "initializer", + space, + p_exp e] and p_str (str, _) = case str of diff --git a/src/sqlite.sml b/src/sqlite.sml index 8a61c25e..440c7c28 100644 --- a/src/sqlite.sml +++ b/src/sqlite.sml @@ -757,6 +757,7 @@ fun nextval {loc, seqE, seqName} = newline] fun nextvalPrepared _ = raise Fail "SQLite.nextvalPrepared called" +fun setval _ = raise Fail "SQLite.setval called" fun sqlifyString s = "'" ^ String.translate (fn #"'" => "''" | ch => @@ -783,6 +784,7 @@ val () = addDbms {name = "sqlite", dmlPrepared = dmlPrepared, nextval = nextval, nextvalPrepared = nextvalPrepared, + setval = setval, sqlifyString = sqlifyString, p_cast = p_cast, p_blank = p_blank, diff --git a/src/unnest.sml b/src/unnest.sml index a4bdb7a9..c4d9a8b5 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -422,6 +422,7 @@ fun unnest file = | DDatabase _ => default () | DCookie _ => default () | DStyle _ => default () + | DInitializer _ => explore () end and doStr (all as (str, loc), st) = diff --git a/src/urweb.grm b/src/urweb.grm index 87a8547d..8780d9f6 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -201,7 +201,7 @@ fun patType loc (p : pat) = | LET | IN | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | SELECT1 | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW - | COOKIE | STYLE + | COOKIE | STYLE | INITIALIZER | CASE | IF | THEN | ELSE | ANDALSO | ORELSE | XML_BEGIN of string | XML_END | XML_BEGIN_END of string @@ -479,6 +479,7 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let end) | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))]) | STYLE SYMBOL ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))]) + | INITIALIZER eexp ([(DInitializer eexp, s (INITIALIZERleft, eexpright))]) dtype : SYMBOL dargs EQ barOpt dcons (SYMBOL, dargs, dcons) diff --git a/src/urweb.lex b/src/urweb.lex index ed6e310b..d04822f7 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -402,6 +402,7 @@ notags = [^<{\n]+; "class" => (Tokens.CLASS (pos yypos, pos yypos + size yytext)); "cookie" => (Tokens.COOKIE (pos yypos, pos yypos + size yytext)); "style" => (Tokens.STYLE (pos yypos, pos yypos + size yytext)); + "initializer" => (Tokens.INITIALIZER (pos yypos, pos yypos + size yytext)); "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext)); "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext)); diff --git a/tests/init.ur b/tests/init.ur new file mode 100644 index 00000000..0a44a9e4 --- /dev/null +++ b/tests/init.ur @@ -0,0 +1,6 @@ +sequence seq +table fred : {A : int, B : int} + +initializer + setval seq 1; + dml (INSERT INTO fred (A, B) VALUES (0, 1)) diff --git a/tests/init.urp b/tests/init.urp new file mode 100644 index 00000000..a2166e44 --- /dev/null +++ b/tests/init.urp @@ -0,0 +1,5 @@ +debug +database dbname=init +sql init.sql + +init -- cgit v1.2.3 From 6179a09d47c5af4db1ac41d00b8cb7ec36741c3e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 15 Dec 2009 10:19:05 -0500 Subject: Convert to task syntax --- CHANGELOG | 2 +- lib/ur/basis.urs | 6 ++++++ src/cjr.sml | 4 +++- src/cjr_env.sml | 2 +- src/cjr_print.sml | 4 ++-- src/cjrize.sml | 10 +++++++--- src/core.sml | 2 +- src/core_env.sml | 2 +- src/core_print.sml | 8 ++++++-- src/core_util.sml | 14 ++++++++------ src/corify.sml | 6 +++--- src/elab.sml | 2 +- src/elab_env.sml | 2 +- src/elab_print.sml | 8 ++++++-- src/elab_util.sml | 14 ++++++++------ src/elaborate.sml | 18 +++++++++++------- src/elisp/urweb-defs.el | 6 +++--- src/elisp/urweb-mode.el | 4 ++-- src/expl.sml | 2 +- src/expl_env.sml | 2 +- src/expl_print.sml | 8 ++++++-- src/explify.sml | 2 +- src/mono.sml | 2 +- src/mono_env.sml | 2 +- src/mono_print.sml | 8 ++++++-- src/mono_shake.sml | 6 +++--- src/mono_util.sml | 14 ++++++++------ src/monoize.sml | 7 ++++--- src/prepare.sml | 4 ++-- src/reduce.sml | 7 ++++--- src/reduce_local.sml | 2 +- src/shake.sml | 6 +++--- src/source.sml | 2 +- src/source_print.sml | 8 ++++++-- src/unnest.sml | 2 +- src/urweb.grm | 4 ++-- src/urweb.lex | 2 +- tests/init.ur | 2 +- 38 files changed, 125 insertions(+), 81 deletions(-) (limited to 'src/elab_env.sml') diff --git a/CHANGELOG b/CHANGELOG index e1e14aea..ec2eda90 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -6,7 +6,7 @@ Next - More syntactic sugar for SQL - Typing of SQL queries no longer exposes which tables were used in joins but had none of their fields projected -- Module-level initializers +- Tasks ======== 20091203 diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index f7e098d4..f550ce67 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -757,3 +757,9 @@ val onDisconnect : transaction unit -> transaction unit val onServerError : (string -> transaction unit) -> transaction unit val show_xml : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> show (xml ctx use bind) + + +(** Tasks *) + +type task_kind +val initialize : task_kind diff --git a/src/cjr.sml b/src/cjr.sml index 9be54670..f5392d49 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -100,6 +100,8 @@ datatype exp' = withtype exp = exp' located +datatype task = Initialize + datatype decl' = DStruct of int * (string * typ) list | DDatatype of (datatype_kind * string * int * (string * int * typ option) list) list @@ -118,7 +120,7 @@ datatype decl' = | DCookie of string | DStyle of string - | DInitializer of exp + | DTask of task * exp withtype decl = decl' located diff --git a/src/cjr_env.sml b/src/cjr_env.sml index e4d978d5..ac83f263 100644 --- a/src/cjr_env.sml +++ b/src/cjr_env.sml @@ -171,6 +171,6 @@ fun declBinds env (d, loc) = | DJavaScript _ => env | DCookie _ => env | DStyle _ => env - | DInitializer _ => env + | DTask _ => env end diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 6a5116ce..2d547519 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2099,7 +2099,7 @@ fun p_decl env (dAll as (d, _) : decl) = space, string "*/"] - | DInitializer _ => box [] + | DTask _ => box [] datatype 'a search = Found of 'a @@ -2733,7 +2733,7 @@ fun p_file env (ds, ps) = string "}", newline] - val initializers = List.mapPartial (fn (DInitializer e, _) => SOME e | _ => NONE) ds + val initializers = List.mapPartial (fn (DTask (Initialize, e), _) => SOME e | _ => NONE) ds in box [string "#include ", newline, diff --git a/src/cjrize.sml b/src/cjrize.sml index 3936f6a5..0136bdf6 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -660,13 +660,17 @@ fun cifyDecl ((d, loc), sm) = | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm) | L.DCookie args => (SOME (L'.DCookie args, loc), NONE, sm) | L.DStyle args => (SOME (L'.DStyle args, loc), NONE, sm) - | L.DInitializer e => - (case #1 e of + | L.DTask (e1, e2) => + (case #1 e2 of L.EAbs (_, _, _, e) => let + val tk = case #1 e1 of + L.EFfi ("Basis", "initialize") => L'.Initialize + | _ => (ErrorMsg.errorAt loc "Task kind not fully determined"; + L'.Initialize) val (e, sm) = cifyExp (e, sm) in - (SOME (L'.DInitializer e, loc), NONE, sm) + (SOME (L'.DTask (tk, e), loc), NONE, sm) end | _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined"; (NONE, NONE, sm))) diff --git a/src/core.sml b/src/core.sml index a60bfd3b..78a1eded 100644 --- a/src/core.sml +++ b/src/core.sml @@ -134,7 +134,7 @@ datatype decl' = | DDatabase of string | DCookie of string * int * con * string | DStyle of string * int * string - | DInitializer of exp + | DTask of exp * exp withtype decl = decl' located diff --git a/src/core_env.sml b/src/core_env.sml index 5e0af98c..4c50bdd7 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -348,7 +348,7 @@ fun declBinds env (d, loc) = in pushENamed env x n t NONE s end - | DInitializer _ => env + | DTask _ => env fun patBinds env (p, loc) = case p of diff --git a/src/core_print.sml b/src/core_print.sml index 7dd43d56..c1f93587 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -611,9 +611,13 @@ fun p_decl env (dAll as (d, _) : decl) = string "as", space, string s] - | DInitializer e => box [string "initializer", + | DTask (e1, e2) => box [string "task", space, - p_exp env e] + p_exp env e1, + space, + string "=", + space, + p_exp env e2] fun p_file env file = let diff --git a/src/core_util.sml b/src/core_util.sml index 7ead1157..599e1abc 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -971,10 +971,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = fn c' => (DCookie (x, n, c', s), loc)) | DStyle _ => S.return2 dAll - | DInitializer e => - S.map2 (mfe ctx e, - fn e' => - (DInitializer e', loc)) + | DTask (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (DTask (e1', e2'), loc))) and mfvi ctx (x, n, t, e, s) = S.bind2 (mfc ctx t, @@ -1129,7 +1131,7 @@ fun mapfoldB (all as {bind, ...}) = in bind (ctx, NamedE (x, n, t, NONE, s)) end - | DInitializer _ => ctx + | DTask _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -1193,7 +1195,7 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DDatabase _ => count | DCookie (_, n, _, _) => Int.max (n, count) | DStyle (_, n, _) => Int.max (n, count) - | DInitializer _ => count) 0 + | DTask _ => count) 0 end diff --git a/src/corify.sml b/src/corify.sml index cc0500af..9259b4f2 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -1064,8 +1064,8 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = ([(L'.DStyle (x, n, s), loc)], st) end - | L.DInitializer e => - ([(L'.DInitializer (corifyExp st e), loc)], st) + | L.DTask (e1, e2) => + ([(L'.DTask (corifyExp st e1, corifyExp st e2), loc)], st) and corifyStr mods ((str, _), st) = case str of @@ -1124,7 +1124,7 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DDatabase _ => n | L.DCookie (_, _, n', _) => Int.max (n, n') | L.DStyle (_, _, n') => Int.max (n, n') - | L.DInitializer _ => n) + | L.DTask _ => n) 0 ds and maxNameStr (str, _) = diff --git a/src/elab.sml b/src/elab.sml index 1cd7aefa..a0f9a4e8 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -170,7 +170,7 @@ datatype decl' = | DDatabase of string | DCookie of int * string * int * con | DStyle of int * string * int - | DInitializer of exp + | DTask of exp * exp and str' = StrConst of decl list diff --git a/src/elab_env.sml b/src/elab_env.sml index 763cf801..5092c6fb 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1622,6 +1622,6 @@ fun declBinds env (d, loc) = in pushENamedAs env x n t end - | DInitializer _ => env + | DTask _ => env end diff --git a/src/elab_print.sml b/src/elab_print.sml index 906c836d..62b5262f 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -799,9 +799,13 @@ fun p_decl env (dAll as (d, _) : decl) = | DStyle (_, x, n) => box [string "style", space, p_named x n] - | DInitializer e => box [string "initializer", + | DTask (e1, e2) => box [string "task", space, - p_exp env e] + p_exp env e1, + space, + string "=", + space, + p_exp env e2] and p_str env (str, _) = case str of diff --git a/src/elab_util.sml b/src/elab_util.sml index 2a044e71..d0e140c5 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -854,7 +854,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f c), loc))) | DStyle (tn, x, n) => bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))) - | DInitializer _ => ctx, + | DTask _ => ctx, mfd ctx d)) ctx ds, fn ds' => (StrConst ds', loc)) | StrVar _ => S.return2 strAll @@ -979,10 +979,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f fn c' => (DCookie (tn, x, n, c'), loc)) | DStyle _ => S.return2 dAll - | DInitializer e => - S.map2 (mfe ctx e, - fn e' => - (DInitializer e', loc)) + | DTask (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (DTask (e1', e2'), loc))) and mfvi ctx (x, n, c, e) = S.bind2 (mfc ctx c, @@ -1125,7 +1127,7 @@ and maxNameDecl (d, _) = | DDatabase _ => 0 | DCookie (n1, _, n2, _) => Int.max (n1, n2) | DStyle (n1, _, n2) => Int.max (n1, n2) - | DInitializer _ => 0 + | DTask _ => 0 and maxNameStr (str, _) = case str of StrConst ds => maxName ds diff --git a/src/elaborate.sml b/src/elaborate.sml index d1b9648a..2a237c50 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2548,7 +2548,7 @@ and sgiOfDecl (d, loc) = | L'.DDatabase _ => [] | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)] - | L'.DInitializer _ => [] + | L'.DTask _ => [] and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), @@ -3669,14 +3669,18 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = in ([(L'.DStyle (!basis_r, x, n), loc)], (env, denv, gs)) end - | L.DInitializer e => + | L.DTask (e1, e2) => let - val (e', t, gs') = elabExp (env, denv) e - val t' = (L'.CApp ((L'.CModProj (!basis_r, [], "transaction"), loc), - (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc)), loc) + val (e1', t1, gs1) = elabExp (env, denv) e1 + val (e2', t2, gs2) = elabExp (env, denv) e2 + + val t1' = (L'.CModProj (!basis_r, [], "task_kind"), loc) + val t2' = (L'.CApp ((L'.CModProj (!basis_r, [], "transaction"), loc), + (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc)), loc) in - checkCon env e' t t'; - ([(L'.DInitializer e', loc)], (env, denv, gs' @ gs)) + checkCon env e1' t1 t1'; + checkCon env e2' t2 t2'; + ([(L'.DTask (e1', e2'), loc)], (env, denv, gs2 @ gs1 @ gs)) end (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) diff --git a/src/elisp/urweb-defs.el b/src/elisp/urweb-defs.el index bb0e257d..c697a274 100644 --- a/src/elisp/urweb-defs.el +++ b/src/elisp/urweb-defs.el @@ -108,7 +108,7 @@ notion of \"the end of an outline\".") "datatype" "type" "open" "include" urweb-module-head-syms "con" "map" "where" "extern" "constraint" "constraints" - "table" "sequence" "class" "cookie" "initializer") + "table" "sequence" "class" "cookie" "task") "Symbols starting an sexp.") ;; (defconst urweb-not-arg-start-re @@ -135,7 +135,7 @@ notion of \"the end of an outline\".") (("case" "datatype" "if" "then" "else" "let" "open" "sig" "struct" "type" "val" "con" "constraint" "table" "sequence" "class" "cookie" - "initializer"))))) + "task"))))) (defconst urweb-starters-indent-after (urweb-syms-re "let" "in" "struct" "sig") @@ -190,7 +190,7 @@ for all symbols and in all lines starting with the given symbol." '("datatype" "fun" "open" "type" "val" "and" "con" "constraint" "table" "sequence" "class" "cookie" - "initializer")) + "task")) "The starters of new expressions.") (defconst urweb-exptrail-syms diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index ab274f22..107ea3bc 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -136,7 +136,7 @@ See doc for the variable `urweb-mode-info'." "datatype" "else" "end" "extern" "fn" "map" "fun" "functor" "if" "include" "of" "open" "let" "in" - "rec" "sequence" "sig" "signature" "cookie" "style" "initializer" + "rec" "sequence" "sig" "signature" "cookie" "style" "task" "struct" "structure" "table" "view" "then" "type" "val" "where" "with" @@ -226,7 +226,7 @@ See doc for the variable `urweb-mode-info'." ("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)" (1 font-lock-keyword-face) (3 (amAttribute font-lock-type-def-face))) - ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\|initializer\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]" + ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\|task\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]" (1 font-lock-keyword-face) (3 (amAttribute font-lock-variable-name-face))) ("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)" diff --git a/src/expl.sml b/src/expl.sml index eb79e2b0..17797626 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -147,7 +147,7 @@ datatype decl' = | DDatabase of string | DCookie of int * string * int * con | DStyle of int * string * int - | DInitializer of exp + | DTask of exp * exp and str' = StrConst of decl list diff --git a/src/expl_env.sml b/src/expl_env.sml index f16eeb8e..0bf7323f 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -343,7 +343,7 @@ fun declBinds env (d, loc) = in pushENamed env x n t end - | DInitializer _ => env + | DTask _ => env fun sgiBinds env (sgi, loc) = case sgi of diff --git a/src/expl_print.sml b/src/expl_print.sml index 624afa63..5284eecb 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -713,9 +713,13 @@ fun p_decl env (dAll as (d, _) : decl) = | DStyle (_, x, n) => box [string "style", space, p_named x n] - | DInitializer e => box [string "initializer", + | DTask (e1, e2) => box [string "task", space, - p_exp env e] + p_exp env e1, + space, + string "=", + space, + p_exp env e2] and p_str env (str, _) = case str of diff --git a/src/explify.sml b/src/explify.sml index d66b3530..aff91a34 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -195,7 +195,7 @@ fun explifyDecl (d, loc : EM.span) = | L.DDatabase s => SOME (L'.DDatabase s, loc) | L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc) | L.DStyle (nt, x, n) => SOME (L'.DStyle (nt, x, n), loc) - | L.DInitializer e => SOME (L'.DInitializer (explifyExp e), loc) + | L.DTask (e1, e2) => SOME (L'.DTask (explifyExp e1, explifyExp e2), loc) and explifyStr (str, loc) = case str of diff --git a/src/mono.sml b/src/mono.sml index 1962c6c5..e5e68bfa 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -139,7 +139,7 @@ datatype decl' = | DCookie of string | DStyle of string - | DInitializer of exp + | DTask of exp * exp withtype decl = decl' located diff --git a/src/mono_env.sml b/src/mono_env.sml index 6ffab153..c2e6cf02 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -129,7 +129,7 @@ fun declBinds env (d, loc) = | DJavaScript _ => env | DCookie _ => env | DStyle _ => env - | DInitializer _ => env + | DTask _ => env fun patBinds env (p, loc) = case p of diff --git a/src/mono_print.sml b/src/mono_print.sml index 13c45329..da34c220 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -491,9 +491,13 @@ fun p_decl env (dAll as (d, _) : decl) = | DStyle s => box [string "style", space, string s] - | DInitializer e => box [string "initializer", + | DTask (e1, e2) => box [string "task", space, - p_exp env e] + p_exp env e1, + space, + string "=", + space, + p_exp env e2] fun p_file env file = diff --git a/src/mono_shake.sml b/src/mono_shake.sml index fc46cf96..048cc190 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -57,7 +57,7 @@ fun shake file = (fn ((DExport (_, _, n, _, _), _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n)) | ((DDatabase {expunge = n1, initialize = n2, ...}, _), (page_cs, page_es)) => (page_cs, IS.addList (page_es, [n1, n2])) - | ((DInitializer e, _), st) => usedVars st e + | ((DTask (e1, e2), _), st) => usedVars (usedVars st e2) e1 | (_, st) => st) (IS.empty, IS.empty) file val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) => @@ -74,7 +74,7 @@ fun shake file = | ((DJavaScript _, _), acc) => acc | ((DCookie _, _), acc) => acc | ((DStyle _, _), acc) => acc - | ((DInitializer _, _), acc) => acc) + | ((DTask _, _), acc) => acc) (IM.empty, IM.empty) file fun typ (c, s) = @@ -141,7 +141,7 @@ fun shake file = | (DJavaScript _, _) => true | (DCookie _, _) => true | (DStyle _, _) => true - | (DInitializer _, _) => true) file + | (DTask _, _) => true) file end end diff --git a/src/mono_util.sml b/src/mono_util.sml index 184ce168..894e35d0 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -528,10 +528,12 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = | DJavaScript _ => S.return2 dAll | DCookie _ => S.return2 dAll | DStyle _ => S.return2 dAll - | DInitializer e => - S.map2 (mfe ctx e, - fn e' => - (DInitializer e', loc)) + | DTask (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (DTask (e1', e2'), loc))) and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, @@ -618,7 +620,7 @@ fun mapfoldB (all as {bind, ...}) = | DJavaScript _ => ctx | DCookie _ => ctx | DStyle _ => ctx - | DInitializer _ => ctx + | DTask _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -672,7 +674,7 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DJavaScript _ => count | DCookie _ => count | DStyle _ => count - | DInitializer _ => count) 0 + | DTask _ => count) 0 end diff --git a/src/monoize.sml b/src/monoize.sml index 503fd6b3..f6a56c33 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3478,13 +3478,14 @@ fun monoDecl (env, fm) (all as (d, loc)) = [(L'.DStyle s, loc), (L'.DVal (x, n, t', e, s), loc)]) end - | L.DInitializer e => + | L.DTask (e1, e2) => let - val (e, fm) = monoExp (env, St.empty, fm) e + val (e1, fm) = monoExp (env, St.empty, fm) e1 + val (e2, fm) = monoExp (env, St.empty, fm) e2 in SOME (env, fm, - [(L'.DInitializer e, loc)]) + [(L'.DTask (e1, e2), loc)]) end end diff --git a/src/prepare.sml b/src/prepare.sml index 7cbd7d76..2d144c67 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -325,11 +325,11 @@ fun prepDecl (d as (_, loc), st) = | DJavaScript _ => (d, st) | DCookie _ => (d, st) | DStyle _ => (d, st) - | DInitializer e => + | DTask (tk, e) => let val (e, st) = prepExp (e, st) in - ((DInitializer e, loc), st) + ((DTask (tk, e), loc), st) end fun prepare (ds, ps) = diff --git a/src/reduce.sml b/src/reduce.sml index cedb79fa..95b26da8 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -804,11 +804,12 @@ fun reduce file = | DDatabase _ => (d, st) | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st) | DStyle (s, n, s') => ((DStyle (s, n, s'), loc), st) - | DInitializer e => + | DTask (e1, e2) => let - val e = exp (namedC, namedE) [] e + val e1 = exp (namedC, namedE) [] e1 + val e2 = exp (namedC, namedE) [] e2 in - ((DInitializer e, loc), + ((DTask (e1, e2), loc), (polyC, namedC, namedE)) diff --git a/src/reduce_local.sml b/src/reduce_local.sml index 82490118..b040a1ec 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -251,7 +251,7 @@ fun reduce file = | DDatabase _ => d | DCookie _ => d | DStyle _ => d - | DInitializer e => (DInitializer (exp [] e), loc) + | DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc) in map doDecl file end diff --git a/src/shake.sml b/src/shake.sml index 787500ea..d1810bea 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -79,7 +79,7 @@ fun shake file = in (usedE, usedC) end - | ((DInitializer e, _), st) => usedVars st e + | ((DTask (e1, e2), _), st) => usedVars (usedVars st e1) e2 | (_, acc) => acc) (IS.empty, IS.empty) file val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef) @@ -106,7 +106,7 @@ fun shake file = (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DStyle (_, n, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], dummyt, dummye))) - | ((DInitializer _, _), acc) => acc) + | ((DTask _, _), acc) => acc) (IM.empty, IM.empty) file fun kind (_, s) = s @@ -186,7 +186,7 @@ fun shake file = | (DDatabase _, _) => true | (DCookie _, _) => true | (DStyle _, _) => true - | (DInitializer _, _) => true) file + | (DTask _, _) => true) file end end diff --git a/src/source.sml b/src/source.sml index e52872f0..dc867026 100644 --- a/src/source.sml +++ b/src/source.sml @@ -167,7 +167,7 @@ datatype decl' = | DDatabase of string | DCookie of string * con | DStyle of string - | DInitializer of exp + | DTask of exp * exp and str' = StrConst of decl list diff --git a/src/source_print.sml b/src/source_print.sml index 31fc2500..e3b4fe94 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -662,9 +662,13 @@ fun p_decl ((d, _) : decl) = | DStyle x => box [string "style", space, string x] - | DInitializer e => box [string "initializer", + | DTask (e1, e2) => box [string "task", space, - p_exp e] + p_exp e1, + space, + string "=", + space, + p_exp e2] and p_str (str, _) = case str of diff --git a/src/unnest.sml b/src/unnest.sml index c4d9a8b5..e030bbc6 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -422,7 +422,7 @@ fun unnest file = | DDatabase _ => default () | DCookie _ => default () | DStyle _ => default () - | DInitializer _ => explore () + | DTask _ => explore () end and doStr (all as (str, loc), st) = diff --git a/src/urweb.grm b/src/urweb.grm index 8780d9f6..afe7be07 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -201,7 +201,7 @@ fun patType loc (p : pat) = | LET | IN | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | SELECT1 | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW - | COOKIE | STYLE | INITIALIZER + | COOKIE | STYLE | TASK | CASE | IF | THEN | ELSE | ANDALSO | ORELSE | XML_BEGIN of string | XML_END | XML_BEGIN_END of string @@ -479,7 +479,7 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let end) | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))]) | STYLE SYMBOL ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))]) - | INITIALIZER eexp ([(DInitializer eexp, s (INITIALIZERleft, eexpright))]) + | TASK eapps EQ eexp ([(DTask (eapps, eexp), s (TASKleft, eexpright))]) dtype : SYMBOL dargs EQ barOpt dcons (SYMBOL, dargs, dcons) diff --git a/src/urweb.lex b/src/urweb.lex index d04822f7..5fb767b1 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -402,7 +402,7 @@ notags = [^<{\n]+; "class" => (Tokens.CLASS (pos yypos, pos yypos + size yytext)); "cookie" => (Tokens.COOKIE (pos yypos, pos yypos + size yytext)); "style" => (Tokens.STYLE (pos yypos, pos yypos + size yytext)); - "initializer" => (Tokens.INITIALIZER (pos yypos, pos yypos + size yytext)); + "task" => (Tokens.TASK (pos yypos, pos yypos + size yytext)); "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext)); "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext)); diff --git a/tests/init.ur b/tests/init.ur index 0a44a9e4..aafbb55f 100644 --- a/tests/init.ur +++ b/tests/init.ur @@ -1,6 +1,6 @@ sequence seq table fred : {A : int, B : int} -initializer +task initialize = setval seq 1; dml (INSERT INTO fred (A, B) VALUES (0, 1)) -- cgit v1.2.3 From 6a326e3bb3eb16e04f3cca082f0dd67278e85785 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 4 Apr 2010 12:29:34 -0400 Subject: Pushing policies through --- lib/ur/basis.urs | 9 +++++++++ src/cjrize.sml | 1 + src/core.sml | 1 + src/core_env.sml | 1 + src/core_print.sml | 3 +++ src/core_util.sml | 8 +++++++- src/corify.sml | 6 +++++- src/css.sml | 1 + src/elab.sml | 1 + src/elab_env.sml | 1 + src/elab_print.sml | 3 +++ src/elab_util.sml | 8 +++++++- src/elaborate.sml | 10 ++++++++++ src/elisp/urweb-defs.el | 6 +++--- src/elisp/urweb-mode.el | 4 ++-- src/expl.sml | 1 + src/expl_env.sml | 1 + src/expl_print.sml | 3 +++ src/explify.sml | 1 + src/mono.sml | 6 +++++- src/mono_env.sml | 1 + src/mono_print.sml | 9 +++++++++ src/mono_shake.sml | 13 +++++++++++-- src/mono_util.sml | 14 +++++++++++++- src/monoize.sml | 14 ++++++++++++++ src/reduce.sml | 9 +++++++++ src/reduce_local.sml | 1 + src/shake.sml | 11 +++++++++-- src/source.sml | 1 + src/source_print.sml | 3 +++ src/unnest.sml | 1 + src/urweb.grm | 3 ++- src/urweb.lex | 1 + tests/policy.ur | 3 +++ tests/policy.urp | 1 + 35 files changed, 145 insertions(+), 15 deletions(-) create mode 100644 tests/policy.ur create mode 100644 tests/policy.urp (limited to 'src/elab_env.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 8388e107..aad04b5f 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -795,4 +795,13 @@ type task_kind val initialize : task_kind +(** Information flow security *) + +type sql_policy + +val query_policy : tables ::: {{Type}} -> exps ::: {Type} + -> [tables ~ exps] => sql_query [] tables exps + -> sql_policy + + val debug : string -> transaction unit diff --git a/src/cjrize.sml b/src/cjrize.sml index 6e41a69b..b98b3c25 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -674,6 +674,7 @@ fun cifyDecl ((d, loc), sm) = end | _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined"; (NONE, NONE, sm))) + | L.DPolicy _ => (NONE, NONE, sm) fun cjrize ds = let diff --git a/src/core.sml b/src/core.sml index 90005f16..e5358f48 100644 --- a/src/core.sml +++ b/src/core.sml @@ -135,6 +135,7 @@ datatype decl' = | DCookie of string * int * con * string | DStyle of string * int * string | DTask of exp * exp + | DPolicy of exp withtype decl = decl' located diff --git a/src/core_env.sml b/src/core_env.sml index 9001e29c..478ef495 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -349,6 +349,7 @@ fun declBinds env (d, loc) = pushENamed env x n t NONE s end | DTask _ => env + | DPolicy _ => env fun patBinds env (p, loc) = case p of diff --git a/src/core_print.sml b/src/core_print.sml index d6be76a3..fd0556e6 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -618,6 +618,9 @@ fun p_decl env (dAll as (d, _) : decl) = string "=", space, p_exp env e2] + | DPolicy e1 => box [string "policy", + space, + p_exp env e1] fun p_file env file = let diff --git a/src/core_util.sml b/src/core_util.sml index 247dd32e..eedcd2bb 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -992,6 +992,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = S.map2 (mfe ctx e2, fn e2' => (DTask (e1', e2'), loc))) + | DPolicy e => + S.map2 (mfe ctx e, + fn e' => + (DPolicy e', loc)) and mfvi ctx (x, n, t, e, s) = S.bind2 (mfc ctx t, @@ -1147,6 +1151,7 @@ fun mapfoldB (all as {bind, ...}) = bind (ctx, NamedE (x, n, t, NONE, s)) end | DTask _ => ctx + | DPolicy _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -1210,7 +1215,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DDatabase _ => count | DCookie (_, n, _, _) => Int.max (n, count) | DStyle (_, n, _) => Int.max (n, count) - | DTask _ => count) 0 + | DTask _ => count + | DPolicy _ => count) 0 end diff --git a/src/corify.sml b/src/corify.sml index 6931600e..88473455 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -1080,6 +1080,9 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = | L.DTask (e1, e2) => ([(L'.DTask (corifyExp st e1, corifyExp st e2), loc)], st) + | L.DPolicy e1 => + ([(L'.DPolicy (corifyExp st e1), loc)], st) + and corifyStr mods ((str, _), st) = case str of L.StrConst ds => @@ -1137,7 +1140,8 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DDatabase _ => n | L.DCookie (_, _, n', _) => Int.max (n, n') | L.DStyle (_, _, n') => Int.max (n, n') - | L.DTask _ => n) + | L.DTask _ => n + | L.DPolicy _ => n) 0 ds and maxNameStr (str, _) = diff --git a/src/css.sml b/src/css.sml index 7189904f..3df35ed1 100644 --- a/src/css.sml +++ b/src/css.sml @@ -287,6 +287,7 @@ fun summarize file = | DCookie _ => st | DStyle (_, n, s) => (IM.insert (globals, n, (SOME s, [])), classes) | DTask _ => st + | DPolicy _ => st end val (globals, classes) = foldl decl (IM.empty, IM.empty) file diff --git a/src/elab.sml b/src/elab.sml index a0f9a4e8..e040a059 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -171,6 +171,7 @@ datatype decl' = | DCookie of int * string * int * con | DStyle of int * string * int | DTask of exp * exp + | DPolicy of exp and str' = StrConst of decl list diff --git a/src/elab_env.sml b/src/elab_env.sml index 5092c6fb..dd050c9e 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1623,5 +1623,6 @@ fun declBinds env (d, loc) = pushENamedAs env x n t end | DTask _ => env + | DPolicy _ => env end diff --git a/src/elab_print.sml b/src/elab_print.sml index 62b5262f..86448659 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -806,6 +806,9 @@ fun p_decl env (dAll as (d, _) : decl) = string "=", space, p_exp env e2] + | DPolicy e1 => box [string "policy", + space, + p_exp env e1] and p_str env (str, _) = case str of diff --git a/src/elab_util.sml b/src/elab_util.sml index d0e140c5..8345e3f3 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -854,7 +854,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f c), loc))) | DStyle (tn, x, n) => bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))) - | DTask _ => ctx, + | DTask _ => ctx + | DPolicy _ => ctx, mfd ctx d)) ctx ds, fn ds' => (StrConst ds', loc)) | StrVar _ => S.return2 strAll @@ -985,6 +986,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f S.map2 (mfe ctx e2, fn e2' => (DTask (e1', e2'), loc))) + | DPolicy e1 => + S.map2 (mfe ctx e1, + fn e1' => + (DPolicy e1', loc)) and mfvi ctx (x, n, c, e) = S.bind2 (mfc ctx c, @@ -1128,6 +1133,7 @@ and maxNameDecl (d, _) = | DCookie (n1, _, n2, _) => Int.max (n1, n2) | DStyle (n1, _, n2) => Int.max (n1, n2) | DTask _ => 0 + | DPolicy _ => 0 and maxNameStr (str, _) = case str of StrConst ds => maxName ds diff --git a/src/elaborate.sml b/src/elaborate.sml index 1651f344..07818a57 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2595,6 +2595,7 @@ and sgiOfDecl (d, loc) = | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)] | L'.DTask _ => [] + | L'.DPolicy _ => [] and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), @@ -3729,6 +3730,15 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = checkCon env e2' t2 t2'; ([(L'.DTask (e1', e2'), loc)], (env, denv, gs2 @ gs1 @ gs)) end + | L.DPolicy e1 => + let + val (e1', t1, gs1) = elabExp (env, denv) e1 + + val t1' = (L'.CModProj (!basis_r, [], "sql_policy"), loc) + in + checkCon env e1' t1 t1'; + ([(L'.DPolicy e1', loc)], (env, denv, gs1 @ gs)) + end (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) in diff --git a/src/elisp/urweb-defs.el b/src/elisp/urweb-defs.el index c697a274..8054d829 100644 --- a/src/elisp/urweb-defs.el +++ b/src/elisp/urweb-defs.el @@ -108,7 +108,7 @@ notion of \"the end of an outline\".") "datatype" "type" "open" "include" urweb-module-head-syms "con" "map" "where" "extern" "constraint" "constraints" - "table" "sequence" "class" "cookie" "task") + "table" "sequence" "class" "cookie" "task" "policy") "Symbols starting an sexp.") ;; (defconst urweb-not-arg-start-re @@ -135,7 +135,7 @@ notion of \"the end of an outline\".") (("case" "datatype" "if" "then" "else" "let" "open" "sig" "struct" "type" "val" "con" "constraint" "table" "sequence" "class" "cookie" - "task"))))) + "task" "policy"))))) (defconst urweb-starters-indent-after (urweb-syms-re "let" "in" "struct" "sig") @@ -190,7 +190,7 @@ for all symbols and in all lines starting with the given symbol." '("datatype" "fun" "open" "type" "val" "and" "con" "constraint" "table" "sequence" "class" "cookie" - "task")) + "task" "policy")) "The starters of new expressions.") (defconst urweb-exptrail-syms diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index 107ea3bc..c9fe5f19 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -136,7 +136,7 @@ See doc for the variable `urweb-mode-info'." "datatype" "else" "end" "extern" "fn" "map" "fun" "functor" "if" "include" "of" "open" "let" "in" - "rec" "sequence" "sig" "signature" "cookie" "style" "task" + "rec" "sequence" "sig" "signature" "cookie" "style" "task" "policy" "struct" "structure" "table" "view" "then" "type" "val" "where" "with" @@ -226,7 +226,7 @@ See doc for the variable `urweb-mode-info'." ("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)" (1 font-lock-keyword-face) (3 (amAttribute font-lock-type-def-face))) - ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\|task\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]" + ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\|task\\|policy\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]" (1 font-lock-keyword-face) (3 (amAttribute font-lock-variable-name-face))) ("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)" diff --git a/src/expl.sml b/src/expl.sml index 17797626..1212383f 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -148,6 +148,7 @@ datatype decl' = | DCookie of int * string * int * con | DStyle of int * string * int | DTask of exp * exp + | DPolicy of exp and str' = StrConst of decl list diff --git a/src/expl_env.sml b/src/expl_env.sml index 0bf7323f..583e4881 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -344,6 +344,7 @@ fun declBinds env (d, loc) = pushENamed env x n t end | DTask _ => env + | DPolicy _ => env fun sgiBinds env (sgi, loc) = case sgi of diff --git a/src/expl_print.sml b/src/expl_print.sml index 5284eecb..15838729 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -720,6 +720,9 @@ fun p_decl env (dAll as (d, _) : decl) = string "=", space, p_exp env e2] + | DPolicy e1 => box [string "policy", + space, + p_exp env e1] and p_str env (str, _) = case str of diff --git a/src/explify.sml b/src/explify.sml index aff91a34..0013906f 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -196,6 +196,7 @@ fun explifyDecl (d, loc : EM.span) = | L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc) | L.DStyle (nt, x, n) => SOME (L'.DStyle (nt, x, n), loc) | L.DTask (e1, e2) => SOME (L'.DTask (explifyExp e1, explifyExp e2), loc) + | L.DPolicy e1 => SOME (L'.DPolicy (explifyExp e1), loc) and explifyStr (str, loc) = case str of diff --git a/src/mono.sml b/src/mono.sml index 898feb9b..33ab5bd4 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008-2010, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -123,6 +123,8 @@ datatype exp' = withtype exp = exp' located +datatype policy = PolQuery of exp + datatype decl' = DDatatype of (string * int * (string * int * typ option) list) list | DVal of string * int * typ * exp * string @@ -141,6 +143,8 @@ datatype decl' = | DTask of exp * exp + | DPolicy of policy + withtype decl = decl' located type file = decl list diff --git a/src/mono_env.sml b/src/mono_env.sml index c2e6cf02..87f96488 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -130,6 +130,7 @@ fun declBinds env (d, loc) = | DCookie _ => env | DStyle _ => env | DTask _ => env + | DPolicy _ => env fun patBinds env (p, loc) = case p of diff --git a/src/mono_print.sml b/src/mono_print.sml index d1f5fc27..50c4717a 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -412,6 +412,12 @@ fun p_datatype env (x, n, cons) = cons] end +fun p_policy env pol = + case pol of + PolQuery e => box [string "query", + space, + p_exp env e] + fun p_decl env (dAll as (d, _) : decl) = case d of DDatatype x => box [string "datatype", @@ -506,6 +512,9 @@ fun p_decl env (dAll as (d, _) : decl) = string "=", space, p_exp env e2] + | DPolicy p => box [string "policy", + space, + p_policy env p] fun p_file env file = diff --git a/src/mono_shake.sml b/src/mono_shake.sml index e53b6930..358b31d2 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -58,6 +58,13 @@ fun shake file = | ((DDatabase {expunge = n1, initialize = n2, ...}, _), (page_cs, page_es)) => (page_cs, IS.addList (page_es, [n1, n2])) | ((DTask (e1, e2), _), st) => usedVars (usedVars st e2) e1 + | ((DPolicy pol, _), st) => + let + val e1 = case pol of + PolQuery e1 => e1 + in + usedVars st e1 + end | (_, st) => st) (IS.empty, IS.empty) file val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) => @@ -74,7 +81,8 @@ fun shake file = | ((DJavaScript _, _), acc) => acc | ((DCookie _, _), acc) => acc | ((DStyle _, _), acc) => acc - | ((DTask _, _), acc) => acc) + | ((DTask _, _), acc) => acc + | ((DPolicy _, _), acc) => acc) (IM.empty, IM.empty) file fun typ (c, s) = @@ -141,7 +149,8 @@ fun shake file = | (DJavaScript _, _) => true | (DCookie _, _) => true | (DStyle _, _) => true - | (DTask _, _) => true) file + | (DTask _, _) => true + | (DPolicy _, _) => true) file end end diff --git a/src/mono_util.sml b/src/mono_util.sml index a75843c4..094f216b 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -534,6 +534,16 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = S.map2 (mfe ctx e2, fn e2' => (DTask (e1', e2'), loc))) + | DPolicy pol => + S.map2 (mfpol ctx pol, + fn p' => + (DPolicy p', loc)) + + and mfpol ctx pol = + case pol of + PolQuery e => + S.map2 (mfe ctx e, + PolQuery) and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, @@ -621,6 +631,7 @@ fun mapfoldB (all as {bind, ...}) = | DCookie _ => ctx | DStyle _ => ctx | DTask _ => ctx + | DPolicy _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -674,7 +685,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DJavaScript _ => count | DCookie _ => count | DStyle _ => count - | DTask _ => count) 0 + | DTask _ => count + | DPolicy _ => count) 0 end diff --git a/src/monoize.sml b/src/monoize.sml index 25ea87f5..6f229766 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3738,6 +3738,20 @@ fun monoDecl (env, fm) (all as (d, loc)) = fm, [(L'.DTask (e1, e2), loc)]) end + | L.DPolicy e => + let + val (e, make) = + case #1 e of + L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "query_policy"), _), _), _), _), _), e) => + (e, L'.PolQuery) + | _ => (poly (); (e, L'.PolQuery)) + + val (e, fm) = monoExp (env, St.empty, fm) e + in + SOME (env, + fm, + [(L'.DPolicy (make e), loc)]) + end end datatype expungable = Client | Channel diff --git a/src/reduce.sml b/src/reduce.sml index b7ad567a..cefe1955 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -746,6 +746,15 @@ fun reduce file = namedC, namedE)) end + | DPolicy e1 => + let + val e1 = exp (namedC, namedE) [] e1 + in + ((DPolicy e1, loc), + (polyC, + namedC, + namedE)) + end val (file, _) = ListUtil.foldlMap doDecl (IS.empty, IM.empty, IM.empty) file in diff --git a/src/reduce_local.sml b/src/reduce_local.sml index b040a1ec..4c5ab52e 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -252,6 +252,7 @@ fun reduce file = | DCookie _ => d | DStyle _ => d | DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc) + | DPolicy e1 => (DPolicy (exp [] e1), loc) in map doDecl file end diff --git a/src/shake.sml b/src/shake.sml index 686a043c..f679c6e8 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -90,6 +90,11 @@ fun shake file = st else usedVars (usedVars st e1) e2 + | ((DPolicy e1, _), st) => + if !sliceDb then + st + else + usedVars st e1 | (_, acc) => acc) (IS.empty, IS.empty) file val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef) @@ -116,7 +121,8 @@ fun shake file = (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DStyle (_, n, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], dummyt, dummye))) - | ((DTask _, _), acc) => acc) + | ((DTask _, _), acc) => acc + | ((DPolicy _, _), acc) => acc) (IM.empty, IM.empty) file fun kind (_, s) = s @@ -203,7 +209,8 @@ fun shake file = | (DDatabase _, _) => not (!sliceDb) | (DCookie _, _) => not (!sliceDb) | (DStyle _, _) => not (!sliceDb) - | (DTask _, _) => not (!sliceDb)) file + | (DTask _, _) => not (!sliceDb) + | (DPolicy _, _) => not (!sliceDb)) file end end diff --git a/src/source.sml b/src/source.sml index dc867026..9768cfc0 100644 --- a/src/source.sml +++ b/src/source.sml @@ -168,6 +168,7 @@ datatype decl' = | DCookie of string * con | DStyle of string | DTask of exp * exp + | DPolicy of exp and str' = StrConst of decl list diff --git a/src/source_print.sml b/src/source_print.sml index e3b4fe94..590d15d5 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -669,6 +669,9 @@ fun p_decl ((d, _) : decl) = string "=", space, p_exp e2] + | DPolicy e1 => box [string "policy", + space, + p_exp e1] and p_str (str, _) = case str of diff --git a/src/unnest.sml b/src/unnest.sml index e030bbc6..77589bfb 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -423,6 +423,7 @@ fun unnest file = | DCookie _ => default () | DStyle _ => default () | DTask _ => explore () + | DPolicy _ => explore () end and doStr (all as (str, loc), st) = diff --git a/src/urweb.grm b/src/urweb.grm index ad3de6b2..3df9554f 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -202,7 +202,7 @@ fun patType loc (p : pat) = | LET | IN | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | SELECT1 | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW - | COOKIE | STYLE | TASK + | COOKIE | STYLE | TASK | POLICY | CASE | IF | THEN | ELSE | ANDALSO | ORELSE | XML_BEGIN of string | XML_END | XML_BEGIN_END of string @@ -481,6 +481,7 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))]) | STYLE SYMBOL ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))]) | TASK eapps EQ eexp ([(DTask (eapps, eexp), s (TASKleft, eexpright))]) + | POLICY eexp ([(DPolicy eexp, s (POLICYleft, eexpright))]) dtype : SYMBOL dargs EQ barOpt dcons (SYMBOL, dargs, dcons) diff --git a/src/urweb.lex b/src/urweb.lex index 45f555dd..8930c463 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -416,6 +416,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F]; "cookie" => (Tokens.COOKIE (pos yypos, pos yypos + size yytext)); "style" => (Tokens.STYLE (pos yypos, pos yypos + size yytext)); "task" => (Tokens.TASK (pos yypos, pos yypos + size yytext)); + "policy" => (Tokens.POLICY (pos yypos, pos yypos + size yytext)); "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext)); "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext)); diff --git a/tests/policy.ur b/tests/policy.ur new file mode 100644 index 00000000..db87b582 --- /dev/null +++ b/tests/policy.ur @@ -0,0 +1,3 @@ +table fruit : { Id : int, Nam : string, Weight : float } + +policy query_policy (SELECT * FROM fruit) diff --git a/tests/policy.urp b/tests/policy.urp new file mode 100644 index 00000000..b26ebd4a --- /dev/null +++ b/tests/policy.urp @@ -0,0 +1 @@ +policy -- cgit v1.2.3 From b1d29df128dd1fa879e24f0eb3f5cdc1b74e16b7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 3 Jun 2010 13:04:37 -0400 Subject: Some serious bug-fix work to get HTML example to compile; this includes fixing a bug with 'val' patterns in Unnest and the need for more local reduction in Especialize --- lib/ur/basis.urs | 2 +- lib/ur/string.ur | 10 ++- src/compiler.sig | 10 ++- src/compiler.sml | 6 +- src/core_print.sml | 11 +++- src/elab_env.sig | 1 + src/elab_env.sml | 9 +++ src/elab_print.sml | 11 +++- src/elab_util.sml | 32 ++++++++- src/especialize.sml | 7 +- src/expl_print.sml | 11 +++- src/monoize.sml | 7 +- src/reduce.sml | 32 +++++++++ src/reduce_local.sml | 179 +++++++++++++++++++++++++++++++++++++++++++-------- src/unnest.sml | 16 ++++- 15 files changed, 295 insertions(+), 49 deletions(-) (limited to 'src/elab_env.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 19983cd2..f2dffd38 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -79,7 +79,7 @@ val strsub : string -> int -> char val strsuffix : string -> int -> string val strchr : string -> char -> option string val strindex : string -> char -> option int -val strcspn : string -> string -> option int +val strcspn : string -> string -> int val substring : string -> int -> int -> string val str1 : char -> string diff --git a/lib/ur/string.ur b/lib/ur/string.ur index f19ce174..f7781e01 100644 --- a/lib/ur/string.ur +++ b/lib/ur/string.ur @@ -11,7 +11,15 @@ val suffix = Basis.strsuffix val index = Basis.strindex val atFirst = Basis.strchr -fun mindex {Haystack = s, Needle = chs} = Basis.strcspn s chs +fun mindex {Haystack = s, Needle = chs} = + let + val n = Basis.strcspn s chs + in + if n >= length s then + None + else + Some n + end fun substring s {Start = start, Len = len} = Basis.substring s start len diff --git a/src/compiler.sig b/src/compiler.sig index 16207e8b..7e3e8ffc 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -129,10 +129,14 @@ signature COMPILER = sig val toTag : (string, Core.file) transform val toReduce : (string, Core.file) transform val toShakey : (string, Core.file) transform - val toUnpoly : (string, Core.file) transform - val toSpecialize : (string, Core.file) transform + val toUnpoly : (string, Core.file) transform + val toSpecialize : (string, Core.file) transform val toShake4 : (string, Core.file) transform - val toEspecialize2 : (string, Core.file) transform + val toEspecialize2 : (string, Core.file) transform + val toShake4' : (string, Core.file) transform + val toUnpoly2 : (string, Core.file) transform + val toShake4'' : (string, Core.file) transform + val toEspecialize3 : (string, Core.file) transform val toReduce2 : (string, Core.file) transform val toShake5 : (string, Core.file) transform val toMarshalcheck : (string, Core.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 1d15367f..dcc1e5b3 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1013,8 +1013,12 @@ val toSpecialize = transform specialize "specialize" o toUnpoly val toShake4 = transform shake "shake4" o toSpecialize val toEspecialize2 = transform especialize "especialize2" o toShake4 +val toShake4' = transform shake "shake4'" o toEspecialize2 +val toUnpoly2 = transform unpoly "unpoly2" o toShake4' +val toShake4'' = transform shake "shake4'" o toUnpoly2 +val toEspecialize3 = transform especialize "especialize3" o toShake4'' -val toReduce2 = transform reduce "reduce2" o toEspecialize2 +val toReduce2 = transform reduce "reduce2" o toEspecialize3 val toShake5 = transform shake "shake5" o toReduce2 diff --git a/src/core_print.sml b/src/core_print.sml index fd0556e6..f18ea4b9 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -233,12 +233,19 @@ fun p_pat' par env (p, _) = p_pat' true env p]) | PRecord xps => box [string "{", - p_list_sep (box [string ",", space]) (fn (x, p, _) => + p_list_sep (box [string ",", space]) (fn (x, p, t) => box [string x, space, string "=", space, - p_pat env p]) xps, + p_pat env p, + if !debug then + box [space, + string ":", + space, + p_con env t] + else + box []]) xps, string "}"] and p_pat x = p_pat' false x diff --git a/src/elab_env.sig b/src/elab_env.sig index a5b8751a..769fea58 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -118,6 +118,7 @@ signature ELAB_ENV = sig val chaseMpath : env -> (int * string list) -> Elab.str * Elab.sgn val patBinds : env -> Elab.pat -> env + val patBindsN : Elab.pat -> int exception Bad of Elab.con * Elab.con diff --git a/src/elab_env.sml b/src/elab_env.sml index dd050c9e..bb34c345 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1512,6 +1512,15 @@ fun patBinds env (p, loc) = | PCon (_, _, _, SOME p) => patBinds env p | PRecord xps => foldl (fn ((_, p, _), env) => patBinds env p) env xps +fun patBindsN (p, _) = + case p of + PWild => 0 + | PVar _ => 1 + | PPrim _ => 0 + | PCon (_, _, _, NONE) => 0 + | PCon (_, _, _, SOME p) => patBindsN p + | PRecord xps => foldl (fn ((_, p, _), n) => patBindsN p + n) 0 xps + fun edeclBinds env (d, loc) = case d of EDVal (p, _, _) => patBinds env p diff --git a/src/elab_print.sml b/src/elab_print.sml index 86448659..42a0a107 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -252,12 +252,19 @@ fun p_pat' par env (p, _) = p_pat' true env p]) | PRecord xps => box [string "{", - p_list_sep (box [string ",", space]) (fn (x, p, _) => + p_list_sep (box [string ",", space]) (fn (x, p, t) => box [string x, space, string "=", space, - p_pat env p]) xps, + p_pat env p, + if !debug then + box [space, + string ":", + space, + p_con env t] + else + box []]) xps, string "}"] and p_pat x = p_pat' false x diff --git a/src/elab_util.sml b/src/elab_util.sml index 8345e3f3..ec6c51ba 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -429,8 +429,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = | PRecord xps => foldl (fn ((_, p, _), ctx) => pb (p, ctx)) ctx xps in - S.map2 (mfe (pb (p, ctx)) e, - fn e' => (p, e')) + S.bind2 (mfp ctx p, + fn p' => + S.map2 (mfe (pb (p', ctx)) e, + fn e' => (p', e'))) end) pes, fn pes' => S.bind2 (mfc ctx disc, @@ -482,6 +484,32 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = fn k' => (EKApp (e', k'), loc))) + and mfp ctx (pAll as (p, loc)) = + case p of + PWild => S.return2 pAll + | PVar (x, t) => + S.map2 (mfc ctx t, + fn t' => + (PVar (x, t'), loc)) + | PPrim _ => S.return2 pAll + | PCon (dk, pc, args, po) => + S.bind2 (ListUtil.mapfold (mfc ctx) args, + fn args' => + S.map2 ((case po of + NONE => S.return2 NONE + | SOME p => S.map2 (mfp ctx p, SOME)), + fn po' => + (PCon (dk, pc, args', po'), loc))) + | PRecord xps => + S.map2 (ListUtil.mapfold (fn (x, p, c) => + S.bind2 (mfp ctx p, + fn p' => + S.map2 (mfc ctx c, + fn c' => + (x, p', c')))) xps, + fn xps' => + (PRecord xps', loc)) + and mfed ctx (dAll as (d, loc)) = case d of EDVal (p, t, e) => diff --git a/src/especialize.sml b/src/especialize.sml index 7d129b8b..3fa3ea1d 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2009, Adam Chlipala +(* Copyright (c) 2008-2010, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -278,7 +278,7 @@ fun specialize' (funcs, specialized) file = NONE => default () | SOME (f, xs) => case IM.find (#funcs st, f) of - NONE => default () + NONE => ((*print ("No find: " ^ Int.toString f ^ "\n");*) default ()) | SOME {name, args, body, typ, tag} => let val (xs, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st xs @@ -415,6 +415,8 @@ fun specialize' (funcs, specialized) file = (body', typ') fvs val mns = !mayNotSpec (*val () = mayNotSpec := SS.add (mns, name)*) + (*val () = print ("NEW: " ^ name ^ "__" ^ Int.toString f' ^ "\n");*) + val body' = ReduceLocal.reduceExp body' (*val () = Print.preface ("PRE", CorePrint.p_exp CoreEnv.empty body')*) val (body', st) = exp (env, body', st) val () = mayNotSpec := mns @@ -424,7 +426,6 @@ fun specialize' (funcs, specialized) file = e' fvs val e' = foldl (fn (arg, e) => (EApp (e, arg), loc)) e' xs - (*val () = print ("NEW: " ^ name ^ "__" ^ Int.toString f' ^ "\n");*) (*val () = Print.prefaces "Brand new" [("e'", CorePrint.p_exp CoreEnv.empty e'), ("e", CorePrint.p_exp CoreEnv.empty e), diff --git a/src/expl_print.sml b/src/expl_print.sml index 15838729..c953350c 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -234,12 +234,19 @@ fun p_pat' par env (p, _) = | PRecord xps => box [string "{", - p_list_sep (box [string ",", space]) (fn (x, p, _) => + p_list_sep (box [string ",", space]) (fn (x, p, t) => box [string x, space, string "=", space, - p_pat env p]) xps, + p_pat env p, + if !debug then + box [space, + string ":", + space, + p_con env t] + else + box []]) xps, string "}"] and p_pat x = p_pat' false x diff --git a/src/monoize.sml b/src/monoize.sml index e2377bae..d43002cb 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2737,7 +2737,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "tag"), - _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + _), (L.CRecord (_, attrsGiven), _)), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), class), _), attrs), _), tag), _), @@ -2768,7 +2768,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (attrs, fm) = monoExp (env, st, fm) attrs val attrs = case #1 attrs of L'.ERecord xes => xes - | _ => raise Fail "Non-record attributes!" + | _ => map (fn ((L.CName x, _), t) => (x, (L'.EField (attrs, x), loc), monoType env t) + | (c, t) => (E.errorAt loc "Non-constant field name for HTML tag attribute"; + Print.eprefaces' [("Name", CorePrint.p_con env c)]; + ("", (L'.EField (attrs, ""), loc), monoType env t))) attrsGiven val attrs = if List.exists (fn ("Link", _, _) => true diff --git a/src/reduce.sml b/src/reduce.sml index b2911a5f..963863e8 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -65,6 +65,18 @@ val dangling = CoreUtil.Exp.RelE _ => n + 1 | _ => n} +val cdangling = + CoreUtil.Exp.existsB {kind = fn _ => false, + con = fn (n, c) => + case c of + CRel n' => n' >= n + | _ => false, + exp = fn _ => false, + bind = fn (n, b) => + case b of + CoreUtil.Exp.RelC _ => n + 1 + | _ => n} + datatype env_item = UnknownK | KnownK of kind @@ -86,6 +98,15 @@ val edepth' = foldl (fn (UnknownE, n) => n + 1 | (Lift (_, _, n'), n) => n + n' | (_, n) => n) 0 +val cdepth = foldl (fn (UnknownC, n) => n + 1 + | (KnownC _, n) => n + 1 + | (_, n) => n) 0 + +val cdepth' = foldl (fn (UnknownC, n) => n + 1 + | (KnownC _, n) => n + 1 + | (Lift (_, n', _), n) => n + n' + | (_, n) => n) 0 + type env = env_item list fun ei2s ei = @@ -344,6 +365,11 @@ fun kindConAndExp (namedC, namedE) = raise Fail "!") else ()*) + (*val () = if cdangling (cdepth env) all then + Print.prefaces "Bad exp" [("e", CorePrint.p_exp CoreEnv.empty all), + ("env", Print.PD.string (e2s env))] + else + ()*) val r = case e of EPrim _ => all @@ -636,6 +662,12 @@ fun kindConAndExp (namedC, namedE) = raise Fail "!!") else ();*) + (*if cdangling (cdepth' (deKnown env)) r then + (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all), + ("r", CorePrint.p_exp CoreEnv.empty r)]; + raise Fail "!!") + else + ();*) r end in diff --git a/src/reduce_local.sml b/src/reduce_local.sml index 4c5ab52e..43317b9e 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008-2010, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -43,11 +43,15 @@ datatype env_item = Unknown | Known of exp - | Lift of int + | UnknownC + | KnownC of con + + | Lift of int * int type env = env_item list val deKnown = List.filter (fn Known _ => false + | KnownC _ => false | _ => true) datatype result = Yes of env | No | Maybe @@ -120,39 +124,140 @@ fun match (env, p : pat, e : exp) = match (env, p, e) end +fun con env (all as (c, loc)) = + ((*Print.prefaces "con" [("c", CorePrint.p_con CoreEnv.empty all)];*) + case c of + TFun (c1, c2) => (TFun (con env c1, con env c2), loc) + | TCFun (x, k, c2) => (TCFun (x, k, con (UnknownC :: env) c2), loc) + | TKFun (x, c2) => (TKFun (x, con env c2), loc) + | TRecord c => (TRecord (con env c), loc) + + | CRel n => + let + fun find (n', env, nudge, liftC) = + case env of + [] => raise Fail "Reduce.con: CRel" + | Unknown :: rest => find (n', rest, nudge, liftC) + | Known _ :: rest => find (n', rest, nudge, liftC) + | Lift (liftC', _) :: rest => find (n', rest, nudge + liftC', + liftC + liftC') + | UnknownC :: rest => + if n' = 0 then + (CRel (n + nudge), loc) + else + find (n' - 1, rest, nudge, liftC + 1) + | KnownC c :: rest => + if n' = 0 then + con (Lift (liftC, 0) :: rest) c + else + find (n' - 1, rest, nudge - 1, liftC) + in + (*print (Int.toString n ^ ": " ^ e2s env ^ "\n");*) + find (n, env, 0, 0) + end + | CNamed _ => all + | CFfi _ => all + | CApp (c1, c2) => + let + val c1 = con env c1 + val c2 = con env c2 + in + case #1 c1 of + CAbs (_, _, b) => + con (KnownC c2 :: deKnown env) b + + | CApp ((CMap (dom, ran), _), f) => + (case #1 c2 of + CRecord (_, []) => (CRecord (ran, []), loc) + | CRecord (_, (x, c) :: rest) => + con (deKnown env) + (CConcat ((CRecord (ran, [(x, (CApp (f, c), loc))]), loc), + (CApp (c1, (CRecord (dom, rest), loc)), loc)), loc) + | _ => (CApp (c1, c2), loc)) + + | _ => (CApp (c1, c2), loc) + end + | CAbs (x, k, b) => (CAbs (x, k, con (UnknownC :: env) b), loc) + + | CKApp (c1, k) => + let + val c1 = con env c1 + in + case #1 c1 of + CKAbs (_, b) => + con (deKnown env) b + + | _ => (CKApp (c1, k), loc) + end + | CKAbs (x, b) => (CKAbs (x, con env b), loc) + + | CName _ => all + + | CRecord (k, xcs) => (CRecord (k, map (fn (x, c) => (con env x, con env c)) xcs), loc) + | CConcat (c1, c2) => + let + val c1 = con env c1 + val c2 = con env c2 + in + case (#1 c1, #1 c2) of + (CRecord (k, xcs1), CRecord (_, xcs2)) => + (CRecord (k, xcs1 @ xcs2), loc) + | (CRecord (_, []), _) => c2 + | (_, CRecord (_, [])) => c1 + | _ => (CConcat (c1, c2), loc) + end + | CMap _ => all + + | CUnit => all + + | CTuple cs => (CTuple (map (con env) cs), loc) + | CProj (c, n) => + let + val c = con env c + in + case #1 c of + CTuple cs => List.nth (cs, n - 1) + | _ => (CProj (c, n), loc) + end) + +fun patCon pc = + case pc of + PConVar _ => pc + | PConFfi {mod = m, datatyp, params, con = c, arg, kind} => + PConFfi {mod = m, datatyp = datatyp, params = params, con = c, + arg = Option.map (con (map (fn _ => UnknownC) params)) arg, + kind = kind} + fun exp env (all as (e, loc)) = case e of EPrim _ => all | ERel n => let - fun find (n', env, nudge, lift) = + fun find (n', env, nudge, liftC, liftE) = case env of [] => (ERel (n + nudge), loc) - | Lift lift' :: rest => find (n', rest, nudge + lift', lift + lift') + | Lift (liftC', liftE') :: rest => find (n', rest, nudge + liftE', liftC + liftC', liftE + liftE') + | UnknownC :: rest => find (n', rest, nudge, liftC + 1, liftE) + | KnownC _ :: rest => find (n', rest, nudge, liftC, liftE) | Unknown :: rest => if n' = 0 then (ERel (n + nudge), loc) else - find (n' - 1, rest, nudge, lift + 1) + find (n' - 1, rest, nudge, liftC, liftE + 1) | Known e :: rest => if n' = 0 then ((*print "SUBSTITUTING\n";*) - exp (Lift lift :: rest) e) + exp (Lift (liftC, liftE) :: rest) e) else - find (n' - 1, rest, nudge - 1, lift) + find (n' - 1, rest, nudge - 1, liftC, liftE) in - find (n, env, 0, 0) + find (n, env, 0, 0, 0) end | ENamed _ => all - | ECon (dk, pc, cs, eo) => (ECon (dk, pc, cs, Option.map (exp env) eo), loc) + | ECon (dk, pc, cs, eo) => (ECon (dk, patCon pc, map (con env) cs, Option.map (exp env) eo), loc) | EFfi _ => all | EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc) - | EApp ((ECApp ((ECAbs (_, _, (EAbs (_, (CRel 0, _), _, - (ECon (dk, pc, [(CRel 0, loc)], SOME (ERel 0, _)), _)), _)), _), - t), _), e) => - (ECon (dk, pc, [t], SOME (exp env e)), loc) - | EApp (e1, e2) => let val e1 = exp env e1 @@ -163,21 +268,28 @@ fun exp env (all as (e, loc)) = | _ => (EApp (e1, e2), loc) end - | EAbs (x, dom, ran, e) => (EAbs (x, dom, ran, exp (Unknown :: env) e), loc) + | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (Unknown :: env) e), loc) - | ECApp ((ECAbs (_, _, (ECon (dk, pc, [(CRel 0, loc)], NONE), _)), _), t) => - (ECon (dk, pc, [t], NONE), loc) + | ECApp (e, c) => + let + val e = exp env e + val c = con env c + in + case #1 e of + ECAbs (_, _, b) => exp (KnownC c :: deKnown env) b + | _ => (ECApp (e, c), loc) + end - | ECApp (e, c) => (ECApp (exp env e, c), loc) - | ECAbs (x, k, e) => (ECAbs (x, k, exp env e), loc) + | ECAbs (x, k, e) => (ECAbs (x, k, exp (UnknownC :: env) e), loc) | EKApp (e, k) => (EKApp (exp env e, k), loc) | EKAbs (x, e) => (EKAbs (x, exp env e), loc) - | ERecord xcs => (ERecord (map (fn (x, e, t) => (x, exp env e, t)) xcs), loc) + | ERecord xcs => (ERecord (map (fn (x, e, t) => (con env x, exp env e, con env t)) xcs), loc) | EField (e, c, others) => let val e = exp env e + val c = con env c fun default () = (EField (e, c, others), loc) in @@ -189,12 +301,16 @@ fun exp env (all as (e, loc)) = | _ => default () end - | EConcat (e1, c1, e2, c2) => (EConcat (exp env e1, c1, exp env e2, c2), loc) - | ECut (e, c, others) => (ECut (exp env e, c, others), loc) - | ECutMulti (e, c, others) => (ECutMulti (exp env e, c, others), loc) + | EConcat (e1, c1, e2, c2) => (EConcat (exp env e1, con env c1, exp env e2, con env c2), loc) + | ECut (e, c, {field = f, rest = r}) => (ECut (exp env e, + con env c, + {field = con env f, rest = con env r}), loc) + | ECutMulti (e, c, {rest = r}) => (ECutMulti (exp env e, con env c, {rest = con env r}), loc) - | ECase (e, pes, others) => + | ECase (e, pes, {disc = d, result = r}) => let + val others = {disc = con env d, result = con env r} + fun patBinds (p, _) = case p of PWild => 0 @@ -204,9 +320,18 @@ fun exp env (all as (e, loc)) = | PCon (_, _, _, SOME p) => patBinds p | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts + fun pat (all as (p, loc)) = + case p of + PWild => all + | PVar (x, t) => (PVar (x, con env t), loc) + | PPrim _ => all + | PCon (dk, pc, cs, po) => + (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc) + | PRecord xpts => (PRecord (map (fn (x, p, t) => (x, pat p, con env t)) xpts), loc) + fun push () = (ECase (exp env e, - map (fn (p, e) => (p, + map (fn (p, e) => (pat p, exp (List.tabulate (patBinds p, fn _ => Unknown) @ env) e)) pes, others), loc) @@ -226,9 +351,9 @@ fun exp env (all as (e, loc)) = | EWrite e => (EWrite (exp env e), loc) | EClosure (n, es) => (EClosure (n, map (exp env) es), loc) - | ELet (x, t, e1, e2) => (ELet (x, t, exp env e1, exp (Unknown :: env) e2), loc) + | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (Unknown :: env) e2), loc) - | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, t), loc) + | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, con env t), loc) fun reduce file = let diff --git a/src/unnest.sml b/src/unnest.sml index 77589bfb..a2ec32b0 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008-2010, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -204,12 +204,19 @@ fun exp ((ks, ts), e as old, st : state) = | PRecord xpcs => foldl (fn ((_, p, _), ts) => doVars (p, ts)) ts xpcs + + fun bindOne subs = ((0, (ERel 0, #2 ed)) + :: map (fn (n, e) => (n + 1, E.liftExpInExp 0 e)) subs) + + fun bindMany (n, subs) = + case n of + 0 => subs + | _ => bindMany (n - 1, bindOne subs) in ([(EDVal (p, t, e), #2 ed)], (doVars (p, ts), maxName, ds, - ((0, (ERel 0, #2 ed)) - :: map (fn (n, e) => (n + 1, E.liftExpInExp 0 e)) subs), + bindMany (E.patBindsN p, subs), by)) end | EDValRec vis => @@ -310,6 +317,7 @@ fun exp ((ks, ts), e as old, st : state) = let (*val () = print (Int.toString ex ^ "\n")*) val (name, t') = List.nth (ts, ex) + val t' = squishCon cfv t' in ((EAbs (name, t', @@ -354,6 +362,8 @@ fun exp ((ks, ts), e as old, st : state) = (*Print.prefaces "Before" [("e", ElabPrint.p_exp ElabEnv.empty e), ("se", ElabPrint.p_exp ElabEnv.empty (doSubst' (e, subs))), ("e'", ElabPrint.p_exp ElabEnv.empty e')];*) + (*Print.prefaces "Let" [("Before", ElabPrint.p_exp ElabEnv.empty (old, ErrorMsg.dummySpan)), + ("After", ElabPrint.p_exp ElabEnv.empty (ELet (eds, e', t), ErrorMsg.dummySpan))];*) (ELet (eds, e', t), {maxName = maxName, decls = ds}) -- cgit v1.2.3 From 5545969f485ef2fb944db8e7b0237acbabeb8d4c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 7 Sep 2010 08:28:07 -0400 Subject: Server-side 'onError' --- include/types.h | 4 ++ include/urweb.h | 1 + src/c/request.c | 101 ++++++++++++++++++++++++++++++++------------------- src/c/urweb.c | 18 ++++++++- src/cjr.sml | 1 + src/cjr_env.sml | 1 + src/cjr_print.sml | 26 +++++++++++-- src/cjrize.sml | 1 + src/compiler.sig | 3 +- src/compiler.sml | 23 ++++++++++-- src/core.sml | 1 + src/core_env.sml | 1 + src/core_print.sml | 1 + src/core_util.sml | 6 ++- src/corify.sml | 14 ++++++- src/css.sml | 1 + src/demo.sml | 3 +- src/elab.sml | 1 + src/elab_env.sml | 1 + src/elab_print.sml | 1 + src/elab_util.sml | 5 ++- src/elaborate.sml | 27 ++++++++++++++ src/expl.sml | 1 + src/expl_env.sml | 1 + src/expl_print.sml | 1 + src/explify.sml | 3 +- src/mono.sml | 1 + src/mono_env.sml | 1 + src/mono_print.sml | 2 +- src/mono_shake.sml | 7 +++- src/mono_util.sml | 5 ++- src/monoize.sml | 3 ++ src/prepare.sml | 1 + src/reduce.sml | 1 + src/reduce_local.sml | 1 + src/settings.sig | 2 + src/settings.sml | 4 ++ src/shake.sml | 11 +++++- src/source.sml | 1 + src/source_print.sml | 1 + src/unnest.sml | 1 + tests/onerror.ur | 4 ++ tests/onerror.urp | 4 ++ tests/onerror.urs | 1 + tests/onerrorE.ur | 5 +++ 45 files changed, 244 insertions(+), 59 deletions(-) create mode 100644 tests/onerror.ur create mode 100644 tests/onerror.urp create mode 100644 tests/onerror.urs create mode 100644 tests/onerrorE.ur (limited to 'src/elab_env.sml') diff --git a/include/types.h b/include/types.h index 138760e5..ac70c34f 100644 --- a/include/types.h +++ b/include/types.h @@ -73,6 +73,10 @@ typedef struct { uw_Basis_string (*cookie_sig)(uw_context); int (*check_url)(const char *); int (*check_mime)(const char *); + + void (*on_error)(uw_context, char *); } uw_app; +#define ERROR_BUF_LEN 1024 + #endif diff --git a/include/urweb.h b/include/urweb.h index 32e9b4e1..f254da2a 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -36,6 +36,7 @@ failure_kind uw_begin_init(uw_context); void uw_set_on_success(char *); void uw_set_headers(uw_context, char *(*get_header)(void *, const char *), void *get_header_data); failure_kind uw_begin(uw_context, char *path); +failure_kind uw_begin_onError(uw_context, char *msg); void uw_login(uw_context); void uw_commit(uw_context); int uw_rollback(uw_context); diff --git a/src/c/request.c b/src/c/request.c index 5e57d7b0..f72a3199 100644 --- a/src/c/request.c +++ b/src/c/request.c @@ -131,6 +131,8 @@ request_result uw_request(uw_request_context rc, uw_context ctx, char *inputs; const char *prefix = uw_get_url_prefix(ctx); char *s; + int had_error = 0; + char errmsg[ERROR_BUF_LEN]; for (s = path; *s; ++s) { if (s[0] == '%' && s[1] == '2' && s[2] == '7') { @@ -336,32 +338,42 @@ request_result uw_request(uw_request_context rc, uw_context ctx, log_debug(logger_data, "Serving URI %s....\n", path); while (1) { - size_t path_len = strlen(path); + if (!had_error) { + size_t path_len = strlen(path); - on_success(ctx); + on_success(ctx); + + if (path_len + 1 > rc->path_copy_size) { + rc->path_copy_size = path_len + 1; + rc->path_copy = realloc(rc->path_copy, rc->path_copy_size); + } + strcpy(rc->path_copy, path); + fk = uw_begin(ctx, rc->path_copy); + } else + fk = uw_begin_onError(ctx, errmsg); - if (path_len + 1 > rc->path_copy_size) { - rc->path_copy_size = path_len + 1; - rc->path_copy = realloc(rc->path_copy, rc->path_copy_size); - } - strcpy(rc->path_copy, path); - fk = uw_begin(ctx, rc->path_copy); if (fk == SUCCESS || fk == RETURN_INDIRECTLY) { uw_commit(ctx); - if (uw_has_error(ctx)) { + if (uw_has_error(ctx) && !had_error) { log_error(logger_data, "Fatal error: %s\n", uw_error_message(ctx)); uw_reset_keep_error_message(ctx); on_failure(ctx); - uw_write_header(ctx, "Content-type: text/html\r\n"); - uw_write(ctx, "Fatal Error"); - uw_write(ctx, "Fatal error: "); - uw_write(ctx, uw_error_message(ctx)); - uw_write(ctx, "\n"); + + if (uw_get_app(ctx)->on_error) { + had_error = 1; + strcpy(errmsg, uw_error_message(ctx)); + } else { + uw_write_header(ctx, "Content-type: text/html\r\n"); + uw_write(ctx, "Fatal Error"); + uw_write(ctx, "Fatal error: "); + uw_write(ctx, uw_error_message(ctx)); + uw_write(ctx, "\n"); - return FAILED; + return FAILED; + } } else - return SERVED; + return had_error ? FAILED : SERVED; } else if (fk == BOUNDED_RETRY) { if (retries_left) { log_debug(logger_data, "Error triggers bounded retry: %s\n", uw_error_message(ctx)); @@ -372,14 +384,19 @@ request_result uw_request(uw_request_context rc, uw_context ctx, try_rollback(ctx, logger_data, log_error); - uw_reset_keep_error_message(ctx); - on_failure(ctx); - uw_write_header(ctx, "Content-type: text/plain\r\n"); - uw_write(ctx, "Fatal error (out of retries): "); - uw_write(ctx, uw_error_message(ctx)); - uw_write(ctx, "\n"); - - return FAILED; + if (!had_error && uw_get_app(ctx)->on_error) { + had_error = 1; + strcpy(errmsg, uw_error_message(ctx)); + } else { + uw_reset_keep_error_message(ctx); + on_failure(ctx); + uw_write_header(ctx, "Content-type: text/plain\r\n"); + uw_write(ctx, "Fatal error (out of retries): "); + uw_write(ctx, uw_error_message(ctx)); + uw_write(ctx, "\n"); + + return FAILED; + } } } else if (fk == UNLIMITED_RETRY) log_debug(logger_data, "Error triggers unlimited retry: %s\n", uw_error_message(ctx)); @@ -388,26 +405,36 @@ request_result uw_request(uw_request_context rc, uw_context ctx, try_rollback(ctx, logger_data, log_error); - uw_reset_keep_error_message(ctx); - on_failure(ctx); - uw_write_header(ctx, "Content-type: text/html\r\n"); - uw_write(ctx, "Fatal Error"); - uw_write(ctx, "Fatal error: "); - uw_write(ctx, uw_error_message(ctx)); - uw_write(ctx, "\n"); + if (uw_get_app(ctx)->on_error && !had_error) { + had_error = 1; + strcpy(errmsg, uw_error_message(ctx)); + } else { + uw_reset_keep_error_message(ctx); + on_failure(ctx); + uw_write_header(ctx, "Content-type: text/html\r\n"); + uw_write(ctx, "Fatal Error"); + uw_write(ctx, "Fatal error: "); + uw_write(ctx, uw_error_message(ctx)); + uw_write(ctx, "\n"); - return FAILED; + return FAILED; + } } else { log_error(logger_data, "Unknown uw_handle return code!\n"); try_rollback(ctx, logger_data, log_error); - uw_reset_keep_request(ctx); - on_failure(ctx); - uw_write_header(ctx, "Content-type: text/plain\r\n"); - uw_write(ctx, "Unknown uw_handle return code!\n"); + if (uw_get_app(ctx)->on_error && !had_error) { + had_error = 1; + strcpy(errmsg, "Unknown uw_handle return code"); + } else { + uw_reset_keep_request(ctx); + on_failure(ctx); + uw_write_header(ctx, "Content-type: text/plain\r\n"); + uw_write(ctx, "Unknown uw_handle return code!\n"); - return FAILED; + return FAILED; + } } if (try_rollback(ctx, logger_data, log_error)) diff --git a/src/c/urweb.c b/src/c/urweb.c index 74e1b12e..cac518ec 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -353,8 +353,6 @@ int uw_time = 0; // Single-request state -#define ERROR_BUF_LEN 1024 - typedef struct regions { struct regions *next; } regions; @@ -714,6 +712,22 @@ failure_kind uw_begin(uw_context ctx, char *path) { return r; } +failure_kind uw_begin_onError(uw_context ctx, char *msg) { + int r = setjmp(ctx->jmp_buf); + + if (ctx->app->on_error) { + if (r == 0) { + if (ctx->app->db_begin(ctx)) + uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN"); + + ctx->app->on_error(ctx, msg); + } + + return r; + } else + uw_error(ctx, FATAL, "Tried to run nonexistent onError handler"); +} + uw_Basis_client uw_Basis_self(uw_context ctx) { if (ctx->client == NULL) uw_error(ctx, FATAL, "Call to Basis.self() from page that has only server-side code"); diff --git a/src/cjr.sml b/src/cjr.sml index f34662dc..5013033f 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -124,6 +124,7 @@ datatype decl' = | DStyle of string | DTask of task * exp + | DOnError of int withtype decl = decl' located diff --git a/src/cjr_env.sml b/src/cjr_env.sml index ac83f263..21188b51 100644 --- a/src/cjr_env.sml +++ b/src/cjr_env.sml @@ -172,5 +172,6 @@ fun declBinds env (d, loc) = | DCookie _ => env | DStyle _ => env | DTask _ => env + | DOnError _ => env end diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 7331196f..9b5edab5 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -113,9 +113,11 @@ and p_typ env = p_typ' false env fun p_rel env n = string ("__uwr_" ^ ident (#1 (E.lookupERel env n)) ^ "_" ^ Int.toString (E.countERels env - n - 1)) handle CjrEnv.UnboundRel _ => string ("__uwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1)) -fun p_enamed env n = - string ("__uwn_" ^ ident (#1 (E.lookupENamed env n)) ^ "_" ^ Int.toString n) - handle CjrEnv.UnboundNamed _ => string ("__uwn_UNBOUND_" ^ Int.toString n) +fun p_enamed' env n = + "__uwn_" ^ ident (#1 (E.lookupENamed env n)) ^ "_" ^ Int.toString n + handle CjrEnv.UnboundNamed _ => "__uwn_UNBOUND_" ^ Int.toString n + +fun p_enamed env n = string (p_enamed' env n) fun p_con_named env n = string ("__uwc_" ^ ident (#1 (E.lookupConstructor env n)) ^ "_" ^ Int.toString n) @@ -2156,6 +2158,7 @@ fun p_decl env (dAll as (d, _) : decl) = string "*/"] | DTask _ => box [] + | DOnError _ => box [] datatype 'a search = Found of 'a @@ -2791,6 +2794,8 @@ fun p_file env (ds, ps) = val initializers = List.mapPartial (fn (DTask (Initialize, e), _) => SOME e | _ => NONE) ds + val onError = ListUtil.search (fn (DOnError n, _) => SOME n | _ => NONE) ds + val now = Time.now () val nowD = Date.fromTimeUniv now val rfcFmt = "%a, %d %b %Y %H:%M:%S" @@ -2957,6 +2962,18 @@ fun p_file env (ds, ps) = string "static void uw_initializer(uw_context ctx) { };", newline], + case onError of + NONE => box [] + | SOME n => box [string "static void uw_onError(uw_context ctx, char *msg) {", + newline, + box [string "uw_write(ctx, ", + p_enamed env n, + string "(ctx, msg, uw_unit_v));", + newline], + string "}", + newline, + newline], + string "uw_app uw_application = {", p_list_sep (box [string ",", newline]) string [Int.toString (SM.foldl Int.max 0 fnums + 1), @@ -2965,7 +2982,8 @@ fun p_file env (ds, ps) = "uw_client_init", "uw_initializer", "uw_expunger", "uw_db_init", "uw_db_begin", "uw_db_commit", "uw_db_rollback", "uw_db_close", "uw_handle", - "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime"], + "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime", + case onError of NONE => "NULL" | SOME _ => "uw_onError"], string "};", newline] end diff --git a/src/cjrize.sml b/src/cjrize.sml index 22463cd4..2e7afa43 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -675,6 +675,7 @@ fun cifyDecl ((d, loc), sm) = | _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined"; (NONE, NONE, sm))) | L.DPolicy _ => (NONE, NONE, sm) + | L.DOnError n => (SOME (L'.DOnError n, loc), NONE, sm) fun cjrize ds = let diff --git a/src/compiler.sig b/src/compiler.sig index c9b96a52..d0f6ac72 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -54,7 +54,8 @@ signature COMPILER = sig protocol : string option, dbms : string option, sigFile : string option, - safeGets : string list + safeGets : string list, + onError : (string * string list * string) option } val compile : string -> bool val compiler : string -> unit diff --git a/src/compiler.sml b/src/compiler.sml index 6167f08a..c01024f0 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -58,7 +58,8 @@ type job = { protocol : string option, dbms : string option, sigFile : string option, - safeGets : string list + safeGets : string list, + onError : (string * string list * string) option } type ('src, 'dst) phase = { @@ -396,6 +397,7 @@ fun parseUrp' accLibs fname = val dbms = ref NONE val sigFile = ref (Settings.getSigFile ()) val safeGets = ref [] + val onError = ref NONE fun finish sources = let @@ -425,7 +427,8 @@ fun parseUrp' accLibs fname = protocol = !protocol, dbms = !dbms, sigFile = !sigFile, - safeGets = rev (!safeGets) + safeGets = rev (!safeGets), + onError = !onError } fun mergeO f (old, new) = @@ -469,7 +472,8 @@ fun parseUrp' accLibs fname = protocol = mergeO #2 (#protocol old, #protocol new), dbms = mergeO #2 (#dbms old, #dbms new), sigFile = mergeO #2 (#sigFile old, #sigFile new), - safeGets = #safeGets old @ #safeGets new + safeGets = #safeGets old @ #safeGets new, + onError = mergeO #2 (#onError old, #onError new) } in if accLibs then @@ -631,6 +635,12 @@ fun parseUrp' accLibs fname = (case String.fields (fn ch => ch = #"=") arg of [n, v] => pathmap := M.insert (!pathmap, n, v) | _ => ErrorMsg.error "path argument not of the form name=value'") + | "onError" => + (case String.fields (fn ch => ch = #".") arg of + m1 :: (fs as _ :: _) => + onError := SOME (m1, List.take (fs, length fs - 1), List.last fs) + | _ => ErrorMsg.error "invalid 'onError' argument") + | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); read () end @@ -657,6 +667,7 @@ fun parseUrp' accLibs fname = Option.app Settings.setProtocol (#protocol job); Option.app Settings.setDbms (#dbms job); Settings.setSafeGets (#safeGets job); + Settings.setOnError (#onError job); job end in @@ -709,7 +720,7 @@ structure SS = BinarySetFn(struct end) val parse = { - func = fn {database, sources = fnames, ffi, ...} : job => + func = fn {database, sources = fnames, ffi, onError, ...} : job => let val mrs = !moduleRoots @@ -884,6 +895,10 @@ val parse = { val ds = case database of NONE => ds | SOME s => (Source.DDatabase s, loc) :: ds + + val ds = case onError of + NONE => ds + | SOME v => ds @ [(Source.DOnError v, loc)] in ds end handle Empty => ds diff --git a/src/core.sml b/src/core.sml index e5358f48..6d9e56b6 100644 --- a/src/core.sml +++ b/src/core.sml @@ -136,6 +136,7 @@ datatype decl' = | DStyle of string * int * string | DTask of exp * exp | DPolicy of exp + | DOnError of int withtype decl = decl' located diff --git a/src/core_env.sml b/src/core_env.sml index 478ef495..9a4f9ec7 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -350,6 +350,7 @@ fun declBinds env (d, loc) = end | DTask _ => env | DPolicy _ => env + | DOnError _ => env fun patBinds env (p, loc) = case p of diff --git a/src/core_print.sml b/src/core_print.sml index f18ea4b9..ca8066b3 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -628,6 +628,7 @@ fun p_decl env (dAll as (d, _) : decl) = | DPolicy e1 => box [string "policy", space, p_exp env e1] + | DOnError _ => string "ONERROR" fun p_file env file = let diff --git a/src/core_util.sml b/src/core_util.sml index eedcd2bb..e71d7276 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -997,6 +997,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = fn e' => (DPolicy e', loc)) + | DOnError _ => S.return2 dAll + and mfvi ctx (x, n, t, e, s) = S.bind2 (mfc ctx t, fn t' => @@ -1152,6 +1154,7 @@ fun mapfoldB (all as {bind, ...}) = end | DTask _ => ctx | DPolicy _ => ctx + | DOnError _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -1216,7 +1219,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DCookie (_, n, _, _) => Int.max (n, count) | DStyle (_, n, _) => Int.max (n, count) | DTask _ => count - | DPolicy _ => count) 0 + | DPolicy _ => count + | DOnError _ => count) 0 end diff --git a/src/corify.sml b/src/corify.sml index 88473455..27e6c4c7 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -1083,6 +1083,17 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = | L.DPolicy e1 => ([(L'.DPolicy (corifyExp st e1), loc)], st) + | L.DOnError (m, ms, x) => + let + val st = St.lookupStrById st m + val st = foldl St.lookupStrByName st ms + in + case St.lookupValByName st x of + St.ENormal n => ([(L'.DOnError n, loc)], st) + | _ => (ErrorMsg.errorAt loc "Wrong type of identifier for 'onError'"; + ([], st)) + end + and corifyStr mods ((str, _), st) = case str of L.StrConst ds => @@ -1141,7 +1152,8 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DCookie (_, _, n', _) => Int.max (n, n') | L.DStyle (_, _, n') => Int.max (n, n') | L.DTask _ => n - | L.DPolicy _ => n) + | L.DPolicy _ => n + | L.DOnError _ => n) 0 ds and maxNameStr (str, _) = diff --git a/src/css.sml b/src/css.sml index 31c4b9b1..73f180d9 100644 --- a/src/css.sml +++ b/src/css.sml @@ -288,6 +288,7 @@ fun summarize file = | DStyle (_, n, s) => (IM.insert (globals, n, (SOME s, [])), classes) | DTask _ => st | DPolicy _ => st + | DOnError _ => st end val (globals, classes) = foldl decl (IM.empty, IM.empty) file diff --git a/src/demo.sml b/src/demo.sml index a67411de..358815de 100644 --- a/src/demo.sml +++ b/src/demo.sml @@ -115,7 +115,8 @@ fun make' {prefix, dirname, guided} = protocol = mergeWith #2 (#protocol combined, #protocol urp), dbms = mergeWith #2 (#dbms combined, #dbms urp), sigFile = mergeWith #2 (#sigFile combined, #sigFile urp), - safeGets = [] + safeGets = [], + onError = NONE } val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp") diff --git a/src/elab.sml b/src/elab.sml index e040a059..6d405af6 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -172,6 +172,7 @@ datatype decl' = | DStyle of int * string * int | DTask of exp * exp | DPolicy of exp + | DOnError of int * string list * string and str' = StrConst of decl list diff --git a/src/elab_env.sml b/src/elab_env.sml index bb34c345..16596622 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1633,5 +1633,6 @@ fun declBinds env (d, loc) = end | DTask _ => env | DPolicy _ => env + | DOnError _ => env end diff --git a/src/elab_print.sml b/src/elab_print.sml index 42a0a107..4fb7ee73 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -816,6 +816,7 @@ fun p_decl env (dAll as (d, _) : decl) = | DPolicy e1 => box [string "policy", space, p_exp env e1] + | DOnError _ => string "ONERROR" and p_str env (str, _) = case str of diff --git a/src/elab_util.sml b/src/elab_util.sml index ec6c51ba..ccfb86a3 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -883,7 +883,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f | DStyle (tn, x, n) => bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))) | DTask _ => ctx - | DPolicy _ => ctx, + | DPolicy _ => ctx + | DOnError _ => ctx, mfd ctx d)) ctx ds, fn ds' => (StrConst ds', loc)) | StrVar _ => S.return2 strAll @@ -1018,6 +1019,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f S.map2 (mfe ctx e1, fn e1' => (DPolicy e1', loc)) + | DOnError _ => S.return2 dAll and mfvi ctx (x, n, c, e) = S.bind2 (mfc ctx c, @@ -1162,6 +1164,7 @@ and maxNameDecl (d, _) = | DStyle (n1, _, n2) => Int.max (n1, n2) | DTask _ => 0 | DPolicy _ => 0 + | DOnError _ => 0 and maxNameStr (str, _) = case str of StrConst ds => maxName ds diff --git a/src/elaborate.sml b/src/elaborate.sml index 505699bd..e7848f21 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2679,6 +2679,7 @@ and sgiOfDecl (d, loc) = | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)] | L'.DTask _ => [] | L'.DPolicy _ => [] + | L'.DOnError _ => [] and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), @@ -3858,6 +3859,32 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = ([(L'.DPolicy e1', loc)], (env, denv, gs1 @ gs)) end + | L.DOnError (m1, ms, s) => + (case E.lookupStr env m1 of + NONE => (expError env (UnboundStrInExp (loc, m1)); + ([], (env, denv, []))) + | SOME (n, sgn) => + let + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => (conError env (UnboundStrInCon (loc, m)); + (strerror, sgnerror)) + | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) + ((L'.StrVar n, loc), sgn) ms + + val t = case E.projectVal env {sgn = sgn, str = str, field = s} of + NONE => (expError env (UnboundExp (loc, s)); + cerror) + | SOME t => t + + val page = (L'.CModProj (!basis_r, [], "page"), loc) + val xpage = (L'.CApp ((L'.CModProj (!basis_r, [], "transaction"), loc), page), loc) + val func = (L'.TFun ((L'.CModProj (!basis_r, [], "xbody"), loc), xpage), loc) + in + unifyCons env loc t func; + ([(L'.DOnError (n, ms, s), loc)], (env, denv, gs)) + end) + (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) in (*prefaces "/elabDecl" [("d", SourcePrint.p_decl dAll)];*) diff --git a/src/expl.sml b/src/expl.sml index 1212383f..119c1d92 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -149,6 +149,7 @@ datatype decl' = | DStyle of int * string * int | DTask of exp * exp | DPolicy of exp + | DOnError of int * string list * string and str' = StrConst of decl list diff --git a/src/expl_env.sml b/src/expl_env.sml index 9abe7099..f5a5eb0a 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -345,6 +345,7 @@ fun declBinds env (d, loc) = end | DTask _ => env | DPolicy _ => env + | DOnError _ => env fun sgiBinds env (sgi, loc) = case sgi of diff --git a/src/expl_print.sml b/src/expl_print.sml index 5a914194..d89b0512 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -730,6 +730,7 @@ fun p_decl env (dAll as (d, _) : decl) = | DPolicy e1 => box [string "policy", space, p_exp env e1] + | DOnError _ => string "ONERROR" and p_str env (str, _) = case str of diff --git a/src/explify.sml b/src/explify.sml index 0013906f..4f4f83e1 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008-2010, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -197,6 +197,7 @@ fun explifyDecl (d, loc : EM.span) = | L.DStyle (nt, x, n) => SOME (L'.DStyle (nt, x, n), loc) | L.DTask (e1, e2) => SOME (L'.DTask (explifyExp e1, explifyExp e2), loc) | L.DPolicy e1 => SOME (L'.DPolicy (explifyExp e1), loc) + | L.DOnError v => SOME (L'.DOnError v, loc) and explifyStr (str, loc) = case str of diff --git a/src/mono.sml b/src/mono.sml index 554b1dc5..1d446dda 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -151,6 +151,7 @@ datatype decl' = | DTask of exp * exp | DPolicy of policy + | DOnError of int withtype decl = decl' located diff --git a/src/mono_env.sml b/src/mono_env.sml index 87f96488..1df38db3 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -131,6 +131,7 @@ fun declBinds env (d, loc) = | DStyle _ => env | DTask _ => env | DPolicy _ => env + | DOnError _ => env fun patBinds env (p, loc) = case p of diff --git a/src/mono_print.sml b/src/mono_print.sml index c3f2866e..63c98f44 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -527,7 +527,7 @@ fun p_decl env (dAll as (d, _) : decl) = | DPolicy p => box [string "policy", space, p_policy env p] - + | DOnError _ => string "ONERROR" fun p_file env file = let diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 50c4b387..d8baf07e 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -70,6 +70,7 @@ fun shake file = in usedVars st e1 end + | ((DOnError n, _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n)) | (_, st) => st) (IS.empty, IS.empty) file val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) => @@ -87,7 +88,8 @@ fun shake file = | ((DCookie _, _), acc) => acc | ((DStyle _, _), acc) => acc | ((DTask _, _), acc) => acc - | ((DPolicy _, _), acc) => acc) + | ((DPolicy _, _), acc) => acc + | ((DOnError _, _), acc) => acc) (IM.empty, IM.empty) file fun typ (c, s) = @@ -155,7 +157,8 @@ fun shake file = | (DCookie _, _) => true | (DStyle _, _) => true | (DTask _, _) => true - | (DPolicy _, _) => true) file + | (DPolicy _, _) => true + | (DOnError _, _) => true) file end end diff --git a/src/mono_util.sml b/src/mono_util.sml index 8a567e83..d75b8300 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -538,6 +538,7 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = S.map2 (mfpol ctx pol, fn p' => (DPolicy p', loc)) + | DOnError _ => S.return2 dAll and mfpol ctx pol = case pol of @@ -644,6 +645,7 @@ fun mapfoldB (all as {bind, ...}) = | DStyle _ => ctx | DTask _ => ctx | DPolicy _ => ctx + | DOnError _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -698,7 +700,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DCookie _ => count | DStyle _ => count | DTask _ => count - | DPolicy _ => count) 0 + | DPolicy _ => count + | DOnError _ => count) 0 end diff --git a/src/monoize.sml b/src/monoize.sml index 07e69834..bd5787b4 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3962,6 +3962,9 @@ fun monoDecl (env, fm) (all as (d, loc)) = in SOME (env, fm, ps) end + | L.DOnError n => SOME (env, + fm, + [(L'.DOnError n, loc)]) end datatype expungable = Client | Channel diff --git a/src/prepare.sml b/src/prepare.sml index 81de2fa7..4d81940f 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -331,6 +331,7 @@ fun prepDecl (d as (_, loc), st) = in ((DTask (tk, e), loc), st) end + | DOnError _ => (d, st) fun prepare (ds, ps) = let diff --git a/src/reduce.sml b/src/reduce.sml index 36c9f44e..7a962926 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -803,6 +803,7 @@ fun reduce file = namedC, namedE)) end + | DOnError _ => (d, st) val (file, _) = ListUtil.foldlMap doDecl (IS.empty, IM.empty, IM.empty) file in diff --git a/src/reduce_local.sml b/src/reduce_local.sml index cfa6bfd8..0e87e34a 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -378,6 +378,7 @@ fun reduce file = | DStyle _ => d | DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc) | DPolicy e1 => (DPolicy (exp [] e1), loc) + | DOnError _ => d in map doDecl file end diff --git a/src/settings.sig b/src/settings.sig index 51d06902..3ebf9300 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -206,4 +206,6 @@ signature SETTINGS = sig val setSafeGets : string list -> unit val isSafeGet : string -> bool + val setOnError : (string * string list * string) option -> unit + val getOnError : unit -> (string * string list * string) option end diff --git a/src/settings.sml b/src/settings.sml index af16f9ca..5da1a24e 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -486,4 +486,8 @@ val safeGet = ref SS.empty fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls) fun isSafeGet x = SS.member (!safeGet, x) +val onError = ref (NONE : (string * string list * string) option) +fun setOnError x = onError := x +fun getOnError () = !onError + end diff --git a/src/shake.sml b/src/shake.sml index bc81def9..096c31fd 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -101,6 +101,11 @@ fun shake file = st else usedVars st e1 + | ((DOnError n, _), st as (usedE, usedC)) => + if !sliceDb then + st + else + (IS.add (usedE, n), usedC) | (_, acc) => acc) (IS.empty, IS.empty) file val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef) @@ -128,7 +133,8 @@ fun shake file = | ((DStyle (_, n, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], dummyt, dummye))) | ((DTask _, _), acc) => acc - | ((DPolicy _, _), acc) => acc) + | ((DPolicy _, _), acc) => acc + | ((DOnError _, _), acc) => acc) (IM.empty, IM.empty) file fun kind (_, s) = s @@ -216,7 +222,8 @@ fun shake file = | (DCookie _, _) => not (!sliceDb) | (DStyle _, _) => not (!sliceDb) | (DTask _, _) => not (!sliceDb) - | (DPolicy _, _) => not (!sliceDb)) file + | (DPolicy _, _) => not (!sliceDb) + | (DOnError _, _) => not (!sliceDb)) file end end diff --git a/src/source.sml b/src/source.sml index 9768cfc0..b85384ab 100644 --- a/src/source.sml +++ b/src/source.sml @@ -169,6 +169,7 @@ datatype decl' = | DStyle of string | DTask of exp * exp | DPolicy of exp + | DOnError of string * string list * string and str' = StrConst of decl list diff --git a/src/source_print.sml b/src/source_print.sml index 590d15d5..f6218d22 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -672,6 +672,7 @@ fun p_decl ((d, _) : decl) = | DPolicy e1 => box [string "policy", space, p_exp e1] + | DOnError _ => string "ONERROR" and p_str (str, _) = case str of diff --git a/src/unnest.sml b/src/unnest.sml index a2ec32b0..2d6956cb 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -434,6 +434,7 @@ fun unnest file = | DStyle _ => default () | DTask _ => explore () | DPolicy _ => explore () + | DOnError _ => default () end and doStr (all as (str, loc), st) = diff --git a/tests/onerror.ur b/tests/onerror.ur new file mode 100644 index 00000000..9877d8d7 --- /dev/null +++ b/tests/onerror.ur @@ -0,0 +1,4 @@ +fun main n = + case n of + 0 => error Zero is bad! + | _ => return diff --git a/tests/onerror.urp b/tests/onerror.urp new file mode 100644 index 00000000..39d7ac7d --- /dev/null +++ b/tests/onerror.urp @@ -0,0 +1,4 @@ +onError OnerrorE.err + +onerrorE +onerror diff --git a/tests/onerror.urs b/tests/onerror.urs new file mode 100644 index 00000000..38b757ea --- /dev/null +++ b/tests/onerror.urs @@ -0,0 +1 @@ +val main : int -> transaction page diff --git a/tests/onerrorE.ur b/tests/onerrorE.ur new file mode 100644 index 00000000..b2948c71 --- /dev/null +++ b/tests/onerrorE.ur @@ -0,0 +1,5 @@ +fun err x = return +

    Bad thing!

    + + {x} +     -- cgit v1.2.3 From 948aa854af8ca5560a1eea5221c4a1f3a6901970 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 10 Oct 2010 14:41:03 -0400 Subject: Hopeful fix for the Great Unification Bug --- demo/crud.ur | 4 ++-- demo/crud3.ur | 2 +- demo/metaform.ur | 9 ++++---- demo/view.ur | 2 +- src/elab.sml | 2 +- src/elab_env.sig | 2 +- src/elab_env.sml | 40 +++++++++++++++++++++++++---------- src/elab_err.sig | 4 +++- src/elab_err.sml | 12 +++++++++-- src/elab_ops.sig | 2 ++ src/elab_ops.sml | 13 +++++++----- src/elab_print.sml | 11 ++++++---- src/elab_util.sig | 4 +++- src/elab_util.sml | 6 ++++-- src/elaborate.sml | 62 ++++++++++++++++++++++++++++++------------------------ src/explify.sml | 2 +- tests/concat.ur | 13 ++++++++++++ tests/concat.urp | 1 + 18 files changed, 125 insertions(+), 66 deletions(-) create mode 100644 tests/concat.ur create mode 100644 tests/concat.urp (limited to 'src/elab_env.sml') diff --git a/demo/crud.ur b/demo/crud.ur index 2fc82c1b..4d2753ea 100644 --- a/demo/crud.ur +++ b/demo/crud.ur @@ -78,7 +78,7 @@ functor Make(M : sig
    {@foldR [colMeta] [fn cols => xml form [] (map snd cols)] - (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] (col : colMeta t) (acc : xml form [] (map snd rest)) => + (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] (col : colMeta t) acc =>
  • {cdata col.Nam}: {col.Widget [nm]}
    • {useMore acc}     ) @@ -128,7 +128,7 @@ functor Make(M : sig None => return Not found! | Some fs => return {@foldR2 [fst] [colMeta] [fn cols => xml form [] (map snd cols)] - (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] (v : t.1) (col : colMeta t) + (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] v (col : colMeta t) (acc : xml form [] (map snd rest)) =>
  • {cdata col.Nam}: {col.WidgetPopulated [nm] v}
    • diff --git a/demo/crud3.ur b/demo/crud3.ur index c336af30..5be035dd 100644 --- a/demo/crud3.ur +++ b/demo/crud3.ur @@ -20,7 +20,7 @@ open Crud.Make(struct     ), - Parse = (fn p => p.A ^ p.B), + Parse = (fn p : {A : string, B : string} => p.A ^ p.B), Inject = _ } } diff --git a/demo/metaform.ur b/demo/metaform.ur index 729b7d08..c6a6e54b 100644 --- a/demo/metaform.ur +++ b/demo/metaform.ur @@ -15,11 +15,10 @@ functor Make (M : sig fun main () = return {@foldUR [string] [fn cols => xml form [] (mapU string cols)] - (fn [nm :: Name] [rest ::_] [[nm] ~ rest] name - (acc : xml form [] (mapU string rest)) => -
  • {[name]}:
    • - {useMore acc} -     ) + (fn [nm :: Name] [rest ::_] [[nm] ~ rest] name acc => +
  • {[name]}:
    • + {useMore acc} +     ) M.fl M.names} diff --git a/demo/view.ur b/demo/view.ur index 84c179f4..0dcb42fa 100644 --- a/demo/view.ur +++ b/demo/view.ur @@ -1,7 +1,7 @@ table t : { A : int } view v = SELECT t.A AS A FROM t WHERE t.A > 7 -fun list [u] (_ : fieldsOf u [A = int]) (title : string) (x : u) = +fun list [u] (_ : fieldsOf u [A = int]) (title : string) (x : u) : transaction xbody = xml <- queryX (SELECT * FROM x) (fn r : {X : {A : int}} =>
  • {[r.X.A]}
    • ); return diff --git a/src/elab.sml b/src/elab.sml index dcb15502..97acec31 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -78,7 +78,7 @@ datatype con' = | CProj of con * int | CError - | CUnif of ErrorMsg.span * kind * string * con option ref + | CUnif of int * ErrorMsg.span * kind * string * con option ref withtype con = con' located diff --git a/src/elab_env.sig b/src/elab_env.sig index 769fea58..662d7071 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -27,8 +27,8 @@ signature ELAB_ENV = sig - exception SynUnif val liftConInCon : int -> Elab.con -> Elab.con + val mliftConInCon : int -> Elab.con -> Elab.con val liftConInExp : int -> Elab.exp -> Elab.exp val liftExpInExp : int -> Elab.exp -> Elab.exp diff --git a/src/elab_env.sml b/src/elab_env.sml index 16596622..bb731c08 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -43,8 +43,6 @@ exception UnboundNamed of int (* AST utility functions *) -exception SynUnif - val liftKindInKind = U.Kind.mapB {kind = fn bound => fn k => case k of @@ -78,13 +76,32 @@ val liftConInCon = c else CRel (xn + 1) - (*| CUnif _ => raise SynUnif*) + | CUnif (nl, loc, k, s, r) => CUnif (nl+1, loc, k, s, r) | _ => c, bind = fn (bound, U.Con.RelC _) => bound + 1 | (bound, _) => bound} val lift = liftConInCon 0 +fun mliftConInCon by c = + if by = 0 then + c + else + U.Con.mapB {kind = fn _ => fn k => k, + con = fn bound => fn c => + case c of + CRel xn => + if xn < bound then + c + else + CRel (xn + by) + | CUnif (nl, loc, k, s, r) => CUnif (nl+by, loc, k, s, r) + | _ => c, + bind = fn (bound, U.Con.RelC _) => bound + 1 + | (bound, _) => bound} 0 c + +val () = U.mliftConInCon := mliftConInCon + val liftKindInExp = U.Exp.mapB {kind = fn bound => fn k => case k of @@ -108,6 +125,7 @@ val liftConInExp = c else CRel (xn + 1) + | CUnif (nl, loc, k, s, r) => CUnif (nl+1, loc, k, s, r) | _ => c, exp = fn _ => fn e => e, bind = fn (bound, U.Exp.RelC _) => bound + 1 @@ -466,7 +484,7 @@ fun class_name_in (c, _) = case c of CNamed n => SOME (ClNamed n) | CModProj x => SOME (ClProj x) - | CUnif (_, _, _, ref (SOME c)) => class_name_in c + | CUnif (_, _, _, _, ref (SOME c)) => class_name_in c | _ => NONE fun isClass (env : env) c = @@ -480,7 +498,7 @@ fun isClass (env : env) c = fun class_head_in c = case #1 c of CApp (f, _) => class_head_in f - | CUnif (_, _, _, ref (SOME c)) => class_head_in c + | CUnif (_, _, _, _, ref (SOME c)) => class_head_in c | _ => class_name_in c exception Unify @@ -502,8 +520,8 @@ fun unifyKinds (k1, k2) = fun eqCons (c1, c2) = case (#1 c1, #1 c2) of - (CUnif (_, _, _, ref (SOME c1)), _) => eqCons (c1, c2) - | (_, CUnif (_, _, _, ref (SOME c2))) => eqCons (c1, c2) + (CUnif (nl, _, _, _, ref (SOME c1)), _) => eqCons (mliftConInCon nl c1, c2) + | (_, CUnif (nl, _, _, _, ref (SOME c2))) => eqCons (c1, mliftConInCon nl c2) | (CRel n1, CRel n2) => if n1 = n2 then () else raise Unify @@ -545,8 +563,8 @@ fun unifyCons rs = let fun unify d (c1, c2) = case (#1 c1, #1 c2) of - (CUnif (_, _, _, ref (SOME c1)), _) => unify d (c1, c2) - | (_, CUnif (_, _, _, ref (SOME c2))) => unify d (c1, c2) + (CUnif (nl, _, _, _, ref (SOME c1)), _) => unify d (mliftConInCon nl c1, c2) + | (_, CUnif (nl, _, _, _, ref (SOME c2))) => unify d (c1, mliftConInCon nl c2) | (CUnif _, _) => () @@ -633,7 +651,7 @@ fun unifySubst (rs : con list) = exception Bad of con * con val hasUnif = U.Con.exists {kind = fn _ => false, - con = fn CUnif (_, _, _, ref NONE) => true + con = fn CUnif (_, _, _, _, ref NONE) => true | _ => false} fun startsWithUnif c = @@ -670,7 +688,7 @@ fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) = val rk = ref NONE val k = (KUnif (loc, "k", rk), loc) val r = ref NONE - val rc = (CUnif (loc, k, "x", r), loc) + val rc = (CUnif (0, loc, k, "x", r), loc) in ((CApp (f, rc), loc), fn () => (if consEq (rc, x) then diff --git a/src/elab_err.sig b/src/elab_err.sig index f6277488..fbe55a5b 100644 --- a/src/elab_err.sig +++ b/src/elab_err.sig @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008-2010, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -56,6 +56,8 @@ signature ELAB_ERR = sig | CExplicitness of Elab.con * Elab.con | CKindof of Elab.kind * Elab.con * string | CRecordFailure of Elab.con * Elab.con * (Elab.con * Elab.con * Elab.con) option + | TooLifty of ErrorMsg.span * ErrorMsg.span + | TooUnify of Elab.con * Elab.con val cunifyError : ElabEnv.env -> cunify_error -> unit diff --git a/src/elab_err.sml b/src/elab_err.sml index 80de9497..f8a16294 100644 --- a/src/elab_err.sml +++ b/src/elab_err.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008-2010, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -112,7 +112,6 @@ fun conError env err = eprefaces' [("Constructor", p_con env c), ("Kind", p_kind env k)]) - datatype cunify_error = CKind of kind * kind * kunify_error | COccursCheckFailed of con * con @@ -120,6 +119,8 @@ datatype cunify_error = | CExplicitness of con * con | CKindof of kind * con * string | CRecordFailure of con * con * (con * con * con) option + | TooLifty of ErrorMsg.span * ErrorMsg.span + | TooUnify of con * con fun cunifyError env err = case err of @@ -154,6 +155,13 @@ fun cunifyError env err = [("Field", p_con env nm), ("Value 1", p_con env t1), ("Value 2", p_con env t2)])) + | TooLifty (loc1, loc2) => + (ErrorMsg.errorAt loc1 "Can't unify two unification variables that both have suspended liftings"; + eprefaces' [("Other location", Print.PD.string (ErrorMsg.spanToString loc2))]) + | TooUnify (c1, c2) => + (ErrorMsg.errorAt (#2 c1) "Substitution in constructor is blocked by a too-deep unification variable"; + eprefaces' [("Replacement", p_con env c1), + ("Body", p_con env c2)]) datatype exp_error = UnboundExp of ErrorMsg.span * string diff --git a/src/elab_ops.sig b/src/elab_ops.sig index adf69696..ed4c7d68 100644 --- a/src/elab_ops.sig +++ b/src/elab_ops.sig @@ -27,6 +27,8 @@ signature ELAB_OPS = sig + exception SubUnif + val liftKindInKind : int -> Elab.kind -> Elab.kind val subKindInKind : int * Elab.kind -> Elab.kind -> Elab.kind diff --git a/src/elab_ops.sml b/src/elab_ops.sml index 6465668f..15d8e106 100644 --- a/src/elab_ops.sml +++ b/src/elab_ops.sml @@ -97,11 +97,13 @@ fun liftConInCon by = c else CRel (xn + by) - (*| CUnif _ => raise SynUnif*) + | CUnif (nl, loc, k, s, r) => CUnif (nl+by, loc, k, s, r) | _ => c, bind = fn (bound, U.Con.RelC _) => bound + 1 | (bound, _) => bound} +exception SubUnif + fun subConInCon' rep = U.Con.mapB {kind = fn _ => fn k => k, con = fn (by, xn) => fn c => @@ -111,7 +113,8 @@ fun subConInCon' rep = EQUAL => #1 (liftConInCon by 0 rep) | GREATER => CRel (xn' - 1) | LESS => c) - (*| CUnif _ => raise SynUnif*) + | CUnif (0, _, _, _, _) => raise SubUnif + | CUnif (n, loc, k, s, r) => CUnif (n-1, loc, k, s, r) | _ => c, bind = fn ((by, xn), U.Con.RelC _) => (by+1, xn+1) | (ctx, _) => ctx} @@ -153,7 +156,7 @@ fun reset () = (identity := 0; fun hnormCon env (cAll as (c, loc)) = case c of - CUnif (_, _, _, ref (SOME c)) => hnormCon env c + CUnif (nl, _, _, _, ref (SOME c)) => hnormCon env (E.mliftConInCon nl c) | CNamed xn => (case E.lookupCNamed env xn of @@ -276,7 +279,7 @@ fun hnormCon env (cAll as (c, loc)) = let val r = ref NONE in - (r, (CUnif (loc, (KType, loc), "_", r), loc)) + (r, (CUnif (0, loc, (KType, loc), "_", r), loc)) end val (vR, v) = cunif () @@ -284,7 +287,7 @@ fun hnormCon env (cAll as (c, loc)) = val c = (CApp (f, v), loc) in case unconstraint c of - (CUnif (_, _, _, vR'), _) => + (CUnif (_, _, _, _, vR'), _) => if vR' = vR then (inc identity; hnormCon env c2) diff --git a/src/elab_print.sml b/src/elab_print.sml index 279c7231..2b8dc5f4 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -202,10 +202,13 @@ fun p_con' par env (c, _) = string (Int.toString n)] | CError => string "" - | CUnif (_, _, _, ref (SOME c)) => p_con' par env c - | CUnif (_, k, s, _) => box [string (""] + | CUnif (nl, _, _, _, ref (SOME c)) => p_con' par env (E.mliftConInCon nl c) + | CUnif (nl, _, k, s, _) => box [string (" box [] + | _ => string ("+" ^ Int.toString nl), + string ">"] | CKAbs (x, c) => box [string x, space, diff --git a/src/elab_util.sig b/src/elab_util.sig index 934779ff..dc0f25e8 100644 --- a/src/elab_util.sig +++ b/src/elab_util.sig @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008-2010, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -29,6 +29,8 @@ signature ELAB_UTIL = sig val classifyDatatype : (string * int * 'a option) list -> Elab.datatype_kind +val mliftConInCon : (int -> Elab.con -> Elab.con) ref + structure Kind : sig val mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB, bind : 'context * string -> 'context} diff --git a/src/elab_util.sml b/src/elab_util.sml index 33ed599c..d297ccbc 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008-2010, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -118,6 +118,8 @@ fun exists f k = end +val mliftConInCon = ref (fn n : int => fn c : con => (raise Fail "You didn't set ElabUtil.mliftConInCon!") : con) + structure Con = struct datatype binder = @@ -215,7 +217,7 @@ fun mapfoldB {kind = fk, con = fc, bind} = (CProj (c', n), loc)) | CError => S.return2 cAll - | CUnif (_, _, _, ref (SOME c)) => mfc' ctx c + | CUnif (nl, _, _, _, ref (SOME c)) => mfc' ctx (!mliftConInCon nl c) | CUnif _ => S.return2 cAll | CKAbs (x, c) => diff --git a/src/elaborate.sml b/src/elaborate.sml index 2cc01eda..37ca4b25 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -207,7 +207,7 @@ "U" ^ Int.toString (n - 26) in count := n + 1; - (L'.CUnif (loc, k, s, ref NONE), loc) + (L'.CUnif (0, loc, k, s, ref NONE), loc) end end @@ -495,7 +495,7 @@ | _ => false fun cunifsRemain c = case c of - L'.CUnif (loc, _, _, ref NONE) => SOME loc + L'.CUnif (_, loc, _, _, ref NONE) => SOME loc | _ => NONE val kunifsInDecl = U.Decl.exists {kind = kunifsRemain, @@ -516,13 +516,11 @@ fun occursCon r = U.Con.exists {kind = fn _ => false, - con = fn L'.CUnif (_, _, _, r') => r = r' + con = fn L'.CUnif (_, _, _, _, r') => r = r' | _ => false} exception CUnify' of cunify_error - exception SynUnif = E.SynUnif - type record_summary = { fields : (L'.con * L'.con) list, unifs : (L'.con * L'.con option ref) list, @@ -588,7 +586,7 @@ | k => raise CUnify' (CKindof (k, c, "tuple"))) | L'.CError => kerror - | L'.CUnif (_, k, _, _) => k + | L'.CUnif (_, _, k, _, _) => k | L'.CKAbs (x, c) => (L'.KFun (x, kindof (E.pushKRel env x) c), loc) | L'.CKApp (c, k) => @@ -644,7 +642,7 @@ | k => raise CUnify' (CKindof (k, c, "tuple")))*) | L'.CError => false - | L'.CUnif (_, k, _, _) => #1 k = L'.KUnit + | L'.CUnif (_, _, k, _, _) => #1 k = L'.KUnit | L'.CKAbs _ => false | L'.CKApp _ => false @@ -701,8 +699,8 @@ unifs = #unifs s1 @ #unifs s2, others = #others s1 @ #others s2} end - | (L'.CUnif (_, _, _, ref (SOME c)), _) => recordSummary env c - | c' as (L'.CUnif (_, _, _, r), _) => {fields = [], unifs = [(c', r)], others = []} + | (L'.CUnif (nl, _, _, _, ref (SOME c)), _) => recordSummary env (E.mliftConInCon nl c) + | c' as (L'.CUnif (0, _, _, _, r), _) => {fields = [], unifs = [(c', r)], others = []} | c' => {fields = [], unifs = [], others = [c']} in sum @@ -735,8 +733,8 @@ and unifySummaries env (loc, k, s1 : record_summary, s2 : record_summary) = let (*val () = eprefaces "Summaries" [("loc", PD.string (ErrorMsg.spanToString loc)), - ("#1", p_summary env s1), - ("#2", p_summary env s2)]*) + ("#1", p_summary env s1), + ("#2", p_summary env s2)]*) fun eatMatching p (ls1, ls2) = let @@ -922,7 +920,7 @@ unfold (r2, c2'); unifyCons env loc r (L'.CConcat (r1, r2), loc) end - | L'.CUnif (_, _, _, ur) => + | L'.CUnif (0, _, _, _, ur) => ur := SOME (L'.CApp ((L'.CApp ((L'.CMap (dom, ran), loc), f), loc), r), loc) | _ => raise ex in @@ -970,7 +968,7 @@ onFail () in case #1 (hnormCon env c2) of - L'.CUnif (_, k, _, r) => + L'.CUnif (0, _, k, _, r) => (case #1 (hnormKind k) of L'.KTuple ks => let @@ -986,7 +984,7 @@ | _ => onFail () in case #1 (hnormCon env c1) of - L'.CUnif (_, k, _, r) => + L'.CUnif (0, _, k, _, r) => (case #1 (hnormKind k) of L'.KTuple ks => let @@ -1002,7 +1000,7 @@ fun projSpecial2 (c2, n2, onFail) = case #1 (hnormCon env c2) of - L'.CUnif (_, k, _, r) => + L'.CUnif (0, _, k, _, r) => (case #1 (hnormKind k) of L'.KTuple ks => let @@ -1035,19 +1033,24 @@ | (L'.CConcat _, _) => isRecord () | (_, L'.CConcat _) => isRecord () - | (L'.CUnif (_, k1, _, r1), L'.CUnif (_, k2, _, r2)) => - if r1 = r2 then + | (L'.CUnif (nl1, loc1, k1, _, r1), L'.CUnif (nl2, loc2, k2, _, r2)) => + if r1 = r2 andalso nl1 = nl2 then () - else + else if nl1 = 0 then (unifyKinds env k1 k2; r1 := SOME c2All) + else if nl2 = 0 then + (unifyKinds env k1 k2; + r2 := SOME c2All) + else + err (fn _ => TooLifty (loc1, loc2)) - | (L'.CUnif (_, _, _, r), _) => + | (L'.CUnif (0, _, _, _, r), _) => if occursCon r c2All then err COccursCheckFailed else r := SOME c2All - | (_, L'.CUnif (_, _, _, r)) => + | (_, L'.CUnif (0, _, _, _, r)) => if occursCon r c1All then err COccursCheckFailed else @@ -1167,6 +1170,11 @@ | _ => false) | _ => false + fun subConInCon env x y = + ElabOps.subConInCon x y + handle SubUnif => (cunifyError env (TooUnify (#2 x, y)); + cerror) + fun elabHead (env, denv) infer (e as (_, loc)) t = let fun unravelKind (t, e) = @@ -1195,7 +1203,7 @@ let val u = cunif (loc, k) - val t'' = subConInCon (0, u) t' + val t'' = subConInCon env (0, u) t' in unravel (t'', (L'.ECApp (e, u), loc)) end @@ -1282,7 +1290,7 @@ fun elabPat (pAll as (p, loc), (env, bound)) = val k = (L'.KType, loc) val unifs = map (fn _ => cunif (loc, k)) xs val nxs = length unifs - 1 - val t = ListUtil.foldli (fn (i, u, t) => subConInCon (nxs - i, u) t) t unifs + val t = ListUtil.foldli (fn (i, u, t) => subConInCon env (nxs - i, u) t) t unifs val dn = foldl (fn (u, dn) => (L'.CApp (dn, u), loc)) dn unifs in ignore (checkPatCon env p' pt t); @@ -1469,7 +1477,7 @@ fun exhaustive (env, t, ps, loc) = val (t1, args) = unapp (hnormCon env q1, []) val t1 = hnormCon env t1 - fun doSub t = foldl (fn (arg, t) => subConInCon (0, arg) t) t args + fun doSub t = foldl (fn (arg, t) => subConInCon env (0, arg) t) t args fun dtype (dtO, names) = let @@ -1653,7 +1661,7 @@ fun normClassConstraint env (c, loc) = (L'.TFun (c1, c2), loc) end | L'.TCFun (expl, x, k, c1) => (L'.TCFun (expl, x, k, normClassConstraint env c1), loc) - | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint env c + | L'.CUnif (nl, _, _, _, ref (SOME c)) => normClassConstraint env (E.mliftConInCon nl c) | _ => unmodCon env (c, loc) fun findHead e e' = @@ -1863,9 +1871,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) = | L'.TCFun (_, x, k, eb) => let val () = checkKind env c' ck k - val eb' = subConInCon (0, c') eb - handle SynUnif => (expError env (Unif ("substitution", loc, eb)); - cerror) + val eb' = subConInCon env (0, c') eb val ef = (L'.ECApp (e', c'), loc) val (ef, eb', gs3) = @@ -3303,7 +3309,7 @@ and wildifyStr env (str, sgn) = (SOME c1, SOME c2) => SOME (L.CConcat (c1, c2), loc) | _ => NONE) | L'.CUnit => SOME (L.CUnit, loc) - | L'.CUnif (_, _, _, ref (SOME c)) => decompileCon env c + | L'.CUnif (nl, _, _, _, ref (SOME c)) => decompileCon env (E.mliftConInCon nl c) | _ => NONE diff --git a/src/explify.sml b/src/explify.sml index cf6c491c..5081d33b 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -76,7 +76,7 @@ fun explifyCon (c, loc) = | L.CProj (c, n) => (L'.CProj (explifyCon c, n), loc) | L.CError => raise Fail ("explifyCon: CError at " ^ EM.spanToString loc) - | L.CUnif (_, _, _, ref (SOME c)) => explifyCon c + | L.CUnif (nl, _, _, _, ref (SOME c)) => explifyCon (ElabEnv.mliftConInCon nl c) | L.CUnif _ => raise Fail ("explifyCon: CUnif at " ^ EM.spanToString loc) | L.CKAbs (x, c) => (L'.CKAbs (x, explifyCon c), loc) diff --git a/tests/concat.ur b/tests/concat.ur new file mode 100644 index 00000000..1330a21d --- /dev/null +++ b/tests/concat.ur @@ -0,0 +1,13 @@ +functor Make(M : sig + con ts :: {(Type * Type)} + val tab : sql_table (map fst ts) [] + val cols : $(map (fn p => p.2 -> string) ts) + end) = struct +end + +table t : {A : string} + +open Make(struct + val tab = t + val cols = {A = fn p : {B : string, C : string} => p.B ^ p.C} + end) diff --git a/tests/concat.urp b/tests/concat.urp new file mode 100644 index 00000000..442b05b4 --- /dev/null +++ b/tests/concat.urp @@ -0,0 +1 @@ +concat -- cgit v1.2.3 From 83f86225d56718fae1f226202efda9d69a5c369f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 2 Dec 2010 12:24:09 -0500 Subject: More hnorm during type class resolution --- src/elab_env.sml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'src/elab_env.sml') diff --git a/src/elab_env.sml b/src/elab_env.sml index bb731c08..6516f7aa 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -559,10 +559,10 @@ fun eqCons (c1, c2) = | _ => raise Unify -fun unifyCons rs = +fun unifyCons (hnorm : con -> con) rs = let fun unify d (c1, c2) = - case (#1 c1, #1 c2) of + case (#1 (hnorm c1), #1 (hnorm c2)) of (CUnif (nl, _, _, _, ref (SOME c1)), _) => unify d (mliftConInCon nl c1, c2) | (_, CUnif (nl, _, _, _, ref (SOME c2))) => unify d (c1, mliftConInCon nl c2) @@ -623,11 +623,11 @@ fun unifyCons rs = unify end -fun tryUnify nRs (c1, c2) = +fun tryUnify hnorm nRs (c1, c2) = let val rs = List.tabulate (nRs, fn _ => ref NONE) in - (unifyCons rs 0 (c1, c2); + (unifyCons hnorm rs 0 (c1, c2); SOME (map (fn r => case !r of NONE => raise Unify | SOME c => c) rs)) @@ -712,7 +712,7 @@ fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) = case rules of [] => NONE | (nRs, cs, c', e) :: rules' => - case tryUnify nRs (c, c') of + case tryUnify hnorm nRs (c, c') of NONE => tryRules rules' | SOME rs => let @@ -739,7 +739,7 @@ fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) = case ces of [] => rules () | (c', e) :: ces' => - case tryUnify 0 (c, c') of + case tryUnify hnorm 0 (c, c') of NONE => tryGrounds ces' | SOME _ => SOME e in -- cgit v1.2.3 From 07c4bf822d9d94ea15f4a6ae5a4a2e1edd52e05e Mon Sep 17 00:00:00 2001 From: Karn Kallio Date: Mon, 25 Apr 2011 23:11:21 -0530 Subject: Fix for projection of type class constructors in signatures. --- src/elab_env.sml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/elab_env.sml') diff --git a/src/elab_env.sml b/src/elab_env.sml index 6516f7aa..3217669c 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1381,11 +1381,11 @@ fun projectCon env {sgn, str, field} = else NONE | SgiClassAbs (x, _, k) => if x = field then - SOME ((KArrow (k, (KType, #2 sgn)), #2 sgn), NONE) + SOME (k, NONE) else NONE | SgiClass (x, _, k, c) => if x = field then - SOME ((KArrow (k, (KType, #2 sgn)), #2 sgn), SOME c) + SOME (k, SOME c) else NONE | _ => NONE) sgis of -- cgit v1.2.3 From b25211f8bdd3c17b9d56158a8c71712f2ed20f63 Mon Sep 17 00:00:00 2001 From: Karn Kallio Date: Sat, 30 Apr 2011 23:26:08 -0530 Subject: Fix bug in projection of constructors from modules in class rules. --- src/elab_env.sml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/elab_env.sml') diff --git a/src/elab_env.sml b/src/elab_env.sml index 3217669c..23f3df01 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1043,8 +1043,8 @@ fun sgnS_con' (m1, ms', (sgns, strs, cons)) = U.Con.map {kind = fn x => x, con = fn c => case c of - CModProj (m1, ms, x) => - (case IM.find (strs, m1) of + CModProj (m1', ms, x) => + (case IM.find (strs, m1') of NONE => c | SOME m1x => CModProj (m1, ms' @ m1x :: ms, x)) | CNamed n => -- cgit v1.2.3 From 8a2f6e7bf923bc145cb85a5ed5cc34daa0f7d664 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 15 Oct 2011 10:19:50 -0400 Subject: Improved unification of record literals in type class resolution --- src/elab_env.sml | 20 ++++++++++++++++---- tests/tcrec.ur | 5 +++++ 2 files changed, 21 insertions(+), 4 deletions(-) create mode 100644 tests/tcrec.ur (limited to 'src/elab_env.sml') diff --git a/src/elab_env.sml b/src/elab_env.sml index 23f3df01..e53c1538 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -545,8 +545,14 @@ fun eqCons (c1, c2) = | (CRecord (k1, xcs1), CRecord (k2, xcs2)) => (unifyKinds (k1, k2); - ListPair.appEq (fn ((x1, c1), (x2, c2)) => (eqCons (x1, x2); eqCons (c1, c2))) (xcs1, xcs2) - handle ListPair.UnequalLengths => raise Unify) + if length xcs1 <> length xcs2 then + raise Unify + else + List.app (fn (x1, c1) => + if List.exists (fn (x2, c2) => (eqCons (x1, x2); eqCons (c1, c2); true) handle Unify => false) xcs2 then + () + else + raise Unify) xcs1) | (CConcat (f1, x1), CConcat (f2, x2)) => (eqCons (f1, f2); eqCons (x1, x2)) | (CMap (d1, r1), CMap (d2, r2)) => (unifyKinds (d1, d2); unifyKinds (r1, r2)) @@ -606,8 +612,14 @@ fun unifyCons (hnorm : con -> con) rs = | (CRecord (k1, xcs1), CRecord (k2, xcs2)) => (unifyKinds (k1, k2); - ListPair.appEq (fn ((x1, c1), (x2, c2)) => (unify d (x1, x2); unify d (c1, c2))) (xcs1, xcs2) - handle ListPair.UnequalLengths => raise Unify) + if length xcs1 <> length xcs2 then + raise Unify + else + app (fn (x1, c1) => + if List.exists (fn (x2, c2) => (unify d (x1, x2); unify d (c1, c2); true) handle Unify => false) xcs2 then + () + else + raise Unify) xcs1) | (CConcat (f1, x1), CConcat (f2, x2)) => (unify d (f1, f2); unify d (x1, x2)) | (CMap (d1, r1), CMap (d2, r2)) => (unifyKinds (d1, d2); unifyKinds (r1, r2)) diff --git a/tests/tcrec.ur b/tests/tcrec.ur new file mode 100644 index 00000000..3d3e6e64 --- /dev/null +++ b/tests/tcrec.ur @@ -0,0 +1,5 @@ +type r1 = {A : string, B : string} +type r2 = {B : string, A : string} + +val show_r1 : show r1 = mkShow (fn r => r.A ^ "+" ^ r.B) +val show_r2 : show r2 = _ -- cgit v1.2.3 From 4eb93836d04d18f43d8c4360f290a7977d96c468 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 18 Dec 2011 11:29:13 -0500 Subject: Add a new scoping check for unification variables, to fix a type inference bug --- src/elab.sml | 16 ++- src/elab_env.sml | 22 +-- src/elab_err.sig | 2 + src/elab_err.sml | 11 +- src/elab_ops.sml | 4 +- src/elab_print.sml | 6 +- src/elab_util.sig | 7 + src/elab_util.sml | 19 ++- src/elaborate.sml | 398 ++++++++++++++++++++++++++++++++--------------------- src/explify.sml | 6 +- tests/capture.ur | 4 + tests/rcapture.ur | 3 + 12 files changed, 317 insertions(+), 181 deletions(-) create mode 100644 tests/capture.ur create mode 100644 tests/rcapture.ur (limited to 'src/elab_env.sml') diff --git a/src/elab.sml b/src/elab.sml index c042d916..15365951 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2010, Adam Chlipala +(* Copyright (c) 2008-2011, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -38,12 +38,16 @@ datatype kind' = | KTuple of kind list | KError - | KUnif of ErrorMsg.span * string * kind option ref - | KTupleUnif of ErrorMsg.span * (int * kind) list * kind option ref + | KUnif of ErrorMsg.span * string * kunif ref + | KTupleUnif of ErrorMsg.span * (int * kind) list * kunif ref | KRel of int | KFun of string * kind +and kunif = + KUnknown of kind -> bool (* Is the kind a valid unification? *) + | KKnown of kind + withtype kind = kind' located datatype explicitness = @@ -78,7 +82,11 @@ datatype con' = | CProj of con * int | CError - | CUnif of int * ErrorMsg.span * kind * string * con option ref + | CUnif of int * ErrorMsg.span * kind * string * cunif ref + +and cunif = + Unknown of con -> bool (* Is the constructor a valid unification? *) + | Known of con withtype con = con' located diff --git a/src/elab_env.sml b/src/elab_env.sml index e53c1538..ed96782e 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -484,7 +484,7 @@ fun class_name_in (c, _) = case c of CNamed n => SOME (ClNamed n) | CModProj x => SOME (ClProj x) - | CUnif (_, _, _, _, ref (SOME c)) => class_name_in c + | CUnif (_, _, _, _, ref (Known c)) => class_name_in c | _ => NONE fun isClass (env : env) c = @@ -498,7 +498,7 @@ fun isClass (env : env) c = fun class_head_in c = case #1 c of CApp (f, _) => class_head_in f - | CUnif (_, _, _, _, ref (SOME c)) => class_head_in c + | CUnif (_, _, _, _, ref (Known c)) => class_head_in c | _ => class_name_in c exception Unify @@ -512,16 +512,16 @@ fun unifyKinds (k1, k2) = | (KUnit, KUnit) => () | (KTuple ks1, KTuple ks2) => (ListPair.appEq unifyKinds (ks1, ks2) handle ListPair.UnequalLengths => raise Unify) - | (KUnif (_, _, ref (SOME k1)), _) => unifyKinds (k1, k2) - | (_, KUnif (_, _, ref (SOME k2))) => unifyKinds (k1, k2) + | (KUnif (_, _, ref (KKnown k1)), _) => unifyKinds (k1, k2) + | (_, KUnif (_, _, ref (KKnown k2))) => unifyKinds (k1, k2) | (KRel n1, KRel n2) => if n1 = n2 then () else raise Unify | (KFun (_, k1), KFun (_, k2)) => unifyKinds (k1, k2) | _ => raise Unify fun eqCons (c1, c2) = case (#1 c1, #1 c2) of - (CUnif (nl, _, _, _, ref (SOME c1)), _) => eqCons (mliftConInCon nl c1, c2) - | (_, CUnif (nl, _, _, _, ref (SOME c2))) => eqCons (c1, mliftConInCon nl c2) + (CUnif (nl, _, _, _, ref (Known c1)), _) => eqCons (mliftConInCon nl c1, c2) + | (_, CUnif (nl, _, _, _, ref (Known c2))) => eqCons (c1, mliftConInCon nl c2) | (CRel n1, CRel n2) => if n1 = n2 then () else raise Unify @@ -569,8 +569,8 @@ fun unifyCons (hnorm : con -> con) rs = let fun unify d (c1, c2) = case (#1 (hnorm c1), #1 (hnorm c2)) of - (CUnif (nl, _, _, _, ref (SOME c1)), _) => unify d (mliftConInCon nl c1, c2) - | (_, CUnif (nl, _, _, _, ref (SOME c2))) => unify d (c1, mliftConInCon nl c2) + (CUnif (nl, _, _, _, ref (Known c1)), _) => unify d (mliftConInCon nl c1, c2) + | (_, CUnif (nl, _, _, _, ref (Known c2))) => unify d (c1, mliftConInCon nl c2) | (CUnif _, _) => () @@ -663,7 +663,7 @@ fun unifySubst (rs : con list) = exception Bad of con * con val hasUnif = U.Con.exists {kind = fn _ => false, - con = fn CUnif (_, _, _, _, ref NONE) => true + con = fn CUnif (_, _, _, _, ref (Unknown _)) => true | _ => false} fun startsWithUnif c = @@ -697,9 +697,9 @@ fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) = fun isRecord () = let - val rk = ref NONE + val rk = ref (KUnknown (fn _ => true)) val k = (KUnif (loc, "k", rk), loc) - val r = ref NONE + val r = ref (Unknown (fn _ => true)) val rc = (CUnif (0, loc, k, "x", r), loc) in ((CApp (f, rc), loc), diff --git a/src/elab_err.sig b/src/elab_err.sig index a66cf61f..14133d08 100644 --- a/src/elab_err.sig +++ b/src/elab_err.sig @@ -35,6 +35,7 @@ signature ELAB_ERR = sig datatype kunify_error = KOccursCheckFailed of Elab.kind * Elab.kind | KIncompatible of Elab.kind * Elab.kind + | KScope of Elab.kind * Elab.kind val kunifyError : ElabEnv.env -> kunify_error -> unit @@ -59,6 +60,7 @@ signature ELAB_ERR = sig | TooLifty of ErrorMsg.span * ErrorMsg.span | TooUnify of Elab.con * Elab.con | TooDeep + | CScope of Elab.con * Elab.con val cunifyError : ElabEnv.env -> cunify_error -> unit diff --git a/src/elab_err.sml b/src/elab_err.sml index 84c8c61f..2bf059e6 100644 --- a/src/elab_err.sml +++ b/src/elab_err.sml @@ -63,6 +63,7 @@ fun kindError env err = datatype kunify_error = KOccursCheckFailed of kind * kind | KIncompatible of kind * kind + | KScope of kind * kind fun kunifyError env err = case err of @@ -74,7 +75,10 @@ fun kunifyError env err = eprefaces "Incompatible kinds" [("Kind 1", p_kind env k1), ("Kind 2", p_kind env k2)] - + | KScope (k1, k2) => + eprefaces "Scoping prevents kind unification" + [("Kind 1", p_kind env k1), + ("Kind 2", p_kind env k2)] fun p_con env c = P.p_con env (simplCon env c) @@ -122,6 +126,7 @@ datatype cunify_error = | TooLifty of ErrorMsg.span * ErrorMsg.span | TooUnify of con * con | TooDeep + | CScope of con * con fun cunifyError env err = case err of @@ -167,6 +172,10 @@ fun cunifyError env err = eprefaces' [("Replacement", p_con env c1), ("Body", p_con env c2)]) | TooDeep => ErrorMsg.error "Can't reverse-engineer unification variable lifting" + | CScope (c1, c2) => + eprefaces "Scoping prevents constructor unification" + [("Have", p_con env c1), + ("Need", p_con env c2)] datatype exp_error = UnboundExp of ErrorMsg.span * string diff --git a/src/elab_ops.sml b/src/elab_ops.sml index 0af2f4e7..dc9f69a4 100644 --- a/src/elab_ops.sml +++ b/src/elab_ops.sml @@ -156,7 +156,7 @@ fun reset () = (identity := 0; fun hnormCon env (cAll as (c, loc)) = case c of - CUnif (nl, _, _, _, ref (SOME c)) => (#1 (hnormCon env (E.mliftConInCon nl c)), loc) + CUnif (nl, _, _, _, ref (Known c)) => (#1 (hnormCon env (E.mliftConInCon nl c)), loc) | CNamed xn => (case E.lookupCNamed env xn of @@ -277,7 +277,7 @@ fun hnormCon env (cAll as (c, loc)) = let fun cunif () = let - val r = ref NONE + val r = ref (Unknown (fn _ => true)) in (r, (CUnif (0, loc, (KType, loc), "_", r), loc)) end diff --git a/src/elab_print.sml b/src/elab_print.sml index 2b8dc5f4..d292d7c5 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -54,9 +54,9 @@ fun p_kind' par env (k, _) = string ")"] | KError => string "" - | KUnif (_, _, ref (SOME k)) => p_kind' par env k + | KUnif (_, _, ref (KKnown k)) => p_kind' par env k | KUnif (_, s, _) => string ("") - | KTupleUnif (_, _, ref (SOME k)) => p_kind' par env k + | KTupleUnif (_, _, ref (KKnown k)) => p_kind' par env k | KTupleUnif (_, nks, _) => box [string "(", p_list_sep (box [space, string "*", space]) (fn (n, k) => box [string (Int.toString n ^ ":"), @@ -202,7 +202,7 @@ fun p_con' par env (c, _) = string (Int.toString n)] | CError => string "" - | CUnif (nl, _, _, _, ref (SOME c)) => p_con' par env (E.mliftConInCon nl c) + | CUnif (nl, _, _, _, ref (Known c)) => p_con' par env (E.mliftConInCon nl c) | CUnif (nl, _, k, s, _) => box [string (" Elab.kind', con : Elab.con' -> Elab.con'} -> Elab.con -> Elab.con + val appB : {kind : 'context -> Elab.kind' -> unit, + con : 'context -> Elab.con' -> unit, + bind : 'context * binder -> 'context} + -> 'context -> (Elab.con -> unit) + val app : {kind : Elab.kind' -> unit, + con : Elab.con' -> unit} + -> Elab.con -> unit val existsB : {kind : 'context * Elab.kind' -> bool, con : 'context * Elab.con' -> bool, bind : 'context * binder -> 'context} diff --git a/src/elab_util.sml b/src/elab_util.sml index bf0185b1..df78616a 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -75,10 +75,10 @@ fun mapfoldB {kind, bind} = | KError => S.return2 kAll - | KUnif (_, _, ref (SOME k)) => mfk' ctx k + | KUnif (_, _, ref (KKnown k)) => mfk' ctx k | KUnif _ => S.return2 kAll - | KTupleUnif (_, _, ref (SOME k)) => mfk' ctx k + | KTupleUnif (_, _, ref (KKnown k)) => mfk' ctx k | KTupleUnif (loc, nks, r) => S.map2 (ListUtil.mapfold (fn (n, k) => S.map2 (mfk ctx k, @@ -217,7 +217,7 @@ fun mapfoldB {kind = fk, con = fc, bind} = (CProj (c', n), loc)) | CError => S.return2 cAll - | CUnif (nl, _, _, _, ref (SOME c)) => mfc' ctx (!mliftConInCon nl c) + | CUnif (nl, _, _, _, ref (Known c)) => mfc' ctx (!mliftConInCon nl c) | CUnif _ => S.return2 cAll | CKAbs (x, c) => @@ -256,6 +256,19 @@ fun map {kind, con} s = S.Return () => raise Fail "ElabUtil.Con.map: Impossible" | S.Continue (s, ()) => s +fun appB {kind, con, bind} ctx c = + case mapfoldB {kind = fn ctx => fn k => fn () => (kind ctx k; S.Continue (k, ())), + con = fn ctx => fn c => fn () => (con ctx c; S.Continue (c, ())), + bind = bind} ctx c () of + S.Continue _ => () + | S.Return _ => raise Fail "ElabUtil.Con.appB: Impossible" + +fun app {kind, con} s = + case mapfold {kind = fn k => fn () => (kind k; S.Continue (k, ())), + con = fn c => fn () => (con c; S.Continue (c, ()))} s () of + S.Return () => raise Fail "ElabUtil.Con.app: Impossible" + | S.Continue _ => () + fun existsB {kind, con, bind} ctx c = case mapfoldB {kind = fn ctx => fn k => fn () => if kind (ctx, k) then diff --git a/src/elaborate.sml b/src/elaborate.sml index a1da9feb..34cb12b8 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -63,6 +63,29 @@ U.Kind.exists (fn L'.KUnif (_, _, r') => r = r' | _ => false) + fun validateCon env c = + (U.Con.appB {kind = fn env' => fn k => case k of + L'.KRel n => ignore (E.lookupKRel env' n) + | L'.KUnif (_, _, r as ref (L'.KUnknown f)) => + r := L'.KUnknown (fn k => f k andalso validateKind env' k) + | _ => (), + con = fn env' => fn c => case c of + L'.CRel n => ignore (E.lookupCRel env' n) + | L'.CNamed n => ignore (E.lookupCNamed env' n) + | L'.CModProj (n, _, _) => ignore (E.lookupStrNamed env' n) + | L'.CUnif (_, _, _, _, r as ref (L'.Unknown f)) => + r := L'.Unknown (fn c => f c andalso validateCon env' c) + | _ => (), + bind = fn (env', b) => case b of + U.Con.RelK x => E.pushKRel env' x + | U.Con.RelC (x, k) => E.pushCRel env' x k + | U.Con.NamedC (x, n, k, co) => E.pushCNamedAs env x n k co} + env c; + true) + handle _ => false + + and validateKind env k = validateCon env (L'.CRecord (k, []), ErrorMsg.dummySpan) + exception KUnify' of kunify_error fun unifyKinds' env (k1All as (k1, _)) (k2All as (k2, _)) = @@ -93,38 +116,49 @@ | (L'.KError, _) => () | (_, L'.KError) => () - | (L'.KUnif (_, _, ref (SOME k1All)), _) => unifyKinds' env k1All k2All - | (_, L'.KUnif (_, _, ref (SOME k2All))) => unifyKinds' env k1All k2All + | (L'.KUnif (_, _, ref (L'.KKnown k1All)), _) => unifyKinds' env k1All k2All + | (_, L'.KUnif (_, _, ref (L'.KKnown k2All))) => unifyKinds' env k1All k2All - | (L'.KTupleUnif (_, _, ref (SOME k)), _) => unifyKinds' env k k2All - | (_, L'.KTupleUnif (_, _, ref (SOME k))) => unifyKinds' env k1All k + | (L'.KTupleUnif (_, _, ref (L'.KKnown k)), _) => unifyKinds' env k k2All + | (_, L'.KTupleUnif (_, _, ref (L'.KKnown k))) => unifyKinds' env k1All k - | (L'.KUnif (_, _, r1), L'.KUnif (_, _, r2)) => + | (L'.KUnif (_, _, r1 as ref (L'.KUnknown f1)), L'.KUnif (_, _, r2 as ref (L'.KUnknown f2))) => if r1 = r2 then () else - r1 := SOME k2All + (r1 := L'.KKnown k2All; + r2 := L'.KUnknown (fn x => f1 x andalso f2 x)) - | (L'.KUnif (_, _, r), _) => + | (L'.KUnif (_, _, r as ref (L'.KUnknown f)), _) => if occursKind r k2All then err KOccursCheckFailed + else if not (f k2All) then + err KScope else - r := SOME k2All - | (_, L'.KUnif (_, _, r)) => + r := L'.KKnown k2All + | (_, L'.KUnif (_, _, r as ref (L'.KUnknown f))) => if occursKind r k1All then err KOccursCheckFailed + else if not (f k1All) then + err KScope + else + r := L'.KKnown k1All + + | (L'.KTupleUnif (_, nks, r as ref (L'.KUnknown f)), L'.KTuple ks) => + if not (f k2All) then + err KScope + else + ((app (fn (n, k) => unifyKinds' env k (List.nth (ks, n-1))) nks; + r := L'.KKnown k2All) + handle Subscript => err KIncompatible) + | (L'.KTuple ks, L'.KTupleUnif (_, nks, r as ref (L'.KUnknown f))) => + if not (f k2All) then + err KScope else - r := SOME k1All - - | (L'.KTupleUnif (_, nks, r), L'.KTuple ks) => - ((app (fn (n, k) => unifyKinds' env k (List.nth (ks, n-1))) nks; - r := SOME k2All) - handle Subscript => err KIncompatible) - | (L'.KTuple ks, L'.KTupleUnif (_, nks, r)) => - ((app (fn (n, k) => unifyKinds' env (List.nth (ks, n-1)) k) nks; - r := SOME k1All) - handle Subscript => err KIncompatible) - | (L'.KTupleUnif (loc, nks1, r1), L'.KTupleUnif (_, nks2, r2)) => + ((app (fn (n, k) => unifyKinds' env (List.nth (ks, n-1)) k) nks; + r := L'.KKnown k1All) + handle Subscript => err KIncompatible) + | (L'.KTupleUnif (loc, nks1, r1 as ref (L'.KUnknown f1)), L'.KTupleUnif (_, nks2, r2 as ref (L'.KUnknown f2))) => let val nks = foldl (fn (p as (n, k1), nks) => case ListUtil.search (fn (n', k2) => @@ -136,10 +170,10 @@ | SOME k2 => (unifyKinds' env k1 k2; nks)) nks2 nks1 - val k = (L'.KTupleUnif (loc, nks, ref NONE), loc) + val k = (L'.KTupleUnif (loc, nks, ref (L'.KUnknown (fn x => f1 x andalso f2 x))), loc) in - r1 := SOME k; - r2 := SOME k + r1 := L'.KKnown k; + r2 := L'.KKnown k end | _ => err KIncompatible @@ -174,13 +208,14 @@ val char = ref cerror val table = ref cerror + local val count = ref 0 in fun resetKunif () = count := 0 - fun kunif loc = + fun kunif' f loc = let val n = !count val s = if n <= 26 then @@ -189,9 +224,11 @@ "U" ^ Int.toString (n - 26) in count := n + 1; - (L'.KUnif (loc, s, ref NONE), loc) + (L'.KUnif (loc, s, ref (L'.KUnknown f)), loc) end + fun kunif env = kunif' (validateKind env) + end local @@ -200,7 +237,7 @@ fun resetCunif () = count := 0 - fun cunif (loc, k) = + fun cunif' f (loc, k) = let val n = !count val s = if n < 26 then @@ -209,9 +246,11 @@ "U" ^ Int.toString (n - 26) in count := n + 1; - (L'.CUnif (0, loc, k, s, ref NONE), loc) + (L'.CUnif (0, loc, k, s, ref (L'.Unknown f)), loc) end + fun cunif env = cunif' (validateCon env) + end fun elabKind env (k, loc) = @@ -222,7 +261,7 @@ | L.KRecord k => (L'.KRecord (elabKind env k), loc) | L.KUnit => (L'.KUnit, loc) | L.KTuple ks => (L'.KTuple (map (elabKind env) ks), loc) - | L.KWild => kunif loc + | L.KWild => kunif env loc | L.KVar s => (case E.lookupK env s of NONE => @@ -238,18 +277,18 @@ fun hnormKind (kAll as (k, _)) = case k of - L'.KUnif (_, _, ref (SOME k)) => hnormKind k + L'.KUnif (_, _, ref (L'.KKnown k)) => hnormKind k | _ => kAll open ElabOps - fun elabConHead (c as (_, loc)) k = + fun elabConHead env (c as (_, loc)) k = let fun unravel (k, c) = case hnormKind k of (L'.KFun (x, k'), _) => let - val u = kunif loc + val u = kunif env loc val k'' = subKindInKind (0, u) k' in @@ -303,8 +342,8 @@ val (c1', k1, gs1) = elabCon (env, denv) c1 val (c2', k2, gs2) = elabCon (env, denv) c2 - val ku1 = kunif loc - val ku2 = kunif loc + val ku1 = kunif env loc + val ku2 = kunif env loc val denv' = D.assert env denv (c1', c2') val (c', k, gs4) = elabCon (env, denv') c @@ -331,13 +370,13 @@ (cerror, kerror, [])) | E.Rel (n, k) => let - val (c, k) = elabConHead (L'.CRel n, loc) k + val (c, k) = elabConHead env (L'.CRel n, loc) k in (c, k, []) end | E.Named (n, k) => let - val (c, k) = elabConHead (L'.CNamed n, loc) k + val (c, k) = elabConHead env (L'.CNamed n, loc) k in (c, k, []) end) @@ -358,7 +397,7 @@ NONE => (conError env (UnboundCon (loc, s)); kerror) | SOME (k, _) => k - val (c, k) = elabConHead (L'.CModProj (n, ms, s), loc) k + val (c, k) = elabConHead env (L'.CModProj (n, ms, s), loc) k in (c, k, []) end) @@ -367,8 +406,8 @@ let val (c1', k1, gs1) = elabCon (env, denv) c1 val (c2', k2, gs2) = elabCon (env, denv) c2 - val dom = kunif loc - val ran = kunif loc + val dom = kunif env loc + val ran = kunif env loc in checkKind env c1' k1 (L'.KArrow (dom, ran), loc); checkKind env c2' k2 dom; @@ -377,7 +416,7 @@ | L.CAbs (x, ko, t) => let val k' = case ko of - NONE => kunif loc + NONE => kunif env loc | SOME k => elabKind env k val env' = E.pushCRel env x k' val (t', tk, gs) = elabCon (env', D.enter denv) t @@ -401,7 +440,7 @@ | L.CRecord xcs => let - val k = kunif loc + val k = kunif env loc val (xcs', gs) = ListUtil.foldlMap (fn ((x, c), gs) => let @@ -439,7 +478,7 @@ let val (c1', k1, gs1) = elabCon (env, denv) c1 val (c2', k2, gs2) = elabCon (env, denv) c2 - val ku = kunif loc + val ku = kunif env loc val k = (L'.KRecord ku, loc) in checkKind env c1' k1 k; @@ -449,8 +488,8 @@ end | L.CMap => let - val dom = kunif loc - val ran = kunif loc + val dom = kunif env loc + val ran = kunif env loc in ((L'.CMap (dom, ran), loc), mapKind (dom, ran, loc), @@ -474,13 +513,13 @@ let val (c', k, gs) = elabCon (env, denv) c - val k' = kunif loc + val k' = kunif env loc in if n <= 0 then (conError env (ProjBounds (c', n)); (cerror, kerror, [])) else - (checkKind env c' k (L'.KTupleUnif (loc, [(n, k')], ref NONE), loc); + (checkKind env c' k (L'.KTupleUnif (loc, [(n, k')], ref (L'.KUnknown (validateKind env))), loc); ((L'.CProj (c', n), loc), k', gs)) end @@ -488,19 +527,19 @@ let val k' = elabKind env k in - (cunif (loc, k'), k', []) + (cunif env (loc, k'), k', []) end fun kunifsRemain k = case k of - L'.KUnif (_, _, ref NONE) => true - | L'.KTupleUnif (_, _, ref NONE) => true + L'.KUnif (_, _, ref (L'.KUnknown _)) => true + | L'.KTupleUnif (_, _, ref (L'.KUnknown _)) => true | _ => false fun cunifsRemain c = case c of - L'.CUnif (_, loc, k, _, r as ref NONE) => + L'.CUnif (_, loc, k, _, r as ref (L'.Unknown _)) => (case #1 (hnormKind k) of - L'.KUnit => (r := SOME (L'.CUnit, loc); false) + L'.KUnit => (r := L'.Known (L'.CUnit, loc); false) | _ => true) | _ => false @@ -529,7 +568,7 @@ type record_summary = { fields : (L'.con * L'.con) list, - unifs : (L'.con * L'.con option ref) list, + unifs : (L'.con * L'.cunif ref) list, others : L'.con list } @@ -598,10 +637,10 @@ (L'.KTuple ks, _) => List.nth (ks, n - 1) | (L'.KUnif (_, _, r), _) => let - val ku = kunif loc - val k = (L'.KTupleUnif (loc, [(n, ku)], ref NONE), loc) + val ku = kunif env loc + val k = (L'.KTupleUnif (loc, [(n, ku)], r), loc) in - r := SOME k; + r := L'.KKnown k; k end | (L'.KTupleUnif (_, nks, r), _) => @@ -609,10 +648,10 @@ SOME k => k | NONE => let - val ku = kunif loc - val k = (L'.KTupleUnif (loc, ((n, ku) :: nks), ref NONE), loc) + val ku = kunif env loc + val k = (L'.KTupleUnif (loc, ((n, ku) :: nks), r), loc) in - r := SOME k; + r := L'.KKnown k; k end) | k => raise CUnify' (CKindof (k, c, "tuple"))) @@ -713,11 +752,11 @@ case hnormKind (kindof env c) of (L'.KRecord k, _) => k | (L'.KError, _) => kerror - | (L'.KUnif (_, _, r), _) => + | (L'.KUnif (_, _, r as ref (L'.KUnknown f)), _) => let - val k = kunif (#2 c) + val k = kunif' f (#2 c) in - r := SOME (L'.KRecord k, #2 c); + r := L'.KKnown (L'.KRecord k, #2 c); k end | k => raise CUnify' (CKindof (k, c, "record")) @@ -751,7 +790,7 @@ unifs = #unifs s1 @ #unifs s2, others = #others s1 @ #others s2} end - | (L'.CUnif (nl, _, _, _, ref (SOME c)), _) => recordSummary env (E.mliftConInCon nl c) + | (L'.CUnif (nl, _, _, _, ref (L'.Known c)), _) => recordSummary env (E.mliftConInCon nl c) | c' as (L'.CUnif (0, _, _, _, r), _) => {fields = [], unifs = [(c', r)], others = []} | c' => {fields = [], unifs = [], others = [c']} in @@ -845,35 +884,41 @@ val (unifs1, fs1, others1, unifs2, fs2, others2) = case (unifs1, fs1, others1, unifs2, fs2, others2) of - orig as ([(_, r)], [], [], _, _, _) => + orig as ([(_, r as ref (L'.Unknown f))], [], [], _, _, _) => let val c = unsummarize {fields = fs2, others = others2, unifs = unifs2} in - if occursCon r c then + if occursCon r c orelse not (f c) then orig else - (r := SOME c; + (r := L'.Known c; empties) end - | orig as (_, _, _, [(_, r)], [], []) => + | orig as (_, _, _, [(_, r as ref (L'.Unknown f))], [], []) => let val c = unsummarize {fields = fs1, others = others1, unifs = unifs1} in - if occursCon r c then + if occursCon r c orelse not (f c) then orig else - (r := SOME c; + (r := L'.Known c; empties) end - | orig as ([(_, r1 as ref NONE)], _, [], [(_, r2 as ref NONE)], _, []) => + | orig as ([(_, r1 as ref (L'.Unknown f1))], _, [], [(_, r2 as ref (L'.Unknown f2))], _, []) => if List.all (fn (x1, _) => List.all (fn (x2, _) => consNeq env (x1, x2)) fs2) fs1 then let val kr = (L'.KRecord k, loc) - val u = cunif (loc, kr) + val u = cunif env (loc, kr) + + val c1 = (L'.CConcat ((L'.CRecord (k, fs2), loc), u), loc) + val c2 = (L'.CConcat ((L'.CRecord (k, fs1), loc), u), loc) in - r1 := SOME (L'.CConcat ((L'.CRecord (k, fs2), loc), u), loc); - r2 := SOME (L'.CConcat ((L'.CRecord (k, fs1), loc), u), loc); - empties + if not (f1 c1) orelse not (f2 c2) then + orig + else + (r1 := L'.Known c1; + r2 := L'.Known c2; + empties) end else orig @@ -950,10 +995,10 @@ in (case (unifs1, fs1, others1, unifs2, fs2, others2) of (_, [], [], [], [], []) => - app (fn (_, r) => r := SOME empty) unifs1 + app (fn (_, r) => r := L'.Known empty) unifs1 | ([], [], [], _, [], []) => - app (fn (_, r) => r := SOME empty) unifs2 - | (_, _, _, [], [], [cr as (L'.CUnif (nl, _, _, _, r), _)]) => + app (fn (_, r) => r := L'.Known empty) unifs2 + | (_, _, _, [], [], [cr as (L'.CUnif (nl, _, _, _, r as ref (L'.Unknown f)), _)]) => let val c = summaryToCon {fields = fs1, unifs = unifs1, others = others1} in @@ -961,10 +1006,17 @@ (reducedSummaries := NONE; raise CUnify' (COccursCheckFailed (cr, c))) else - (r := SOME (squish nl c)) + let + val sq = squish nl c + in + if not (f sq) then + default () + else + r := L'.Known sq + end handle CantSquish => default () end - | ([], [], [cr as (L'.CUnif (nl, _, _, _, r), _)], _, _, _) => + | ([], [], [cr as (L'.CUnif (nl, _, _, _, r as ref (L'.Unknown f)), _)], _, _, _) => let val c = summaryToCon {fields = fs2, unifs = unifs2, others = others2} in @@ -972,7 +1024,14 @@ (reducedSummaries := NONE; raise CUnify' (COccursCheckFailed (cr, c))) else - (r := SOME (squish nl c)) + let + val sq = squish nl c + in + if not (f sq) then + default () + else + r := L'.Known sq + end handle CantSquish => default () end | _ => default ()) @@ -992,15 +1051,15 @@ let val v' = case dom of (L'.KUnit, _) => (L'.CUnit, loc) - | _ => cunif (loc, dom) + | _ => cunif env (loc, dom) in unifyCons env loc v (L'.CApp (f, v'), loc); unifyCons env loc r (L'.CRecord (dom, [(x, v')]), loc) end | L'.CRecord (_, (x, v) :: rest) => let - val r1 = cunif (loc, (L'.KRecord dom, loc)) - val r2 = cunif (loc, (L'.KRecord dom, loc)) + val r1 = cunif env (loc, (L'.KRecord dom, loc)) + val r2 = cunif env (loc, (L'.KRecord dom, loc)) in unfold (r1, (L'.CRecord (ran, [(x, v)]), loc)); unfold (r2, (L'.CRecord (ran, rest), loc)); @@ -1008,15 +1067,22 @@ end | L'.CConcat (c1', c2') => let - val r1 = cunif (loc, (L'.KRecord dom, loc)) - val r2 = cunif (loc, (L'.KRecord dom, loc)) + val r1 = cunif env (loc, (L'.KRecord dom, loc)) + val r2 = cunif env (loc, (L'.KRecord dom, loc)) in unfold (r1, c1'); unfold (r2, c2'); unifyCons env loc r (L'.CConcat (r1, r2), loc) end - | L'.CUnif (0, _, _, _, ur) => - ur := SOME (L'.CApp ((L'.CApp ((L'.CMap (dom, ran), loc), f), loc), r), loc) + | L'.CUnif (0, _, _, _, ur as ref (L'.Unknown rf)) => + let + val c' = (L'.CApp ((L'.CApp ((L'.CMap (dom, ran), loc), f), loc), r), loc) + in + if not (rf c') then + cunifyError env (CScope (c, c')) + else + ur := L'.Known c' + end | _ => raise ex in unfold (r, c) @@ -1063,14 +1129,14 @@ onFail () in case #1 (hnormCon env c2) of - L'.CUnif (0, _, k, _, r) => + L'.CUnif (0, _, k, _, r as ref (L'.Unknown f)) => (case #1 (hnormKind k) of L'.KTuple ks => let val loc = #2 c2 - val us = map (fn k => cunif (loc, k)) ks + val us = map (fn k => cunif' f (loc, k)) ks in - r := SOME (L'.CTuple us, loc); + r := L'.Known (L'.CTuple us, loc); unifyCons' env loc c1All (List.nth (us, n2 - 1)) end | _ => tryNormal ()) @@ -1079,14 +1145,14 @@ | _ => onFail () in case #1 (hnormCon env c1) of - L'.CUnif (0, _, k, _, r) => + L'.CUnif (0, _, k, _, r as ref (L'.Unknown f)) => (case #1 (hnormKind k) of L'.KTuple ks => let val loc = #2 c1 - val us = map (fn k => cunif (loc, k)) ks + val us = map (fn k => cunif' f (loc, k)) ks in - r := SOME (L'.CTuple us, loc); + r := L'.Known (L'.CTuple us, loc); unifyCons' env loc (List.nth (us, n1 - 1)) c2All end | _ => trySnd ()) @@ -1095,14 +1161,14 @@ fun projSpecial2 (c2, n2, onFail) = case #1 (hnormCon env c2) of - L'.CUnif (0, _, k, _, r) => + L'.CUnif (0, _, k, _, r as ref (L'.Unknown f)) => (case #1 (hnormKind k) of L'.KTuple ks => let val loc = #2 c2 - val us = map (fn k => cunif (loc, k)) ks + val us = map (fn k => cunif' f (loc, k)) ks in - r := SOME (L'.CTuple us, loc); + r := L'.Known (L'.CTuple us, loc); unifyCons' env loc c1All (List.nth (us, n2 - 1)) end | _ => onFail ()) @@ -1123,40 +1189,64 @@ (L'.CError, _) => () | (_, L'.CError) => () - | (L'.CUnif (nl1, loc1, k1, _, r1), L'.CUnif (nl2, loc2, k2, _, r2)) => + | (L'.CUnif (nl1, loc1, k1, _, r1 as ref (L'.Unknown f1)), L'.CUnif (nl2, loc2, k2, _, r2 as ref (L'.Unknown f2))) => if r1 = r2 andalso nl1 = nl2 then () else if nl1 = 0 then (unifyKinds env k1 k2; - r1 := SOME c2All) + if f1 c2All then + r1 := L'.Known c2All + else + err CScope) else if nl2 = 0 then (unifyKinds env k1 k2; - r2 := SOME c1All) + if f2 c1All then + r2 := L'.Known c1All + else + err CScope) else err (fn _ => TooLifty (loc1, loc2)) - | (L'.CUnif (0, _, _, _, r), _) => + | (L'.CUnif (0, _, _, _, r as ref (L'.Unknown f)), _) => if occursCon r c2All then err COccursCheckFailed + else if f c2All then + r := L'.Known c2All else - r := SOME c2All - | (_, L'.CUnif (0, _, _, _, r)) => + err CScope + | (_, L'.CUnif (0, _, _, _, r as ref (L'.Unknown f))) => if occursCon r c1All then err COccursCheckFailed + else if f c1All then + r := L'.Known c1All else - r := SOME c1All + err CScope - | (L'.CUnif (nl, _, _, _, r), _) => + | (L'.CUnif (nl, _, _, _, r as ref (L'.Unknown f)), _) => if occursCon r c2All then err COccursCheckFailed else - (r := SOME (squish nl c2All) + (let + val sq = squish nl c2All + in + if f sq then + r := L'.Known sq + else + err CScope + end handle CantSquish => err (fn _ => TooDeep)) - | (_, L'.CUnif (nl, _, _, _, r)) => + | (_, L'.CUnif (nl, _, _, _, r as ref (L'.Unknown f))) => if occursCon r c1All then err COccursCheckFailed else - (r := SOME (squish nl c1All) + (let + val sq = squish nl c1All + in + if f sq then + r := L'.Known sq + else + err CScope + end handle CantSquish => err (fn _ => TooDeep)) | (L'.CRecord _, _) => isRecord () @@ -1169,7 +1259,7 @@ | (L'.TFun (d1, r1), L'.TFun (d2, r2)) => (unifyCons' env loc d1 d2; - unifyCons' env loc r1 r2) + unifyCons' env loc r1 r2) | (L'.TCFun (expl1, x1, d1, r1), L'.TCFun (expl2, _, d2, r2)) => if expl1 <> expl2 then err CExplicitness @@ -1295,7 +1385,7 @@ case hnormCon env t of (L'.TKFun (x, t'), _) => let - val u = kunif loc + val u = kunif env loc val t'' = subKindInCon (0, u) t' in @@ -1307,7 +1397,7 @@ case hnormCon env t of (L'.TKFun (x, t'), _) => let - val u = kunif loc + val u = kunif env loc val t'' = subKindInCon (0, u) t' in @@ -1315,7 +1405,7 @@ end | (L'.TCFun (L'.Implicit, x, k, t'), _) => let - val u = cunif (loc, k) + val u = cunif env (loc, k) val t'' = subConInCon env (0, u) t' in @@ -1393,7 +1483,7 @@ fun elabPat (pAll as (p, loc), (env, bound)) = | (NONE, NONE) => let val k = (L'.KType, loc) - val unifs = map (fn _ => cunif (loc, k)) xs + val unifs = map (fn _ => cunif env (loc, k)) xs val dn = foldl (fn (u, dn) => (L'.CApp (dn, u), loc)) dn unifs in (((L'.PCon (dk, pc, unifs, NONE), loc), dn), @@ -1404,7 +1494,7 @@ fun elabPat (pAll as (p, loc), (env, bound)) = val ((p', pt), (env, bound)) = elabPat (p, (env, bound)) val k = (L'.KType, loc) - val unifs = map (fn _ => cunif (loc, k)) xs + val unifs = map (fn _ => cunif env (loc, k)) xs val nxs = length unifs - 1 val t = ListUtil.foldli (fn (i, u, t) => subConInCon env (nxs - i, E.mliftConInCon (nxs - i) u) t) t unifs @@ -1416,7 +1506,7 @@ fun elabPat (pAll as (p, loc), (env, bound)) = end in case p of - L.PWild => (((L'.PWild, loc), cunif (loc, (L'.KType, loc))), + L.PWild => (((L'.PWild, loc), cunif env (loc, (L'.KType, loc))), (env, bound)) | L.PVar x => let @@ -1424,7 +1514,7 @@ fun elabPat (pAll as (p, loc), (env, bound)) = (expError env (DuplicatePatternVariable (loc, x)); terror) else - cunif (loc, (L'.KType, loc)) + cunif env (loc, (L'.KType, loc)) in (((L'.PVar (x, t), loc), t), (E.pushERel env x t, SS.add (bound, x))) @@ -1473,7 +1563,7 @@ fun elabPat (pAll as (p, loc), (env, bound)) = val c = (L'.CRecord (k, map (fn (x, _, t) => ((L'.CName x, loc), t)) xpts), loc) val c = if flex then - (L'.CConcat (c, cunif (loc, (L'.KRecord k, loc))), loc) + (L'.CConcat (c, cunif env (loc, (L'.KRecord k, loc))), loc) else c in @@ -1778,7 +1868,7 @@ fun normClassConstraint env (c, loc) = (L'.TFun (c1, c2), loc) end | L'.TCFun (expl, x, k, c1) => (L'.TCFun (expl, x, k, normClassConstraint env c1), loc) - | L'.CUnif (nl, _, _, _, ref (SOME c)) => normClassConstraint env (E.mliftConInCon nl c) + | L'.CUnif (nl, _, _, _, ref (L'.Known c)) => normClassConstraint env (E.mliftConInCon nl c) | _ => unmodCon env (c, loc) fun findHead e e' = @@ -1887,7 +1977,7 @@ fun ndelVal (r : needed, k) = fun chaseUnifs c = case #1 c of - L'.CUnif (_, _, _, _, ref (SOME c)) => chaseUnifs c + L'.CUnif (_, _, _, _, ref (L'.Known c)) => chaseUnifs c | _ => c fun elabExp (env, denv) (eAll as (e, loc)) = @@ -1937,7 +2027,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) = | L.EWild => let val r = ref NONE - val c = cunif (loc, (L'.KType, loc)) + val c = cunif env (loc, (L'.KType, loc)) in ((L'.EUnif r, loc), c, [TypeClass (env, c, r, loc)]) end @@ -1948,8 +2038,8 @@ fun elabExp (env, denv) (eAll as (e, loc)) = val (e2', t2, gs2) = elabExp (env, denv) e2 - val dom = cunif (loc, ktype) - val ran = cunif (loc, ktype) + val dom = cunif env (loc, ktype) + val ran = cunif env (loc, ktype) val t = (L'.TFun (dom, ran), loc) val () = checkCon env e1' t1 t @@ -1966,7 +2056,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) = | L.EAbs (x, to, e) => let val (t', gs1) = case to of - NONE => (cunif (loc, ktype), []) + NONE => (cunif env (loc, ktype), []) | SOME t => let val (t', tk, gs) = elabCon (env, denv) t @@ -2042,8 +2132,8 @@ fun elabExp (env, denv) (eAll as (e, loc)) = val (c1', k1, gs1) = elabCon (env, denv) c1 val (c2', k2, gs2) = elabCon (env, denv) c2 - val ku1 = kunif loc - val ku2 = kunif loc + val ku1 = kunif env loc + val ku2 = kunif env loc val denv' = D.assert env denv (c1', c2') val (e', t, gs3) = elabExp (env, denv') e @@ -2057,11 +2147,11 @@ fun elabExp (env, denv) (eAll as (e, loc)) = let val (e', t, gs1) = elabExp (env, denv) e - val k1 = kunif loc - val c1 = cunif (loc, (L'.KRecord k1, loc)) - val k2 = kunif loc - val c2 = cunif (loc, (L'.KRecord k2, loc)) - val t' = cunif (loc, ktype) + val k1 = kunif env loc + val c1 = cunif env (loc, (L'.KRecord k1, loc)) + val k2 = kunif env loc + val c2 = cunif env (loc, (L'.KRecord k2, loc)) + val t' = cunif env (loc, ktype) val () = checkCon env e' t (L'.TDisjoint (c1, c2, t'), loc) val gs2 = D.prove env denv (c1, c2, loc) in @@ -2115,8 +2205,8 @@ fun elabExp (env, denv) (eAll as (e, loc)) = val (e', et, gs1) = elabExp (env, denv) e val (c', ck, gs2) = elabCon (env, denv) c - val ft = cunif (loc, ktype) - val rest = cunif (loc, ktype_record) + val ft = cunif env (loc, ktype) + val rest = cunif env (loc, ktype_record) val first = (L'.CRecord (ktype, [(c', ft)]), loc) val () = checkCon env e' et (L'.TRecord (L'.CConcat (first, rest), loc), loc); @@ -2130,8 +2220,8 @@ fun elabExp (env, denv) (eAll as (e, loc)) = val (e1', e1t, gs1) = elabExp (env, denv) e1 val (e2', e2t, gs2) = elabExp (env, denv) e2 - val r1 = cunif (loc, ktype_record) - val r2 = cunif (loc, ktype_record) + val r1 = cunif env (loc, ktype_record) + val r2 = cunif env (loc, ktype_record) val () = checkCon env e1' e1t (L'.TRecord r1, loc) val () = checkCon env e2' e2t (L'.TRecord r2, loc) @@ -2147,8 +2237,8 @@ fun elabExp (env, denv) (eAll as (e, loc)) = val (e', et, gs1) = elabExp (env, denv) e val (c', ck, gs2) = elabCon (env, denv) c - val ft = cunif (loc, ktype) - val rest = cunif (loc, ktype_record) + val ft = cunif env (loc, ktype) + val rest = cunif env (loc, ktype_record) val first = (L'.CRecord (ktype, [(c', ft)]), loc) val () = checkCon env e' et @@ -2165,7 +2255,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) = val (e', et, gs1) = elabExp (env, denv) e val (c', ck, gs2) = elabCon (env, denv) c - val rest = cunif (loc, ktype_record) + val rest = cunif env (loc, ktype_record) val () = checkCon env e' et (L'.TRecord (L'.CConcat (c', rest), loc), loc) @@ -2180,7 +2270,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) = | L.ECase (e, pes) => let val (e', et, gs1) = elabExp (env, denv) e - val result = cunif (loc, (L'.KType, loc)) + val result = cunif env (loc, (L'.KType, loc)) val (pes', gs) = ListUtil.foldlMap (fn ((p, e), gs) => let @@ -2255,7 +2345,7 @@ and elabEdecl denv (dAll as (d, loc), (env, gs)) = (fn ((x, co, e), gs) => let val (c', _, gs1) = case co of - NONE => (cunif (loc, ktype), ktype, []) + NONE => (cunif env (loc, ktype), ktype, []) | SOME c => elabCon (env, denv) c in ((x, c', e), enD gs1 @ gs) @@ -2339,7 +2429,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = | L.SgiCon (x, ko, c) => let val k' = case ko of - NONE => kunif loc + NONE => kunif env loc | SOME k => elabKind env k val (c', ck, gs') = elabCon (env, denv) c @@ -2479,8 +2569,8 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = val cstK = (L'.KRecord (L'.KRecord (L'.KUnit, loc), loc), loc) val (c', ck, gs') = elabCon (env, denv) c - val pkey = cunif (loc, cstK) - val visible = cunif (loc, cstK) + val pkey = cunif env (loc, cstK) + val visible = cunif env (loc, cstK) val (env', ds, uniques) = case (#1 pe, #1 ce) of (L.EVar (["Basis"], "no_primary_key", _), L.EVar (["Basis"], "no_constraint", _)) => @@ -2556,8 +2646,8 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = val denv = D.assert env denv (c1', c2') in - checkKind env c1' k1 (L'.KRecord (kunif loc), loc); - checkKind env c2' k2 (L'.KRecord (kunif loc), loc); + checkKind env c1' k1 (L'.KRecord (kunif env loc), loc); + checkKind env c2' k2 (L'.KRecord (kunif env loc), loc); ([(L'.SgiConstraint (c1', c2'), loc)], (env, denv, gs1 @ gs2)) end @@ -3421,9 +3511,9 @@ and wildifyStr env (str, sgn) = end | L'.KError => NONE - | L'.KUnif (_, _, ref (SOME k)) => decompileKind k + | L'.KUnif (_, _, ref (L'.KKnown k)) => decompileKind k | L'.KUnif _ => NONE - | L'.KTupleUnif (_, _, ref (SOME k)) => decompileKind k + | L'.KTupleUnif (_, _, ref (L'.KKnown k)) => decompileKind k | L'.KTupleUnif _ => NONE | L'.KRel _ => NONE @@ -3472,7 +3562,7 @@ and wildifyStr env (str, sgn) = (SOME c1, SOME c2) => SOME (L.CConcat (c1, c2), loc) | _ => NONE) | L'.CUnit => SOME (L.CUnit, loc) - | L'.CUnif (nl, _, _, _, ref (SOME c)) => decompileCon env (E.mliftConInCon nl c) + | L'.CUnif (nl, _, _, _, ref (L'.Known c)) => decompileCon env (E.mliftConInCon nl c) | L'.CApp (f, x) => (case (decompileCon env f, decompileCon env x) of @@ -3599,7 +3689,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = L.DCon (x, ko, c) => let val k' = case ko of - NONE => kunif loc + NONE => kunif env loc | SOME k => elabKind env k val (c', ck, gs') = elabCon (env, denv) c @@ -3723,7 +3813,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = | L.DVal (x, co, e) => let val (c', _, gs1) = case co of - NONE => (cunif (loc, ktype), ktype, []) + NONE => (cunif env (loc, ktype), ktype, []) | SOME c => elabCon (env, denv) c val (e', et, gs2) = elabExp (env, denv) e @@ -3751,7 +3841,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = (fn ((x, co, e), gs) => let val (c', _, gs1) = case co of - NONE => (cunif (loc, ktype), ktype, []) + NONE => (cunif env (loc, ktype), ktype, []) | SOME c => elabCon (env, denv) c val c' = normClassConstraint env c' in @@ -3868,8 +3958,8 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = val denv' = D.assert env denv (c1', c2') in - checkKind env c1' k1 (L'.KRecord (kunif loc), loc); - checkKind env c2' k2 (L'.KRecord (kunif loc), loc); + checkKind env c1' k1 (L'.KRecord (kunif env loc), loc); + checkKind env c2' k2 (L'.KRecord (kunif env loc), loc); ([(L'.DConstraint (c1', c2'), loc)], (env, denv', enD gs1 @ enD gs2 @ enD gs3 @ gs)) end @@ -3959,8 +4049,8 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = val cstK = (L'.KRecord (L'.KRecord (L'.KUnit, loc), loc), loc) val (c', k, gs') = elabCon (env, denv) c - val pkey = cunif (loc, cstK) - val uniques = cunif (loc, cstK) + val pkey = cunif env (loc, cstK) + val uniques = cunif env (loc, cstK) val ct = tableOf () val ct = (L'.CApp (ct, c'), loc) @@ -3995,8 +4085,8 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = val (e', t, gs') = elabExp (env, denv) e val k = (L'.KRecord (L'.KType, loc), loc) - val fs = cunif (loc, k) - val ts = cunif (loc, (L'.KRecord k, loc)) + val fs = cunif env (loc, k) + val ts = cunif env (loc, (L'.KRecord k, loc)) val tf = (L'.CApp ((L'.CMap (k, k), loc), (L'.CAbs ("_", k, (L'.CRecord ((L'.KType, loc), []), loc)), loc)), loc) val ts = (L'.CApp (tf, ts), loc) @@ -4048,7 +4138,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = val (e1', t1, gs1) = elabExp (env, denv) e1 val (e2', t2, gs2) = elabExp (env, denv) e2 - val targ = cunif (loc, (L'.KType, loc)) + val targ = cunif env (loc, (L'.KType, loc)) val t1' = (L'.CModProj (!basis_r, [], "task_kind"), loc) val t1' = (L'.CApp (t1', targ), loc) diff --git a/src/explify.sml b/src/explify.sml index 5081d33b..3c922a44 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -42,9 +42,9 @@ fun explifyKind (k, loc) = | L.KTuple ks => (L'.KTuple (map explifyKind ks), loc) | L.KError => raise Fail ("explifyKind: KError at " ^ EM.spanToString loc) - | L.KUnif (_, _, ref (SOME k)) => explifyKind k + | L.KUnif (_, _, ref (L.KKnown k)) => explifyKind k | L.KUnif _ => raise Fail ("explifyKind: KUnif at " ^ EM.spanToString loc) - | L.KTupleUnif (loc, _, ref (SOME k)) => explifyKind k + | L.KTupleUnif (loc, _, ref (L.KKnown k)) => explifyKind k | L.KTupleUnif _ => raise Fail ("explifyKind: KTupleUnif at " ^ EM.spanToString loc) | L.KRel n => (L'.KRel n, loc) @@ -76,7 +76,7 @@ fun explifyCon (c, loc) = | L.CProj (c, n) => (L'.CProj (explifyCon c, n), loc) | L.CError => raise Fail ("explifyCon: CError at " ^ EM.spanToString loc) - | L.CUnif (nl, _, _, _, ref (SOME c)) => explifyCon (ElabEnv.mliftConInCon nl c) + | L.CUnif (nl, _, _, _, ref (L.Known c)) => explifyCon (ElabEnv.mliftConInCon nl c) | L.CUnif _ => raise Fail ("explifyCon: CUnif at " ^ EM.spanToString loc) | L.CKAbs (x, c) => (L'.CKAbs (x, explifyCon c), loc) diff --git a/tests/capture.ur b/tests/capture.ur new file mode 100644 index 00000000..0eb3d8b5 --- /dev/null +++ b/tests/capture.ur @@ -0,0 +1,4 @@ +val y = [] + +type foo = int +val z : list {F : foo} = y diff --git a/tests/rcapture.ur b/tests/rcapture.ur new file mode 100644 index 00000000..782efcd9 --- /dev/null +++ b/tests/rcapture.ur @@ -0,0 +1,3 @@ +fun frob x = x + +fun foo [a] (x : a) = frob x -- cgit v1.2.3 From 802fc606ff18c261eb591d7ae6dbb99fe9c48af9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 4 May 2012 10:33:04 -0400 Subject: More diagnostic information about some type class resolution failures --- src/elab_env.sig | 1 + src/elab_env.sml | 26 ++++++++++++++++---------- src/elab_err.sml | 15 ++++----------- src/elaborate.sml | 8 +++++++- tests/classFail.ur | 3 +++ 5 files changed, 31 insertions(+), 22 deletions(-) create mode 100644 tests/classFail.ur (limited to 'src/elab_env.sml') diff --git a/src/elab_env.sig b/src/elab_env.sig index 662d7071..e0c589c4 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -73,6 +73,7 @@ signature ELAB_ENV = sig val isClass : env -> Elab.con -> bool val resolveClass : (Elab.con -> Elab.con) -> (Elab.con * Elab.con -> bool) -> env -> Elab.con -> Elab.exp option + val resolveFailureCause : unit -> Elab.con option val listClasses : env -> (Elab.con * (Elab.con * Elab.exp) list) list val pushERel : env -> string -> Elab.con -> env diff --git a/src/elab_env.sml b/src/elab_env.sml index ed96782e..bf0808f5 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -678,13 +678,18 @@ fun startsWithUnif c = | SOME x => hasUnif x end +val cause = ref (NONE : con option) +fun resolveFailureCause () = !cause + fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) = let - fun resolve c = + fun resolve firstLevel c = let + fun notFound () = (if firstLevel then () else cause := SOME c; NONE) + fun doHead f = case CM.find (#classes env, f) of - NONE => NONE + NONE => notFound () | SOME class => let val loc = #2 c @@ -722,13 +727,13 @@ fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) = fun tryRules rules = case rules of - [] => NONE + [] => notFound () | (nRs, cs, c', e) :: rules' => case tryUnify hnorm nRs (c, c') of NONE => tryRules rules' | SOME rs => let - val eos = map (resolve o unifySubst rs) cs + val eos = map (resolve false o unifySubst rs) cs in if List.exists (not o Option.isSome) eos orelse not (equate ()) @@ -759,7 +764,7 @@ fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) = end in if startsWithUnif c then - NONE + notFound () else case #1 c of TRecord c => @@ -777,21 +782,22 @@ fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) = (CApp (f, x), loc) => (CApp (hnorm f, hnorm x), loc) | _ => t in - case resolve t of - NONE => NONE + case resolve false t of + NONE => notFound () | SOME e => resolver (xts, (x, e, t) :: acc) end in resolver (xts, []) end - | _ => NONE) + | _ => notFound ()) | _ => case class_head_in c of SOME f => doHead f - | _ => NONE + | _ => notFound () end in - resolve + cause := NONE; + resolve true end fun pushERel (env : env) x t = diff --git a/src/elab_err.sml b/src/elab_err.sml index f21ddce0..0e04cf51 100644 --- a/src/elab_err.sml +++ b/src/elab_err.sml @@ -239,17 +239,10 @@ fun expError env err = ("Type", p_con env c)]) co) | Unresolvable (loc, c) => (ErrorMsg.errorAt loc "Can't resolve type class instance"; - eprefaces' [("Class constraint", p_con env c)(*, - ("Class database", p_list (fn (c, rules) => - box [P.p_con env c, - PD.string ":", - space, - p_list (fn (c, e) => - box [p_exp env e, - PD.string ":", - space, - P.p_con env c]) rules]) - (E.listClasses env))*)]) + eprefaces' ([("Class constraint", p_con env c)] + @ (case E.resolveFailureCause () of + NONE => [] + | SOME c' => [("Reduced to unresolvable", p_con env c')]))) | IllegalRec (x, e) => (ErrorMsg.errorAt (#2 e) "Illegal 'val rec' righthand side (must be a function abstraction)"; eprefaces' [("Variable", PD.string x), diff --git a/src/elaborate.sml b/src/elaborate.sml index f098b580..5799d6bb 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -4676,7 +4676,13 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = (!delayedUnifs);*) end | TypeClass (env, c, r, loc) => - expError env (Unresolvable (loc, c))) + let + val c = normClassKey env c + in + case resolveClass env c of + SOME _ => raise Fail "Type class resolution succeeded unexpectedly" + | NONE => expError env (Unresolvable (loc, c)) + end) gs) end in diff --git a/tests/classFail.ur b/tests/classFail.ur new file mode 100644 index 00000000..dd7b66e9 --- /dev/null +++ b/tests/classFail.ur @@ -0,0 +1,3 @@ +val x = show 7 +val y = show (8, 9) +val z : (show int * show unit) = _ -- cgit v1.2.3 From 7c37a6336fb1a56fee80e94f9e5188c3436102cd Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 25 Jul 2012 14:04:59 -0400 Subject: Allow type class instances with hypotheses via local ('let') definitions --- src/elab_env.sml | 165 +++++++++++++++++++++++++++++---------------------- src/elab_util.sig | 5 ++ src/elab_util.sml | 20 +++++++ src/source_print.sig | 1 + 4 files changed, 119 insertions(+), 72 deletions(-) (limited to 'src/elab_env.sml') diff --git a/src/elab_env.sml b/src/elab_env.sml index bf0808f5..df031288 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -163,6 +163,22 @@ val subExpInExp = | ((xn, rep), U.Exp.RelC _) => (xn, liftConInExp 0 rep) | (ctx, _) => ctx} +val openCon = + U.Con.existsB {kind = fn ((nk, _), k) => + case k of + KRel n => n >= nk + | _ => false, + con = fn ((_, nc), c) => + case c of + CRel n => n >= nc + | _ => false, + bind = fn (all as (nk, nc), b) => + case b of + U.Con.RelK _ => (nk+1, nc) + | U.Con.RelC _ => (nk, nc+1) + | _ => all} + (0, 0) + (* Back to environments *) datatype 'a var' = @@ -208,10 +224,12 @@ end structure CS = BinarySetFn(CK) structure CM = BinaryMapFn(CK) -type class = {ground : (con * exp) list, - rules : (int * con list * con * exp) list} -val empty_class = {ground = [], - rules = []} +type rules = (int * con list * con * exp) list + +type class = {closedRules : rules, + openRules : rules} +val empty_class = {closedRules = [], + openRules = []} type env = { renameK : int SM.map, @@ -286,11 +304,13 @@ fun pushKRel (env : env) x = datatypes = #datatypes env, constructors = #constructors env, - classes = CM.map (fn cl => {ground = map (fn (c, e) => - (liftKindInCon 0 c, - e)) - (#ground cl), - rules = #rules cl}) + classes = CM.map (fn cl => {closedRules = #closedRules cl, + openRules = map (fn (nvs, cs, c, e) => + (nvs, + map (liftKindInCon 0) cs, + liftKindInCon 0 c, + liftKindInExp 0 e)) + (#openRules cl)}) (#classes env), renameE = SM.map (fn Rel' (n, c) => Rel' (n, liftKindInCon 0 c) @@ -328,11 +348,13 @@ fun pushCRel (env : env) x k = constructors = #constructors env, classes = CM.map (fn class => - {ground = map (fn (c, e) => - (liftConInCon 0 c, - e)) - (#ground class), - rules = #rules class}) + {closedRules = #closedRules class, + openRules = map (fn (nvs, cs, c, e) => + (nvs, + map (liftConInCon 0) cs, + liftConInCon 0 c, + liftConInExp 0 e)) + (#openRules class)}) (#classes env), renameE = SM.map (fn Rel' (n, c) => Rel' (n, lift c) @@ -441,10 +463,9 @@ fun datatypeArgs (xs, _) = xs fun constructors (_, dt) = IM.foldri (fn (n, (x, to), ls) => (x, n, to) :: ls) [] dt fun listClasses (env : env) = - map (fn (cn, {ground, rules}) => + map (fn (cn, {closedRules, openRules}) => (class_name_out cn, - ground - @ map (fn (nvs, cs, c, e) => + map (fn (nvs, cs, c, e) => let val loc = #2 c val c = foldr (fn (c', c) => (TFun (c', c), loc)) c cs @@ -455,7 +476,7 @@ fun listClasses (env : env) = c (List.tabulate (nvs, fn _ => ())) in (c, e) - end) rules)) (CM.listItemsi (#classes env)) + end) (closedRules @ openRules))) (CM.listItemsi (#classes env)) fun pushClass (env : env) n = {renameK = #renameK env, @@ -653,6 +674,8 @@ fun unifySubst (rs : con list) = CRel n => if n < d then c + else if n - d >= length rs then + CRel (n - d) else #1 (List.nth (rs, n - d)) | _ => c, @@ -729,7 +752,7 @@ fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) = case rules of [] => notFound () | (nRs, cs, c', e) :: rules' => - case tryUnify hnorm nRs (c, c') of + case tryUnify hnorm nRs (c, c') of NONE => tryRules rules' | SOME rs => let @@ -749,18 +772,8 @@ fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) = SOME e end end - - fun rules () = tryRules (#rules class) - - fun tryGrounds ces = - case ces of - [] => rules () - | (c', e) :: ces' => - case tryUnify hnorm 0 (c, c') of - NONE => tryGrounds ces' - | SOME _ => SOME e in - tryGrounds (#ground class) + tryRules (#openRules class @ #closedRules class) end in if startsWithUnif c then @@ -800,23 +813,55 @@ fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) = resolve true end +fun rule_in c = + let + fun quantifiers (c, nvars) = + case #1 c of + CUnif (_, _, _, _, ref (Known c)) => quantifiers (c, nvars) + | TCFun (_, _, _, c) => quantifiers (c, nvars + 1) + | _ => + let + fun clauses (c, hyps) = + case #1 c of + TFun (hyp, c) => + (case class_head_in hyp of + SOME _ => clauses (c, hyp :: hyps) + | NONE => NONE) + | _ => + case class_head_in c of + NONE => NONE + | SOME f => SOME (f, nvars, rev hyps, c) + in + clauses (c, []) + end + in + quantifiers (c, 0) + end + fun pushERel (env : env) x t = let val renameE = SM.map (fn Rel' (n, t) => Rel' (n+1, t) | x => x) (#renameE env) val classes = CM.map (fn class => - {ground = map (fn (c, e) => (c, liftExp e)) (#ground class), - rules = #rules class}) (#classes env) - val classes = case class_head_in t of + {openRules = map (fn (nvs, cs, c, e) => (nvs, cs, c, liftExp e)) (#openRules class), + closedRules = #closedRules class}) (#classes env) + val classes = case rule_in t of NONE => classes - | SOME f => + | SOME (f, nvs, cs, c) => case CM.find (classes, f) of NONE => classes | SOME class => let - val class = {ground = (t, (ERel 0, #2 t)) :: #ground class, - rules = #rules class} + val rule = (nvs, cs, c, (ERel 0, #2 t)) + + val class = + if openCon t then + {openRules = rule :: #openRules class, + closedRules = #closedRules class} + else + {closedRules = rule :: #closedRules class, + openRules = #openRules class} in CM.insert (classes, f, class) end @@ -848,30 +893,6 @@ fun lookupERel (env : env) n = (List.nth (#relE env, n)) handle Subscript => raise UnboundRel n -fun rule_in c = - let - fun quantifiers (c, nvars) = - case #1 c of - TCFun (_, _, _, c) => quantifiers (c, nvars + 1) - | _ => - let - fun clauses (c, hyps) = - case #1 c of - TFun (hyp, c) => - (case class_head_in hyp of - SOME _ => clauses (c, hyp :: hyps) - | NONE => NONE) - | _ => - case class_head_in c of - NONE => NONE - | SOME f => SOME (f, nvars, rev hyps, c) - in - clauses (c, []) - end - in - quantifiers (c, 0) - end - fun pushENamedAs (env : env) x n t = let val classes = #classes env @@ -885,8 +906,8 @@ fun pushENamedAs (env : env) x n t = val e = (ENamed n, #2 t) val class = - {ground = #ground class, - rules = (nvs, cs, c, e) :: #rules class} + {openRules = #openRules class, + closedRules = (nvs, cs, c, e) :: #closedRules class} in CM.insert (classes, f, class) end @@ -1210,11 +1231,11 @@ fun enrichClasses env classes (m1, ms) sgn = val e = (EModProj (m1, ms, x), #2 sgn) val class = - {ground = #ground class, - rules = (nvs, - map globalize cs, - globalize c, - e) :: #rules class} + {openRules = #openRules class, + closedRules = (nvs, + map globalize cs, + globalize c, + e) :: #closedRules class} in CM.insert (classes, cn, class) end @@ -1236,11 +1257,11 @@ fun enrichClasses env classes (m1, ms) sgn = val e = (EModProj (m1, ms, x), #2 sgn) val class = - {ground = #ground class, - rules = (nvs, - map globalize cs, - globalize c, - e) :: #rules class} + {openRules = #openRules class, + closedRules = (nvs, + map globalize cs, + globalize c, + e) :: #closedRules class} in CM.insert (classes, cn, class) end diff --git a/src/elab_util.sig b/src/elab_util.sig index b63d9b7f..6c08442b 100644 --- a/src/elab_util.sig +++ b/src/elab_util.sig @@ -112,6 +112,11 @@ structure Exp : sig val exists : {kind : Elab.kind' -> bool, con : Elab.con' -> bool, exp : Elab.exp' -> bool} -> Elab.exp -> bool + val existsB : {kind : 'context * Elab.kind' -> bool, + con : 'context * Elab.con' -> bool, + exp : 'context * Elab.exp' -> bool, + bind : 'context * binder -> 'context} + -> 'context -> Elab.exp -> bool val foldB : {kind : 'context * Elab.kind' * 'state -> 'state, con : 'context * Elab.con' * 'state -> 'state, diff --git a/src/elab_util.sml b/src/elab_util.sml index b799bbc4..97e3b572 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -568,6 +568,26 @@ fun mapfold {kind = fk, con = fc, exp = fe} = exp = fn () => fe, bind = fn ((), _) => ()} () +fun existsB {kind, con, exp, bind} ctx e = + case mapfoldB {kind = fn ctx => fn k => fn () => + if kind (ctx, k) then + S.Return () + else + S.Continue (k, ()), + con = fn ctx => fn c => fn () => + if con (ctx, c) then + S.Return () + else + S.Continue (c, ()), + exp = fn ctx => fn e => fn () => + if exp (ctx, e) then + S.Return () + else + S.Continue (e, ()), + bind = bind} ctx e () of + S.Return _ => true + | S.Continue _ => false + fun exists {kind, con, exp} k = case mapfold {kind = fn k => fn () => if kind k then diff --git a/src/source_print.sig b/src/source_print.sig index 042e6a23..f5b0df29 100644 --- a/src/source_print.sig +++ b/src/source_print.sig @@ -33,6 +33,7 @@ signature SOURCE_PRINT = sig val p_con : Source.con Print.printer val p_exp : Source.exp Print.printer val p_decl : Source.decl Print.printer + val p_edecl : Source.edecl Print.printer val p_sgn_item : Source.sgn_item Print.printer val p_str : Source.str Print.printer val p_file : Source.file Print.printer -- cgit v1.2.3 From dff81b1a774536c0da5e9650855dfbfc37101419 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 26 Jul 2012 10:04:58 -0400 Subject: Remove misguided type class optimization --- src/elab_env.sml | 25 ++----------------------- 1 file changed, 2 insertions(+), 23 deletions(-) (limited to 'src/elab_env.sml') diff --git a/src/elab_env.sml b/src/elab_env.sml index df031288..f31804f2 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -163,22 +163,6 @@ val subExpInExp = | ((xn, rep), U.Exp.RelC _) => (xn, liftConInExp 0 rep) | (ctx, _) => ctx} -val openCon = - U.Con.existsB {kind = fn ((nk, _), k) => - case k of - KRel n => n >= nk - | _ => false, - con = fn ((_, nc), c) => - case c of - CRel n => n >= nc - | _ => false, - bind = fn (all as (nk, nc), b) => - case b of - U.Con.RelK _ => (nk+1, nc) - | U.Con.RelC _ => (nk, nc+1) - | _ => all} - (0, 0) - (* Back to environments *) datatype 'a var' = @@ -855,13 +839,8 @@ fun pushERel (env : env) x t = let val rule = (nvs, cs, c, (ERel 0, #2 t)) - val class = - if openCon t then - {openRules = rule :: #openRules class, - closedRules = #closedRules class} - else - {closedRules = rule :: #closedRules class, - openRules = #openRules class} + val class = {openRules = rule :: #openRules class, + closedRules = #closedRules class} in CM.insert (classes, f, class) end -- cgit v1.2.3 From 4211ec9bd6e9d8172f74cdb56a1207fc1d64990f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 29 Jul 2012 12:27:13 -0400 Subject: Remove 'class' declaration; now use 'con' instead --- doc/manual.tex | 46 +++++++++++++++++++++++----------------------- src/elab.sml | 1 - src/elab_env.sml | 7 ------- src/elab_print.sml | 11 ----------- src/elab_util.sml | 10 ---------- src/elaborate.sml | 18 +++--------------- src/explify.sml | 2 -- src/source.sml | 1 - src/source_print.sml | 7 ------- src/unnest.sml | 1 - src/urweb.grm | 19 ------------------- 11 files changed, 26 insertions(+), 97 deletions(-) (limited to 'src/elab_env.sml') diff --git a/doc/manual.tex b/doc/manual.tex index c7a6491b..0b8f1c06 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -21,7 +21,7 @@ \section{Introduction} -\emph{Ur} is a programming language designed to introduce richer type system features into functional programming in the tradition of ML and Haskell. Ur is functional, pure, statically-typed, and strict. Ur supports a powerful kind of \emph{metaprogramming} based on \emph{type-level computation with type-level records}. +\emph{Ur} is a programming language designed to introduce richer type system features into functional programming in the tradition of ML and Haskell. Ur is functional, pure, statically typed, and strict. Ur supports a powerful kind of \emph{metaprogramming} based on \emph{type-level computation with type-level records}. \emph{Ur/Web} is Ur plus a special standard library and associated rules for parsing and optimization. Ur/Web supports construction of dynamic web applications backed by SQL databases. The signature of the standard library is such that well-typed Ur/Web programs ``don't go wrong'' in a very broad sense. Not only do they not crash during particular page generations, but they also may not: @@ -155,7 +155,7 @@ Here is the complete list of directive forms. ``FFI'' stands for ``foreign func \item \texttt{deltas}: maximum number of messages sendable in a single request handler with \texttt{Basis.send} \item \texttt{globals}: maximum number of global variables that FFI libraries may set in a single request context \item \texttt{headers}: maximum size (in bytes) of per-request buffer used to hold HTTP headers for generated pages - \item \texttt{heap}: maximum size (in bytes) of per-request heap for dynamically-allocated data + \item \texttt{heap}: maximum size (in bytes) of per-request heap for dynamically allocated data \item \texttt{inputs}: maximum number of top-level form fields per request \item \texttt{messages}: maximum size (in bytes) of per-request buffer used to hold a single outgoing message sent with \texttt{Basis.send} \item \texttt{page}: maximum size (in bytes) of per-request buffer used to hold HTML content of generated pages @@ -522,7 +522,7 @@ $$\begin{array}{rrcll} &&& (e) & \textrm{explicit precedence} \\ \\ \textrm{Local declarations} & ed &::=& \cd{val} \; x : \tau = e & \textrm{non-recursive value} \\ - &&& \cd{val} \; \cd{rec} \; (x : \tau = e \; \cd{and})^+ & \textrm{mutually-recursive values} \\ + &&& \cd{val} \; \cd{rec} \; (x : \tau = e \; \cd{and})^+ & \textrm{mutually recursive values} \\ \end{array}$$ As with constructors, we include both abstraction and application for kind polymorphism, but applications are only inferred internally. @@ -533,7 +533,7 @@ $$\begin{array}{rrcll} &&& \mt{datatype} \; x \; x^* = dc\mid^+ & \textrm{algebraic datatype definition} \\ &&& \mt{datatype} \; x = \mt{datatype} \; M.x & \textrm{algebraic datatype import} \\ &&& \mt{val} \; x : \tau = e & \textrm{value} \\ - &&& \mt{val} \; \cd{rec} \; (x : \tau = e \; \mt{and})^+ & \textrm{mutually-recursive values} \\ + &&& \mt{val} \; \cd{rec} \; (x : \tau = e \; \mt{and})^+ & \textrm{mutually recursive values} \\ &&& \mt{structure} \; X : S = M & \textrm{module definition} \\ &&& \mt{signature} \; X = S & \textrm{signature definition} \\ &&& \mt{open} \; M & \textrm{module inclusion} \\ @@ -544,7 +544,6 @@ $$\begin{array}{rrcll} &&& \mt{sequence} \; x & \textrm{SQL sequence} \\ &&& \mt{cookie} \; x : \tau & \textrm{HTTP cookie} \\ &&& \mt{style} \; x : \tau & \textrm{CSS class} \\ - &&& \mt{class} \; x :: \kappa = c & \textrm{concrete constructor class} \\ &&& \mt{task} \; e = e & \textrm{recurring task} \\ \\ \textrm{Modules} & M &::=& \mt{struct} \; d^* \; \mt{end} & \textrm{constant} \\ @@ -590,7 +589,7 @@ At the expression level, an analogue is available of the composite $\lambda$ for A local $\mt{val}$ declaration may bind a pattern instead of just a plain variable. As for function arguments, only irrefutable patterns are legal. -The keyword $\mt{fun}$ is a shorthand for $\mt{val} \; \mt{rec}$ that allows arguments to be specified before the equal sign in the definition of each mutually-recursive function, as in SML. Each curried argument must follow the grammar of the $b$ non-terminal introduced two paragraphs ago. A $\mt{fun}$ declaration is elaborated into a version that adds additional $\lambda$s to the fronts of the righthand sides, as appropriate. +The keyword $\mt{fun}$ is a shorthand for $\mt{val} \; \mt{rec}$ that allows arguments to be specified before the equal sign in the definition of each mutually recursive function, as in SML. Each curried argument must follow the grammar of the $b$ non-terminal introduced two paragraphs ago. A $\mt{fun}$ declaration is elaborated into a version that adds additional $\lambda$s to the fronts of the righthand sides, as appropriate. A signature item $\mt{functor} \; X_1 \; (X_2 : S_1) : S_2$ is elaborated into $\mt{structure} \; X_1 : \mt{functor}(X_2 : S_1) : S_2$. A declaration $\mt{functor} \; X_1 \; (X_2 : S_1) : S_2 = M$ is elaborated into $\mt{structure} \; X_1 : \mt{functor}(X_2 : S_1) : S_2 = \mt{functor}(X_2 : S_1) : S_2 = M$. @@ -949,8 +948,6 @@ $$\infer{\Gamma \vdash p : \tau \leadsto \Gamma'; \tau}{ We use an auxiliary judgment $\overline{y}; x; \Gamma \vdash \overline{dc} \leadsto \Gamma'$, expressing the enrichment of $\Gamma$ with the types of the datatype constructors $\overline{dc}$, when they are known to belong to datatype $x$ with type parameters $\overline{y}$. -This is the first judgment where we deal with constructor classes, for the $\mt{class}$ declaration form. We will omit their special handling in this formal specification. Section \ref{typeclasses} gives an informal description of how constructor classes influence type inference. - We presuppose the existence of a function $\mathcal O$, where $\mathcal O(M, \overline{s})$ implements the $\mt{open}$ declaration by producing a context with the appropriate entry for each available component of module $M$ with signature items $\overline{s}$. Where possible, $\mathcal O$ uses ``transparent'' entries (e.g., an abstract type $M.x$ is mapped to $x :: \mt{Type} = M.x$), so that the relationship with $M$ is maintained. A related function $\mathcal O_c$ builds a context containing the disjointness constraints found in $\overline s$. We write $\kappa_1^n \to \kappa$ as a shorthand, where $\kappa_1^0 \to \kappa = \kappa$ and $\kappa_1^{n+1} \to \kappa_2 = \kappa_1 \to (\kappa_1^n \to \kappa_2)$. We write $\mt{len}(\overline{y})$ for the length of vector $\overline{y}$ of variables. @@ -1026,10 +1023,6 @@ $$\infer{\Gamma \vdash \mt{task} \; e_1 = e_2 \leadsto \Gamma}{ & \Gamma \vdash e_2 :: \tau \to \mt{Basis}.\mt{transaction} \; \{\} }$$ -$$\infer{\Gamma \vdash \mt{class} \; x :: \kappa = c \leadsto \Gamma, x :: \kappa = c}{ - \Gamma \vdash c :: \kappa -}$$ - $$\infer{\overline{y}; x; \Gamma \vdash \cdot \leadsto \Gamma}{} \quad \infer{\overline{y}; x; \Gamma \vdash X \mid \overline{dc} \leadsto \Gamma', X : \overline{y ::: \mt{Type}} \to x \; \overline{y}}{ \overline{y}; x; \Gamma \vdash \overline{dc} \leadsto \Gamma' @@ -1042,6 +1035,8 @@ $$\infer{\overline{y}; x; \Gamma \vdash \cdot \leadsto \Gamma}{} We appeal to a signature item analogue of the $\mathcal O$ function from the last subsection. +This is the first judgment where we deal with constructor classes, for the $\mt{class}$ forms. We will omit their special handling in this formal specification. Section \ref{typeclasses} gives an informal description of how constructor classes influence type inference. + $$\infer{\Gamma \vdash \cdot \leadsto \Gamma}{} \quad \infer{\Gamma \vdash s, \overline{s} \leadsto \Gamma''}{ \Gamma \vdash s \leadsto \Gamma' @@ -1090,7 +1085,7 @@ $$\infer{\Gamma \vdash \mt{class} \; x :: \kappa = c \leadsto \Gamma, x :: \kapp \subsection{Signature Compatibility} -To simplify the judgments in this section, we assume that all signatures are alpha-varied as necessary to avoid including multiple bindings for the same identifier. This is in addition to the usual alpha-variation of locally-bound variables. +To simplify the judgments in this section, we assume that all signatures are alpha-varied as necessary to avoid including multiple bindings for the same identifier. This is in addition to the usual alpha-variation of locally bound variables. We rely on a judgment $\Gamma \vdash \overline{s} \leq s'$, which expresses the occurrence in signature items $\overline{s}$ of an item compatible with $s'$. We also use a judgment $\Gamma \vdash \overline{dc} \leq \overline{dc}$, which expresses compatibility of datatype definitions. @@ -1201,6 +1196,12 @@ $$\infer{\Gamma \vdash \mt{class} \; x :: \kappa \leq \mt{class} \; x :: \kappa} \Gamma \vdash c_1 \equiv c_2 }$$ +$$\infer{\Gamma \vdash \mt{con} \; x :: \kappa \leq \mt{class} \; x :: \kappa}{} +\quad \infer{\Gamma \vdash \mt{con} \; x :: \kappa = c \leq \mt{class} \; x :: \kappa}{} +\quad \infer{\Gamma \vdash \mt{con} \; x :: \kappa = c_1 \leq \mt{class} \; x :: \kappa = c_2}{ + \Gamma \vdash c_1 \equiv c_2 +}$$ + \subsection{Module Typing} We use a helper function $\mt{sigOf}$, which converts declarations and sequences of declarations into their principal signature items and sequences of signature items, respectively. @@ -1249,8 +1250,7 @@ $$\infer{\Gamma \vdash M_1(M_2) : [X \mapsto M_2]S_2}{ \mt{sigOf}(\mt{view} \; x = e) &=& \mt{view} \; x : c \textrm{ (where $\Gamma \vdash e : \mt{Basis}.\mt{sql\_query} \; [] \; [] \; (\mt{map} \; (\lambda \_ \Rightarrow []) \; c') \; c$)} \\ \mt{sigOf}(\mt{sequence} \; x) &=& \mt{sequence} \; x \\ \mt{sigOf}(\mt{cookie} \; x : \tau) &=& \mt{cookie} \; x : \tau \\ - \mt{sigOf}(\mt{style} \; x) &=& \mt{style} \; x \\ - \mt{sigOf}(\mt{class} \; x :: \kappa = c) &=& \mt{class} \; x :: \kappa = c \\ + \mt{sigOf}(\mt{style} \; x) &=& \mt{style} \; x \end{eqnarray*} \begin{eqnarray*} \mt{selfify}(M, \cdot) &=& \cdot \\ @@ -1329,11 +1329,11 @@ The type inference engine tries to take advantage of the algebraic rules governi Ur includes a constructor class facility inspired by Haskell's. The current version is experimental, with very general Prolog-like facilities that can lead to compile-time non-termination. -Constructor classes are integrated with the module system. A constructor class of kind $\kappa$ is just a constructor of kind $\kappa$. By marking such a constructor $c$ as a constructor class, the programmer instructs the type inference engine to, in each scope, record all values of types $c \; c_1 \; \ldots \; c_n$ as \emph{instances}. Any function argument whose type is of such a form is treated as implicit, to be determined by examining the current instance database. +Constructor classes are integrated with the module system. A constructor class of kind $\kappa$ is just a constructor of kind $\kappa$. By marking such a constructor $c$ as a constructor class, the programmer instructs the type inference engine to, in each scope, record all values of types $c \; c_1 \; \ldots \; c_n$ as \emph{instances}. Any function argument whose type is of such a form is treated as implicit, to be determined by examining the current instance database. Any suitably kinded constructor within a module may be exposed as a constructor class from outside the module, simply by using a $\mt{class}$ signature item instead of a $\mt{con}$ signature item in the module's signature. -The ``dictionary encoding'' often used in Haskell implementations is made explicit in Ur. Constructor class instances are just properly-typed values, and they can also be considered as ``proofs'' of membership in the class. In some cases, it is useful to pass these proofs around explicitly. An underscore written where a proof is expected will also be inferred, if possible, from the current instance database. +The ``dictionary encoding'' often used in Haskell implementations is made explicit in Ur. Constructor class instances are just properly typed values, and they can also be considered as ``proofs'' of membership in the class. In some cases, it is useful to pass these proofs around explicitly. An underscore written where a proof is expected will also be inferred, if possible, from the current instance database. -Just as for constructors, constructors classes may be exported from modules, and they may be exported as concrete or abstract. Concrete constructor classes have their ``real'' definitions exposed, so that client code may add new instances freely. Abstract constructor classes are useful as ``predicates'' that can be used to enforce invariants, as we will see in some definitions of SQL syntax in the Ur/Web standard library. +Just as for constructors, constructors classes may be exported from modules, and they may be exported as concrete or abstract. Concrete constructor classes have their ``real'' definitions exposed, so that client code may add new instances freely. Automatic inference of concrete class instances will not generally work, so abstract classes are almost always the right choice. They are useful as ``predicates'' that can be used to enforce invariants, as we will see in some definitions of SQL syntax in the Ur/Web standard library. Free extension of a concrete class is easily supported by exporting a constructor function from a module, since the class implementation will be concrete within the module. \subsection{Reverse-Engineering Record Types} @@ -1434,7 +1434,7 @@ $$\begin{array}{l} \subsection{HTTP} -There are transactions for reading an HTTP header by name and for getting and setting strongly-typed cookies. Cookies may only be created by the $\mt{cookie}$ declaration form, ensuring that they be named consistently based on module structure. For now, cookie operations are server-side only. +There are transactions for reading an HTTP header by name and for getting and setting strongly typed cookies. Cookies may only be created by the $\mt{cookie}$ declaration form, ensuring that they be named consistently based on module structure. For now, cookie operations are server-side only. $$\begin{array}{l} \mt{con} \; \mt{http\_cookie} :: \mt{Type} \to \mt{Type} \\ \mt{val} \; \mt{getCookie} : \mt{t} ::: \mt{Type} \to \mt{http\_cookie} \; \mt{t} \to \mt{transaction} \; (\mt{option} \; \mt{t}) \\ @@ -1777,7 +1777,7 @@ $$\begin{array}{l} \mt{val} \; \mt{sql\_mod} : \mt{sql\_binary} \; \mt{int} \; \mt{int} \; \mt{int} \end{array}$$ -Finally, we have aggregate functions. The $\mt{COUNT(\ast)}$ syntax is handled specially, since it takes no real argument. The other aggregate functions are placed into a general type family, using constructor classes to restrict usage to properly-typed arguments. The key aspect of the $\mt{sql\_aggregate}$ function's type is the shift of aggregate-function-only fields into unrestricted fields. +Finally, we have aggregate functions. The $\mt{COUNT(\ast)}$ syntax is handled specially, since it takes no real argument. The other aggregate functions are placed into a general type family, using constructor classes to restrict usage to properly typed arguments. The key aspect of the $\mt{sql\_aggregate}$ function's type is the shift of aggregate-function-only fields into unrestricted fields. $$\begin{array}{l} \mt{val} \; \mt{sql\_count} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{int} \end{array}$$ @@ -1939,7 +1939,7 @@ $$\begin{array}{l} \mt{val} \; \mt{tryDml} : \mt{dml} \to \mt{transaction} \; (\mt{option} \; \mt{string}) \end{array}$$ -Properly-typed records may be used to form $\mt{INSERT}$ commands. +Properly typed records may be used to form $\mt{INSERT}$ commands. $$\begin{array}{l} \mt{val} \; \mt{insert} : \mt{fields} ::: \{\mt{Type}\} \to \mt{sql\_table} \; \mt{fields} \\ \hspace{.1in} \to \$(\mt{map} \; (\mt{sql\_exp} \; [] \; [] \; []) \; \mt{fields}) \to \mt{dml} @@ -2306,7 +2306,7 @@ Similar support is provided for \cd{style} attributes. Normal CSS syntax may be \section{\label{structure}The Structure of Web Applications} -A web application is built from a series of modules, with one module, the last one appearing in the \texttt{.urp} file, designated as the main module. The signature of the main module determines the URL entry points to the application. Such an entry point should have type $\mt{t1} \to \ldots \to \mt{tn} \to \mt{transaction} \; \mt{page}$, for any integer $n \geq 0$, where $\mt{page}$ is a type synonym for top-level HTML pages, defined in $\mt{Basis}$. If such a function is at the top level of main module $M$, with $n = 0$, it will be accessible at URI \texttt{/M/f}, and so on for more deeply-nested functions, as described in Section \ref{tag} below. See Section \ref{cl} for information on the \texttt{prefix} and \texttt{rewrite url} directives, which can be used to rewrite the default URIs of different entry point functions. The final URL of a function is its default module-based URI, with \texttt{rewrite url} rules applied, and with the \texttt{prefix} prepended. Arguments to an entry-point function are deserialized from the part of the URI following \texttt{f}. +A web application is built from a series of modules, with one module, the last one appearing in the \texttt{.urp} file, designated as the main module. The signature of the main module determines the URL entry points to the application. Such an entry point should have type $\mt{t1} \to \ldots \to \mt{tn} \to \mt{transaction} \; \mt{page}$, for any integer $n \geq 0$, where $\mt{page}$ is a type synonym for top-level HTML pages, defined in $\mt{Basis}$. If such a function is at the top level of main module $M$, with $n = 0$, it will be accessible at URI \texttt{/M/f}, and so on for more deeply nested functions, as described in Section \ref{tag} below. See Section \ref{cl} for information on the \texttt{prefix} and \texttt{rewrite url} directives, which can be used to rewrite the default URIs of different entry point functions. The final URL of a function is its default module-based URI, with \texttt{rewrite url} rules applied, and with the \texttt{prefix} prepended. Arguments to an entry-point function are deserialized from the part of the URI following \texttt{f}. Elements of modules beside the main module, including page handlers, will only be included in the final application if they are transitive dependencies of the handlers in the main module. @@ -2506,7 +2506,7 @@ Functions are specialized to particular argument patterns. This is an important \subsection{Untangle} -Remove unnecessary mutual recursion, splitting recursive groups into strongly-connected components. +Remove unnecessary mutual recursion, splitting recursive groups into strongly connected components. \subsection{Shake} diff --git a/src/elab.sml b/src/elab.sml index 15365951..9147f7d3 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -175,7 +175,6 @@ datatype decl' = | DTable of int * string * int * con * exp * con * exp * con | DSequence of int * string * int | DView of int * string * int * exp * con - | DClass of string * int * kind * con | DDatabase of string | DCookie of int * string * int * con | DStyle of int * string * int diff --git a/src/elab_env.sml b/src/elab_env.sml index f31804f2..5d684817 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1647,13 +1647,6 @@ fun declBinds env (d, loc) = in pushENamedAs env x n ct end - | DClass (x, n, k, c) => - let - val k = (KArrow (k, (KType, loc)), loc) - val env = pushCNamedAs env x n k (SOME c) - in - pushClass env n - end | DDatabase _ => env | DCookie (tn, x, n, c) => let diff --git a/src/elab_print.sml b/src/elab_print.sml index 37669312..c32368a9 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -828,17 +828,6 @@ fun p_decl env (dAll as (d, _) : decl) = string "as", space, p_exp env e] - | DClass (x, n, k, c) => box [string "class", - space, - p_named x n, - space, - string "::", - space, - p_kind env k, - space, - string "=", - space, - p_con env c] | DDatabase s => box [string "database", space, string s] diff --git a/src/elab_util.sml b/src/elab_util.sml index 97e3b572..51bcba5a 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -919,8 +919,6 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f in bind (ctx, NamedE (x, ct)) end - | DClass (x, n, k, c) => - bind (ctx, NamedC (x, n, (KArrow (k, (KType, loc)), loc), SOME c)) | DDatabase _ => ctx | DCookie (tn, x, n, c) => bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "cookie"), loc), @@ -1040,13 +1038,6 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f fn c' => (DView (tn, x, n, e', c'), loc))) - | DClass (x, n, k, c) => - S.bind2 (mfk ctx k, - fn k' => - S.map2 (mfc ctx c, - fn c' => - (DClass (x, n, k', c'), loc))) - | DDatabase _ => S.return2 dAll | DCookie (tn, x, n, c) => @@ -1233,7 +1224,6 @@ and maxNameDecl (d, _) = | DSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn) | DFfiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn) | DConstraint _ => 0 - | DClass (_, n, _, _) => n | DExport _ => 0 | DTable (n1, _, n2, _, _, _, _, _) => Int.max (n1, n2) | DSequence (n1, _, n2) => Int.max (n1, n2) diff --git a/src/elaborate.sml b/src/elaborate.sml index 8436c975..426934bd 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2982,7 +2982,6 @@ and sgiOfDecl (d, loc) = | L'.DSequence (tn, x, n) => [(L'.SgiVal (x, n, sequenceOf ()), loc)] | L'.DView (tn, x, n, _, c) => [(L'.SgiVal (x, n, (L'.CApp (viewOf (), c), loc)), loc)] - | L'.DClass (x, n, k, c) => [(L'.SgiClass (x, n, k, c), loc)] | L'.DDatabase _ => [] | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)] @@ -3362,6 +3361,8 @@ and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = case sgi1 of L'.SgiClassAbs (x', n1, k1) => found (x', n1, k1, NONE) | L'.SgiClass (x', n1, k1, c) => found (x', n1, k1, SOME c) + | L'.SgiConAbs (x', n1, k1) => found (x', n1, k1, NONE) + | L'.SgiCon (x', n1, k1, c) => found (x', n1, k1, SOME c) | _ => NONE end) | L'.SgiClass (x, n2, k2, c2) => @@ -3401,6 +3402,7 @@ and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = in case sgi1 of L'.SgiClass (x', n1, k1, c1) => found (x', n1, k1, c1) + | L'.SgiCon (x', n1, k1, c1) => found (x', n1, k1, c1) | _ => NONE end) end @@ -3508,7 +3510,6 @@ and wildifyStr env (str, sgn) = fun dname (d, _) = case d of L.DCon (x, _, _) => SOME x - | L.DClass (x, _, _) => SOME x | _ => NONE fun decompileKind (k, loc) = @@ -3641,7 +3642,6 @@ and wildifyStr env (str, sgn) = foldl (fn ((d, _), nd) => case d of L.DCon (x, _, _) => ndelCon (nd, x) - | L.DClass (x, _, _) => ndelCon (nd, x) | L.DVal (x, _, _) => ndelVal (nd, x) | L.DOpen _ => nempty | L.DStr (x, _, _, (L.StrConst ds', _)) => @@ -3666,7 +3666,6 @@ and wildifyStr env (str, sgn) = | L.DDatatypeImp _ => true | L.DStr _ => true | L.DConstraint _ => true - | L.DClass _ => true | _ => false in if isCony then @@ -4184,17 +4183,6 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = (env', denv, gs' @ gs)) end - | L.DClass (x, k, c) => - let - val k = elabKind env k - val (c', ck, gs') = elabCon (env, denv) c - val (env, n) = E.pushCNamed env x k (SOME c') - val env = E.pushClass env n - in - checkKind env c' ck k; - ([(L'.DClass (x, n, k, c'), loc)], (env, denv, enD gs' @ gs)) - end - | L.DDatabase s => ([(L'.DDatabase s, loc)], (env, denv, gs)) | L.DCookie (x, c) => diff --git a/src/explify.sml b/src/explify.sml index 3c922a44..65e78443 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -192,8 +192,6 @@ fun explifyDecl (d, loc : EM.span) = | L.DView (nt, x, n, e, c) => SOME (L'.DView (nt, x, n, explifyExp e, explifyCon c), loc) | L.DSequence (nt, x, n) => SOME (L'.DSequence (nt, x, n), loc) - | L.DClass (x, n, k, c) => SOME (L'.DCon (x, n, - (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), explifyCon c), loc) | L.DDatabase s => SOME (L'.DDatabase s, loc) | L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc) | L.DStyle (nt, x, n) => SOME (L'.DStyle (nt, x, n), loc) diff --git a/src/source.sml b/src/source.sml index 8b126628..18f83d2b 100644 --- a/src/source.sml +++ b/src/source.sml @@ -163,7 +163,6 @@ datatype decl' = | DTable of string * con * exp * exp | DSequence of string | DView of string * exp - | DClass of string * kind * con | DDatabase of string | DCookie of string * con | DStyle of string diff --git a/src/source_print.sml b/src/source_print.sml index aad673f3..cd3314e1 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -640,13 +640,6 @@ fun p_decl ((d, _) : decl) = string "=", space, p_exp e] - | DClass (x, k, c) => box [string "class", - space, - string x, - space, - string "=", - space, - p_con c] | DDatabase s => box [string "database", space, diff --git a/src/unnest.sml b/src/unnest.sml index 2d6956cb..52d729d7 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -428,7 +428,6 @@ fun unnest file = | DTable _ => default () | DSequence _ => default () | DView _ => default () - | DClass _ => default () | DDatabase _ => default () | DCookie _ => default () | DStyle _ => default () diff --git a/src/urweb.grm b/src/urweb.grm index 708e5fcd..084cec1e 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -602,25 +602,6 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let s (VIEWleft, queryright))]) | VIEW SYMBOL EQ LBRACE eexp RBRACE ([(DView (SYMBOL, eexp), s (VIEWleft, RBRACEright))]) - | CLASS SYMBOL EQ cexp (let - val loc = s (CLASSleft, cexpright) - in - [(DClass (SYMBOL, (KWild, loc), cexp), loc)] - end) - | CLASS SYMBOL DCOLON kind EQ cexp ([(DClass (SYMBOL, kind, cexp), s (CLASSleft, cexpright))]) - | CLASS SYMBOL SYMBOL EQ cexp (let - val loc = s (CLASSleft, cexpright) - val k = (KWild, loc) - val c = (CAbs (SYMBOL2, SOME k, cexp), loc) - in - [(DClass (SYMBOL1, k, c), s (CLASSleft, cexpright))] - end) - | CLASS SYMBOL LPAREN SYMBOL DCOLON kind RPAREN EQ cexp (let - val loc = s (CLASSleft, cexpright) - val c = (CAbs (SYMBOL2, SOME kind, cexp), loc) - in - [(DClass (SYMBOL1, kind, c), s (CLASSleft, cexpright))] - end) | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))]) | STYLE SYMBOL ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))]) | TASK eapps EQ eexp ([(DTask (eapps, eexp), s (TASKleft, eexpright))]) -- cgit v1.2.3 From f718e640c3cbe6a891519364992117f49ca333fa Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Mon, 19 Aug 2013 12:25:32 -0400 Subject: Allow [where con] to descend within submodule structure; open submodule constraints while checking later signature items --- src/elab.sml | 2 +- src/elab_env.sml | 58 +++++++++++++++++++++++++++++++---------------- src/elab_print.sml | 22 +++++++++--------- src/elab_util.sml | 6 ++--- src/elaborate.sml | 64 ++++++++++++++++++++++++++++++++++++---------------- src/expl.sml | 2 +- src/expl_print.sml | 4 ++-- src/expl_util.sml | 4 ++-- src/explify.sml | 2 +- src/source.sml | 2 +- src/source_print.sml | 24 +++++++++++--------- src/urweb.grm | 4 ++-- 12 files changed, 120 insertions(+), 74 deletions(-) (limited to 'src/elab_env.sml') diff --git a/src/elab.sml b/src/elab.sml index 9147f7d3..2dab5c34 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -154,7 +154,7 @@ and sgn' = SgnConst of sgn_item list | SgnVar of int | SgnFun of string * int * sgn * sgn - | SgnWhere of sgn * string * con + | SgnWhere of sgn * string list * string * con | SgnProj of int * string list * string | SgnError diff --git a/src/elab_env.sml b/src/elab_env.sml index 5d684817..465fb7e4 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1126,26 +1126,44 @@ and hnormSgn env (all as (sgn, loc)) = NONE => raise Fail "ElabEnv.hnormSgn: projectSgn failed" | SOME sgn => hnormSgn env sgn end - | SgnWhere (sgn, x, c) => - case #1 (hnormSgn env sgn) of - SgnError => (SgnError, loc) - | SgnConst sgis => - let - fun traverse (pre, post) = - case post of - [] => raise Fail "ElabEnv.hnormSgn: Can't reduce 'where' [1]" - | (sgi as (SgiConAbs (x', n, k), loc)) :: rest => - if x = x' then - List.revAppend (pre, (SgiCon (x', n, k, c), loc) :: rest) - else - traverse (sgi :: pre, rest) - | sgi :: rest => traverse (sgi :: pre, rest) - - val sgis = traverse ([], sgis) - in - (SgnConst sgis, loc) - end - | _ => raise Fail "ElabEnv.hnormSgn: Can't reduce 'where' [2]" + | SgnWhere (sgn, ms, x, c) => + let + fun rewrite (sgn, ms) = + case #1 (hnormSgn env sgn) of + SgnError => (SgnError, loc) + | SgnConst sgis => + let + fun traverse (ms, pre, post) = + case post of + [] => raise Fail "ElabEnv.hnormSgn: Can't reduce 'where' [1]" + + | (sgi as (SgiConAbs (x', n, k), loc)) :: rest => + if List.null ms andalso x = x' then + List.revAppend (pre, (SgiCon (x', n, k, c), loc) :: rest) + else + traverse (ms, sgi :: pre, rest) + + | (sgi as (SgiStr (x', n, sgn'), loc)) :: rest => + (case ms of + [] => traverse (ms, sgi :: pre, rest) + | x :: ms' => + if x = x' then + List.revAppend (pre, + (SgiStr (x', n, + rewrite (sgn', ms')), loc) :: rest) + else + traverse (ms, sgi :: pre, rest)) + + | sgi :: rest => traverse (ms, sgi :: pre, rest) + + val sgis = traverse (ms, [], sgis) + in + (SgnConst sgis, loc) + end + | _ => raise Fail "ElabEnv.hnormSgn: Can't reduce 'where' [2]" + in + rewrite (sgn, ms) + end fun manifest (m, ms, loc) = foldl (fn (m, str) => (StrProj (str, m), loc)) (StrVar m, loc) ms diff --git a/src/elab_print.sml b/src/elab_print.sml index c32368a9..7ce94c97 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -680,17 +680,17 @@ and p_sgn env (sgn, _) = string ":", space, p_sgn (E.pushStrNamedAs env x n sgn) sgn'] - | SgnWhere (sgn, x, c) => box [p_sgn env sgn, - space, - string "where", - space, - string "con", - space, - string x, - space, - string "=", - space, - p_con env c] + | SgnWhere (sgn, ms, x, c) => box [p_sgn env sgn, + space, + string "where", + space, + string "con", + space, + p_list_sep (string ".") string (ms @ [x]), + space, + string "=", + space, + p_con env c] | SgnProj (m1, ms, x) => let val m1x = #1 (E.lookupStrNamed env m1) diff --git a/src/elab_util.sml b/src/elab_util.sml index 51bcba5a..60245585 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -759,12 +759,12 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = fn s2' => (SgnFun (m, n, s1', s2'), loc))) | SgnProj _ => S.return2 sAll - | SgnWhere (sgn, x, c) => + | SgnWhere (sgn, ms, x, c) => S.bind2 (sg ctx sgn, fn sgn' => S.map2 (con ctx c, fn c' => - (SgnWhere (sgn', x, c'), loc))) + (SgnWhere (sgn', ms, x, c'), loc))) | SgnError => S.return2 sAll in sg @@ -1248,7 +1248,7 @@ and maxNameSgn (sgn, _) = SgnConst sgis => foldl (fn (sgi, count) => Int.max (maxNameSgi sgi, count)) 0 sgis | SgnVar n => n | SgnFun (_, n, dom, ran) => Int.max (n, Int.max (maxNameSgn dom, maxNameSgn ran)) - | SgnWhere (sgn, _, _) => maxNameSgn sgn + | SgnWhere (sgn, _, _, _) => maxNameSgn sgn | SgnProj (n, _, _) => n | SgnError => 0 diff --git a/src/elaborate.sml b/src/elaborate.sml index 426934bd..18010244 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2012, Adam Chlipala +(* Copyright (c) 2008-2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -2640,8 +2640,9 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = let val (sgn', gs') = elabSgn (env, denv) sgn val (env', n) = E.pushStrNamed env x sgn' + val denv' = dopenConstraints (loc, env', denv) {str = x, strs = []} in - ([(L'.SgiStr (x, n, sgn'), loc)], (env', denv, gs' @ gs)) + ([(L'.SgiStr (x, n, sgn'), loc)], (env', denv', gs' @ gs)) end | L.SgiSgn (x, sgn) => @@ -2798,26 +2799,33 @@ and elabSgn (env, denv) (sgn, loc) = in ((L'.SgnFun (m, n, dom', ran'), loc), gs1 @ gs2) end - | L.SgnWhere (sgn, x, c) => + | L.SgnWhere (sgn, ms, x, c) => let val (sgn', ds1) = elabSgn (env, denv) sgn val (c', ck, ds2) = elabCon (env, denv) c - in - case #1 (hnormSgn env sgn') of - L'.SgnError => (sgnerror, []) - | L'.SgnConst sgis => - if List.exists (fn (L'.SgiConAbs (x', _, k), _) => - x' = x andalso - (unifyKinds env k ck - handle KUnify x => sgnError env (WhereWrongKind x); - true) - | _ => false) sgis then - ((L'.SgnWhere (sgn', x, c'), loc), ds1 @ ds2) - else - (sgnError env (UnWhereable (sgn', x)); - (sgnerror, [])) - | _ => (sgnError env (UnWhereable (sgn', x)); - (sgnerror, [])) + + fun checkPath (ms, sgn') = + case #1 (hnormSgn env sgn') of + L'.SgnConst sgis => + List.exists (fn (L'.SgiConAbs (x', _, k), _) => + List.null ms andalso x' = x andalso + (unifyKinds env k ck + handle KUnify x => sgnError env (WhereWrongKind x); + true) + | (L'.SgiStr (x', _, sgn''), _) => + (case ms of + [] => false + | m :: ms' => + m = x' andalso + checkPath (ms', sgn'')) + | _ => false) sgis + | _ => false + in + if checkPath (ms, sgn') then + ((L'.SgnWhere (sgn', ms, x, c'), loc), ds1 @ ds2) + else + (sgnError env (UnWhereable (sgn', x)); + (sgnerror, [])) end | L.SgnProj (m, ms, x) => (case E.lookupStr env m of @@ -3594,6 +3602,24 @@ and wildifyStr env (str, sgn) = (SOME f, SOME x) => SOME (L.CApp (f, x), loc) | _ => NONE) + | L'.CTuple cs => + let + val cs' = foldr (fn (c, cs') => + case cs' of + NONE => NONE + | SOME cs' => + case decompileCon env c of + NONE => NONE + | SOME c' => SOME (c' :: cs')) + (SOME []) cs + in + case cs' of + NONE => NONE + | SOME cs' => SOME (L.CTuple cs', loc) + end + + | L'.CMap _ => SOME (L.CMap, loc) + | c => (Print.preface ("WTF?", p_con env (c, loc)); NONE) fun buildNeeded env sgis = diff --git a/src/expl.sml b/src/expl.sml index 119c1d92..0d4e63cc 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -125,7 +125,7 @@ and sgn' = SgnConst of sgn_item list | SgnVar of int | SgnFun of string * int * sgn * sgn - | SgnWhere of sgn * string * con + | SgnWhere of sgn * string list * string * con | SgnProj of int * string list * string withtype sgn_item = sgn_item' located diff --git a/src/expl_print.sml b/src/expl_print.sml index d89b0512..a830dccb 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -569,13 +569,13 @@ and p_sgn env (sgn, loc) = string ":", space, p_sgn (E.pushStrNamed env x n sgn) sgn'] - | SgnWhere (sgn, x, c) => box [p_sgn env sgn, + | SgnWhere (sgn, ms, x, c) => box [p_sgn env sgn, space, string "where", space, string "con", space, - string x, + p_list_sep (string ".") string (ms @ [x]), space, string "=", space, diff --git a/src/expl_util.sml b/src/expl_util.sml index 1932d52d..ff55823f 100644 --- a/src/expl_util.sml +++ b/src/expl_util.sml @@ -526,12 +526,12 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = S.map2 (sg (bind (ctx, Str (m, s1'))) s2, fn s2' => (SgnFun (m, n, s1', s2'), loc))) - | SgnWhere (sgn, x, c) => + | SgnWhere (sgn, ms, x, c) => S.bind2 (sg ctx sgn, fn sgn' => S.map2 (con ctx c, fn c' => - (SgnWhere (sgn', x, c'), loc))) + (SgnWhere (sgn', ms, x, c'), loc))) | SgnProj _ => S.return2 sAll in sg diff --git a/src/explify.sml b/src/explify.sml index 65e78443..4c60bd20 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -162,7 +162,7 @@ and explifySgn (sgn, loc) = L.SgnConst sgis => (L'.SgnConst (List.mapPartial explifySgi sgis), loc) | L.SgnVar n => (L'.SgnVar n, loc) | L.SgnFun (m, n, dom, ran) => (L'.SgnFun (m, n, explifySgn dom, explifySgn ran), loc) - | L.SgnWhere (sgn, x, c) => (L'.SgnWhere (explifySgn sgn, x, explifyCon c), loc) + | L.SgnWhere (sgn, ms, x, c) => (L'.SgnWhere (explifySgn sgn, ms, x, explifyCon c), loc) | L.SgnProj x => (L'.SgnProj x, loc) | L.SgnError => raise Fail ("explifySgn: SgnError at " ^ EM.spanToString loc) diff --git a/src/source.sml b/src/source.sml index 18f83d2b..d66160db 100644 --- a/src/source.sml +++ b/src/source.sml @@ -100,7 +100,7 @@ and sgn' = SgnConst of sgn_item list | SgnVar of string | SgnFun of string * sgn * sgn - | SgnWhere of sgn * string * con + | SgnWhere of sgn * string list * string * con | SgnProj of string * string list * string and pat' = diff --git a/src/source_print.sml b/src/source_print.sml index cd3314e1..c8a38922 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -505,17 +505,19 @@ and p_sgn (sgn, _) = string ":", space, p_sgn sgn'] - | SgnWhere (sgn, x, c) => box [p_sgn sgn, - space, - string "where", - space, - string "con", - space, - string x, - space, - string "=", - space, - p_con c] + | SgnWhere (sgn, ms, x, c) => box [p_sgn sgn, + space, + string "where", + space, + string "con", + space, + p_list_sep (string ".") + string (ms @ [x]), + string x, + space, + string "=", + space, + p_con c] | SgnProj (m, ms, x) => p_list_sep (string ".") string (m :: ms @ [x]) diff --git a/src/urweb.grm b/src/urweb.grm index c2a48742..29019649 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -802,8 +802,8 @@ sgntm : SIG sgis END (SgnConst sgis, s (SIGleft, ENDright)) List.take (ms, length ms - 1), List.nth (ms, length ms - 1)), s (mpathleft, mpathright)) - | sgntm WHERE CON SYMBOL EQ cexp (SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright)) - | sgntm WHERE LTYPE SYMBOL EQ cexp(SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright)) + | sgntm WHERE CON path EQ cexp (SgnWhere (sgntm, #1 path, #2 path, cexp), s (sgntmleft, cexpright)) + | sgntm WHERE LTYPE path EQ cexp (SgnWhere (sgntm, #1 path, #2 path, cexp), s (sgntmleft, cexpright)) | LPAREN sgn RPAREN (sgn) cexpO : (NONE) -- cgit v1.2.3 From 0c83e8f7c345a27be3cae77eeb2d7cb8658e5e9c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 2 May 2014 19:19:09 -0400 Subject: New lessSafeFfi --- doc/manual.tex | 18 ++++++++++++ src/compiler.sml | 1 + src/corify.sml | 75 ++++++++++++++++++++++++++++++++++++++++++++----- src/elab.sml | 3 +- src/elab_env.sml | 1 + src/elab_print.sml | 1 + src/elab_util.sml | 8 +++++- src/elaborate.sml | 15 ++++++++++ src/elisp/urweb-mode.el | 2 +- src/expl.sml | 1 + src/expl_env.sml | 1 + src/expl_print.sml | 1 + src/expl_rename.sml | 10 +++++++ src/explify.sml | 1 + src/settings.sig | 7 +++++ src/settings.sml | 8 ++++++ src/source.sml | 8 ++++++ src/source_print.sml | 1 + src/unnest.sml | 1 + src/urweb.grm | 21 ++++++++++++-- src/urweb.lex | 1 + tests/lessSafeFfi.ur | 19 +++++++++++++ tests/lessSafeFfi.urp | 5 ++++ tests/lessSafeFfi.urs | 1 + 24 files changed, 198 insertions(+), 12 deletions(-) create mode 100644 tests/lessSafeFfi.ur create mode 100644 tests/lessSafeFfi.urp create mode 100644 tests/lessSafeFfi.urs (limited to 'src/elab_env.sml') diff --git a/doc/manual.tex b/doc/manual.tex index db4994a5..b233473e 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -2530,6 +2530,24 @@ FFI modules may introduce new tags as values with $\mt{Basis.tag}$ types. See \ The onus is on the coder of a new tag's interface to think about consequences for code injection attacks, messing with the DOM in ways that may break Ur/Web reactive programming, etc. +\subsection{The Less Safe FFI} + +An alternative interface is provided for declaring FFI functions inline within normal Ur/Web modules. This facility must be opted into with the \texttt{lessSafeFfi} \texttt{.urp} directive, since it breaks a crucial property, allowing code in a \texttt{.ur} file to break basic invariants of the Ur/Web type system. Without this option, one only needs to audit \texttt{.urp} files to be sure an application obeys the type-system rules. The alternative interface may be more convenient for such purposes as declaring an FFI function typed in terms of some type local to a module. + +When the less safe mode is enabled, declarations like this one are accepted, at the top level of a \texttt{.ur} file: +\begin{verbatim} + ffi foo : int -> int +\end{verbatim} + +Now \texttt{foo} is available as a normal function. If called in server-side code, and if the above declaration appeared in \texttt{bar.ur}, the C function will be linked as \texttt{uw\_Bar\_foo()}. It is also possible to declare an FFI function to be implemented in JavaScript, using a general facility for including modifiers in an FFI declaration. The modifiers appear before the colon, separated by spaces. Here are the available ones, which have the same semantics as corresponding \texttt{.urp} directives. +\begin{itemize} +\item \texttt{effectful} +\item \texttt{benignEffectful} +\item \texttt{clientOnly} +\item \texttt{serverOnly} +\item \texttt{jsFunc "putJsFuncNameHere"} +\end{itemize} + \section{Compiler Phases} diff --git a/src/compiler.sml b/src/compiler.sml index cc4e33c5..269a7824 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -874,6 +874,7 @@ fun parseUrp' accLibs fname = | "timeFormat" => Settings.setTimeFormat arg | "noMangleSql" => Settings.setMangleSql false | "html5" => Settings.setIsHtml5 true + | "lessSafeFfi" => Settings.setLessSafeFfi true | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); read () diff --git a/src/corify.sml b/src/corify.sml index 085b2eb8..b08ef7eb 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -643,6 +643,12 @@ fun corifyExp st (e, loc) = | L.ELet (x, t, e1, e2) => (L'.ELet (x, corifyCon st t, corifyExp st e1, corifyExp st e2), loc) +fun isTransactional (c, _) = + case c of + L'.TFun (_, c) => isTransactional c + | L'.CApp ((L'.CFfi ("Basis", "transaction"), _), _) => true + | _ => false + fun corifyDecl mods (all as (d, loc : EM.span), st) = case d of L.DCon (x, n, k, c) => @@ -970,12 +976,6 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = in transactify c end - - fun isTransactional (c, _) = - case c of - L'.TFun (_, c) => isTransactional c - | L'.CApp ((L'.CFfi ("Basis", "transaction"), _), _) => true - | _ => false in if isTransactional c then let @@ -1164,6 +1164,66 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = ([], st)) end + | L.DFfi (x, n, modes, t) => + let + val m = case St.name st of + [m] => m + | _ => (ErrorMsg.errorAt loc "Used 'ffi' declaration beneath module top level"; + "") + + val name = (m, x) + + val (st, n) = St.bindVal st x n + val s = doRestify Settings.Url (mods, x) + + val t' = corifyCon st t + + fun numArgs (t : L'.con) = + case #1 t of + L'.TFun (_, ran) => 1 + numArgs ran + | _ => 0 + + fun makeArgs (i, t : L'.con, acc) = + case #1 t of + L'.TFun (dom, ran) => makeArgs (i-1, ran, ((L'.ERel i, loc), dom) :: acc) + | _ => rev acc + + fun wrapAbs (i, t : L'.con, tTrans, e) = + case (#1 t, #1 tTrans) of + (L'.TFun (dom, ran), L'.TFun (_, ran')) => (L'.EAbs ("x" ^ Int.toString i, dom, ran, wrapAbs (i+1, ran, ran', e)), loc) + | _ => e + + fun getRan (t : L'.con) = + case #1 t of + L'.TFun (_, ran) => getRan ran + | _ => t + + fun addLastBit (t : L'.con) = + case #1 t of + L'.TFun (dom, ran) => (L'.TFun (dom, addLastBit ran), #2 t) + | _ => (L'.TFun ((L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc), t), loc) + + val e = (L'.EFfiApp (m, x, makeArgs (numArgs t' - 1, t', [])), loc) + val (e, tTrans) = if isTransactional t' then + ((L'.EAbs ("_", (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc), getRan t', e), loc), addLastBit t') + else + (e, t') + val e = wrapAbs (0, t', tTrans, e) + in + app (fn Source.Effectful => Settings.addEffectful name + | Source.BenignEffectful => Settings.addBenignEffectful name + | Source.ClientOnly => Settings.addClientOnly name + | Source.ServerOnly => Settings.addServerOnly name + | Source.JsFunc s => Settings.addJsFunc (name, s)) modes; + + if isTransactional t' andalso not (Settings.isBenignEffectful name) then + Settings.addEffectful name + else + (); + + ([(L'.DVal (x, n, t', e, s), loc)], st) + end + and corifyStr mods ((str, loc), st) = case str of L.StrConst ds => @@ -1237,7 +1297,8 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DStyle (_, _, n') => Int.max (n, n') | L.DTask _ => n | L.DPolicy _ => n - | L.DOnError _ => n) + | L.DOnError _ => n + | L.DFfi (_, n', _, _) => Int.max (n, n')) 0 ds and maxNameStr (str, _) = diff --git a/src/elab.sml b/src/elab.sml index 2dab5c34..249531f1 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2011, Adam Chlipala +(* Copyright (c) 2008-2011, 2014, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -181,6 +181,7 @@ datatype decl' = | DTask of exp * exp | DPolicy of exp | DOnError of int * string list * string + | DFfi of string * int * Source.ffi_mode list * con and str' = StrConst of decl list diff --git a/src/elab_env.sml b/src/elab_env.sml index 465fb7e4..9fbe7bd7 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1681,5 +1681,6 @@ fun declBinds env (d, loc) = | DTask _ => env | DPolicy _ => env | DOnError _ => env + | DFfi (x, n, _, t) => pushENamedAs env x n t end diff --git a/src/elab_print.sml b/src/elab_print.sml index 7ce94c97..957d4646 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -852,6 +852,7 @@ fun p_decl env (dAll as (d, _) : decl) = space, p_exp env e1] | DOnError _ => string "ONERROR" + | DFfi _ => string "FFI" and p_str env (str, _) = case str of diff --git a/src/elab_util.sml b/src/elab_util.sml index 60245585..fef55852 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -927,7 +927,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))) | DTask _ => ctx | DPolicy _ => ctx - | DOnError _ => ctx, + | DOnError _ => ctx + | DFfi (x, _, _, t) => bind (ctx, NamedE (x, t)), mfd ctx d)) ctx ds, fn ds' => (StrConst ds', loc)) | StrVar _ => S.return2 strAll @@ -1056,6 +1057,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f fn e1' => (DPolicy e1', loc)) | DOnError _ => S.return2 dAll + | DFfi (x, n, modes, t) => + S.map2 (mfc ctx t, + fn t' => + (DFfi (x, n, modes, t'), loc)) and mfvi ctx (x, n, c, e) = S.bind2 (mfc ctx c, @@ -1234,6 +1239,7 @@ and maxNameDecl (d, _) = | DTask _ => 0 | DPolicy _ => 0 | DOnError _ => 0 + | DFfi (_, n, _, _) => n and maxNameStr (str, _) = case str of StrConst ds => maxName ds diff --git a/src/elaborate.sml b/src/elaborate.sml index 97ac610b..d492883f 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2999,6 +2999,7 @@ and sgiOfDecl (d, loc) = | L'.DTask _ => [] | L'.DPolicy _ => [] | L'.DOnError _ => [] + | L'.DFfi (x, n, _, t) => [(L'.SgiVal (x, n, t), loc)] and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), @@ -4298,6 +4299,20 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = ([(L'.DOnError (n, ms, s), loc)], (env, denv, gs)) end) + | L.DFfi (x, modes, t) => + let + val () = if Settings.getLessSafeFfi () then + () + else + ErrorMsg.errorAt loc "To enable 'ffi' declarations, the .urp directive 'lessSafeFfi' is mandatory." + + val (t', _, gs1) = elabCon (env, denv) t + val t' = normClassConstraint env t' + val (env', n) = E.pushENamed env x t' + in + ([(L'.DFfi (x, n, modes, t'), loc)], (env', denv, enD gs1 @ gs)) + end + (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) in (*prefaces "/elabDecl" [("d", SourcePrint.p_decl dAll), diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index f183a9ab..edbff1b0 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -139,7 +139,7 @@ See doc for the variable `urweb-mode-info'." "of" "open" "let" "in" "rec" "sequence" "sig" "signature" "cookie" "style" "task" "policy" "struct" "structure" "table" "view" "then" "type" "val" "where" - "with" + "with" "ffi" "Name" "Type" "Unit") "A regexp that matches any non-SQL keywords of Ur/Web.") diff --git a/src/expl.sml b/src/expl.sml index 0d4e63cc..3d784e3f 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -150,6 +150,7 @@ datatype decl' = | DTask of exp * exp | DPolicy of exp | DOnError of int * string list * string + | DFfi of string * int * Source.ffi_mode list * con and str' = StrConst of decl list diff --git a/src/expl_env.sml b/src/expl_env.sml index f5a5eb0a..5712a72d 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -346,6 +346,7 @@ fun declBinds env (d, loc) = | DTask _ => env | DPolicy _ => env | DOnError _ => env + | DFfi (x, n, _, t) => pushENamed env x n t fun sgiBinds env (sgi, loc) = case sgi of diff --git a/src/expl_print.sml b/src/expl_print.sml index a830dccb..22d246e2 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -731,6 +731,7 @@ fun p_decl env (dAll as (d, _) : decl) = space, p_exp env e1] | DOnError _ => string "ONERROR" + | DFfi _ => string "FFI" and p_str env (str, _) = case str of diff --git a/src/expl_rename.sml b/src/expl_rename.sml index 7e7a155a..bb763a60 100644 --- a/src/expl_rename.sml +++ b/src/expl_rename.sml @@ -219,6 +219,7 @@ fun renameDecl st (all as (d, loc)) = (case St.lookup (st, n) of NONE => all | SOME n' => (DOnError (n', xs, x), loc)) + | DFfi (x, n, modes, t) => (DFfi (x, n, modes, renameCon st t), loc) and renameStr st (all as (str, loc)) = case str of @@ -413,6 +414,15 @@ fun dupDecl (all as (d, loc), st) = (case St.lookup (st, n) of NONE => ([all], st) | SOME n' => ([(DOnError (n', xs, x), loc)], st)) + | DFfi (x, n, modes, t) => + let + val (st, n') = St.bind (st, n) + val t' = renameCon st t + in + ([(DFfi (x, n, modes, t'), loc), + (DVal (x, n', t', (ENamed n, loc)), loc)], + st) + end fun rename {NextId, FormalName, FormalId, Body = all as (str, loc)} = case str of diff --git a/src/explify.sml b/src/explify.sml index 4c60bd20..fd0f3277 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -198,6 +198,7 @@ fun explifyDecl (d, loc : EM.span) = | L.DTask (e1, e2) => SOME (L'.DTask (explifyExp e1, explifyExp e2), loc) | L.DPolicy e1 => SOME (L'.DPolicy (explifyExp e1), loc) | L.DOnError v => SOME (L'.DOnError v, loc) + | L.DFfi (x, n, modes, t) => SOME (L'.DFfi (x, n, modes, explifyCon t), loc) and explifyStr (str, loc) = case str of diff --git a/src/settings.sig b/src/settings.sig index 20dd00c2..29c4c506 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -78,18 +78,22 @@ signature SETTINGS = sig (* Which FFI functions should not have their calls removed or reordered, but cause no lasting effects? *) val setBenignEffectful : ffi list -> unit + val addBenignEffectful : ffi -> unit val isBenignEffectful : ffi -> bool (* Which FFI functions may only be run in clients? *) val setClientOnly : ffi list -> unit + val addClientOnly : ffi -> unit val isClientOnly : ffi -> bool (* Which FFI functions may only be run on servers? *) val setServerOnly : ffi list -> unit + val addServerOnly : ffi -> unit val isServerOnly : ffi -> bool (* Which FFI functions may be run in JavaScript? (JavaScript function names included) *) val setJsFuncs : (ffi * string) list -> unit + val addJsFunc : ffi * string -> unit val jsFunc : ffi -> string option val allJsFuncs : unit -> (ffi * string) list @@ -271,4 +275,7 @@ signature SETTINGS = sig val setIsHtml5 : bool -> unit val getIsHtml5 : unit -> bool + + val setLessSafeFfi : bool -> unit + val getLessSafeFfi : unit -> bool end diff --git a/src/settings.sml b/src/settings.sml index 4cdb4119..f00a4853 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -194,6 +194,7 @@ val benignBase = basis ["get_cookie", val benign = ref benignBase fun setBenignEffectful ls = benign := S.addList (benignBase, ls) +fun addBenignEffectful x = benign := S.add (!benign, x) fun isBenignEffectful x = S.member (!benign, x) val clientBase = basis ["get_client_source", @@ -225,6 +226,7 @@ val clientBase = basis ["get_client_source", "giveFocus"] val client = ref clientBase fun setClientOnly ls = client := S.addList (clientBase, ls) +fun addClientOnly x = client := S.add (!client, x) fun isClientOnly x = S.member (!client, x) val serverBase = basis ["requestHeader", @@ -240,6 +242,7 @@ val serverBase = basis ["requestHeader", "firstFormField"] val server = ref serverBase fun setServerOnly ls = server := S.addList (serverBase, ls) +fun addServerOnly x = server := S.add (!server, x) fun isServerOnly x = S.member (!server, x) val basisM = foldl (fn ((k, v : string), m) => M.insert (m, ("Basis", k), v)) M.empty @@ -364,6 +367,7 @@ val jsFuncsBase = basisM [("alert", "alert"), val jsFuncs = ref jsFuncsBase fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls fun jsFunc x = M.find (!jsFuncs, x) +fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, v) fun allJsFuncs () = M.listItemsi (!jsFuncs) datatype pattern_kind = Exact | Prefix @@ -735,4 +739,8 @@ val html5 = ref false fun setIsHtml5 b = html5 := b fun getIsHtml5 () = !html5 +val less = ref false +fun setLessSafeFfi b = less := b +fun getLessSafeFfi () = !less + end diff --git a/src/source.sml b/src/source.sml index eea7ad4c..2a741dd9 100644 --- a/src/source.sml +++ b/src/source.sml @@ -147,6 +147,13 @@ and pat = pat' located and exp = exp' located and edecl = edecl' located +datatype ffi_mode = + Effectful + | BenignEffectful + | ClientOnly + | ServerOnly + | JsFunc of string + datatype decl' = DCon of string * kind option * con | DDatatype of (string * string list * (string * con option) list) list @@ -169,6 +176,7 @@ datatype decl' = | DTask of exp * exp | DPolicy of exp | DOnError of string * string list * string + | DFfi of string * ffi_mode list * con and str' = StrConst of decl list diff --git a/src/source_print.sml b/src/source_print.sml index fdacfe6c..db56a0db 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -674,6 +674,7 @@ fun p_decl ((d, _) : decl) = space, p_exp e1] | DOnError _ => string "ONERROR" + | DFfi _ => string "FFI" and p_str (str, _) = case str of diff --git a/src/unnest.sml b/src/unnest.sml index 17bfd39f..fceb5026 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -452,6 +452,7 @@ fun unnest file = | DTask _ => explore () | DPolicy _ => explore () | DOnError _ => default () + | DFfi _ => default () end and doStr (all as (str, loc), st) = diff --git a/src/urweb.grm b/src/urweb.grm index 7aec9492..157ecfac 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2012, Adam Chlipala +(* Copyright (c) 2008-2014, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -365,7 +365,7 @@ fun patternOut (e : exp) = | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE | EQ | COMMA | COLON | DCOLON | DCOLONWILD | TCOLON | TCOLONWILD | DOT | HASH | UNDER | UNDERUNDER | BAR | PLUS | MINUS | DIVIDE | DOTDOTDOT | MOD | AT - | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS + | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS | FFI | DATATYPE | OF | TYPE | NAME | ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW | BANG @@ -532,6 +532,9 @@ fun patternOut (e : exp) = | enterDml of unit | leaveDml of unit + | ffi_mode of ffi_mode + | ffi_modes of ffi_mode list + %verbose (* print summary of errors *) %pos int (* positions *) @@ -645,6 +648,7 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let | STYLE SYMBOL ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))]) | TASK eapps EQ eexp ([(DTask (eapps, eexp), s (TASKleft, eexpright))]) | POLICY eexp ([(DPolicy eexp, s (POLICYleft, eexpright))]) + | FFI SYMBOL ffi_modes COLON cexp([(DFfi (SYMBOL, ffi_modes, cexp), s (FFIleft, cexpright))]) dtype : SYMBOL dargs EQ barOpt dcons (SYMBOL, dargs, dcons) @@ -2267,3 +2271,16 @@ sqlagg : AVG ("avg") | SUM ("sum") | MIN ("min") | MAX ("max") + +ffi_mode : SYMBOL (case SYMBOL of + "effectful" => Effectful + | "benignEffectful" => BenignEffectful + | "clientOnly" => ClientOnly + | "serverOnly" => ServerOnly + | _ => (ErrorMsg.errorAt (s (SYMBOLleft, SYMBOLright)) "Invalid FFI mode"; Effectful)) + | SYMBOL STRING (case SYMBOL of + "jsFunc" => JsFunc STRING + | _ => (ErrorMsg.errorAt (s (SYMBOLleft, SYMBOLright)) "Invalid FFI mode"; Effectful)) + +ffi_modes : ([]) + | ffi_mode ffi_modes (ffi_mode :: ffi_modes) diff --git a/src/urweb.lex b/src/urweb.lex index 293c6dc6..15ae448e 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -445,6 +445,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F]; "style" => (Tokens.STYLE (pos yypos, pos yypos + size yytext)); "task" => (Tokens.TASK (pos yypos, pos yypos + size yytext)); "policy" => (Tokens.POLICY (pos yypos, pos yypos + size yytext)); + "ffi" => (Tokens.FFI (pos yypos, pos yypos + size yytext)); "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext)); "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext)); diff --git a/tests/lessSafeFfi.ur b/tests/lessSafeFfi.ur new file mode 100644 index 00000000..da79bfdc --- /dev/null +++ b/tests/lessSafeFfi.ur @@ -0,0 +1,19 @@ +ffi foo : int -> int +ffi bar serverOnly benignEffectful : int -> transaction unit +ffi baz : transaction int + +ffi bup jsFunc "jsbup" : int -> transaction unit + +fun other () : transaction page = + (*bar 17; + q <- baz;*) + return + (*{[foo 42]}, {[q]}*) +