Commit eb9bbe10 authored by simonpj's avatar simonpj

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

Add string/rational literals, and e::t form to TH
parent 8a82d183
......@@ -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
......
......@@ -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)
......
......@@ -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)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment