[project @ 2002-10-31 13:13:04 by simonpj]

Finish TH exprs with type sigs

diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index 9412e41..ed01e3f 100644 (file)
--- a/ghc/compiler/deSugar/DsMeta.hs
+++ b/ghc/compiler/deSugar/DsMeta.hs
@@ -42,7 +42,7 @@ import HsSyn            ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..),
                    toHsType
                  )
 
-import PrelNames  ( mETA_META_Name )
+import PrelNames  ( mETA_META_Name, rationalTyConName )
 import MkIface   ( ifaceTyThing )
 import Name       ( Name, nameOccName, nameModule )
 import OccName   ( isDataOcc, isTvOcc, occNameUserString )
@@ -320,10 +320,13 @@ repE (HsVar x)            =
        Just (Splice e)  -> do { e' <- dsExpr e
                               ; return (MkC e') } }
 repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
-repE (HsLit l)   = do { a <- repLiteral l;           repLit a }
-repE (HsLam m)   = repLambda m
-repE (HsApp x y) = do {a <- repE x; b <- repE y; repApp a b}
--- HsOverLit l never happens (if it does, the catch-all will find it)
+
+       -- Remember, we're desugaring renamer output here, so
+       -- HsOverlit can definitely occur
+repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
+repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
+repE (HsLam m)     = repLambda m
+repE (HsApp x y)   = do {a <- repE x; b <- repE y; repApp a b}
 
 repE (OpApp e1 op fix e2) =
   case op of
@@ -904,6 +907,13 @@ repLiteral lit
     uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
                    (ppr lit)
 
+repOverloadedLiteral :: HsOverLit -> DsM (Core M.Lit)
+repOverloadedLiteral (HsIntegral i _)   = repLiteral (HsInt i)
+repOverloadedLiteral (HsFractional f _) = do { rat_ty <- lookupType rationalTyConName ;
+                                              repLiteral (HsRat f rat_ty) }
+       -- The type Rational will be in the environment, becuase 
+       -- the smart constructor 'THSyntax.rationalL' uses it in its type,
+       -- and rationalL is sucked in when any TH stuff is used
               
 --------------- Miscellaneous -------------------
 

diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs
index b7d96e9..904c89d 100644 (file)
--- a/ghc/compiler/hsSyn/Convert.lhs
+++ b/ghc/compiler/hsSyn/Convert.lhs
@@ -107,7 +107,7 @@ cvt (Infix (Just x) s (Just y)) = OpApp (cvt x) (HsVar(vName s)) undefined (cvt
 cvt (Infix Nothing  s (Just y)) = SectionR (HsVar(vName s)) (cvt y)
 cvt (Infix (Just x) s Nothing ) = SectionL (cvt x) (HsVar(vName s))
 cvt (Infix Nothing  s Nothing ) = HsVar(vName s) -- Can I indicate this is an infix thing?
-
+cvt (SigExp e t)               = ExprWithTySig (cvt e) (cvtType t)
 
 cvtdecs :: [Meta.Dec] -> HsBinds RdrName
 cvtdecs [] = EmptyBinds

diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs
index f29069e..6f60abf 100644 (file)
--- a/ghc/compiler/typecheck/TcSplice.lhs
+++ b/ghc/compiler/typecheck/TcSplice.lhs
@@ -349,10 +349,10 @@ Two successive brackets aren't allowed
 showSplice :: String -> TypecheckedHsExpr -> SDoc -> TcM ()
 showSplice what before after
   = getSrcLocM         `thenM` \ loc ->
-    traceSplice (hang (ppr loc <> colon <+> text "Splicing" <+> text what) 4
-                     (sep [nest 2 (ppr before),
-                           text "======>",
-                           nest 2 after]))
+    traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what, 
+                      nest 2 (sep [nest 2 (ppr before),
+                                   text "======>",
+                                   nest 2 after])])
 
 illegalSplice level
   = ptext SLIT("Illegal splice at level") <+> ppr level