Commit 3355c9d5 authored by simonpj's avatar simonpj

[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.)
parent f761d6d0
......@@ -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}
......
......@@ -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]")
......
......@@ -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
......
......@@ -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
......
{-# 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
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......
......@@ -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
......
......@@ -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.
......
......@@ -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)
......
......@@ -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
......
......@@ -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]
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment