import HsSyn
import TcRnMonad
+import TcHsSyn ( hsLPatType )
import Inst
import TcEnv
import InstEnv
import TcMType
import TcIface
import TcTyFuns
+import DsUtils -- Big-tuple functions
import TypeRep
import Var
import Name
(eq_irreds, dict_irreds) = partition isEqInst irreds
n_dict_irreds = length dict_irreds
dict_irred_ids = map instToId dict_irreds
- tup_ty = mkTupleTy Boxed n_dict_irreds (map idType dict_irred_ids)
- pat = TuplePat (map nlVarPat dict_irred_ids) Boxed tup_ty
+ lpat = mkBigLHsPatTup (map (L span . VarPat) dict_irred_ids)
rhs = L span (mkHsWrap co (HsVar (instToId implic_inst)))
co = mkWpApps (map instToId dict_givens)
<.> mkWpTyApps eq_tyvar_cos
<.> mkWpTyApps (mkTyVarTys all_tvs)
bind | [dict_irred_id] <- dict_irred_ids = VarBind dict_irred_id rhs
- | otherwise = PatBind { pat_lhs = L span pat,
+ | otherwise = PatBind { pat_lhs = lpat,
pat_rhs = unguardedGRHSs rhs,
- pat_rhs_ty = tup_ty,
+ pat_rhs_ty = hsLPatType lpat,
bind_fvs = placeHolderNames }
; traceTc $ text "makeImplicationBind" <+> ppr implic_inst
; return ([implic_inst], unitBag (L span bind))
t_a to 'a', where 'a' is the skolem from test5's signatures (due to the
Modular s a predicate in that signature). If we don't zonk (Modular s t_a) in
the givens, we will get into a loop as improveOne uses the unification engine
-TcGadt.tcUnifyTys, which doesn't know about mutable type variables.
+Unify.tcUnifyTys, which doesn't know about mutable type variables.
Note [LOOP]
-- Warn in the mono
; warn_mono <- doptM Opt_WarnMonomorphism
; warnTc (warn_mono && (constrained_tvs' `intersectsVarSet` qtvs1))
- (vcat[ ptext SLIT("the Monomorphism Restriction applies to the binding")
- <> plural bndrs <+> ptext SLIT("for") <+> pp_bndrs,
- ptext SLIT("Consider giving a type signature for") <+> pp_bndrs])
+ (vcat[ ptext (sLit "the Monomorphism Restriction applies to the binding")
+ <> plural bndrs <+> ptext (sLit "for") <+> pp_bndrs,
+ ptext (sLit "Consider giving a type signature for") <+> pp_bndrs])
; traceTc (text "tcSimplifyRestricted" <+> vcat [
pprInsts wanteds, pprInsts constrained_dicts',
-> TcM ImprovementDone
unifyEqns [] = return False
unifyEqns eqns
- = do { traceTc (ptext SLIT("Improve:") <+> vcat (map pprEquationDoc eqns))
+ = do { traceTc (ptext (sLit "Improve:") <+> vcat (map pprEquationDoc eqns))
; mapM_ unify eqns
; return True }
where
mkEqnMsg (pred1,from1) (pred2,from2) tidy_env
= do { pred1' <- zonkTcPredType pred1; pred2' <- zonkTcPredType pred2
; let { pred1'' = tidyPred tidy_env pred1'; pred2'' = tidyPred tidy_env pred2' }
- ; let msg = vcat [ptext SLIT("When using functional dependencies to combine"),
+ ; let msg = vcat [ptext (sLit "When using functional dependencies to combine"),
nest 2 (sep [ppr pred1'' <> comma, nest 2 from1]),
nest 2 (sep [ppr pred2'' <> comma, nest 2 from2])]
; return (tidy_env, msg) }
= do { traceTc (text "reduceList " <+> (ppr wanteds $$ ppr state))
; dopts <- getDOpts
; when (debugIsOn && (n > 8)) $ do
- dumpTcRn (hang (ptext SLIT("Interesting! Context reduction stack depth") <+> int n)
+ debugDumpTcRn (hang (ptext (sLit "Interesting! Context reduction stack depth") <+> int n)
2 (ifPprDebug (nest 2 (pprStack stk))))
; if n >= ctxtStkDepth dopts then
failWithTc (reduceDepthErr n stk)
= do { -- Solve the sub-problem
; let try_me inst = ReduceMe AddSCs -- Note [Freeness and implications]
env' = env { red_givens = extra_givens ++ red_givens env
- , red_doc = sep [ptext SLIT("reduceImplication for")
+ , red_doc = sep [ptext (sLit "reduceImplication for")
<+> ppr name,
- nest 2 (parens $ ptext SLIT("within")
+ nest 2 (parens $ ptext (sLit "within")
<+> red_doc env)]
, red_try_me = try_me }
<.> WpLet (binds `unionBags` bind)
wrap_inline | null dict_ids = idHsWrapper
| otherwise = WpInline
- rhs = mkHsWrap co payload
+ rhs = mkLHsWrap co payload
loc = instLocSpan inst_loc
- payload | [dict_wanted] <- dict_wanteds = HsVar (instToId dict_wanted)
- | otherwise = ExplicitTuple (map (L loc . HsVar . instToId) dict_wanteds) Boxed
+ payload = mkBigLHsTup (map (L loc . HsVar . instToId) dict_wanteds)
; traceTc (vcat [text "reduceImplication" <+> ppr name,
ppr simpler_implic_insts,
text "->" <+> ppr rhs])
- ; return (unitBag (L loc (VarBind (instToId orig_implic) (L loc rhs))),
+ ; return (unitBag (L loc (VarBind (instToId orig_implic) rhs)),
simpler_implic_insts)
}
}
to float the (C Int) out, even though it mentions no type variable in
the constraints!
+One more example: the constraint
+ class C a => D a b
+ instance (C a, E c) => E (a,c)
+
+ constraint: forall b. D Int b => E (Int,c)
+
+You might think that the (D Int b) can't possibly contribute
+to solving (E (Int,c)), since the latter mentions 'c'. But
+in fact it can, because solving the (E (Int,c)) constraint needs
+dictionaries
+ C Int, E c
+and the (C Int) can be satisfied from the superclass of (D Int b).
+So we must still not float (E (Int,c)) out.
+
+To think about: special cases for unary type classes?
+
Note [Pruning the givens in an implication constraint]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we are about to form the implication constraint
forall tvs. Eq a => Ord b
The (Eq a) cannot contribute to the (Ord b), because it has no access to
the type variable 'b'. So we could filter out the (Eq a) from the givens.
+But BE CAREFUL of the examples above in [Freeness and implications].
Doing so would be a bit tidier, but all the implication constraints get
simplified away by the optimiser, so it's no great win. So I don't take
ppr = pprAvails
pprAvails (Avails imp avails)
- = vcat [ ptext SLIT("Avails") <> (if imp then ptext SLIT("[improved]") else empty)
+ = vcat [ ptext (sLit "Avails") <> (if imp then ptext (sLit "[improved]") else empty)
, nest 2 $ braces $
vcat [ sep [ppr inst, nest 2 (equals <+> ppr avail)]
| (inst,avail) <- fmToList avails ]]
; return (binds1 `unionBags` binds2 `unionBags` binds3) }
where
- doc1 = doc <+> ptext SLIT("(first round)")
- doc2 = doc <+> ptext SLIT("(approximate)")
- doc3 = doc <+> ptext SLIT("(disambiguate)")
+ doc1 = doc <+> ptext (sLit "(first round)")
+ doc2 = doc <+> ptext (sLit "(approximate)")
+ doc3 = doc <+> ptext (sLit "(disambiguate)")
\end{code}
If a dictionary constrains a type variable which is
; return simpl_theta }
where
- doc = ptext SLIT("deriving classes for a data type")
+ doc = ptext (sLit "deriving classes for a data type")
ok dict | isDict dict = validDerivPred (dictPred dict)
| otherwise = False
if null irreds then
return ()
else
- traceTc (ptext SLIT("tcSimplifyDefault failing")) >> failM
+ traceTc (ptext (sLit "tcSimplifyDefault failing")) >> failM
where
- doc = ptext SLIT("default declaration")
+ doc = ptext (sLit "default declaration")
\end{code}
where
(tidy_env, tidy_ips) = tidyInsts ips
mk_msg dflags ips
- = vcat [sep [ptext SLIT("Implicit parameters escape from"),
- nest 2 (ptext SLIT("the monomorphic top-level binding")
- <> plural bndrs <+> ptext SLIT("of")
+ = vcat [sep [ptext (sLit "Implicit parameters escape from"),
+ nest 2 (ptext (sLit "the monomorphic top-level binding")
+ <> plural bndrs <+> ptext (sLit "of")
<+> pprBinders bndrs <> colon)],
nest 2 (vcat (map ppr_ip ips)),
monomorphism_fix dflags]
where
(tidy_env, tidy_dicts) = tidyInsts dicts
report dicts = addErrTcM (tidy_env, mk_msg dicts)
- mk_msg dicts = addInstLoc dicts (ptext SLIT("Unbound implicit parameter") <>
+ mk_msg dicts = addInstLoc dicts (ptext (sLit "Unbound implicit parameter") <>
plural tidy_dicts <+> pprDictsTheta tidy_dicts)
addNoInstanceErrs :: [Inst] -- Wanted (can include implications)
mk_overlap_msg dict (matches, unifiers)
= ASSERT( not (null matches) )
- vcat [ addInstLoc [dict] ((ptext SLIT("Overlapping instances for")
+ vcat [ addInstLoc [dict] ((ptext (sLit "Overlapping instances for")
<+> pprPred (dictPred dict))),
- sep [ptext SLIT("Matching instances") <> colon,
+ sep [ptext (sLit "Matching instances") <> colon,
nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])],
if not (isSingleton matches)
then -- Two or more matches
empty
else -- One match, plus some unifiers
ASSERT( not (null unifiers) )
- parens (vcat [ptext SLIT("The choice depends on the instantiation of") <+>
+ parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))),
- ptext SLIT("To pick the first instance above, use -fallow-incoherent-instances"),
- ptext SLIT("when compiling the other instance declarations")])]
+ ptext (sLit "To pick the first instance above, use -fallow-incoherent-instances"),
+ ptext (sLit "when compiling the other instance declarations")])]
where
ispecs = [ispec | (ispec, _) <- matches]
| Just (loc, givens) <- mb_what, -- Nested (type signatures, instance decls)
not (isEmptyVarSet (tyVarsOfInsts insts))
= vcat [ addInstLoc insts $
- sep [ ptext SLIT("Could not deduce") <+> pprDictsTheta insts
- , nest 2 $ ptext SLIT("from the context") <+> pprDictsTheta givens]
+ sep [ ptext (sLit "Could not deduce") <+> pprDictsTheta insts
+ , nest 2 $ ptext (sLit "from the context") <+> pprDictsTheta givens]
, show_fixes (fix1 loc : fixes2) ]
| otherwise -- Top level
= vcat [ addInstLoc insts $
- ptext SLIT("No instance") <> plural insts
- <+> ptext SLIT("for") <+> pprDictsTheta insts
+ ptext (sLit "No instance") <> plural insts
+ <+> ptext (sLit "for") <+> pprDictsTheta insts
, show_fixes fixes2 ]
where
- fix1 loc = sep [ ptext SLIT("add") <+> pprDictsTheta insts
- <+> ptext SLIT("to the context of"),
+ fix1 loc = sep [ ptext (sLit "add") <+> pprDictsTheta insts
+ <+> ptext (sLit "to the context of"),
nest 2 (ppr (instLocOrigin loc)) ]
-- I'm not sure it helps to add the location
- -- nest 2 (ptext SLIT("at") <+> ppr (instLocSpan loc)) ]
+ -- nest 2 (ptext (sLit "at") <+> ppr (instLocSpan loc)) ]
fixes2 | null instance_dicts = []
- | otherwise = [sep [ptext SLIT("add an instance declaration for"),
+ | otherwise = [sep [ptext (sLit "add an instance declaration for"),
pprDictsTheta instance_dicts]]
instance_dicts = [d | d <- insts, isClassDict d, not (isTyVarDict d)]
-- Insts for which it is worth suggesting an adding an instance declaration
show_fixes :: [SDoc] -> SDoc
show_fixes [] = empty
- show_fixes (f:fs) = sep [ptext SLIT("Possible fix:"),
- nest 2 (vcat (f : map (ptext SLIT("or") <+>) fs))]
+ show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
+ nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
addTopAmbigErrs dicts
-- Divide into groups that share a common set of ambiguous tyvars
; return (tidy_env, mk_msg dflags docs) }
where
mk_msg _ _ | any isRuntimeUnk inst_tvs
- = vcat [ptext SLIT("Cannot resolve unknown runtime types:") <+>
+ = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
(pprWithCommas ppr inst_tvs),
- ptext SLIT("Use :print or :force to determine these types")]
- mk_msg _ [] = ptext SLIT("Probable fix: add a type signature that fixes these type variable(s)")
+ ptext (sLit "Use :print or :force to determine these types")]
+ mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
-- This happens in things like
-- f x = show (read "foo")
-- where monomorphism doesn't play any role
mk_msg dflags docs
- = vcat [ptext SLIT("Possible cause: the monomorphism restriction applied to the following:"),
+ = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
nest 2 (vcat docs),
monomorphism_fix dflags]
monomorphism_fix :: DynFlags -> SDoc
monomorphism_fix dflags
- = ptext SLIT("Probable fix:") <+> vcat
- [ptext SLIT("give these definition(s) an explicit type signature"),
+ = ptext (sLit "Probable fix:") <+> vcat
+ [ptext (sLit "give these definition(s) an explicit type signature"),
if dopt Opt_MonomorphismRestriction dflags
- then ptext SLIT("or use -fno-monomorphism-restriction")
+ then ptext (sLit "or use -fno-monomorphism-restriction")
else empty] -- Only suggest adding "-fno-monomorphism-restriction"
-- if it is not already set!
-- Tidy them first
(_, tidy_dicts) = tidyInsts dicts
- warn_msg = vcat [ptext SLIT("Defaulting the following constraint(s) to type") <+>
+ warn_msg = vcat [ptext (sLit "Defaulting the following constraint(s) to type") <+>
quotes (ppr default_ty),
pprDictsInFull tidy_dicts]
reduceDepthErr n stack
- = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
- ptext SLIT("Use -fcontext-stack=N to increase stack size to N"),
+ = vcat [ptext (sLit "Context reduction stack overflow; size =") <+> int n,
+ ptext (sLit "Use -fcontext-stack=N to increase stack size to N"),
nest 4 (pprStack stack)]
pprStack stack = vcat (map pprInstInFull stack)