[project @ 2002-10-30 13:16:40 by simonpj]

Add string/rational literals, and e::t form to TH

ghc/compiler/deSugar/DsMeta.hs

@@ -20,8 +20,8 @@ module DsMeta( dsBracket, dsReify,
 
 import {-# SOURCE #-}	DsExpr ( dsExpr )
 
-import DsUtils    ( mkListExpr, mkStringLit, mkCoreTup,
-		    mkIntExpr, mkCharExpr )
+import MatchLit	  ( dsLit )
+import DsUtils    ( mkListExpr, mkStringLit, mkCoreTup, mkIntExpr )
 import DsMonad
 
 import qualified Language.Haskell.THSyntax as M
@@ -319,12 +319,12 @@ repE (HsVar x)            =
 	Just (Bound y)   -> repVarOrCon x (coreVar y)
 	Just (Splice e)  -> do { e' <- dsExpr e
 			       ; return (MkC e') } }
-repE (HsIPVar x)          = 
-  panic "DsMeta.repE: Can't represent implicit parameters"
-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 (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)
+
 repE (OpApp e1 op fix e2) =
   case op of
     HsVar op -> do { arg1 <- repE e1; 
@@ -367,8 +367,8 @@ repE (ExplicitTuple es boxed)
   | otherwise		  = panic "DsMeta.repE: Can't represent unboxed tuples"
 repE (RecordConOut _ _ _) = panic "DsMeta.repE: No record construction yet"
 repE (RecordUpdOut _ _ _ _) = panic "DsMeta.repE: No record update yet"
-repE (ExprWithTySig e ty) = 
-  panic "DsMeta.repE: No expressions with type signatures yet" 
+
+repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 }
 repE (ArithSeqOut _ aseq) =
   case aseq of
     From e              -> do { ds1 <- repE e; repFrom ds1 }
@@ -786,6 +786,9 @@ repComp (MkC ss) = rep2 compName [ss]
 repListExp :: Core [M.Expr] -> DsM (Core M.Expr)
 repListExp (MkC es) = rep2 listExpName [es]
 
+repSigExp :: Core M.Expr -> Core M.Type -> DsM (Core M.Expr)
+repSigExp (MkC e) (MkC t) = rep2 sigExpName [e,t]
+
 repInfixApp :: Core M.Expr -> Core String -> Core M.Expr -> DsM (Core M.Expr)
 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
 
@@ -889,13 +892,17 @@ repListTyCon = rep2 listTyConName []
 --		Literals
 
 repLiteral :: HsLit -> DsM (Core M.Lit)
-repLiteral (HsInt i)  = rep2 intLName [mkIntExpr i]
-repLiteral (HsChar c) = rep2 charLName [mkCharExpr c]
-repLiteral x = panic "trying to represent exotic literal"
-
-repOverloadedLiteral :: HsOverLit -> DsM(Core M.Lit)
-repOverloadedLiteral (HsIntegral i _)   = rep2 intLName [mkIntExpr i]
-repOverloadedLiteral (HsFractional f _) = panic "Cant do fractional literals yet"
+repLiteral lit 
+  = do { lit_expr <- dsLit lit; rep2 lit_name [lit_expr] }
+  where
+    lit_name = case lit of
+		 HsInt _    -> intLName
+		 HsChar _   -> charLName
+		 HsString _ -> stringLName
+		 HsRat _ _  -> rationalLName
+		 other 	    -> uh_oh
+    uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
+		    (ppr lit)
 
               
 --------------- Miscellaneous -------------------
@@ -976,11 +983,12 @@ templateHaskellNames :: NameSet
 -- The names that are implicitly mentioned by ``bracket''
 -- Should stay in sync with the import list of DsMeta
 templateHaskellNames
-  = mkNameSet [ intLName,charLName, plitName, pvarName, ptupName, 
+  = mkNameSet [ intLName,charLName, stringLName, rationalLName,
+		plitName, pvarName, ptupName, 
 		pconName, ptildeName, paspatName, pwildName, 
                 varName, conName, litName, appName, infixEName, lamName,
                 tupName, doEName, compName, 
-                listExpName, condName, letEName, caseEName,
+                listExpName, sigExpName, condName, letEName, caseEName,
                 infixAppName, negName, sectionLName, sectionRName,
                 guardedName, normalName, 
 		bindStName, letStName, noBindStName, parStName,
@@ -1009,6 +1017,8 @@ mk_known_key_name space str uniq
 
 intLName       = varQual FSLIT("intL")          intLIdKey
 charLName      = varQual FSLIT("charL")         charLIdKey
+stringLName    = varQual FSLIT("stringL")       stringLIdKey
+rationalLName  = varQual FSLIT("rationalL")     rationalLIdKey
 plitName       = varQual FSLIT("plit")          plitIdKey
 pvarName       = varQual FSLIT("pvar")          pvarIdKey
 ptupName       = varQual FSLIT("ptup")          ptupIdKey
@@ -1026,6 +1036,7 @@ tupName        = varQual FSLIT("tup")           tupIdKey
 doEName        = varQual FSLIT("doE")           doEIdKey
 compName       = varQual FSLIT("comp")          compIdKey
 listExpName    = varQual FSLIT("listExp")       listExpIdKey
+sigExpName     = varQual FSLIT("sigExp")        sigExpIdKey
 condName       = varQual FSLIT("cond")          condIdKey
 letEName       = varQual FSLIT("letE")          letEIdKey
 caseEName      = varQual FSLIT("caseE")         caseEIdKey
@@ -1177,6 +1188,13 @@ namedTyConIdKey	= mkPreludeMiscIdUnique 257
 
 constrIdKey	= mkPreludeMiscIdUnique 258
 
+stringLIdKey	= mkPreludeMiscIdUnique 259
+rationalLIdKey	= mkPreludeMiscIdUnique 260
+
+sigExpIdKey     = mkPreludeMiscIdUnique 261
+
+
+
 -- %************************************************************************
 -- %*									*
 --		Other utilities

ghc/compiler/deSugar/DsUtils.lhs

@@ -401,9 +401,11 @@ mkErrorAppDs err_id ty msg
 %************************************************************************
 
 \begin{code}
-mkCharExpr    :: Int	 -> CoreExpr	  -- Returns 	C# c :: Int
-mkIntExpr     :: Integer -> CoreExpr	  -- Returns 	I# i :: Int
-mkIntegerExpr :: Integer -> DsM CoreExpr  -- Result :: Integer
+mkCharExpr    :: Int	    -> CoreExpr	     -- Returns	C# c :: Int
+mkIntExpr     :: Integer    -> CoreExpr	     -- Returns	I# i :: Int
+mkIntegerExpr :: Integer    -> DsM CoreExpr  -- Result :: Integer
+mkStringLit   :: String     -> DsM CoreExpr  -- Result :: String
+mkStringLitFS :: FastString -> DsM CoreExpr  -- Result :: String
 
 mkIntExpr  i = mkConApp intDataCon  [mkIntLit i]
 mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)]
@@ -438,10 +440,8 @@ mkIntegerExpr i
 
 mkSmallIntegerLit i = mkConApp smallIntegerDataCon [mkIntLit i]
 
-mkStringLit   :: String       -> DsM CoreExpr
 mkStringLit str	= mkStringLitFS (mkFastString str)
 
-mkStringLitFS :: FastString  -> DsM CoreExpr
 mkStringLitFS str
   | nullFastString str
   = returnDs (mkNilExpr charTy)

ghc/compiler/hsSyn/Convert.lhs

@@ -26,7 +26,7 @@ import HsSyn as Hs
 
 import RdrName	( RdrName, mkRdrUnqual, mkRdrQual, mkOrig )
 import Module   ( mkModuleName )
-import RdrHsSyn	( mkHsIntegral, mkClassDecl, mkTyData )
+import RdrHsSyn	( mkHsIntegral, mkHsFractional, mkClassDecl, mkTyData )
 import OccName
 import SrcLoc	( SrcLoc, generatedSrcLoc )
 import TyCon	( DataConDetails(..) )
@@ -173,11 +173,14 @@ cvtpair (x,y) = GRHS [BindStmt truePat (cvt x) loc0,
 		      ResultStmt (cvt y) loc0] loc0
 
 cvtOverLit :: Lit -> HsOverLit
-cvtOverLit (Int i) = mkHsIntegral (fromInt i)
+cvtOverLit (Int i)      = mkHsIntegral (fromInt i)
+cvtOverLit (Rational r) = mkHsFractional r
 -- An Int is like an an (overloaded) '3' in a Haskell source program
+-- Similarly 3.5 for fractionals
 
 cvtLit :: Lit -> HsLit
-cvtLit (Char c)	      = HsChar (ord c)
+cvtLit (Char c)	  = HsChar (ord c)
+cvtLit (String s) = HsString (mkFastString s)
 
 cvtp :: Meta.Pat -> Hs.Pat RdrName
 cvtp (Plit l)