newDictsFromOld, newDicts, cloneDict,
newOverloadedLit, newIPDict,
newMethod, newMethodFromName, newMethodWithGivenTy,
- tcInstClassOp, tcInstCall, tcInstDataCon, tcSyntaxName,
+ tcInstClassOp, tcInstCall, tcInstDataCon,
+ tcSyntaxName, tcStdSyntaxName,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
isDict, isClassDict, isMethod,
isLinearInst, linearInstType, isIPDict, isInheritableInst,
isTyVarDict, isStdClassTyVarDict, isMethodFor,
- instBindingRequired, instCanBeGeneralised,
+ instBindingRequired,
zonkInst, zonkInsts,
instToId, instName,
#include "HsVersions.h"
-import {-# SOURCE #-} TcExpr( tcExpr )
+import {-# SOURCE #-} TcExpr( tcCheckSigma )
import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..) )
-import TcHsSyn ( TcExpr, TcId, TcIdSet, TypecheckedHsExpr,
- mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
+import TcHsSyn ( TcExpr, TcId, TcIdSet,
+ mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId,
+ mkCoercion, ExprCoFn
)
import TcRnMonad
import TcEnv ( tcGetInstEnv, tcLookupId, tcLookupTyCon, checkWellStaged, topIdLvl )
import InstEnv ( InstLookupResult(..), lookupInstEnv )
-import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType,
+import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
)
import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
- SourceType(..), PredType, ThetaType, TyVarDetails(VanillaTv),
+ SourceType(..), PredType, TyVarDetails(VanillaTv),
tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
- tcSplitMethodTy, tcSplitPhiTy, mkGenTyConApp,
+ tcSplitPhiTy, mkGenTyConApp,
isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
- isClassPred, isTyVarClassPred, isLinearPred, predHasFDs,
+ isClassPred, isTyVarClassPred, isLinearPred,
getClassPredTys, getClassPredTys_maybe, mkPredName,
isInheritablePred, isIPPred,
tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
)
import CoreFVs ( idFreeTyVars )
-import Class ( Class )
import DataCon ( DataCon,dataConSig )
import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
-import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
+import PrelInfo ( isStandardClass, isNoDictClass )
import Name ( Name, mkMethodOcc, getOccName )
import PprType ( pprPred, pprParendType )
-import Subst ( emptyInScopeSet, mkSubst, substTy, substTyWith, substTheta, mkTyVarSubst )
+import Subst ( substTy, substTyWith, substTheta, mkTyVarSubst )
import Literal ( inIntRange )
import Var ( TyVar )
import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
getDictClassTys (Dict _ pred _) = getClassPredTys pred
-- fdPredsOfInst is used to get predicates that contain functional
--- dependencies; i.e. should participate in improvement
-fdPredsOfInst (Dict _ pred _) | predHasFDs pred = [pred]
- | otherwise = []
-fdPredsOfInst (Method _ _ _ theta _ _) = filter predHasFDs theta
-fdPredsOfInst other = []
+-- dependencies *or* might do so. The "might do" part is because
+-- a constraint (C a b) might have a superclass with FDs
+-- Leaving these in is really important for the call to fdPredsOfInsts
+-- in TcSimplify.inferLoop, because the result is fed to 'grow',
+-- which is supposed to be conservative
+fdPredsOfInst (Dict _ pred _) = [pred]
+fdPredsOfInst (Method _ _ _ theta _ _) = theta
+fdPredsOfInst other = [] -- LitInsts etc
fdPredsOfInsts :: [Inst] -> [PredType]
fdPredsOfInsts insts = concatMap fdPredsOfInst insts
instBindingRequired :: Inst -> Bool
instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
instBindingRequired other = True
-
-instCanBeGeneralised :: Inst -> Bool
-instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
-instCanBeGeneralised other = True
\end{code}
\begin{code}
-tcInstCall :: InstOrigin -> TcType -> TcM (TypecheckedHsExpr -> TypecheckedHsExpr, TcType)
+tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, TcType)
tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
= tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
newDicts orig theta `thenM` \ dicts ->
let
inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts)
in
- returnM (inst_fn, tau)
+ returnM (mkCoercion inst_fn, tau)
tcInstDataCon :: InstOrigin -> DataCon
-> TcM ([TcType], -- Types to instantiate at
| fi /= fromIntegerName -- Do not generate a LitInst for rebindable
-- syntax. Reason: tcSyntaxName does unification
-- which is very inconvenient in tcSimplify
- = tcSyntaxName orig expected_ty fromIntegerName fi `thenM` \ (expr, _) ->
+ = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) ->
returnM (HsApp expr (HsLit (HsInteger i)))
| Just expr <- shortCutIntLit i expected_ty
newOverloadedLit orig lit@(HsFractional r fr) expected_ty
| fr /= fromRationalName -- c.f. HsIntegral case
- = tcSyntaxName orig expected_ty fromRationalName fr `thenM` \ (expr, _) ->
- mkRatLit r `thenM` \ rat_lit ->
+ = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) ->
+ mkRatLit r `thenM` \ rat_lit ->
returnM (HsApp expr rat_lit)
| Just expr <- shortCutFracLit r expected_ty
newLitInst orig lit expected_ty
= getInstLoc orig `thenM` \ loc ->
newUnique `thenM` \ new_uniq ->
- zapToType expected_ty `thenM_`
- -- The expected type might be a 'hole' type variable,
- -- in which case we must zap it to an ordinary type variable
let
lit_inst = LitInst lit_id lit expected_ty loc
lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty
tidyInsts :: [Inst] -> (TidyEnv, [Inst])
tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
-showLIE :: String -> TcM () -- Debugging
+showLIE :: SDoc -> TcM () -- Debugging
showLIE str
= do { lie_var <- getLIEVar ;
lie <- readMutVar lie_var ;
- traceTc (text str <+> pprInstsInFull (lieToList lie)) }
+ traceTc (str <+> pprInstsInFull (lieToList lie)) }
\end{code}
\begin{code}
tcSyntaxName :: InstOrigin
-> TcType -- Type to instantiate it at
- -> Name -> Name -- (Standard name, user name)
- -> TcM (TcExpr, TcType) -- Suitable expression with its type
+ -> (Name, HsExpr Name) -- (Standard name, user name)
+ -> TcM (Name, TcExpr) -- (Standard name, suitable expression)
-- NB: tcSyntaxName calls tcExpr, and hence can do unification.
-- So we do not call it from lookupInst, which is called from tcSimplify
-tcSyntaxName orig ty std_nm user_nm
+tcSyntaxName orig ty (std_nm, HsVar user_nm)
| std_nm == user_nm
- = newMethodFromName orig ty std_nm `thenM` \ id ->
- returnM (HsVar id, idType id)
+ = tcStdSyntaxName orig ty std_nm
- | otherwise
+tcSyntaxName orig ty (std_nm, user_nm_expr)
= tcLookupId std_nm `thenM` \ std_id ->
let
-- C.f. newMethodAtLoc
([tv], _, tau) = tcSplitSigmaTy (idType std_id)
tau1 = substTyWith [tv] [ty] tau
+ -- Actually, the "tau-type" might be a sigma-type in the
+ -- case of locally-polymorphic methods.
in
- addErrCtxtM (syntaxNameCtxt user_nm orig tau1) $
- tcExpr (HsVar user_nm) tau1 `thenM` \ user_fn ->
- returnM (user_fn, tau1)
+ addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $
+ tcCheckSigma user_nm_expr tau1 `thenM` \ expr ->
+ returnM (std_nm, expr)
+
+tcStdSyntaxName :: InstOrigin
+ -> TcType -- Type to instantiate it at
+ -> Name -- Standard name
+ -> TcM (Name, TcExpr) -- (Standard name, suitable expression)
+
+tcStdSyntaxName orig ty std_nm
+ = newMethodFromName orig ty std_nm `thenM` \ id ->
+ returnM (std_nm, HsVar id)
syntaxNameCtxt name orig ty tidy_env
= getInstLoc orig `thenM` \ inst_loc ->