-%************************************************************************
-%* *
-\subsection[simple]{@Simple@ versions}
-%* *
-%************************************************************************
-
-Much simpler versions when there are no bindings to make!
-
-@tcSimplifyThetas@ simplifies class-type constraints formed by
-@deriving@ declarations and when specialising instances. We are
-only interested in the simplified bunch of class/type constraints.
-
-It simplifies to constraints of the form (C a b c) where
-a,b,c are type variables. This is required for the context of
-instance declarations.
-
-\begin{code}
-tcSimplifyDeriv :: InstOrigin
- -> [TyVar]
- -> ThetaType -- Wanted
- -> TcM ThetaType -- Needed
--- Given instance (wanted) => C inst_ty
--- Simplify 'wanted' as much as possible
-
-tcSimplifyDeriv orig tyvars theta
- = do { (tvs, _, tenv) <- tcInstTyVars tyvars
- -- The main loop may do unification, and that may crash if
- -- it doesn't see a TcTyVar, so we have to instantiate. Sigh
- -- ToDo: what if two of them do get unified?
- ; wanteds <- newDictBndrsO orig (substTheta tenv theta)
- ; (irreds, _) <- tryHardCheckLoop doc wanteds
-
- ; let (tv_dicts, others) = partition ok irreds
- ; addNoInstanceErrs others
- -- See Note [Exotic derived instance contexts] in TcMType
-
- ; let rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars)
- simpl_theta = substTheta rev_env (map dictPred tv_dicts)
- -- This reverse-mapping is a pain, but the result
- -- should mention the original TyVars not TcTyVars
-
- ; return simpl_theta }
- where
- doc = ptext SLIT("deriving classes for a data type")
-
- ok dict | isDict dict = validDerivPred (dictPred dict)
- | otherwise = False
-\end{code}
-
-
-@tcSimplifyDefault@ just checks class-type constraints, essentially;
-used with \tr{default} declarations. We are only interested in
-whether it worked or not.
-
-\begin{code}
-tcSimplifyDefault :: ThetaType -- Wanted; has no type variables in it
- -> TcM ()
-
-tcSimplifyDefault theta
- = newDictBndrsO DefaultOrigin theta `thenM` \ wanteds ->
- tryHardCheckLoop doc wanteds `thenM` \ (irreds, _) ->
- addNoInstanceErrs irreds `thenM_`
- if null irreds then
- returnM ()
- else
- failM
- where
- doc = ptext SLIT("default declaration")
-\end{code}
-
-
-%************************************************************************
-%* *
-\section{Errors and contexts}
-%* *
-%************************************************************************
-
-ToDo: for these error messages, should we note the location as coming
-from the insts, or just whatever seems to be around in the monad just
-now?
-
-\begin{code}
-groupErrs :: ([Inst] -> TcM ()) -- Deal with one group
- -> [Inst] -- The offending Insts
- -> TcM ()
--- Group together insts with the same origin
--- We want to report them together in error messages
-
-groupErrs report_err []
- = returnM ()
-groupErrs report_err (inst:insts)
- = do_one (inst:friends) `thenM_`
- groupErrs report_err others
-
- where
- -- (It may seem a bit crude to compare the error messages,
- -- but it makes sure that we combine just what the user sees,
- -- and it avoids need equality on InstLocs.)
- (friends, others) = partition is_friend insts
- loc_msg = showSDoc (pprInstLoc (instLoc inst))
- is_friend friend = showSDoc (pprInstLoc (instLoc friend)) == loc_msg
- do_one insts = addInstCtxt (instLoc (head insts)) (report_err insts)
- -- Add location and context information derived from the Insts
-
--- Add the "arising from..." part to a message about bunch of dicts
-addInstLoc :: [Inst] -> Message -> Message
-addInstLoc insts msg = msg $$ nest 2 (pprInstArising (head insts))
-
-addTopIPErrs :: [Name] -> [Inst] -> TcM ()
-addTopIPErrs bndrs []
- = return ()
-addTopIPErrs bndrs ips
- = do { dflags <- getDOpts
- ; addErrTcM (tidy_env, mk_msg dflags tidy_ips) }
- 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")
- <+> pprBinders bndrs <> colon)],
- nest 2 (vcat (map ppr_ip ips)),
- monomorphism_fix dflags]
- ppr_ip ip = pprPred (dictPred ip) <+> pprInstArising ip
-
-topIPErrs :: [Inst] -> TcM ()
-topIPErrs dicts
- = groupErrs report tidy_dicts
- 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") <>
- plural tidy_dicts <+> pprDictsTheta tidy_dicts)
-
-addNoInstanceErrs :: [Inst] -- Wanted (can include implications)
- -> TcM ()
-addNoInstanceErrs insts
- = do { let (tidy_env, tidy_insts) = tidyInsts insts
- ; reportNoInstances tidy_env Nothing tidy_insts }
-
-reportNoInstances
- :: TidyEnv
- -> Maybe (InstLoc, [Inst]) -- Context
- -- Nothing => top level
- -- Just (d,g) => d describes the construct
- -- with givens g
- -> [Inst] -- What is wanted (can include implications)
- -> TcM ()
-
-reportNoInstances tidy_env mb_what insts
- = groupErrs (report_no_instances tidy_env mb_what) insts
-
-report_no_instances tidy_env mb_what insts
- = do { inst_envs <- tcGetInstEnvs
- ; let (implics, insts1) = partition isImplicInst insts
- (insts2, overlaps) = partitionWith (check_overlap inst_envs) insts1
- (eqInsts, insts3) = partition isEqInst insts2
- ; traceTc (text "reportNoInstances" <+> vcat
- [ppr implics, ppr insts1, ppr insts2])
- ; mapM_ complain_implic implics
- ; mapM_ (\doc -> addErrTcM (tidy_env, doc)) overlaps
- ; groupErrs complain_no_inst insts3
- ; mapM_ complain_eq eqInsts
- }
- where
- complain_no_inst insts = addErrTcM (tidy_env, mk_no_inst_err insts)
-
- complain_implic inst -- Recurse!
- = reportNoInstances tidy_env
- (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
- check_overlap inst_envs wanted
- | not (isClassDict wanted) = Left wanted
- | otherwise
- = case lookupInstEnv inst_envs clas tys of
- -- The case of exactly one match and no unifiers means a
- -- successful lookup. That can't happen here, because dicts
- -- only end up here if they didn't match in Inst.lookupInst
-#ifdef DEBUG
- ([m],[]) -> pprPanic "reportNoInstance" (ppr wanted)
-#endif
- ([], _) -> Left wanted -- No match
- res -> Right (mk_overlap_msg wanted res)
- where
- (clas,tys) = getDictClassTys wanted
-
- mk_overlap_msg dict (matches, unifiers)
- = ASSERT( not (null matches) )
- vcat [ addInstLoc [dict] ((ptext SLIT("Overlapping instances for")
- <+> pprPred (dictPred dict))),
- 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") <+>
- 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")])]
- where
- ispecs = [ispec | (ispec, _) <- matches]
-
- mk_no_inst_err insts
- | null insts = empty
-
- | 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]
- , show_fixes (fix1 loc : fixes2) ]
-
- | otherwise -- Top level
- = vcat [ addInstLoc 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"),
- nest 2 (ppr (instLocOrigin loc)) ]
- -- I'm not sure it helps to add the location
- -- nest 2 (ptext SLIT("at") <+> ppr (instLocSpan loc)) ]
-
- fixes2 | null instance_dicts = []
- | 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
- -- Exclude implicit parameters, and tyvar dicts
-
- 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))]
-
-addTopAmbigErrs dicts
--- Divide into groups that share a common set of ambiguous tyvars
- = ifErrsM (return ()) $ -- Only report ambiguity if no other errors happened
- -- See Note [Avoiding spurious errors]
- mapM_ report (equivClasses cmp [(d, tvs_of d) | d <- tidy_dicts])
- where
- (tidy_env, tidy_dicts) = tidyInsts dicts
-
- tvs_of :: Inst -> [TcTyVar]
- tvs_of d = varSetElems (tyVarsOfInst d)
- cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
-
- report :: [(Inst,[TcTyVar])] -> TcM ()
- report pairs@((inst,tvs) : _) -- The pairs share a common set of ambiguous tyvars
- = mkMonomorphismMsg tidy_env tvs `thenM` \ (tidy_env, mono_msg) ->
- setSrcSpan (instSpan inst) $
- -- the location of the first one will do for the err message
- addErrTcM (tidy_env, msg $$ mono_msg)
- where
- dicts = map fst pairs
- msg = sep [text "Ambiguous type variable" <> plural tvs <+>
- pprQuotedList tvs <+> in_msg,
- nest 2 (pprDictsInFull dicts)]
- in_msg = text "in the constraint" <> plural dicts <> colon
- report [] = panic "addTopAmbigErrs"
-
-
-mkMonomorphismMsg :: TidyEnv -> [TcTyVar] -> TcM (TidyEnv, Message)
--- There's an error with these Insts; if they have free type variables
--- it's probably caused by the monomorphism restriction.
--- Try to identify the offending variable
--- ASSUMPTION: the Insts are fully zonked
-mkMonomorphismMsg tidy_env inst_tvs
- = do { dflags <- getDOpts
- ; (tidy_env, docs) <- findGlobals (mkVarSet inst_tvs) tidy_env
- ; return (tidy_env, mk_msg dflags docs) }
- where
- mk_msg _ _ | any isRuntimeUnk inst_tvs
- = 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)")
- -- 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:"),
- nest 2 (vcat docs),
- monomorphism_fix dflags]
-
-isRuntimeUnk :: TcTyVar -> Bool
-isRuntimeUnk x | SkolemTv RuntimeUnkSkol <- tcTyVarDetails x = True
- | otherwise = False
-
-monomorphism_fix :: DynFlags -> SDoc
-monomorphism_fix dflags
- = 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")
- else empty] -- Only suggest adding "-fno-monomorphism-restriction"
- -- if it is not already set!
-
-warnDefault ups default_ty
- = doptM Opt_WarnTypeDefaults `thenM` \ warn_flag ->
- addInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg)
- where
- dicts = [d | (d,_,_) <- ups]
-
- -- Tidy them first
- (_, tidy_dicts) = tidyInsts dicts
- 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"),
- 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}