X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcEnv.lhs;h=67e65afc3c887f9659d62a0878578ac0589b22aa;hb=1a9245caefb80a3c4c5965aaacdf9a607e792e1c;hp=74eb195ca93b9ac8f95187910194b75459837a04;hpb=a364279dac70162e4e22f7673c01642de6afaf6f;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 74eb195..67e65af 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -12,7 +12,7 @@ module TcEnv( InstBindings(..), -- Global environment - tcExtendGlobalEnv, + tcExtendGlobalEnv, setGlobalTypeEnv, tcExtendGlobalValEnv, tcLookupLocatedGlobal, tcLookupGlobal, tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon, @@ -38,11 +38,12 @@ module TcEnv( tcGetGlobalTyVars, -- Template Haskell stuff - checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel, - topIdLvl, thTopLevelId, + checkWellStaged, tcMetaTy, thLevel, + topIdLvl, thTopLevelId, thRnBrack, isBrackStage, -- New Ids - newLocalName, newDFunName, newFamInstTyConName, + newLocalName, newDFunName, newFamInstTyConName, + mkStableIdFromString, mkStableIdFromName ) where #include "HsVersions.h" @@ -54,10 +55,12 @@ import TcRnMonad import TcMType import TcType -- import TcSuspension -import qualified Type +-- import qualified Type +import Id +import Coercion import Var import VarSet -import VarEnv +-- import VarEnv import RdrName import InstEnv import FamInstEnv @@ -66,13 +69,11 @@ import TyCon import TypeRep import Class import Name -import PrelNames import NameEnv -import OccName import HscTypes import SrcLoc import Outputable -import Maybes +import Unique import FastString \end{code} @@ -106,30 +107,25 @@ tcLookupGlobal name Nothing -> do -- Try global envt - { (eps,hpt) <- getEpsAndHpt - ; dflags <- getDOpts - ; case lookupType dflags hpt (eps_PTE eps) name of { + { hsc_env <- getTopEnv + ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) + ; case mb_thing of { Just thing -> return thing ; Nothing -> do -- Should it have been in the local envt? { case nameModule_maybe name of - Nothing -> notFound name env -- Internal names can happen in GHCi + Nothing -> notFound name -- Internal names can happen in GHCi Just mod | mod == tcg_mod env -- Names from this module - -> notFound name env -- should be in tcg_type_env - | mod == thFAKE -- Names bound in TH declaration brackets - -> notFound name env -- should be in tcg_env + -> notFound name -- should be in tcg_type_env | otherwise -> tcImportDecl name -- Go find it in an interface }}}}} tcLookupField :: Name -> TcM Id -- Returns the selector Id -tcLookupField name = do - thing <- tcLookup name -- Note [Record field lookup] - case thing of - AGlobal (AnId id) -> return id - thing -> wrongThingErr "field name" thing name +tcLookupField name + = tcLookupId name -- Note [Record field lookup] {- Note [Record field lookup] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -140,7 +136,7 @@ Then the renamer (which does not keep track of what is a record selector and what is not) will rename the definition thus f_7 = e { f_7 = True } Now the type checker will find f_7 in the *local* type environment, not -the global one. It's wrong, of course, but we want to report a tidy +the global (imported) one. It's wrong, of course, but we want to report a tidy error, not in TcEnv.notFound. -} tcLookupDataCon :: Name -> TcM DataCon @@ -175,9 +171,13 @@ tcLookupLocatedTyCon = addLocM tcLookupTyCon -- Look up the instance tycon of a family instance. -- --- The match must be unique - ie, match exactly one instance - but the --- type arguments used for matching may be more specific than those of --- the family instance declaration. +-- The match may be ambiguous (as we know that overlapping instances have +-- identical right-hand sides under overlapping substitutions - see +-- 'FamInstEnv.lookupFamInstEnvConflicts'). However, the type arguments used +-- for matching must be equal to or be more specific than those of the family +-- instance declaration. We pick one of the matches in case of ambiguity; as +-- the right-hand sides are identical under the match substitution, the choice +-- does not matter. -- -- Return the instance tycon and its type instance. For example, if we have -- @@ -198,12 +198,17 @@ tcLookupFamInst tycon tys ; eps <- getEps ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env) ; case lookupFamInstEnv instEnv tycon tys of - [(fam_inst, rep_tys)] -> return $ Just (famInstTyCon fam_inst, - rep_tys) - _ -> return Nothing + [] -> return Nothing + ((fam_inst, rep_tys):_) + -> return $ Just (famInstTyCon fam_inst, rep_tys) } \end{code} +\begin{code} +instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where + lookupThing = tcLookupGlobal +\end{code} + %************************************************************************ %* * Extending the global environment @@ -212,28 +217,37 @@ tcLookupFamInst tycon tys \begin{code} +setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv +-- Use this to update the global type env +-- It updates both * the normal tcg_type_env field +-- * the tcg_type_env_var field seen by interface files +setGlobalTypeEnv tcg_env new_type_env + = do { -- Sync the type-envt variable seen by interface files + writeMutVar (tcg_type_env_var tcg_env) new_type_env + ; return (tcg_env { tcg_type_env = new_type_env }) } + tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r -- Given a mixture of Ids, TyCons, Classes, all from the -- module being compiled, extend the global environment tcExtendGlobalEnv things thing_inside - = do { env <- getGblEnv - ; let ge' = extendTypeEnvList (tcg_type_env env) things - ; setGblEnv (env {tcg_type_env = ge'}) thing_inside } + = do { tcg_env <- getGblEnv + ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things + ; tcg_env' <- setGlobalTypeEnv tcg_env ge' + ; setGblEnv tcg_env' thing_inside } tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a -- Same deal as tcExtendGlobalEnv, but for Ids tcExtendGlobalValEnv ids thing_inside = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside -\end{code} -\begin{code} tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r -- Extend the global environments for the type/class knot tying game +-- Just like tcExtendGlobalEnv, except the argument is a list of pairs tcExtendRecEnv gbl_stuff thing_inside - = updGblEnv upd thing_inside - where - upd env = env { tcg_type_env = extend (tcg_type_env env) } - extend env = extendNameEnvList env gbl_stuff + = do { tcg_env <- getGblEnv + ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff + ; tcg_env' <- setGlobalTypeEnv tcg_env ge' + ; setGblEnv tcg_env' thing_inside } \end{code} @@ -305,13 +319,10 @@ tcExtendKindEnv things thing_inside upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things] -tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r +tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> ([LHsTyVarBndr Name] -> TcM r) -> TcM r tcExtendKindEnvTvs bndrs thing_inside - = updLclEnv upd thing_inside - where - upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } - extend env = extendNameEnvList env pairs - pairs = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs] + = tcExtendKindEnv (map (hsTyVarNameKind . unLoc) bndrs) + (thing_inside bndrs) tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r tcExtendTyVarEnv tvs thing_inside @@ -323,7 +334,7 @@ tcExtendTyVarEnv2 binds thing_inside = do tcl_tyvars = gtvs, tcl_rdr = rdr_env}) <- getLclEnv let - rdr_env' = extendLocalRdrEnv rdr_env (map fst binds) + rdr_env' = extendLocalRdrEnvList rdr_env (map fst binds) new_tv_set = tcTyVarsOfTypes (map snd binds) le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds] @@ -394,7 +405,7 @@ tc_extend_local_id_env env th_lvl names_w_ids thing_inside _ -> Wobbly}) | (name,id) <- names_w_ids, let id_ty = idType id] le' = extendNameEnvList (tcl_env env) extra_env - rdr_env' = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids] + rdr_env' = extendLocalRdrEnvList (tcl_rdr env) [name | (name,_) <- names_w_ids] \end{code} @@ -512,39 +523,25 @@ tcExtendRules lcl_rules thing_inside %************************************************************************ \begin{code} -instance Outputable ThStage where - ppr Comp = text "Comp" - ppr (Brack l _ _) = text "Brack" <+> int l - ppr (Splice l) = text "Splice" <+> int l - - -thLevel :: ThStage -> ThLevel -thLevel Comp = topLevel -thLevel (Splice l) = l -thLevel (Brack l _ _) = l - - checkWellStaged :: SDoc -- What the stage check is for -> ThLevel -- Binding level (increases inside brackets) - -> ThStage -- Use stage + -> ThLevel -- Use stage -> TcM () -- Fail if badly staged, adding an error -checkWellStaged pp_thing bind_lvl use_stage +checkWellStaged pp_thing bind_lvl use_lvl | use_lvl >= bind_lvl -- OK! Used later than bound = return () -- E.g. \x -> [| $(f x) |] - | bind_lvl == topLevel -- GHC restriction on top level splices + | bind_lvl == outerLevel -- GHC restriction on top level splices = failWithTc $ sep [ptext (sLit "GHC stage restriction:") <+> pp_thing, - nest 2 (ptext (sLit "is used in a top-level splice, and must be imported, not defined locally"))] + nest 2 (vcat [ ptext (sLit "is used in a top-level splice or annotation,") + , ptext (sLit "and must be imported, not defined locally")])] | otherwise -- Badly staged = failWithTc $ -- E.g. \x -> $(f x) ptext (sLit "Stage error:") <+> pp_thing <+> hsep [ptext (sLit "is bound at stage") <+> ppr bind_lvl, ptext (sLit "but used at stage") <+> ppr use_lvl] - where - use_lvl = thLevel use_stage - topIdLvl :: Id -> ThLevel -- Globals may either be imported, or may be from an earlier "chunk" @@ -556,19 +553,9 @@ topIdLvl :: Id -> ThLevel -- $( f x ) -- By the time we are prcessing the $(f x), the binding for "x" -- will be in the global env, not the local one. -topIdLvl id | isLocalId id = topLevel +topIdLvl id | isLocalId id = outerLevel | otherwise = impLevel --- Indicates the legal transitions on bracket( [| |] ). -bracketOK :: ThStage -> Maybe ThLevel -bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket -bracketOK stage = Just (thLevel stage + 1) - --- Indicates the legal transitions on splice($). -spliceOK :: ThStage -> Maybe ThLevel -spliceOK (Splice _) = Nothing -- Splice illegal inside splice -spliceOK stage = Just (thLevel stage - 1) - tcMetaTy :: Name -> TcM Type -- Given the name of a Template Haskell data type, -- return the type @@ -577,6 +564,16 @@ tcMetaTy tc_name = do t <- tcLookupTyCon tc_name return (mkTyConApp t []) +thRnBrack :: ThStage +-- Used *only* to indicate that we are inside a TH bracket during renaming +-- Tested by TcEnv.isBrackStage +-- See Note [Top-level Names in Template Haskell decl quotes] +thRnBrack = Brack (panic "thRnBrack1") (panic "thRnBrack2") (panic "thRnBrack3") + +isBrackStage :: ThStage -> Bool +isBrackStage (Brack {}) = True +isBrackStage _other = False + thTopLevelId :: Id -> Bool -- See Note [What is a top-level Id?] in TcSplice thTopLevelId id = isGlobalId id || isExternalName (idName id) @@ -600,43 +597,55 @@ But local instance decls includes as well as explicit user written ones. \begin{code} -data InstInfo +data InstInfo a = InstInfo { iSpec :: Instance, -- Includes the dfun id. Its forall'd type - iBinds :: InstBindings -- variables scope over the stuff in InstBindings! + iBinds :: InstBindings a -- variables scope over the stuff in InstBindings! } -iDFunId :: InstInfo -> DFunId +iDFunId :: InstInfo a -> DFunId iDFunId info = instanceDFunId (iSpec info) -data InstBindings +data InstBindings a = VanillaInst -- The normal case - (LHsBinds Name) -- Bindings for the instance methods - [LSig Name] -- User pragmas recorded for generating + (LHsBinds a) -- Bindings for the instance methods + [LSig a] -- User pragmas recorded for generating -- specialised instances + Bool -- True <=> This code came from a standalone deriving clause + + | NewTypeDerived -- Used for deriving instances of newtypes, where the + -- witness dictionary is identical to the argument + -- dictionary. Hence no bindings, no pragmas. - | NewTypeDerived -- Used for deriving instances of newtypes, where the - -- witness dictionary is identical to the argument - -- dictionary. Hence no bindings, no pragmas. + CoercionI -- The coercion maps from newtype to the representation type + -- (mentioning type variables bound by the forall'd iSpec variables) + -- E.g. newtype instance N [a] = N1 (Tree a) + -- co : N [a] ~ Tree a -pprInstInfo :: InstInfo -> SDoc + TyCon -- The TyCon is the newtype N. If it's indexed, then it's the + -- representation TyCon, so that tyConDataCons returns [N1], + -- the "data constructor". + -- See Note [Newtype deriving and unused constructors] + -- in TcDeriv + +pprInstInfo :: InstInfo a -> SDoc pprInstInfo info = vcat [ptext (sLit "InstInfo:") <+> ppr (idType (iDFunId info))] -pprInstInfoDetails :: InstInfo -> SDoc +pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info)) where - details (VanillaInst b _) = pprLHsBinds b - details NewTypeDerived = text "Derived from the representation type" + details (VanillaInst b _ _) = pprLHsBinds b + details (NewTypeDerived {}) = text "Derived from the representation type" -simpleInstInfoClsTy :: InstInfo -> (Class, Type) +simpleInstInfoClsTy :: InstInfo a -> (Class, Type) simpleInstInfoClsTy info = case instanceHead (iSpec info) of (_, _, cls, [ty]) -> (cls, ty) _ -> panic "simpleInstInfoClsTy" -simpleInstInfoTy :: InstInfo -> Type +simpleInstInfoTy :: InstInfo a -> Type simpleInstInfoTy info = snd (simpleInstInfoClsTy info) -simpleInstInfoTyCon :: InstInfo -> TyCon +simpleInstInfoTyCon :: InstInfo a -> TyCon -- Gets the type constructor for a simple instance declaration, -- i.e. one of the form instance (...) => C (T a b c) where ... simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) @@ -647,17 +656,13 @@ name, like otber top-level names, and hence must be made with newGlobalBinder. \begin{code} newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name -newDFunName clas (ty:_) loc - = do { index <- nextDFunIndex - ; is_boot <- tcIsHsBoot +newDFunName clas tys loc + = do { is_boot <- tcIsHsBoot ; mod <- getModule ; let info_string = occNameString (getOccName clas) ++ - occNameString (getDFunTyKey ty) - dfun_occ = mkDFunOcc info_string is_boot index - + concatMap (occNameString.getDFunTyKey) tys + ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot) ; newGlobalBinder mod dfun_occ loc } - -newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) \end{code} Make a name for the representation tycon of a family instance. It's an @@ -665,14 +670,36 @@ Make a name for the representation tycon of a family instance. It's an newGlobalBinder. \begin{code} -newFamInstTyConName :: Name -> SrcSpan -> TcM Name -newFamInstTyConName tc_name loc - = do { index <- nextDFunIndex - ; mod <- getModule - ; let occ = nameOccName tc_name - ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc } +newFamInstTyConName :: Name -> [Type] -> SrcSpan -> TcM Name +newFamInstTyConName tc_name tys loc + = do { mod <- getModule + ; let info_string = occNameString (getOccName tc_name) ++ + concatMap (occNameString.getDFunTyKey) tys + ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string) + ; newGlobalBinder mod occ loc } \end{code} +Stable names used for foreign exports and annotations. +For stable names, the name must be unique (see #1533). If the +same thing has several stable Ids based on it, the +top-level bindings generated must not have the same name. +Hence we create an External name (doesn't change), and we +append a Unique to the string right here. + +\begin{code} +mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId +mkStableIdFromString str sig_ty loc occ_wrapper = do + uniq <- newUnique + mod <- getModule + let uniq_str = showSDoc (pprUnique uniq) :: String + occ = mkVarOcc (str ++ '_' : uniq_str) :: OccName + gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name + id = mkExportedLocalId gnm sig_ty :: Id + return id + +mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId +mkStableIdFromName nm = mkStableIdFromString (getOccString nm) +\end{code} %************************************************************************ %* * @@ -687,12 +714,14 @@ pprBinders :: [Name] -> SDoc pprBinders [bndr] = quotes (ppr bndr) pprBinders bndrs = pprWithCommas ppr bndrs -notFound :: Name -> TcGblEnv -> TcM TyThing -notFound name env - = failWithTc (vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> +notFound :: Name -> TcM TyThing +notFound name + = do { (gbl,lcl) <- getEnvs + ; failWithTc (vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> ptext (sLit "is not in scope during type checking, but it passed the renamer"), - ptext (sLit "tcg_type_env of environment:") <+> ppr (tcg_type_env env)] - ) + ptext (sLit "tcg_type_env of environment:") <+> ppr (tcg_type_env gbl), + ptext (sLit "tcl_env of environment:") <+> ppr (tcl_env lcl)] + ) } wrongThingErr :: String -> TcTyThing -> Name -> TcM a wrongThingErr expected thing name