## Mercurial > urweb

### view src/elab_ops.sml @ 1273:7d0254d15b21

Find changesets by keywords (author, files, the commit message), revision
number or hash, or revset expression.

New release

author | Adam Chlipala <adamc@hcoop.net> |
---|---|

date | Thu, 03 Jun 2010 13:31:48 -0400 |

parents | a779402841f6 |

children | c7b9a33c26c8 |

line wrap: on

line source

(* 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 ElabOps :> ELAB_OPS = struct 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 _ => fn k => k, con = fn bound => fn c => case c of CRel xn => if xn < bound then c else CRel (xn + by) (*| CUnif _ => raise SynUnif*) | _ => c, bind = fn (bound, U.Con.RelC _) => bound + 1 | (bound, _) => bound} fun subConInCon' rep = U.Con.mapB {kind = fn _ => fn k => k, con = fn (by, xn) => fn c => case c of CRel xn' => (case Int.compare (xn', xn) of EQUAL => #1 (liftConInCon by 0 rep) | GREATER => CRel (xn' - 1) | LESS => c) (*| CUnif _ => raise SynUnif*) | _ => c, bind = fn ((by, xn), U.Con.RelC _) => (by+1, xn+1) | (ctx, _) => ctx} val liftConInCon = liftConInCon 1 fun subConInCon (xn, rep) = subConInCon' rep (0, xn) fun subStrInSgn (m1, m2) = U.Sgn.map {kind = fn k => k, con = fn c as CModProj (m1', ms, x) => if m1 = m1' then CModProj (m2, ms, x) else c | c => c, sgn_item = fn sgi => sgi, sgn = fn sgn => sgn} val occurs = U.Con.existsB {kind = fn _ => false, con = fn (n, c) => case c of CRel n' => n' = n | _ => false, bind = fn (n, b) => case b of U.Con.RelC _ => n + 1 | _ => n} 0 val identity = ref 0 val distribute = ref 0 val fuse = ref 0 fun reset () = (identity := 0; distribute := 0; fuse := 0) fun hnormCon env (cAll as (c, loc)) = case c of CUnif (_, _, _, ref (SOME c)) => hnormCon env c | CNamed xn => (case E.lookupCNamed env xn of (_, _, SOME c') => hnormCon env c' | _ => cAll) | CModProj (n, ms, x) => let val (_, sgn) = E.lookupStrNamed env n val (str, sgn) = foldl (fn (m, (str, sgn)) => case E.projectStr env {sgn = sgn, str = str, field = m} of NONE => raise Fail "hnormCon: Unknown substructure" | SOME sgn => ((StrProj (str, m), loc), sgn)) ((StrVar n, loc), sgn) ms in case E.projectCon env {sgn = sgn, str = str, field = x} of NONE => raise Fail "kindof: Unknown con in structure" | SOME (_, NONE) => cAll | SOME (_, SOME c) => hnormCon env c end (* Eta reduction *) | CAbs (x, k, b) => (case #1 (hnormCon (E.pushCRel env x k) b) of CApp (f, (CRel 0, _)) => if occurs f then cAll else hnormCon env (subConInCon (0, (CUnit, loc)) f) | _ => cAll) | CApp (c1, c2) => (case #1 (hnormCon env c1) of CAbs (x, k, cb) => let val sc = (hnormCon env (subConInCon (0, c2) cb)) handle SynUnif => cAll (*val env' = E.pushCRel env x k*) in (*Print.eprefaces "Subst" [("x", Print.PD.string x), ("cb", ElabPrint.p_con env' cb), ("c2", ElabPrint.p_con env c2), ("sc", ElabPrint.p_con env sc)];*) sc end | c1' as CApp (c', f) => let fun default () = (CApp ((c1', loc), hnormCon env c2), loc) in case #1 (hnormCon env c') of CMap (ks as (k1, k2)) => (case #1 (hnormCon env c2) of CRecord (_, []) => (CRecord (k2, []), loc) | CRecord (_, (x, c) :: rest) => hnormCon env (CConcat ((CRecord (k2, [(x, (CApp (f, c), loc))]), loc), (CApp (c1, (CRecord (k2, rest), loc)), loc)), loc) | CConcat ((CRecord (k, (x, c) :: rest), _), rest') => let val rest'' = (CConcat ((CRecord (k, rest), loc), rest'), loc) in hnormCon env (CConcat ((CRecord (k2, [(x, (CApp (f, c), loc))]), loc), (CApp (c1, rest''), loc)), loc) end | _ => let fun unconstraint c = case hnormCon env c of (TDisjoint (_, _, c), _) => unconstraint c | c => c fun inc r = r := !r + 1 fun tryDistributivity () = case hnormCon env c2 of (CConcat (c1, c2'), _) => let val c = (CMap ks, loc) val c = (CApp (c, f), loc) val c1 = (CApp (c, c1), loc) val c2 = (CApp (c, c2'), loc) val c = (CConcat (c1, c2), loc) in inc distribute; hnormCon env c end | _ => default () fun tryFusion () = case #1 (hnormCon env c2) of CApp (f', r') => (case #1 (hnormCon env f') of CApp (f', inner_f) => (case #1 (hnormCon env f') of CMap (dom, _) => let val inner_f = liftConInCon 0 inner_f val f = liftConInCon 0 f val f' = (CApp (inner_f, (CRel 0, loc)), loc) val f' = (CApp (f, f'), loc) val f' = (CAbs ("v", dom, f'), loc) val c = (CMap (dom, k2), loc) val c = (CApp (c, f'), loc) val c = (CApp (c, r'), loc) in inc fuse; hnormCon env c end | _ => tryDistributivity ()) | _ => tryDistributivity ()) | _ => tryDistributivity () fun tryIdentity () = let fun cunif () = let val r = ref NONE in (r, (CUnif (loc, (KType, loc), "_", r), loc)) end val (vR, v) = cunif () val c = (CApp (f, v), loc) in case unconstraint c of (CUnif (_, _, _, vR'), _) => if vR' = vR then (inc identity; hnormCon env c2) else tryFusion () | _ => tryFusion () end in tryIdentity () end) | _ => 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 ((CRecord (k, xcs1), loc), (CRecord (_, xcs2), _)) => (CRecord (k, xcs1 @ xcs2), loc) | ((CRecord (_, []), _), c2') => c2' | ((CConcat (c11, c12), loc), c2') => hnormCon env (CConcat (c11, (CConcat (c12, c2'), loc)), loc) | (c1', (CRecord (_, []), _)) => c1' | (c1', c2') => (CConcat (c1', c2'), loc)) | CProj (c, n) => (case hnormCon env c of (CTuple cs, _) => hnormCon env (List.nth (cs, n - 1)) | _ => cAll) | _ => cAll end