`setArityInfo` exactArity arity
`setStrictnessInfo` strict_info
- rules = addRule id emptyCoreRules (primOpRule prim_op)
+ rules = addRule emptyCoreRules id (primOpRule prim_op)
-- For each ccall we manufacture a separate CCallOpId, giving it
NameSet,
emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets,
minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet,
- delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet
+ delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet,
+
+ -- Free variables
+ FreeVars, isEmptyFVs, emptyFVs, plusFVs, plusFV,
+ mkFVs, addOneFV, unitFV, delFV, delFVs
) where
#include "HsVersions.h"
\end{code}
+%************************************************************************
+%* *
+\subsection{Free variables}
+%* *
+%************************************************************************
+
+These synonyms are useful when we are thinking of free variables
+
+\begin{code}
+type FreeVars = NameSet
+
+plusFV :: FreeVars -> FreeVars -> FreeVars
+addOneFV :: FreeVars -> Name -> FreeVars
+unitFV :: Name -> FreeVars
+emptyFVs :: FreeVars
+plusFVs :: [FreeVars] -> FreeVars
+mkFVs :: [Name] -> FreeVars
+delFV :: Name -> FreeVars -> FreeVars
+delFVs :: [Name] -> FreeVars -> FreeVars
+
+isEmptyFVs = isEmptyNameSet
+emptyFVs = emptyNameSet
+plusFVs = unionManyNameSets
+plusFV = unionNameSets
+mkFVs = mkNameSet
+addOneFV = addOneToNameSet
+unitFV = unitNameSet
+delFV n s = delFromNameSet s n
+delFVs ns s = delListFromNameSet s ns
+\end{code}
+
-- Environment
RdrNameEnv,
emptyRdrEnv, lookupRdrEnv, addListToRdrEnv, rdrEnvElts,
- extendRdrEnv, rdrEnvToList,
+ extendRdrEnv, rdrEnvToList, elemRdrEnv,
-- Printing; instance Outputable RdrName
pprUnqualRdrName
extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a
rdrEnvToList :: RdrNameEnv a -> [(RdrName, a)]
rdrEnvElts :: RdrNameEnv a -> [a]
+elemRdrEnv :: RdrName -> RdrNameEnv a -> Bool
emptyRdrEnv = emptyFM
lookupRdrEnv = lookupFM
rdrEnvElts = eltsFM
extendRdrEnv = addToFM
rdrEnvToList = fmToList
+elemRdrEnv = elemFM
\end{code}
module VarSet (
VarSet, IdSet, TyVarSet, UVarSet,
emptyVarSet, unitVarSet, mkVarSet,
- extendVarSet,
+ extendVarSet, extendVarSet_C,
elemVarSet, varSetElems, subVarSet,
unionVarSet, unionVarSets,
intersectVarSet, intersectsVarSet,
#include "HsVersions.h"
-import CmdLineOpts ( opt_PprStyle_Debug )
-import Var ( Var, Id, TyVar, UVar, setVarUnique )
-import Unique ( Unique, Uniquable(..) )
+import Var ( Var, Id, TyVar, UVar )
+import Unique ( Unique )
import UniqSet
-import UniqFM ( delFromUFM_Directly )
-import Outputable
+import UniqFM ( delFromUFM_Directly, addToUFM_C )
\end{code}
%************************************************************************
sizeVarSet :: VarSet -> Int
filterVarSet :: (Var -> Bool) -> VarSet -> VarSet
subVarSet :: VarSet -> VarSet -> Bool
+extendVarSet_C :: (Var->Var->Var) -> VarSet -> Var -> VarSet
delVarSetByKey :: VarSet -> Unique -> VarSet
mapVarSet = mapUniqSet
sizeVarSet = sizeUniqSet
filterVarSet = filterUniqSet
+extendVarSet_C combine s x = addToUFM_C combine s x x
a `subVarSet` b = isEmptyVarSet (a `minusVarSet` b)
delVarSetByKey = delFromUFM_Directly -- Can't be bothered to add this to UniqSet
\end{code}
module HsCore (
UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
UfBinding(..), UfConAlt(..),
- HsIdInfo(..), pprHsIdInfo,
+ HsIdInfo(..), pprHsIdInfo,
eq_ufExpr, eq_ufBinders, pprUfExpr,
- toUfExpr, toUfBndr
+ toUfExpr, toUfBndr, ufBinderName
) where
#include "HsVersions.h"
import TyCon ( isTupleTyCon, tupleTyConBoxity )
import Type ( Kind )
import CostCentre
-import SrcLoc ( SrcLoc )
import Outputable
\end{code}
data UfBinder name
= UfValBinder name (HsType name)
| UfTyBinder name Kind
+
+ufBinderName :: UfBinder name -> name
+ufBinderName (UfValBinder n _) = n
+ufBinderName (UfTyBinder n _) = n
\end{code}
DeprecDecl(..), DeprecTxt,
hsDeclName, instDeclName, tyClDeclName, tyClDeclNames,
isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule,
- mkClassDeclSysNames,
+ mkClassDeclSysNames, isIfaceRuleDecl,
getClassDeclSysNames
) where
getClassDeclSysNames (a:b:c:ds) = (a,b,c,ds)
\end{code}
-
\begin{code}
isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
name -- Name of the constructor's 'worker Id'
-- Filled in as the ConDecl is built
- [HsTyVarBndr name] -- Existentially quantified type variables
+ [HsTyVarBndr name] -- Existentially quantified type variables
(HsContext name) -- ...and context
-- If both are empty then there are no existentials
name -- Head of LHS
CoreRule
+isIfaceRuleDecl (HsRule _ _ _ _ _ _) = False
+isIfaceRuleDecl other = True
data RuleBndr name
= RuleBndr name
import Module ( Module, ModuleName, ModuleEnv,
lookupModuleEnv, lookupModuleEnvByName
)
+import Rules ( RuleBase )
import VarSet ( TyVarSet )
import VarEnv ( emptyVarEnv )
import Id ( Id )
-- The next three fields are created by the typechecker
md_types :: TypeEnv,
md_insts :: [DFunId], -- Dfun-ids for the instances in this module
- md_rules :: RuleBase -- Domain may include Ids from other modules
+ md_rules :: [(Id,CoreRule)] -- Domain may include Ids from other modules
}
\end{code}
emptyModDetails
= ModDetails { md_types = emptyTypeEnv,
md_insts = [],
- md_rules = emptyRuleBase
+ md_rules = []
}
emptyModIface :: Module -> ModIface
pcs_insts :: PackageInstEnv, -- The total InstEnv accumulated from all
-- the non-home-package modules
- pcs_rules :: PackageRuleEnv, -- Ditto RuleEnv
+ pcs_rules :: PackageRuleBase, -- Ditto RuleEnv
pcs_PRS :: PersistentRenamerState
}
RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl
)
import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl,
- extractHsTyNames, extractHsCtxtTyNames
+ extractHsTyNames, extractHsCtxtTyNames,
+ instDeclFVs, tyClDeclFVs, ruleDeclFVs
)
import CmdLineOpts ( DynFlags, DynFlag(..) )
import RnMonad
import RnNames ( getGlobalNames )
import RnSource ( rnSourceDecls, rnDecl, rnTyClDecl, rnRuleDecl, rnInstDecl )
-import RnIfaces ( getImportedInstDecls, importDecl, mkImportInfo,
+import RnIfaces ( slurpImpDecls, mkImportInfo,
getInterfaceExports,
- getImportedRules, getSlurped,
- ImportDeclResult(..),
RecompileRequired, recompileRequired
)
import RnHiFiles ( findAndReadIface, removeContext, loadExports, loadFixDecls, loadDeprecs )
renameModule dflags finder hit hst old_pcs this_module rdr_module
= -- Initialise the renamer monad
do {
- (new_pcs, errors_found, (maybe_rn_stuff, dump_action))
+ (new_pcs, errors_found, maybe_rn_stuff)
<- initRn dflags finder hit hst old_pcs this_module (rename this_module rdr_module) ;
- -- Dump any debugging output
- dump_action ;
-
-- Return results. No harm in updating the PCS
if errors_found then
return (new_pcs, Nothing)
\end{code}
\begin{code}
-rename :: Module -> RdrNameHsModule -> RnMG (Maybe (ModIface, [RenamedHsDecl]), IO ())
+rename :: Module -> RdrNameHsModule -> RnMG (Maybe (ModIface, [RenamedHsDecl]))
rename this_module this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc)
= -- FIND THE GLOBAL NAME ENVIRONMENT
getGlobalNames this_mod `thenRn` \ maybe_stuff ->
-- CHECK FOR EARLY EXIT
case maybe_stuff of {
Nothing -> -- Everything is up to date; no need to recompile further
- rnDump [] [] `thenRn` \ dump_action ->
- returnRn (Nothing, dump_action) ;
+ rnDump [] [] `thenRn_`
+ returnRn Nothing ;
Just (gbl_env, local_gbl_env, export_avails, global_avail_env) ->
slurpImpDecls slurp_fvs `thenRn` \ rn_imp_decls ->
-- EXIT IF ERRORS FOUND
- rnDump rn_imp_decls rn_local_decls `thenRn` \ dump_action ->
+ rnDump rn_imp_decls rn_local_decls `thenRn_`
checkErrsRn `thenRn` \ no_errs_so_far ->
if not no_errs_so_far then
-- Found errors already, so exit now
- returnRn (Nothing, dump_action)
+ returnRn Nothing
else
-- GENERATE THE VERSION/USAGE INFO
export_avails source_fvs
rn_imp_decls `thenRn_`
- returnRn (Just (mod_iface, final_decls), dump_action) }
+ returnRn (Just (mod_iface, final_decls))
+ }
\end{code}
@implicitFVs@ forces the renamer to slurp in some things which aren't
%*********************************************************
%* *
-\subsection{Slurping declarations}
-%* *
-%*********************************************************
-
-\begin{code}
--------------------------------------------------------
-slurpImpDecls source_fvs
- = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_`
-
- -- The current slurped-set records all local things
- getSlurped `thenRn` \ source_binders ->
- slurpSourceRefs source_binders source_fvs `thenRn` \ (decls, needed) ->
-
- -- Then get everything else
- closeDecls decls needed `thenRn` \ decls1 ->
-
- -- Finally, get any deferred data type decls
- slurpDeferredDecls decls1 `thenRn` \ final_decls ->
-
- returnRn final_decls
-
--------------------------------------------------------
-slurpSourceRefs :: NameSet -- Variables defined in source
- -> FreeVars -- Variables referenced in source
- -> RnMG ([RenamedHsDecl],
- FreeVars) -- Un-satisfied needs
--- The declaration (and hence home module) of each gate has
--- already been loaded
-
-slurpSourceRefs source_binders source_fvs
- = go_outer [] -- Accumulating decls
- emptyFVs -- Unsatisfied needs
- emptyFVs -- Accumulating gates
- (nameSetToList source_fvs) -- Things whose defn hasn't been loaded yet
- where
- -- The outer loop repeatedly slurps the decls for the current gates
- -- and the instance decls
-
- -- The outer loop is needed because consider
- -- instance Foo a => Baz (Maybe a) where ...
- -- It may be that @Baz@ and @Maybe@ are used in the source module,
- -- but not @Foo@; so we need to chase @Foo@ too.
- --
- -- We also need to follow superclass refs. In particular, 'chasing @Foo@' must
- -- include actually getting in Foo's class decl
- -- class Wib a => Foo a where ..
- -- so that its superclasses are discovered. The point is that Wib is a gate too.
- -- We do this for tycons too, so that we look through type synonyms.
-
- go_outer decls fvs all_gates []
- = returnRn (decls, fvs)
-
- go_outer decls fvs all_gates refs -- refs are not necessarily slurped yet
- = traceRn (text "go_outer" <+> ppr refs) `thenRn_`
- foldlRn go_inner (decls, fvs, emptyFVs) refs `thenRn` \ (decls1, fvs1, gates1) ->
- getImportedInstDecls (all_gates `plusFV` gates1) `thenRn` \ inst_decls ->
- rnInstDecls decls1 fvs1 gates1 inst_decls `thenRn` \ (decls2, fvs2, gates2) ->
- go_outer decls2 fvs2 (all_gates `plusFV` gates2)
- (nameSetToList (gates2 `minusNameSet` all_gates))
- -- Knock out the all_gates because even if we don't slurp any new
- -- decls we can get some apparently-new gates from wired-in names
-
- go_inner (decls, fvs, gates) wanted_name
- = importDecl wanted_name `thenRn` \ import_result ->
- case import_result of
- AlreadySlurped -> returnRn (decls, fvs, gates)
- WiredIn -> returnRn (decls, fvs, gates `plusFV` getWiredInGates wanted_name)
- Deferred -> returnRn (decls, fvs, gates `addOneFV` wanted_name) -- It's a type constructor
-
- HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) ->
- returnRn (TyClD new_decl : decls,
- fvs1 `plusFV` fvs,
- gates `plusFV` getGates source_fvs new_decl)
-
-rnInstDecls decls fvs gates []
- = returnRn (decls, fvs, gates)
-rnInstDecls decls fvs gates (d:ds)
- = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) ->
- rnInstDecls (new_decl:decls)
- (fvs1 `plusFV` fvs)
- (gates `plusFV` getInstDeclGates new_decl)
- ds
-\end{code}
-
-
-\begin{code}
--------------------------------------------------------
--- 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
-
-
--------------------------------------------------------
--- 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` \ import_result ->
- case import_result of
- -- Found a declaration... rename it
- HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) ->
- returnRn (TyClD new_decl:decls, fvs1 `plusFV` fvs)
-
- -- No declaration... (wired in thing, or deferred, or already slurped)
- other -> returnRn (decls, fvs)
-
-
--------------------------------------------------------
-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)
-rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl)
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Deferred declarations}
-%* *
-%*********************************************************
-
-The idea of deferred declarations is this. Suppose we have a function
- f :: T -> Int
- data T = T1 A | T2 B
- data A = A1 X | A2 Y
- data B = B1 P | B2 Q
-Then we don't want to load T and all its constructors, and all
-the types those constructors refer to, and all the types *those*
-constructors refer to, and so on. That might mean loading many more
-interface files than is really necessary. So we 'defer' loading T.
-
-But f might be strict, and the calling convention for evaluating
-values of type T depends on how many constructors T has, so
-we do need to load T, but not the full details of the type T.
-So we load the full decl for T, but only skeleton decls for A and B:
- f :: T -> Int
- data T = {- 2 constructors -}
-
-Whether all this is worth it is moot.
-
-\begin{code}
-slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl]
-slurpDeferredDecls decls = returnRn decls
-
-{- OMIT FOR NOW
-slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl]
-slurpDeferredDecls decls
- = getDeferredDecls `thenRn` \ def_decls ->
- rnIfaceDecls decls emptyFVs (map stripDecl def_decls) `thenRn` \ (decls1, fvs) ->
- ASSERT( isEmptyFVs fvs )
- returnRn decls1
-
-stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ loc name1 name2))
- = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing loc
- name1 name2))
- -- Nuke the context and constructors
- -- But retain the *number* of constructors!
- -- Also the tvs will have kinds on them.
--}
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Extracting the `gates'}
-%* *
-%*********************************************************
-
-When we import a declaration like
-\begin{verbatim}
- data T = T1 Wibble | T2 Wobble
-\end{verbatim}
-we don't want to treat @Wibble@ and @Wobble@ as gates
-{\em unless} @T1@, @T2@ respectively are mentioned by the user program.
-If only @T@ is mentioned
-we want only @T@ to be a gate;
-that way we don't suck in useless instance
-decls for (say) @Eq Wibble@, when they can't possibly be useful.
-
-@getGates@ takes a newly imported (and renamed) decl, and the free
-vars of the source program, and extracts from the decl the gate names.
-
-\begin{code}
-getGates source_fvs (IfaceSig _ ty _ _)
- = extractHsTyNames ty
-
-getGates source_fvs (ClassDecl ctxt cls tvs _ sigs _ _ _ )
- = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
- (hsTyVarNames tvs)
- `addOneToNameSet` cls)
- `plusFV` maybe_double
- where
- get (ClassOpSig n _ ty _)
- | n `elemNameSet` source_fvs = extractHsTyNames ty
- | otherwise = emptyFVs
-
- -- If we load any numeric class that doesn't have
- -- Int as an instance, add Double to the gates.
- -- This takes account of the fact that Double might be needed for
- -- defaulting, but we don't want to load Double (and all its baggage)
- -- if the more exotic classes aren't used at all.
- maybe_double | nameUnique cls `elem` fractionalClassKeys
- = unitFV (getName doubleTyCon)
- | otherwise
- = emptyFVs
-
-getGates source_fvs (TySynonym tycon tvs ty _)
- = delListFromNameSet (extractHsTyNames ty)
- (hsTyVarNames tvs)
- -- A type synonym type constructor isn't a "gate" for instance decls
-
-getGates source_fvs (TyData _ ctxt tycon tvs cons _ _ _ _ _)
- = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
- (hsTyVarNames tvs)
- `addOneToNameSet` tycon
- where
- get (ConDecl n _ tvs ctxt details _)
- | n `elemNameSet` source_fvs
- -- If the constructor is method, get fvs from all its fields
- = delListFromNameSet (get_details details `plusFV`
- extractHsCtxtTyNames ctxt)
- (hsTyVarNames tvs)
- get (ConDecl n _ tvs ctxt (RecCon fields) _)
- -- Even if the constructor isn't mentioned, the fields
- -- might be, as selectors. They can't mention existentially
- -- bound tyvars (typechecker checks for that) so no need for
- -- the deleteListFromNameSet part
- = foldr (plusFV . get_field) emptyFVs fields
-
- get other_con = emptyFVs
-
- get_details (VanillaCon tys) = plusFVs (map get_bang tys)
- get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2
- get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields]
-
- get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t
- | otherwise = emptyFVs
-
- get_bang bty = extractHsTyNames (getBangType bty)
-\end{code}
-
-@getWiredInGates@ is just like @getGates@, but it sees a wired-in @Name@
-rather than a declaration.
-
-\begin{code}
-getWiredInGates :: Name -> FreeVars
-getWiredInGates name -- No classes are wired in
- = case lookupNameEnv wiredInThingEnv name of
- Just (AnId the_id) -> getWiredInGates_s (namesOfType (idType the_id))
-
- Just (ATyCon tc)
- | isSynTyCon tc
- -> getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars))
- where
- (tyvars,ty) = getSynTyConDefn tc
-
- other -> unitFV name
-
-getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names)
-\end{code}
-
-\begin{code}
-getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty
-getInstDeclGates other = emptyFVs
-\end{code}
-
-
-%*********************************************************
-%* *
\subsection{Fixities}
%* *
%*********************************************************
\end{code}
+
+%*********************************************************
+%* *
+\subsection{Closing up the interface decls}
+%* *
+%*********************************************************
+
+Suppose we discover we don't need to recompile. Then we start from the
+IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need.
+
+\begin{code}
+closeIfaceDecls :: DynFlags -> Finder
+ -> HomeIfaceTable -> HomeSymbolTable
+ -> PersistentCompilerState
+ -> ModIface -- Get the decls from here
+ -> IO (PersistentCompilerState, Bool, [RenamedHsDecl])
+ -- True <=> errors happened
+closeIfaceDecls dflags finder hit hst pcs mod
+ mod_iface@(ModIface { mi_module = mod, mi_decls = iface_decls })
+ = initRn dflags finder hit hst pcs mod $
+
+ let
+ rule_decls = dcl_rules iface_decls
+ inst_decls = dcl_insts iface_decls
+ tycl_decls = dcl_tycl iface_decls
+ decls = map RuleD rule_decls ++
+ map InstD inst_decls ++
+ map TyClD tycl_decls
+ needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets`
+ unionManyNameSets (map instDeclFVs rule_decls) `unionNameSets`
+ unionManyNameSets (map tyClDeclFVs rule_decls)
+ in
+ closeDecls decls needed
+\end{code}
+
%*********************************************************
%* *
\subsection{Unused names}
rnDump :: [RenamedHsDecl] -- Renamed imported decls
-> [RenamedHsDecl] -- Renamed local decls
- -> RnMG (IO ())
+ -> RnMG ()
rnDump imp_decls local_decls
- = doptRn Opt_D_dump_rn_trace `thenRn` \ dump_rn_trace ->
- doptRn Opt_D_dump_rn_stats `thenRn` \ dump_rn_stats ->
- doptRn Opt_D_dump_rn `thenRn` \ dump_rn ->
- if dump_rn_trace || dump_rn_stats || dump_rn then
- getRnStats imp_decls `thenRn` \ stats_msg ->
- returnRn (printErrs stats_msg >>
- dumpIfSet dump_rn "Renamer:"
- (vcat (map ppr (local_decls ++ imp_decls))))
- else
- returnRn (return ())
+ = doptRn Opt_D_dump_rn_trace `thenRn` \ dump_rn_trace ->
+ doptRn Opt_D_dump_rn_stats `thenRn` \ dump_rn_stats ->
+ doptRn Opt_D_dump_rn `thenRn` \ dump_rn ->
+ getIfacesRn `thenRn` \ ifaces ->
+
+ ioToRnM (do { dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn)
+ "Renamer statistics"
+ (getRnStats imp_decls ifaces) ;
+
+ dumpIfSet dump_rn "Renamer:"
+ (vcat (map ppr (local_decls ++ imp_decls)))
+ }) `thenRn_`
+
+ returnRn ()
\end{code}
%*********************************************************
\begin{code}
-getRnStats :: [RenamedHsDecl] -> RnMG SDoc
-getRnStats imported_decls
- = getIfacesRn `thenRn` \ ifaces ->
- let
- n_mods = length [() | (_, _, True) <- eltsFM (iImpModInfo ifaces)]
-
- decls_read = [decl | (avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces),
- -- Data, newtype, and class decls are in the decls_fm
- -- under multiple names; the tycon/class, and each
- -- constructor/class op too.
- -- The 'True' selects just the 'main' decl
- not (isLocallyDefined (availName avail))
- ]
-
- (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd) = countTyClDecls decls_read
- (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls
-
- unslurped_insts = iInsts ifaces
- inst_decls_unslurped = length (bagToList unslurped_insts)
- inst_decls_read = id_sp + inst_decls_unslurped
-
- stats = vcat
- [int n_mods <+> text "interfaces read",
- hsep [ int cd_sp, text "class decls imported, out of",
- int cd_rd, text "read"],
- hsep [ int dd_sp, text "data decls imported, out of",
- int dd_rd, text "read"],
- hsep [ int nd_sp, text "newtype decls imported, out of",
- int nd_rd, text "read"],
- hsep [int sd_sp, text "type synonym decls imported, out of",
- int sd_rd, text "read"],
- hsep [int vd_sp, text "value signatures imported, out of",
- int vd_rd, text "read"],
- hsep [int id_sp, text "instance decls imported, out of",
- int inst_decls_read, text "read"],
- text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName)
- [d | TyClD d <- imported_decls, isClassDecl d]),
- text "cls dcls read" <+> fsep (map (ppr . tyClDeclName)
+getRnStats :: [RenamedHsDecl] -> Ifaces -> SDoc
+getRnStats imported_decls ifaces
+ = hcat [text "Renamer stats: ", stats])
+ where
+ n_mods = length [() | (_, _, True) <- eltsFM (iImpModInfo ifaces)]
+
+ decls_read = [decl | (avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces),
+ -- Data, newtype, and class decls are in the decls_fm
+ -- under multiple names; the tycon/class, and each
+ -- constructor/class op too.
+ -- The 'True' selects just the 'main' decl
+ not (isLocallyDefined (availName avail))
+ ]
+
+ (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd) = countTyClDecls decls_read
+ (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls
+
+ unslurped_insts = iInsts ifaces
+ inst_decls_unslurped = length (bagToList unslurped_insts)
+ inst_decls_read = id_sp + inst_decls_unslurped
+
+ stats = vcat
+ [int n_mods <+> text "interfaces read",
+ hsep [ int cd_sp, text "class decls imported, out of",
+ int cd_rd, text "read"],
+ hsep [ int dd_sp, text "data decls imported, out of",
+ int dd_rd, text "read"],
+ hsep [ int nd_sp, text "newtype decls imported, out of",
+ int nd_rd, text "read"],
+ hsep [int sd_sp, text "type synonym decls imported, out of",
+ int sd_rd, text "read"],
+ hsep [int vd_sp, text "value signatures imported, out of",
+ int vd_rd, text "read"],
+ hsep [int id_sp, text "instance decls imported, out of",
+ int inst_decls_read, text "read"],
+ text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName)
+ [d | TyClD d <- imported_decls, isClassDecl d]),
+ text "cls dcls read" <+> fsep (map (ppr . tyClDeclName)
[d | d <- decls_read, isClassDecl d])]
- in
- returnRn (hcat [text "Renamer stats: ", stats])
count_decls decls
= (class_decls,
#include "HsVersions.h"
-import {-# SOURCE #-} RnSource ( rnHsSigType )
+import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType )
import HsSyn
import HsBinds ( eqHsSig, sigName, hsSigDoc )
-> [RdrNameSig]
-> RnMS ([RenamedSig], FreeVars)
-renameSigs ok_sig [] = returnRn ([], emptyFVs) -- Common shortcut
+renameSigs ok_sig []
+ = returnRn ([], emptyFVs) -- Common shortcut
renameSigs ok_sig sigs
= -- Rename the signatures
- mapFvRn renameSig sigs `thenRn` \ (sigs', fvs) ->
+ mapRn renameSig sigs `thenRn` \ sigs' ->
-- Check for (a) duplicate signatures
-- (b) signatures for things not in this group
(goods, bads) = partition ok_sig in_scope
in
mapRn_ unknownSigErr bads `thenRn_`
- returnRn (goods, fvs)
+ returnRn (goods, hsSigFVs goods)
-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
-- because this won't work for:
-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)
-- Doesn't seem worth much trouble to sort this.
-renameSig :: Sig RdrName -> RnMS (Sig Name, FreeVars)
+renameSig :: Sig RdrName -> RnMS (Sig Name)
-- ClassOpSig is renamed elsewhere.
renameSig (Sig v ty src_loc)
= pushSrcLocRn src_loc $
lookupSigOccRn v `thenRn` \ new_v ->
- rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) ->
- returnRn (Sig new_v new_ty src_loc, fvs `addOneFV` new_v)
+ rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
+ returnRn (Sig new_v new_ty src_loc)
renameSig (SpecInstSig ty src_loc)
= pushSrcLocRn src_loc $
- rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ (new_ty, fvs) ->
- returnRn (SpecInstSig new_ty src_loc, fvs)
+ rnHsType (text "A SPECIALISE instance pragma") ty `thenRn` \ new_ty ->
+ returnRn (SpecInstSig new_ty src_loc)
renameSig (SpecSig v ty src_loc)
= pushSrcLocRn src_loc $
lookupSigOccRn v `thenRn` \ new_v ->
- rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) ->
- returnRn (SpecSig new_v new_ty src_loc, fvs `addOneFV` new_v)
+ rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
+ returnRn (SpecSig new_v new_ty src_loc)
renameSig (FixSig (FixitySig v fix src_loc))
= pushSrcLocRn src_loc $
lookupSigOccRn v `thenRn` \ new_v ->
- returnRn (FixSig (FixitySig new_v fix src_loc), unitFV new_v)
+ returnRn (FixSig (FixitySig new_v fix src_loc))
renameSig (InlineSig v p src_loc)
= pushSrcLocRn src_loc $
lookupSigOccRn v `thenRn` \ new_v ->
- returnRn (InlineSig new_v p src_loc, unitFV new_v)
+ returnRn (InlineSig new_v p src_loc)
renameSig (NoInlineSig v p src_loc)
= pushSrcLocRn src_loc $
lookupSigOccRn v `thenRn` \ new_v ->
- returnRn (NoInlineSig new_v p src_loc, unitFV new_v)
+ returnRn (NoInlineSig new_v p src_loc)
\end{code}
\begin{code}
%************************************************************************
\begin{code}
-type FreeVars = NameSet
-
-plusFV :: FreeVars -> FreeVars -> FreeVars
-addOneFV :: FreeVars -> Name -> FreeVars
-unitFV :: Name -> FreeVars
-emptyFVs :: FreeVars
-plusFVs :: [FreeVars] -> FreeVars
-mkFVs :: [Name] -> FreeVars
-
-isEmptyFVs = isEmptyNameSet
-emptyFVs = emptyNameSet
-plusFVs = unionManyNameSets
-plusFV = unionNameSets
-mkFVs = mkNameSet
-
--- No point in adding implicitly imported names to the free-var set
-addOneFV s n = addOneToNameSet s n
-unitFV n = unitNameSet n
-
-- A useful utility
mapFvRn f xs = mapRn f xs `thenRn` \ stuff ->
let
#include "HsVersions.h"
import {-# SOURCE #-} RnBinds ( rnBinds )
-import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType )
+import {-# SOURCE #-} RnSource ( rnHsTypeFVs )
import HsSyn
import RdrHsSyn
import RnHsSyn
import RnMonad
import RnEnv
-import RnIfaces ( lookupFixityRn )
+import RnHiFiles ( lookupFixityRn )
import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts )
import Literal ( inIntRange )
import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity )
if glaExts
then rnPat pat `thenRn` \ (pat', fvs1) ->
- rnHsType doc ty `thenRn` \ (ty', fvs2) ->
+ rnHsTypeFVs doc ty `thenRn` \ (ty', fvs2) ->
returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
else addErrRn (patSigErr ty) `thenRn_`
rnRpats rpats `thenRn` \ (rpats', fvs) ->
returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
rnPat (TypePatIn name) =
- (rnHsType (text "type pattern") name) `thenRn` \ (name', fvs) ->
+ (rnHsTypeFVs (text "type pattern") name) `thenRn` \ (name', fvs) ->
returnRn (TypePatIn name', fvs)
\end{code}
doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts ->
(case maybe_rhs_sig of
Nothing -> returnRn (Nothing, emptyFVs)
- Just ty | opt_GlasgowExts -> rnHsType doc_sig ty `thenRn` \ (ty', ty_fvs) ->
+ Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenRn` \ (ty', ty_fvs) ->
returnRn (Just ty', ty_fvs)
| otherwise -> addErrRn (patSigErr ty) `thenRn_`
returnRn (Nothing, emptyFVs)
returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
rnExpr (ExprWithTySig expr pty)
- = rnExpr expr `thenRn` \ (expr', fvExpr) ->
- rnHsSigType (text "an expression") pty `thenRn` \ (pty', fvTy) ->
+ = rnExpr expr `thenRn` \ (expr', fvExpr) ->
+ rnHsTypeFVs (text "an expression type signature") pty `thenRn` \ (pty', fvTy) ->
returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
rnExpr (HsIf p b1 b2 src_loc)
rnExpr b2 `thenRn` \ (b2', fvB2) ->
returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
-rnExpr (HsType a) =
- (rnHsType doc a) `thenRn` \ (t, fvT) -> returnRn (HsType t, fvT)
- where doc = text "renaming a type pattern"
-
+rnExpr (HsType a)
+ = rnHsTypeFVs doc a `thenRn` \ (t, fvT) ->
+ returnRn (HsType t, fvT)
+ where
+ doc = text "renaming a type pattern"
rnExpr (ArithSeqIn seq)
= lookupOrigName enumClass_RDR `thenRn` \ enum ->
tryLoadInterface, loadOrphanModules,
loadExports, loadFixDecls, loadDeprecs,
+ lookupFixityRn,
+
getTyClDeclBinders,
removeContext -- removeContext probably belongs somewhere else
) where
%*********************************************************
+%* *
+\subsection{Looking up fixities}
+%* *
+%*********************************************************
+
+This has to be in RnIfaces (or RnHiFiles) because it calls loadHomeInterface
+
+\begin{code}
+lookupFixityRn :: Name -> RnMS Fixity
+lookupFixityRn name
+ | isLocallyDefined name
+ = getFixityEnv `thenRn` \ local_fix_env ->
+ returnRn (lookupLocalFixity local_fix_env name)
+
+ | otherwise -- Imported
+ -- For imported names, we have to get their fixities by doing a loadHomeInterface,
+ -- and consulting the Ifaces that comes back from that, because the interface
+ -- file for the Name might not have been loaded yet. Why not? Suppose you import module A,
+ -- which exports a function 'f', which is defined in module B. Then B isn't loaded
+ -- right away (after all, it's possible that nothing from B will be used).
+ -- When we come across a use of 'f', we need to know its fixity, and it's then,
+ -- and only then, that we load B.hi. That is what's happening here.
+ = getHomeIfaceTableRn `thenRn` \ hit ->
+ loadHomeInterface doc name `thenRn` \ ifaces ->
+ case lookupTable hit (iPIT ifaces) name of
+ Just iface -> returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity)
+ Nothing -> returnRn defaultFixity
+ where
+ doc = ptext SLIT("Checking fixity for") <+> ppr name
+\end{code}
+
+
+%*********************************************************
%* *
\subsection{Errors}
%* *
#include "HsVersions.h"
import HsSyn
+import HsCore
+import Class ( FunDep, DefMeth(..) )
import TysWiredIn ( tupleTyCon, listTyCon, charTyCon )
import Name ( Name, getName, isTyVarName )
import NameSet
import BasicTypes ( Boxity )
+import Maybes ( orElse )
import Outputable
\end{code}
extractHsTyVars :: RenamedHsType -> NameSet
extractHsTyVars x = filterNameSet isTyVarName (extractHsTyNames x)
+extractFunDepNames :: FunDep Name -> NameSet
+extractFunDepNames (ns1, ns2) = mkNameSet ns1 `unionNameSets` mkNameSet ns2
+
extractHsTyNames :: RenamedHsType -> NameSet
extractHsTyNames ty
= get ty
%************************************************************************
%* *
+\subsection{Free variables of declarations}
+%* *
+%************************************************************************
+
+Return the Names that must be in scope if we are to use this declaration.
+In all cases this is set up for interface-file declarations:
+ - for class decls we ignroe the bindings
+ - for instance decls likewise, plus the pragmas
+ - for rule decls, we ignore HsRules
+
+\begin{code}
+tyClDeclFVs :: RenamedTyClDecl -> NameSet
+tyClDeclFVs (IfaceSig name ty id_infos loc)
+ = extractHsTyNames ty `plusFV`
+ plusFVs (map hsIdInfoFVs id_infos)
+
+tyClDeclFVs (TyData _ context _ tyvars condecls _ derivings _ _ _)
+ = delFVs (map hsTyVarName tyvars) $
+ extractHsCtxtTyNames context `plusFV`
+ plusFVs (map conDeclFVs condecls) `plusFV`
+ mkNameSet (derivings `orElse` [])
+
+tyClDeclFVs (TySynonym _ tyvars ty _)
+ = delFVs (map hsTyVarName tyvars) (extractHsTyNames ty)
+
+tyClDeclFVs (ClassDecl context _ tyvars fds sigs _ _ src_loc)
+ = delFVs (map hsTyVarName tyvars) $
+ extractHsCtxtTyNames context `plusFV`
+ plusFVs (map extractFunDepNames fds) `plusFV`
+ plusFVs (map hsSigFVs sigs)
+
+----------------
+hsSigFVs (Sig v ty _) = extractHsTyNames ty `addOneFV` v
+hsSigFVs (SpecInstSig ty _) = extractHsTyNames ty
+hsSigFVs (SpecSig v ty _) = extractHsTyNames ty `addOneFV` v
+hsSigFVs (FixSig (FixitySig v _ _)) = unitFV v
+hsSigFVs (InlineSig v p _) = unitFV v
+hsSigFVs (NoInlineSig v p _) = unitFV v
+hsSigFVs (ClassOpSig v dm ty _) = dmFVs dm `plusFV` extractHsTyNames ty `addOneFV` v
+
+dmFVs (Just (DefMeth v)) = unitFV v
+dmFVs other = emptyFVs
+
+----------------
+instDeclFVs (InstDecl inst_ty _ _ maybe_dfun _)
+ = extractHsTyNames inst_ty `plusFV`
+ (case maybe_dfun of { Just n -> unitFV n; Nothing -> emptyFVs })
+
+----------------
+ruleDeclFVs (HsRule _ _ _ _ _ _) = emptyFVs
+ruleDeclFVs (IfaceRule _ vars _ _ rhs _)
+ = delFVs (map ufBinderName vars) $
+ ufExprFVs rhs
+
+----------------
+conDeclFVs (ConDecl _ _ tyvars context details _)
+ = delFVs (map hsTyVarName tyvars) $
+ extractHsCtxtTyNames context `plusFV`
+ conDetailsFVs details
+
+conDetailsFVs (VanillaCon btys) = plusFVs (map bangTyFVs btys)
+conDetailsFVs (InfixCon bty1 bty2) = bangTyFVs bty1 `plusFV` bangTyFVs bty2
+conDetailsFVs (RecCon flds) = plusFVs [bangTyFVs bty | (_, bty) <- flds]
+
+bangTyFVs bty = extractHsTyNames (getBangType bty)
+
+----------------
+hsIdInfoFVs (HsUnfold _ unf) = ufExprFVs unf
+hsIdInfoFVs (HsWorker n) = unitFV n
+hsIdInfoFVs other = emptyFVs
+
+----------------
+ufExprFVs (UfVar n) = unitFV n
+ufExprFVs (UfLit l) = emptyFVs
+ufExprFVs (UfLitLit l ty) = extractHsTyNames ty
+ufExprFVs (UfCCall cc ty) = extractHsTyNames ty
+ufExprFVs (UfType ty) = extractHsTyNames ty
+ufExprFVs (UfTuple tc es) = hsTupConFVs tc `plusFV` plusFVs (map ufExprFVs es)
+ufExprFVs (UfLam v e) = ufBndrFVs v (ufExprFVs e)
+ufExprFVs (UfApp e1 e2) = ufExprFVs e1 `plusFV` ufExprFVs e2
+ufExprFVs (UfCase e n as) = ufExprFVs e `plusFV` delFV n (plusFVs (map ufAltFVs as))
+ufExprFVs (UfNote n e) = ufNoteFVs n `plusFV` ufExprFVs e
+ufExprFVs (UfLet (UfNonRec b r) e) = ufExprFVs r `plusFV` ufBndrFVs b (ufExprFVs e)
+ufExprFVs (UfLet (UfRec prs) e) = foldr ufBndrFVs
+ (foldr (plusFV . ufExprFVs . snd) (ufExprFVs e) prs)
+ (map fst prs)
+
+ufBndrFVs (UfValBinder n ty) fvs = extractHsTyNames ty `plusFV` delFV n fvs
+ufBndrFVs (UfTyBinder n k) fvs = delFV n fvs
+
+ufAltFVs (con, vs, e) = ufConFVs con `plusFV` delFVs vs (ufExprFVs e)
+
+ufConFVs (UfDataAlt n) = unitFV n
+ufConFVs (UfTupleAlt t) = hsTupConFVs t
+ufConFVs (UfLitLitAlt _ ty) = extractHsTyNames ty
+ufConFVs other = emptyFVs
+
+ufNoteFVs (UfCoerce ty) = extractHsTyNames ty
+ufNoteFVs note = emptyFVs
+
+hsTupConFVs (HsTupCon n _) = unitFV n
+\end{code}
+
+%************************************************************************
+%* *
\subsection{A few functions on generic defintions
%* *
%************************************************************************
\begin{code}
module RnIfaces
- (
+ (
getInterfaceExports,
- getImportedInstDecls, getImportedRules,
- lookupFixityRn,
- importDecl, ImportDeclResult(..), recordLocalSlurps,
- mkImportInfo, getSlurped,
+ recordLocalSlurps,
+ mkImportInfo,
+
+ slurpImpDecls,
RecompileRequired, outOfDate, upToDate, recompileRequired
)
import RnHiFiles ( tryLoadInterface, loadHomeInterface, loadInterface,
loadOrphanModules
)
+import RnSource ( rnTyClDecl, rnDecl )
import RnEnv
import RnMonad
import Name ( Name {-instance NamedThing-}, nameOccName,
%* *
%*********************************************************
-This has to be in RnIfaces (or RnHiFiles) because it calls loadHomeInterface
-
-\begin{code}
-lookupFixityRn :: Name -> RnMS Fixity
-lookupFixityRn name
- | isLocallyDefined name
- = getFixityEnv `thenRn` \ local_fix_env ->
- returnRn (lookupLocalFixity local_fix_env name)
-
- | otherwise -- Imported
- -- For imported names, we have to get their fixities by doing a loadHomeInterface,
- -- and consulting the Ifaces that comes back from that, because the interface
- -- file for the Name might not have been loaded yet. Why not? Suppose you import module A,
- -- which exports a function 'f', which is defined in module B. Then B isn't loaded
- -- right away (after all, it's possible that nothing from B will be used).
- -- When we come across a use of 'f', we need to know its fixity, and it's then,
- -- and only then, that we load B.hi. That is what's happening here.
- = getHomeIfaceTableRn `thenRn` \ hit ->
- loadHomeInterface doc name `thenRn` \ ifaces ->
- case lookupTable hit (iPIT ifaces) name of
- Just iface -> returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity)
- Nothing -> returnRn defaultFixity
- where
- doc = ptext SLIT("Checking fixity for") <+> ppr name
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Instance declarations are handled specially}
-%* *
-%*********************************************************
-
\begin{code}
getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameHsDecl)]
getImportedInstDecls gates
add_item xs _ = x:xs
\end{code}
+%*********************************************************
+%* *
+\subsection{Slurping declarations}
+%* *
+%*********************************************************
+
+\begin{code}
+-------------------------------------------------------
+slurpImpDecls source_fvs
+ = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_`
+
+ -- The current slurped-set records all local things
+ getSlurped `thenRn` \ source_binders ->
+ slurpSourceRefs source_binders source_fvs `thenRn` \ (decls, needed) ->
+
+ -- Then get everything else
+ closeDecls decls needed `thenRn` \ decls1 ->
+
+ -- Finally, get any deferred data type decls
+ slurpDeferredDecls decls1 `thenRn` \ final_decls ->
+
+ returnRn final_decls
+
+
+-------------------------------------------------------
+slurpSourceRefs :: NameSet -- Variables defined in source
+ -> FreeVars -- Variables referenced in source
+ -> RnMG ([RenamedHsDecl],
+ FreeVars) -- Un-satisfied needs
+-- The declaration (and hence home module) of each gate has
+-- already been loaded
+
+slurpSourceRefs source_binders source_fvs
+ = go_outer [] -- Accumulating decls
+ emptyFVs -- Unsatisfied needs
+ emptyFVs -- Accumulating gates
+ (nameSetToList source_fvs) -- Things whose defn hasn't been loaded yet
+ where
+ -- The outer loop repeatedly slurps the decls for the current gates
+ -- and the instance decls
+
+ -- The outer loop is needed because consider
+ -- instance Foo a => Baz (Maybe a) where ...
+ -- It may be that @Baz@ and @Maybe@ are used in the source module,
+ -- but not @Foo@; so we need to chase @Foo@ too.
+ --
+ -- We also need to follow superclass refs. In particular, 'chasing @Foo@' must
+ -- include actually getting in Foo's class decl
+ -- class Wib a => Foo a where ..
+ -- so that its superclasses are discovered. The point is that Wib is a gate too.
+ -- We do this for tycons too, so that we look through type synonyms.
+
+ go_outer decls fvs all_gates []
+ = returnRn (decls, fvs)
+
+ go_outer decls fvs all_gates refs -- refs are not necessarily slurped yet
+ = traceRn (text "go_outer" <+> ppr refs) `thenRn_`
+ foldlRn go_inner (decls, fvs, emptyFVs) refs `thenRn` \ (decls1, fvs1, gates1) ->
+ getImportedInstDecls (all_gates `plusFV` gates1) `thenRn` \ inst_decls ->
+ rnInstDecls decls1 fvs1 gates1 inst_decls `thenRn` \ (decls2, fvs2, gates2) ->
+ go_outer decls2 fvs2 (all_gates `plusFV` gates2)
+ (nameSetToList (gates2 `minusNameSet` all_gates))
+ -- Knock out the all_gates because even if we don't slurp any new
+ -- decls we can get some apparently-new gates from wired-in names
+
+ go_inner (decls, fvs, gates) wanted_name
+ = importDecl wanted_name `thenRn` \ import_result ->
+ case import_result of
+ AlreadySlurped -> returnRn (decls, fvs, gates)
+ WiredIn -> returnRn (decls, fvs, gates `plusFV` getWiredInGates wanted_name)
+ Deferred -> returnRn (decls, fvs, gates `addOneFV` wanted_name) -- It's a type constructor
+
+ HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) ->
+ returnRn (TyClD new_decl : decls,
+ fvs1 `plusFV` fvs,
+ gates `plusFV` getGates source_fvs new_decl)
+
+rnInstDecls decls fvs gates []
+ = returnRn (decls, fvs, gates)
+rnInstDecls decls fvs gates (d:ds)
+ = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) ->
+ rnInstDecls (new_decl:decls)
+ (fvs1 `plusFV` fvs)
+ (gates `plusFV` getInstDeclGates new_decl)
+ ds
+\end{code}
+
+
+\begin{code}
+-------------------------------------------------------
+-- 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
+
+
+-------------------------------------------------------
+-- 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` \ import_result ->
+ case import_result of
+ -- Found a declaration... rename it
+ HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) ->
+ returnRn (TyClD new_decl:decls, fvs1 `plusFV` fvs)
+
+ -- No declaration... (wired in thing, or deferred, or already slurped)
+ other -> returnRn (decls, fvs)
+
+
+-------------------------------------------------------
+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)
+rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl)
+\end{code}
+
+
\begin{code}
getSlurped
= getIfacesRn `thenRn` \ ifaces ->
\end{code}
+
+%*********************************************************
+%* *
+\subsection{Deferred declarations}
+%* *
+%*********************************************************
+
+The idea of deferred declarations is this. Suppose we have a function
+ f :: T -> Int
+ data T = T1 A | T2 B
+ data A = A1 X | A2 Y
+ data B = B1 P | B2 Q
+Then we don't want to load T and all its constructors, and all
+the types those constructors refer to, and all the types *those*
+constructors refer to, and so on. That might mean loading many more
+interface files than is really necessary. So we 'defer' loading T.
+
+But f might be strict, and the calling convention for evaluating
+values of type T depends on how many constructors T has, so
+we do need to load T, but not the full details of the type T.
+So we load the full decl for T, but only skeleton decls for A and B:
+ f :: T -> Int
+ data T = {- 2 constructors -}
+
+Whether all this is worth it is moot.
+
+\begin{code}
+slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl]
+slurpDeferredDecls decls = returnRn decls
+
+{- OMIT FOR NOW
+slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl]
+slurpDeferredDecls decls
+ = getDeferredDecls `thenRn` \ def_decls ->
+ rnIfaceDecls decls emptyFVs (map stripDecl def_decls) `thenRn` \ (decls1, fvs) ->
+ ASSERT( isEmptyFVs fvs )
+ returnRn decls1
+
+stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ loc name1 name2))
+ = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing loc
+ name1 name2))
+ -- Nuke the context and constructors
+ -- But retain the *number* of constructors!
+ -- Also the tvs will have kinds on them.
+-}
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Extracting the `gates'}
+%* *
+%*********************************************************
+
+When we import a declaration like
+\begin{verbatim}
+ data T = T1 Wibble | T2 Wobble
+\end{verbatim}
+we don't want to treat @Wibble@ and @Wobble@ as gates
+{\em unless} @T1@, @T2@ respectively are mentioned by the user program.
+If only @T@ is mentioned
+we want only @T@ to be a gate;
+that way we don't suck in useless instance
+decls for (say) @Eq Wibble@, when they can't possibly be useful.
+
+@getGates@ takes a newly imported (and renamed) decl, and the free
+vars of the source program, and extracts from the decl the gate names.
+
+\begin{code}
+getGates source_fvs (IfaceSig _ ty _ _)
+ = extractHsTyNames ty
+
+getGates source_fvs (ClassDecl ctxt cls tvs _ sigs _ _ _ )
+ = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
+ (hsTyVarNames tvs)
+ `addOneToNameSet` cls)
+ `plusFV` maybe_double
+ where
+ get (ClassOpSig n _ ty _)
+ | n `elemNameSet` source_fvs = extractHsTyNames ty
+ | otherwise = emptyFVs
+
+ -- If we load any numeric class that doesn't have
+ -- Int as an instance, add Double to the gates.
+ -- This takes account of the fact that Double might be needed for
+ -- defaulting, but we don't want to load Double (and all its baggage)
+ -- if the more exotic classes aren't used at all.
+ maybe_double | nameUnique cls `elem` fractionalClassKeys
+ = unitFV (getName doubleTyCon)
+ | otherwise
+ = emptyFVs
+
+getGates source_fvs (TySynonym tycon tvs ty _)
+ = delListFromNameSet (extractHsTyNames ty)
+ (hsTyVarNames tvs)
+ -- A type synonym type constructor isn't a "gate" for instance decls
+
+getGates source_fvs (TyData _ ctxt tycon tvs cons _ _ _ _ _)
+ = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
+ (hsTyVarNames tvs)
+ `addOneToNameSet` tycon
+ where
+ get (ConDecl n _ tvs ctxt details _)
+ | n `elemNameSet` source_fvs
+ -- If the constructor is method, get fvs from all its fields
+ = delListFromNameSet (get_details details `plusFV`
+ extractHsCtxtTyNames ctxt)
+ (hsTyVarNames tvs)
+ get (ConDecl n _ tvs ctxt (RecCon fields) _)
+ -- Even if the constructor isn't mentioned, the fields
+ -- might be, as selectors. They can't mention existentially
+ -- bound tyvars (typechecker checks for that) so no need for
+ -- the deleteListFromNameSet part
+ = foldr (plusFV . get_field) emptyFVs fields
+
+ get other_con = emptyFVs
+
+ get_details (VanillaCon tys) = plusFVs (map get_bang tys)
+ get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2
+ get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields]
+
+ get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t
+ | otherwise = emptyFVs
+
+ get_bang bty = extractHsTyNames (getBangType bty)
+\end{code}
+
+@getWiredInGates@ is just like @getGates@, but it sees a wired-in @Name@
+rather than a declaration.
+
+\begin{code}
+getWiredInGates :: Name -> FreeVars
+getWiredInGates name -- No classes are wired in
+ = case lookupNameEnv wiredInThingEnv name of
+ Just (AnId the_id) -> getWiredInGates_s (namesOfType (idType the_id))
+
+ Just (ATyCon tc)
+ | isSynTyCon tc
+ -> getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars))
+ where
+ (tyvars,ty) = getSynTyConDefn tc
+
+ other -> unitFV name
+
+getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names)
+\end{code}
+
+\begin{code}
+getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty
+getInstDeclGates other = emptyFVs
+\end{code}
+
+
%*********************************************************
%* *
\subsection{Getting in a declaration}
-_interface_ RnSource 1
+_interface_ RnSource 2
_exports_
-RnSource rnHsType rnHsPolyType rnHsSigType;
+RnSource rnHsType rnHsSigType rnHsTypeFVs;
_declarations_
-1 rnHsType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType
+1 rnHsTypeFVs _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType
-> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;;
-1 rnHsSigType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType
- -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;;
-1 rnHsPolyType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType
- -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;;
+2 rnHsSigType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType
+ -> RnMonad.RnMS RnHsSyn.RenamedHsType ;;
+2 rnHsType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType
+ -> RnMonad.RnMS RnHsSyn.RenamedHsType ;;
\section[RnSource]{Main pass of renamer}
\begin{code}
-module RnSource ( rnDecl, rnTyClDecl, rnRuleDecl, rnInstDecl,
- rnSourceDecls, rnHsType, rnHsSigType
+module RnSource ( rnDecl, rnTyClDecl, rnRuleDecl, rnInstDecl, rnSourceDecls,
+ rnHsType, rnHsSigType, rnHsTypeFVs, rnHsSigTypeFVs
) where
#include "HsVersions.h"
import RnExpr
import HsSyn
import HsTypes ( hsTyVarNames, pprHsContext )
-import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr )
+import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr, elemRdrEnv )
import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
extractRuleBndrsTyVars, extractHsTyRdrTyVars,
extractHsCtxtRdrTyVars, extractGenericPatTyVars
)
import RnMonad
-import FunDeps ( oclose )
import Class ( FunDep, DefMeth (..) )
import Name ( Name, OccName, nameOccName, NamedThing(..) )
import NameSet
-import FiniteMap ( elemFM )
import PrelInfo ( derivableClassKeys, cCallishClassKeys )
import PrelNames ( deRefStablePtr_RDR, makeStablePtr_RDR,
bindIO_RDR, returnIO_RDR
rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) ->
returnRn (ValD new_binds, fvs)
-rnDecl (TyClD tycl_decl) = rnTyClDecl tycl_decl `thenRn` \ (new_decl, fvs) ->
- returnRn (TyClD new_decl, fvs)
-
-rnDecl (RuleD rule)
- = rnRuleDecl rule `thenRn` \ (new_rule, fvs) ->
- returnRn (RuleD new_rule, fvs)
+rnDecl (TyClD tycl_decl)
+ = rnTyClDecl tycl_decl `thenRn` \ new_decl ->
+ rnClassBinds new_decl `thenRn` \ (new_decl', fvs) ->
+ returnRn (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl')
rnDecl (InstD inst)
- = rnInstDecl inst `thenRn` \ (new_inst, fvs) ->
- returnRn (InstD new_inst, fvs)
+ = rnInstDecl inst `thenRn` \ new_inst ->
+ rnInstBinds new_inst `thenRn` \ (new_inst', fvs)
+ returnRn (InstD new_inst, fvs `plusFV` instDeclFVs new_inst')
+
+rnDecl (RuleD rule)
+ | isIfaceRuleDecl rule
+ = rnIfaceRuleDecl rule `thenRn` \ new_rule ->
+ returnRn (RuleD new_rule, ruleDeclFVs new_rule)
+ | otherwise
+ = rnHsRuleDecl rule
rnDecl (DefD (DefaultDecl tys src_loc))
= pushSrcLocRn src_loc $
- rnHsTypes doc_str tys `thenRn` \ (tys', fvs) ->
+ mapFvRn (rnHsTypeFVs doc_str) tys `thenRn` \ (tys', fvs) ->
returnRn (DefD (DefaultDecl tys' src_loc), fvs)
where
doc_str = text "a `default' declaration"
extra_fvs imp_exp `thenRn` \ fvs1 ->
- rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
+ rnHsTypeFVs fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
fvs1 `plusFV` fvs2)
where
- fo_decl_msg = ptext SLIT("a foreign declaration")
+ fo_decl_msg = ptext SLIT("The foreign declaration for") <+> ppr name
isDyn = isDynamicExtName ext_nm
ok_ext_nm Dynamic = True
\begin{code}
rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
= pushSrcLocRn src_loc $
- rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
- let
- inst_tyvars = case inst_ty' of
+ rnHsSigType (text "an instance decl") inst_ty `thenRn` \ inst_ty' ->
+
+ (case maybe_dfun_rdr_name of
+ Nothing -> returnRn Nothing
+ Just dfun_rdr_name -> lookupSysBinder dfun_rdr_name `thenRn` \ dfun_name ->
+ returnRn (Just dfun_name)
+ ) `thenRn` \ maybe_dfun_name ->
+
+ -- The typechecker checks that all the bindings are for the right class.
+ returnRn (InstDecl inst_ty' mbinds' new_uprags maybe_dfun_name src_loc)
+ where
+ meth_doc = text "the bindings in an instance declaration"
+ meth_names = collectLocatedMonoBinders mbinds
+
+-- Compare rnClassBinds
+rnInstBinds (InstDecl _ mbinds uprags _ _ )
+ (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
+ = let
+ inst_tyvars = case inst_ty of
HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
other -> []
-- (Slightly strangely) the forall-d tyvars scope over
-- But the (unqualified) method names are in scope
bindLocalNames binders (
renameSigs (okInstDclSig binder_set) uprags
- ) `thenRn` \ (new_uprags, prag_fvs) ->
+ ) `thenRn` \ (uprags', prag_fvs) ->
- (case maybe_dfun_rdr_name of
- Nothing -> returnRn (Nothing, emptyFVs)
-
- Just dfun_rdr_name -> lookupSysBinder dfun_rdr_name `thenRn` \ dfun_name ->
- returnRn (Just dfun_name, unitFV dfun_name)
- ) `thenRn` \ (maybe_dfun_name, dfun_fv) ->
-
- -- The typechecker checks that all the bindings are for the right class.
- returnRn (InstDecl inst_ty' mbinds' new_uprags maybe_dfun_name src_loc,
- inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
- where
- meth_doc = text "the bindings in an instance declaration"
- meth_names = collectLocatedMonoBinders mbinds
+ returnRn (InstDecl inst_ty mbinds' uprags' maybe_dfun_rdr_name src_loc,
+ meth_fvs `plusFV` prag_fvs)
\end{code}
%*********************************************************
%*********************************************************
\begin{code}
-rnRuleDecl (IfaceRule rule_name vars fn args rhs src_loc)
+rnIfaceRuleDecl (IfaceRule rule_name vars fn args rhs src_loc)
= pushSrcLocRn src_loc $
lookupOccRn fn `thenRn` \ fn' ->
rnCoreBndrs vars $ \ vars' ->
- mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) ->
- rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
- returnRn (IfaceRule rule_name vars' fn' args' rhs' src_loc,
- (fvs1 `plusFV` fvs2) `addOneFV` fn')
+ mapFvRn rnCoreExpr args `thenRn` \ args' ->
+ rnCoreExpr rhs `thenRn` \ rhs' ->
+ returnRn (IfaceRule rule_name vars' fn' args' rhs' src_loc)
-rnRuleDecl (HsRule rule_name tvs vars lhs rhs src_loc)
+rnHsRuleDecl (HsRule rule_name tvs vars lhs rhs src_loc)
= ASSERT( null tvs )
pushSrcLocRn src_loc $
get_var (RuleBndrSig v _) = v
rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs)
- rn_var (RuleBndrSig v t, id) = rnHsType doc t `thenRn` \ (t', fvs) ->
+ rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t `thenRn` \ (t', fvs) ->
returnRn (RuleBndrSig id t', fvs)
\end{code}
rnTyClDecl (IfaceSig name ty id_infos loc)
= pushSrcLocRn loc $
lookupTopBndrRn name `thenRn` \ name' ->
- rnHsType doc_str ty `thenRn` \ (ty',fvs1) ->
- mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) ->
- returnRn (IfaceSig name' ty' id_infos' loc, fvs1 `plusFV` fvs2)
+ rnHsType doc_str ty `thenRn` \ ty' ->
+ mapRn rnIdInfo id_infos `thenRn` \ id_infos' ->
+ returnRn (IfaceSig name' ty' id_infos' loc)
where
doc_str = text "the interface signature for" <+> quotes (ppr name)
rnTyClDecl (TyData new_or_data context tycon tyvars condecls nconstrs derivings src_loc gen_name1 gen_name2)
= pushSrcLocRn src_loc $
lookupTopBndrRn tycon `thenRn` \ tycon' ->
- bindTyVarsFVRn data_doc tyvars $ \ tyvars' ->
- rnContext data_doc context `thenRn` \ (context', cxt_fvs) ->
+ bindTyVarsRn data_doc tyvars $ \ tyvars' ->
+ rnContext data_doc context `thenRn` \ context' ->
checkDupOrQualNames data_doc con_names `thenRn_`
- mapFvRn rnConDecl condecls `thenRn` \ (condecls', con_fvs) ->
+ mapFvRn rnConDecl condecls `thenRn` \ condecls' ->
lookupSysBinder gen_name1 `thenRn` \ name1' ->
lookupSysBinder gen_name2 `thenRn` \ name2' ->
- rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) ->
+ rnDerivs derivings `thenRn` \ derivings' ->
returnRn (TyData new_or_data context' tycon' tyvars' condecls' nconstrs
- derivings' src_loc name1' name2',
- cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
+ derivings' src_loc name1' name2')
where
data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
con_names = map conDeclName condecls
= pushSrcLocRn src_loc $
doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
lookupTopBndrRn name `thenRn` \ name' ->
- bindTyVarsFVRn syn_doc tyvars $ \ tyvars' ->
- rnHsType syn_doc (unquantify glaExts ty) `thenRn` \ (ty', ty_fvs) ->
- returnRn (TySynonym name' tyvars' ty' src_loc, ty_fvs)
+ bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
+ rnHsType syn_doc (unquantify glaExts ty) `thenRn` \ ty' ->
+ returnRn (TySynonym name' tyvars' ty' src_loc)
where
syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
-- They aren't in scope (because they aren't visible to the user)
-- and what we want to do is simply look them up in the cache;
-- we jolly well ought to get a 'hit' there!
- -- So the 'Imported' part of this call is not relevant.
- -- Unclean; but since these two are the only place this happens
- -- I can't work up the energy to do it more beautifully
-
- mapRn lookupSysBinder names `thenRn` \ names' ->
+ mapRn lookupSysBinder names `thenRn` \ names' ->
-- Tyvars scope over bindings and context
- bindTyVarsFV2Rn cls_doc tyvars ( \ clas_tyvar_names tyvars' ->
+ bindTyVars2Rn cls_doc tyvars $ \ clas_tyvar_names tyvars' ->
-- Check the superclasses
- rnContext cls_doc context `thenRn` \ (context', cxt_fvs) ->
+ rnContext cls_doc context `thenRn` \ context' ->
-- Check the functional dependencies
- rnFds cls_doc fds `thenRn` \ (fds', fds_fvs) ->
+ rnFds cls_doc fds `thenRn` \ fds' ->
-- Check the signatures
-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
(op_sigs, non_op_sigs) = partition isClassOpSig sigs
sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
in
- checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
- mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs `thenRn` \ (sigs', sig_fvs) ->
+ checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
+ mapRn (rnClassOp cname' clas_tyvar_names fds') op_sigs `thenRn` \ sigs' ->
let
binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
in
- renameSigs (okClsDclSig binders) non_op_sigs `thenRn` \ (non_ops', fix_fvs) ->
+ renameSigs (okClsDclSig binders) non_op_sigs `thenRn` \ non_ops' ->
- -- Check the methods
- -- The newLocals call is tiresome: given a generic class decl
+ -- 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
+ -- for instance decls.
+
+ returnRn (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds' names' src_loc)
+ where
+ cls_doc = text "the declaration for class" <+> ppr cname
+ sig_doc = text "the signatures for class" <+> ppr cname
+ meth_doc = text "the default-methods for class" <+> ppr cname
+
+rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op maybe_dm_stuff ty locn)
+ = pushSrcLocRn locn $
+ lookupTopBndrRn op `thenRn` \ op_name ->
+
+ -- Check the signature
+ rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty ->
+
+ -- Make the default-method name
+ (case maybe_dm_stuff of
+ Nothing -> returnRn Nothing -- Source-file class decl
+
+ Just (DefMeth dm_rdr_name)
+ -> -- Imported class that has a default method decl
+ -- See comments with tname, snames, above
+ lookupSysBinder dm_rdr_name `thenRn` \ dm_name ->
+ returnRn (Just (DefMeth dm_name))
+ -- An imported class decl for a class decl that had an explicit default
+ -- method, mentions, rather than defines,
+ -- the default method, so we must arrange to pull it in
+
+ Just GenDefMeth -> returnRn (Just GenDefMeth)
+ Just NoDefMeth -> returnRn (Just NoDefMeth)
+ ) `thenRn` \ maybe_dm_stuff' ->
+
+ returnRn (ClassOpSig op_name maybe_dm_stuff' new_ty locn)
+
+rnClassBinds :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars)
+ -- Rename the mbinds only; the rest is done already
+rnClassBinds (ClassDecl _ _ _ _ _ mbinds _ _ ) -- Get mbinds from here
+ (ClassDecl context cname tyvars fds sigs _ names src_loc) -- Everything else is here
+ = -- The newLocals call is tiresome: given a generic class decl
-- class C a where
-- op :: a -> a
-- op {| x+y |} (Inl a) = ...
-- we want to name both "x" tyvars with the same unique, so that they are
-- easy to group together in the typechecker.
-- Hence the
+ extendTyVarEnvFVRn (map hsTyVarName tyvars) $
getLocalNameEnv `thenRn` \ name_env ->
let
meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
- not (tv `elemFM` name_env)]
+ not (tv `elemRdrEnv` name_env)]
in
checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
newLocalsRn mkLocalName gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars ->
rnMethodBinds gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) ->
-
- -- 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
- -- for instance decls.
-
- returnRn (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds'
- names' src_loc,
- sig_fvs `plusFV`
-
- fix_fvs `plusFV`
- cxt_fvs `plusFV`
- fds_fvs `plusFV`
- meth_fvs
- )
- )
- where
- cls_doc = text "the declaration for class" <+> ppr cname
- sig_doc = text "the signatures for class" <+> ppr cname
- meth_doc = text "the default-methods for class" <+> ppr cname
-
- rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op maybe_dm_stuff ty locn)
- = pushSrcLocRn locn $
- lookupTopBndrRn op `thenRn` \ op_name ->
-
- -- Check the signature
- rnHsSigType (quotes (ppr op)) ty `thenRn` \ (new_ty, op_ty_fvs) ->
- let
- check_in_op_ty clas_tyvar =
- checkRn (clas_tyvar `elemNameSet` oclose clas_fds op_ty_fvs)
- (classTyVarNotInOpTyErr clas_tyvar sig)
- in
- mapRn_ check_in_op_ty clas_tyvars `thenRn_`
-
- -- Make the default-method name
- (case maybe_dm_stuff of
- Nothing -> returnRn (Nothing, emptyFVs) -- Source-file class decl
-
- Just (DefMeth dm_rdr_name)
- -> -- Imported class that has a default method decl
- -- See comments with tname, snames, above
- lookupSysBinder dm_rdr_name `thenRn` \ dm_name ->
- returnRn (Just (DefMeth dm_name), unitFV dm_name)
- -- An imported class decl for a class decl that had an explicit default
- -- method, mentions, rather than defines,
- -- the default method, so we must arrange to pull it in
- Just GenDefMeth
- -> returnRn (Just GenDefMeth, emptyFVs)
- Just NoDefMeth
- -> returnRn (Just NoDefMeth, emptyFVs)
- ) `thenRn` \ (maybe_dm_stuff', dm_fvs) ->
-
- returnRn (ClassOpSig op_name maybe_dm_stuff' new_ty locn, op_ty_fvs `plusFV` dm_fvs)
+ returnRn (ClassDecl context cname tyvars fds sigs mbinds' names src_loc, meth_fvs)
\end{code}
conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
conDeclName (ConDecl n _ _ _ _ l) = (n,l)
-rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
+rnConDecl :: RdrNameConDecl -> RnMS RenamedConDecl
rnConDecl (ConDecl name wkr tvs cxt details locn)
= pushSrcLocRn locn $
checkConName name `thenRn_`
lookupSysBinder wkr `thenRn` \ new_wkr ->
-- See comments with ClassDecl
- bindTyVarsFVRn doc tvs $ \ new_tyvars ->
- rnContext doc cxt `thenRn` \ (new_context, cxt_fvs) ->
- rnConDetails doc locn details `thenRn` \ (new_details, det_fvs) ->
- returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn,
- cxt_fvs `plusFV` det_fvs)
+ bindTyVarsRn doc tvs $ \ new_tyvars ->
+ rnContext doc cxt `thenRn` \ new_context ->
+ rnConDetails doc locn details `thenRn` \ new_details ->
+ returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn)
where
doc = text "the definition of data constructor" <+> quotes (ppr name)
rnConDetails doc locn (VanillaCon tys)
- = mapFvRn (rnBangTy doc) tys `thenRn` \ (new_tys, fvs) ->
- returnRn (VanillaCon new_tys, fvs)
+ = mapRn (rnBangTy doc) tys `thenRn` \ new_tys ->
+ returnRn (VanillaCon new_tys)
rnConDetails doc locn (InfixCon ty1 ty2)
- = rnBangTy doc ty1 `thenRn` \ (new_ty1, fvs1) ->
- rnBangTy doc ty2 `thenRn` \ (new_ty2, fvs2) ->
- returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
+ = rnBangTy doc ty1 `thenRn` \ new_ty1 ->
+ rnBangTy doc ty2 `thenRn` \ new_ty2 ->
+ returnRn (InfixCon new_ty1 new_ty2)
rnConDetails doc locn (RecCon fields)
= checkDupOrQualNames doc field_names `thenRn_`
- mapFvRn (rnField doc) fields `thenRn` \ (new_fields, fvs) ->
- returnRn (RecCon new_fields, fvs)
+ mapRn (rnField doc) fields `thenRn` \ new_fields ->
+ returnRn (RecCon new_fields)
where
field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
rnField doc (names, ty)
= mapRn lookupTopBndrRn names `thenRn` \ new_names ->
- rnBangTy doc ty `thenRn` \ (new_ty, fvs) ->
- returnRn ((new_names, new_ty), fvs)
+ rnBangTy doc ty `thenRn` \ new_ty ->
+ returnRn (new_names, new_ty)
rnBangTy doc (Banged ty)
- = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
- returnRn (Banged new_ty, fvs)
+ = rnHsType doc ty `thenRn` \ new_ty ->
+ returnRn (Banged new_ty)
rnBangTy doc (Unbanged ty)
- = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
- returnRn (Unbanged new_ty, fvs)
+ = rnHsType doc ty `thenRn` \ new_ty ->
+ returnRn (Unbanged new_ty)
rnBangTy doc (Unpacked ty)
- = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
- returnRn (Unpacked new_ty, fvs)
+ = rnHsType doc ty `thenRn` \ new_ty ->
+ returnRn (Unpacked new_ty)
-- This data decl will parse OK
-- data T = a Int
%*********************************************************
\begin{code}
-rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
+rnHsTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
+rnHsTypeFVs doc_str ty
+ = rnHsType doc_str ty `thenRn` \ ty' ->
+ returnRn (ty', extractHsTyNames ty')
+
+rnHsSigTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
+rnHsSigTypeFVs doc_str ty
+ = rnHsSigType doc_str ty `thenRn` \ ty' ->
+ returnRn (ty', extractHsTyNames ty')
+
+rnHsSigType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
-- rnHsSigType is used for source-language type signatures,
-- which use *implicit* universal quantification.
rnHsSigType doc_str ty
= rnHsType (text "the type signature for" <+> doc_str) ty
---------------------------------------
-rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
+rnHsType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
rnHsType doc (HsForAllTy Nothing ctxt ty)
-- Implicit quantifiction in source code (no kinds on tyvars)
mentioned_in_tau = extractHsTyRdrTyVars ty
mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt)
- forall_tyvars = filter (not . (`elemFM` name_env)) mentioned
+ forall_tyvars = filter (not . (`elemRdrEnv` name_env)) mentioned
in
rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
rnHsType doc (HsTyVar tyvar)
= lookupOccRn tyvar `thenRn` \ tyvar' ->
- returnRn (HsTyVar tyvar', unitFV tyvar')
+ returnRn (HsTyVar tyvar')
rnHsType doc (HsOpTy ty1 opname ty2)
= lookupOccRn opname `thenRn` \ name' ->
- rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
- rnHsType doc ty2 `thenRn` \ (ty2',fvs2) ->
- returnRn (HsOpTy ty1' name' ty2', fvs1 `plusFV` fvs2 `addOneFV` name')
+ rnHsType doc ty1 `thenRn` \ ty1' ->
+ rnHsType doc ty2 `thenRn` \ ty2' ->
+ returnRn (HsOpTy ty1' name' ty2')
rnHsType doc (HsNumTy i)
- | i == 1 = returnRn (HsNumTy i, emptyFVs)
- | otherwise = failWithRn (HsNumTy i, emptyFVs)
+ | i == 1 = returnRn (HsNumTy i)
+ | otherwise = failWithRn (HsNumTy i)
(ptext SLIT("Only unit numeric type pattern is valid"))
rnHsType doc (HsFunTy ty1 ty2)
- = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
+ = rnHsType doc ty1 `thenRn` \ ty1' ->
-- Might find a for-all as the arg of a function type
- rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
+ rnHsType doc ty2 `thenRn` \ ty2' ->
-- Or as the result. This happens when reading Prelude.hi
-- when we find return :: forall m. Monad m -> forall a. a -> m a
- returnRn (HsFunTy ty1' ty2', fvs1 `plusFV` fvs2)
+ returnRn (HsFunTy ty1' ty2')
rnHsType doc (HsListTy ty)
- = rnHsType doc ty `thenRn` \ (ty', fvs) ->
- returnRn (HsListTy ty', fvs `addOneFV` listTyCon_name)
+ = rnHsType doc ty `thenRn` \ ty' ->
+ returnRn (HsListTy ty')
-- Unboxed tuples are allowed to have poly-typed arguments. These
-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
rnHsType doc (HsTupleTy (HsTupCon _ boxity) tys)
-- Don't do lookupOccRn, because this is built-in syntax
-- so it doesn't need to be in scope
- = mapFvRn (rnHsType doc) tys `thenRn` \ (tys', fvs) ->
- returnRn (HsTupleTy (HsTupCon n' boxity) tys', fvs `addOneFV` n')
+ = mapFvRn (rnHsType doc) tys `thenRn` \ tys' ->
+ returnRn (HsTupleTy (HsTupCon n' boxity) tys')
where
n' = tupleTyCon_name boxity (length tys)
rnHsType doc (HsAppTy ty1 ty2)
- = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
- rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
- returnRn (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2)
+ = rnHsType doc ty1 `thenRn` \ ty1' ->
+ rnHsType doc ty2 `thenRn` \ ty2' ->
+ returnRn (HsAppTy ty1' ty2')
rnHsType doc (HsPredTy pred)
- = rnPred doc pred `thenRn` \ (pred', fvs) ->
- returnRn (HsPredTy pred', fvs)
+ = rnPred doc pred `thenRn` \ pred' ->
+ returnRn (HsPredTy pred')
rnHsType doc (HsUsgForAllTy uv_rdr ty)
= bindUVarRn doc uv_rdr $ \ uv_name ->
- rnHsType doc ty `thenRn` \ (ty', fvs) ->
- returnRn (HsUsgForAllTy uv_name ty',
- fvs )
+ rnHsType doc ty `thenRn` \ ty' ->
+ returnRn (HsUsgForAllTy uv_name ty')
rnHsType doc (HsUsgTy usg ty)
- = newUsg usg `thenRn` \ (usg', usg_fvs) ->
- rnHsType doc ty `thenRn` \ (ty', ty_fvs) ->
+ = newUsg usg `thenRn` \ usg' ->
+ rnHsType doc ty `thenRn` \ ty' ->
-- A for-all can occur inside a usage annotation
- returnRn (HsUsgTy usg' ty',
- usg_fvs `plusFV` ty_fvs)
+ returnRn (HsUsgTy usg' ty')
where
newUsg usg = case usg of
- HsUsOnce -> returnRn (HsUsOnce, emptyFVs)
- HsUsMany -> returnRn (HsUsMany, emptyFVs)
+ HsUsOnce -> returnRn HsUsOnce
+ HsUsMany -> returnRn HsUsMany
HsUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
- returnRn (HsUsVar uv_name, emptyFVs)
+ returnRn (HsUsVar uv_name)
-rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
+rnHsTypes doc tys = mapRn (rnHsType doc) tys
\end{code}
\begin{code}
-- and we need the workers...
rnHsTupCon (HsTupCon n boxity)
= lookupOccRn n `thenRn` \ n' ->
- returnRn (HsTupCon n' boxity, unitFV n')
+ returnRn (HsTupCon n' boxity)
rnHsTupConWkr (HsTupCon n boxity)
-- Tuple construtors are for the *worker* of the tuple
-- Going direct saves needless messing about
= lookupOccRn (mkRdrNameWkr n) `thenRn` \ n' ->
- returnRn (HsTupCon n' boxity, unitFV n')
+ returnRn (HsTupCon n' boxity)
\end{code}
\begin{code}
rnForAll doc forall_tyvars ctxt ty
= bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars ->
- rnContext doc ctxt `thenRn` \ (new_ctxt, cxt_fvs) ->
- rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) ->
- returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty,
- cxt_fvs `plusFV` ty_fvs)
+ rnContext doc ctxt `thenRn` \ new_ctxt ->
+ rnHsType doc ty `thenRn` \ new_ty ->
+ returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty)
\end{code}
\begin{code}
-rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
+rnContext :: SDoc -> RdrNameContext -> RnMS RenamedContext
rnContext doc ctxt
- = mapAndUnzipRn rn_pred ctxt `thenRn` \ (theta, fvs_s) ->
+ = mapRn rn_pred ctxt `thenRn` \ theta ->
let
(_, dups) = removeDupsEq theta
-- We only have equality, not ordering
-- Check for duplicate assertions
-- If this isn't an error, then it ought to be:
mapRn (addWarnRn . dupClassAssertWarn theta) dups `thenRn_`
- returnRn (theta, plusFVs fvs_s)
+ returnRn theta
where
--Someone discovered that @CCallable@ and @CReturnable@
-- could be used in contexts such as:
-- foo :: CCallable a => a -> PrimIO Int
-- Doing this utterly wrecks the whole point of introducing these
-- classes so we specifically check that this isn't being done.
- rn_pred pred = rnPred doc pred `thenRn` \ (pred', fvs)->
+ rn_pred pred = rnPred doc pred `thenRn` \ pred'->
checkRn (not (bad_pred pred'))
(naughtyCCallContextErr pred') `thenRn_`
- returnRn (pred', fvs)
+ returnRn pred'
bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys
bad_pred other = False
rnPred doc (HsPClass clas tys)
= lookupOccRn clas `thenRn` \ clas_name ->
- rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
- returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
+ rnHsTypes doc tys `thenRn` \ tys' ->
+ returnRn (HsPClass clas_name tys')
rnPred doc (HsPIParam n ty)
= newIPName n `thenRn` \ name ->
- rnHsType doc ty `thenRn` \ (ty', fvs) ->
- returnRn (HsPIParam name ty', fvs)
+ rnHsType doc ty `thenRn` \ ty' ->
+ returnRn (HsPIParam name ty')
\end{code}
\begin{code}
%*********************************************************
\begin{code}
-rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
-
rnIdInfo (HsWorker worker)
= lookupOccRn worker `thenRn` \ worker' ->
- returnRn (HsWorker worker', unitFV worker')
-
-rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
- returnRn (HsUnfold inline expr', fvs)
-rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs)
-rnIdInfo HsNoCafRefs = returnRn (HsNoCafRefs, emptyFVs)
-rnIdInfo HsCprInfo = returnRn (HsCprInfo, emptyFVs)
-
+ returnRn (HsWorker worker')
+
+rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ expr' ->
+ returnRn (HsUnfold inline expr')
+rnIdInfo (HsStrictness str) = returnRn (HsStrictness str)
+rnIdInfo (HsArity arity) = returnRn (HsArity arity)
+rnIdInfo HsNoCafRefs = returnRn HsNoCafRefs
+rnIdInfo HsCprInfo = returnRn HsCprInfo
\end{code}
@UfCore@ expressions.
\begin{code}
rnCoreExpr (UfType ty)
- = rnHsType (text "unfolding type") ty `thenRn` \ (ty', fvs) ->
- returnRn (UfType ty', fvs)
+ = rnHsType (text "unfolding type") ty `thenRn` \ ty' ->
+ returnRn (UfType ty')
rnCoreExpr (UfVar v)
= lookupOccRn v `thenRn` \ v' ->
- returnRn (UfVar v', unitFV v')
+ returnRn (UfVar v')
rnCoreExpr (UfLit l)
- = returnRn (UfLit l, emptyFVs)
+ = returnRn (UfLit l)
rnCoreExpr (UfLitLit l ty)
- = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) ->
- returnRn (UfLitLit l ty', fvs)
+ = rnHsType (text "litlit") ty `thenRn` \ ty' ->
+ returnRn (UfLitLit l ty')
rnCoreExpr (UfCCall cc ty)
- = rnHsType (text "ccall") ty `thenRn` \ (ty', fvs) ->
- returnRn (UfCCall cc ty', fvs)
+ = rnHsType (text "ccall") ty `thenRn` \ ty' ->
+ returnRn (UfCCall cc ty')
rnCoreExpr (UfTuple con args)
- = rnHsTupConWkr con `thenRn` \ (con', fvs1) ->
- mapFvRn rnCoreExpr args `thenRn` \ (args', fvs2) ->
- returnRn (UfTuple con' args', fvs1 `plusFV` fvs2)
+ = rnHsTupConWkr con `thenRn` \ con' ->
+ mapRn rnCoreExpr args `thenRn` \ args' ->
+ returnRn (UfTuple con' args')
rnCoreExpr (UfApp fun arg)
- = rnCoreExpr fun `thenRn` \ (fun', fv1) ->
- rnCoreExpr arg `thenRn` \ (arg', fv2) ->
- returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
+ = rnCoreExpr fun `thenRn` \ fun' ->
+ rnCoreExpr arg `thenRn` \ arg' ->
+ returnRn (UfApp fun' arg')
rnCoreExpr (UfCase scrut bndr alts)
- = rnCoreExpr scrut `thenRn` \ (scrut', fvs1) ->
- bindCoreLocalFVRn bndr ( \ bndr' ->
- mapFvRn rnCoreAlt alts `thenRn` \ (alts', fvs2) ->
- returnRn (UfCase scrut' bndr' alts', fvs2)
- ) `thenRn` \ (case', fvs3) ->
- returnRn (case', fvs1 `plusFV` fvs3)
+ = rnCoreExpr scrut `thenRn` \ scrut' ->
+ bindCoreLocalFVRn bndr $ \ bndr' ->
+ mapRn rnCoreAlt alts `thenRn` \ alts' ->
+ returnRn (UfCase scrut' bndr' alts')
rnCoreExpr (UfNote note expr)
- = rnNote note `thenRn` \ (note', fvs1) ->
- rnCoreExpr expr `thenRn` \ (expr', fvs2) ->
- returnRn (UfNote note' expr', fvs1 `plusFV` fvs2)
+ = rnNote note `thenRn` \ note' ->
+ rnCoreExpr expr `thenRn` \ expr' ->
+ returnRn (UfNote note' expr')
rnCoreExpr (UfLam bndr body)
= rnCoreBndr bndr $ \ bndr' ->
- rnCoreExpr body `thenRn` \ (body', fvs) ->
- returnRn (UfLam bndr' body', fvs)
+ rnCoreExpr body `thenRn` \ body' ->
+ returnRn (UfLam bndr' body')
rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
- = rnCoreExpr rhs `thenRn` \ (rhs', fvs1) ->
- rnCoreBndr bndr ( \ bndr' ->
- rnCoreExpr body `thenRn` \ (body', fvs2) ->
- returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
- ) `thenRn` \ (result, fvs3) ->
- returnRn (result, fvs1 `plusFV` fvs3)
+ = rnCoreExpr rhs `thenRn` \ rhs' ->
+ rnCoreBndr bndr $ \ bndr' ->
+ rnCoreExpr body `thenRn` \ body' ->
+ returnRn (UfLet (UfNonRec bndr' rhs') body')
rnCoreExpr (UfLet (UfRec pairs) body)
= rnCoreBndrs bndrs $ \ bndrs' ->
- mapFvRn rnCoreExpr rhss `thenRn` \ (rhss', fvs1) ->
- rnCoreExpr body `thenRn` \ (body', fvs2) ->
- returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
+ mapRn rnCoreExpr rhss `thenRn` \ rhss' ->
+ rnCoreExpr body `thenRn` \ body' ->
+ returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
where
(bndrs, rhss) = unzip pairs
\end{code}
\begin{code}
rnCoreBndr (UfValBinder name ty) thing_inside
- = rnHsType doc ty `thenRn` \ (ty', fvs1) ->
+ = rnHsType doc ty `thenRn` \ ty' ->
bindCoreLocalFVRn name ( \ name' ->
thing_inside (UfValBinder name' ty')
) `thenRn` \ (result, fvs2) ->
doc = text "unfolding id"
rnCoreBndr (UfTyBinder name kind) thing_inside
- = bindCoreLocalFVRn name $ \ name' ->
+ = bindCoreLocalRn name $ \ name' ->
thing_inside (UfTyBinder name' kind)
rnCoreBndrs [] thing_inside = thing_inside []
\begin{code}
rnCoreAlt (con, bndrs, rhs)
- = rnUfCon con bndrs `thenRn` \ (con', fvs1) ->
- bindCoreLocalsFVRn bndrs ( \ bndrs' ->
- rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
- returnRn ((con', bndrs', rhs'), fvs2)
- ) `thenRn` \ (result, fvs3) ->
- returnRn (result, fvs1 `plusFV` fvs3)
+ = rnUfCon con bndrs `thenRn` \ con' ->
+ bindCoreLocalsRn bndrs $ \ bndrs' ->
+ rnCoreExpr rhs `thenRn` \ rhs' ->
+ returnRn (con', bndrs', rhs')
rnNote (UfCoerce ty)
- = rnHsType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) ->
- returnRn (UfCoerce ty', fvs)
+ = rnHsType (text "unfolding coerce") ty `thenRn` \ ty' ->
+ returnRn (UfCoerce ty')
-rnNote (UfSCC cc) = returnRn (UfSCC cc, emptyFVs)
-rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
-rnNote UfInlineMe = returnRn (UfInlineMe, emptyFVs)
+rnNote (UfSCC cc) = returnRn (UfSCC cc)
+rnNote UfInlineCall = returnRn UfInlineCall
+rnNote UfInlineMe = returnRn UfInlineMe
rnUfCon UfDefault _
- = returnRn (UfDefault, emptyFVs)
+ = returnRn UfDefault
rnUfCon (UfTupleAlt tup_con) bndrs
- = rnHsTupCon tup_con `thenRn` \ (HsTupCon con' _, fvs) ->
- returnRn (UfDataAlt con', fvs)
+ = rnHsTupCon tup_con `thenRn` \ (HsTupCon con' _) ->
+ returnRn (UfDataAlt con')
-- Makes the type checker a little easier
rnUfCon (UfDataAlt con) _
= lookupOccRn con `thenRn` \ con' ->
- returnRn (UfDataAlt con', unitFV con')
+ returnRn (UfDataAlt con')
rnUfCon (UfLitAlt lit) _
- = returnRn (UfLitAlt lit, emptyFVs)
+ = returnRn (UfLitAlt lit)
rnUfCon (UfLitLitAlt lit ty) _
- = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) ->
- returnRn (UfLitLitAlt lit ty', fvs)
+ = rnHsType (text "litlit") ty `thenRn` \ ty' ->
+ returnRn (UfLitLitAlt lit ty')
\end{code}
%*********************************************************
derivingNonStdClassErr clas
= hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
-classTyVarNotInOpTyErr clas_tyvar sig
- = hang (hsep [ptext SLIT("Class type variable"),
- quotes (ppr clas_tyvar),
- ptext SLIT("does not appear in method signature")])
- 4 (ppr sig)
-
badDataCon name
= hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
-> [CoreBind] -- Input
-> IO (SimplCount, [CoreBind], Maybe RuleBase) -- New bindings
-simplifyPgm dflags (imported_rule_ids, rule_lhs_fvs)
+simplifyPgm dflags (RuleBase imported_rule_ids rule_lhs_fvs)
sw_chkr us binds
= do {
beginPass dflags "Simplify";
%************************************************************************
\begin{code}
-addRule :: Id -> CoreRules -> CoreRule -> CoreRules
+addRule :: CoreRules -> Id -> CoreRule -> CoreRules
-- Insert the new rule just before a rule that is *less specific*
-- than the new one; or at the end if there isn't such a one.
-- We make no check for rules that unify without one dominating
-- the other. Arguably this would be a bug.
-addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _)
+addRule (Rules rules rhs_fvs) id rule@(BuiltinRule _)
= Rules (rule:rules) rhs_fvs
-- Put it at the start for lack of anything better
-addRule id (Rules rules rhs_fvs) rule
+addRule (Rules rules rhs_fvs) id rule
= Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs)
where
new_rule = occurAnalyseRule rule
where
rule_name = _PK_ ("SPEC " ++ showSDoc (ppr id))
new_rules = foldr add (idSpecialisation id) spec_stuff
- add (vars, args, rhs) rules = addRule id rules (Rule rule_name vars args rhs)
+ add (vars, args, rhs) rules = addRule rules id (Rule rule_name vars args rhs)
\end{code}
%************************************************************************
\begin{code}
-data RuleBase = RuleBase (IdEnv CoreRules) -- Maps an Id to its rules
- IdSet -- Ids (whether local or imported) mentioned on
- -- LHS of some rule; these should be black listed
+data RuleBase = RuleBase
+ IdSet -- Ids with their rules in their specialisations
+ -- Held as a set, so that it can simply be the initial
+ -- in-scope set in the simplifier
-emptyRuleBase = RuleBase emptyVarEnv emptyVarSet
+ IdSet -- Ids (whether local or imported) mentioned on
+ -- LHS of some rule; these should be black listed
-extendRuleBaseList :: RuleBase -> [(Name,CoreRule)] -> RuleBase
+emptyRuleBase = RuleBase emptyVarSet emptyVarSet
+
+extendRuleBaseList :: RuleBase -> [(Id,CoreRule)] -> RuleBase
extendRuleBaseList rule_base new_guys
- = foldr extendRuleBase rule_base new_guys
+ = foldl extendRuleBase rule_base new_guys
-extendRuleBase :: RuleBase -> (Name,CoreRule) -> RuleBase
-extendRuleBase (RuleBase rule_env rule_fvs) (id, rule)
- = RuleBase (extendVarEnv rule_env id (addRule id rules_for_id rule))
+extendRuleBase :: RuleBase -> (Id,CoreRule) -> RuleBase
+extendRuleBase (RuleBase rule_ids rule_fvs) (id, rule)
+ = RuleBase (extendVarSet rule_ids new_id)
(rule_fvs `unionVarSet` extendVarSet lhs_fvs id)
where
- rules_for_id = case lookupWithDefaultVarEnv rule_env emptyCoreRules id
-
+ new_id = setIdSpecialisation id (addRule old_rules id rule)
+ old_rules = case lookupVarSet rule_ids id of
+ Nothing -> emptyCoreRules
+ Just id' -> idSpecialisation id'
+
lhs_fvs = ruleSomeLhsFreeVars isId rule
-- Find *all* the free Ids of the LHS, not just
-- locally defined ones!!
-unionRuleBase (rule_ids1, black_ids1) (rule_ids2, black_ids2)
- = (plusUFM_C merge_rules rule_ids1 rule_ids2,
- unionVarSet black_ids1 black_ids2)
+unionRuleBase (RuleBase rule_ids1 black_ids1) (RuleBase rule_ids2 black_ids2)
+ = RuleBase (plusUFM_C merge_rules rule_ids1 rule_ids2)
+ (unionVarSet black_ids1 black_ids2)
where
- merge_rules id1 id2 = let rules1 = idSpecialisation id1
- rules2 = idSpecialisation id2
- new_rules = foldl (addRule id1) rules1 (rulesRules rules2)
- in
- setIdSpecialisation id1 new_rules
+
+merge_rules id1 id2 = let rules1 = idSpecialisation id1
+ rules2 = idSpecialisation id2
+ new_rules = foldl (addRule id1) rules1 (rulesRules rules2)
+ in
+ setIdSpecialisation id1 new_rules
pprRuleBase :: RuleBase -> SDoc
-pprRuleBase (rules,_) = vcat [ pprCoreRule (ppr id) rs
- | id <- varSetElems rules,
- rs <- rulesRules $ idSpecialisation id ]
+pprRuleBase (RuleBase rules _) = vcat [ pprCoreRule (ppr id) rs
+ | id <- varSetElems rules,
+ rs <- rulesRules $ idSpecialisation id ]
-- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
-- It attaches those rules that are for local Ids to their binders, and
-- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined
-- so that the opportunity to apply the rule isn't lost too soon
-prepareLocalRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase)
+prepareLocalRuleBase :: [CoreBind] -> [(Id,CoreRule)] -> ([CoreBind], RuleBase)
prepareLocalRuleBase binds local_rules
- = (map zap_bind binds, (imported_id_rule_ids, rule_lhs_fvs))
+ = error "urk"
+{-
+ = (map zap_bind binds, RuleBase imported_id_rule_ids rule_lhs_fvs)
where
- (rule_ids, rule_lhs_fvs) = foldr add_rule emptyRuleBase local_rules
+ RuleBase rule_ids rule_lhs_fvs = extendRuleBaseList emptyRuleBase local_rules
imported_id_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids
-- rule_fvs is the set of all variables mentioned in this module's rules
Just bndr' -> setIdNoDiscard bndr'
Nothing | bndr `elemVarSet` rule_fvs -> setIdNoDiscard bndr
| otherwise -> bndr
+-}
-addRuleToId id rule = setIdSpecialisation id (addRule id (idSpecialisation id) rule)
+addRuleToId id rule = setIdSpecialisation id (addRule (idSpecialisation id) id rule)
-- prepareOrphanRuleBase does exactly the same as prepareLocalRuleBase, except that
-- it assumes that none of the rules can be attached to local Ids.
prepareOrphanRuleBase :: [ProtoCoreRule] -> RuleBase
prepareOrphanRuleBase imported_rules
- = foldr add_rule (emptyVarSet, emptyVarSet) imported_rules
+ = error "urk"
+{-
+ = foldr add_rule emptyRuleBase imported_rules
+-}
\end{code}
tcExtendLocalValEnv, tcExtendTyVarEnv, newDefaultMethodName
)
import TcBinds ( tcBindWithSigs, tcSpecSigs )
-import TcMonoType ( tcHsSigType, tcClassContext, checkSigTyVars, sigCtxt, mkTcSig )
+import TcMonoType ( tcHsSigType, tcClassContext, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig )
import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcSigTyVars )
import TcMonad
-- LOOK THINGS UP IN THE ENVIRONMENT
tcLookupClass class_name `thenTc` \ clas ->
let
- tyvars = classTyVars clas
+ (tyvars, fds) = classTvsFds clas
op_sigs = filter isClassOpSig class_sigs
op_names = [n | ClassOpSig n _ _ _ <- op_sigs]
(_, datacon_name, datacon_wkr_name, sc_sel_names) = getClassDeclSysNames sys_names
tcSuperClasses clas context sc_sel_names `thenTc` \ (sc_theta, sc_sel_ids) ->
-- CHECK THE CLASS SIGNATURES,
- mapTc (tcClassSig rec_env clas tyvars dm_info) op_sigs `thenTc` \ sig_stuff ->
+ mapTc (tcClassSig rec_env tyvar_names clas tyvars fds dm_info)
+ op_sigs `thenTc` \ sig_stuff ->
-- MAKE THE CLASS DETAILS
let
tcClassSig :: TcEnv -- Knot tying only!
+ -> [HsTyVarBndr Name] -- From the declaration, for error messages
-> Class -- ...ditto...
-> [TyVar] -- The class type variable, used for error check only
+ -> [FunDep TyVar]
-> NameEnv (DefMeth Name) -- Info about default methods
-> RenamedClassOpSig
-> TcM (Type, -- Type of the method
-- so we distinguish them in checkDefaultBinds, and pass this knowledge in the
-- Class.DefMeth data structure.
-tcClassSig rec_env clas clas_tyvars dm_info
+tcClassSig rec_env tyvar_names clas clas_tyvars fds dm_info
(ClassOpSig op_name maybe_dm op_ty src_loc)
= tcAddSrcLoc src_loc $
-- Check the type signature. NB that the envt *already has*
-- bindings for the type variables; see comments in TcTyAndClassDcls.
- -- NB: Renamer checks that the class type variable is mentioned in local_ty,
- -- and that it is not constrained by theta
tcHsSigType op_ty `thenTc` \ local_ty ->
let
- global_ty = mkSigmaTy clas_tyvars
- [mkClassPred clas (mkTyVarTys clas_tyvars)]
- local_ty
+ theta = [mkClassPred clas (mkTyVarTys clas_tyvars)]
+ global_ty = mkSigmaTy clas_tyvars theta local_ty
-- Build the selector id and default method id
sel_id = mkDictSelId op_name clas
DefMeth dm_name -> DefMeth (tcAddImportedIdInfo rec_env dm_id)
where
dm_id = mkDefaultMethodId dm_name clas global_ty
+
+ full_hs_ty = HsForAllTy (Just tyvar_names) op_ty
in
+ -- Check for ambiguous class op types
+ checkAmbiguity full_ty clas_tyvars theta local_ty `thenRn_`
+
-- Check that for a generic method, the type of
-- the method is sufficiently simple
checkTc (dm_info_name /= GenDefMeth || validGenericMethodType local_ty)
\begin{code}
module TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType,
- tcContext, tcClassContext,
+ tcContext, tcClassContext, checkAmbiguity,
-- Kind checking
kcHsTyVar, kcHsTyVars, mkTyClTyVars,
checkAmbiguity full_ty tyvars theta tau `thenTc_`
returnTc (mkSigmaTy tyvars theta tau)
+checkAmbiguity :: RenamedHsType -> [TyVar] -> ThetaType -> Type -> TcM ()
-- Check for ambiguity
-- forall V. P => tau
-- is ambiguous if P contains generic variables
-- This is the is_free test below.
checkAmbiguity full_ty forall_tyvars theta tau
- = mapTc check_pred theta
+ = mapTc_ check_pred theta
where
tau_vars = tyVarsOfType tau
fds = instFunDepsOfTheta theta
#include "HsVersions.h"
-import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..) )
+import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..), isIfaceRuleDecl )
import CoreSyn ( CoreRule(..) )
import RnHsSyn ( RenamedHsDecl, RenamedRuleDecl )
import HscTypes ( PackageRuleEnv )
plusLIEs lies, new_local_rules)
where
rule_decls = [rule | RuleD rule <- decls]
- (imported_rules, local_rules) = partition is_iface_rule rule_decls
-
- is_iface_rule (IfaceRule _ _ _ _ _ _) = True
- is_iface_rule other = False
+ (imported_rules, local_rules) = partition isIfaceRuleDecl rule_decls
tcIfaceRule :: RenamedRuleDecl -> TcM (Id, CoreRule)
-- No zonking necessary!
import Type ( Type, isUnLiftedType, applyTys, tyVarsOfType, tyVarsOfTypes,
mkTyVarTys, mkForAllTys, mkTyConApp, splitFunTys,
- mkFunTy, funResultTy, isTyVarTy, splitForAllTys,
+ mkFunTy, isTyVarTy,
splitSigmaTy, getTyVar, splitTyConApp_maybe, funTyCon
)
)
import Name ( Name, mkSysLocalName )
import CoreSyn ( mkLams, Expr(..), CoreExpr, AltCon(..), Note(..),
- mkConApp, Alt, Bind (..), mkTyApps, mkVarApps )
-import BasicTypes ( RecFlag(..), EP(..), Boxity(..) )
+ mkConApp, Alt, mkTyApps, mkVarApps )
+import BasicTypes ( EP(..), Boxity(..) )
import Var ( TyVar )
import VarSet ( isEmptyVarSet )
-import Id ( Id, mkTemplateLocal, mkTemplateLocals, idType, idName,
- mkTemplateLocalsNum, mkVanillaId, mkId
+import Id ( Id, mkTemplateLocal, idType, idName,
+ mkTemplateLocalsNum, mkId
)
import TysWiredIn ( genericTyCons,
genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
import IdInfo ( vanillaIdInfo, setUnfoldingInfo )
import CoreUnfold ( mkTopUnfolding )
-import Unique ( Uniquable(..), mkBuiltinUnique )
+import Unique ( mkBuiltinUnique )
import SrcLoc ( builtinSrcLoc )
-import Maybes ( maybeToBool, expectJust )
+import Maybes ( expectJust )
import Outputable
#include "HsVersions.h"
projects / ghc-hetmet.git / commitdiff