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

diff --git a/compiler/coq b/compiler/coq
index 11f5f9e..666a692 160000 (submodule)
--- 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 (file)
--- 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 (file)
--- 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') }