%
\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,
tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
lclEnvElts, getInLocalScope, findGlobals,
wrongThingErr, pprBinders,
- refineEnvironment,
tcExtendRecEnv, -- For knot-tying
-- Template Haskell stuff
checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel,
- topIdLvl,
+ topIdLvl, thTopLevelId,
-- New Ids
newLocalName, newDFunName, newFamInstTyConName,
import TcRnMonad
import TcMType
import TcType
-import TcGadt
-- import TcSuspension
import qualified Type
import Var
import DataCon
import TyCon
import TypeRep
-import Coercion
import Class
import Name
import PrelNames
import SrcLoc
import Outputable
import Maybes
+import FastString
\end{code}
= 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
-- Should it have been in the local envt?
{ case nameModule_maybe name of
- Nothing -> notFound name -- Internal names can happen in GHCi
+ Nothing -> notFound name env -- Internal names can happen in GHCi
Just mod | mod == tcg_mod env -- Names from this module
- -> notFound name -- should be in tcg_type_env
+ -> notFound name env -- should be in tcg_type_env
| mod == thFAKE -- Names bound in TH declaration brackets
- -> notFound name -- should be in tcg_env
+ -> 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
- = tcLookupGlobal name `thenM` \ thing ->
+tcLookupField name = do
+ thing <- tcLookup name -- Note [Record field lookup]
case thing of
- AnId id -> return id
- other -> wrongThingErr "field name" (AGlobal thing) name
+ AGlobal (AnId id) -> return id
+ thing -> wrongThingErr "field name" thing name
+
+{- Note [Record field lookup]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~
+You might think we should have tcLookupGlobal here, since record fields
+are always top level. But consider
+ f = e { f = True }
+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
+error, not in TcEnv.notFound. -}
tcLookupDataCon :: Name -> TcM DataCon
-tcLookupDataCon name
- = tcLookupGlobal name `thenM` \ thing ->
+tcLookupDataCon name = do
+ thing <- tcLookupGlobal name
case thing of
ADataCon con -> return con
- other -> wrongThingErr "data constructor" (AGlobal thing) name
+ _ -> wrongThingErr "data constructor" (AGlobal thing) name
tcLookupClass :: Name -> TcM Class
-tcLookupClass name
- = tcLookupGlobal name `thenM` \ thing ->
+tcLookupClass name = do
+ thing <- tcLookupGlobal name
case thing of
AClass cls -> return cls
- other -> wrongThingErr "class" (AGlobal thing) name
-
+ _ -> wrongThingErr "class" (AGlobal thing) name
+
tcLookupTyCon :: Name -> TcM TyCon
-tcLookupTyCon name
- = tcLookupGlobal name `thenM` \ thing ->
+tcLookupTyCon name = do
+ thing <- tcLookupGlobal name
case thing of
ATyCon tc -> return tc
- other -> wrongThingErr "type constructor" (AGlobal thing) name
+ _ -> wrongThingErr "type constructor" (AGlobal thing) name
tcLookupLocatedGlobalId :: Located Name -> TcM Id
tcLookupLocatedGlobalId = addLocM tcLookupId
; case lookupFamInstEnv instEnv tycon tys of
[(fam_inst, rep_tys)] -> return $ Just (famInstTyCon fam_inst,
rep_tys)
- other -> return Nothing
+ _ -> return Nothing
}
\end{code}
tcLookupLocated = addLocM tcLookup
tcLookup :: Name -> TcM TcTyThing
-tcLookup name
- = getLclEnv `thenM` \ local_env ->
+tcLookup name = do
+ local_env <- getLclEnv
case lookupNameEnv (tcl_env local_env) name of
- Just thing -> returnM thing
- Nothing -> tcLookupGlobal name `thenM` \ thing ->
- returnM (AGlobal thing)
+ Just thing -> return thing
+ Nothing -> AGlobal <$> tcLookupGlobal name
tcLookupTyVar :: Name -> TcM TcTyVar
-tcLookupTyVar name
- = tcLookup name `thenM` \ thing ->
+tcLookupTyVar name = do
+ thing <- tcLookup name
case thing of
ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty)
- other -> pprPanic "tcLookupTyVar" (ppr name)
+ _ -> pprPanic "tcLookupTyVar" (ppr name)
tcLookupId :: Name -> TcM Id
-- Used when we aren't interested in the binding level, nor refinement.
-- The "no refinement" part means that we return the un-refined Id regardless
--
-- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
-tcLookupId name
- = tcLookup name `thenM` \ thing ->
+tcLookupId name = do
+ thing <- tcLookup name
case thing of
- ATcId { tct_id = id} -> returnM id
- AGlobal (AnId id) -> returnM id
- other -> pprPanic "tcLookupId" (ppr name)
+ ATcId { tct_id = id} -> return id
+ AGlobal (AnId id) -> return id
+ _ -> pprPanic "tcLookupId" (ppr name)
tcLookupLocalIds :: [Name] -> TcM [TcId]
-- We expect the variables to all be bound, and all at
-- the same level as the lookup. Only used in one place...
-tcLookupLocalIds ns
- = getLclEnv `thenM` \ env ->
- returnM (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
+tcLookupLocalIds ns = do
+ env <- getLclEnv
+ return (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
where
lookup lenv lvl name
= case lookupNameEnv lenv name of
Just (ATcId { tct_id = id, tct_level = lvl1 })
-> ASSERT( lvl == lvl1 ) id
- other -> pprPanic "tcLookupLocalIds" (ppr name)
+ _ -> pprPanic "tcLookupLocalIds" (ppr name)
lclEnvElts :: TcLclEnv -> [TcTyThing]
lclEnvElts env = nameEnvElts (tcl_env env)
getInLocalScope :: TcM (Name -> Bool)
-- Ids only
-getInLocalScope = getLclEnv `thenM` \ env ->
- let
- lcl_env = tcl_env env
- in
- return (`elemNameEnv` lcl_env)
+getInLocalScope = do
+ env <- getLclEnv
+ let lcl_env = tcl_env env
+ return (`elemNameEnv` lcl_env)
\end{code}
\begin{code}
= tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
-tcExtendTyVarEnv2 binds thing_inside
- = getLclEnv `thenM` \ env@(TcLclEnv {tcl_env = le,
- tcl_tyvars = gtvs,
- tcl_rdr = rdr_env}) ->
+tcExtendTyVarEnv2 binds thing_inside = do
+ env@(TcLclEnv {tcl_env = le,
+ tcl_tyvars = gtvs,
+ tcl_rdr = rdr_env}) <- getLclEnv
let
rdr_env' = extendLocalRdrEnv rdr_env (map fst binds)
new_tv_set = tcTyVarsOfTypes (map snd binds)
le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
- in
+
-- It's important to add the in-scope tyvars to the global tyvar set
-- as well. Consider
-- f (_::r) = let g y = y::r in ...
-- Here, g mustn't be generalised. This is also important during
-- class and instance decls, when we mustn't generalise the class tyvars
-- when typechecking the methods.
- tc_extend_gtvs gtvs new_tv_set `thenM` \ gtvs' ->
+ gtvs' <- tc_extend_gtvs gtvs new_tv_set
setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
getScopedTyVarBinds :: TcM [(Name, TcType)]
-> TidyEnv
-> TcM (TidyEnv, [SDoc])
-findGlobals tvs tidy_env
- = getLclEnv `thenM` \ lcl_env ->
+findGlobals tvs tidy_env = do
+ lcl_env <- getLclEnv
go tidy_env [] (lclEnvElts lcl_env)
where
- go tidy_env acc [] = returnM (tidy_env, acc)
- go tidy_env acc (thing : things)
- = find_thing ignore_it tidy_env thing `thenM` \ (tidy_env1, maybe_doc) ->
+ go tidy_env acc [] = return (tidy_env, acc)
+ go tidy_env acc (thing : things) = do
+ (tidy_env1, maybe_doc) <- find_thing ignore_it tidy_env thing
case maybe_doc of
Just d -> go tidy_env1 (d:acc) things
Nothing -> go tidy_env1 acc things
ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
-----------------------
-find_thing ignore_it tidy_env (ATcId { tct_id = id })
- = zonkTcType (idType id) `thenM` \ id_ty ->
+find_thing :: (TcType -> Bool) -> TidyEnv -> TcTyThing
+ -> TcM (TidyEnv, Maybe SDoc)
+find_thing ignore_it tidy_env (ATcId { tct_id = id }) = do
+ id_ty <- zonkTcType (idType id)
if ignore_it id_ty then
- returnM (tidy_env, Nothing)
- else let
+ return (tidy_env, Nothing)
+ else let
(tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
- nest 2 (parens (ptext SLIT("bound at") <+>
+ nest 2 (parens (ptext (sLit "bound at") <+>
ppr (getSrcLoc id)))]
- in
- returnM (tidy_env', Just msg)
+ in
+ return (tidy_env', Just msg)
-find_thing ignore_it tidy_env (ATyVar tv ty)
- = zonkTcType ty `thenM` \ tv_ty ->
+find_thing ignore_it tidy_env (ATyVar tv ty) = do
+ tv_ty <- zonkTcType ty
if ignore_it tv_ty then
- returnM (tidy_env, Nothing)
- else let
+ return (tidy_env, Nothing)
+ else let
-- The name tv is scoped, so we don't need to tidy it
(tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
- msg = sep [ptext SLIT("Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
+ msg = sep [ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty,
getOccName tv == getOccName tv' = empty
| otherwise = equals <+> ppr tidy_ty
-- It's ok to use Type.getTyVar_maybe because ty is zonked by now
- bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
- in
- returnM (tidy_env1, Just msg)
+ bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
+ in
+ return (tidy_env1, Just msg)
find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
\end{code}
-\begin{code}
-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 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 = 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}
-
%************************************************************************
%* *
\subsection{The global tyvars}
%************************************************************************
\begin{code}
-tc_extend_gtvs gtvs extra_global_tvs
- = readMutVar gtvs `thenM` \ global_tvs ->
+tc_extend_gtvs :: IORef VarSet -> VarSet -> TcM (IORef VarSet)
+tc_extend_gtvs gtvs extra_global_tvs = do
+ global_tvs <- readMutVar gtvs
newMutVar (global_tvs `unionVarSet` extra_global_tvs)
\end{code}
\begin{code}
tcGetGlobalTyVars :: TcM TcTyVarSet
-tcGetGlobalTyVars
- = getLclEnv `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
- readMutVar gtv_var `thenM` \ gbl_tvs ->
- zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenM` \ gbl_tvs' ->
- writeMutVar gtv_var gbl_tvs' `thenM_`
- returnM gbl_tvs'
+tcGetGlobalTyVars = do
+ (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv
+ gbl_tvs <- readMutVar gtv_var
+ gbl_tvs' <- zonkTcTyVarsAndFV (varSetElems gbl_tvs)
+ writeMutVar gtv_var gbl_tvs'
+ return gbl_tvs'
\end{code}
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
+ = return () -- E.g. \x -> [| $(f x) |]
| 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"))]
+ 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"))]
| otherwise -- Badly staged
- = failWithTc $
- 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]
+ = 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
-- Given the name of a Template Haskell data type,
-- return the type
-- E.g. given the name "Expr" return the type "Expr"
-tcMetaTy tc_name
- = tcLookupTyCon tc_name `thenM` \ t ->
- returnM (mkTyConApp t [])
+tcMetaTy tc_name = do
+ t <- tcLookupTyCon tc_name
+ return (mkTyConApp t [])
+
+thTopLevelId :: Id -> Bool
+-- See Note [What is a top-level Id?] in TcSplice
+thTopLevelId id = isGlobalId id || isExternalName (idName id)
\end{code}
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
| 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))]
+pprInstInfo :: InstInfo a -> SDoc
+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"
-simpleInstInfoClsTy :: InstInfo -> (Class, Type)
+simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
simpleInstInfoClsTy info = case instanceHead (iSpec info) of
- (_, _, cls, [ty]) -> (cls, ty)
+ (_, _, 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)
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 -> TcGblEnv -> TcM TyThing
+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 :: String -> TcTyThing -> Name -> TcM a
wrongThingErr expected thing name
= failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
- ptext SLIT("used as a") <+> text expected)
+ ptext (sLit "used as a") <+> text expected)
\end{code}
projects / ghc-hetmet.git / blobdiff