makeMiniFixityEnv)
import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn,
lookupTopBndrRn, lookupLocatedTopBndrRn,
- lookupOccRn, newLocalBndrsRn,
+ lookupOccRn, newLocalBndrsRn, bindLocalNamesFV,
bindLocatedLocalsFV, bindPatSigTyVarsFV,
bindTyVarsRn, extendTyVarEnvFVRn,
bindLocalNames, checkDupRdrNames, mapFvRn
import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcRnMonad
+import ForeignCall ( CCallTarget(..) )
+import Module
import HscTypes ( Warnings(..), plusWarns )
import Class ( FunDep )
import Name ( Name, nameOccName )
import Outputable
import Bag
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 ListSetOps (findDupsEq)
import Control.Monad
import Data.Maybe
%*********************************************************
\begin{code}
-rnDocDecl :: DocDecl RdrName -> RnM (DocDecl Name)
+rnDocDecl :: DocDecl -> RnM DocDecl
rnDocDecl (DocCommentNext doc) = do
rn_doc <- rnHsDoc doc
return (DocCommentNext rn_doc)
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
(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) ->
\begin{code}
rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
rnSrcDerivDecl (DerivDecl ty)
- = do ty' <- rnLHsType (text "a deriving decl") ty
- let fvs = extractHsTyNames ty'
- return (DerivDecl ty', fvs)
+ = do { standalone_deriv_ok <- doptM Opt_StandaloneDeriving
+ ; unless standalone_deriv_ok (addErr standaloneDerivErr)
+ ; ty' <- rnLHsType (text "a deriving decl") ty
+ ; let fvs = extractHsTyNames ty'
+ ; return (DerivDecl ty', fvs) }
+
+standaloneDerivErr :: SDoc
+standaloneDerivErr
+ = hang (ptext (sLit "Illegal standalone deriving declaration"))
+ 2 (ptext (sLit "Use -XStandaloneDeriving to enable this extension"))
\end{code}
%*********************************************************
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
tcdLName = tycon, tcdTyVars = tyvars,
tcdTyPats = typatsMaybe, tcdCons = condecls,
tcdKindSig = sig, tcdDerivs = derivs}
- | is_vanilla -- Normal Haskell data type decl
- = ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the
- -- data type is syntactically illegal
- ASSERT( distinctTyVarBndrs tyvars ) -- Tyvars should be distinct
- do { bindTyVarsRn data_doc tyvars $ \ tyvars' -> do
- { tycon' <- if isFamInstDecl tydecl
- then lookupLocatedOccRn tycon -- may be imported family
- else lookupLocatedTopBndrRn tycon
- ; context' <- rnContext data_doc context
- ; typats' <- rnTyPats data_doc typatsMaybe
- ; condecls' <- rnConDecls (unLoc tycon') condecls
- -- No need to check for duplicate constructor decls
- -- since that is done by RnNames.extendGlobalRdrEnvRn
- ; (derivs', deriv_fvs) <- rn_derivs derivs
- ; return (TyData {tcdND = new_or_data, tcdCtxt = context',
- tcdLName = tycon', tcdTyVars = tyvars',
- tcdTyPats = typats', tcdKindSig = Nothing,
- tcdCons = condecls', tcdDerivs = derivs'},
- delFVs (map hsLTyVarName tyvars') $
- extractHsCtxtTyNames context' `plusFV`
- plusFVs (map conDeclFVs condecls') `plusFV`
- deriv_fvs `plusFV`
- (if isFamInstDecl tydecl
- then unitFV (unLoc tycon') -- type instance => use
- else emptyFVs))
- } }
-
- | otherwise -- GADT
= do { tycon' <- if isFamInstDecl tydecl
then lookupLocatedOccRn tycon -- may be imported family
else lookupLocatedTopBndrRn tycon
- ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
- ; (tyvars', typats')
- <- bindTyVarsRn data_doc tyvars $ \ tyvars' -> do
+ ; checkTc (h98_style || null (unLoc context))
+ (badGadtStupidTheta tycon)
+ ; (tyvars', context', typats', derivs', deriv_fvs)
+ <- bindTyVarsRn tyvars $ \ tyvars' -> do
+ -- Checks for distinct tyvars
{ typats' <- rnTyPats data_doc typatsMaybe
- ; return (tyvars', typats') }
+ ; 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 }
- ; condecls' <- rnConDecls (unLoc tycon') condecls
+ -- For the constructor declarations, bring into scope the tyvars
+ -- bound by the header, but *only* in the H98 case
+ ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars'
+ | otherwise = []
+ ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $
+ rnConDecls condecls
-- No need to check for duplicate constructor decls
-- since that is done by RnNames.extendGlobalRdrEnvRn
- ; (derivs', deriv_fvs) <- rn_derivs derivs
- ; return (TyData {tcdND = new_or_data, tcdCtxt = noLoc [],
+ ; return (TyData {tcdND = new_or_data, tcdCtxt = context',
tcdLName = tycon', tcdTyVars = tyvars',
tcdTyPats = typats', tcdKindSig = sig,
tcdCons = condecls', tcdDerivs = derivs'},
- plusFVs (map conDeclFVs condecls') `plusFV`
- deriv_fvs `plusFV`
+ con_fvs `plusFV`
+ deriv_fvs `plusFV`
(if isFamInstDecl tydecl
then unitFV (unLoc tycon') -- type instance => use
else emptyFVs))
}
where
- is_vanilla = case condecls of -- Yuk
- [] -> True
+ h98_style = case condecls of
L _ (ConDecl { con_res = ResTyH98 }) : _ -> True
- _ -> False
-
+ _ -> False
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})
- = ASSERT( distinctTyVarBndrs tyvars ) -- Tyvars should be distinct
- do { bindTyVarsRn syn_doc tyvars $ \ tyvars' -> do
- { 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
; (ats', ats_fvs) <- rnATs ats
-- 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
-
-distinctTyVarBndrs :: [LHsTyVarBndr RdrName] -> Bool
--- The tyvar binders should have distinct names
-distinctTyVarBndrs tvs
- = null (findDupsEq eq tvs)
- where
- eq (L _ v1) (L _ v2) = hsTyVarName v1 == hsTyVarName v2
badGadtStupidTheta :: Located RdrName -> SDoc
badGadtStupidTheta _
%*********************************************************
\begin{code}
+rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
-- 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 :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
rnTyPats _ Nothing = return Nothing
rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats
-rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
-rnConDecls _tycon condecls
- = mapM (wrapLocM rnConDecl) condecls
+rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
+rnConDecls condecls
+ = do { condecls' <- mapM (wrapLocM rnConDecl) condecls
+ ; return (condecls', plusFVs (map conDeclFVs condecls')) }
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
- , con_cxt = cxt, con_details = details
- , con_res = res_ty, con_doc = mb_doc
- , con_old_rec = old_rec, con_explicit = expl })
+ , con_cxt = cxt, con_details = details
+ , con_res = res_ty, con_doc = mb_doc
+ , con_old_rec = old_rec, con_explicit = expl })
= do { addLocM checkConName name
; when old_rec (addWarn (deprecRecSyntax decl))
-
; new_name <- lookupLocatedTopBndrRn name
- ; name_env <- getLocalRdrEnv
-
- -- For H98 syntax, the tvs are the existential ones
- -- For GADT syntax, the tvs are all the quantified tyvars
- -- Hence the 'filter' in the ResTyH98 case only
- ; let not_in_scope = not . (`elemLocalRdrEnv` name_env) . unLoc
- arg_tys = hsConDeclArgTys details
- implicit_tvs = case res_ty of
- ResTyH98 -> filter not_in_scope $
- get_rdr_tvs arg_tys
- ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
+
+ -- For H98 syntax, the tvs are the existential ones
+ -- For GADT syntax, the tvs are all the quantified tyvars
+ -- Hence the 'filter' in the ResTyH98 case only
+ ; rdr_env <- getLocalRdrEnv
+ ; let in_scope = (`elemLocalRdrEnv` rdr_env) . unLoc
+ arg_tys = hsConDeclArgTys details
+ implicit_tvs = case res_ty of
+ ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys)
+ ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
new_tvs = case expl of
Explicit -> tvs
Implicit -> userHsTyVarBndrs implicit_tvs
; 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'
projects / ghc-hetmet.git / blobdiff