From eb9bbe105300c5a13ee9edc8a4965a2eb52019bd Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 30 Oct 2002 13:17:06 +0000 Subject: [PATCH] [project @ 2002-10-30 13:16:40 by simonpj] Add string/rational literals, and e::t form to TH --- ghc/compiler/deSugar/DsMeta.hs | 56 +++++++++++++++++++++++++------------- ghc/compiler/deSugar/DsUtils.lhs | 10 +++---- ghc/compiler/hsSyn/Convert.lhs | 9 ++++-- 3 files changed, 48 insertions(+), 27 deletions(-) diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index fe77aff..9412e41 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/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 diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index fe5aa75..790097c 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/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) diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index c8cca66..b7d96e9 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/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) -- 1.7.10.4