X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMeta.hs;h=9412e41da9ab9f6a26d31ccf52d059e1e72e8a72;hb=eb9bbe105300c5a13ee9edc8a4965a2eb52019bd;hp=caea8044a6bf181a7efc2359460807cbadc641f7;hpb=e0445ffa5a89632b542e7d7bc2ad46d944716453;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index caea804..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 @@ -52,8 +52,10 @@ import OccName ( isDataOcc, isTvOcc, occNameUserString ) -- ws previously used in this file. import qualified OccName( varName, tcName ) -import Module ( moduleUserString ) +import Module ( Module, mkThPkgModule, moduleUserString ) import Id ( Id, idType ) +import Name ( mkKnownKeyExternalName ) +import OccName ( mkOccFS ) import NameEnv import NameSet import Type ( Type, TyThing(..), mkGenTyConApp ) @@ -65,7 +67,7 @@ import SrcLoc ( noSrcLoc ) import Maybe ( catMaybes ) import Panic ( panic ) import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique ) -import BasicTypes ( NewOrData(..), StrictnessMark(..) ) +import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed ) import Outputable import FastString ( mkFastString ) @@ -297,83 +299,105 @@ repTy (HsPredTy (HsClassP c tys)) = repTy (foldl HsAppTy (HsTyVar c) tys) repTy other_ty = pprPanic "repTy" (ppr other_ty) -- HsForAllTy, HsKindSig ------------------------------------------------------------------------------ +----------------------------------------------------------------------------- -- Expressions ------------------------------------------------------------------------------ +----------------------------------------------------------------------------- repEs :: [HsExpr Name] -> DsM (Core [M.Expr]) repEs es = do { es' <- mapM repE es ; coreList exprTyConName es' } +-- FIXME: some of these panics should be converted into proper error messages +-- unless we can make sure that constructs, which are plainly not +-- supported in TH already lead to error messages at an earlier stage repE :: HsExpr Name -> DsM (Core M.Expr) -repE (HsVar x) - = do { mb_val <- dsLookupMetaEnv x - ; case mb_val of - Nothing -> do { str <- globalVar x - ; repVarOrCon x str } - Just (Bound y) -> repVarOrCon x (coreVar y) - Just (Splice e) -> do { e' <- dsExpr e - ; return (MkC e') } } - -repE (HsIPVar x) = panic "Can't represent implicit parameters" -repE (HsLit l) = do { a <- repLiteral l; repLit a } -repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a } - -repE (HsSplice n e loc) - = do { mb_val <- dsLookupMetaEnv n - ; case mb_val of - Just (Splice e) -> do { e' <- dsExpr e - ; return (MkC e') } - other -> pprPanic "HsSplice" (ppr n) } - - -repE (HsLam m) = repLambda m -repE (HsApp x y) = do {a <- repE x; b <- repE y; repApp a b} -repE (NegApp x nm) = panic "No negate yet" -repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b } -repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b } - -repE (OpApp e1 (HsVar op) fix e2) - = do { arg1 <- repE e1; - arg2 <- repE e2; - the_op <- lookupOcc op ; - repInfixApp arg1 the_op arg2 } - -repE (HsCase e ms loc) - = do { arg <- repE e - ; ms2 <- mapM repMatchTup ms - ; repCaseE arg (nonEmptyCoreList ms2) } - --- I havn't got the types here right yet -repE (HsDo DoExpr sts _ ty loc) = do { (ss,zs) <- repSts sts; - e <- repDoE (nonEmptyCoreList zs); - wrapGenSyns expTyConName ss e } -repE (HsDo ListComp sts _ ty loc) = do { (ss,zs) <- repSts sts; - e <- repComp (nonEmptyCoreList zs); - wrapGenSyns expTyConName ss e } - -repE (ArithSeqIn (From e)) = do { ds1 <- repE e; repFrom ds1 } -repE (ArithSeqIn (FromThen e1 e2)) = do { ds1 <- repE e1; ds2 <- repE e2; - repFromThen ds1 ds2 } -repE (ArithSeqIn (FromTo e1 e2)) = do { ds1 <- repE e1; ds2 <- repE e2; - repFromTo ds1 ds2 } -repE (ArithSeqIn (FromThenTo e1 e2 e3)) = do { ds1 <- repE e1; ds2 <- repE e2; - ds3 <- repE e3; repFromThenTo ds1 ds2 ds3 } - -repE (HsIf x y z loc) = do { a <- repE x; b <- repE y; c <- repE z; repCond a b c } - -repE (HsLet bs e) = do { (ss,ds) <- repBinds bs - ; e2 <- addBinds ss (repE e) - ; z <- repLetE ds e2 - ; wrapGenSyns expTyConName ss z } -repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs } -repE (ExplicitTuple es boxed) = do { xs <- repEs es; repTup xs } - -repE (ExplicitPArr ty es) = panic "No parallel arrays yet" -repE (RecordConOut _ _ _) = panic "No record construction yet" -repE (RecordUpdOut _ _ _ _) = panic "No record update yet" -repE (ExprWithTySig e ty) = panic "No expressions with type signatures yet" - +repE (HsVar x) = + do { mb_val <- dsLookupMetaEnv x + ; case mb_val of + Nothing -> do { str <- globalVar x + ; repVarOrCon x str } + 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 (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; + arg2 <- repE e2; + the_op <- lookupOcc op ; + repInfixApp arg1 the_op arg2 } + _ -> panic "DsMeta.repE: Operator is not a variable" +repE (NegApp x nm) = repE x >>= repNeg +repE (HsPar x) = repE x +repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b } +repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b } +repE (HsCase e ms loc) = do { arg <- repE e + ; ms2 <- mapM repMatchTup ms + ; repCaseE arg (nonEmptyCoreList ms2) } +repE (HsIf x y z loc) = do + a <- repE x + b <- repE y + c <- repE z + repCond a b c +repE (HsLet bs e) = do { (ss,ds) <- repBinds bs + ; e2 <- addBinds ss (repE e) + ; z <- repLetE ds e2 + ; wrapGenSyns expTyConName ss z } +-- FIXME: I haven't got the types here right yet +repE (HsDo ctxt sts _ ty loc) + | isComprCtxt ctxt = do { (ss,zs) <- repSts sts; + e <- repDoE (nonEmptyCoreList zs); + wrapGenSyns expTyConName ss e } + | otherwise = + panic "DsMeta.repE: Can't represent mdo and [: :] yet" + where + isComprCtxt ListComp = True + isComprCtxt DoExpr = True + isComprCtxt _ = False +repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs } +repE (ExplicitPArr ty es) = + panic "DsMeta.repE: No explicit parallel arrays yet" +repE (ExplicitTuple es boxed) + | isBoxed boxed = do { xs <- repEs es; repTup xs } + | 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) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 } +repE (ArithSeqOut _ aseq) = + case aseq of + From e -> do { ds1 <- repE e; repFrom ds1 } + FromThen e1 e2 -> do + ds1 <- repE e1 + ds2 <- repE e2 + repFromThen ds1 ds2 + FromTo e1 e2 -> do + ds1 <- repE e1 + ds2 <- repE e2 + repFromTo ds1 ds2 + FromThenTo e1 e2 e3 -> do + ds1 <- repE e1 + ds2 <- repE e2 + ds3 <- repE e3 + repFromThenTo ds1 ds2 ds3 +repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing" +repE (HsCCall _ _ _ _ _) = panic "DsMeta.repE: Can't represent __ccall__" +repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC" +repE (HsBracketOut _ _) = + panic "DsMeta.repE: Can't represent Oxford brackets" +repE (HsSplice n e loc) = do { mb_val <- dsLookupMetaEnv n + ; case mb_val of + Just (Splice e) -> do { e' <- dsExpr e + ; return (MkC e') } + other -> pprPanic "HsSplice" (ppr n) } +repE (HsReify _) = panic "DsMeta.repE: Can't represent reification" +repE e = + pprPanic "DsMeta.repE: Illegal expression form" (ppr e) ----------------------------------------------------------------------------- -- Building representations of auxillary structures like Match, Clause, Stmt, @@ -762,9 +786,15 @@ 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] +repNeg :: Core M.Expr -> DsM (Core M.Expr) +repNeg (MkC x) = rep2 negName [x] + repSectionL :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr) repSectionL (MkC x) (MkC y) = rep2 infixAppName [x,y] @@ -862,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 ------------------- @@ -949,12 +983,14 @@ 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, - infixAppName, sectionLName, sectionRName, guardedName, normalName, + listExpName, sigExpName, condName, letEName, caseEName, + infixAppName, negName, sectionLName, sectionRName, + guardedName, normalName, bindStName, letStName, noBindStName, parStName, fromName, fromThenName, fromToName, fromThenToName, funName, valName, liftName, @@ -976,11 +1012,13 @@ thModule :: Module -- NB: the THSyntax module comes from the "haskell-src" package thModule = mkThPkgModule mETA_META_Name -mk_known_key_name space mod str uniq +mk_known_key_name space str uniq = mkKnownKeyExternalName thModule (mkOccFS 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 @@ -998,10 +1036,12 @@ 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 infixAppName = varQual FSLIT("infixApp") infixAppIdKey +negName = varQual FSLIT("neg") negIdKey sectionLName = varQual FSLIT("sectionL") sectionLIdKey sectionRName = varQual FSLIT("sectionR") sectionRIdKey guardedName = varQual FSLIT("guarded") guardedIdKey @@ -1127,25 +1167,33 @@ condIdKey = mkPreludeMiscIdUnique 238 letEIdKey = mkPreludeMiscIdUnique 239 caseEIdKey = mkPreludeMiscIdUnique 240 infixAppIdKey = mkPreludeMiscIdUnique 241 -sectionLIdKey = mkPreludeMiscIdUnique 242 -sectionRIdKey = mkPreludeMiscIdUnique 243 -guardedIdKey = mkPreludeMiscIdUnique 244 -normalIdKey = mkPreludeMiscIdUnique 245 -bindStIdKey = mkPreludeMiscIdUnique 246 -letStIdKey = mkPreludeMiscIdUnique 247 -noBindStIdKey = mkPreludeMiscIdUnique 248 -parStIdKey = mkPreludeMiscIdUnique 249 - -tvarIdKey = mkPreludeMiscIdUnique 250 -tconIdKey = mkPreludeMiscIdUnique 251 -tappIdKey = mkPreludeMiscIdUnique 252 - -arrowIdKey = mkPreludeMiscIdUnique 253 -tupleIdKey = mkPreludeMiscIdUnique 254 -listIdKey = mkPreludeMiscIdUnique 255 -namedTyConIdKey = mkPreludeMiscIdUnique 256 - -constrIdKey = mkPreludeMiscIdUnique 257 +negIdKey = mkPreludeMiscIdUnique 242 +sectionLIdKey = mkPreludeMiscIdUnique 243 +sectionRIdKey = mkPreludeMiscIdUnique 244 +guardedIdKey = mkPreludeMiscIdUnique 245 +normalIdKey = mkPreludeMiscIdUnique 246 +bindStIdKey = mkPreludeMiscIdUnique 247 +letStIdKey = mkPreludeMiscIdUnique 248 +noBindStIdKey = mkPreludeMiscIdUnique 249 +parStIdKey = mkPreludeMiscIdUnique 250 + +tvarIdKey = mkPreludeMiscIdUnique 251 +tconIdKey = mkPreludeMiscIdUnique 252 +tappIdKey = mkPreludeMiscIdUnique 253 + +arrowIdKey = mkPreludeMiscIdUnique 254 +tupleIdKey = mkPreludeMiscIdUnique 255 +listIdKey = mkPreludeMiscIdUnique 256 +namedTyConIdKey = mkPreludeMiscIdUnique 257 + +constrIdKey = mkPreludeMiscIdUnique 258 + +stringLIdKey = mkPreludeMiscIdUnique 259 +rationalLIdKey = mkPreludeMiscIdUnique 260 + +sigExpIdKey = mkPreludeMiscIdUnique 261 + + -- %************************************************************************ -- %* *