+-------------------------------------------------------
+slurpImpDecls source_fvs
+ = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_`
+ -- The current slurped-set records all local things
+ getSlurped `thenRn` \ local_binders ->
+
+ slurpSourceRefs source_fvs `thenRn` \ (decls1, needed1, wired_in) ->
+ let
+ inst_gates1 = foldr (plusFV . getWiredInGates) source_fvs wired_in
+ inst_gates2 = foldr (plusFV . getGates source_fvs) inst_gates1 decls1
+ in
+ -- Do this first slurpDecls before the getImportedInstDecls,
+ -- so that the home modules of all the inst_gates will be sure to be loaded
+ slurpDecls decls1 needed1 `thenRn` \ (decls2, needed2) ->
+ mapRn_ (load_home local_binders) wired_in `thenRn_`
+
+ -- Now we can get the instance decls
+ getImportedInstDecls inst_gates2 `thenRn` \ inst_decls ->
+ rnIfaceDecls decls2 needed2 inst_decls `thenRn` \ (decls3, needed3) ->
+ closeDecls decls3 needed3
+ where
+ load_home local_binders name
+ | name `elemNameSet` local_binders = returnRn ()
+ -- When compiling the prelude, a wired-in thing may
+ -- be defined in this module, in which case we don't
+ -- want to load its home module!
+ -- Using 'isLocallyDefined' doesn't work because some of
+ -- the free variables returned are simply 'listTyCon_Name',
+ -- with a system provenance. We could look them up every time
+ -- but that seems a waste.
+ | otherwise = loadHomeInterface doc name `thenRn_`
+ returnRn ()
+ where
+ doc = ptext SLIT("need home module for wired in thing") <+> ppr name
+
+-------------------------------------------------------
+slurpSourceRefs :: FreeVars -- Variables referenced in source
+ -> RnMG ([RenamedHsDecl],
+ FreeVars, -- Un-satisfied needs
+ [Name]) -- Those variables referenced in the source
+ -- that turned out to be wired in things
+
+slurpSourceRefs source_fvs
+ = go [] emptyFVs [] (nameSetToList source_fvs)
+ where
+ go decls fvs wired []
+ = returnRn (decls, fvs, wired)
+ go decls fvs wired (wanted_name:refs)
+ | isWiredInName wanted_name
+ = go decls fvs (wanted_name:wired) refs
+ | otherwise
+ = importDecl wanted_name `thenRn` \ maybe_decl ->
+ case maybe_decl of
+ -- No declaration... (already slurped, or local)
+ Nothing -> go decls fvs wired refs
+ Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) ->
+ go (new_decl : decls) (fvs1 `plusFV` fvs) wired
+ (extraGates new_decl ++ refs)
+
+-- Hack alert. If we suck in a class
+-- class Ord a => Baz a where ...
+-- then Eq is also a 'gate'. Why? Because Eq is a superclass of Ord,
+-- and hence may be needed during context reduction even though
+-- Eq is never mentioned explicitly. So we snaffle out the super-classes
+-- right now, so that slurpSourceRefs will heave them in
+--
+-- Similarly the RHS of type synonyms
+extraGates (TyClD (ClassDecl ctxt _ tvs _ _ _ _ _ _ _))
+ = nameSetToList (delListFromNameSet (extractHsCtxtTyNames ctxt) (map getTyVarName tvs))
+extraGates (TyClD (TySynonym _ tvs ty _))
+ = nameSetToList (delListFromNameSet (extractHsTyNames ty) (map getTyVarName tvs))
+extraGates other = []
+
+-------------------------------------------------------
+-- closeDecls keeps going until the free-var set is empty
+closeDecls decls needed
+ | not (isEmptyFVs needed)
+ = slurpDecls decls needed `thenRn` \ (decls1, needed1) ->
+ closeDecls decls1 needed1
+
+ | otherwise
+ = getImportedRules `thenRn` \ rule_decls ->
+ case rule_decls of
+ [] -> returnRn decls -- No new rules, so we are done
+ other -> rnIfaceDecls decls emptyFVs rule_decls `thenRn` \ (decls1, needed1) ->
+ closeDecls decls1 needed1
+
+
+-------------------------------------------------------
+rnIfaceDecls :: [RenamedHsDecl] -> FreeVars
+ -> [(Module, RdrNameHsDecl)]
+ -> RnM d ([RenamedHsDecl], FreeVars)
+rnIfaceDecls decls fvs [] = returnRn (decls, fvs)
+rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) ->
+ rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds
+
+rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl)
+
+
+-------------------------------------------------------
+-- Augment decls with any decls needed by needed.
+-- Return also free vars of the new decls (only)
+slurpDecls decls needed
+ = go decls emptyFVs (nameSetToList needed)
+ where
+ go decls fvs [] = returnRn (decls, fvs)
+ go decls fvs (ref:refs) = slurpDecl decls fvs ref `thenRn` \ (decls1, fvs1) ->
+ go decls1 fvs1 refs
+
+-------------------------------------------------------
+slurpDecl decls fvs wanted_name
+ = importDecl wanted_name `thenRn` \ maybe_decl ->
+ case maybe_decl of
+ -- No declaration... (wired in thing)
+ Nothing -> returnRn (decls, fvs)
+
+ -- Found a declaration... rename it
+ Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) ->
+ returnRn (new_decl:decls, fvs1 `plusFV` fvs)
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Extracting the 'gates'}
+%* *
+%*********************************************************
+
+When we import a declaration like
+
+ data T = T1 Wibble | T2 Wobble
projects / ghc-hetmet.git / commitdiff