X-Git-Url: http://git.megacz.com/?p=coq-hetmet.git;a=blobdiff_plain;f=src%2FHaskStrong.v;h=874b368d80faac736c1e8146062a65beb852df4a;hp=d52acb959fc168ee3d43b01a3d70d51109d0e252;hb=4c5c94487aa2bf5489371f112607f0a4c4f01a94;hpb=1c1cdb9014f409248ca96b677503719916b2b477

diff --git a/src/HaskStrong.v b/src/HaskStrong.v
index d52acb9..874b368 100644
--- a/src/HaskStrong.v
+++ b/src/HaskStrong.v
@@ -13,6 +13,7 @@ Require Import HaskLiterals.
 Require Import HaskTyCons.
 Require Import HaskStrongTypes.
 Require Import HaskWeakVars.
+Require Import HaskCoreToWeak.
 Require Import HaskCoreVars.
 
 Section HaskStrong.
@@ -25,59 +26,57 @@ Section HaskStrong.
   { scbwv_exprvars          :  vec VV (sac_numExprVars sac)
   ; scbwv_exprvars_distinct :  distinct (vec2list scbwv_exprvars)
   ; scbwv_varstypes         := vec_zip scbwv_exprvars (sac_types sac Γ atypes)
-  ; scbwv_ξ                 := fun ξ lev =>  update_ξ (weakLT'○ξ) (weakL' lev) (vec2list scbwv_varstypes)
+  ; scbwv_xi                := fun ξ lev =>  update_xi (weakLT'○ξ) (weakL' lev) (vec2list scbwv_varstypes)
   }.
   Implicit Arguments StrongCaseBranchWithVVs [[Γ]].
 
-  Inductive Expr : forall Γ (Δ:CoercionEnv Γ), (VV -> LeveledHaskType Γ ★) -> LeveledHaskType Γ ★ -> Type :=
+  Inductive Expr : forall Γ (Δ:CoercionEnv Γ), (VV -> LeveledHaskType Γ ★) -> HaskType Γ ★ -> HaskLevel Γ -> Type :=
 
   (* an "EGlobal" is any variable which is free in the expression which was passed to -fcoqpass (ie bound outside it) *)
-  | EGlobal: forall Γ Δ ξ   (g:Global Γ) v lev,                                                      Expr Γ Δ ξ (g v @@ lev)
+  | EGlobal: forall Γ Δ ξ   (g:Global Γ) v lev,                                                      Expr Γ Δ ξ (g v) lev
 
-  | EVar   : ∀ Γ Δ ξ ev,                                                                             Expr Γ Δ ξ (ξ ev)
-  | ELit   : ∀ Γ Δ ξ lit   l,                                                                        Expr Γ Δ ξ (literalType lit@@l)
-  | EApp   : ∀ Γ Δ ξ t1 t2 l,        Expr Γ Δ ξ (t2--->t1 @@ l)   -> Expr Γ Δ ξ (t2 @@ l)         -> Expr Γ Δ ξ (t1 @@ l)
-  | ELam   : ∀ Γ Δ ξ t1 t2 l ev,              Expr Γ Δ (update_ξ ξ l ((ev,t1)::nil)) (t2@@l)      -> Expr Γ Δ ξ (t1--->t2@@l)
-  | ELet   : ∀ Γ Δ ξ tv t  l ev,Expr Γ Δ ξ (tv@@l)->Expr Γ Δ (update_ξ ξ l ((ev,tv)::nil))(t@@l)  -> Expr Γ Δ ξ (t@@l)
-  | EEsc   : ∀ Γ Δ ξ ec t  l,     Expr Γ Δ ξ (<[ ec |- t ]> @@ l)                                 -> Expr Γ Δ ξ (t @@ (ec::l))
-  | EBrak  : ∀ Γ Δ ξ ec t  l,     Expr Γ Δ ξ (t @@ (ec::l))                                       -> Expr Γ Δ ξ (<[ ec |- t ]> @@ l)
-  | ECast  : forall Γ Δ ξ t1 t2 (γ:HaskCoercion Γ Δ (t1 ∼∼∼ t2)) l,
-    Expr Γ Δ ξ (t1 @@ l)                        -> Expr Γ Δ ξ (t2 @@ l)
-  | ENote  : ∀ Γ Δ ξ t, Note                      -> Expr Γ Δ ξ t                                 -> Expr Γ Δ ξ t
-  | ETyApp : ∀ Γ Δ κ σ τ ξ l,                    Expr Γ Δ ξ (HaskTAll κ σ @@ l)                   -> Expr Γ Δ ξ (substT σ τ @@ l)
-  | ECoLam : forall Γ Δ κ σ (σ₁ σ₂:HaskType Γ κ) ξ l,
-    Expr Γ (σ₁∼∼∼σ₂::Δ) ξ (σ @@ l)    -> Expr Γ Δ ξ (σ₁∼∼σ₂    ⇒ σ @@ l)
-  | ECoApp : forall Γ Δ κ (σ₁ σ₂:HaskType Γ κ) (γ:HaskCoercion Γ Δ (σ₁∼∼∼σ₂)) σ ξ l,
-    Expr Γ Δ ξ (σ₁ ∼∼ σ₂ ⇒ σ @@ l)            -> Expr Γ Δ ξ (σ        @@l)
+  | EVar   : ∀ Γ Δ ξ ev,                                                                Expr Γ Δ ξ (unlev (ξ ev)) (getlev (ξ ev))
+  | ELit   : ∀ Γ Δ ξ lit   l,                                                                        Expr Γ Δ ξ (literalType lit) l
+  | EApp   : ∀ Γ Δ ξ t1 t2 l,        Expr Γ Δ ξ (t2--->t1) l   -> Expr Γ Δ ξ t2 l         -> Expr Γ Δ ξ (t1) l
+  | ELam   : ∀ Γ Δ ξ t1 t2 l ev,              Expr Γ Δ (update_xi ξ l ((ev,t1)::nil)) t2 l       -> Expr Γ Δ ξ (t1--->t2) l
+  | ELet   : ∀ Γ Δ ξ tv t  l ev,Expr Γ Δ ξ  tv l ->Expr Γ Δ (update_xi ξ l ((ev,tv)::nil)) t l  -> Expr Γ Δ ξ t l
+  | EEsc   : ∀ Γ Δ ξ ec t  l,     Expr Γ Δ ξ  (<[ ec |- t ]>)  l                                  -> Expr Γ Δ ξ t (ec::l)
+  | EBrak  : ∀ Γ Δ ξ ec t  l,     Expr Γ Δ ξ t  (ec::l)                                         -> Expr Γ Δ ξ (<[ ec |- t ]>) l
+  | ECast  : forall Γ Δ ξ t1 t2 (γ:HaskCoercion Γ Δ (t1 ∼∼∼ t2)) l, Expr Γ Δ ξ t1 l             -> Expr Γ Δ ξ t2 l
+  | ENote  : ∀ Γ Δ ξ t l, Note                      -> Expr Γ Δ ξ t l                               -> Expr Γ Δ ξ t l
+  | ETyApp : ∀ Γ Δ κ σ τ ξ l,                    Expr Γ Δ ξ (HaskTAll κ σ) l                   -> Expr Γ Δ ξ (substT σ τ) l
+  | ECoLam : forall Γ Δ κ σ (σ₁ σ₂:HaskType Γ κ) ξ l, Expr Γ (σ₁∼∼∼σ₂::Δ) ξ σ l    -> Expr Γ Δ ξ (σ₁∼∼σ₂    ⇒ σ) l
+  | ECoApp : forall Γ Δ κ (σ₁ σ₂:HaskType Γ κ) (γ:HaskCoercion Γ Δ (σ₁∼∼∼σ₂)) σ ξ l, Expr Γ Δ ξ (σ₁ ∼∼ σ₂ ⇒ σ) l  -> Expr Γ Δ ξ σ l
   | ETyLam : ∀ Γ Δ ξ κ σ l,
-    Expr (κ::Γ) (weakCE Δ) (weakLT○ξ) (HaskTApp (weakF σ) (FreshHaskTyVar _)@@(weakL l))-> Expr Γ Δ ξ (HaskTAll κ σ @@ l)
+    Expr (κ::Γ) (weakCE Δ) (weakLT○ξ) (HaskTApp (weakF σ) (FreshHaskTyVar _)) (weakL l)-> Expr Γ Δ ξ (HaskTAll κ σ) l
   | ECase    : forall Γ Δ ξ l tc tbranches atypes,
-               Expr Γ Δ ξ (caseType tc atypes @@ l) ->
+               Expr Γ Δ ξ (caseType tc atypes) l ->
                Tree ??{ sac : _
                     & { scb : StrongCaseBranchWithVVs tc atypes sac
-                    &         Expr (sac_Γ sac Γ)
-                                   (sac_Δ sac Γ atypes (weakCK'' Δ))
-                                   (scbwv_ξ scb ξ l)
-                                   (weakLT' (tbranches@@l)) } } ->
-               Expr Γ Δ ξ (tbranches @@ l)
+                    &         Expr (sac_gamma sac Γ)
+                                   (sac_delta sac Γ atypes (weakCK'' Δ))
+                                   (scbwv_xi scb ξ l)
+                                   (weakT' tbranches)
+                                   (weakL' l) } } ->
+               Expr Γ Δ ξ tbranches l
 
   | ELetRec  : ∀ Γ Δ ξ l τ vars,
     distinct (leaves (mapOptionTree (@fst _ _) vars)) ->
-    let ξ' := update_ξ ξ l (leaves vars) in
-    ELetRecBindings Γ Δ ξ'     l vars ->
-    Expr            Γ Δ ξ' (τ@@l) ->
-    Expr            Γ Δ ξ  (τ@@l)
+    let ξ' := update_xi ξ l (leaves vars) in
+    ELetRecBindings Γ Δ ξ'   l vars ->
+    Expr            Γ Δ ξ' τ l ->
+    Expr            Γ Δ ξ  τ l
 
   (* can't avoid having an additional inductive: it is a tree of Expr's, each of whose ξ depends on the type of the entire tree *)
   with ELetRecBindings : ∀ Γ, CoercionEnv Γ -> (VV -> LeveledHaskType Γ ★) -> HaskLevel Γ -> Tree ??(VV*HaskType Γ ★) -> Type :=
   | ELR_nil    : ∀ Γ Δ ξ l  ,                                                                 ELetRecBindings Γ Δ ξ l []
-  | ELR_leaf   : ∀ Γ Δ ξ l v t,                                        Expr Γ Δ ξ (t @@ l) -> ELetRecBindings Γ Δ ξ l [(v,t)]
+  | ELR_leaf   : ∀ Γ Δ ξ l v t,                                        Expr Γ Δ ξ  t  l    -> ELetRecBindings Γ Δ ξ l [(v,t)]
   | ELR_branch : ∀ Γ Δ ξ l t1 t2, ELetRecBindings Γ Δ ξ l t1 -> ELetRecBindings Γ Δ ξ l t2 -> ELetRecBindings Γ Δ ξ l (t1,,t2)
   .
 
   Context {ToStringVV:ToString VV}.
   Context {ToLatexVV:ToLatex VV}.
-  Fixpoint exprToString {Γ}{Δ}{ξ}{τ}(exp:Expr Γ Δ ξ τ) : string :=
+  Fixpoint exprToString {Γ}{Δ}{ξ}{τ}{l}(exp:Expr Γ Δ ξ τ l) : string :=
     match exp with
     | EVar  Γ' _ ξ' ev              => "var."+++ toString ev
     | EGlobal Γ' _ ξ'   g v _       => "global." +++ toString (g:CoreVar)
@@ -87,7 +86,7 @@ Section HaskStrong.
     | EApp  Γ' _ _ _ _ _ e1 e2      => "("+++exprToString e1+++")("+++exprToString e2+++")"
     | EEsc  Γ' _ _ ec t _ e         => "~~("+++exprToString e+++")"
     | EBrak Γ' _ _ ec t _ e         => "<["+++exprToString e+++"]>"
-    | ENote _ _ _ _ n e             => "note."+++exprToString e
+    | ENote _ _ _ _ n _ e           => "note."+++exprToString e
     | ETyApp  Γ Δ κ σ τ ξ l       e => "("+++exprToString e+++")@("+++toString τ+++")"
     | ECoApp Γ Δ κ σ₁ σ₂ γ σ ξ l e  => "("+++exprToString e+++")~(co)"
     | ECast Γ Δ ξ t1 t2 γ l e       => "cast ("+++exprToString e+++"):t2"
@@ -96,7 +95,7 @@ Section HaskStrong.
     | ECase Γ Δ ξ l tc branches atypes escrut alts => "case " +++ exprToString escrut +++ " of FIXME"
     | ELetRec _ _ _ _ _ vars vu elrb e => "letrec FIXME in " +++ exprToString e
     end.
-  Instance ExprToString Γ Δ ξ τ : ToString (Expr Γ Δ ξ τ) := { toString := exprToString }.
+  Instance ExprToString Γ Δ ξ τ l : ToString (Expr Γ Δ ξ τ l) := { toString := exprToString }.
 
 End HaskStrong.
 Implicit Arguments StrongCaseBranchWithVVs [[Γ]].