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,
+ Inst,
pprInstances, pprDictsTheta, pprDictsInFull, -- User error messages
showLIE, pprInst, pprInsts, pprInstInFull, -- Debugging messages
tidyInsts, tidyMoreInsts,
newDictBndr, newDictBndrs, newDictBndrsO,
+ newDictOccs, newDictOcc,
instCall, instStupidTheta,
- cloneDict,
- shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict,
- newMethod, newMethodFromName, newMethodWithGivenTy,
+ cloneDict, mkOverLit,
+ newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy,
tcInstClassOp,
tcSyntaxName, isHsVar,
InstOrigin(..), InstLoc, pprInstLoc,
- mkWantedCo, mkGivenCo,
- fromWantedCo, fromGivenCo,
- eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst,
- finalizeEqInst, writeWantedCoercion,
- eqInstType, updateEqInstCoercion,
- eqInstCoercion, eqInstTys
+ mkWantedCo, mkGivenCo, isWantedCo, eqInstCoType, mkIdEqInstCo,
+ mkSymEqInstCo, mkLeftTransEqInstCo, mkRightTransEqInstCo, mkAppEqInstCo,
+ wantedEqInstIsUnsolved, eitherEqInst, mkEqInst, mkWantedEqInst,
+ wantedToLocalEqInst, finalizeEqInst, eqInstType, eqInstCoercion,
+ eqInstTys
) where
#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
import FunDeps
import TcMType
import TcType
+import MkCore
import Type
import TypeRep
import Class
import Coercion
import HscTypes
import CoreFVs
-import DataCon
import Id
import Name
import NameSet
-import Literal
import Var ( Var, TyVar )
import qualified Var
import VarEnv
import VarSet
-import TysWiredIn
import PrelNames
import BasicTypes
import SrcLoc
import Unique
import Outputable
import Data.List
-import TypeRep
-import Class
import Control.Monad
\end{code}
+
Selection
~~~~~~~~~
\begin{code}
instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
tci_wanted = wanteds})
= mkLocalId nm (mkImplicTy tvs givens wanteds)
-instToVar i@(EqInst {})
- = eitherEqInst i id (\(TyVarTy covar) -> covar)
+instToVar inst@(EqInst {})
+ = eitherEqInst inst id assertCoVar
+ where
+ assertCoVar (TyVarTy cotv) = cotv
+ assertCoVar coty = pprPanic "Inst.instToVar" (ppr coty)
instType :: Inst -> Type
instType (LitInst {tci_ty = ty}) = ty
-- 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) $
in
mkForAllTys tvs $
mkPhiTy (map dictPred givens) $
- if isSingleton dict_wanteds then
- instType (head dict_wanteds)
- else
- mkTupleTy Boxed (length dict_wanteds) (map instType dict_wanteds)
+ mkBigCoreTupTy (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}
newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
newDictBndr :: InstLoc -> TcPredType -> TcM Inst
+-- Makes a "given"
newDictBndr inst_loc pred@(EqPred ty1 ty2)
= do { uniq <- newUnique
; let name = mkPredName uniq inst_loc pred
+ co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))
; return (EqInst {tci_name = name,
tci_loc = inst_loc,
tci_left = ty1,
tci_right = ty2,
- tci_co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))})
- }
-newDictBndr inst_loc pred
+ tci_co = co }) }
+
+newDictBndr inst_loc pred = newDict inst_loc pred
+
+-------------------
+newDictOccs :: InstLoc -> TcThetaType -> TcM [Inst]
+newDictOccs inst_loc theta = mapM (newDictOcc inst_loc) theta
+
+newDictOcc :: InstLoc -> TcPredType -> TcM Inst
+-- Makes a "wanted"
+newDictOcc inst_loc pred@(EqPred ty1 ty2)
+ = do { uniq <- newUnique
+ ; cotv <- newMetaCoVar ty1 ty2
+ ; let name = mkPredName uniq inst_loc pred
+ ; return (EqInst {tci_name = name,
+ tci_loc = inst_loc,
+ tci_left = ty1,
+ tci_right = ty2,
+ tci_co = Left cotv }) }
+
+newDictOcc inst_loc pred = newDict inst_loc pred
+
+----------------
+newDict :: InstLoc -> TcPredType -> TcM Inst
+-- Always makes a Dict, not an EqInst
+newDict inst_loc pred
= do { uniq <- newUnique
; let name = mkPredName uniq inst_loc pred
; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
-- 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
instCallDicts loc (EqPred ty1 ty2 : preds)
= do { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
; coi <- boxyUnify ty1 ty2
--- ; coi <- unifyType ty1 ty2
; let co = fromCoI coi ty1
; co_fn <- instCallDicts loc preds
; return (co_fn <.> WpTyApp co) }
instCallDicts loc (pred : preds)
- = do { uniq <- newUnique
- ; let name = mkPredName uniq loc pred
- dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
+ = do { dict <- newDict loc pred
; extendLIE dict
; co_fn <- instCallDicts loc preds
; return (co_fn <.> WpApp (instToId dict)) }
-------------
cloneDict :: Inst -> TcM Inst
-cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
- ; return (dict {tci_name = setNameUnique nm uniq}) }
-cloneDict eq@(EqInst {}) = return eq
+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)
-- For vanilla implicit parameters, there is only one in scope
-- scope, so we make up a new namea.
newIPDict :: InstOrigin -> IPName Name -> Type
-> TcM (IPName Id, Inst)
-newIPDict orig ip_name ty = do
- inst_loc <- getInstLoc orig
- uniq <- newUnique
- let
- pred = IParam ip_name ty
- 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)
+newIPDict orig ip_name ty
+ = do { inst_loc <- getInstLoc orig
+ ; dict <- newDict inst_loc (IParam ip_name ty)
+ ; return (mapIPName (\_ -> instToId dict) ip_name, dict) }
\end{code}
-- 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 "$"
+ Nothing -> mkTcOcc "$"
Just (tc, _) -> getOccName tc
\end{code}
newMethodFromName origin ty name = do
id <- tcLookupId name
-- Use tcLookupId not tcLookupGlobalId; the method is almost
- -- always a class op, but with -fno-implicit-prelude GHC is
+ -- always a class op, but with -XNoImplicitPrelude GHC is
-- meant to find whatever thing is in scope, and that may
-- be an ordinary function.
loc <- getInstLoc origin
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 = Just (HsLit (HsInt i))
- | isIntegerTy ty = Just (HsLit (HsInteger i ty))
- | otherwise = shortCutFracLit (fromInteger i) ty
- -- The 'otherwise' case is important
- -- Consider (3 :: Float). Syntactically it looks like an IntLit,
- -- so we'll call shortCutIntLit, but of course it's a float
- -- This can make a big difference for programs with a lot of
- -- literals, compiled without -O
-
-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}
\begin{code}
zonkInst :: Inst -> TcM Inst
-zonkInst dict@(Dict { tci_pred = pred}) = do
+zonkInst dict@(Dict {tci_pred = pred}) = do
new_pred <- zonkTcPredType pred
return (dict {tci_pred = new_pred})
(\co -> liftM mkGivenCo $ zonkTcType co)
; ty1' <- zonkTcType ty1
; ty2' <- zonkTcType ty2
- ; return (eqinst {tci_co = co', tci_left= ty1', tci_right = ty2' })
+ ; 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})
+ | debugIsOn && rebindable = panic "lookupSimpleInst" -- A LitInst invariant
+ | 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
- dfun_mod = nameModule dfun_name
+ dfun_mod = ASSERT( isExternalName dfun_name )
+ nameModule dfun_name
; if isInternalName dfun_name || -- Internal name => defined in this module
modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
then return () -- internal, or in another package
%* *
%************************************************************************
-Suppose we are doing the -fno-implicit-prelude thing, and we encounter
+Suppose we are doing the -XNoImplicitPrelude 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
Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
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}
%* *
%************************************************************************
+Operations on EqInstCo.
+
\begin{code}
-mkGivenCo :: Coercion -> Either TcTyVar Coercion
+mkGivenCo :: Coercion -> EqInstCo
mkGivenCo = Right
-mkWantedCo :: TcTyVar -> Either TcTyVar Coercion
+mkWantedCo :: TcTyVar -> EqInstCo
mkWantedCo = Left
-fromGivenCo :: Either TcTyVar Coercion -> Coercion
-fromGivenCo (Right co) = co
-fromGivenCo _ = panic "fromGivenCo: not a wanted coercion"
+isWantedCo :: EqInstCo -> Bool
+isWantedCo (Left _) = True
+isWantedCo _ = False
+
+eqInstCoType :: EqInstCo -> TcType
+eqInstCoType (Left cotv) = mkTyVarTy cotv
+eqInstCoType (Right co) = co
+\end{code}
+
+Coercion transformations on EqInstCo. These transformations work differently
+depending on whether a EqInstCo is for a wanted or local equality:
+
+ Local : apply the inverse of the specified coercion
+ Wanted: obtain a fresh coercion hole (meta tyvar) and update the old hole
+ to be the specified coercion applied to the new coercion hole
+
+\begin{code}
+-- Coercion transformation: co = id
+--
+mkIdEqInstCo :: EqInstCo -> Type -> TcM ()
+mkIdEqInstCo (Left cotv) t
+ = writeMetaTyVar cotv t
+mkIdEqInstCo (Right _) _
+ = return ()
+
+-- Coercion transformation: co = sym co'
+--
+mkSymEqInstCo :: EqInstCo -> (Type, Type) -> TcM EqInstCo
+mkSymEqInstCo (Left cotv) (ty1, ty2)
+ = do { cotv' <- newMetaCoVar ty1 ty2
+ ; writeMetaTyVar cotv (mkSymCoercion (TyVarTy cotv'))
+ ; return $ Left cotv'
+ }
+mkSymEqInstCo (Right co) _
+ = return $ Right (mkSymCoercion co)
+
+-- Coercion transformation: co = co' |> given_co
+--
+mkLeftTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo
+mkLeftTransEqInstCo (Left cotv) given_co (ty1, ty2)
+ = do { cotv' <- newMetaCoVar ty1 ty2
+ ; writeMetaTyVar cotv (TyVarTy cotv' `mkTransCoercion` given_co)
+ ; return $ Left cotv'
+ }
+mkLeftTransEqInstCo (Right co) given_co _
+ = return $ Right (co `mkTransCoercion` mkSymCoercion given_co)
+
+-- Coercion transformation: co = given_co |> co'
+--
+mkRightTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo
+mkRightTransEqInstCo (Left cotv) given_co (ty1, ty2)
+ = do { cotv' <- newMetaCoVar ty1 ty2
+ ; writeMetaTyVar cotv (given_co `mkTransCoercion` TyVarTy cotv')
+ ; return $ Left cotv'
+ }
+mkRightTransEqInstCo (Right co) given_co _
+ = return $ Right (mkSymCoercion given_co `mkTransCoercion` co)
+
+-- Coercion transformation: co = col cor
+--
+mkAppEqInstCo :: EqInstCo -> (Type, Type) -> (Type, Type)
+ -> TcM (EqInstCo, EqInstCo)
+mkAppEqInstCo (Left cotv) (ty1_l, ty2_l) (ty1_r, ty2_r)
+ = do { cotv_l <- newMetaCoVar ty1_l ty2_l
+ ; cotv_r <- newMetaCoVar ty1_r ty2_r
+ ; writeMetaTyVar cotv (mkAppCoercion (TyVarTy cotv_l) (TyVarTy cotv_r))
+ ; return (Left cotv_l, Left cotv_r)
+ }
+mkAppEqInstCo (Right co) _ _
+ = return (Right $ mkLeftCoercion co, Right $ mkRightCoercion co)
+\end{code}
+
+Operations on entire EqInst.
-fromWantedCo :: String -> Either TcTyVar Coercion -> TcTyVar
-fromWantedCo _ (Left covar) = covar
-fromWantedCo msg _ = panic ("fromWantedCo: not a wanted coercion: " ++ msg)
+\begin{code}
+-- |A wanted equality is unsolved as long as its cotv is unfilled.
+--
+wantedEqInstIsUnsolved :: Inst -> TcM Bool
+wantedEqInstIsUnsolved (EqInst {tci_co = Left cotv})
+ = liftM not $ isFilledMetaTyVar cotv
+wantedEqInstIsUnsolved _ = return True
eitherEqInst :: Inst -- given or wanted EqInst
-> (TcTyVar -> a) -- result if wanted
= 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
-
-mkEqInst :: PredType -> Either TcTyVar Coercion -> TcM Inst
+mkEqInst :: PredType -> EqInstCo -> TcM Inst
mkEqInst (EqPred ty1 ty2) co
= do { uniq <- newUnique
; src_span <- getSrcSpanM
; err_ctxt <- getErrCtxt
; let loc = InstLoc EqOrigin src_span err_ctxt
name = mkName uniq src_span
- inst = EqInst {tci_left = ty1, tci_right = ty2, tci_co = co, tci_loc = loc, tci_name = name}
+ inst = EqInst { tci_left = ty1
+ , tci_right = ty2
+ , tci_co = co
+ , tci_loc = loc
+ , tci_name = name
+ }
; return inst
}
- where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
+ 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)
+
+-- Turn a wanted equality into a local that propagates the uninstantiated
+-- coercion variable as witness. We need this to propagate wanted irreds into
+-- attempts to solve implication constraints.
+--
+wantedToLocalEqInst :: Inst -> Inst
+wantedToLocalEqInst eq@(EqInst {tci_co = Left cotv})
+ = eq {tci_co = Right (mkTyVarTy cotv)}
+wantedToLocalEqInst eq = eq
+
+-- Turn a wanted into a local EqInst (needed during type inference for
+-- signatures)
+--
+-- * Give it a name and change the coercion around.
+--
+finalizeEqInst :: Inst -- wanted
+ -> TcM Inst -- given
+finalizeEqInst wanted@(EqInst{tci_left = ty1, tci_right = ty2,
+ tci_name = name, tci_co = Left cotv})
+ = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
+
+ -- fill the coercion hole
+ ; writeMetaTyVar cotv (TyVarTy var)
+
+ -- set the new coercion
+ ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
+ ; return given
+ }
--- type inference:
--- We want to promote the wanted EqInst to a given EqInst
--- in the signature context.
--- This means we have to give the coercion a name
--- and fill it in as its own name.
-finalizeEqInst
- :: Inst -- wanted
- -> TcM Inst -- given
-finalizeEqInst wanted@(EqInst {tci_left = ty1, tci_right = ty2, tci_name = name})
- = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
- ; writeWantedCoercion wanted (TyVarTy var)
- ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
- ; return given
- }
-
-writeWantedCoercion
- :: Inst -- wanted EqInst
- -> Coercion -- coercion to fill the hole with
- -> TcM ()
-writeWantedCoercion wanted co
- = do { let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted
- ; writeMetaTyVar cotv co
- }
+finalizeEqInst i = pprPanic "finalizeEqInst" (ppr i)
eqInstType :: Inst -> TcType
eqInstType inst = eitherEqInst inst mkTyVarTy id
-eqInstCoercion :: Inst -> Either TcTyVar Coercion
+eqInstCoercion :: Inst -> EqInstCo
eqInstCoercion = tci_co
eqInstTys :: Inst -> (TcType, TcType)
eqInstTys inst = (tci_left inst, tci_right inst)
-
-updateEqInstCoercion :: (Either TcTyVar Coercion -> Either TcTyVar Coercion) -> Inst -> Inst
-updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}
\end{code}
projects / ghc-hetmet.git / blobdiff