X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=a068e5318ed8ead5cacd5f453b6af3eff59d561d;hp=3f5a258ed3648bb5ab174e01e027187300edf275;hb=34c8d0312071f7d0f4d221a997d3408c653ef9e5;hpb=cb8fb4dc68b503474bd65c0a669d9018a3ce96fe

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 3f5a258..a068e53 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -42,6 +42,7 @@ import DataCon
 import Name
 import TyCon
 import Type
+import TypeRep
 import Coercion
 import Var
 import VarSet
@@ -136,12 +137,52 @@ tcInfExpr e             = tcInfer (tcExpr e)
 %************************************************************************
 
 \begin{code}
+
+updHetMetLevel :: ([TyVar] -> [TyVar]) -> TcM a -> TcM a
+updHetMetLevel f comp =
+    updEnv
+      (\oldenv -> let oldlev = (case oldenv of Env { env_lcl = e' } -> case e' of TcLclEnv { tcl_hetMetLevel = x } -> x)
+                  in (oldenv { env_lcl = (env_lcl oldenv) { tcl_hetMetLevel = f oldlev } }))
+                  
+      comp
+
+addEscapes :: [TyVar] -> HsExpr Name -> HsExpr Name
+addEscapes []     e = e
+addEscapes (t:ts) e = HsHetMetEsc (TyVarTy t) placeHolderType (noLoc (addEscapes ts e))
+
+getIdLevel :: Name -> TcM [TyVar]
+getIdLevel name
+       = do { thing <- tcLookup name
+	    ; case thing of
+    	    	 ATcId { tct_hetMetLevel = variable_hetMetLevel } -> return $ variable_hetMetLevel
+                 _ -> return []
+            }
+
 tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
 tcExpr e res_ty | debugIsOn && isSigmaTy res_ty     -- Sanity check
        	        = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
 
 tcExpr (HsVar name)  res_ty = tcCheckId name res_ty
 
+tcExpr (HsHetMetBrak _ e) res_ty =
+    do { (coi, [inferred_name,elt_ty]) <- matchExpectedTyConApp hetMetCodeTypeTyCon res_ty
+       ; fresh_ec_name <- newFlexiTyVar liftedTypeKind
+       ; expr' <-  updHetMetLevel (\old_lev -> (fresh_ec_name:old_lev))
+                   $ tcPolyExpr e elt_ty
+       ; unifyType (TyVarTy fresh_ec_name) inferred_name
+       ; return $ mkHsWrapCoI coi (HsHetMetBrak (TyVarTy fresh_ec_name) expr') }
+tcExpr (HsHetMetEsc _ _ e) res_ty =
+    do { cur_level <- getHetMetLevel
+       ; expr' <-  updHetMetLevel (\old_lev -> tail old_lev)
+                   $ tcExpr (unLoc e) (mkTyConApp hetMetCodeTypeTyCon [(TyVarTy $ head cur_level),res_ty])
+       ; ty' <- zonkTcType res_ty
+       ; return $ mkHsWrapCoI (ACo res_ty) (HsHetMetEsc (TyVarTy $ head cur_level) ty' (noLoc expr')) }
+tcExpr (HsHetMetCSP _ e) res_ty =
+    do { cur_level <- getHetMetLevel
+       ; expr' <-  updHetMetLevel (\old_lev -> tail old_lev)
+                   $ tcExpr (unLoc e) res_ty
+       ; return $ mkHsWrapCoI (ACo res_ty) (HsHetMetCSP (TyVarTy $ head cur_level) (noLoc expr')) }
+
 tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty
 
 tcExpr (HsLit lit)   res_ty = do { let lit_ty = hsLitType lit
@@ -960,24 +1001,40 @@ tcInferId n = tcInferIdWithOrig (OccurrenceOf n) n
 tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
 -- Look up an occurrence of an Id, and instantiate it (deeply)
 
-tcInferIdWithOrig orig id_name
-  = do { id <- lookup_id
-       ; (id_expr, id_rho) <- instantiateOuter orig id
-       ; (wrap, rho) <- deeplyInstantiate orig id_rho
-       ; return (mkHsWrap wrap id_expr, rho) }
+tcInferIdWithOrig orig id_name =
+ do { id_level  <- getIdLevel id_name
+    ; cur_level <- getHetMetLevel
+    ; if (length id_level < length cur_level)
+      then do { (lhexp, tcrho) <-
+                    tcInferRho (noLoc $ addEscapes (take ((length cur_level) - (length id_level)) cur_level) (HsVar id_name))
+              ; return (unLoc lhexp, tcrho)
+              }
+      else tcInferIdWithOrig' orig id_name
+    }
+
+tcInferIdWithOrig' orig id_name =
+  do { id <- lookup_id
+     ; (id_expr, id_rho) <- instantiateOuter orig id
+     ; (wrap, rho) <- deeplyInstantiate orig id_rho
+     ; return (mkHsWrap wrap id_expr, rho) }
   where
     lookup_id :: TcM TcId
     lookup_id 
        = do { thing <- tcLookup id_name
 	    ; case thing of
-    	    	 ATcId { tct_id = id, tct_level = lvl }
+    	    	 ATcId { tct_id = id, tct_level = lvl, tct_hetMetLevel = variable_hetMetLevel }
 	           -> do { check_naughty id        -- Note [Local record selectors]
                          ; checkThLocalId id lvl
+                         ; current_hetMetLevel  <- getHetMetLevel
+                         ; mapM
+                             (\(name1,name2) -> unifyType (TyVarTy name1) (TyVarTy name2))
+                             (zip variable_hetMetLevel current_hetMetLevel)
                          ; return id }
 
     	    	 AGlobal (AnId id) 
-                   -> do { check_naughty id; return id }
-	    	 	-- A global cannot possibly be ill-staged
+                   -> do { check_naughty id
+                         ; return id }
+	    	 	-- A global cannot possibly be ill-staged in Template Haskell
 	    	 	-- nor does it need the 'lifting' treatment
                         -- hence no checkTh stuff here