X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcEnv.lhs;h=4c87a12671f75fd9b35e31a4de4aa6aec1171776;hp=936ec5b5ac36b64a688ec01690111d657c0e5427;hb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;hpb=c94408e522e5af3b79a5beadc7e6d15cee553ee7 diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 936ec5b..4c87a12 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -1,4 +1,15 @@ +% +% (c) The University of Glasgow 2006 +% + \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module TcEnv( TyThing(..), TcTyThing(..), TcId, @@ -13,11 +24,12 @@ module TcEnv( tcLookupLocatedGlobal, tcLookupGlobal, tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, - tcLookupLocatedClass, + tcLookupLocatedClass, tcLookupFamInst, -- Local environment tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendTyVarEnv, tcExtendTyVarEnv2, + tcExtendGhciEnv, tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupId, tcLookupTyVar, getScopedTyVarBinds, @@ -38,41 +50,39 @@ module TcEnv( topIdLvl, -- New Ids - newLocalName, newDFunName + newLocalName, newDFunName, newFamInstTyConName, ) where #include "HsVersions.h" -import HsSyn ( LRuleDecl, LHsBinds, LSig, - LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds, - ExprCoFn(..), idCoercion, (<.>) ) -import TcIface ( tcImportDecl ) -import IfaceEnv ( newGlobalBinder ) +import HsSyn +import TcIface +import IfaceEnv import TcRnMonad -import TcMType ( zonkTcType, zonkTcTyVarsAndFV ) -import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType, TvSubst, - substTy, substTyVar, tyVarsOfType, tcTyVarsOfTypes, mkTyConApp, - getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy, - tidyOpenType, isRefineableTy - ) -import TcGadt ( Refinement, refineType ) -import qualified Type ( getTyVar_maybe ) -import Id ( idName, isLocalId, setIdType ) -import Var ( TyVar, Id, idType, tyVarName ) +import TcMType +import TcType +import TcGadt +-- import TcSuspension +import qualified Type +import Var import VarSet import VarEnv -import RdrName ( extendLocalRdrEnv ) -import InstEnv ( Instance, DFunId, instanceDFunId, instanceHead ) -import DataCon ( DataCon ) -import TyCon ( TyCon ) -import Class ( Class ) -import Name ( Name, NamedThing(..), getSrcLoc, nameModule ) -import PrelNames ( thFAKE ) +import RdrName +import InstEnv +import FamInstEnv +import DataCon +import TyCon +import TypeRep +import Coercion +import Class +import Name +import PrelNames import NameEnv -import OccName ( mkDFunOcc, occNameString ) -import HscTypes ( extendTypeEnvList, lookupType, TyThing(..), ExternalPackageState(..) ) -import SrcLoc ( SrcLoc, Located(..) ) +import OccName +import HscTypes +import SrcLoc import Outputable +import Maybes \end{code} @@ -100,7 +110,7 @@ tcLookupGlobal name = do { env <- getGblEnv -- Try local envt - ; case lookupNameEnv (tcg_type_env env) name of { + ; case lookupNameEnv (tcg_type_env env) name of { Just thing -> return thing ; Nothing -> do @@ -112,13 +122,15 @@ tcLookupGlobal name Nothing -> do -- Should it have been in the local envt? - { let mod = nameModule name - ; if mod == tcg_mod env || mod == thFAKE then - notFound name -- It should be local, so panic - -- The thFAKE possibility is because it - -- might be in a declaration bracket - else - tcImportDecl name -- Go find it in an interface + { case nameModule_maybe name of + Nothing -> notFound name env -- 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 + | otherwise + -> tcImportDecl name -- Go find it in an interface }}}}} tcLookupField :: Name -> TcM Id -- Returns the selector Id @@ -157,6 +169,36 @@ tcLookupLocatedClass = addLocM tcLookupClass tcLookupLocatedTyCon :: Located Name -> TcM TyCon 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. +-- +-- Return the instance tycon and its type instance. For example, if we have +-- +-- tcLookupFamInst 'T' '[Int]' yields (':R42T', 'Int') +-- +-- then we have a coercion (ie, type instance of family instance coercion) +-- +-- :Co:R42T Int :: T [Int] ~ :R42T Int +-- +-- which implies that :R42T was declared as 'data instance T [a]'. +-- +tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe (TyCon, [Type])) +tcLookupFamInst tycon tys + | not (isOpenTyCon tycon) + = return Nothing + | otherwise + = do { env <- getGblEnv + ; 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) + other -> return Nothing + } \end{code} %************************************************************************ @@ -302,12 +344,6 @@ getScopedTyVarBinds \begin{code} tcExtendIdEnv :: [TcId] -> TcM a -> TcM a --- Invariant: the TcIds are fully zonked. Reasons: --- (a) The kinds of the forall'd type variables are defaulted --- (see Kind.defaultKind, done in zonkQuantifiedTyVar) --- (b) There are no via-Indirect occurrences of the bound variables --- in the types, because instantiation does not look through such things --- (c) The call to tyVarsOfTypes is ok without looking through refs tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a @@ -316,25 +352,48 @@ tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above) tcExtendIdEnv2 names_w_ids thing_inside - = getLclEnv `thenM` \ env -> - let - extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids] - th_lvl = thLevel (tcl_th_ctxt env) - extra_env = [ (name, ATcId { tct_id = id, - tct_level = th_lvl, - tct_type = id_ty, - tct_co = if isRefineableTy id_ty - then Just idCoercion - else Nothing }) - | (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] - in - traceTc (text "env2") `thenM_` - traceTc (text "env3" <+> ppr extra_env) `thenM_` - tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' -> - (traceTc (text "env4") `thenM_` - setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside) + = do { env <- getLclEnv + ; tc_extend_local_id_env env (thLevel (tcl_th_ctxt env)) names_w_ids thing_inside } + +tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a +-- Used to bind Ids for GHCi identifiers bound earlier in the user interaction +-- Note especially that we bind them at TH level 'impLevel'. That's because it's +-- OK to use a variable bound earlier in the interaction in a splice, becuase +-- GHCi has already compiled it to bytecode +tcExtendGhciEnv ids thing_inside + = do { env <- getLclEnv + ; tc_extend_local_id_env env impLevel [(idName id, id) | id <- ids] thing_inside } + +tc_extend_local_id_env -- This is the guy who does the work + :: TcLclEnv + -> ThLevel + -> [(Name,TcId)] + -> TcM a -> TcM a +-- Invariant: the TcIds are fully zonked. Reasons: +-- (a) The kinds of the forall'd type variables are defaulted +-- (see Kind.defaultKind, done in zonkQuantifiedTyVar) +-- (b) There are no via-Indirect occurrences of the bound variables +-- in the types, because instantiation does not look through such things +-- (c) The call to tyVarsOfTypes is ok without looking through refs + +tc_extend_local_id_env env th_lvl names_w_ids thing_inside + = do { traceTc (text "env2") + ; traceTc (text "env3" <+> ppr extra_env) + ; gtvs' <- tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars + ; let env' = env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'} + ; setLclEnv env' thing_inside } + where + extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids] + extra_env = [ (name, ATcId { tct_id = id, + tct_level = th_lvl, + tct_type = id_ty, + tct_co = case isRefineableTy id_ty of + (True,_) -> Unrefineable + (_,True) -> Rigid idHsWrapper + _ -> 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] \end{code} @@ -360,7 +419,7 @@ findGlobals tvs tidy_env Just d -> go tidy_env1 (d:acc) things Nothing -> go tidy_env1 acc things - ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty) + ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty ----------------------- find_thing ignore_it tidy_env (ATcId { tct_id = id }) @@ -396,20 +455,35 @@ find_thing _ _ thing = pprPanic "find_thing" (ppr thing) \end{code} \begin{code} -refineEnvironment :: Refinement -> TcM a -> TcM a +refineEnvironment + :: Refinement + -> Bool -- whether type equations are involved + -> TcM a + -> TcM a -- I don't think I have to refine the set of global type variables in scope -- Reason: the refinement never increases that set -refineEnvironment reft thing_inside +refineEnvironment reft otherEquations thing_inside + | isEmptyRefinement reft -- Common case + , not otherEquations + = thing_inside + | otherwise = do { env <- getLclEnv ; let le' = mapNameEnv refine (tcl_env env) ; setLclEnv (env {tcl_env = le'}) thing_inside } where - refine elt@(ATcId { tct_co = Just co, tct_type = ty }) - = let (co', ty') = refineType reft ty - in elt { tct_co = Just (co' <.> co), tct_type = ty' } - refine (ATyVar tv ty) = ATyVar tv (snd (refineType reft ty)) - -- Ignore the coercion that refineType returns - refine elt = elt + refine elt@(ATcId { tct_co = Rigid co, tct_type = ty }) + | Just (co', ty') <- refineType reft ty + = elt { tct_co = Rigid (WpCo co' <.> co), tct_type = ty' } + refine elt@(ATcId { tct_co = Wobbly}) +-- Main new idea: make wobbly things invisible whenever there +-- is a refinement of any sort +-- | otherEquations + = elt { tct_co = WobblyInvisible} + refine (ATyVar tv ty) + | Just (_, ty') <- refineType reft ty + = ATyVar tv ty' -- Ignore the coercion that refineType returns + + refine elt = elt -- Common case \end{code} %************************************************************************ @@ -479,12 +553,12 @@ thLevel (Brack l _ _) = l checkWellStaged :: SDoc -- What the stage check is for - -> ThLevel -- Binding level + -> ThLevel -- Binding level (increases inside brackets) -> ThStage -- Use stage -> TcM () -- Fail if badly staged, adding an error checkWellStaged pp_thing bind_lvl use_stage - | bind_lvl <= use_lvl -- OK! - = returnM () + | use_lvl >= bind_lvl -- OK! Used later than bound + = returnM () -- E.g. \x -> [| $(f x) |] | bind_lvl == topLevel -- GHC restriction on top level splices = failWithTc $ @@ -492,7 +566,7 @@ checkWellStaged pp_thing bind_lvl use_stage nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))] | otherwise -- Badly staged - = failWithTc $ + = 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] @@ -561,24 +635,20 @@ iDFunId info = instanceDFunId (iSpec info) data InstBindings = VanillaInst -- The normal case - (LHsBinds Name) -- Bindings + (LHsBinds Name) -- Bindings for the instance methods [LSig Name] -- User pragmas recorded for generating -- specialised instances - | NewTypeDerived - (Maybe TyCon) -- maybe a coercion for the newtype - -- Used for deriving instances of newtypes, where the - [Type] -- witness dictionary is identical to the argument - -- dictionary. Hence no bindings, no pragmas - -- The [Type] are the representation types - -- See notes in TcDeriv + | NewTypeDerived -- Used for deriving instances of newtypes, where the + -- witness dictionary is identical to the argument + -- dictionary. Hence no bindings, no pragmas. pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))] 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 info = case instanceHead (iSpec info) of @@ -597,7 +667,7 @@ Make a name for the dict fun for an instance decl. It's an *external* name, like otber top-level names, and hence must be made with newGlobalBinder. \begin{code} -newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name +newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name newDFunName clas (ty:_) loc = do { index <- nextDFunIndex ; is_boot <- tcIsHsBoot @@ -606,11 +676,24 @@ newDFunName clas (ty:_) loc occNameString (getDFunTyKey ty) dfun_occ = mkDFunOcc info_string is_boot index - ; newGlobalBinder mod dfun_occ Nothing loc } + ; 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 +*external* name, like otber top-level names, and hence must be made with +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 } +\end{code} + %************************************************************************ %* * @@ -625,9 +708,11 @@ pprBinders :: [Name] -> SDoc pprBinders [bndr] = quotes (ppr bndr) pprBinders bndrs = pprWithCommas ppr bndrs -notFound name - = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+> - ptext SLIT("is not in scope")) +notFound name env + = 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)] + ) wrongThingErr expected thing name = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>