X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnSource.lhs;h=2d6da1f34f40c027528ea0e4e61221acd1fdbe54;hb=44c7a4c69eaeafb6930b229741760c9075e72959;hp=7d3d308d3e8a501caddeb4c586f38f174f4928ce;hpb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 7d3d308..2d6da1f 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -7,43 +7,42 @@ 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. @@ -65,7 +64,7 @@ Checks the @(..)@ etc constraints in the export list. \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, @@ -81,13 +80,14 @@ rnSrcDecls (HsGroup { hs_valds = [HsBindGroup binds sigs _], -- 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 @@ -112,7 +112,7 @@ rnSrcDecls (HsGroup { hs_valds = [HsBindGroup binds sigs _], 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, @@ -121,9 +121,14 @@ rnSrcDecls (HsGroup { hs_valds = [HsBindGroup binds sigs _], 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) }}} @@ -145,27 +150,34 @@ addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } %********************************************************* \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 @@ -174,8 +186,7 @@ rnFixityDecl fix_env (L loc (FixitySig rdr_name fixity)) 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 @@ -205,12 +216,12 @@ rnSrcDeprecDecls [] = 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 @@ -234,63 +245,6 @@ rnDefaultDecl (DefaultDecl tys) %********************************************************* %* * - 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} %* * %********************************************************* @@ -347,9 +301,9 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags) -- 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' @@ -487,16 +441,18 @@ rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_ 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` @@ -504,9 +460,9 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, 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 @@ -515,21 +471,20 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, ; 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' -> @@ -554,17 +509,16 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 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 @@ -602,6 +556,10 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 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} %********************************************************* @@ -613,34 +571,43 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, \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 -> @@ -677,10 +644,6 @@ checkConName name = checkErr (isRdrDataCon name) (badDataCon name) 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} @@ -712,12 +675,48 @@ rnHsTyvar doc tyvar = lookupOccRn tyvar %* * %********************************************************* +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}