From ce15c63e3e309ee175dfa5f4ad787c347c7dab1c Mon Sep 17 00:00:00 2001 From: Adam Megacz Date: Mon, 7 Mar 2011 20:35:15 -0800 Subject: [PATCH] handle stage-(n+1) literals properly by expanding them in the typechecker --- compiler/coq | 2 +- compiler/prelude/PrelNames.lhs | 6 +++--- compiler/typecheck/TcExpr.lhs | 16 +++++++++++++--- 3 files changed, 17 insertions(+), 7 deletions(-) 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') } -- 1.7.10.4