import HsSyn
import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
-import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
+import RdrHsSyn ( extractHsRhoRdrTyVars )
import RnHsSyn
import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields )
import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
makeMiniFixityEnv)
import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn,
lookupTopBndrRn, lookupLocatedTopBndrRn,
- lookupOccRn, newLocalBndrsRn, bindLocalNamesFV,
+ lookupOccRn, bindLocalNamesFV,
bindLocatedLocalsFV, bindPatSigTyVarsFV,
bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn,
bindLocalNames, checkDupRdrNames, mapFvRn
import HscTypes ( HscEnv, hsc_dflags )
import BasicTypes ( Boxity(..) )
import ListSetOps ( findDupsEq )
-
+import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
import Control.Monad
+import Maybes( orElse )
import Data.Maybe
\end{code}
hs_fords = foreign_decls,
hs_defds = default_decls,
hs_ruleds = rule_decls,
+ hs_vects = vect_decls,
hs_docs = docs })
= do {
-- (A) Process the fixity declarations, creating a mapping from
-- means we'll only report a declaration as unused if it isn't
-- mentioned at all. Ah well.
traceRn (text "Start rnTyClDecls") ;
- (rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ;
+ (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
-- (F) Rename Value declarations right-hand sides
traceRn (text "Start rnmono") ;
- (rn_val_decls, bind_dus) <- rnTopBindsRHS val_bndr_set new_lhs ;
+ (rn_val_decls, bind_dus) <- rnTopBindsRHS new_lhs ;
traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
-- (G) Rename Fixity and deprecations
(rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ;
(rn_rule_decls, src_fvs3) <- setOptM Opt_ScopedTypeVariables $
- rnList rnHsRuleDecl rule_decls ;
- -- Inside RULES, scoped type variables are on
- (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
- (rn_ann_decls, src_fvs5) <- rnList rnAnnDecl ann_decls ;
- (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl default_decls ;
- (rn_deriv_decls, src_fvs7) <- rnList rnSrcDerivDecl deriv_decls ;
+ rnList rnHsRuleDecl rule_decls ;
+ -- Inside RULES, scoped type variables are on
+ (rn_vect_decls, src_fvs4) <- rnList rnHsVectDecl vect_decls ;
+ (rn_foreign_decls, src_fvs5) <- rnList rnHsForeignDecl foreign_decls ;
+ (rn_ann_decls, src_fvs6) <- rnList rnAnnDecl ann_decls ;
+ (rn_default_decls, src_fvs7) <- rnList rnDefaultDecl default_decls ;
+ (rn_deriv_decls, src_fvs8) <- rnList rnSrcDerivDecl deriv_decls ;
-- Haddock docs; no free vars
rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
hs_annds = rn_ann_decls,
hs_defds = rn_default_decls,
hs_ruleds = rn_rule_decls,
+ hs_vects = rn_vect_decls,
hs_docs = rn_docs } ;
tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ;
ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ;
other_def = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ;
other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
- src_fvs5, src_fvs6, src_fvs7] ;
+ src_fvs5, src_fvs6, src_fvs7, src_fvs8] ;
-- It is tiresome to gather the binders from type and class decls
src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
inNewEnv env cont = do e <- env
setGblEnv e $ cont e
-rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
--- Used for external core
-rnTyClDecls tycl_decls = do (decls', _fvs) <- rnList rnTyClDecl tycl_decls
- return decls'
-
addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
-- This function could be defined lower down in the module hierarchy,
-- but there doesn't seem anywhere very logical to put it.
rnSrcWarnDecls bound_names decls
= do { -- check for duplicates
- ; mapM_ (\ (L loc rdr:lrdr':_) -> addErrAt loc (dupWarnDecl lrdr' rdr))
+ ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups
+ in addErrAt loc (dupWarnDecl lrdr' rdr))
warn_rdr_dups
; pairs_s <- mapM (addLocM rn_deprec) decls
; return (WarnSome ((concat pairs_s))) }
-- The typechecker (not the renamer) checks that all
-- the bindings are for the right class
let
- meth_names = collectMethodBinders mbinds
(inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
in
- checkDupRdrNames meth_names `thenM_`
- -- Check that the same method is not given twice in the
- -- same instance decl instance C T where
- -- f x = ...
- -- g y = ...
- -- f x = ...
- -- We must use checkDupRdrNames because the Name of the
- -- method is the Name of the class selector, whose SrcSpan
- -- points to the class declaration
-
extendTyVarEnvForMethodBinds inst_tyvars (
-- (Slightly strangely) the forall-d tyvars scope over
-- the method bindings too
rnMethodBinds cls (\_ -> []) -- No scoped tyvars
- [] mbinds
+ mbinds
) `thenM` \ (mbinds', meth_fvs) ->
-- Rename the associated types
-- The typechecker (not the renamer) checks that all
%*********************************************************
+%* *
+\subsection{Vectorisation declarations}
+%* *
+%*********************************************************
+
+\begin{code}
+rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars)
+rnHsVectDecl (HsVect var Nothing)
+ = do { var' <- wrapLocM lookupTopBndrRn var
+ ; return (HsVect var' Nothing, unitFV (unLoc var'))
+ }
+rnHsVectDecl (HsVect var (Just rhs))
+ = do { var' <- wrapLocM lookupTopBndrRn var
+ ; (rhs', fv_rhs) <- rnLExpr rhs
+ ; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var')
+ }
+\end{code}
+
+%*********************************************************
%* *
\subsection{Type, class and iface sig declarations}
%* *
However, we can also do some scoping checks at the same time.
\begin{code}
+rnTyClDecls :: [[LTyClDecl RdrName]] -> RnM ([[LTyClDecl Name]], FreeVars)
+-- Renamed the declarations and do depedency analysis on them
+rnTyClDecls tycl_ds
+ = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (concat tycl_ds)
+
+ ; let sccs :: [SCC (LTyClDecl Name)]
+ sccs = depAnalTyClDecls ds_w_fvs
+
+ all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs
+
+ ; return (map flattenSCC sccs, all_fvs) }
+
rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
= lookupLocatedTopBndrRn name `thenM` \ name' ->
-- we want to name both "x" tyvars with the same unique, so that they are
-- easy to group together in the typechecker.
; (mbinds', meth_fvs)
- <- extendTyVarEnvForMethodBinds tyvars' $ do
- { name_env <- getLocalRdrEnv
- ; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
- not (unLoc tv `elemLocalRdrEnv` name_env) ]
+ <- extendTyVarEnvForMethodBinds tyvars' $
-- No need to check for duplicate method signatures
-- since that is done by RnNames.extendGlobalRdrEnvRn
-- and the methods are already in scope
- ; gen_tyvars <- newLocalBndrsRn gen_rdr_tyvars_w_locs
- ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
+ rnMethodBinds (unLoc cname') (mkSigTvFn sigs') mbinds
-- Haddock docs
; docs' <- mapM (wrapLocM rnDocDecl) docs
are no data constructors we allow h98_style = True
+\begin{code}
+depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)]
+-- See Note [Dependency analysis of type and class decls]
+depAnalTyClDecls ds_w_fvs
+ = stronglyConnCompFromEdgedVertices edges
+ where
+ edges = [ (d, tcdName (unLoc d), map get_assoc (nameSetToList fvs))
+ | (d, fvs) <- ds_w_fvs ]
+ get_assoc n = lookupNameEnv assoc_env n `orElse` n
+ assoc_env = mkNameEnv [ (tcdName assoc_decl, cls_name)
+ | (L _ (ClassDecl { tcdLName = L _ cls_name
+ , tcdATs = ats }) ,_) <- ds_w_fvs
+ , L _ assoc_decl <- ats ]
+\end{code}
+
+Note [Dependency analysis of type and class decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to do dependency analysis on type and class declarations
+else we get bad error messages. Consider
+
+ data T f a = MkT f a
+ data S f a = MkS f (T f a)
+
+This has a kind error, but the error message is better if you
+check T first, (fixing its kind) and *then* S. If you do kind
+inference together, you might get an error reported in S, which
+is jolly confusing. See Trac #4875
+
+
%*********************************************************
%* *
\subsection{Support code for type/data declarations}
Get the mapping from constructors to fields for this module.
It's convenient to do this after the data type decls have been renamed
\begin{code}
-extendRecordFieldEnv :: [LTyClDecl RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv
+extendRecordFieldEnv :: [[LTyClDecl RdrName]] -> [LInstDecl RdrName] -> TcM TcGblEnv
extendRecordFieldEnv tycl_decls inst_decls
= do { tcg_env <- getGblEnv
; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
all_data_cons :: [ConDecl RdrName]
all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls
, L _ con <- cons ]
- all_tycl_decls = at_tycl_decls ++ tycl_decls
+ all_tycl_decls = at_tycl_decls ++ concat tycl_decls
at_tycl_decls = instDeclATs inst_decls -- Do not forget associated types!
get_con (ConDecl { con_name = con, con_details = RecCon flds })
add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
| isClassDecl d
= let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
- addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
+ addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
| otherwise
- = addl (gp { hs_tyclds = L l d : ts }) ds
+ = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
-- Signatures: fixity sigs go a different place than all others
add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
= addl (gp { hs_annds = L l d : ts }) ds
add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
= addl (gp { hs_ruleds = L l d : ts }) ds
+add gp@(HsGroup {hs_vects = ts}) l (VectD d) ds
+ = addl (gp { hs_vects = L l d : ts }) ds
add gp l (DocD d) ds
= addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
+add_tycld :: LTyClDecl a -> [[LTyClDecl a]] -> [[LTyClDecl a]]
+add_tycld d [] = [[d]]
+add_tycld d (ds:dss) = (d:ds) : dss
+
add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
add_sig :: LSig a -> HsValBinds a -> HsValBinds a
add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
-\end{code}
\ No newline at end of file
+\end{code}
projects / ghc-hetmet.git / blobdiff