\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
\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_names = collectHsBindLocatedBinders mbinds
+ meth_names = collectMethodBinders mbinds
(inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
in
checkDupRdrNames meth_names `thenM_`
--
-- But the (unqualified) method names are in scope
let
- binders = collectHsBindBinders mbinds'
+ binders = collectHsBindsBinders mbinds'
bndr_set = mkNameSet binders
in
bindLocalNames binders
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)
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
+
%*********************************************************
%* *
\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