module RnSource (
rnSrcDecls, addTcgDUs,
rnTyClDecls, checkModDeprec,
- rnBindGroups, rnBindGroupsAndThen, rnSplice
+ rnSplice, checkTH
) where
#include "HsVersions.h"
+import {-# SOURCE #-} RnExpr( rnLExpr )
+
import HsSyn
-import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, elemLocalRdrEnv )
-import RdrHsSyn ( extractGenericPatTyVars )
+import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, globalRdrEnvElts,
+ GlobalRdrElt(..), isLocalGRE )
+import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
import RnHsSyn
-import RnExpr ( rnLExpr, checkTH )
import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
-import RnBinds ( rnTopBinds, rnBinds, rnMethodBinds,
- rnBindsAndThen, renameSigs, checkSigs )
-import RnEnv ( lookupTopBndrRn, lookupTopFixSigNames,
+import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs )
+import RnEnv ( lookupLocalDataTcNames,
lookupLocatedTopBndrRn, lookupLocatedOccRn,
lookupOccRn, newLocalsRn,
bindLocatedLocalsFV, bindPatSigTyVarsFV,
bindTyVarsRn, extendTyVarEnvFVRn,
- bindLocalNames, newIPNameRn,
- checkDupNames, mapFvRn,
- unknownNameErr
+ bindLocalNames, checkDupNames, mapFvRn
)
import TcRnMonad
-import BasicTypes ( TopLevelFlag(..) )
import HscTypes ( FixityEnv, FixItem(..),
Deprecations, Deprecs(..), DeprecTxt, plusDeprecs )
import Class ( FunDep )
-import Name ( Name )
+import Name ( Name, nameOccName )
import NameSet
import NameEnv
+import OccName ( occEnvElts )
import Outputable
import SrcLoc ( Located(..), unLoc, getLoc, noLoc )
-import CmdLineOpts ( DynFlag(..) )
- -- Warn of unused for-all'd tyvars
+import DynFlags ( DynFlag(..) )
import Maybes ( seqMaybe )
-import Maybe ( catMaybes, isNothing )
+import Maybe ( isNothing )
+import BasicTypes ( Boxity(..) )
\end{code}
@rnSourceDecl@ `renames' declarations.
\begin{code}
rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
-rnSrcDecls (HsGroup { hs_valds = [HsBindGroup binds sigs _],
+rnSrcDecls (HsGroup { hs_valds = val_decls,
hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_fixds = fix_decls,
-- Deal with top-level fixity decls
-- (returns the total new fixity env)
- fix_env <- rnSrcFixityDecls fix_decls ;
+ fix_env <- rnSrcFixityDeclsEnv fix_decls ;
+ rn_fix_decls <- rnSrcFixityDecls fix_decls ;
updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
$ do {
-- Rename other declarations
traceRn (text "Start rnmono") ;
- (rn_val_decls, bind_dus) <- rnTopBinds binds sigs ;
+ (rn_val_decls, bind_dus) <- rnTopBinds val_decls ;
traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
-- You might think that we could build proper def/use information
rn_group = HsGroup { hs_valds = rn_val_decls,
hs_tyclds = rn_tycl_decls,
hs_instds = rn_inst_decls,
- hs_fixds = [],
+ hs_fixds = rn_fix_decls,
hs_depds = [],
hs_fords = rn_foreign_decls,
hs_defds = rn_default_decls,
other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3,
src_fvs4, src_fvs5] ;
src_dus = bind_dus `plusDU` usesOnly other_fvs
+ -- Note: src_dus will contain *uses* for locally-defined types
+ -- and classes, but no *defs* for them. (Because rnTyClDecl
+ -- returns only the uses.) This is a little
+ -- surprising but it doesn't actually matter at all.
} ;
traceRn (text "finish rnSrc" <+> ppr rn_group) ;
+ traceRn (text "finish Dus" <+> ppr src_dus ) ;
tcg_env <- getGblEnv ;
return (tcg_env `addTcgDUs` src_dus, rn_group)
}}}
%*********************************************************
\begin{code}
-rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM FixityEnv
+rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM [LFixitySig Name]
rnSrcFixityDecls fix_decls
+ = do fix_decls <- mapM rnFixityDecl fix_decls
+ return (concat fix_decls)
+
+rnFixityDecl :: LFixitySig RdrName -> RnM [LFixitySig Name]
+rnFixityDecl (L loc (FixitySig (L nameLoc rdr_name) fixity))
+ = do names <- lookupLocalDataTcNames rdr_name
+ return [ L loc (FixitySig (L nameLoc name) fixity)
+ | name <- names ]
+
+rnSrcFixityDeclsEnv :: [LFixitySig RdrName] -> RnM FixityEnv
+rnSrcFixityDeclsEnv fix_decls
= getGblEnv `thenM` \ gbl_env ->
- foldlM rnFixityDecl (tcg_fix_env gbl_env)
+ foldlM rnFixityDeclEnv (tcg_fix_env gbl_env)
fix_decls `thenM` \ fix_env ->
traceRn (text "fixity env" <+> pprFixEnv fix_env) `thenM_`
returnM fix_env
-rnFixityDecl :: FixityEnv -> LFixitySig RdrName -> RnM FixityEnv
-rnFixityDecl fix_env (L loc (FixitySig rdr_name fixity))
+rnFixityDeclEnv :: FixityEnv -> LFixitySig RdrName -> RnM FixityEnv
+rnFixityDeclEnv fix_env (L loc (FixitySig rdr_name fixity))
= setSrcSpan loc $
-- GHC extension: look up both the tycon and data con
-- for con-like things
-- If neither are in scope, report an error; otherwise
-- add both to the fixity env
- addLocM lookupTopFixSigNames rdr_name `thenM` \ names ->
- if null names then
- addLocErr rdr_name unknownNameErr `thenM_`
- returnM fix_env
- else
- foldlM add fix_env names
+ addLocM lookupLocalDataTcNames rdr_name `thenM` \ names ->
+ foldlM add fix_env names
where
add fix_env name
= case lookupNameEnv fix_env name of
returnM fix_env
Nothing -> returnM (extendNameEnv fix_env name fix_item)
where
- fix_item = FixItem (rdrNameOcc (unLoc rdr_name)) fixity
- (getLoc rdr_name)
+ fix_item = FixItem (nameOccName name) fixity (getLoc rdr_name)
pprFixEnv :: FixityEnv -> SDoc
pprFixEnv env
= returnM NoDeprecs
rnSrcDeprecDecls decls
- = mappM (addLocM rn_deprec) decls `thenM` \ pairs ->
- returnM (DeprecSome (mkNameEnv (catMaybes pairs)))
+ = mappM (addLocM rn_deprec) decls `thenM` \ pairs_s ->
+ returnM (DeprecSome (mkNameEnv (concat pairs_s)))
where
rn_deprec (Deprecation rdr_name txt)
- = lookupTopBndrRn rdr_name `thenM` \ name ->
- returnM (Just (name, (rdrNameOcc 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
%*********************************************************
%* *
- Bindings
-%* *
-%*********************************************************
-
-These chaps are here, rather than in TcBinds, so that there
-is just one hi-boot file (for RnSource). rnSrcDecls is part
-of the loop too, and it must be defined in this module.
-
-\begin{code}
-rnBindGroups :: [HsBindGroup RdrName] -> RnM ([HsBindGroup Name], DefUses)
--- This version assumes that the binders are already in scope
--- It's used only in 'mdo'
-rnBindGroups []
- = returnM ([], emptyDUs)
-rnBindGroups [HsBindGroup bind sigs _]
- = rnBinds NotTopLevel bind sigs
-rnBindGroups b@[HsIPBinds bind]
- = do addErr (badIpBinds b)
- returnM ([], emptyDUs)
-rnBindGroups _
- = panic "rnBindGroups"
-
-rnBindGroupsAndThen
- :: [HsBindGroup RdrName]
- -> ([HsBindGroup Name] -> RnM (result, FreeVars))
- -> RnM (result, FreeVars)
--- This version (a) assumes that the binding vars are not already in scope
--- (b) removes the binders from the free vars of the thing inside
--- The parser doesn't produce ThenBinds
-rnBindGroupsAndThen [] thing_inside
- = thing_inside []
-rnBindGroupsAndThen [HsBindGroup bind sigs _] thing_inside
- = rnBindsAndThen bind sigs $ \ groups -> thing_inside groups
-rnBindGroupsAndThen [HsIPBinds binds] thing_inside
- = rnIPBinds binds `thenM` \ (binds',fv_binds) ->
- thing_inside [HsIPBinds binds'] `thenM` \ (thing, fvs_thing) ->
- returnM (thing, fvs_thing `plusFV` fv_binds)
-
-rnIPBinds [] = returnM ([], emptyFVs)
-rnIPBinds (bind : binds)
- = wrapLocFstM rnIPBind bind `thenM` \ (bind', fvBind) ->
- rnIPBinds binds `thenM` \ (binds',fvBinds) ->
- returnM (bind' : binds', fvBind `plusFV` fvBinds)
-
-rnIPBind (IPBind n expr)
- = newIPNameRn n `thenM` \ name ->
- rnLExpr expr `thenM` \ (expr',fvExpr) ->
- return (IPBind name expr', fvExpr)
-
-badIpBinds binds
- = hang (ptext SLIT("Implicit-parameter bindings illegal in 'mdo':")) 4
- (ppr binds)
-\end{code}
-
-
-%*********************************************************
-%* *
\subsection{Foreign declarations}
%* *
%*********************************************************
-- But the (unqualified) method names are in scope
let
binders = collectHsBindBinders mbinds'
+ ok_sig = okInstDclSig (mkNameSet binders)
in
- bindLocalNames binders (renameSigs uprags) `thenM` \ uprags' ->
- checkSigs (okInstDclSig (mkNameSet binders)) uprags' `thenM_`
+ bindLocalNames binders (renameSigs ok_sig uprags) `thenM` \ uprags' ->
returnM (InstDecl inst_ty' mbinds' uprags',
meth_fvs `plusFV` hsSigsFVs uprags'
rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
tcdTyVars = tyvars, tcdCons = condecls,
- tcdDerivs = derivs})
+ tcdKindSig = sig, tcdDerivs = derivs})
| is_vanilla -- Normal Haskell data type decl
- = bindTyVarsRn data_doc tyvars $ \ tyvars' ->
+ = ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the
+ -- data type is syntactically illegal
+ bindTyVarsRn data_doc tyvars $ \ tyvars' ->
do { tycon' <- lookupLocatedTopBndrRn tycon
; context' <- rnContext data_doc context
; (derivs', deriv_fvs) <- rn_derivs derivs
; checkDupNames data_doc con_names
; condecls' <- rnConDecls (unLoc tycon') condecls
; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon',
- tcdTyVars = tyvars', tcdCons = condecls',
+ tcdTyVars = tyvars', tcdKindSig = Nothing, tcdCons = condecls',
tcdDerivs = derivs'},
delFVs (map hsLTyVarName tyvars') $
extractHsCtxtTyNames context' `plusFV`
deriv_fvs) }
| otherwise -- GADT
- = ASSERT( null (unLoc context) )
- do { tycon' <- lookupLocatedTopBndrRn tycon
- ; tyvars' <- bindTyVarsRn data_doc tyvars
+ = do { tycon' <- lookupLocatedTopBndrRn tycon
+ ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
+ ; tyvars' <- bindTyVarsRn data_doc tyvars
(\ tyvars' -> return tyvars')
-- For GADTs, the type variables in the declaration
-- do not scope over the constructor signatures
; checkDupNames data_doc con_names
; condecls' <- rnConDecls (unLoc tycon') condecls
; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon',
- tcdTyVars = tyvars', tcdCons = condecls',
+ tcdTyVars = tyvars', tcdCons = condecls', tcdKindSig = sig,
tcdDerivs = derivs'},
plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }
where
is_vanilla = case condecls of -- Yuk
[] -> True
- L _ (ConDecl {}) : _ -> True
+ L _ (ConDecl { con_res = ResTyH98 }) : _ -> True
other -> False
data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
con_names = map con_names_helper condecls
- con_names_helper (L _ (ConDecl n _ _ _)) = n
- con_names_helper (L _ (GadtDecl n _)) = n
+ con_names_helper (L _ c) = con_name c
rn_derivs Nothing = returnM (Nothing, emptyFVs)
rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' ->
bindTyVarsRn cls_doc tyvars ( \ tyvars' ->
rnContext cls_doc context `thenM` \ context' ->
rnFds cls_doc fds `thenM` \ fds' ->
- renameSigs sigs `thenM` \ sigs' ->
+ renameSigs okClsDclSig sigs `thenM` \ sigs' ->
returnM (tyvars', context', fds', sigs')
) `thenM` \ (tyvars', context', fds', sigs') ->
-- 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 _ (Sig op _) <- sigs]
+ sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
in
checkDupNames sig_doc sig_rdr_names_w_locs `thenM_`
- checkSigs okClsDclSig sigs' `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
meth_doc = text "In the default-methods for class" <+> ppr cname
cls_doc = text "In the declaration for class" <+> ppr cname
sig_doc = text "In the signatures for class" <+> ppr cname
+
+badGadtStupidTheta tycon
+ = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),
+ ptext SLIT("(You can put a context on each contructor, though.)")]
\end{code}
%*********************************************************
\begin{code}
rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
rnConDecls tycon condecls
- = -- Check that there's at least one condecl,
- -- or else we're reading an interface file, or -fglasgow-exts
- (if null condecls then
- doptM Opt_GlasgowExts `thenM` \ glaExts ->
- checkErr glaExts (emptyConDeclsErr tycon)
- else returnM ()
- ) `thenM_`
- mappM (wrapLocM rnConDecl) condecls
+ = mappM (wrapLocM rnConDecl) condecls
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
-rnConDecl (ConDecl name tvs cxt details)
- = addLocM checkConName name `thenM_`
- lookupLocatedTopBndrRn name `thenM` \ new_name ->
-
- bindTyVarsRn doc tvs $ \ new_tyvars ->
- rnContext doc cxt `thenM` \ new_context ->
- rnConDetails doc details `thenM` \ new_details ->
- returnM (ConDecl new_name new_tyvars new_context new_details)
- where
- doc = text "In the definition of data constructor" <+> quotes (ppr name)
+rnConDecl (ConDecl name expl tvs cxt details res_ty)
+ = do { addLocM checkConName name
-rnConDecl (GadtDecl name ty)
- = addLocM checkConName name `thenM_`
- lookupLocatedTopBndrRn name `thenM` \ new_name ->
- rnHsSigType doc ty `thenM` \ new_ty ->
- returnM (GadtDecl new_name new_ty)
+ ; new_name <- lookupLocatedTopBndrRn name
+ ; name_env <- getLocalRdrEnv
+
+ -- For H98 syntax, the tvs are the existential ones
+ -- For GADT syntax, the tvs are all the quantified tyvars
+ -- Hence the 'filter' in the ResTyH98 case only
+ ; let not_in_scope = not . (`elemLocalRdrEnv` name_env) . unLoc
+ arg_tys = hsConArgs details
+ implicit_tvs = case res_ty of
+ ResTyH98 -> filter not_in_scope $
+ get_rdr_tvs arg_tys
+ ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
+ tvs' = case expl of
+ Explicit -> tvs
+ Implicit -> userHsTyVarBndrs implicit_tvs
+
+ ; bindTyVarsRn doc tvs' $ \new_tyvars -> do
+ { new_context <- rnContext doc cxt
+ ; new_details <- rnConDetails doc details
+ ; new_res_ty <- rnConResult doc res_ty
+ ; let rv = ConDecl new_name expl new_tyvars new_context new_details new_res_ty
+ ; traceRn (text "****** - autrijus" <> ppr rv)
+ ; return rv } }
where
doc = text "In the definition of data constructor" <+> quotes (ppr name)
+ get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
+
+rnConResult _ ResTyH98 = return ResTyH98
+rnConResult doc (ResTyGADT ty) = do
+ ty' <- rnHsSigType doc ty
+ return $ ResTyGADT ty'
rnConDetails doc (PrefixCon tys)
= mappM (rnLHsType doc) tys `thenM` \ new_tys ->
badDataCon name
= hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
-
-emptyConDeclsErr tycon
- = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
- nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
\end{code}
%* *
%*********************************************************
+Note [Splices]
+~~~~~~~~~~~~~~
+Consider
+ f = ...
+ h = ...$(thing "f")...
+
+The splice can expand into literally anything, so when we do dependency
+analysis we must assume that it might mention 'f'. So we simply treat
+all locally-defined names as mentioned by any splice. This is terribly
+brutal, but I don't see what else to do. For example, it'll mean
+that every locally-defined thing will appear to be used, so no unused-binding
+warnings. But if we miss the dependency, then we might typecheck 'h' before 'f',
+and that will crash the type checker because 'f' isn't in scope.
+
+Currently, I'm not treating a splice as also mentioning every import,
+which is a bit inconsistent -- but there are a lot of them. We might
+thereby get some bogus unused-import warnings, but we won't crash the
+type checker. Not very satisfactory really.
+
\begin{code}
rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
rnSplice (HsSplice n expr)
- = checkTH expr "splice" `thenM_`
- getSrcSpanM `thenM` \ loc ->
- newLocalsRn [L loc n] `thenM` \ [n'] ->
- rnLExpr expr `thenM` \ (expr', fvs) ->
- returnM (HsSplice n' expr', fvs)
+ = do { checkTH expr "splice"
+ ; loc <- getSrcSpanM
+ ; [n'] <- newLocalsRn [L loc n]
+ ; (expr', fvs) <- rnLExpr expr
+
+ -- Ugh! See Note [Splices] above
+ ; lcl_rdr <- getLocalRdrEnv
+ ; gbl_rdr <- getGlobalRdrEnv
+ ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr,
+ isLocalGRE gre]
+ lcl_names = mkNameSet (occEnvElts lcl_rdr)
+
+ ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
+
+#ifdef GHCI
+checkTH e what = returnM () -- OK
+#else
+checkTH e what -- Raise an error in a stage-1 compiler
+ = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
+ ptext SLIT("illegal in a stage-1 compiler"),
+ nest 2 (ppr e)])
+#endif
\end{code}
projects / ghc-hetmet.git / blobdiff