X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FInst.lhs;h=45e8d8db8b363ee95462b31653d0ff2007ba0766;hp=5e9d985ca2a5b9cf3bfca41dd0b10d74c51cb5f2;hb=26416bba9d0bfe0b10bfee9d01053cf507d2918b;hpb=12d8935ec994db50dc5c0451abb6c35a823ed918 diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 5e9d985..45e8d8d 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -6,13 +6,6 @@ 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, @@ -23,9 +16,8 @@ module Inst ( newDictBndr, newDictBndrs, newDictBndrsO, instCall, instStupidTheta, - cloneDict, - shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict, - newMethod, newMethodFromName, newMethodWithGivenTy, + cloneDict, mkOverLit, + newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy, tcInstClassOp, tcSyntaxName, isHsVar, @@ -58,9 +50,9 @@ module Inst ( #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 @@ -100,7 +92,7 @@ import Data.List import TypeRep import Class -import Control.Monad ( liftM ) +import Control.Monad \end{code} @@ -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) $ @@ -153,10 +146,12 @@ mkImplicTy tvs givens wanteds -- The type of an implication constraint 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) @@ -166,6 +161,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 +172,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 +188,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 +204,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 +228,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} @@ -327,7 +327,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 @@ -356,7 +356,7 @@ instCallDicts loc (pred : preds) ------------- 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) @@ -367,15 +367,15 @@ 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 - = getInstLoc orig `thenM` \ inst_loc -> - newUnique `thenM` \ uniq -> +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} - in - returnM (mapIPName (\n -> instToId dict) ip_name, dict) + + return (mapIPName (\_ -> instToId dict) ip_name, dict) \end{code} @@ -405,22 +405,23 @@ mkPredName uniq loc pred_ty \begin{code} newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId -newMethodFromName origin ty name - = tcLookupId name `thenM` \ id -> +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 -- meant to find whatever thing is in scope, and that may -- be an ordinary function. - getInstLoc origin `thenM` \ loc -> - tcInstClassOp loc id [ty] `thenM` \ inst -> - extendLIE inst `thenM_` - returnM (instToId inst) - -newMethodWithGivenTy orig id tys - = getInstLoc orig `thenM` \ loc -> - newMethod loc id tys `thenM` \ inst -> - extendLIE inst `thenM_` - returnM (instToId inst) + loc <- getInstLoc origin + inst <- tcInstClassOp loc id [ty] + extendLIE inst + return (instToId inst) + +newMethodWithGivenTy :: InstOrigin -> Id -> [Type] -> TcRn TcId +newMethodWithGivenTy orig id tys = do + loc <- getInstLoc orig + inst <- newMethod loc id tys + extendLIE inst + return (instToId inst) -------------------------------------------- -- tcInstClassOp, and newMethod do *not* drop the @@ -434,11 +435,10 @@ newMethodWithGivenTy orig id tys -- Hence the call to checkKind -- A worry: is this needed anywhere else? tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst -tcInstClassOp inst_loc sel_id tys - = let +tcInstClassOp inst_loc sel_id tys = do + let (tyvars, _rho) = tcSplitForAllTys (idType sel_id) - in - zipWithM_ checkKind tyvars tys `thenM_` + zipWithM_ checkKind tyvars tys newMethod inst_loc sel_id tys checkKind :: TyVar -> TcType -> TcM () @@ -459,64 +459,34 @@ checkKind tv ty --------------------------- -newMethod inst_loc id tys - = newUnique `thenM` \ new_uniq -> +newMethod :: InstLoc -> Id -> [Type] -> TcRn Inst +newMethod inst_loc id tys = do + new_uniq <- newUnique let (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys) 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 = instLocSpan inst_loc - in - returnM inst + + return inst \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 - = tcMetaTy integerTyConName `thenM` \ integer_ty -> - getSrcSpanM `thenM` \ span -> - returnM (L span $ HsLit (HsInteger i integer_ty)) - -mkRatLit :: Rational -> TcM (LHsExpr TcId) -mkRatLit r - = tcMetaTy rationalTyConName `thenM` \ rat_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)) +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,24 +500,24 @@ Zonking makes sure that the instance types are fully zonked. \begin{code} zonkInst :: Inst -> TcM Inst -zonkInst dict@(Dict { tci_pred = pred}) - = zonkTcPredType pred `thenM` \ new_pred -> - returnM (dict {tci_pred = new_pred}) +zonkInst dict@(Dict { tci_pred = pred}) = do + new_pred <- zonkTcPredType pred + return (dict {tci_pred = new_pred}) -zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) - = zonkId id `thenM` \ new_id -> +zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) = do + new_id <- zonkId id -- Essential to zonk the id in case it's a local variable -- Can't use zonkIdOcc because the id might itself be -- an InstId, in which case it won't be in scope - zonkTcTypes tys `thenM` \ new_tys -> - zonkTcThetaType theta `thenM` \ new_theta -> - returnM (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta }) + new_tys <- zonkTcTypes tys + new_theta <- zonkTcThetaType theta + return (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta }) -- No need to zonk the tci_id -zonkInst lit@(LitInst {tci_ty = ty}) - = zonkTcType ty `thenM` \ new_ty -> - returnM (lit {tci_ty = new_ty}) +zonkInst lit@(LitInst {tci_ty = ty}) = do + new_ty <- zonkTcType ty + return (lit {tci_ty = new_ty}) zonkInst implic@(ImplicInst {}) = ASSERT( all isImmutableTyVar (tci_tyvars implic) ) @@ -564,7 +534,8 @@ zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2}) ; return (eqinst {tci_co = co', tci_left= ty1', tci_right = ty2' }) } -zonkInsts insts = mappM zonkInst insts +zonkInsts :: [Inst] -> TcRn [Inst] +zonkInsts insts = mapM zonkInst insts \end{code} @@ -599,20 +570,18 @@ 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)) pprInst inst = ppr name <> braces (pprUnique (getUnique name)) <+> dcolon - <+> (braces (ppr (instType inst) <> implicWantedEqs) $$ - ifPprDebug implic_stuff) + <+> braces (ppr (instType inst) <> implicWantedEqs) where name = instName inst - (implic_stuff, implicWantedEqs) - | isImplicInst inst = (ppr (tci_reft inst), - text " &" <+> - ppr (filter isEqInst (tci_wanted inst))) - | otherwise = (empty, empty) + implicWantedEqs + | isImplicInst inst = text " &" <+> + ppr (filter isEqInst (tci_wanted inst)) + | otherwise = empty pprInstInFull inst@(EqInst {}) = pprInst inst pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)] @@ -722,21 +691,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:")) + 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 @@ -782,41 +755,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 - = 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 (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 - = returnM (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 ) -- A LitInst invariant - tcLookupId fromRationalName `thenM` \ from_rational -> - tcInstClassOp loc from_rational [ty] `thenM` \ method_inst -> - mkRatLit f `thenM` \ rat_lit -> - returnM (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 - = 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)) + = 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}) @@ -826,7 +783,7 @@ 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 @@ -837,17 +794,17 @@ lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc}) ; 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 + ; tys <- mapM inst_tv mb_inst_tys ; let (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys) src_loc = instLocSpan loc dfun = HsVar dfun_id ; if null theta then - returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun)) + return (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun)) else do { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!! ; let co_fn = dict_app <.> mkWpTyApps tys - ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun)) + ; return (GenInst dicts (L src_loc $ HsWrap co_fn dfun)) }}}} --------------- @@ -881,8 +838,10 @@ 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 @@ -943,36 +902,38 @@ tcSyntaxName :: InstOrigin tcSyntaxName orig ty (std_nm, HsVar user_nm) | std_nm == user_nm - = newMethodFromName orig ty std_nm `thenM` \ id -> - returnM (std_nm, HsVar id) + = do id <- newMethodFromName orig ty std_nm + return (std_nm, HsVar id) -tcSyntaxName orig ty (std_nm, user_nm_expr) - = tcLookupId std_nm `thenM` \ std_id -> +tcSyntaxName orig ty (std_nm, user_nm_expr) = do + std_id <- tcLookupId std_nm let -- C.f. newMethodAtLoc ([tv], _, tau) = tcSplitSigmaTy (idType std_id) sigma1 = substTyWith [tv] [ty] tau -- Actually, the "tau-type" might be a sigma-type in the -- case of locally-polymorphic methods. - in - addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ + + addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do -- Check that the user-supplied thing has the -- same type as the standard one. -- Tiresome jiggling because tcCheckSigma takes a located expression - getSrcSpanM `thenM` \ span -> - tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr -> - returnM (std_nm, unLoc expr) - -syntaxNameCtxt name orig ty tidy_env - = getInstLoc orig `thenM` \ inst_loc -> + span <- getSrcSpanM + 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)] - in - returnM (tidy_env, msg) + 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} %************************************************************************ @@ -1004,6 +965,7 @@ 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 @@ -1019,12 +981,14 @@ mkEqInst (EqPred ty1 ty2) co ; 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 @@ -1040,6 +1004,7 @@ finalizeEqInst wanted@(EqInst {tci_left = ty1, tci_right = ty2, tci_name = name} ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var } ; return given } +finalizeEqInst i = pprPanic "finalizeEqInst" (ppr i) writeWantedCoercion :: Inst -- wanted EqInst