\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 )
import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcRnMonad
+import ForeignCall ( CCallTarget(..) )
+import Module
import HscTypes ( Warnings(..), plusWarns )
import Class ( FunDep )
import Name ( Name, nameOccName )
import FastString
import Util ( filterOut )
import SrcLoc
-import DynFlags ( DynFlag(..) )
+import DynFlags ( DynFlag(..), DynFlags, thisPackage )
+import HscTypes ( HscEnv, hsc_dflags )
import BasicTypes ( Boxity(..) )
import ListSetOps ( findDupsEq )
+
import Control.Monad
import Data.Maybe
\end{code}
-- 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
rnSrcWarnDecls bound_names decls
= do { -- check for duplicates
- ; mapM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupWarnDecl lrdr')) warn_rdr_dups
- ; mapM (addLocM rn_deprec) decls `thenM` \ pairs_s ->
- return (WarnSome ((concat pairs_s))) }
+ ; mapM_ (\ (L loc rdr:lrdr':_) -> addErrAt loc (dupWarnDecl lrdr' rdr))
+ warn_rdr_dups
+ ; pairs_s <- mapM (addLocM rn_deprec) decls
+ ; return (WarnSome ((concat pairs_s))) }
where
rn_deprec (Warning rdr_name txt)
-- ensures that the names are defined locally
\begin{code}
rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
rnHsForeignDecl (ForeignImport name ty spec)
- = lookupLocatedTopBndrRn name `thenM` \ name' ->
+ = getTopEnv `thenM` \ (topEnv :: HscEnv) ->
+ lookupLocatedTopBndrRn name `thenM` \ name' ->
rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
- return (ForeignImport name' ty' spec, fvs)
+
+ -- Mark any PackageTarget style imports as coming from the current package
+ let packageId = thisPackage $ hsc_dflags topEnv
+ spec' = patchForeignImport packageId spec
+
+ in return (ForeignImport name' ty' spec', fvs)
rnHsForeignDecl (ForeignExport name ty spec)
= lookupLocatedOccRn name `thenM` \ name' ->
fo_decl_msg :: Located RdrName -> SDoc
fo_decl_msg name = ptext (sLit "In the foreign declaration for") <+> ppr name
+
+
+-- | For Windows DLLs we need to know what packages imported symbols are from
+-- to generate correct calls. Imported symbols are tagged with the current
+-- package, so if they get inlined across a package boundry we'll still
+-- know where they're from.
+--
+patchForeignImport :: PackageId -> ForeignImport -> ForeignImport
+patchForeignImport packageId (CImport cconv safety fs spec)
+ = CImport cconv safety fs (patchCImportSpec packageId spec)
+
+patchCImportSpec :: PackageId -> CImportSpec -> CImportSpec
+patchCImportSpec packageId spec
+ = case spec of
+ CFunction callTarget -> CFunction $ patchCCallTarget packageId callTarget
+ _ -> spec
+
+patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget
+patchCCallTarget packageId callTarget
+ = case callTarget of
+ StaticTarget label Nothing
+ -> StaticTarget label (Just packageId)
+
+ _ -> callTarget
+
+
\end{code}
-- The typechecker (not the renamer) checks that all
-- the bindings are for the right class
let
- meth_doc = text "In the bindings in an instance declaration"
- meth_names = collectHsBindLocatedBinders mbinds
+ meth_names = collectMethodBinders mbinds
(inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
in
- checkDupRdrNames meth_doc meth_names `thenM_`
+ checkDupRdrNames meth_names `thenM_`
-- Check that the same method is not given twice in the
-- same instance decl instance C T where
-- f x = ...
-- The typechecker (not the renamer) checks that all
-- the declarations are for the right class
let
- at_doc = text "In the associated types of an instance declaration"
at_names = map (head . tyClDeclNames . unLoc) ats
in
- checkDupRdrNames at_doc at_names `thenM_`
+ checkDupRdrNames at_names `thenM_`
-- See notes with checkDupRdrNames for methods, above
rnATInsts ats `thenM` \ (ats', at_fvs) ->
--
-- But the (unqualified) method names are in scope
let
- binders = collectHsBindBinders mbinds'
+ binders = collectHsBindsBinders mbinds'
bndr_set = mkNameSet binders
in
bindLocalNames binders
rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
= bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $
- bindLocatedLocalsFV doc (map get_var vars) $ \ ids ->
+ bindLocatedLocalsFV (map get_var vars) $ \ ids ->
do { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids)
-- NB: The binders in a rule are always Ids
-- We don't (yet) support type variables
; checkTc (h98_style || null (unLoc context))
(badGadtStupidTheta tycon)
; (tyvars', context', typats', derivs', deriv_fvs)
- <- bindTyVarsRn data_doc tyvars $ \ tyvars' -> do
+ <- bindTyVarsRn tyvars $ \ tyvars' -> do
-- Checks for distinct tyvars
{ typats' <- rnTyPats data_doc typatsMaybe
; context' <- rnContext data_doc context
else emptyFVs))
}
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)
-- "type" and "type instance" declarations
rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
tcdTyPats = typatsMaybe, tcdSynRhs = ty})
- = do { bindTyVarsRn syn_doc 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
- ; 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))
- } }
+ = bindTyVarsRn 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
+ ; 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))
+ }
where
syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
-- Tyvars scope over superclass context and method signatures
; (tyvars', context', fds', ats', ats_fvs, sigs')
- <- bindTyVarsRn cls_doc tyvars $ \ tyvars' -> do
+ <- bindTyVarsRn tyvars $ \ tyvars' -> do
-- Checks for distinct tyvars
{ context' <- rnContext cls_doc context
; fds' <- rnFds cls_doc fds
-- Check the signatures
-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
- ; checkDupRdrNames sig_doc sig_rdr_names_w_locs
+ ; checkDupRdrNames sig_rdr_names_w_locs
-- Typechecker is responsible for checking that we only
-- give default-method bindings for things in this class.
-- The renamer *could* check this for class decls, but can't
ats_fvs) }
where
cls_doc = text "In the declaration for class" <+> ppr cname
- sig_doc = text "In the signatures for class" <+> ppr cname
badGadtStupidTheta :: Located RdrName -> SDoc
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
+
%*********************************************************
%* *
; mb_doc' <- rnMbLHsDoc mb_doc
- ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do
+ ; bindTyVarsRn new_tvs $ \new_tyvars -> do
{ new_context <- rnContext doc cxt
; new_details <- rnConDeclDetails doc details
; (new_details', new_res_ty) <- rnConResult doc new_details res_ty
-- are usage occurences for associated types.
--
rnFamily :: TyClDecl RdrName
- -> (SDoc -> [LHsTyVarBndr RdrName] ->
+ -> ([LHsTyVarBndr RdrName] ->
([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
RnM (TyClDecl Name, FreeVars))
-> RnM (TyClDecl Name, FreeVars)
rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
tcdLName = tycon, tcdTyVars = tyvars})
bindIdxVars =
- do { bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
+ do { bindIdxVars tyvars $ \tyvars' -> do {
; tycon' <- lookupLocatedTopBndrRn tycon
; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
} }
rnFamily d _ = pprPanic "rnFamily" (ppr d)
-family_doc :: Located RdrName -> SDoc
-family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
-
-- Rename associated type declarations (in classes)
--
-- * This can be family declarations and (default) type instances
rnTyClDecl tydecl
rn_at _ = panic "RnSource.rnATs: invalid TyClDecl"
- lookupIdxVars _ tyvars cont =
+ lookupIdxVars tyvars cont =
do { checkForDups tyvars;
; tyvars' <- mapM lookupIdxVar tyvars
; cont tyvars'
\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 _ (SpliceD e) ds = return (gp, Just (e, ds))
+
+#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
projects / ghc-hetmet.git / blobdiff