X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=7d7c46141c88ff6f53786bbf6bfe13f99b7e7b22;hb=1e3348f855578fc60ed52fa62bb4846798a5cd3e;hp=9f960b1cfc7e41a1357516d342f1f23a2c6feea2;hpb=9176377bf7d989919fe7d27cad1f56bd9c4e7b6b;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 9f960b1..7d7c461 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -167,7 +167,7 @@ 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
+       ; fresh_ec_name <- newFlexiTyVar ecKind
        ; expr' <-  updHetMetLevel (\old_lev -> (fresh_ec_name:old_lev))
                    $ tcPolyExpr e elt_ty
        ; unifyType (TyVarTy fresh_ec_name) inferred_name
@@ -186,9 +186,20 @@ 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') }
 
@@ -204,9 +215,18 @@ tcExpr (HsCoreAnn lbl expr) res_ty
   = do	{ expr' <- tcMonoExpr expr res_ty
 	; return (HsCoreAnn lbl expr') }
 
-tcExpr (HsOverLit lit) res_ty  
-  = do 	{ lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty
-	; return (HsOverLit lit') }
+tcExpr (HsOverLit lit) res_ty =
+  getHetMetLevel >>= \lev ->
+   case lev of
+    []        -> do { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty
+	            ; return (HsOverLit lit') }
+    (ec:rest) -> let n = case lit of
+                           (OverLit { ol_val = HsIntegral i   }) -> hetmet_guest_integer_literal_name
+                           (OverLit { ol_val = HsIsString fs  }) -> hetmet_guest_string_literal_name
+                           (OverLit { ol_val = HsFractional f }) -> error "fractional literals not allowed at depth >0"
+                 in  tcExpr (HsHetMetEsc (TyVarTy ec) placeHolderType $ noLoc $
+                                         (HsApp (noLoc $ HsVar n) (noLoc $ HsOverLit lit))) res_ty
+  
 
 tcExpr (NegApp expr neg_expr) res_ty
   = do	{ neg_expr' <- tcSyntaxOp NegateOrigin neg_expr