module Inst (
Inst,
- pprDFuns, pprDictsTheta, pprDictsInFull, -- User error messages
+ pprInstances, pprDictsTheta, pprDictsInFull, -- User error messages
showLIE, pprInst, pprInsts, pprInstInFull, -- Debugging messages
tidyInsts, tidyMoreInsts,
newDicts, newDictAtLoc, newDictsAtLoc, cloneDict,
- newOverloadedLit, newIPDict,
+ tcOverloadedLit, newIPDict,
newMethod, newMethodFromName, newMethodWithGivenTy,
tcInstClassOp, tcInstCall, tcInstStupidTheta,
- tcSyntaxName, tcStdSyntaxName,
+ tcSyntaxName,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
instLoc, getDictClassTys, dictPred,
lookupInst, LookupInstResult(..), lookupPred,
- tcExtendLocalInstEnv, tcGetInstEnvs,
+ tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
isDict, isClassDict, isMethod,
isLinearInst, linearInstType, isIPDict, isInheritableInst,
- isTyVarDict, isStdClassTyVarDict, isMethodFor,
+ isTyVarDict, isMethodFor,
instBindingRequired,
zonkInst, zonkInsts,
#include "HsVersions.h"
-import {-# SOURCE #-} TcExpr( tcCheckSigma )
+import {-# SOURCE #-} TcExpr( tcCheckSigma, tcSyntaxOp )
import {-# SOURCE #-} TcUnify ( unifyTauTy ) -- Used in checkKind (sigh)
-import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp )
-import TcHsSyn ( TcId, TcIdSet,
- mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId,
+import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
+ nlHsLit, nlHsVar )
+import TcHsSyn ( mkHsTyApp, mkHsDictApp, zonkId,
mkCoercion, ExprCoFn
)
import TcRnMonad
import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
-import InstEnv ( DFunId, InstEnv, lookupInstEnv, checkFunDeps, extendInstEnv )
-import TcIface ( loadImportedInsts )
+import InstEnv ( DFunId, InstEnv, Instance(..), OverlapFlag(..),
+ lookupInstEnv, extendInstEnv, pprInstances,
+ instanceHead, instanceDFunId, setInstanceDFunId )
+import FunDeps ( checkFunDeps )
import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType,
tcInstTyVar, tcInstType, tcSkolType
)
import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar, TcPredType,
PredType(..), SkolemInfo(..), typeKind, mkSigmaTy,
- tcSplitForAllTys, tcSplitForAllTys,
- tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy, tcSplitDFunHead,
+ tcSplitForAllTys, mkFunTy,
+ tcSplitPhiTy, tcSplitDFunHead,
isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
- tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
+ mkPredTy, mkTyVarTy, mkTyVarTys,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
isClassPred, isTyVarClassPred, isLinearPred,
- getClassPredTys, getClassPredTys_maybe, mkPredName,
+ getClassPredTys, mkPredName,
isInheritablePred, isIPPred,
tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
- pprPred, pprParendType, pprThetaArrow, pprTheta, pprClassPred
+ pprPred, pprParendType, pprTheta
)
import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst,
notElemTvSubst, extendTvSubstList )
import Packages ( isHomeModule )
import HscTypes ( ExternalPackageState(..) )
import CoreFVs ( idFreeTyVars )
-import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName )
+import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName, dataConWrapId )
import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
-import PrelInfo ( isStandardClass, isNoDictClass )
+import PrelInfo ( isNoDictClass )
import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
- isInternalName, setNameUnique, mkSystemVarNameEncoded )
+ isInternalName, setNameUnique, mkSystemVarName )
import NameSet ( addOneToNameSet )
import Literal ( inIntRange )
import Var ( TyVar, tyVarKind, setIdType )
import BasicTypes( IPName(..), mapIPName, ipNameName )
import UniqSupply( uniqsFromSupply )
import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
-import CmdLineOpts( DynFlags )
+import DynFlags ( DynFlag(..), dopt )
import Maybes ( isJust )
import Outputable
\end{code}
linearInstType :: Inst -> TcType -- %x::t --> t
linearInstType (Dict _ (IParam _ ty) _) = ty
-
-
-isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
- Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
- other -> False
\end{code}
Two predicates which deal with the case where class constraints don't
returnM inst
\end{code}
-In newOverloadedLit we convert directly to an Int or Integer if we
+In tcOverloadedLit we convert directly to an Int or Integer if we
know that's what we want. This may save some time, by not
temporarily generating overloaded literals, but it won't catch all
cases (the rest are caught in lookupInst).
\begin{code}
-newOverloadedLit :: InstOrigin
- -> HsOverLit
+tcOverloadedLit :: InstOrigin
+ -> HsOverLit Name
-> TcType
- -> TcM (LHsExpr TcId)
-newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
- | fi /= fromIntegerName -- Do not generate a LitInst for rebindable syntax.
- -- Reason: tcSyntaxName does unification
- -- which is very inconvenient in tcSimplify
- -- ToDo: noLoc sadness
- = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) ->
- mkIntegerLit i `thenM` \ integer_lit ->
- returnM (mkHsApp (noLoc expr) integer_lit)
- -- The mkHsApp will get the loc from the literal
+ -> TcM (HsOverLit TcId)
+tcOverloadedLit orig lit@(HsIntegral i fi) expected_ty
+ | not (fi `isHsVar` fromIntegerName) -- Do not generate a LitInst for rebindable syntax.
+ -- Reason: If we do, tcSimplify will call lookupInst, which
+ -- will call tcSyntaxName, which does unification,
+ -- which tcSimplify doesn't like
+ -- ToDo: noLoc sadness
+ = do { integer_ty <- tcMetaTy integerTyConName
+ ; fi' <- tcSyntaxOp orig fi (mkFunTy integer_ty expected_ty)
+ ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty)))) }
+
| Just expr <- shortCutIntLit i expected_ty
- = returnM expr
+ = return (HsIntegral i expr)
| otherwise
- = newLitInst orig lit expected_ty
+ = do { expr <- newLitInst orig lit expected_ty
+ ; return (HsIntegral i expr) }
-newOverloadedLit orig lit@(HsFractional r fr) expected_ty
- | fr /= fromRationalName -- c.f. HsIntegral case
- = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) ->
- mkRatLit r `thenM` \ rat_lit ->
- returnM (mkHsApp (noLoc expr) rat_lit)
- -- The mkHsApp will get the loc from the literal
+tcOverloadedLit orig lit@(HsFractional r fr) expected_ty
+ | not (fr `isHsVar` fromRationalName) -- c.f. HsIntegral case
+ = do { rat_ty <- tcMetaTy rationalTyConName
+ ; fr' <- tcSyntaxOp orig fr (mkFunTy rat_ty expected_ty)
+ ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty)))) }
| Just expr <- shortCutFracLit r expected_ty
- = returnM expr
+ = return (HsFractional r expr)
| otherwise
- = newLitInst orig lit expected_ty
-
-newLitInst :: InstOrigin -> HsOverLit -> TcType -> TcM (LHsExpr TcId)
-newLitInst orig lit expected_ty
- = getInstLoc orig `thenM` \ loc ->
- newUnique `thenM` \ new_uniq ->
- let
- lit_nm = mkSystemVarNameEncoded new_uniq FSLIT("lit")
- -- The "encoded" bit means that we don't need to z-encode
- -- the string every time we call this!
- lit_inst = LitInst lit_nm lit expected_ty loc
- in
- extendLIE lit_inst `thenM_`
- returnM (L (instLocSrcSpan loc) (HsVar (instToId lit_inst)))
-
-shortCutIntLit :: Integer -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
+ = do { expr <- newLitInst orig lit expected_ty
+ ; return (HsFractional r expr) }
+
+newLitInst :: InstOrigin -> HsOverLit Name -> TcType -> TcM (HsExpr TcId)
+newLitInst orig lit expected_ty -- Make a LitInst
+ = do { loc <- getInstLoc orig
+ ; new_uniq <- newUnique
+ ; let
+ lit_nm = mkSystemVarName new_uniq FSLIT("lit")
+ lit_inst = LitInst lit_nm lit expected_ty loc
+ ; extendLIE lit_inst
+ ; return (HsVar (instToId lit_inst)) }
+
+shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
shortCutIntLit i ty
| isIntTy ty && inIntRange i -- Short cut for Int
- = Just (noLoc (HsLit (HsInt i)))
+ = Just (HsLit (HsInt i))
| isIntegerTy ty -- Short cut for Integer
- = Just (noLoc (HsLit (HsInteger i ty)))
+ = Just (HsLit (HsInteger i ty))
| otherwise = Nothing
-shortCutFracLit :: Rational -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
+shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
shortCutFracLit f ty
| isFloatTy ty
- = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
+ = Just (mk_lit floatDataCon (HsFloatPrim f))
| isDoubleTy ty
- = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
+ = Just (mk_lit doubleDataCon (HsDoublePrim f))
| otherwise = Nothing
+ where
+ mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
mkIntegerLit i
= tcMetaTy rationalTyConName `thenM` \ rat_ty ->
getSrcSpanM `thenM` \ span ->
returnM (L span $ HsLit (HsRat r rat_ty))
+
+isHsVar :: HsExpr Name -> Name -> Bool
+isHsVar (HsVar f) g = f==g
+isHsVar other g = False
\end{code}
pprInstInFull inst
= sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
-pprDFuns :: [DFunId] -> SDoc
--- Prints the dfun as an instance declaration
-pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
- 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
- pprClassPred clas tys])
- | dfun <- dfuns
- , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
- -- Print without the for-all, which the programmer doesn't write
-
tidyInst :: TidyEnv -> Inst -> Inst
tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc
tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc
%************************************************************************
\begin{code}
-tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
+tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
-- Add new locally-defined instances
tcExtendLocalInstEnv dfuns thing_inside
= do { traceDFuns dfuns
; env <- getGblEnv
- ; dflags <- getDOpts
- ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns
+ ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
tcg_inst_env = inst_env' }
; setGblEnv env' thing_inside }
-addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
+addLocalInst :: InstEnv -> Instance -> TcM InstEnv
-- Check that the proposed new instance is OK,
-- and then add it to the home inst env
-addInst dflags home_ie dfun
+addLocalInst home_ie ispec
= do { -- Instantiate the dfun type so that we extend the instance
-- envt with completely fresh template variables
-- This is important because the template variables must
-- not overlap with anything in the things being looked up
-- (since we do unification).
-- We use tcSkolType because we don't want to allocate fresh
- -- *meta* type variables.
- (tvs', theta', tau') <- tcSkolType (InstSkol dfun) (idType dfun)
+ -- *meta* type variables.
+ let dfun = instanceDFunId ispec
+ ; (tvs', theta', tau') <- tcSkolType (InstSkol dfun) (idType dfun)
; let (cls, tys') = tcSplitDFunHead tau'
dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
+ ispec' = setInstanceDFunId ispec dfun'
-- Load imported instances, so that we report
-- duplicates correctly
- ; pkg_ie <- loadImportedInsts cls tys'
+ ; eps <- getEps
+ ; let inst_envs = (eps_inst_env eps, home_ie)
-- Check functional dependencies
- ; case checkFunDeps (pkg_ie, home_ie) dfun' of
- Just dfuns -> funDepErr dfun dfuns
+ ; case checkFunDeps inst_envs ispec' of
+ Just specs -> funDepErr ispec' specs
Nothing -> return ()
-- Check for duplicate instance decls
- ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys'
- ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
- isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
- -- Find memebers of the match list which
- -- dfun itself matches. If the match is 2-way, it's a duplicate
- ; case dup_dfuns of
- dup_dfun : _ -> dupInstErr dfun dup_dfun
- [] -> return ()
+ ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
+ ; dup_ispecs = [ dup_ispec
+ | (_, dup_ispec) <- matches
+ , let (_,_,_,dup_tys) = instanceHead dup_ispec
+ , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
+ -- Find memebers of the match list which ispec itself matches.
+ -- If the match is 2-way, it's a duplicate
+ ; case dup_ispecs of
+ dup_ispec : _ -> dupInstErr ispec' dup_ispec
+ [] -> return ()
-- OK, now extend the envt
- ; return (extendInstEnv home_ie dfun') }
-
-
-traceDFuns dfuns
- = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
+ ; return (extendInstEnv home_ie ispec') }
+
+getOverlapFlag :: TcM OverlapFlag
+getOverlapFlag
+ = do { dflags <- getDOpts
+ ; let overlap_ok = dopt Opt_AllowOverlappingInstances dflags
+ incoherent_ok = dopt Opt_AllowIncoherentInstances dflags
+ overlap_flag | incoherent_ok = Incoherent
+ | overlap_ok = OverlapOk
+ | otherwise = NoOverlap
+
+ ; return overlap_flag }
+
+traceDFuns ispecs
+ = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
where
- pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
+ pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
+ -- Print the dfun name itself too
-funDepErr dfun dfuns
- = addDictLoc dfun $
+funDepErr ispec ispecs
+ = addDictLoc ispec $
addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
- 2 (pprDFuns (dfun:dfuns)))
-dupInstErr dfun dup_dfun
- = addDictLoc dfun $
+ 2 (pprInstances (ispec:ispecs)))
+dupInstErr ispec dup_ispec
+ = addDictLoc ispec $
addErr (hang (ptext SLIT("Duplicate instance declarations:"))
- 2 (pprDFuns [dfun, dup_dfun]))
+ 2 (pprInstances [ispec, dup_ispec]))
-addDictLoc dfun thing_inside
+addDictLoc ispec thing_inside
= setSrcSpan (mkSrcSpan loc loc) thing_inside
where
- loc = getSrcLoc dfun
+ loc = getSrcLoc ispec
\end{code}
-- Look for short cuts first: if the literal is *definitely* a
-- int, integer, float or a double, generate the real thing here.
--- This is essential (see nofib/spectral/nucleic).
+-- This is essential (see nofib/spectral/nucleic).
-- [Same shortcut as in newOverloadedLit, but we
-- may have done some unification by now]
-
lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
| Just expr <- shortCutIntLit i ty
- = returnM (GenInst [] expr) -- GenInst, not SimpleInst, because
+ = returnM (GenInst [] (noLoc expr)) -- GenInst, not SimpleInst, because
-- expr may be a constructor application
| otherwise
- = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
+ = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
tcLookupId fromIntegerName `thenM` \ from_integer ->
tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
mkIntegerLit i `thenM` \ integer_lit ->
lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
| Just expr <- shortCutFracLit f ty
- = returnM (GenInst [] expr)
+ = returnM (GenInst [] (noLoc expr))
| otherwise
- = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
+ = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
tcLookupId fromRationalName `thenM` \ from_rational ->
tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
mkRatLit f `thenM` \ rat_lit ->
lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
-- Look up a class constraint in the instance environment
lookupPred pred@(ClassP clas tys)
- = do { pkg_ie <- loadImportedInsts clas tys
- -- Suck in any instance decls that may be relevant
+ = do { eps <- getEps
; tcg_env <- getGblEnv
- ; dflags <- getDOpts
- ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
- ([(tenv, (_,_,dfun_id))], [])
- -> do { traceTc (text "lookupInst success" <+>
+ ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
+ ; case lookupInstEnv inst_envs clas tys of {
+ ([(tenv, ispec)], [])
+ -> do { let dfun_id = is_dfun ispec
+ ; traceTc (text "lookupInst success" <+>
vcat [text "dict" <+> ppr pred,
text "witness" <+> ppr dfun_id
<+> ppr (idType dfun_id) ])
lookupPred ip_pred = return Nothing
record_dfun_usage dfun_id
- = do { dflags <- getDOpts
+ = do { gbl <- getGblEnv
; let dfun_name = idName dfun_id
dfun_mod = nameModule dfun_name
- ; if isInternalName dfun_name || not (isHomeModule dflags dfun_mod)
+ ; if isInternalName dfun_name || -- Internal name => defined in this module
+ not (isHomeModule (tcg_home_mods gbl) dfun_mod)
then return () -- internal, or in another package
else do { tcg_env <- getGblEnv
; updMutVar (tcg_inst_uses tcg_env)
%* *
%************************************************************************
-
Suppose we are doing the -fno-implicit-prelude thing, and we encounter
a do-expression. We have to find (>>) in the current environment, which is
done by the rename. Then we have to check that it has the same type as
-> TcType -- Type to instantiate it at
-> (Name, HsExpr Name) -- (Standard name, user name)
-> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
-
+-- *** NOW USED ONLY FOR CmdTop (sigh) ***
-- 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, HsVar user_nm)
| std_nm == user_nm
- = tcStdSyntaxName orig ty std_nm
+ = newMethodFromName orig ty std_nm `thenM` \ id ->
+ returnM (std_nm, HsVar id)
tcSyntaxName orig ty (std_nm, user_nm_expr)
= tcLookupId std_nm `thenM` \ std_id ->
tcCheckSigma (L span user_nm_expr) sigma1 `thenM` \ expr ->
returnM (std_nm, unLoc expr)
-tcStdSyntaxName :: InstOrigin
- -> TcType -- Type to instantiate it at
- -> Name -- Standard name
- -> TcM (Name, HsExpr TcId) -- (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 ->
let
projects / ghc-hetmet.git / blobdiff