X-Git-Url: http://git.megacz.com/?p=coq-hetmet.git;a=blobdiff_plain;f=src%2FHaskWeak.v;h=077f7b509a22032859a83729226a7fc82b2620fe;hp=f177e1f144b52704b4687cc476ee1be809476d53;hb=1a2754d2e135ef3c5fd7ef817e1129af93b533a5;hpb=1f411b48dd607e76a65903e8506d0ae5e7470321 diff --git a/src/HaskWeak.v b/src/HaskWeak.v index f177e1f..077f7b5 100644 --- a/src/HaskWeak.v +++ b/src/HaskWeak.v @@ -7,16 +7,22 @@ Require Import Preamble. Require Import General. Require Import Coq.Lists.List. Require Import HaskKinds. -Require Import HaskCoreLiterals. +Require Import HaskLiterals. +Require Import HaskTyCons. Require Import HaskCoreVars. -Require Import HaskCoreTypes. -Require Import HaskCoreTypes. Require Import HaskWeakVars. Require Import HaskWeakTypes. +Inductive WeakAltCon := +| WeakDataAlt : CoreDataCon -> WeakAltCon +| WeakLitAlt : HaskLiteral -> WeakAltCon +| WeakDEFAULT : WeakAltCon. + Inductive WeakExpr := | WEVar : WeakExprVar -> WeakExpr | WELit : HaskLiteral -> WeakExpr + +(* TO DO: add a WEWhere and use the source location to detect which one the user used *) | WELet : WeakExprVar -> WeakExpr -> WeakExpr -> WeakExpr | WELetRec : Tree ??(WeakExprVar * WeakExpr) -> WeakExpr -> WeakExpr | WECast : WeakExpr -> WeakCoercion -> WeakExpr @@ -28,112 +34,78 @@ Inductive WeakExpr := | WETyLam : WeakTypeVar -> WeakExpr -> WeakExpr | WECoLam : WeakCoerVar -> WeakExpr -> WeakExpr -(* the WeakType argument in WEBrak/WEEsc is used only when going back *) -(* from Weak to Core; it lets us dodge a possibly-failing type *) -(* calculation *) -| WEBrak : WeakTypeVar -> WeakExpr -> WeakType -> WeakExpr -| WEEsc : WeakTypeVar -> WeakExpr -> WeakType -> WeakExpr +(* The WeakType argument in WEBrak/WEEsc is used only when going back *) +(* from Weak to Core; it lets us dodge a possibly-failing type *) +(* calculation. The CoreVar argument is the GlobalVar for the hetmet_brak *) +(* or hetmet_esc identifier *) +| WEBrak : WeakExprVar -> WeakTypeVar -> WeakExpr -> WeakType -> WeakExpr +| WEEsc : WeakExprVar -> WeakTypeVar -> WeakExpr -> WeakType -> WeakExpr +| WECSP : WeakExprVar -> WeakTypeVar -> WeakExpr -> WeakType -> WeakExpr -(* note that HaskWeak "Case" does not bind a variable; coreExprToWeakExpr adds a let-binder *) -| WECase : forall (scrutinee:WeakExpr) +| WECase : forall (vscrut:WeakExprVar) + (scrutinee:WeakExpr) (tbranches:WeakType) (tc:TyCon) (type_params:list WeakType) - (alts : Tree ??(AltCon*list WeakTypeVar*list WeakCoerVar*list WeakExprVar*WeakExpr)), + (alts : Tree ??(WeakAltCon*list WeakTypeVar*list WeakCoerVar*list WeakExprVar*WeakExpr)), WeakExpr. -(* calculate the free WeakVar's in a WeakExpr *) -(* -Fixpoint getWeakExprFreeVars (me:WeakExpr) : list WeakExprVar := - match me with - | WELit _ => nil - | WEVar cv => cv::nil - | WECast e co => getWeakExprFreeVars e - | WENote n e => getWeakExprFreeVars e - | WETyApp e t => getWeakExprFreeVars e - | WECoApp e co => getWeakExprFreeVars e - | WEBrak ec e _ => getWeakExprFreeVars e - | WEEsc ec e _ => getWeakExprFreeVars e - | WELet cv e1 e2 => mergeDistinctLists (getWeakExprFreeVars e1) (removeFromDistinctList cv (getWeakExprFreeVars e2)) - | WEApp e1 e2 => mergeDistinctLists (getWeakExprFreeVars e1) (getWeakExprFreeVars e2) - | WELam cv e => @removeFromDistinctList _ WeakExprVarEqDecidable cv (getWeakExprFreeVars e) - | WETyLam cv e => getWeakExprFreeVars e - | WECoLam cv e => getWeakExprFreeVars e - - (* the messy fixpoints below are required by Coq's termination conditions; trust me, I tried to get rid of them *) - | WECase scrutinee tbranches tc type_params alts => - mergeDistinctLists (getWeakExprFreeVars scrutinee) ( - ((fix getWeakExprFreeVarsAlts (alts:Tree ??(AltCon*list WeakTypeVar*list WeakCoerVar*list WeakExprVar*WeakExpr)) - {struct alts} : list WeakExprVar := - match alts with - | T_Leaf None => nil - | T_Leaf (Some (DEFAULT,_,_,_,e)) => getWeakExprFreeVars e - | T_Leaf (Some (LitAlt lit,_,_,_,e)) => getWeakExprFreeVars e - | T_Leaf (Some ((DataAlt dc), tvars, cvars, evars,e)) => removeFromDistinctList' evars (getWeakExprFreeVars e) - | T_Branch b1 b2 => mergeDistinctLists (getWeakExprFreeVarsAlts b1) (getWeakExprFreeVarsAlts b2) - end) alts)) - | WELetRec mlr e => (fix removeVarsLetRec (mlr:Tree ??(WeakExprVar * WeakExpr))(cvl:list WeakExprVar) := - match mlr with - | T_Leaf None => cvl - | T_Leaf (Some (cv,e)) => removeFromDistinctList cv cvl - | T_Branch b1 b2 => removeVarsLetRec b1 (removeVarsLetRec b2 cvl) - end) mlr (mergeDistinctLists (getWeakExprFreeVars e) - ((fix getWeakExprFreeVarsLetRec (mlr:Tree ??(WeakExprVar * WeakExpr)) := - match mlr with - | T_Leaf None => nil - | T_Leaf (Some (cv,e)) => getWeakExprFreeVars e - | T_Branch b1 b2 => mergeDistinctLists (getWeakExprFreeVarsLetRec b1) (getWeakExprFreeVarsLetRec b2) - end) mlr)) - end. - -(* wrap lambdas around an expression until it has no free expression variables *) -Definition makeClosedExpression : WeakExpr -> WeakExpr := - fun me => (fix closeExpression (me:WeakExpr)(cvl:list WeakExprVar) := - match cvl with - | nil => me - | cv::cvl' => WELam cv (closeExpression me cvl') - end) me (getWeakExprFreeVars me). -*) Definition weakTypeOfLiteral (lit:HaskLiteral) : WeakType := (WTyCon (haskLiteralToTyCon lit)). -(* calculate the CoreType of a WeakExpr *) -Fixpoint weakTypeOfWeakExpr (ce:WeakExpr) : ???WeakType := - match ce with - | WEVar (weakExprVar v t) => OK t - | WELit lit => OK (weakTypeOfLiteral lit) - | WEApp e1 e2 => weakTypeOfWeakExpr e1 >>= fun t' => - match t' with - | (WAppTy (WAppTy WFunTyCon t1) t2) => OK t2 - | _ => Error ("found non-function type "+++t'+++" in EApp") - end - | WETyApp e t => weakTypeOfWeakExpr e >>= fun te => - match te with - | WForAllTy v ct => OK (replaceWeakTypeVar ct v t) - | _ => Error ("found non-forall type "+++te+++" in ETyApp") - end - | WECoApp e co => weakTypeOfWeakExpr e >>= fun te => - match te with - | WCoFunTy t1 t2 t => OK t - | _ => Error ("found non-coercion type "+++te+++" in ETyApp") - end - | WELam (weakExprVar ev vt) e => weakTypeOfWeakExpr e >>= fun t' => OK (WAppTy (WAppTy WFunTyCon vt) t') - | WETyLam tv e => weakTypeOfWeakExpr e >>= fun t' => OK (WForAllTy tv t') - | WECoLam (weakCoerVar cv _ φ₁ φ₂) e => weakTypeOfWeakExpr e >>= fun t' => OK (WCoFunTy φ₁ φ₂ t') - | WELet ev ve e => weakTypeOfWeakExpr e - | WELetRec rb e => weakTypeOfWeakExpr e - | WENote n e => weakTypeOfWeakExpr e - | WECast e (weakCoercion _ t1 t2 _) => OK t2 - | WECase scrutinee tbranches tc type_params alts => OK tbranches - - (* note that we willfully ignore the type stashed in WEBrak/WEEsc here *) - | WEBrak ec e _ => weakTypeOfWeakExpr e >>= fun t' => OK (WCodeTy ec t') - | WEEsc ec e _ => weakTypeOfWeakExpr e >>= fun t' => - match t' with - | (WAppTy (WAppTy WCodeTyCon (WTyVarTy ec')) t'') => - if eqd_dec ec ec' then OK t'' - else Error "level mismatch in escapification" - | _ => Error "ill-typed escapification" - end +(* +Fixpoint weakExprVarOccursFree (wvf:WeakExprVar)(we:WeakExpr) : bool := + match we with + | WEVar wv => if eqd_dec (wvf:CoreVar) (wv:CoreVar) then true else false + | WELit lit => false + | WEApp e1 e2 => weakExprVarOccursFree wvf e1 || weakExprVarOccursFree wvf e2 + | WETyApp e t => weakExprVarOccursFree wvf e + | WECoApp e co => weakExprVarOccursFree wvf e + | WENote n e => weakExprVarOccursFree wvf e + | WELam ev e => if eqd_dec (wvf:CoreVar) (ev:CoreVar) then false else weakExprVarOccursFree wvf e + | WETyLam tv e => weakExprVarOccursFree wvf e + | WECoLam cv e => weakExprVarOccursFree wvf e + | WECast e co => weakExprVarOccursFree wvf e + | WEBrak v wtv e t => weakExprVarOccursFree wvf e + | WEEsc v wtv e t => weakExprVarOccursFree wvf e + | WECSP v wtv e t => weakExprVarOccursFree wvf e + | WELet v ebind ebody => weakExprVarOccursFree wvf ebind + || if eqd_dec (wvf:CoreVar) (v:CoreVar) then false else weakExprVarOccursFree wvf ebody + | WECase vs es tb tc tys alts => + if weakExprVarOccursFree wvf es + then true + else (fix weakExprVarOccursFreeBranches (alts:Tree ??(_)) : bool := + match alts with + | T_Leaf None => false + | T_Leaf (Some (_,_,_,v',e')) => + if fold_left bor (map (fun v'':WeakExprVar => if eqd_dec (wvf:CoreVar) (v'':CoreVar) then true else false ) v') false + then false + else weakExprVarOccursFree wvf e' + | T_Branch b1 b2 => weakExprVarOccursFreeBranches b1 || + weakExprVarOccursFreeBranches b2 + end) alts + | WELetRec mlr e => false end. +(* some very simple-minded cleanups to produce "prettier" expressions *) +Fixpoint simplifyWeakExpr (me:WeakExpr) : WeakExpr := + match me with + | WEVar wv => WEVar wv + | WELit lit => WELit lit + | WEApp e1 e2 => WEApp (simplifyWeakExpr e1) (simplifyWeakExpr e2) + | WETyApp e t => WETyApp (simplifyWeakExpr e ) t + | WECoApp e co => CoreEApp (simplifyWeakExpr e ) co + | WENote n e => CoreENote n (simplifyWeakExpr e ) + | WELam ev e => CoreELam ev (simplifyWeakExpr e ) + | WETyLam tv e => CoreELam tv (simplifyWeakExpr e ) + | WECoLam cv e => CoreELam cv (simplifyWeakExpr e ) + | WECast e co => CoreECast (simplifyWeakExpr e ) co + | WEBrak v wtv e t => WEBrak v wtv (simplifyWeakExpr e ) t + | WEEsc v wtv e t => WEEsc v wtv (simplifyWeakExpr e ) t + | WECSP v wtv e t => WECSP v wtv (simplifyWeakExpr e ) t + | WELet v ebind ebody => WELet v (simplifyWeakExpr ebind) (simplifyWeakExpr ebody) + | WECase vs es tb tc tys alts => WECase vs es tb tc tys (* FIXME alts *) + (* un-letrec-ify multi branch letrecs *) + | WELetRec mlr e => WELetRec mlr (simplifyWeakExpr e ) + end. +*)