The @Inst@ type: dictionaries or method instances
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module Inst (
Inst,
newDictBndr, newDictBndrs, newDictBndrsO,
instCall, instStupidTheta,
- cloneDict,
- shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict,
- newMethod, newMethodFromName, newMethodWithGivenTy,
+ cloneDict, mkOverLit,
+ newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy,
tcInstClassOp,
tcSyntaxName, isHsVar,
#include "HsVersions.h"
import {-# SOURCE #-} TcExpr( tcPolyExpr )
-import {-# SOURCE #-} TcUnify( boxyUnify, unifyType )
+import {-# SOURCE #-} TcUnify( boxyUnify {- , unifyType -} )
-import FastString(FastString)
+import FastString
import HsSyn
import TcHsSyn
import TcRnMonad
-- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
+mkImplicTy :: [TyVar] -> [Inst] -> [Inst] -> Type
mkImplicTy tvs givens wanteds -- The type of an implication constraint
= ASSERT( all isAbstractableInst givens )
-- pprTrace "mkImplicTy" (ppr givens) $
else
mkTupleTy Boxed (length dict_wanteds) (map instType dict_wanteds)
+dictPred :: Inst -> TcPredType
dictPred (Dict {tci_pred = pred}) = pred
dictPred (EqInst {tci_left=ty1,tci_right=ty2}) = EqPred ty1 ty2
dictPred inst = pprPanic "dictPred" (ppr inst)
+getDictClassTys :: Inst -> (Class, [Type])
getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
getDictClassTys inst = pprPanic "getDictClassTys" (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 :: Inst -> [TcPredType]
fdPredsOfInst (Dict {tci_pred = pred}) = [pred]
fdPredsOfInst (Method {tci_theta = theta}) = theta
fdPredsOfInst (ImplicInst {tci_given = gs,
fdPredsOfInsts :: [Inst] -> [PredType]
fdPredsOfInsts insts = concatMap fdPredsOfInst insts
+isInheritableInst :: Inst -> Bool
isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred
isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
-isInheritableInst other = True
+isInheritableInst _ = True
---------------------------------
ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
-ipNamesOfInst other = []
+ipNamesOfInst _ = []
---------------------------------
tyVarsOfInst :: Inst -> TcTyVarSet
-- Remember the free tyvars of a coercion
tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
+tyVarsOfInsts :: [Inst] -> VarSet
tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
+tyVarsOfLIE :: Bag Inst -> VarSet
tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
isEqInst :: Inst -> Bool
isEqInst (EqInst {}) = True
-isEqInst other = False
+isEqInst _ = False
isDict :: Inst -> Bool
isDict (Dict {}) = True
-isDict other = False
+isDict _ = False
isClassDict :: Inst -> Bool
isClassDict (Dict {tci_pred = pred}) = isClassPred pred
-isClassDict other = False
+isClassDict _ = False
isTyVarDict :: Inst -> Bool
isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
-isTyVarDict other = False
+isTyVarDict _ = False
isIPDict :: Inst -> Bool
isIPDict (Dict {tci_pred = pred}) = isIPPred pred
-isIPDict other = False
+isIPDict _ = False
+isImplicInst :: Inst -> Bool
isImplicInst (ImplicInst {}) = True
-isImplicInst other = False
+isImplicInst _ = False
isMethod :: Inst -> Bool
isMethod (Method {}) = True
-isMethod other = False
+isMethod _ = False
isMethodFor :: TcIdSet -> Inst -> Bool
isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
-isMethodFor ids inst = False
+isMethodFor _ _ = False
isMethodOrLit :: Inst -> Bool
isMethodOrLit (Method {}) = True
isMethodOrLit (LitInst {}) = True
-isMethodOrLit other = False
+isMethodOrLit _ = False
\end{code}
-- into the LIE, and returns a HsWrapper to enclose the call site.
-- This is the key place where equality predicates
-- are unleashed into the world
-instCallDicts loc [] = return idHsWrapper
+instCallDicts _ [] = return idHsWrapper
-- instCallDicts loc (EqPred ty1 ty2 : preds)
-- = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
-------------
cloneDict :: Inst -> TcM Inst
-cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
+cloneDict dict@(Dict nm _ _) = do { uniq <- newUnique
; return (dict {tci_name = setNameUnique nm uniq}) }
cloneDict eq@(EqInst {}) = return eq
cloneDict other = pprPanic "cloneDict" (ppr other)
name = mkPredName uniq inst_loc pred
dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
- return (mapIPName (\n -> instToId dict) ip_name, dict)
+ return (mapIPName (\_ -> instToId dict) ip_name, dict)
\end{code}
extendLIE inst
return (instToId inst)
+newMethodWithGivenTy :: InstOrigin -> Id -> [Type] -> TcRn TcId
newMethodWithGivenTy orig id tys = do
loc <- getInstLoc orig
inst <- newMethod loc id tys
---------------------------
+newMethod :: InstLoc -> Id -> [Type] -> TcRn Inst
newMethod inst_loc id tys = do
new_uniq <- newUnique
let
\end{code}
\begin{code}
-shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
-shortCutIntLit i ty
- | isIntTy ty && inIntRange i -- Short cut for Int
- = Just (HsLit (HsInt i))
- | isIntegerTy ty -- Short cut for Integer
- = Just (HsLit (HsInteger i ty))
- | otherwise = Nothing
-
-shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
-shortCutFracLit f ty
- | isFloatTy ty
- = Just (mk_lit floatDataCon (HsFloatPrim f))
- | isDoubleTy ty
- = Just (mk_lit doubleDataCon (HsDoublePrim f))
- | otherwise = Nothing
- 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 = do
- integer_ty <- tcMetaTy integerTyConName
- span <- getSrcSpanM
- return (L span $ HsLit (HsInteger i integer_ty))
-
-mkRatLit :: Rational -> TcM (LHsExpr TcId)
-mkRatLit r = do
- rat_ty <- tcMetaTy rationalTyConName
- span <- getSrcSpanM
- return (L span $ HsLit (HsRat r rat_ty))
-
-mkStrLit :: FastString -> TcM (LHsExpr TcId)
-mkStrLit s = do
- --string_ty <- tcMetaTy stringTyConName
- span <- getSrcSpanM
- return (L span $ HsLit (HsString s))
+mkOverLit :: OverLitVal -> TcM HsLit
+mkOverLit (HsIntegral i)
+ = do { integer_ty <- tcMetaTy integerTyConName
+ ; return (HsInteger i integer_ty) }
+
+mkOverLit (HsFractional r)
+ = do { rat_ty <- tcMetaTy rationalTyConName
+ ; return (HsRat r rat_ty) }
+
+mkOverLit (HsIsString s) = return (HsString s)
isHsVar :: HsExpr Name -> Name -> Bool
-isHsVar (HsVar f) g = f==g
-isHsVar other g = False
+isHsVar (HsVar f) g = f == g
+isHsVar _ _ = False
\end{code}
; return (eqinst {tci_co = co', tci_left= ty1', tci_right = ty2' })
}
+zonkInsts :: [Inst] -> TcRn [Inst]
zonkInsts insts = mapM zonkInst insts
\end{code}
pprInst, pprInstInFull :: Inst -> SDoc
-- Debugging: print the evidence :: type
-pprInst i@(EqInst {tci_left = ty1, tci_right = ty2, tci_co = co})
+pprInst i@(EqInst {tci_left = ty1, tci_right = ty2})
= eitherEqInst i
(\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
(\co -> text "Given" <+> ppr co <+> dcolon <+> ppr (EqPred ty1 ty2))
; return overlap_flag }
+traceDFuns :: [Instance] -> TcRn ()
traceDFuns ispecs
= traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
where
pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
-- Print the dfun name itself too
+funDepErr :: Instance -> [Instance] -> TcRn ()
funDepErr ispec ispecs
= addDictLoc ispec $
- addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
+ addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:"))
2 (pprInstances (ispec:ispecs)))
+dupInstErr :: Instance -> Instance -> TcRn ()
dupInstErr ispec dup_ispec
= addDictLoc ispec $
- addErr (hang (ptext SLIT("Duplicate instance declarations:"))
+ addErr (hang (ptext (sLit "Duplicate instance declarations:"))
2 (pprInstances [ispec, dup_ispec]))
+addDictLoc :: Instance -> TcRn a -> TcRn a
addDictLoc ispec thing_inside
= setSrcSpan (mkSrcSpan loc loc) thing_inside
where
-- [Same shortcut as in newOverloadedLit, but we
-- may have done some unification by now]
-lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name _, tci_ty = ty, tci_loc = loc})
- | Just expr <- shortCutIntLit i ty
- = return (GenInst [] (noLoc expr))
- | otherwise
- = ASSERT( from_integer_name `isHsVar` fromIntegerName ) do -- A LitInst invariant
- from_integer <- tcLookupId fromIntegerName
- method_inst <- tcInstClassOp loc from_integer [ty]
- integer_lit <- mkIntegerLit i
- return (GenInst [method_inst]
- (mkHsApp (L (instLocSpan loc)
- (HsVar (instToId method_inst))) integer_lit))
-
-lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name _, tci_ty = ty, tci_loc = loc})
- | Just expr <- shortCutFracLit f ty
- = return (GenInst [] (noLoc expr))
+lookupSimpleInst (LitInst { tci_lit = lit@OverLit { ol_val = lit_val
+ , ol_rebindable = rebindable }
+ , tci_ty = ty, tci_loc = iloc})
+#ifdef DEBUG
+ | rebindable = panic "lookupSimpleInst" -- A LitInst invariant
+#endif
+ | Just witness <- shortCutLit lit_val ty
+ = do { let lit' = lit { ol_witness = witness, ol_type = ty }
+ ; return (GenInst [] (L loc (HsOverLit lit'))) }
| otherwise
- = ASSERT( from_rat_name `isHsVar` fromRationalName ) do -- A LitInst invariant
- from_rational <- tcLookupId fromRationalName
- method_inst <- tcInstClassOp loc from_rational [ty]
- rat_lit <- mkRatLit f
- return (GenInst [method_inst] (mkHsApp (L (instLocSpan loc)
- (HsVar (instToId method_inst))) rat_lit))
-
-lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name _, tci_ty = ty, tci_loc = loc})
- | Just expr <- shortCutStringLit s ty
- = return (GenInst [] (noLoc expr))
- | otherwise
- = ASSERT( from_string_name `isHsVar` fromStringName ) do -- A LitInst invariant
- from_string <- tcLookupId fromStringName
- method_inst <- tcInstClassOp loc from_string [ty]
- string_lit <- mkStrLit s
- return (GenInst [method_inst]
- (mkHsApp (L (instLocSpan loc)
- (HsVar (instToId method_inst))) string_lit))
+ = do { hs_lit <- mkOverLit lit_val
+ ; from_thing <- tcLookupId (hsOverLitName lit_val)
+ -- Not rebindable, so hsOverLitName is the right thing
+ ; method_inst <- tcInstClassOp iloc from_thing [ty]
+ ; let witness = HsApp (L loc (HsVar (instToId method_inst)))
+ (L loc (HsLit hs_lit))
+ lit' = lit { ol_witness = witness, ol_type = ty }
+ ; return (GenInst [method_inst] (L loc (HsOverLit lit'))) }
+ where
+ loc = instLocSpan iloc
--------------------- Dictionaries ------------------------
lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
Just (dfun_id, mb_inst_tys) -> do
{ use_stage <- getStage
- ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
+ ; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
(topIdLvl dfun_id) use_stage
-- It's possible that not all the tyvars are in
; return Nothing }
}}
-lookupPred ip_pred = return Nothing -- Implicit parameters
+lookupPred (IParam {}) = return Nothing -- Implicit parameters
+lookupPred (EqPred {}) = panic "lookupPred EqPred"
+record_dfun_usage :: Id -> TcRn ()
record_dfun_usage dfun_id
= do { hsc_env <- getTopEnv
; let dfun_name = idName dfun_id
expr <- tcPolyExpr (L span user_nm_expr) sigma1
return (std_nm, unLoc expr)
+syntaxNameCtxt :: HsExpr Name -> InstOrigin -> Type -> TidyEnv
+ -> TcRn (TidyEnv, SDoc)
syntaxNameCtxt name orig ty tidy_env = do
inst_loc <- getInstLoc orig
let
- 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 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)]
+ 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 (ptext (sLit "arising from") <+> pprInstLoc inst_loc)]
return (tidy_env, msg)
\end{code}
= case either_co of
Left covar -> withWanted covar
Right co -> withGiven co
+eitherEqInst i _ _ = pprPanic "eitherEqInst" (ppr i)
mkEqInsts :: [PredType] -> [Either TcTyVar Coercion] -> TcM [Inst]
mkEqInsts preds cos = zipWithM mkEqInst preds cos
; return inst
}
where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
+mkEqInst pred _ = pprPanic "mkEqInst" (ppr pred)
mkWantedEqInst :: PredType -> TcM Inst
mkWantedEqInst pred@(EqPred ty1 ty2)
= do { cotv <- newMetaCoVar ty1 ty2
; mkEqInst pred (Left cotv)
}
+mkWantedEqInst pred = pprPanic "mkWantedEqInst" (ppr pred)
-- type inference:
-- We want to promote the wanted EqInst to a given EqInst
; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
; return given
}
+finalizeEqInst i = pprPanic "finalizeEqInst" (ppr i)
writeWantedCoercion
:: Inst -- wanted EqInst
projects / ghc-hetmet.git / blobdiff