tcGetGlobalTyVars,
-- Template Haskell stuff
- checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel,
+ checkWellStaged, tcMetaTy, thLevel,
topIdLvl, thTopLevelId, thRnBrack, isBrackStage,
-- New Ids
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
-- 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
}}}}}
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
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]
_ -> 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}
%************************************************************************
\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"
-- $( 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
-- specialised instances
Bool -- True <=> This code came from a standalone deriving clause
- | 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
+ | 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))]
pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
where
details (VanillaInst b _ _) = pprLHsBinds b
- details (NewTypeDerived _) = text "Derived from the representation type"
+ details (NewTypeDerived {}) = text "Derived from the representation type"
simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
simpleInstInfoClsTy info = case instanceHead (iSpec info) of
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
projects / ghc-hetmet.git / blobdiff