X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=5d23110e5fc9bdfa624d4cb761fd83c32a61468e;hp=2911ce01200d574501a1ea15c35dea11be024b97;hb=302e2e29f2e1074bfba561e077a484dc4e1d15f6;hpb=7854ec4b11e117f8514553890851d14a66690fbb diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 2911ce0..5d23110 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -5,12 +5,15 @@ \begin{code} module RnSource ( - rnSrcDecls, addTcgDUs, rnTyClDecls + rnSrcDecls, addTcgDUs, rnTyClDecls, findSplice ) where #include "HsVersions.h" import {-# SOURCE #-} RnExpr( rnLExpr ) +#ifdef GHCI +import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl ) +#endif /* GHCI */ import HsSyn import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc ) @@ -23,7 +26,7 @@ import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn, lookupTopBndrRn, lookupLocatedTopBndrRn, lookupOccRn, newLocalBndrsRn, bindLocalNamesFV, bindLocatedLocalsFV, bindPatSigTyVarsFV, - bindTyVarsRn, extendTyVarEnvFVRn, + bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn, bindLocalNames, checkDupRdrNames, mapFvRn ) import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn ) @@ -122,7 +125,7 @@ rnSrcDecls group@(HsGroup {hs_valds = val_decls, -- It uses the fixity env from (A) to bind fixities for view patterns. new_lhs <- rnTopBindsLHS local_fix_env val_decls ; -- bind the LHSes (and their fixities) in the global rdr environment - let { val_binders = map unLoc $ collectHsValBinders new_lhs ; + let { val_binders = collectHsValBinders new_lhs ; val_bndr_set = mkNameSet val_binders ; all_bndr_set = val_bndr_set `unionNameSets` availsToNameSet tc_avails ; val_avails = map Avail val_binders @@ -412,8 +415,8 @@ patchCImportSpec packageId spec patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget patchCCallTarget packageId callTarget = case callTarget of - PackageTarget label Nothing - -> PackageTarget label (Just packageId) + StaticTarget label Nothing + -> StaticTarget label (Just packageId) _ -> callTarget @@ -437,7 +440,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- The typechecker (not the renamer) checks that all -- the bindings are for the right class let - meth_names = collectHsBindLocatedBinders mbinds + meth_names = collectMethodBinders mbinds (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty') in checkDupRdrNames meth_names `thenM_` @@ -475,7 +478,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- -- But the (unqualified) method names are in scope let - binders = collectHsBindBinders mbinds' + binders = collectHsBindsBinders mbinds' bndr_set = mkNameSet binders in bindLocalNames binders @@ -682,32 +685,33 @@ rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name}) -- all flavours of type family declarations ("type family", "newtype fanily", -- and "data family") -rnTyClDecl (tydecl@TyFamily {}) = - rnFamily tydecl bindTyVarsRn +rnTyClDecl tydecl@TyFamily {} = rnFamily tydecl bindTyVarsFV -- "data", "newtype", "data instance, and "newtype instance" declarations rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, tcdTyVars = tyvars, - tcdTyPats = typatsMaybe, tcdCons = condecls, + tcdTyPats = typats, tcdCons = condecls, tcdKindSig = sig, tcdDerivs = derivs} = do { tycon' <- if isFamInstDecl tydecl then lookupLocatedOccRn tycon -- may be imported family else lookupLocatedTopBndrRn tycon ; checkTc (h98_style || null (unLoc context)) (badGadtStupidTheta tycon) - ; (tyvars', context', typats', derivs', deriv_fvs) - <- bindTyVarsRn tyvars $ \ tyvars' -> do + ; ((tyvars', context', typats', derivs'), stuff_fvs) + <- bindTyVarsFV tyvars $ \ tyvars' -> do -- Checks for distinct tyvars - { typats' <- rnTyPats data_doc typatsMaybe - ; context' <- rnContext data_doc context - ; (derivs', deriv_fvs) <- rn_derivs derivs - ; return (tyvars', context', typats', derivs', deriv_fvs) } - -- For GADTs, the type variables in the declaration - -- do not scope over the constructor signatures - -- data T a where { T1 :: forall b. b-> b } + { context' <- rnContext data_doc context + ; (typats', fvs1) <- rnTyPats data_doc tycon' typats + ; (derivs', fvs2) <- rn_derivs derivs + ; let fvs = fvs1 `plusFV` fvs2 `plusFV` + extractHsCtxtTyNames context' + ; return ((tyvars', context', typats', derivs'), fvs) } -- For the constructor declarations, bring into scope the tyvars -- bound by the header, but *only* in the H98 case + -- Reason: for GADTs, the type variables in the declaration + -- do not scope over the constructor signatures + -- data T a where { T1 :: forall b. b-> b } ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars' | otherwise = [] ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $ @@ -719,16 +723,13 @@ rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon', tcdTyVars = tyvars', tcdTyPats = typats', tcdKindSig = sig, tcdCons = condecls', tcdDerivs = derivs'}, - con_fvs `plusFV` - deriv_fvs `plusFV` - (if isFamInstDecl tydecl - then unitFV (unLoc tycon') -- type instance => use - else emptyFVs)) + con_fvs `plusFV` stuff_fvs) } where - h98_style = case condecls of - L _ (ConDecl { con_res = ResTyH98 }) : _ -> True - _ -> False + h98_style = case condecls of -- Note [Stupid theta] + L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False + _ -> True + data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) rn_derivs Nothing = return (Nothing, emptyFVs) @@ -737,22 +738,17 @@ rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, -- "type" and "type instance" declarations rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, - tcdTyPats = typatsMaybe, tcdSynRhs = ty}) - = bindTyVarsRn tyvars $ \ tyvars' -> do + tcdTyPats = typats, tcdSynRhs = ty}) + = bindTyVarsFV tyvars $ \ tyvars' -> do { -- Checks for distinct tyvars name' <- if isFamInstDecl tydecl then lookupLocatedOccRn name -- may be imported family else lookupLocatedTopBndrRn name - ; typats' <- rnTyPats syn_doc typatsMaybe - ; (ty', fvs) <- rnHsTypeFVs syn_doc ty + ; (typats',fvs1) <- rnTyPats syn_doc name' typats + ; (ty', fvs2) <- rnHsTypeFVs syn_doc ty ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars' , tcdTyPats = typats', tcdSynRhs = ty'}, - delFVs (map hsLTyVarName tyvars') $ - fvs `plusFV` - (if isFamInstDecl tydecl - then unitFV (unLoc name') -- type instance => use - else emptyFVs)) - } + fvs1 `plusFV` fvs2) } where syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) @@ -762,14 +758,18 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, = do { cname' <- lookupLocatedTopBndrRn cname -- Tyvars scope over superclass context and method signatures - ; (tyvars', context', fds', ats', ats_fvs, sigs') - <- bindTyVarsRn tyvars $ \ tyvars' -> do + ; ((tyvars', context', fds', ats', sigs'), stuff_fvs) + <- bindTyVarsFV tyvars $ \ tyvars' -> do -- Checks for distinct tyvars { context' <- rnContext cls_doc context ; fds' <- rnFds cls_doc fds - ; (ats', ats_fvs) <- rnATs ats + ; (ats', at_fvs) <- rnATs ats ; sigs' <- renameSigs Nothing okClsDclSig sigs - ; return (tyvars', context', fds', ats', ats_fvs, sigs') } + ; let fvs = at_fvs `plusFV` + extractHsCtxtTyNames context' `plusFV` + hsSigsFVs sigs' + -- The fundeps have no free variables + ; return ((tyvars', context', fds', ats', sigs'), fvs) } -- No need to check for duplicate associated type decls -- since that is done by RnNames.extendGlobalRdrEnvRn @@ -808,13 +808,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, ; return (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'}, - - delFVs (map hsLTyVarName tyvars') $ - extractHsCtxtTyNames context' `plusFV` - plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV` - hsSigsFVs sigs' `plusFV` - meth_fvs `plusFV` - ats_fvs) } + meth_fvs `plusFV` stuff_fvs) } where cls_doc = text "In the declaration for class" <+> ppr cname @@ -824,6 +818,15 @@ badGadtStupidTheta _ ptext (sLit "(You can put a context on each contructor, though.)")] \end{code} +Note [Stupid theta] +~~~~~~~~~~~~~~~~~~~ +Trac #3850 complains about a regression wrt 6.10 for + data Show a => T a +There is no reason not to allow the stupid theta if there are no data +constructors. It's still stupid, but does no harm, and I don't want +to cause programs to break unnecessarily (notably HList). So if there +are no data constructors we allow h98_style = True + %********************************************************* %* * @@ -832,12 +835,17 @@ badGadtStupidTheta _ %********************************************************* \begin{code} -rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name]) +rnTyPats :: SDoc -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars) -- Although, we are processing type patterns here, all type variables will -- already be in scope (they are the same as in the 'tcdTyVars' field of the -- type declaration to which these patterns belong) -rnTyPats _ Nothing = return Nothing -rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats +rnTyPats _ _ Nothing + = return (Nothing, emptyFVs) +rnTyPats doc tc (Just typats) + = do { typats' <- rnLHsTypes doc typats + ; let fvs = addOneFV (extractHsTyNames_s typats') (unLoc tc) + -- type instance => use, hence addOneFV + ; return (Just typats', fvs) } rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars) rnConDecls condecls @@ -957,7 +965,7 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats rn_at _ = panic "RnSource.rnATs: invalid TyClDecl" lookupIdxVars tyvars cont = - do { checkForDups tyvars; + do { checkForDups tyvars ; tyvars' <- mapM lookupIdxVar tyvars ; cont tyvars' } @@ -1086,3 +1094,94 @@ rnHsTyVar _doc tyvar = lookupOccRn tyvar \end{code} +%********************************************************* +%* * + findSplice +%* * +%********************************************************* + +This code marches down the declarations, looking for the first +Template Haskell splice. As it does so it + a) groups the declarations into a HsGroup + b) runs any top-level quasi-quotes + +\begin{code} +findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) +findSplice ds = addl emptyRdrGroup ds + +addl :: HsGroup RdrName -> [LHsDecl RdrName] + -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) +-- This stuff reverses the declarations (again) but it doesn't matter +addl gp [] = return (gp, Nothing) +addl gp (L l d : ds) = add gp l d ds + + +add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName] + -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) + +add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds + = do { -- We've found a top-level splice. If it is an *implicit* one + -- (i.e. a naked top level expression) + case flag of + Explicit -> return () + Implicit -> do { th_on <- doptM Opt_TemplateHaskell + ; unless th_on $ setSrcSpan loc $ + failWith badImplicitSplice } + + ; return (gp, Just (splice, ds)) } + where + badImplicitSplice = ptext (sLit "Parse error: naked expression at top level") + +#ifndef GHCI +add _ _ (QuasiQuoteD qq) _ + = pprPanic "Can't do QuasiQuote declarations without GHCi" (ppr qq) +#else +add gp _ (QuasiQuoteD qq) ds -- Expand quasiquotes + = do { ds' <- runQuasiQuoteDecl qq + ; addl gp (ds' ++ ds) } +#endif + +-- Class declarations: pull out the fixity signatures to the top +add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds + | isClassDecl d + = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in + addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds + | otherwise + = addl (gp { hs_tyclds = L l d : ts }) ds + +-- Signatures: fixity sigs go a different place than all others +add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds + = addl (gp {hs_fixds = L l f : ts}) ds +add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds + = addl (gp {hs_valds = add_sig (L l d) ts}) ds + +-- Value declarations: use add_bind +add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds + = addl (gp { hs_valds = add_bind (L l d) ts }) ds + +-- The rest are routine +add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds + = addl (gp { hs_instds = L l d : ts }) ds +add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds + = addl (gp { hs_derivds = L l d : ts }) ds +add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds + = addl (gp { hs_defds = L l d : ts }) ds +add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds + = addl (gp { hs_fords = L l d : ts }) ds +add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds + = addl (gp { hs_warnds = L l d : ts }) ds +add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds + = addl (gp { hs_annds = L l d : ts }) ds +add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds + = addl (gp { hs_ruleds = L l d : ts }) ds +add gp l (DocD d) ds + = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds + +add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a +add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs +add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind" + +add_sig :: LSig a -> HsValBinds a -> HsValBinds a +add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) +add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig" +\end{code} \ No newline at end of file