From: Adam Megacz <megacz@cs.berkeley.edu>
Date: Tue, 8 Mar 2011 04:35:15 +0000 (-0800)
Subject: handle stage-(n+1) literals properly by expanding them in the typechecker
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=ce15c63e3e309ee175dfa5f4ad787c347c7dab1c;hp=9e5a454cd78650a0c9e2a859693ee1af056b3fb9

handle stage-(n+1) literals properly by expanding them in the typechecker
---

diff --git a/compiler/coq b/compiler/coq
index 11f5f9e..666a692 160000
--- a/compiler/coq
+++ b/compiler/coq
@@ -1 +1 @@
-Subproject commit 11f5f9e762626272e8d339d8e6edad514e536041
+Subproject commit 666a6921196c8bea334158985fb1bca61dee0fe5
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 5c2dfa0..b43373e 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -788,9 +788,9 @@ hetmet_guest_integer_literal_name, hetmet_guest_string_literal_name, hetmet_gues
 hetmet_brak_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_brak") hetmet_brak_key
 hetmet_esc_name  = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_esc")  hetmet_esc_key
 hetmet_csp_name  = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_csp") hetmet_csp_key
-hetmet_guest_integer_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_guest_integer_literal") hetmet_guest_integer_literal_key
-hetmet_guest_string_literal_name  = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_guest_string_literal")  hetmet_guest_string_literal_key
-hetmet_guest_char_literal_name    = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_guest_char_literal")    hetmet_guest_char_literal_key
+hetmet_guest_integer_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "guestIntegerLiteral") hetmet_guest_integer_literal_key
+hetmet_guest_string_literal_name  = varQual gHC_HETMET_CODETYPES (fsLit "guestStringLiteral")  hetmet_guest_string_literal_key
+hetmet_guest_char_literal_name    = varQual gHC_HETMET_CODETYPES (fsLit "guestCharLiteral")    hetmet_guest_char_literal_key
 
 -- IO things
 ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName,
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 9f960b1..24399f9 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -186,9 +186,19 @@ tcExpr (HsHetMetCSP _ e) res_ty =
 
 tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty
 
-tcExpr (HsLit lit)   res_ty = do { let lit_ty = hsLitType lit
-		     	         ; tcWrapResult (HsLit lit) lit_ty res_ty }
-
+tcExpr (HsLit lit)   res_ty =
+  getHetMetLevel >>= \lev ->
+   case lev of
+    []        -> do { let lit_ty = hsLitType lit
+                    ; tcWrapResult (HsLit lit) lit_ty res_ty }
+    (ec:rest) -> let n = case lit of
+                                (HsChar c)       -> hetmet_guest_char_literal_name
+                                (HsString str)   -> hetmet_guest_string_literal_name
+                                (HsInteger i _)  -> hetmet_guest_integer_literal_name
+                                (HsInt i)        -> hetmet_guest_integer_literal_name
+                                _                -> error "literals of this sort are not allowed at depth >0"
+                 in  tcExpr (HsHetMetEsc (TyVarTy ec) placeHolderType $ noLoc $ HsApp (noLoc $ HsVar n) (noLoc $ HsLit lit)) res_ty
+  
 tcExpr (HsPar expr)  res_ty = do { expr' <- tcMonoExprNC expr res_ty
 				 ; return (HsPar expr') }