newDictBndr, newDictBndrs, newDictBndrsO,
instCall, instStupidTheta,
cloneDict,
- shortCutFracLit, shortCutIntLit, newIPDict,
+ shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict,
newMethod, newMethodFromName, newMethodWithGivenTy,
tcInstClassOp,
tcSyntaxName, isHsVar,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
- instLoc, getDictClassTys, dictPred,
+ getDictClassTys, dictPred,
- lookupInst, LookupInstResult(..), lookupPred,
+ lookupSimpleInst, LookupInstResult(..),
tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
- isDict, isClassDict, isMethod,
- isIPDict, isInheritableInst,
+ isDict, isClassDict, isMethod, isImplicInst,
+ isIPDict, isInheritableInst, isMethodOrLit,
isTyVarDict, isMethodFor,
zonkInst, zonkInsts,
instToId, instToVar, instName,
- InstOrigin(..), InstLoc(..), pprInstLoc
+ InstOrigin(..), InstLoc, pprInstLoc
) where
#include "HsVersions.h"
import {-# SOURCE #-} TcExpr( tcPolyExpr )
import {-# SOURCE #-} TcUnify( unifyType )
+import FastString(FastString)
import HsSyn
import TcHsSyn
import TcRnMonad
import SrcLoc
import DynFlags
import Maybes
+import Util
import Outputable
+
+import Data.List
\end{code}
~~~~~~~~~
\begin{code}
instName :: Inst -> Name
-instName inst = idName (instToId inst)
+instName inst = Var.varName (instToVar inst)
instToId :: Inst -> TcId
instToId inst = ASSERT2( isId id, ppr inst ) id
instToVar (Dict {tci_name = nm, tci_pred = pred})
| isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
| otherwise = mkLocalId nm (mkPredTy pred)
-
-instLoc inst = tci_loc inst
+instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
+ tci_wanted = wanteds})
+ = mkLocalId nm (mkImplicTy tvs givens wanteds)
+
+instType :: Inst -> Type
+instType (LitInst {tci_ty = ty}) = ty
+instType (Method {tci_id = id}) = idType id
+instType (Dict {tci_pred = pred}) = mkPredTy pred
+instType imp@(ImplicInst {}) = mkImplicTy (tci_tyvars imp) (tci_given imp)
+ (tci_wanted imp)
+
+mkImplicTy tvs givens wanteds -- The type of an implication constraint
+ = ASSERT( all isDict givens )
+ -- pprTrace "mkImplicTy" (ppr givens) $
+ mkForAllTys tvs $
+ mkPhiTy (map dictPred givens) $
+ if isSingleton wanteds then
+ instType (head wanteds)
+ else
+ mkTupleTy Boxed (length wanteds) (map instType wanteds)
dictPred (Dict {tci_pred = pred}) = pred
dictPred inst = pprPanic "dictPred" (ppr inst)
-- 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 {tci_pred = pred}) = [pred]
-fdPredsOfInst (Method {tci_theta = theta}) = theta
-fdPredsOfInst other = [] -- LitInsts etc
+fdPredsOfInst (Dict {tci_pred = pred}) = [pred]
+fdPredsOfInst (Method {tci_theta = theta}) = theta
+fdPredsOfInst (ImplicInst {tci_given = gs,
+ tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
+fdPredsOfInst (LitInst {}) = []
fdPredsOfInsts :: [Inst] -> [PredType]
fdPredsOfInsts insts = concatMap fdPredsOfInst insts
isInheritableInst other = True
+---------------------------------
+-- Get the implicit parameters mentioned by these Insts
+-- NB: the results of these functions are insensitive to zonking
+
ipNamesOfInsts :: [Inst] -> [Name]
ipNamesOfInst :: Inst -> [Name]
--- Get the implicit parameters mentioned by these Insts
--- NB: ?x and %x get different Names
ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
ipNamesOfInst other = []
+---------------------------------
tyVarsOfInst :: Inst -> TcTyVarSet
tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty
tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
-tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
+tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
-- The id might have free type variables; in the case of
-- locally-overloaded class methods, for example
-
+tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
+ = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
+ `minusVarSet` mkVarSet tvs
+ `unionVarSet` unionVarSets (map varTypeTyVars tvs)
+ -- Remember the free tyvars of a coercion
tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
isIPDict (Dict {tci_pred = pred}) = isIPPred pred
isIPDict other = False
+isImplicInst (ImplicInst {}) = True
+isImplicInst other = False
+
isMethod :: Inst -> Bool
isMethod (Method {}) = True
isMethod other = False
isMethodFor :: TcIdSet -> Inst -> Bool
isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
isMethodFor ids inst = False
-\end{code}
+isMethodOrLit :: Inst -> Bool
+isMethodOrLit (Method {}) = True
+isMethodOrLit (LitInst {}) = True
+isMethodOrLit other = False
+\end{code}
%************************************************************************
newDictBndr :: InstLoc -> TcPredType -> TcM Inst
newDictBndr inst_loc pred
= do { uniq <- newUnique
- ; let name = mkPredName uniq (instLocSrcLoc inst_loc) pred
+ ; let name = mkPredName uniq inst_loc pred
; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
----------------
instCallDicts loc (pred : preds)
= do { uniq <- newUnique
- ; let name = mkPredName uniq (instLocSrcLoc loc) pred
+ ; let name = mkPredName uniq loc pred
dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
; (dicts, co_fn) <- instCallDicts loc preds
; return (dict:dicts, co_fn <.> WpApp (instToId dict)) }
-------------
-cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params
+cloneDict :: Inst -> TcM Inst
cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
; return (dict {tci_name = setNameUnique nm uniq}) }
cloneDict other = pprPanic "cloneDict" (ppr other)
newUnique `thenM` \ uniq ->
let
pred = IParam ip_name ty
- name = mkPredName uniq (instLocSrcLoc inst_loc) pred
+ name = mkPredName uniq inst_loc pred
dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
in
returnM (mapIPName (\n -> instToId dict) ip_name, dict)
\end{code}
+\begin{code}
+mkPredName :: Unique -> InstLoc -> PredType -> Name
+mkPredName uniq loc pred_ty
+ = mkInternalName uniq occ (instLocSpan loc)
+ where
+ occ = case pred_ty of
+ ClassP cls _ -> mkDictOcc (getOccName cls)
+ IParam ip _ -> getOccName (ipNameName ip)
+ EqPred ty _ -> mkEqPredCoOcc baseOcc
+ where
+ -- we use the outermost tycon of the lhs, if there is one, to
+ -- improve readability of Core code
+ baseOcc = case splitTyConApp_maybe ty of
+ Nothing -> mkOccName tcName "$"
+ Just (tc, _) -> getOccName tc
+\end{code}
%************************************************************************
%* *
meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
tci_theta = theta, tci_loc = inst_loc}
- loc = instLocSrcLoc inst_loc
+ loc = instLocSpan inst_loc
in
returnM inst
\end{code}
where
mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
+shortCutStringLit :: FastString -> TcType -> Maybe (HsExpr TcId)
+shortCutStringLit s ty
+ | isStringTy ty -- Short cut for String
+ = Just (HsLit (HsString s))
+ | otherwise = Nothing
+
mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
mkIntegerLit i
= tcMetaTy integerTyConName `thenM` \ integer_ty ->
getSrcSpanM `thenM` \ span ->
returnM (L span $ HsLit (HsRat r rat_ty))
+mkStrLit :: FastString -> TcM (LHsExpr TcId)
+mkStrLit s
+ = --tcMetaTy stringTyConName `thenM` \ string_ty ->
+ getSrcSpanM `thenM` \ span ->
+ returnM (L span $ HsLit (HsString s))
+
isHsVar :: HsExpr Name -> Name -> Bool
isHsVar (HsVar f) g = f==g
isHsVar other g = False
= zonkTcType ty `thenM` \ new_ty ->
returnM (lit {tci_ty = new_ty})
+zonkInst implic@(ImplicInst {})
+ = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
+ do { givens' <- zonkInsts (tci_given implic)
+ ; wanteds' <- zonkInsts (tci_wanted implic)
+ ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
+
zonkInsts insts = mappM zonkInst insts
\end{code}
pprDictsTheta :: [Inst] -> SDoc
-- Print in type-like fashion (Eq a, Show b)
-pprDictsTheta dicts = pprTheta (map dictPred dicts)
+-- The Inst can be an implication constraint, but not a Method or LitInst
+pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
pprDictsInFull :: [Inst] -> SDoc
-- Print in type-like fashion, but with source location
pprDictsInFull dicts
= vcat (map go dicts)
where
- go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
+ go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
pprInsts :: [Inst] -> SDoc
-- Debugging: print the evidence :: type
-pprInsts insts = brackets (interpp'SP insts)
+pprInsts insts = brackets (interpp'SP insts)
pprInst, pprInstInFull :: Inst -> SDoc
-- Debugging: print the evidence :: type
-pprInst (LitInst {tci_name = nm, tci_ty = ty}) = ppr nm <+> dcolon <+> ppr ty
-pprInst (Dict {tci_name = nm, tci_pred = pred}) = ppr nm <+> dcolon <+> pprPred pred
-
-pprInst (Method {tci_id = inst_id, tci_oid = id, tci_tys = tys})
- = ppr inst_id <+> dcolon <+>
- braces (sep [ppr id <+> ptext SLIT("at"),
- brackets (sep (map pprParendType tys))])
+pprInst inst = ppr (instName inst) <+> dcolon
+ <+> (braces (ppr (instType inst)) $$
+ ifPprDebug implic_stuff)
+ where
+ implic_stuff | isImplicInst inst = ppr (tci_reft inst)
+ | otherwise = empty
-pprInstInFull inst
- = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
+pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
tidyInst :: TidyEnv -> Inst -> Inst
tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
+tidyInst env implic@(ImplicInst {})
+ = implic { tci_tyvars = tvs'
+ , tci_given = map (tidyInst env') (tci_given implic)
+ , tci_wanted = map (tidyInst env') (tci_wanted implic) }
+ where
+ (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
-- This function doesn't assume that the tyvars are in scope
-- We use tcInstSkolType because we don't want to allocate fresh
-- *meta* type variables.
let dfun = instanceDFunId ispec
- ; (tvs', theta', tau') <- tcInstSkolType (InstSkol dfun) (idType dfun)
+ ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
; let (cls, tys') = tcSplitDFunHead tau'
dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
ispec' = setInstanceDFunId ispec dfun'
-- Check for duplicate instance decls
; let { (matches, _) = lookupInstEnv inst_envs cls tys'
; dup_ispecs = [ dup_ispec
- | (_, dup_ispec) <- matches
+ | (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.
\begin{code}
data LookupInstResult
= NoInstance
- | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
- | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
+ | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
+
+lookupSimpleInst :: Inst -> TcM LookupInstResult
+-- This is "simple" in tthat it returns NoInstance for implication constraints
-lookupInst :: Inst -> TcM LookupInstResult
-- It's important that lookupInst does not put any new stuff into
-- the LIE. Instead, any Insts needed by the lookup are returned in
-- the LookupInstResult, where they can be further processed by tcSimplify
+--------------------- Implications ------------------------
+lookupSimpleInst (ImplicInst {}) = return NoInstance
--- Methods
-
-lookupInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
+--------------------- Methods ------------------------
+lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
= do { (dicts, dict_app) <- instCallDicts loc theta
; let co_fn = dict_app <.> mkWpTyApps tys
; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
where
- span = instLocSrcSpan loc
-
--- Literals
+ span = instLocSpan loc
+--------------------- Literals ------------------------
-- 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).
-- [Same shortcut as in newOverloadedLit, but we
-- may have done some unification by now]
-lookupInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty, tci_loc = loc})
+lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty, tci_loc = loc})
| Just expr <- shortCutIntLit i ty
- = returnM (GenInst [] (noLoc expr)) -- GenInst, not SimpleInst, because
- -- expr may be a constructor application
+ = returnM (GenInst [] (noLoc expr))
| otherwise
= 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 ->
returnM (GenInst [method_inst]
- (mkHsApp (L (instLocSrcSpan loc)
+ (mkHsApp (L (instLocSpan loc)
(HsVar (instToId method_inst))) integer_lit))
-lookupInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_loc = loc})
+lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_loc = loc})
| Just expr <- shortCutFracLit f ty
= returnM (GenInst [] (noLoc expr))
tcLookupId fromRationalName `thenM` \ from_rational ->
tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
mkRatLit f `thenM` \ rat_lit ->
- returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
+ returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc)
(HsVar (instToId method_inst))) rat_lit))
--- Dictionaries
-lookupInst (Dict {tci_pred = pred, tci_loc = loc})
+lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name, tci_ty = ty, tci_loc = loc})
+ | Just expr <- shortCutStringLit s ty
+ = returnM (GenInst [] (noLoc expr))
+ | otherwise
+ = ASSERT( from_string_name `isHsVar` fromStringName ) -- A LitInst invariant
+ tcLookupId fromStringName `thenM` \ from_string ->
+ tcInstClassOp loc from_string [ty] `thenM` \ method_inst ->
+ mkStrLit s `thenM` \ string_lit ->
+ returnM (GenInst [method_inst]
+ (mkHsApp (L (instLocSpan loc)
+ (HsVar (instToId method_inst))) string_lit))
+
+--------------------- Dictionaries ------------------------
+lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
= do { mb_result <- lookupPred pred
; case mb_result of {
Nothing -> return NoInstance ;
- Just (tenv, dfun_id) -> do
-
- -- tenv is a substitution that instantiates the dfun_id
- -- to match the requested result type.
- --
- -- We ASSUME that the dfun is quantified over the very same tyvars
- -- that are bound by the tenv.
- --
- -- However, the dfun
- -- might have some tyvars that *only* appear in arguments
- -- dfun :: forall a b. C a b, Ord b => D [a]
- -- We instantiate b to a flexi type variable -- it'll presumably
- -- become fixed later via functional dependencies
+ Just (dfun_id, mb_inst_tys) -> do
+
{ use_stage <- getStage
; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
(topIdLvl dfun_id) use_stage
-- the substitution, tenv. For example:
-- instance C X a => D X where ...
-- (presumably there's a functional dependency in class C)
- -- Hence the open_tvs to instantiate any un-substituted tyvars.
- ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
- open_tvs = filter (`notElemTvSubst` tenv) tyvars
- ; open_tvs' <- mappM tcInstTyVar open_tvs
+ -- Hence mb_inst_tys :: Either TyVar TcType
+
+ ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
+ inst_tv (Right ty) = return ty
+ ; tys <- mappM inst_tv mb_inst_tys
; let
- tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
- -- Since the open_tvs' are freshly made, they cannot possibly be captured by
- -- any nested for-alls in rho. So the in-scope set is unchanged
- dfun_rho = substTy tenv' rho
- (theta, _) = tcSplitPhiTy dfun_rho
- src_loc = instLocSrcSpan loc
+ (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
+ src_loc = instLocSpan loc
dfun = HsVar dfun_id
- tys = map (substTyVar tenv') tyvars
; if null theta then
- returnM (SimpleInst (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
+ returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
else do
{ (dicts, dict_app) <- instCallDicts loc theta
; let co_fn = dict_app <.> mkWpTyApps tys
}}}}
---------------
-lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
+lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
-- Look up a class constraint in the instance environment
lookupPred pred@(ClassP clas tys)
= do { eps <- getEps
; tcg_env <- getGblEnv
; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
; case lookupInstEnv inst_envs clas tys of {
- ([(tenv, ispec)], [])
+ ([(ispec, inst_tys)], [])
-> do { let dfun_id = is_dfun ispec
; traceTc (text "lookupInst success" <+>
vcat [text "dict" <+> ppr pred,
<+> ppr (idType dfun_id) ])
-- Record that this dfun is needed
; record_dfun_usage dfun_id
- ; return (Just (tenv, dfun_id)) } ;
+ ; return (Just (dfun_id, inst_tys)) } ;
(matches, unifs)
-> do { traceTc (text "lookupInst fail" <+>
; return Nothing }
}}
-lookupPred ip_pred = return Nothing
+lookupPred ip_pred = return Nothing -- Implicit parameters
record_dfun_usage dfun_id
= do { hsc_env <- getTopEnv
msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
ptext SLIT("(needed by a syntactic construct)"),
nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
- nest 2 (pprInstLoc inst_loc)]
+ nest 2 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)]
in
returnM (tidy_env, msg)
\end{code}