eliminate reliance on -XRebindableSyntax

[ghc-hetmet.git] / compiler / typecheck / TcExpr.lhs

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index a068e53..976aca7 100644 (file)
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -50,6 +50,7 @@ import TysWiredIn
 import TysPrim( intPrimTy )
 import PrimOp( tagToEnumKey )
 import PrelNames
+import Module
 import DynFlags
 import SrcLoc
 import Util
@@ -185,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') }
 
@@ -203,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
@@ -778,7 +799,7 @@ tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
        ; expr1' <- tcPolyExpr expr1 elt_ty
        ; expr2' <- tcPolyExpr expr2 elt_ty
        ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq) 
-                                enumFromToPName elt_ty 
+                                (enumFromToPName basePackageId) elt_ty    -- !!!FIXME: chak
        ; return $ mkHsWrapCoI coi 
                      (PArrSeq enum_from_to (FromTo expr1' expr2')) }
 
@@ -788,7 +809,7 @@ tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
        ; expr2' <- tcPolyExpr expr2 elt_ty
        ; expr3' <- tcPolyExpr expr3 elt_ty
        ; eft <- newMethodFromName (PArrSeqOrigin seq)
-                     enumFromThenToPName elt_ty
+                     (enumFromThenToPName basePackageId) elt_ty        -- !!!FIXME: chak
        ; return $ mkHsWrapCoI coi 
                      (PArrSeq eft (FromThenTo expr1' expr2' expr3')) }