X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsMeta.hs;h=42e96bf724b4ef116bf1762bb892df883b7dee61;hb=235edf36cc202bb21c00d0e5e05ebf076fb0542e;hp=b41873f7b81ba1528f0ac7ab3b014a0f40728c7f;hpb=90dc9026b091be5cca5da4c6cbd3713ecc493361;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index b41873f..42e96bf 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -13,11 +13,18 @@ -- a Royal Pain (triggers other recompilation). ----------------------------------------------------------------------------- +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details module DsMeta( dsBracket, templateHaskellNames, qTyConName, nameTyConName, - liftName, expQTyConName, decQTyConName, typeQTyConName, - decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName + liftName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName, + decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName, + quoteExpName, quotePatName ) where #include "HsVersions.h" @@ -33,7 +40,6 @@ import qualified Language.Haskell.TH as TH import HsSyn import Class import PrelNames -import OccName -- To avoid clashes with DsMeta.varName we must make a local alias for -- OccName.varName we do this by removing varName from the import of -- OccName above, making a qualified instance of OccName and using @@ -42,10 +48,8 @@ import qualified OccName import Module import Id -import OccName import Name import NameEnv -import Type import TcType import TyCon import TysWiredIn @@ -421,7 +425,7 @@ repTy (HsForAllTy _ tvs ctxt ty) = repTy (HsTyVar n) | isTvOcc (nameOccName n) = do - tv1 <- lookupBinder n + tv1 <- lookupTvOcc n repTvar tv1 | otherwise = do tc1 <- lookupOcc n @@ -534,7 +538,7 @@ repE (RecordCon c _ flds) = do { x <- lookupLOcc c; fs <- repFields flds; repRecCon x fs } -repE (RecordUpd e flds _ _) +repE (RecordUpd e flds _ _ _) = do { x <- repLE e; fs <- repFields flds; repRecUpd x fs } @@ -616,12 +620,12 @@ repGuards other g <- repPatGE (nonEmptyCoreList ss') rhs' return (gs, g) -repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp]) -repFields flds = do - fnames <- mapM lookupLOcc (map fst flds) - es <- mapM repLE (map snd flds) - fs <- zipWithM repFieldExp fnames es - coreList fieldExpQTyConName fs +repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp]) +repFields (HsRecFields { rec_flds = flds }) + = do { fnames <- mapM lookupLOcc (map hsRecFieldId flds) + ; es <- mapM repLE (map hsRecFieldArg flds) + ; fs <- zipWithM repFieldExp fnames es + ; coreList fieldExpQTyConName fs } ----------------------------------------------------------------------------- @@ -704,8 +708,8 @@ rep_val_binds (ValBindsOut binds sigs) = do { core1 <- rep_binds' (unionManyBags (map snd binds)) ; core2 <- rep_sigs' sigs ; return (core1 ++ core2) } -rep_val_binds (ValBindsOut binds sigs) - = panic "rep_val_binds: ValBindsOut" +rep_val_binds (ValBindsIn binds sigs) + = panic "rep_val_binds: ValBindsIn" rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ] rep_binds binds = do { binds_w_locs <- rep_binds' binds @@ -787,7 +791,7 @@ repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds))) do { xs <- repLPs ps; body <- repLE e; repLam xs body }) ; wrapGenSyns ss lam } -repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch LambdaExpr m) +repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m) ----------------------------------------------------------------------------- @@ -817,9 +821,10 @@ repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs } repP (ConPatIn dc details) = do { con_str <- lookupLOcc dc ; case details of - PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs } - RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map hsRecFieldId pairs) - ; ps <- sequence $ map repLP (map hsRecFieldArg pairs) + PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs } + RecCon rec -> do { let flds = rec_flds rec + ; vs <- sequence $ map lookupLOcc (map hsRecFieldId flds) + ; ps <- sequence $ map repLP (map hsRecFieldArg flds) ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps ; fps' <- coreList fieldPatQTyConName fps ; repPrec con_str fps' } @@ -827,8 +832,8 @@ repP (ConPatIn dc details) p2' <- repLP p2; repPinfix p1' con_str p2' } } -repP (NPat l Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a } -repP p@(NPat l (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p) +repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a } +repP p@(NPat l (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p) -- The problem is to do with scoped type variables. -- To implement them, we have to implement the scoping rules @@ -913,6 +918,18 @@ lookupOcc n Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n) } +lookupTvOcc :: Name -> DsM (Core TH.Name) +-- Type variables can't be staged and are not lexically scoped in TH +lookupTvOcc n + = do { mb_val <- dsLookupMetaEnv n ; + case mb_val of + Just (Bound x) -> return (coreVar x) + other -> failWithDs msg + } + where + msg = vcat [ ptext SLIT("Illegal lexically-scoped type variable") <+> quotes (ppr n) + , ptext SLIT("Lexically scoped type variables are not supported by Template Haskell") ] + globalVar :: Name -> DsM (Core TH.Name) -- Not bound by the meta-env -- Could be top-level; or could be local @@ -1188,15 +1205,15 @@ repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty] repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ) repCtxt (MkC tys) = rep2 cxtName [tys] -repConstr :: Core TH.Name -> HsConDetails Name (LBangType Name) +repConstr :: Core TH.Name -> HsConDeclDetails Name -> DsM (Core TH.ConQ) repConstr con (PrefixCon ps) = do arg_tys <- mapM repBangTy ps arg_tys1 <- coreList strictTypeQTyConName arg_tys rep2 normalCName [unC con, unC arg_tys1] repConstr con (RecCon ips) - = do arg_vs <- mapM lookupLOcc (map hsRecFieldId ips) - arg_tys <- mapM repBangTy (map hsRecFieldArg ips) + = do arg_vs <- mapM lookupLOcc (map cd_fld_name ips) + arg_tys <- mapM repBangTy (map cd_fld_type ips) arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y]) arg_vs arg_tys arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys @@ -1273,9 +1290,9 @@ mk_string s = do string_ty <- lookupType stringTyConName return $ HsString s repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit) -repOverloadedLiteral (HsIntegral i _) = do { lit <- mk_integer i; repLiteral lit } -repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit } -repOverloadedLiteral (HsIsString s _) = do { lit <- mk_string s; repLiteral lit } +repOverloadedLiteral (HsIntegral i _ _) = do { lit <- mk_integer i; repLiteral lit } +repOverloadedLiteral (HsFractional f _ _) = do { lit <- mk_rational f; repLiteral lit } +repOverloadedLiteral (HsIsString s _ _) = do { lit <- mk_string s; repLiteral lit } -- The type Rational will be in the environment, becuase -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, -- and rationalL is sucked in when any TH stuff is used @@ -1409,11 +1426,15 @@ templateHaskellNames = [ decQTyConName, conQTyConName, strictTypeQTyConName, varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName, typeTyConName, matchTyConName, clauseTyConName, patQTyConName, - fieldPatQTyConName, fieldExpQTyConName, funDepTyConName] + fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, + + -- Quasiquoting + quoteExpName, quotePatName] thSyn :: Module thSyn = mkTHModule FSLIT("Language.Haskell.TH.Syntax") thLib = mkTHModule FSLIT("Language.Haskell.TH.Lib") +qqLib = mkTHModule FSLIT("Language.Haskell.TH.Quote") mkTHModule m = mkModule thPackageId (mkModuleNameFS m) @@ -1421,6 +1442,7 @@ libFun = mk_known_key_name OccName.varName thLib libTc = mk_known_key_name OccName.tcName thLib thFun = mk_known_key_name OccName.varName thSyn thTc = mk_known_key_name OccName.tcName thSyn +qqFun = mk_known_key_name OccName.varName qqLib -------------------- TH.Syntax ----------------------- qTyConName = thTc FSLIT("Q") qTyConKey @@ -1587,6 +1609,10 @@ fieldExpQTyConName = libTc FSLIT("FieldExpQ") fieldExpQTyConKey patQTyConName = libTc FSLIT("PatQ") patQTyConKey fieldPatQTyConName = libTc FSLIT("FieldPatQ") fieldPatQTyConKey +-- quasiquoting +quoteExpName = qqFun FSLIT("quoteExp") quoteExpKey +quotePatName = qqFun FSLIT("quotePat") quotePatKey + -- TyConUniques available: 100-129 -- Check in PrelNames if you want to change this @@ -1753,3 +1779,7 @@ threadsafeIdKey = mkPreludeMiscIdUnique 307 -- data FunDep = ... funDepIdKey = mkPreludeMiscIdUnique 320 +-- quasiquoting +quoteExpKey = mkPreludeMiscIdUnique 321 +quotePatKey = mkPreludeMiscIdUnique 322 +