X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcEnv.lhs;h=67e65afc3c887f9659d62a0878578ac0589b22aa;hb=1a9245caefb80a3c4c5965aaacdf9a607e792e1c;hp=36231cdd974ee11e41e7fc9ad0f38ab0c9f342b2;hpb=f61fe72d9bcefdf7f9e04f2d0d94c7d842f7625b;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 36231cd..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,12 +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 @@ -115,10 +115,10 @@ 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 }}}}} @@ -319,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 @@ -337,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] @@ -408,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} @@ -526,41 +523,25 @@ tcExtendRules lcl_rules thing_inside %************************************************************************ \begin{code} -instance Outputable ThStage where - ppr (Comp l) = text "Comp" <+> int l - ppr (Brack l _ _) = text "Brack" <+> int l - ppr (Splice l) = text "Splice" <+> int l - - -thLevel :: ThStage -> ThLevel -thLevel (Comp l) = l -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") <+> use_lvl_doc <> ptext (sLit ", 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 - use_lvl_doc | use_lvl == thLevel topStage = ptext (sLit "a top-level splice") - | use_lvl == thLevel topAnnStage = ptext (sLit "an annotation") - | otherwise = panic "checkWellStaged" topIdLvl :: Id -> ThLevel -- Globals may either be imported, or may be from an earlier "chunk" @@ -572,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 @@ -640,14 +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 - CoercionI -- witness dictionary is identical to the argument - -- dictionary. Hence no bindings, no pragmas. - -- 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 + 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))] @@ -655,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 @@ -677,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 @@ -695,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. @@ -738,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