X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcEnv.lhs;h=67e65afc3c887f9659d62a0878578ac0589b22aa;hb=1a9245caefb80a3c4c5965aaacdf9a607e792e1c;hp=d0388456e7ad153fdf1e3e84ae32f25d871e278b;hpb=61bcd16d4f3d4cf84b26bf7bb92f16f0440b7071;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index d038845..67e65af 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -38,7 +38,7 @@ module TcEnv( tcGetGlobalTyVars, -- Template Haskell stuff - checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel, + checkWellStaged, tcMetaTy, thLevel, topIdLvl, thTopLevelId, thRnBrack, isBrackStage, -- New Ids @@ -55,11 +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 @@ -69,11 +70,9 @@ import TypeRep import Class import Name import NameEnv -import OccName import HscTypes import SrcLoc import Outputable -import Maybes import Unique import FastString \end{code} @@ -116,20 +115,17 @@ tcLookupGlobal name -- 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 + -> 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -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 @@ -314,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 @@ -332,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] @@ -403,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} @@ -521,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" @@ -565,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 @@ -633,10 +611,22 @@ data InstBindings a (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 + + 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))] @@ -644,8 +634,8 @@ pprInstInfo info = vcat [ptext (sLit "InstInfo:") <+> ppr (idType (iDFunId info) 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 a -> (Class, Type) simpleInstInfoClsTy info = case instanceHead (iSpec info) of @@ -666,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 @@ -684,12 +670,13 @@ 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. @@ -727,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