Mercurial > urweb

comparison src/elab_util.sml @ 211:e86411f647c6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Initial type class support
author Adam Chlipala <adamc@hcoop.net>
date Sat, 16 Aug 2008 14:32:18 -0400
parents cc68da3801bc
children 0343557355fc
comparison
equal deleted inserted replaced
210:f4033abd6ab1 211:e86411f647c6
373 S.Return () 373 S.Return ()
374 else 374 else
375 S.Continue (e, ())} k () of 375 S.Continue (e, ())} k () of
376 S.Return _ => true 376 S.Return _ => true
377 | S.Continue _ => false 377 | S.Continue _ => false
378
379 fun mapB {kind, con, exp, bind} ctx e =
380 case mapfoldB {kind = fn k => fn () => S.Continue (kind k, ()),
381 con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()),
382 exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
383 bind = bind} ctx e () of
384 S.Continue (e, ()) => e
385 | S.Return _ => raise Fail "ElabUtil.Exp.mapB: Impossible"
378 386
379 end 387 end
380 388
381 structure Sgn = struct 389 structure Sgn = struct
382 390
453 (SgiConstraint (c1', c2'), loc))) 461 (SgiConstraint (c1', c2'), loc)))
454 | SgiTable (tn, x, n, c) => 462 | SgiTable (tn, x, n, c) =>
455 S.map2 (con ctx c, 463 S.map2 (con ctx c,
456 fn c' => 464 fn c' =>
457 (SgiTable (tn, x, n, c'), loc)) 465 (SgiTable (tn, x, n, c'), loc))
466 | SgiClassAbs _ => S.return2 siAll
467 | SgiClass (x, n, c) =>
468 S.map2 (con ctx c,
469 fn c' =>
470 (SgiClass (x, n, c'), loc))
458 471
459 and sg ctx s acc = 472 and sg ctx s acc =
460 S.bindP (sg' ctx s acc, sgn ctx) 473 S.bindP (sg' ctx s acc, sgn ctx)
461 474
462 and sg' ctx (sAll as (s, loc)) = 475 and sg' ctx (sAll as (s, loc)) =
476 | SgiStr (x, _, sgn) => 489 | SgiStr (x, _, sgn) =>
477 bind (ctx, Str (x, sgn)) 490 bind (ctx, Str (x, sgn))
478 | SgiSgn (x, _, sgn) => 491 | SgiSgn (x, _, sgn) =>
479 bind (ctx, Sgn (x, sgn)) 492 bind (ctx, Sgn (x, sgn))
480 | SgiConstraint _ => ctx 493 | SgiConstraint _ => ctx
481 | SgiTable _ => ctx, 494 | SgiTable _ => ctx
495 | SgiClassAbs (x, _) =>
496 bind (ctx, NamedC (x, (KArrow ((KType, loc), (KType, loc)), loc)))
497 | SgiClass (x, _, _) =>
498 bind (ctx, NamedC (x, (KArrow ((KType, loc), (KType, loc)), loc))),
482 sgi ctx si)) ctx sgis, 499 sgi ctx si)) ctx sgis,
483 fn sgis' => 500 fn sgis' =>
484 (SgnConst sgis', loc)) 501 (SgnConst sgis', loc))
485 502
486 | SgnVar _ => S.return2 sAll 503 | SgnVar _ => S.return2 sAll