Mercurial > urweb

comparison src/reduce.sml @ 931:be6585b4058b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Have nullable columns working with Dbgrid
author Adam Chlipala <adamc@hcoop.net>
date Sun, 13 Sep 2009 12:00:34 -0400
parents 51bc7681c47e
children 280f81731426
comparison
equal deleted inserted replaced
930:51bc7681c47e 931:be6585b4058b
518 val e' = (EApp (e', e''), loc) 518 val e' = (EApp (e', e''), loc)
519 in 519 in
520 e' 520 e'
521 end 521 end
522 522
523 | EApp
524 ((EApp
525 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _),
526 t1),
527 _), t2), _),
528 (EFfi ("Basis", "transaction_monad"), _)), _),
529 (ECase (e, pes, {disc, ...}), _)), _), trans) =>
530 let
531 val e' = (EFfi ("Basis", "bind"), loc)
532 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
533 val e' = (ECApp (e', t1), loc)
534 val e' = (ECApp (e', t2), loc)
535 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
536
537 fun doCase (p, e) =
538 let
539 val e' = (EApp (e', e), loc)
540 val e' = (EApp (e',
541 multiLiftExpInExp (E.patBindsN p)
542 trans), loc)
543 in
544 (p, reassoc e')
545 end
546 in
547 (ECase (e, map doCase pes,
548 {disc = disc,
549 result = (CApp ((CFfi ("Basis", "transaction"), loc),
550 t2), loc)}), loc)
551 end
552
523 | _ => e 553 | _ => e
524 554
525 val e1 = exp env e1 555 val e1 = exp env e1
526 val e2 = exp env e2 556 val e2 = exp env e2
527 val e12 = reassoc (EApp (e1, e2), loc) 557 val e12 = reassoc (EApp (e1, e2), loc)
528 in 558 in
529 case #1 e12 of 559 case #1 e12 of
530 EApp ((EAbs (_, _, _, b), _), e2) => 560 EApp ((EAbs (_, _, _, b), _), e2) =>
531 ((*Print.preface ("Body", CorePrint.p_exp CoreEnv.empty b);*) 561 exp (KnownE e2 :: env') b
532 exp (KnownE e2 :: env') b)
533 (*| EApp
534 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1),
535 _), t2), _),
536 _), _),
537 (EApp (
538 (EApp (
539 (ECApp (
540 (ECApp ((EFfi ("Basis", "return"), _), _), _),
541 _), _),
542 _), _), v), _)) =>
543 (ELet ("rv", con env t1, v,
544 exp (deKnown env) (EApp (E.liftExpInExp 0 e2, (ERel 0, loc)), loc)), loc)*)
545 (*| EApp
546 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1),
547 _), t2), _),
548 (EFfi ("Basis", "transaction_monad"), _)), _),
549 (EServerCall (n, es, ke, dom, ran), _)) =>
550 let
551 val e' = (EFfi ("Basis", "bind"), loc)
552 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
553 val e' = (ECApp (e', dom), loc)
554 val e' = (ECApp (e', t2), loc)
555 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
556 val e' = (EApp (e', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc)
557 val e' = (EApp (e', E.liftExpInExp 0 (exp env e2)), loc)
558 val e' = (EAbs ("x", dom, t2, e'), loc)
559 val e' = (EServerCall (n, es, e', dom, t2), loc)
560 val e' = exp (deKnown env) e'
561 in
562 (*Print.prefaces "SC" [("Old", CorePrint.p_exp CoreEnv.empty all),
563 ("New", CorePrint.p_exp CoreEnv.empty e')]*)
564 e'
565 end
566 | EApp
567 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), mt),
568 _), _), _), t3), _),
569 me), _),
570 (EApp ((EApp
571 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _),
572 t1), _), t2), _),
573 _), _),
574 trans1), _), trans2), _)) =>
575 let
576 val e'' = (EFfi ("Basis", "bind"), loc)
577 val e'' = (ECApp (e'', mt), loc)
578 val e'' = (ECApp (e'', t2), loc)
579 val e'' = (ECApp (e'', t3), loc)
580 val e'' = (EApp (e'', me), loc)
581 val e'' = (EApp (e'', (EApp (E.liftExpInExp 0 trans2, (ERel 0, loc)), loc)), loc)
582 val e'' = (EApp (e'', E.liftExpInExp 0 e2), loc)
583 val e'' = (EAbs ("xb", t1, (CApp (mt, t3), loc), e''), loc)
584
585 val e' = (EFfi ("Basis", "bind"), loc)
586 val e' = (ECApp (e', mt), loc)
587 val e' = (ECApp (e', t1), loc)
588 val e' = (ECApp (e', t3), loc)
589 val e' = (EApp (e', me), loc)
590 val e' = (EApp (e', trans1), loc)
591 val e' = (EApp (e', e''), loc)
592 (*val () = Print.prefaces "Going in" [("e", CorePrint.p_exp CoreEnv.empty (e, loc)),
593 ("e1", CorePrint.p_exp CoreEnv.empty e1),
594 ("e'", CorePrint.p_exp CoreEnv.empty e')]*)
595 val ee' = exp (deKnown env) e'
596 val () = Print.prefaces "Coming out" [("ee'", CorePrint.p_exp CoreEnv.empty ee')]
597 in
598 (*Print.prefaces "Commute" [("Pre", CorePrint.p_exp CoreEnv.empty (e, loc)),
599 ("Mid", CorePrint.p_exp CoreEnv.empty e'),
600 ("env", Print.PD.string (e2s env)),
601 ("Post", CorePrint.p_exp CoreEnv.empty ee')];*)
602 ee'
603 end
604 | _ => (EApp (e1, exp env e2), loc)*)
605 | _ => e12 562 | _ => e12
606 end 563 end
607 564
608 | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (UnknownE :: env) e), loc) 565 | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (UnknownE :: env) e), loc)
609 566