-- 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}
import CoreSyn
import Type ( Type )
+import TyCon ( TyCon )
+import Class ( Class )
import PrimOp ( PrimOp )
import NameEnv ( NameEnv, lookupNameEnv )
import Name ( Name )
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*
-- 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
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]")
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
| 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
{-# 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
--
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 )
= 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
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
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(..) )
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
-- 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
\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
= 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
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
TyThing(..), TyThingDetails(..), TcTyThing(..), TcId,
-- Instance environment, and InstInfo type
- tcGetInstEnv, tcSetInstEnv,
+ tcGetInstEnv,
InstInfo(..), pprInstInfo, pprInstInfoDetails,
simpleInstInfoTy, simpleInstInfoTyCon,
InstBindings(..),
lclEnvElts, getInLocalScope, findGlobals,
-- Instance environment
- tcExtendLocalInstEnv, tcExtendInstEnv,
+ tcExtendLocalInstEnv, tcExtendInstEnv, tcExtendTempInstEnv, tcWithTempInstEnv,
-- Rules
tcExtendRules,
\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
; 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}
| (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_`
-- 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) $
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
-- 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.
import FiniteMap
import Outputable
import ListSetOps ( equivClasses )
-import Util ( zipEqual )
+import Util ( zipEqual, isSingleton )
import List ( partition )
import CmdLineOpts
\end{code}
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)
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 )
%************************************************************************
%* *
-\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))
text "======>",
nest 2 after])])
+illegalBracket level
+ = ptext SLIT("Illegal bracket at level") <+> ppr level
+
illegalSplice level
= ptext SLIT("Illegal splice at level") <+> ppr level
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 )
| 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]
projects / ghc-hetmet.git / commitdiff