\begin{code}
module RnSource (
rnSrcDecls, addTcgDUs,
- rnTyClDecls, checkModDeprec,
+ rnTyClDecls,
rnSplice, checkTH
) where
import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn )
import RnEnv ( lookupLocalDataTcNames,
lookupLocatedTopBndrRn, lookupLocatedOccRn,
- lookupOccRn, lookupTopBndrRn, newLocalsRn,
+ lookupOccRn, newLocalsRn,
bindLocatedLocalsFV, bindPatSigTyVarsFV,
bindTyVarsRn, extendTyVarEnvFVRn,
bindLocalNames, checkDupNames, mapFvRn
import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcRnMonad
-import HscTypes ( FixityEnv, FixItem(..),
- Deprecations, Deprecs(..), DeprecTxt, plusDeprecs )
+import HscTypes ( FixityEnv, FixItem(..), Deprecations, Deprecs(..), plusDeprecs )
import Class ( FunDep )
import Name ( Name, nameOccName )
import NameSet
import SrcLoc ( Located(..), unLoc, noLoc )
import DynFlags ( DynFlag(..) )
import Maybes ( seqMaybe )
-import Maybe ( isNothing, isJust )
+import Maybe ( isNothing )
import Monad ( liftM, when )
import BasicTypes ( Boxity(..) )
\end{code}
hs_fords = foreign_decls,
hs_defds = default_decls,
hs_ruleds = rule_decls,
- hs_docs = docs })
+ hs_docs = docs })
= do { -- Deal with deprecations (returns only the extra deprecations)
deprecs <- rnSrcDeprecDecls deprec_decls ;
-- So we content ourselves with gathering uses only; that
-- means we'll only report a declaration as unused if it isn't
-- mentioned at all. Ah well.
- (rn_tycl_decls, src_fvs1)
- <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ;
- (rn_inst_decls, src_fvs2)
- <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ;
- (rn_deriv_decls, src_fvs_deriv)
- <- mapFvRn (wrapLocFstM rnSrcDerivDecl) deriv_decls ;
- (rn_rule_decls, src_fvs3)
- <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ;
- (rn_foreign_decls, src_fvs4)
- <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ;
- (rn_default_decls, src_fvs5)
- <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
-
- rn_docs <- mapM rnDocEntity docs ;
+ traceRn (text "Start rnTyClDecls") ;
+ (rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ;
+ (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ;
+ (rn_rule_decls, src_fvs3) <- rnList rnHsRuleDecl rule_decls ;
+ (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
+ (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ;
+ (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ;
+
+ -- Haddock docs; no free vars
+ rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
let {
rn_group = HsGroup { hs_valds = rn_val_decls,
hs_fords = rn_foreign_decls,
hs_defds = rn_default_decls,
hs_ruleds = rn_rule_decls,
- hs_docs = rn_docs } ;
+ hs_docs = rn_docs } ;
- other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs_deriv, src_fvs3,
+ other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs6, src_fvs3,
src_fvs4, src_fvs5] ;
src_dus = bind_dus `plusDU` usesOnly other_fvs
-- Note: src_dus will contain *uses* for locally-defined types
return (tcg_env `addTcgDUs` src_dus, rn_group)
}}}
-rnDocEntity :: DocEntity RdrName -> RnM (DocEntity Name)
-rnDocEntity (DocEntity docdecl) = do
- rn_docdecl <- rnDocDecl docdecl
- return (DocEntity rn_docdecl)
-rnDocEntity (DeclEntity name) = do
- rn_name <- lookupTopBndrRn name
- return (DeclEntity rn_name)
+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
+addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
+
+rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
+rnList f xs = mapFvRn (wrapLocFstM f) xs
+\end{code}
+
+%*********************************************************
+%* *
+ HsDoc stuff
+%* *
+%*********************************************************
+
+\begin{code}
rnDocDecl :: DocDecl RdrName -> RnM (DocDecl Name)
rnDocDecl (DocCommentNext doc) = do
rn_doc <- rnHsDoc doc
rnDocDecl (DocGroup lev doc) = do
rn_doc <- rnHsDoc doc
return (DocGroup lev rn_doc)
-
-rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
-rnTyClDecls tycl_decls = do
- (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls
- return decls'
-
-addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
-addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
\end{code}
rn_deprec (Deprecation rdr_name txt)
= lookupLocalDataTcNames rdr_name `thenM` \ names ->
returnM [(name, (nameOccName name, txt)) | name <- names]
-
-checkModDeprec :: Maybe DeprecTxt -> Deprecations
--- Check for a module deprecation; done once at top level
-checkModDeprec Nothing = NoDeprecs
-checkModDeprec (Just txt) = DeprecAll txt
\end{code}
%*********************************************************
Renaming of the associated types in instances.
-* We raise an error if we encounter a kind signature in an instance.
-
\begin{code}
rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
-rnATInsts atDecls =
- mapFvRn (wrapLocFstM rnATInst) atDecls
+rnATInsts atDecls = rnList rnATInst atDecls
where
- rnATInst tydecl@TyFunction {} =
- do
- addErr noKindSig
- rnTyClDecl tydecl
+ rnATInst tydecl@TyData {} = rnTyClDecl tydecl
rnATInst tydecl@TySynonym {} = rnTyClDecl tydecl
- rnATInst tydecl@TyData {} =
- do
- checkM (not . isKindSigDecl $ tydecl) $ addErr noKindSig
- rnTyClDecl tydecl
- rnATInst _ =
- panic "RnSource.rnATInsts: not a type declaration"
-
-noKindSig = text "Instances cannot have kind signatures"
+ rnATInst tydecl =
+ pprPanic "RnSource.rnATInsts: invalid AT instance"
+ (ppr (tcdName tydecl))
\end{code}
For the method bindings in class and instance decls, we extend the
\begin{code}
rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
-rnSrcDerivDecl (DerivDecl ty n)
+rnSrcDerivDecl (DerivDecl ty)
= do ty' <- rnLHsType (text "a deriving decl") ty
- n' <- lookupLocatedOccRn n
- let fvs = extractHsTyNames ty' `addOneFV` unLoc n'
- return (DerivDecl ty' n', fvs)
+ let fvs = extractHsTyNames ty'
+ return (DerivDecl ty', fvs)
\end{code}
%*********************************************************
returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
emptyFVs)
+-- all flavours of type family declarations ("type family", "newtype fanily",
+-- and "data family")
+rnTyClDecl (tydecl@TyFamily {}) =
+ rnFamily tydecl bindTyVarsRn
+
+-- "data", "newtype", "data instance, and "newtype instance" declarations
rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
tcdLName = tycon, tcdTyVars = tyvars,
tcdTyPats = typatsMaybe, tcdCons = condecls,
tcdKindSig = sig, tcdDerivs = derivs})
- | isKindSigDecl tydecl -- kind signature of indexed type
- = rnTySig tydecl bindTyVarsRn
| is_vanilla -- Normal Haskell data type decl
= ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the
-- data type is syntactically illegal
bindTyVarsRn data_doc tyvars $ \ tyvars' ->
- do { tycon' <- if isIdxTyDecl tydecl
+ do { tycon' <- if isFamInstDecl tydecl
then lookupLocatedOccRn tycon -- may be imported family
else lookupLocatedTopBndrRn tycon
; context' <- rnContext data_doc context
extractHsCtxtTyNames context' `plusFV`
plusFVs (map conDeclFVs condecls') `plusFV`
deriv_fvs `plusFV`
- (if isIdxTyDecl tydecl
+ (if isFamInstDecl tydecl
then unitFV (unLoc tycon') -- type instance => use
else emptyFVs))
}
| otherwise -- GADT
= ASSERT( none typatsMaybe ) -- GADTs cannot have type patterns for now
- do { tycon' <- if isIdxTyDecl tydecl
+ do { tycon' <- if isFamInstDecl tydecl
then lookupLocatedOccRn tycon -- may be imported family
else lookupLocatedTopBndrRn tycon
; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
tcdCons = condecls', tcdDerivs = derivs'},
plusFVs (map conDeclFVs condecls') `plusFV`
deriv_fvs `plusFV`
- (if isIdxTyDecl tydecl
+ (if isFamInstDecl tydecl
then unitFV (unLoc tycon') -- type instance => use
else emptyFVs))
}
rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' ->
returnM (Just ds', extractHsTyNames_s ds')
-rnTyClDecl (tydecl@TyFunction {}) =
- rnTySig tydecl bindTyVarsRn
-
+-- "type" and "type instance" declarations
rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
tcdTyPats = typatsMaybe, tcdSynRhs = ty})
= bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
- do { name' <- if isIdxTyDecl tydecl
+ do { name' <- if isFamInstDecl tydecl
then lookupLocatedOccRn name -- may be imported family
else lookupLocatedTopBndrRn name
; typats' <- rnTyPats syn_doc typatsMaybe
tcdTyPats = typats', tcdSynRhs = ty'},
delFVs (map hsLTyVarName tyvars') $
fvs `plusFV`
- (if isIdxTyDecl tydecl
+ (if isFamInstDecl tydecl
then unitFV (unLoc name') -- type instance => use
else emptyFVs))
}
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
- = lookupLocatedTopBndrRn cname `thenM` \ cname' ->
+ = do { cname' <- lookupLocatedTopBndrRn cname
-- Tyvars scope over superclass context and method signatures
- bindTyVarsRn cls_doc tyvars ( \ tyvars' ->
- rnContext cls_doc context `thenM` \ context' ->
- rnFds cls_doc fds `thenM` \ fds' ->
- rnATs ats `thenM` \ (ats', ats_fvs) ->
- renameSigs okClsDclSig sigs `thenM` \ sigs' ->
- mapM rnDocEntity docs `thenM` \ docs' ->
- returnM (tyvars', context', fds', (ats', ats_fvs), sigs', docs')
- ) `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs', docs') ->
+ ; (tyvars', context', fds', ats', ats_fvs, sigs')
+ <- bindTyVarsRn cls_doc tyvars $ \ tyvars' -> do
+ { context' <- rnContext cls_doc context
+ ; fds' <- rnFds cls_doc fds
+ ; (ats', ats_fvs) <- rnATs ats
+ ; sigs' <- renameSigs okClsDclSig sigs
+ ; return (tyvars', context', fds', ats', ats_fvs, sigs') }
-- Check for duplicates among the associated types
- let
- at_rdr_names_w_locs = [tcdLName ty | L _ ty <- ats]
- in
- checkDupNames at_doc at_rdr_names_w_locs `thenM_`
+ ; let at_rdr_names_w_locs = [tcdLName ty | L _ ty <- ats]
+ ; checkDupNames at_doc at_rdr_names_w_locs
-- Check the signatures
-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
- let
- sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
- in
- checkDupNames sig_doc sig_rdr_names_w_locs `thenM_`
- -- 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.
+ ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
+ ; checkDupNames sig_doc sig_rdr_names_w_locs
+ -- Typechecker is responsible for checking that we only
+ -- give default-method bindings for things in this class.
+ -- The renamer *could* check this for class decls, but can't
+ -- for instance decls.
-- The newLocals call is tiresome: given a generic class decl
-- class C a where
-- op {| a*b |} (a*b) = ...
-- we want to name both "x" tyvars with the same unique, so that they are
-- easy to group together in the typechecker.
- extendTyVarEnvForMethodBinds tyvars' (
- getLocalRdrEnv `thenM` \ name_env ->
- let
- meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
- gen_rdr_tyvars_w_locs =
- [ tv | tv <- extractGenericPatTyVars mbinds,
- not (unLoc tv `elemLocalRdrEnv` name_env) ]
- in
- checkDupNames meth_doc meth_rdr_names_w_locs `thenM_`
- newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars ->
- rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds
- ) `thenM` \ (mbinds', meth_fvs) ->
-
- returnM (ClassDecl { tcdCtxt = context', tcdLName = cname',
- tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
- tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
- delFVs (map hsLTyVarName tyvars') $
- extractHsCtxtTyNames context' `plusFV`
- plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV`
- hsSigsFVs sigs' `plusFV`
- meth_fvs `plusFV`
- ats_fvs)
+ ; (mbinds', meth_fvs)
+ <- extendTyVarEnvForMethodBinds tyvars' $ do
+ { name_env <- getLocalRdrEnv
+ ; let meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
+ gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
+ not (unLoc tv `elemLocalRdrEnv` name_env) ]
+ ; checkDupNames meth_doc meth_rdr_names_w_locs
+ ; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs
+ ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
+
+ -- Haddock docs
+ ; docs' <- mapM (wrapLocM rnDocDecl) docs
+
+ ; return (ClassDecl { tcdCtxt = context', tcdLName = cname',
+ tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
+ tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
+
+ delFVs (map hsLTyVarName tyvars') $
+ extractHsCtxtTyNames context' `plusFV`
+ plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV`
+ hsSigsFVs sigs' `plusFV`
+ meth_fvs `plusFV`
+ ats_fvs) }
where
meth_doc = text "In the default-methods for class" <+> ppr cname
cls_doc = text "In the declaration for class" <+> ppr cname
rnMbLHsDoc haddock_doc `thenM` \ new_haddock_doc ->
returnM (HsRecField new_name new_ty new_haddock_doc)
--- Rename kind signatures (signatures of indexed data types/newtypes and
--- signatures of type functions)
+-- Rename family declarations
--
-- * This function is parametrised by the routine handling the index
-- variables. On the toplevel, these are defining occurences, whereas they
-- are usage occurences for associated types.
--
-rnTySig :: TyClDecl RdrName
- -> (SDoc -> [LHsTyVarBndr RdrName] ->
- ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
- RnM (TyClDecl Name, FreeVars))
- -> RnM (TyClDecl Name, FreeVars)
-
-rnTySig (tydecl@TyData {tcdCtxt = context, tcdLName = tycon,
- tcdTyVars = tyvars, tcdTyPats = mb_typats,
- tcdCons = condecls, tcdKindSig = sig,
- tcdDerivs = derivs})
+rnFamily :: TyClDecl RdrName
+ -> (SDoc -> [LHsTyVarBndr RdrName] ->
+ ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
+ RnM (TyClDecl Name, FreeVars))
+ -> RnM (TyClDecl Name, FreeVars)
+
+rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
+ tcdLName = tycon, tcdTyVars = tyvars})
bindIdxVars =
- ASSERT( null condecls ) -- won't have constructors
- ASSERT( isNothing mb_typats ) -- won't have type patterns
- ASSERT( isNothing derivs ) -- won't have deriving
- ASSERT( isJust sig ) -- will have kind signature
- do { checkM (not . null $ tyvars) $ addErr needOneIdx -- #indexes >= 1
- ; bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do {
+ do { checkM (isDataFlavour flavour -- for synonyms,
+ || not (null tyvars)) $ addErr needOneIdx -- #indexes >= 1
+ ; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
; tycon' <- lookupLocatedTopBndrRn tycon
- ; context' <- rnContext (ksig_doc tycon) context
- ; returnM (TyData {tcdND = tcdND tydecl, tcdCtxt = context',
- tcdLName = tycon', tcdTyVars = tyvars',
- tcdTyPats = Nothing, tcdKindSig = sig,
- tcdCons = [], tcdDerivs = Nothing},
- delFVs (map hsLTyVarName tyvars') $
- extractHsCtxtTyNames context')
- } }
- where
-
-rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars,
- tcdKind = sig})
- bindIdxVars =
- do { checkM (not . null $ tyvars) $ addErr needOneIdx -- #indexes >= 1
- ; bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do {
- ; tycon' <- lookupLocatedTopBndrRn tycon
- ; returnM (TyFunction {tcdLName = tycon', tcdTyVars = tyvars',
- tcdIso = tcdIso tydecl, tcdKind = sig},
+ ; returnM (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
+ tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
emptyFVs)
} }
+ where
+ isDataFlavour DataFamily = True
+ isDataFlavour _ = False
-ksig_doc tycon = text "In the kind signature for" <+> quotes (ppr tycon)
-needOneIdx = text "Kind signature requires at least one type index"
+family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
+needOneIdx = text "Type family declarations requires at least one type index"
-- Rename associated type declarations (in classes)
--
--- * This can be kind signatures and (default) type function equations.
+-- * This can be family declarations and (default) type instances
--
rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
where
- rn_at (tydecl@TyData {}) = rnTySig tydecl lookupIdxVars
- rn_at (tydecl@TyFunction {}) = rnTySig tydecl lookupIdxVars
- rn_at (tydecl@TySynonym {}) =
+ rn_at (tydecl@TyFamily {}) = rnFamily tydecl lookupIdxVars
+ rn_at (tydecl@TySynonym {}) =
do
checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
rnTyClDecl tydecl
projects / ghc-hetmet.git / blobdiff