From 3355c9d53b220ccb110e5a3c81a1a8b2c9c41555 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 19 Feb 2003 15:54:12 +0000 Subject: [PATCH] [project @ 2003-02-19 15:54:05 by simonpj] ------------------------------------- Two minor wibbles ------------------------------------- 1. Make the generic toT/fromT Ids for "generic derived classes" into proper ImplicitIds, with their own GlobalIdDetails. This makes it easier to identify them. (The lack of this showed up as a bug when I made an apparently-innocuous other change.) 2. Distinguish ClassOpIds from RecordSelIds in their GlobalIdDetails. They are treated differently here and there, so I made this change as part of (1) 3. Ensure that a declaration quotation [d| ... |] does not have a permanent effect on the instance environment. (A TH fix.) --- ghc/compiler/basicTypes/Id.lhs | 8 +++-- ghc/compiler/basicTypes/IdInfo.lhs | 7 +++++ ghc/compiler/basicTypes/MkId.lhs | 4 +-- ghc/compiler/coreSyn/CoreUtils.lhs | 2 +- ghc/compiler/ghci/InteractiveUI.hs | 15 +++++----- ghc/compiler/rename/RnIfaces.lhs | 2 ++ ghc/compiler/typecheck/TcDeriv.lhs | 44 +++++++++------------------- ghc/compiler/typecheck/TcEnv.lhs | 52 ++++++++++++++++++++------------- ghc/compiler/typecheck/TcExpr.lhs | 37 ++--------------------- ghc/compiler/typecheck/TcRnTypes.lhs | 5 ++++ ghc/compiler/typecheck/TcSimplify.lhs | 6 ++-- ghc/compiler/typecheck/TcSplice.lhs | 42 ++++++++++++++++++++++---- ghc/compiler/types/Generics.lhs | 10 ++++--- 13 files changed, 124 insertions(+), 110 deletions(-) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 8386115..ca0de3c 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -289,15 +289,17 @@ isImplicitId :: Id -> Bool -- file, even if it's mentioned in some other interface unfolding. isImplicitId id = case globalIdDetails id of - RecordSelId _ -> True -- Includes dictionary selectors + RecordSelId _ -> True FCallId _ -> True PrimOpId _ -> True + ClassOpId _ -> True + GenericOpId _ -> True DataConWorkId _ -> True DataConWrapId _ -> True -- These are are implied by their type or class decl; -- remember that all type and class decls appear in the interface file. - -- The dfun id must *not* be omitted, because it carries version info for - -- the instance decl + -- The dfun id is not an implicit Id; it must *not* be omitted, because + -- it carries version info for the instance decl other -> False \end{code} diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index bc38b8c..6e871ba 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -81,6 +81,8 @@ module IdInfo ( import CoreSyn import Type ( Type ) +import TyCon ( TyCon ) +import Class ( Class ) import PrimOp ( PrimOp ) import NameEnv ( NameEnv, lookupNameEnv ) import Name ( Name ) @@ -234,6 +236,7 @@ an IdInfo.hi-boot, but no Id.hi-boot, and GlobalIdDetails is imported data GlobalIdDetails = VanillaGlobal -- Imported from elsewhere, a default method Id. + | GenericOpId TyCon -- The to/from operations of a | RecordSelId FieldLabel -- The Id for a record selector | DataConWorkId DataCon -- The Id for a data constructor *worker* | DataConWrapId DataCon -- The Id for a data constructor *wrapper* @@ -242,6 +245,8 @@ data GlobalIdDetails -- b) when typechecking a pattern we can get from the -- Id back to the data con] + | ClassOpId Class -- An operation of a class + | PrimOpId PrimOp -- The Id for a primitive operator | FCallId ForeignCall -- The Id for a foreign call @@ -252,8 +257,10 @@ notGlobalId = NotGlobalId instance Outputable GlobalIdDetails where ppr NotGlobalId = ptext SLIT("[***NotGlobalId***]") ppr VanillaGlobal = ptext SLIT("[GlobalId]") + ppr (GenericOpId _) = ptext SLIT("[GenericOp]") ppr (DataConWorkId _) = ptext SLIT("[DataCon]") ppr (DataConWrapId _) = ptext SLIT("[DataConWrapper]") + ppr (ClassOpId _) = ptext SLIT("[ClassOp]") ppr (PrimOpId _) = ptext SLIT("[PrimOp]") ppr (FCallId _) = ptext SLIT("[ForeignCall]") ppr (RecordSelId _) = ptext SLIT("[RecSel]") diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 8be5844..f42f178 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -602,12 +602,10 @@ This is unlike ordinary record selectors, which have all the for-alls at the outside. When dealing with classes it's very convenient to recover the original type signature from the class op selector. -ToDo: unify with mkRecordSelId? - \begin{code} mkDictSelId :: Name -> Class -> Id mkDictSelId name clas - = mkGlobalId (RecordSelId field_lbl) name sel_ty info + = mkGlobalId (ClassOpId clas) name sel_ty info where sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id)) -- We can't just say (exprType rhs), because that would give a type diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index d2f04c4..9de9bf1 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -448,7 +448,7 @@ idAppIsCheap id n_val_args | otherwise = case globalIdDetails id of DataConWorkId _ -> True RecordSelId _ -> True -- I'm experimenting with making record selection - -- look cheap, so we will substitute it inside a + ClassOpId _ -> True -- look cheap, so we will substitute it inside a -- lambda. Particularly for dictionary field selection PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index a9b4f94..125c899 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.145 2003/02/17 12:24:26 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.146 2003/02/19 15:54:07 simonpj Exp $ -- -- GHC Interactive User Interface -- @@ -26,7 +26,8 @@ import DriverUtil ( remove_spaces, handle ) import Linker ( initLinker, showLinkerState, linkLibraries, linkPackages ) import Util -import Id ( isRecordSelector, isImplicitId, recordSelectorFieldLabel, idName ) +import IdInfo ( GlobalIdDetails(..) ) +import Id ( isImplicitId, idName ) import Class ( className ) import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) ) import DataCon ( dataConName ) @@ -513,12 +514,10 @@ info s = do = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)] idDescr id - | isRecordSelector id = - case tyConClass_maybe (fieldLabelTyCon ( - recordSelectorFieldLabel id)) of - Nothing -> text "record selector" - Just c -> text "method in class " <> ppr c - | otherwise = text "variable" + = case globalIdDetails id of + RecordSelId lbl -> text "record selector for type" <+> ppr (fieldLabelTyCon lbl) + ClassOpId cls -> text "method in class" <+> ppr cls + otherwise -> text "variable" -- also print out the source location for home things showSrcLoc name diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 8a11006..5a4bd8e 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -199,6 +199,8 @@ get_main_name (AnId id) DataConWorkId dc -> get_main_name (ATyCon (dataConTyCon dc)) DataConWrapId dc -> get_main_name (ATyCon (dataConTyCon dc)) RecordSelId lbl -> get_main_name (ATyCon (fieldLabelTyCon lbl)) + GenericOpId tc -> get_main_name (ATyCon tc) + ClassOpId cl -> className cl other -> idName id diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 8a4ea72..c7b7d64 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -17,18 +17,18 @@ import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds, RenamedTyClDecl, RenamedHsPr import CmdLineOpts ( DynFlag(..) ) import TcRnMonad -import TcEnv ( tcGetInstEnv, tcSetInstEnv, newDFunName, +import TcEnv ( tcExtendTempInstEnv, newDFunName, InstInfo(..), pprInstInfo, InstBindings(..), pprInstInfoDetails, tcLookupTyCon, tcExtendTyVarEnv ) import TcGenDeriv -- Deriv stuff -import InstEnv ( InstEnv, simpleDFunClassTyCon, extendInstEnv ) +import InstEnv ( InstEnv, simpleDFunClassTyCon ) import TcMonoType ( tcHsPred ) import TcSimplify ( tcSimplifyDeriv ) import RnBinds ( rnMethodBinds, rnTopMonoBinds ) import RnEnv ( bindLocalsFVRn ) -import TcRnMonad ( thenM, returnM, mapAndUnzipM ) +import TcRnMonad ( thenM, returnM, mapAndUnzipM ) import HscTypes ( DFunId ) import BasicTypes ( NewOrData(..) ) @@ -199,18 +199,15 @@ tcDeriving :: [RenamedTyClDecl] -- All type constructors tcDeriving tycl_decls = recoverM (returnM ([], EmptyBinds, emptyFVs)) $ getDOpts `thenM` \ dflags -> - tcGetInstEnv `thenM` \ inst_env -> -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". makeDerivEqns tycl_decls `thenM` \ (ordinary_eqns, newtype_inst_info) -> - let + tcExtendTempInstEnv (map iDFunId newtype_inst_info) $ -- Add the newtype-derived instances to the inst env -- before tacking the "ordinary" ones - inst_env1 = extend_inst_env dflags inst_env - (map iDFunId newtype_inst_info) - in - deriveOrdinaryStuff inst_env1 ordinary_eqns `thenM` \ (ordinary_inst_info, binds, fvs) -> + + deriveOrdinaryStuff ordinary_eqns `thenM` \ (ordinary_inst_info, binds, fvs) -> let inst_info = newtype_inst_info ++ ordinary_inst_info in @@ -230,14 +227,14 @@ tcDeriving tycl_decls -- pprInstInfo doesn't print much: only the type ----------------------------------------- -deriveOrdinaryStuff inst_env_in [] -- Short cut +deriveOrdinaryStuff [] -- Short cut = returnM ([], EmptyBinds, emptyFVs) -deriveOrdinaryStuff inst_env_in eqns +deriveOrdinaryStuff eqns = -- Take the equation list and solve it, to deliver a list of -- solutions, a.k.a. the contexts for the instance decls -- required for the corresponding equations. - solveDerivEqns inst_env_in eqns `thenM` \ new_dfuns -> + solveDerivEqns eqns `thenM` \ new_dfuns -> -- Now augment the InstInfos, adding in the rather boring -- actual-code-to-do-the-methods binds. We may also need to @@ -552,12 +549,11 @@ ordered by sorting on type varible, tv, (major key) and then class, k, \end{itemize} \begin{code} -solveDerivEqns :: InstEnv - -> [DerivEqn] +solveDerivEqns :: [DerivEqn] -> TcM [DFunId] -- Solns in same order as eqns. -- This bunch is Absolutely minimal... -solveDerivEqns inst_env_in orig_eqns +solveDerivEqns orig_eqns = iterateDeriv 1 initial_solutions where -- The initial solutions for the equations claim that each @@ -579,15 +575,13 @@ solveDerivEqns inst_env_in orig_eqns = pprPanic "solveDerivEqns: probable loop" (vcat (map pprDerivEqn orig_eqns) $$ ppr current_solns) | otherwise - = getDOpts `thenM` \ dflags -> - let - dfuns = zipWithEqual "add_solns" mk_deriv_dfun orig_eqns current_solns - inst_env = extend_inst_env dflags inst_env_in dfuns + = let + dfuns = zipWithEqual "add_solns" mk_deriv_dfun orig_eqns current_solns in checkNoErrs ( -- Extend the inst info from the explicit instance decls -- with the current set of solutions, and simplify each RHS - tcSetInstEnv inst_env $ + tcExtendTempInstEnv dfuns $ mappM gen_soln orig_eqns ) `thenM` \ new_solns -> if (current_solns == new_solns) then @@ -602,16 +596,6 @@ solveDerivEqns inst_env_in orig_eqns addErrCtxt (derivCtxt (Just clas) tc) $ tcSimplifyDeriv tyvars deriv_rhs `thenM` \ theta -> returnM (sortLt (<) theta) -- Canonicalise before returning the soluction -\end{code} - -\begin{code} -extend_inst_env dflags inst_env new_dfuns - = new_inst_env - where - (new_inst_env, _errs) = extendInstEnv dflags inst_env new_dfuns - -- Ignore the errors about duplicate instances. - -- We don't want repeated error messages - -- They'll appear later, when we do the top-level extendInstEnvs mk_deriv_dfun (dfun_name, clas, tycon, tyvars, _) theta = mkDictFunId dfun_name tyvars theta diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index e29223b..afbaa61 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -3,7 +3,7 @@ module TcEnv( TyThing(..), TyThingDetails(..), TcTyThing(..), TcId, -- Instance environment, and InstInfo type - tcGetInstEnv, tcSetInstEnv, + tcGetInstEnv, InstInfo(..), pprInstInfo, pprInstInfoDetails, simpleInstInfoTy, simpleInstInfoTyCon, InstBindings(..), @@ -25,7 +25,7 @@ module TcEnv( lclEnvElts, getInLocalScope, findGlobals, -- Instance environment - tcExtendLocalInstEnv, tcExtendInstEnv, + tcExtendLocalInstEnv, tcExtendInstEnv, tcExtendTempInstEnv, tcWithTempInstEnv, -- Rules tcExtendRules, @@ -552,23 +552,7 @@ from this module \begin{code} tcGetInstEnv :: TcM InstEnv -tcGetInstEnv = getGblEnv `thenM` \ env -> - readMutVar (tcg_inst_env env) - -tcSetInstEnv :: InstEnv -> TcM a -> TcM a --- Horribly imperative; --- but used only when temporarily enhancing the instance --- envt during 'deriving' context inference -tcSetInstEnv ie thing_inside - = getGblEnv `thenM` \ env -> - let - ie_var = tcg_inst_env env - in - readMutVar ie_var `thenM` \ old_ie -> - writeMutVar ie_var ie `thenM_` - thing_inside `thenM` \ result -> - writeMutVar ie_var old_ie `thenM_` - returnM result +tcGetInstEnv = do { env <- getGblEnv; readMutVar (tcg_inst_env env) } tcExtendInstEnv :: [DFunId] -> TcM a -> TcM a -- Add instances from local or imported @@ -615,10 +599,38 @@ tcExtendLocalInstEnv infos thing_inside ; writeMutVar ie_var inst_env' ; setGblEnv env' thing_inside } +tcExtendTempInstEnv :: [DFunId] -> TcM a -> TcM a + -- Extend the instance envt, but with *no* permanent + -- effect on mutable variables; also ignore errors + -- Used during 'deriving' stuff +tcExtendTempInstEnv dfuns thing_inside + = do { dflags <- getDOpts + ; env <- getGblEnv + ; let ie_var = tcg_inst_env env + ; inst_env <- readMutVar ie_var + ; let (inst_env', errs) = extendInstEnv dflags inst_env dfuns + -- Ignore the errors about duplicate instances. + -- We don't want repeated error messages + -- They'll appear later, when we do the top-level extendInstEnvs + ; writeMutVar ie_var inst_env' + ; result <- thing_inside + ; writeMutVar ie_var inst_env -- Restore! + ; return result } + +tcWithTempInstEnv :: TcM a -> TcM a +-- Run thing_inside, discarding any effects on the instance environment +tcWithTempInstEnv thing_inside + = do { env <- getGblEnv + ; let ie_var = tcg_inst_env env + ; old_ie <- readMutVar ie_var + ; result <- thing_inside + ; writeMutVar ie_var old_ie -- Restore + ; return result } + traceDFuns dfuns = traceTc (text "Adding instances:" <+> vcat (map pp dfuns)) where - pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun) + pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun) \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index fcf9376..0f69371 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -445,12 +445,8 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids, not (is_selector maybe_sel_id) ] - is_selector (Just (AnId sel_id)) - = isRecordSelector sel_id && -- At the moment, class ops are - -- treated as record selectors, but - -- we want to exclude that case here - not (isClassTyCon (fieldLabelTyCon (recordSelectorFieldLabel sel_id))) - is_selector other = False + is_selector (Just (AnId sel_id)) = isRecordSelector sel_id -- Excludes class ops + is_selector other = False in checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM) `thenM_` @@ -620,31 +616,7 @@ tcMonoExpr (PArrSeqIn _) _ -- Rename excludes these cases otherwise tcMonoExpr (HsSplice n expr loc) res_ty = addSrcLoc loc (tcSpliceExpr n expr res_ty) - -tcMonoExpr (HsBracket brack loc) res_ty - = addSrcLoc loc $ - getStage `thenM` \ level -> - case bracketOK level of { - Nothing -> failWithTc (illegalBracket level) ; - Just next_level -> - - -- Typecheck expr to make sure it is valid, - -- but throw away the results. We'll type check - -- it again when we actually use it. - newMutVar [] `thenM` \ pending_splices -> - getLIEVar `thenM` \ lie_var -> - - setStage (Brack next_level pending_splices lie_var) ( - getLIE (tcBracket brack) - ) `thenM` \ (meta_ty, lie) -> - tcSimplifyBracket lie `thenM_` - - unifyTauTy res_ty meta_ty `thenM_` - - -- Return the original expression, not the type-decorated one - readMutVar pending_splices `thenM` \ pendings -> - returnM (HsBracketOut brack pendings) - } +tcMonoExpr (HsBracket brack loc) res_ty = addSrcLoc loc (tcBracket brack) tcMonoExpr (HsReify (Reify flavour name)) res_ty = addErrCtxt (ptext SLIT("At the reification of") <+> ppr name) $ @@ -1093,9 +1065,6 @@ parrCtxt expr predCtxt expr = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr) -illegalBracket level - = ptext SLIT("Illegal bracket at level") <+> ppr level - appCtxt fun args = ptext SLIT("In the application") <+> quotes (ppr the_app) where diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 790911b..1e58edd 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -283,6 +283,11 @@ data TcGblEnv -- and then in the mutable EPS, because the InstEnv for this module -- is constructed (in principle at least) only from the modules -- 'below' this one, so it's this-module-specific + -- + -- On the other hand, a declaration quote [d| ... |] may introduce + -- some new instance declarations that we *don't* want to persist + -- outside the quote, so we tiresomely need to revert the InstEnv + -- after finishing the quote (see TcSplice.tcBracket) -- Now a bunch of things about this module that are simply -- accumulated, but never consulted until the end. diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 6c845aa..6f8ed08 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -63,7 +63,7 @@ import VarEnv ( TidyEnv ) import FiniteMap import Outputable import ListSetOps ( equivClasses ) -import Util ( zipEqual ) +import Util ( zipEqual, isSingleton ) import List ( partition ) import CmdLineOpts \end{code} @@ -1969,8 +1969,10 @@ addTopAmbigErrs (tidy_env, tidy_dicts) where dicts = map fst pairs msg = sep [text "Ambiguous type variable" <> plural tvs <+> - pprQuotedList tvs <+> text "in these top-level constraint" <> plural dicts, + pprQuotedList tvs <+> in_msg, nest 2 (pprInstsInFull dicts)] + in_msg | isSingleton dicts = text "in the top-level constraint:" + | otherwise = text "in these top-level constraints:" mkMonomorphismMsg :: TidyEnv -> [Inst] -> TcM (TidyEnv, Message) diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index b893dcc..d191fcd 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -25,7 +25,7 @@ import TcExpr ( tcMonoExpr ) import TcHsSyn ( TcExpr, TypecheckedHsExpr, mkHsLet, zonkTopExpr ) import TcSimplify ( tcSimplifyTop ) import TcType ( TcType, openTypeKind, mkAppTy ) -import TcEnv ( spliceOK, tcMetaTy ) +import TcEnv ( spliceOK, tcMetaTy, tcWithTempInstEnv ) import TcRnTypes ( TopEnv(..) ) import TcMType ( newTyVarTy, zapToType ) import Name ( Name ) @@ -63,20 +63,49 @@ tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e) %************************************************************************ %* * -\subsection{Splicing an expression} +\subsection{Quoting an expression} %* * %************************************************************************ \begin{code} tcBracket :: HsBracket Name -> TcM TcType -tcBracket (ExpBr expr) +tcBracket brack + = getStage `thenM` \ level -> + case bracketOK level of { + Nothing -> failWithTc (illegalBracket level) ; + Just next_level -> + + -- Typecheck expr to make sure it is valid, + -- but throw away the results. We'll type check + -- it again when we actually use it. + newMutVar [] `thenM` \ pending_splices -> + getLIEVar `thenM` \ lie_var -> + + setStage (Brack next_level pending_splices lie_var) ( + getLIE (tc_bracket brack) + ) `thenM` \ (meta_ty, lie) -> + tcSimplifyBracket lie `thenM_` + + unifyTauTy res_ty meta_ty `thenM_` + + -- Return the original expression, not the type-decorated one + readMutVar pending_splices `thenM` \ pendings -> + returnM (HsBracketOut brack pendings) + } + +tc_bracket (ExpBr expr) = newTyVarTy openTypeKind `thenM` \ any_ty -> tcMonoExpr expr any_ty `thenM_` tcMetaTy exprTyConName -- Result type is Expr (= Q Exp) -tcBracket (DecBr decls) - = tcTopSrcDecls decls `thenM_` +tc_bracket (DecBr decls) + = tcWithTempInstEnv (tcTopSrcDecls decls) `thenM_` + -- Typecheck the declarations, dicarding any side effects + -- on the instance environment (which is in a mutable variable) + -- and the extended environment. We'll get all that stuff + -- later, when we splice it in + tcMetaTy decTyConName `thenM` \ decl_ty -> tcMetaTy qTyConName `thenM` \ q_ty -> returnM (mkAppTy q_ty (mkListTy decl_ty)) @@ -364,6 +393,9 @@ showSplice what before after text "======>", nest 2 after])]) +illegalBracket level + = ptext SLIT("Illegal bracket at level") <+> ppr level + illegalSplice level = ptext SLIT("Illegal splice at level") <+> ppr level diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 3a596e7..20bc33a 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -25,13 +25,13 @@ import CoreUtils ( exprArity ) import BasicTypes ( EP(..), Boxity(..) ) import Var ( TyVar ) import VarSet ( varSetElems ) -import Id ( Id, mkVanillaGlobal, idType, idName, mkSysLocal ) +import Id ( Id, mkGlobalId, idType, idName, mkSysLocal ) import MkId ( mkReboxingAlt, mkNewTypeBody ) import TysWiredIn ( genericTyCons, genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon, inlDataCon, crossTyCon, crossDataCon ) -import IdInfo ( noCafIdInfo, setUnfoldingInfo, setArityInfo ) +import IdInfo ( GlobalIdDetails(..), noCafIdInfo, setUnfoldingInfo, setArityInfo ) import CoreUnfold ( mkTopUnfolding ) import Maybe ( isNothing ) @@ -261,9 +261,11 @@ mkTyConGenInfo tycon [from_name, to_name] | otherwise = ASSERT( not (null datacons) ) -- mk_sum_stuff loops if no datacons - Just (EP { fromEP = mkVanillaGlobal from_name from_ty from_id_info, - toEP = mkVanillaGlobal to_name to_ty to_id_info }) + Just (EP { fromEP = mk_id from_name from_ty from_id_info, + toEP = mk_id to_name to_ty to_id_info }) where + mk_id = mkGlobalId (GenericOpId tycon) + maybe_datacons = tyConDataCons_maybe tycon Just datacons = maybe_datacons -- [C, D] -- 1.7.10.4