X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcEnv.lhs;h=055fc2cf8825e55035ad767b293e0e36aea59f5d;hb=ca8d50e001ffa64cefac0231f1cdbdff19b47e8c;hp=c93dbe156bf98a586ac4b1040198dd1913087333;hpb=1fa3580c54985d73178d1d396b897176a57cd7f3;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index c93dbe1..055fc2c 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -39,7 +39,7 @@ module TcEnv( -- Template Haskell stuff checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel, - topIdLvl, thTopLevelId, + topIdLvl, thTopLevelId, thRnBrack, isBrackStage, -- New Ids newLocalName, newDFunName, newFamInstTyConName, @@ -57,6 +57,7 @@ import TcType -- import TcSuspension import qualified Type import Id +import Coercion import Var import VarSet import VarEnv @@ -68,13 +69,10 @@ 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} @@ -121,18 +119,13 @@ tcLookupGlobal name 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 | 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -143,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 @@ -178,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 -- @@ -201,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 @@ -525,13 +527,13 @@ tcExtendRules lcl_rules thing_inside \begin{code} instance Outputable ThStage where - ppr Comp = text "Comp" + 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 = topLevel +thLevel (Comp l) = l thLevel (Splice l) = l thLevel (Brack l _ _) = l @@ -547,7 +549,7 @@ checkWellStaged pp_thing bind_lvl use_stage | bind_lvl == topLevel -- 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 (ptext (sLit "is used in") <+> use_lvl_doc <> ptext (sLit ", and must be imported, not defined locally"))] | otherwise -- Badly staged = failWithTc $ -- E.g. \x -> $(f x) @@ -556,7 +558,9 @@ checkWellStaged pp_thing bind_lvl use_stage 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" @@ -589,6 +593,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) @@ -626,10 +640,15 @@ 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 + 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 pprInstInfo :: InstInfo a -> SDoc pprInstInfo info = vcat [ptext (sLit "InstInfo:") <+> ppr (idType (iDFunId info))] @@ -637,8 +656,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 @@ -659,17 +678,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 @@ -677,12 +692,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.