X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FInst.lhs;h=b5eeff0b6b5ef9b2dc2bfba94ca83eadcdf18626;hp=b1636a7e221851338f6e1ac9db14614f3c165d38;hb=66579ff945831c5fc9a17c58c722ff01f2268d76;hpb=c51a0666f41b91ed6b8cad334eb54e7f01560d32 diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index b1636a7..b5eeff0 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -6,15 +6,8 @@ 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 @@ -22,10 +15,10 @@ module Inst ( 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, @@ -47,18 +40,17 @@ module Inst ( 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 import HsSyn @@ -69,6 +61,7 @@ import InstEnv import FunDeps import TcMType import TcType +import MkCore import Type import TypeRep import Class @@ -77,16 +70,13 @@ import Module 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 @@ -97,13 +87,12 @@ import Util import Unique import Outputable import Data.List -import TypeRep -import Class import Control.Monad \end{code} + Selection ~~~~~~~~~ \begin{code} @@ -128,8 +117,11 @@ instToVar (Dict {tci_name = nm, tci_pred = pred}) 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 @@ -140,6 +132,7 @@ instType imp@(ImplicInst {}) = mkImplicTy (tci_tyvars imp) (tci_given imp) -- 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) $ @@ -148,15 +141,14 @@ mkImplicTy tvs givens wanteds -- The type of an implication constraint 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) @@ -166,6 +158,7 @@ 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, @@ -176,9 +169,10 @@ fdPredsOfInst (EqInst {}) = [] 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 --------------------------------- @@ -191,7 +185,7 @@ 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 = [] +ipNamesOfInst _ = [] --------------------------------- tyVarsOfInst :: Inst -> TcTyVarSet @@ -207,7 +201,9 @@ tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wan -- 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) @@ -229,39 +225,40 @@ isAbstractableInst inst = isDict inst || isEqInst inst 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} @@ -285,16 +282,41 @@ newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst] 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}) } @@ -327,7 +349,7 @@ instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper -- 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 @@ -341,24 +363,21 @@ instCallDicts loc [] = return idHsWrapper 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 @@ -367,15 +386,10 @@ cloneDict other = pprPanic "cloneDict" (ppr other) -- 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} @@ -392,7 +406,7 @@ mkPredName uniq loc pred_ty -- 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} @@ -408,7 +422,7 @@ newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId 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 @@ -416,6 +430,7 @@ newMethodFromName origin ty name = do extendLIE inst return (instToId inst) +newMethodWithGivenTy :: InstOrigin -> Id -> [Type] -> TcRn TcId newMethodWithGivenTy orig id tys = do loc <- getInstLoc orig inst <- newMethod loc id tys @@ -458,6 +473,7 @@ checkKind tv ty --------------------------- +newMethod :: InstLoc -> Id -> [Type] -> TcRn Inst newMethod inst_loc id tys = do new_uniq <- newUnique let @@ -471,52 +487,20 @@ newMethod inst_loc id tys = do \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} @@ -530,7 +514,7 @@ Zonking makes sure that the instance types are fully zonked. \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}) @@ -561,9 +545,10 @@ zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2}) (\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} @@ -599,7 +584,7 @@ pprInsts insts = brackets (interpp'SP insts) 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)) @@ -720,21 +705,25 @@ getOverlapFlag ; 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:")) 2 (pprInstances (ispec:ispecs))) +dupInstErr :: Instance -> Instance -> TcRn () dupInstErr ispec dup_ispec = addDictLoc ispec $ 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 @@ -780,41 +769,25 @@ lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_lo -- [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}) @@ -879,12 +852,15 @@ lookupPred pred@(ClassP clas tys) ; 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 @@ -908,7 +884,7 @@ tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv; %* * %************************************************************************ -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 @@ -962,6 +938,8 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do 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 @@ -979,20 +957,96 @@ syntaxNameCtxt name orig ty tidy_env = do %* * %************************************************************************ +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 @@ -1002,61 +1056,70 @@ eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven = 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}