other -> notFound "tcLookupGlobal" name
tcLookupGlobalId :: Name -> TcM Id
+-- Never used for Haskell-source DataCons, hence no ADataCon case
tcLookupGlobalId name
= tcLookupGlobal_maybe name `thenM` \ maybe_thing ->
case maybe_thing of
- Just (AnId id) -> returnM id
-
- -- When typechecking Haskell source, occurrences of
- -- data constructors use the "source name", which maps
- -- to ADataCon; we want the wrapper instead
- Just (ADataCon dc) -> returnM (dataConWrapId dc)
-
- other -> notFound "tcLookupGlobal (id)" name
+ Just (AnId id) -> returnM id
+ other -> notFound "tcLookupGlobal (id)" name
tcLookupDataCon :: Name -> TcM DataCon
tcLookupDataCon con_name
tcLookupId :: Name -> TcM Id
-- Used when we aren't interested in the binding level
+-- Never a DataCon. (Why does that matter? see TcExpr.tcId)
tcLookupId name
= tcLookup name `thenM` \ thing ->
case thing of
- ATcId tc_id lvl -> returnM tc_id
- AGlobal (AnId id) -> returnM id
- AGlobal (ADataCon dc) -> returnM (dataConWrapId dc)
- -- C.f. tcLookupGlobalId
- other -> pprPanic "tcLookupId" (ppr name)
+ ATcId tc_id lvl -> returnM tc_id
+ AGlobal (AnId id) -> returnM id
+ other -> pprPanic "tcLookupId" (ppr name)
tcLookupIdLvl :: Name -> TcM (Id, Level)
+-- DataCons dealt with separately
tcLookupIdLvl name
= tcLookup name `thenM` \ thing ->
case thing of
- ATcId tc_id lvl -> returnM (tc_id, lvl)
- AGlobal (AnId id) -> returnM (id, topIdLvl id)
- AGlobal (ADataCon dc) -> returnM (dataConWrapId dc, impLevel)
+ ATcId tc_id lvl -> returnM (tc_id, lvl)
+ AGlobal (AnId id) -> returnM (id, topIdLvl id)
other -> pprPanic "tcLookupIdLvl" (ppr name)
tcLookupLocalIds :: [Name] -> TcM [TcId]
tidyOpenType
)
import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
-import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector, isDataConWrapId_maybe )
-import DataCon ( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks )
+import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector )
+import DataCon ( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks, dataConWrapId )
import Name ( Name )
-import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons )
+import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons, isClassTyCon )
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import VarSet ( emptyVarSet, elemVarSet )
import TysWiredIn ( boolTy )
let
bad_guys = [ addErrTc (notSelector field_name)
| (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids,
- case maybe_sel_id of
- Just (AnId sel_id) -> not (isRecordSelector sel_id)
- other -> True
+ 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
in
checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM) `thenM_`
let
-- It's OK to use the non-tc splitters here (for a selector)
(Just (AnId sel_id) : _) = maybe_sel_ids
-
- (_, _, tau) = tcSplitSigmaTy (idType sel_id) -- Selectors can be overloaded
- -- when the data type has a context
- data_ty = tcFunArgTy tau -- Must succeed since sel_id is a selector
- tycon = tcTyConAppTyCon data_ty
+ field_lbl = recordSelectorFieldLabel sel_id -- We've failed already if
+ tycon = fieldLabelTyCon field_lbl -- it's not a field label
data_cons = tyConDataCons tycon
tycon_tyvars = tyConTyVars tycon -- The data cons use the same type vars
in
\begin{code}
tcId :: Name -> TcM (TcExpr, TcType)
tcId name -- Look up the Id and instantiate its type
- = tcLookupIdLvl name `thenM` \ (id, bind_lvl) ->
+ = -- First check whether it's a DataCon
+ -- Reason: we must not forget to chuck in the
+ -- constraints from their "silly context"
+ tcLookupGlobal_maybe name `thenM` \ maybe_thing ->
+ case maybe_thing of {
+ Just (ADataCon data_con) -> inst_data_con data_con ;
+ other ->
+
+ -- OK, so now look for ordinary Ids
+ tcLookupIdLvl name `thenM` \ (id, bind_lvl) ->
+#ifndef GHCI
+ loop (HsVar id) (idType id) -- Non-TH case
+
+#else /* GHCI is on */
-- Check for cross-stage lifting
-#ifdef GHCI
getStage `thenM` \ use_stage ->
case use_stage of
Brack use_lvl ps_var lie_var
other ->
checkWellStaged (quotes (ppr id)) bind_lvl use_stage `thenM_`
+ loop (HsVar id) (idType id)
#endif
- -- This is the bit that handles the no-Template-Haskell case
- case isDataConWrapId_maybe id of
- Nothing -> loop (HsVar id) (idType id)
- Just data_con -> inst_data_con id data_con
+ }
where
orig = OccurrenceOf name
| otherwise
= returnM (fun, fun_ty)
- want_method_inst fun_ty
- | opt_NoMethodSharing = False
- | otherwise = case tcSplitSigmaTy fun_ty of
- (_,[],_) -> False -- Not overloaded
- (_,theta,_) -> not (any isLinearPred theta)
- -- This is a slight hack.
+ -- Hack Alert (want_method_inst)!
-- If f :: (%x :: T) => Int -> Int
-- Then if we have two separate calls, (f 3, f 4), we cannot
-- make a method constraint that then gets shared, thus:
-- because that loses the linearity of the constraint.
-- The simplest thing to do is never to construct a method constraint
-- in the first place that has a linear implicit parameter in it.
+ want_method_inst fun_ty
+ | opt_NoMethodSharing = False
+ | otherwise = case tcSplitSigmaTy fun_ty of
+ (_,[],_) -> False -- Not overloaded
+ (_,theta,_) -> not (any isLinearPred theta)
+
-- We treat data constructors differently, because we have to generate
-- constraints for their silly theta, which no longer appears in
-- the type of dataConWrapId. It's dual to TcPat.tcConstructor
- inst_data_con id data_con
+ inst_data_con data_con
= tcInstDataCon orig data_con `thenM` \ (ty_args, ex_dicts, arg_tys, result_ty, _) ->
extendLIEs ex_dicts `thenM_`
- returnM (mkHsDictApp (mkHsTyApp (HsVar id) ty_args) (map instToId ex_dicts),
+ returnM (mkHsDictApp (mkHsTyApp (HsVar (dataConWrapId data_con)) ty_args)
+ (map instToId ex_dicts),
mkFunTys arg_tys result_ty)
\end{code}
projects / ghc-hetmet.git / commitdiff