Note [Implicit parameters and ambiguity]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-What type should we infer for this?
- f x = (show ?y, x::Int)
-Since we must quantify over the ?y, the most plausible type is
- f :: (Show a, ?y::a) => Int -> (String, Int)
-But notice that the type of the RHS is (String,Int), with no type
-varibables mentioned at all! The type of f looks ambiguous. But
-it isn't, because at a call site we might have
- let ?y = 5::Int in f 7
+Only a *class* predicate can give rise to ambiguity
+An *implicit parameter* cannot. For example:
+ foo :: (?x :: [a]) => Int
+ foo = length ?x
+is fine. The call site will suppply a particular 'x'
+
+Furthermore, the type variables fixed by an implicit parameter
+propagate to the others. E.g.
+ foo :: (Show a, ?x::[a]) => Int
+ foo = show (?x++?x)
+The type of foo looks ambiguous. But it isn't, because at a call site
+we might have
+ let ?x = 5::Int in foo
and all is well. In effect, implicit parameters are, well, parameters,
so we can take their type variables into account as part of the
"tau-tvs" stuff. This is done in the function 'FunDeps.grow'.
-- to fromInteger; this looks fragile to me
; lookup_result <- lookupSimpleInst w'
; case lookup_result of
- GenInst ws' rhs -> go dicts (addBind binds w rhs) (ws' ++ ws)
+ GenInst ws' rhs ->
+ go dicts (addInstToDictBind binds w rhs) (ws' ++ ws)
NoInstance -> pprPanic "tcSimplifyRuleLhs" (ppr w)
}
\end{code}
; traceTc $ text "reduceContext: ancestor eqs" <+> ppr ancestor_eqs
-- 1. Normalise the *given* *equality* constraints
- ; (given_eqs, eliminate_skolems) <- normaliseGivens given_eqs0
+ ; (given_eqs, eliminate_skolems) <- normaliseGivenEqs given_eqs0
-- 2. Normalise the *given* *dictionary* constraints
-- wrt. the toplevel and given equations
given_dicts0
-- 3. Solve the *wanted* *equation* constraints
- ; eq_irreds0 <- solveWanteds given_eqs wanted_eqs
+ ; eq_irreds0 <- solveWantedEqs given_eqs wanted_eqs
-- 4. Normalise the *wanted* equality constraints with respect to
-- each other
- ; eq_irreds <- normaliseWanteds eq_irreds0
+ ; eq_irreds <- normaliseWantedEqs eq_irreds0
-- 5. Build the Avail mapping from "given_dicts"
; init_state <- foldlM addGiven emptyAvails given_dicts
Just (Given id)
| id == w_id -> go avails binds irreds (w:givens) ws
- | otherwise -> go avails (addBind binds w (nlHsVar id)) irreds (update_id w id:givens) ws
+ | otherwise ->
+ go avails (addInstToDictBind binds w (nlHsVar id)) irreds
+ (update_id w id:givens) ws
-- The sought Id can be one of the givens, via a superclass chain
-- and then we definitely don't want to generate an x=x binding!
Just (Rhs rhs ws') -> go (add_given avails w) new_binds irreds givens (ws' ++ ws)
where
- new_binds = addBind binds w rhs
+ new_binds = addInstToDictBind binds w rhs
where
w_id = instToId w
update_id m@(Method{}) id = m {tci_id = id}
Just (Rhs rhs ws') -> go (add_given avails w) new_binds givens (ws' ++ ws)
where
- new_binds = addBind binds w rhs
+ new_binds = addInstToDictBind binds w rhs
where
w_id = instToId w
find_all :: IdSet -> Inst -> IdSet
find_all so_far kid
+ | isEqInst kid = so_far
| kid_id `elemVarSet` so_far = so_far
| Just avail <- findAvail avails kid = findAllDeps so_far' avail
| otherwise = so_far'
; mapM_ complain_implic implics
; mapM_ (\doc -> addErrTcM (tidy_env, doc)) overlaps
; groupErrs complain_no_inst insts3
- ; mapM_ complain_eq eqInsts
+ ; mapM_ eqInstMisMatch eqInsts
}
where
complain_no_inst insts = addErrTcM (tidy_env, mk_no_inst_err insts)
(Just (tci_loc inst, tci_given inst))
(tci_wanted inst)
- complain_eq EqInst {tci_left = lty, tci_right = rty,
- tci_loc = InstLoc _ _ ctxt}
- = do { (env, msg) <- misMatchMsg lty rty
- ; setErrCtxt ctxt $
- failWithTcM (env, msg)
- }
-
check_overlap :: (InstEnv,InstEnv) -> Inst -> Either Inst SDoc
-- Right msg => overlap message
-- Left inst => no instance
nest 4 (pprStack stack)]
pprStack stack = vcat (map pprInstInFull stack)
-
------------------------
-misMatchMsg :: TcType -> TcType -> TcM (TidyEnv, SDoc)
--- Generate the message when two types fail to match,
--- going to some trouble to make it helpful.
--- The argument order is: actual type, expected type
-misMatchMsg ty_act ty_exp
- = do { env0 <- tcInitTidyEnv
- ; ty_exp <- zonkTcType ty_exp
- ; ty_act <- zonkTcType ty_act
- ; (env1, pp_exp, extra_exp) <- ppr_ty env0 ty_exp
- ; (env2, pp_act, extra_act) <- ppr_ty env1 ty_act
- ; return (env2,
- sep [sep [ptext SLIT("Couldn't match expected type") <+> pp_exp,
- nest 7 $
- ptext SLIT("against inferred type") <+> pp_act],
- nest 2 (extra_exp $$ extra_act)]) }
-
-ppr_ty :: TidyEnv -> TcType -> TcM (TidyEnv, SDoc, SDoc)
-ppr_ty env ty
- = do { let (env1, tidy_ty) = tidyOpenType env ty
- ; (env2, extra) <- ppr_extra env1 tidy_ty
- ; return (env2, quotes (ppr tidy_ty), extra) }
-
--- (ppr_extra env ty) shows extra info about 'ty'
-ppr_extra env (TyVarTy tv)
- | isSkolemTyVar tv || isSigTyVar tv
- = return (env1, pprSkolTvBinding tv1)
- where
- (env1, tv1) = tidySkolemTyVar env tv
-
-ppr_extra env ty = return (env, empty) -- Normal case
\end{code}
projects / ghc-hetmet.git / blobdiff