Mercurial > urweb
diff src/unnest.sml @ 623:588b9d16b00a
Start of kind polymorphism, up to the point where demo/hello elaborates with updated Basis/Top
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 22 Feb 2009 16:10:25 -0500 |
| parents | 366676f7bc88 |
| children | f152f215a02c |
line wrap: on
line diff
--- a/src/unnest.sml Sat Feb 21 16:11:56 2009 -0500 +++ b/src/unnest.sml Sun Feb 22 16:10:25 2009 -0500 @@ -37,7 +37,7 @@ 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 @@ | (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 @@ | ((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 @@ | _ => 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 @@ 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 @@ | _ => 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 @@ 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