{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module TcErrors(
reportUnsolved, reportAllUnsolved, warnAllUnsolved,
warnDefaulting,
solverDepthErrorTcS
) where
#include "HsVersions.h"
import GhcPrelude
import TcRnTypes
import TcRnMonad
import TcMType
import TcUnify( occCheckForErrors, OccCheckResult(..) )
import TcEnv( tcInitTidyEnv )
import TcType
import RnUnbound ( unknownNameSuggestions )
import Type
import TyCoRep
import Unify ( tcMatchTys )
import Module
import FamInst
import FamInstEnv ( flattenTys )
import Inst
import InstEnv
import TyCon
import Class
import DataCon
import TcEvidence
import TcEvTerm
import HsExpr ( UnboundVar(..) )
import HsBinds ( PatSynBind(..) )
import Name
import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv
, mkRdrUnqual, isLocalGRE, greSrcSpan )
import PrelNames ( typeableClassName )
import Id
import Var
import VarSet
import VarEnv
import NameSet
import Bag
import ErrUtils ( ErrMsg, errDoc, pprLocErrMsg )
import BasicTypes
import ConLike ( ConLike(..))
import Util
import FastString
import Outputable
import SrcLoc
import DynFlags
import ListSetOps ( equivClasses )
import Maybes
import Pair
import qualified GHC.LanguageExtensions as LangExt
import FV ( fvVarList, unionFV )
import Control.Monad ( when )
import Data.Foldable ( toList )
import Data.List ( partition, mapAccumL, nub, sortBy, unfoldr )
import qualified Data.Set as Set
import {-# SOURCE #-} TcHoleErrors ( findValidHoleFits )
import qualified Data.Semigroup as Semigroup
reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
reportUnsolved wanted :: WantedConstraints
wanted
= do { EvBindsVar
binds_var <- TcM EvBindsVar
newTcEvBinds
; Bool
defer_errors <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_DeferTypeErrors
; Bool
warn_errors <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnDeferredTypeErrors
; let type_errors :: TypeErrorChoice
type_errors | Bool -> Bool
not Bool
defer_errors = TypeErrorChoice
TypeError
| Bool
warn_errors = WarnReason -> TypeErrorChoice
TypeWarn (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnDeferredTypeErrors)
| Bool
otherwise = TypeErrorChoice
TypeDefer
; Bool
defer_holes <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_DeferTypedHoles
; Bool
warn_holes <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnTypedHoles
; let expr_holes :: HoleChoice
expr_holes | Bool -> Bool
not Bool
defer_holes = HoleChoice
HoleError
| Bool
warn_holes = HoleChoice
HoleWarn
| Bool
otherwise = HoleChoice
HoleDefer
; Bool
partial_sigs <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PartialTypeSignatures
; Bool
warn_partial_sigs <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnPartialTypeSignatures
; let type_holes :: HoleChoice
type_holes | Bool -> Bool
not Bool
partial_sigs = HoleChoice
HoleError
| Bool
warn_partial_sigs = HoleChoice
HoleWarn
| Bool
otherwise = HoleChoice
HoleDefer
; Bool
defer_out_of_scope <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_DeferOutOfScopeVariables
; Bool
warn_out_of_scope <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnDeferredOutOfScopeVariables
; let out_of_scope_holes :: HoleChoice
out_of_scope_holes | Bool -> Bool
not Bool
defer_out_of_scope = HoleChoice
HoleError
| Bool
warn_out_of_scope = HoleChoice
HoleWarn
| Bool
otherwise = HoleChoice
HoleDefer
; TypeErrorChoice
-> HoleChoice
-> HoleChoice
-> HoleChoice
-> EvBindsVar
-> WantedConstraints
-> TcM ()
report_unsolved TypeErrorChoice
type_errors HoleChoice
expr_holes
HoleChoice
type_holes HoleChoice
out_of_scope_holes
EvBindsVar
binds_var WantedConstraints
wanted
; EvBindMap
ev_binds <- EvBindsVar -> TcM EvBindMap
getTcEvBindsMap EvBindsVar
binds_var
; Bag EvBind -> TcM (Bag EvBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (EvBindMap -> Bag EvBind
evBindMapBinds EvBindMap
ev_binds)}
reportAllUnsolved :: WantedConstraints -> TcM ()
reportAllUnsolved :: WantedConstraints -> TcM ()
reportAllUnsolved wanted :: WantedConstraints
wanted
= do { EvBindsVar
ev_binds <- TcM EvBindsVar
newNoTcEvBinds
; Bool
partial_sigs <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PartialTypeSignatures
; Bool
warn_partial_sigs <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnPartialTypeSignatures
; let type_holes :: HoleChoice
type_holes | Bool -> Bool
not Bool
partial_sigs = HoleChoice
HoleError
| Bool
warn_partial_sigs = HoleChoice
HoleWarn
| Bool
otherwise = HoleChoice
HoleDefer
; TypeErrorChoice
-> HoleChoice
-> HoleChoice
-> HoleChoice
-> EvBindsVar
-> WantedConstraints
-> TcM ()
report_unsolved TypeErrorChoice
TypeError HoleChoice
HoleError HoleChoice
type_holes HoleChoice
HoleError
EvBindsVar
ev_binds WantedConstraints
wanted }
warnAllUnsolved :: WantedConstraints -> TcM ()
warnAllUnsolved :: WantedConstraints -> TcM ()
warnAllUnsolved wanted :: WantedConstraints
wanted
= do { EvBindsVar
ev_binds <- TcM EvBindsVar
newTcEvBinds
; TypeErrorChoice
-> HoleChoice
-> HoleChoice
-> HoleChoice
-> EvBindsVar
-> WantedConstraints
-> TcM ()
report_unsolved (WarnReason -> TypeErrorChoice
TypeWarn WarnReason
NoReason) HoleChoice
HoleWarn HoleChoice
HoleWarn HoleChoice
HoleWarn
EvBindsVar
ev_binds WantedConstraints
wanted }
report_unsolved :: TypeErrorChoice
-> HoleChoice
-> HoleChoice
-> HoleChoice
-> EvBindsVar
-> WantedConstraints -> TcM ()
report_unsolved :: TypeErrorChoice
-> HoleChoice
-> HoleChoice
-> HoleChoice
-> EvBindsVar
-> WantedConstraints
-> TcM ()
report_unsolved type_errors :: TypeErrorChoice
type_errors expr_holes :: HoleChoice
expr_holes
type_holes :: HoleChoice
type_holes out_of_scope_holes :: HoleChoice
out_of_scope_holes binds_var :: EvBindsVar
binds_var wanted :: WantedConstraints
wanted
| WantedConstraints -> Bool
isEmptyWC WantedConstraints
wanted
= () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= do { String -> SDoc -> TcM ()
traceTc "reportUnsolved {" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text "type errors:" SDoc -> SDoc -> SDoc
<+> TypeErrorChoice -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypeErrorChoice
type_errors
, String -> SDoc
text "expr holes:" SDoc -> SDoc -> SDoc
<+> HoleChoice -> SDoc
forall a. Outputable a => a -> SDoc
ppr HoleChoice
expr_holes
, String -> SDoc
text "type holes:" SDoc -> SDoc -> SDoc
<+> HoleChoice -> SDoc
forall a. Outputable a => a -> SDoc
ppr HoleChoice
type_holes
, String -> SDoc
text "scope holes:" SDoc -> SDoc -> SDoc
<+> HoleChoice -> SDoc
forall a. Outputable a => a -> SDoc
ppr HoleChoice
out_of_scope_holes ]
; String -> SDoc -> TcM ()
traceTc "reportUnsolved (before zonking and tidying)" (WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wanted)
; WantedConstraints
wanted <- WantedConstraints -> TcM WantedConstraints
zonkWC WantedConstraints
wanted
; TidyEnv
env0 <- TcM TidyEnv
tcInitTidyEnv
; let tidy_env :: TidyEnv
tidy_env = TidyEnv -> [TyCoVar] -> TidyEnv
tidyFreeTyCoVars TidyEnv
env0 [TyCoVar]
free_tvs
free_tvs :: [TyCoVar]
free_tvs = WantedConstraints -> [TyCoVar]
tyCoVarsOfWCList WantedConstraints
wanted
; String -> SDoc -> TcM ()
traceTc "reportUnsolved (after zonking):" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text "Free tyvars:" SDoc -> SDoc -> SDoc
<+> [TyCoVar] -> SDoc
pprTyVars [TyCoVar]
free_tvs
, String -> SDoc
text "Tidy env:" SDoc -> SDoc -> SDoc
<+> TidyEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr TidyEnv
tidy_env
, String -> SDoc
text "Wanted:" SDoc -> SDoc -> SDoc
<+> WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wanted ]
; Bool
warn_redundant <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnRedundantConstraints
; let err_ctxt :: ReportErrCtxt
err_ctxt = CEC :: [Implication]
-> TidyEnv
-> EvBindsVar
-> TypeErrorChoice
-> HoleChoice
-> HoleChoice
-> HoleChoice
-> Bool
-> Bool
-> ReportErrCtxt
CEC { cec_encl :: [Implication]
cec_encl = []
, cec_tidy :: TidyEnv
cec_tidy = TidyEnv
tidy_env
, cec_defer_type_errors :: TypeErrorChoice
cec_defer_type_errors = TypeErrorChoice
type_errors
, cec_expr_holes :: HoleChoice
cec_expr_holes = HoleChoice
expr_holes
, cec_type_holes :: HoleChoice
cec_type_holes = HoleChoice
type_holes
, cec_out_of_scope_holes :: HoleChoice
cec_out_of_scope_holes = HoleChoice
out_of_scope_holes
, cec_suppress :: Bool
cec_suppress = WantedConstraints -> Bool
insolubleWC WantedConstraints
wanted
, cec_warn_redundant :: Bool
cec_warn_redundant = Bool
warn_redundant
, cec_binds :: EvBindsVar
cec_binds = EvBindsVar
binds_var }
; TcLevel
tc_lvl <- TcM TcLevel
getTcLevel
; ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()
reportWanteds ReportErrCtxt
err_ctxt TcLevel
tc_lvl WantedConstraints
wanted
; String -> SDoc -> TcM ()
traceTc "reportUnsolved }" SDoc
empty }
data Report
= Report { Report -> [SDoc]
report_important :: [SDoc]
, Report -> [SDoc]
report_relevant_bindings :: [SDoc]
, Report -> [SDoc]
report_valid_hole_fits :: [SDoc]
}
instance Outputable Report where
ppr :: Report -> SDoc
ppr (Report { report_important :: Report -> [SDoc]
report_important = [SDoc]
imp
, report_relevant_bindings :: Report -> [SDoc]
report_relevant_bindings = [SDoc]
rel
, report_valid_hole_fits :: Report -> [SDoc]
report_valid_hole_fits = [SDoc]
val })
= [SDoc] -> SDoc
vcat [ String -> SDoc
text "important:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat [SDoc]
imp
, String -> SDoc
text "relevant:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat [SDoc]
rel
, String -> SDoc
text "valid:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat [SDoc]
val ]
instance Semigroup Report where
Report a1 :: [SDoc]
a1 b1 :: [SDoc]
b1 c1 :: [SDoc]
c1 <> :: Report -> Report -> Report
<> Report a2 :: [SDoc]
a2 b2 :: [SDoc]
b2 c2 :: [SDoc]
c2 = [SDoc] -> [SDoc] -> [SDoc] -> Report
Report ([SDoc]
a1 [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
a2) ([SDoc]
b1 [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
b2) ([SDoc]
c1 [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
c2)
instance Monoid Report where
mempty :: Report
mempty = [SDoc] -> [SDoc] -> [SDoc] -> Report
Report [] [] []
mappend :: Report -> Report -> Report
mappend = Report -> Report -> Report
forall a. Semigroup a => a -> a -> a
(Semigroup.<>)
important :: SDoc -> Report
important :: SDoc -> Report
important doc :: SDoc
doc = Report
forall a. Monoid a => a
mempty { report_important :: [SDoc]
report_important = [SDoc
doc] }
relevant_bindings :: SDoc -> Report
relevant_bindings :: SDoc -> Report
relevant_bindings doc :: SDoc
doc = Report
forall a. Monoid a => a
mempty { report_relevant_bindings :: [SDoc]
report_relevant_bindings = [SDoc
doc] }
valid_hole_fits :: SDoc -> Report
valid_hole_fits :: SDoc -> Report
valid_hole_fits docs :: SDoc
docs = Report
forall a. Monoid a => a
mempty { report_valid_hole_fits :: [SDoc]
report_valid_hole_fits = [SDoc
docs] }
data TypeErrorChoice
= TypeError
| TypeWarn WarnReason
| TypeDefer
data HoleChoice
= HoleError
| HoleWarn
| HoleDefer
instance Outputable HoleChoice where
ppr :: HoleChoice -> SDoc
ppr HoleError = String -> SDoc
text "HoleError"
ppr HoleWarn = String -> SDoc
text "HoleWarn"
ppr HoleDefer = String -> SDoc
text "HoleDefer"
instance Outputable TypeErrorChoice where
ppr :: TypeErrorChoice -> SDoc
ppr TypeError = String -> SDoc
text "TypeError"
ppr (TypeWarn reason :: WarnReason
reason) = String -> SDoc
text "TypeWarn" SDoc -> SDoc -> SDoc
<+> WarnReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr WarnReason
reason
ppr TypeDefer = String -> SDoc
text "TypeDefer"
data ReportErrCtxt
= CEC { ReportErrCtxt -> [Implication]
cec_encl :: [Implication]
, ReportErrCtxt -> TidyEnv
cec_tidy :: TidyEnv
, ReportErrCtxt -> EvBindsVar
cec_binds :: EvBindsVar
, ReportErrCtxt -> TypeErrorChoice
cec_defer_type_errors :: TypeErrorChoice
, ReportErrCtxt -> HoleChoice
cec_expr_holes :: HoleChoice
, ReportErrCtxt -> HoleChoice
cec_type_holes :: HoleChoice
, ReportErrCtxt -> HoleChoice
cec_out_of_scope_holes :: HoleChoice
, ReportErrCtxt -> Bool
cec_warn_redundant :: Bool
, ReportErrCtxt -> Bool
cec_suppress :: Bool
}
instance Outputable ReportErrCtxt where
ppr :: ReportErrCtxt -> SDoc
ppr (CEC { cec_binds :: ReportErrCtxt -> EvBindsVar
cec_binds = EvBindsVar
bvar
, cec_defer_type_errors :: ReportErrCtxt -> TypeErrorChoice
cec_defer_type_errors = TypeErrorChoice
dte
, cec_expr_holes :: ReportErrCtxt -> HoleChoice
cec_expr_holes = HoleChoice
eh
, cec_type_holes :: ReportErrCtxt -> HoleChoice
cec_type_holes = HoleChoice
th
, cec_out_of_scope_holes :: ReportErrCtxt -> HoleChoice
cec_out_of_scope_holes = HoleChoice
osh
, cec_warn_redundant :: ReportErrCtxt -> Bool
cec_warn_redundant = Bool
wr
, cec_suppress :: ReportErrCtxt -> Bool
cec_suppress = Bool
sup })
= String -> SDoc
text "CEC" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat
[ String -> SDoc
text "cec_binds" SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> EvBindsVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvBindsVar
bvar
, String -> SDoc
text "cec_defer_type_errors" SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> TypeErrorChoice -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypeErrorChoice
dte
, String -> SDoc
text "cec_expr_holes" SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> HoleChoice -> SDoc
forall a. Outputable a => a -> SDoc
ppr HoleChoice
eh
, String -> SDoc
text "cec_type_holes" SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> HoleChoice -> SDoc
forall a. Outputable a => a -> SDoc
ppr HoleChoice
th
, String -> SDoc
text "cec_out_of_scope_holes" SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> HoleChoice -> SDoc
forall a. Outputable a => a -> SDoc
ppr HoleChoice
osh
, String -> SDoc
text "cec_warn_redundant" SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
wr
, String -> SDoc
text "cec_suppress" SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
sup ])
deferringAnyBindings :: ReportErrCtxt -> Bool
deferringAnyBindings :: ReportErrCtxt -> Bool
deferringAnyBindings (CEC { cec_defer_type_errors :: ReportErrCtxt -> TypeErrorChoice
cec_defer_type_errors = TypeErrorChoice
TypeError
, cec_expr_holes :: ReportErrCtxt -> HoleChoice
cec_expr_holes = HoleChoice
HoleError
, cec_out_of_scope_holes :: ReportErrCtxt -> HoleChoice
cec_out_of_scope_holes = HoleChoice
HoleError }) = Bool
False
deferringAnyBindings _ = Bool
True
noDeferredBindings :: ReportErrCtxt -> ReportErrCtxt
noDeferredBindings :: ReportErrCtxt -> ReportErrCtxt
noDeferredBindings ctxt :: ReportErrCtxt
ctxt = ReportErrCtxt
ctxt { cec_defer_type_errors :: TypeErrorChoice
cec_defer_type_errors = TypeErrorChoice
TypeError
, cec_expr_holes :: HoleChoice
cec_expr_holes = HoleChoice
HoleError
, cec_out_of_scope_holes :: HoleChoice
cec_out_of_scope_holes = HoleChoice
HoleError }
reportImplic :: ReportErrCtxt -> Implication -> TcM ()
reportImplic :: ReportErrCtxt -> Implication -> TcM ()
reportImplic ctxt :: ReportErrCtxt
ctxt implic :: Implication
implic@(Implic { ic_skols :: Implication -> [TyCoVar]
ic_skols = [TyCoVar]
tvs, ic_telescope :: Implication -> Maybe SDoc
ic_telescope = Maybe SDoc
m_telescope
, ic_given :: Implication -> [TyCoVar]
ic_given = [TyCoVar]
given
, ic_wanted :: Implication -> WantedConstraints
ic_wanted = WantedConstraints
wanted, ic_binds :: Implication -> EvBindsVar
ic_binds = EvBindsVar
evb
, ic_status :: Implication -> ImplicStatus
ic_status = ImplicStatus
status, ic_info :: Implication -> SkolemInfo
ic_info = SkolemInfo
info
, ic_tclvl :: Implication -> TcLevel
ic_tclvl = TcLevel
tc_lvl })
| SkolemInfo
BracketSkol <- SkolemInfo
info
, Bool -> Bool
not Bool
insoluble
= () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= do { String -> SDoc -> TcM ()
traceTc "reportImplic" (Implication -> SDoc
forall a. Outputable a => a -> SDoc
ppr Implication
implic')
; ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()
reportWanteds ReportErrCtxt
ctxt' TcLevel
tc_lvl WantedConstraints
wanted
; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ReportErrCtxt -> Bool
cec_warn_redundant ReportErrCtxt
ctxt) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [TyCoVar] -> TcM ()
warnRedundantConstraints ReportErrCtxt
ctxt' TcLclEnv
tcl_env SkolemInfo
info' [TyCoVar]
dead_givens
; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
bad_telescope (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$ ReportErrCtxt -> TcLclEnv -> Maybe SDoc -> [TyCoVar] -> TcM ()
reportBadTelescope ReportErrCtxt
ctxt TcLclEnv
tcl_env Maybe SDoc
m_telescope [TyCoVar]
tvs }
where
tcl_env :: TcLclEnv
tcl_env = Implication -> TcLclEnv
implicLclEnv Implication
implic
insoluble :: Bool
insoluble = ImplicStatus -> Bool
isInsolubleStatus ImplicStatus
status
(env1 :: TidyEnv
env1, tvs' :: [TyCoVar]
tvs') = (TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar))
-> TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)
tidyVarBndr (ReportErrCtxt -> TidyEnv
cec_tidy ReportErrCtxt
ctxt) [TyCoVar]
tvs
info' :: SkolemInfo
info' = TidyEnv -> SkolemInfo -> SkolemInfo
tidySkolemInfo TidyEnv
env1 SkolemInfo
info
implic' :: Implication
implic' = Implication
implic { ic_skols :: [TyCoVar]
ic_skols = [TyCoVar]
tvs'
, ic_given :: [TyCoVar]
ic_given = (TyCoVar -> TyCoVar) -> [TyCoVar] -> [TyCoVar]
forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> TyCoVar -> TyCoVar
tidyEvVar TidyEnv
env1) [TyCoVar]
given
, ic_info :: SkolemInfo
ic_info = SkolemInfo
info' }
ctxt1 :: ReportErrCtxt
ctxt1 | CoEvBindsVar{} <- EvBindsVar
evb = ReportErrCtxt -> ReportErrCtxt
noDeferredBindings ReportErrCtxt
ctxt
| Bool
otherwise = ReportErrCtxt
ctxt
ctxt' :: ReportErrCtxt
ctxt' = ReportErrCtxt
ctxt1 { cec_tidy :: TidyEnv
cec_tidy = TidyEnv
env1
, cec_encl :: [Implication]
cec_encl = Implication
implic' Implication -> [Implication] -> [Implication]
forall a. a -> [a] -> [a]
: ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt
, cec_suppress :: Bool
cec_suppress = Bool
insoluble Bool -> Bool -> Bool
|| ReportErrCtxt -> Bool
cec_suppress ReportErrCtxt
ctxt
, cec_binds :: EvBindsVar
cec_binds = EvBindsVar
evb }
dead_givens :: [TyCoVar]
dead_givens = case ImplicStatus
status of
IC_Solved { ics_dead :: ImplicStatus -> [TyCoVar]
ics_dead = [TyCoVar]
dead } -> [TyCoVar]
dead
_ -> []
bad_telescope :: Bool
bad_telescope = case ImplicStatus
status of
IC_BadTelescope -> Bool
True
_ -> Bool
False
warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM ()
warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [TyCoVar] -> TcM ()
warnRedundantConstraints ctxt :: ReportErrCtxt
ctxt env :: TcLclEnv
env info :: SkolemInfo
info ev_vars :: [TyCoVar]
ev_vars
| [TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
redundant_evs
= () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| SigSkol {} <- SkolemInfo
info
= TcLclEnv -> TcM () -> TcM ()
forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv TcLclEnv
env (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcM () -> TcM ()
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (String -> SDoc
text "In" SDoc -> SDoc -> SDoc
<+> SkolemInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfo
info) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; ErrMsg
msg <- ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg
mkErrorReport ReportErrCtxt
ctxt TcLclEnv
env (SDoc -> Report
important SDoc
doc)
; WarnReason -> ErrMsg -> TcM ()
reportWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnRedundantConstraints) ErrMsg
msg }
| Bool
otherwise
= do { ErrMsg
msg <- ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg
mkErrorReport ReportErrCtxt
ctxt TcLclEnv
env (SDoc -> Report
important SDoc
doc)
; WarnReason -> ErrMsg -> TcM ()
reportWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnRedundantConstraints) ErrMsg
msg }
where
doc :: SDoc
doc = String -> SDoc
text "Redundant constraint" SDoc -> SDoc -> SDoc
<> [TyCoVar] -> SDoc
forall a. [a] -> SDoc
plural [TyCoVar]
redundant_evs SDoc -> SDoc -> SDoc
<> SDoc
colon
SDoc -> SDoc -> SDoc
<+> [TyCoVar] -> SDoc
pprEvVarTheta [TyCoVar]
redundant_evs
redundant_evs :: [TyCoVar]
redundant_evs =
(TyCoVar -> Bool) -> [TyCoVar] -> [TyCoVar]
forall a. (a -> Bool) -> [a] -> [a]
filterOut TyCoVar -> Bool
is_type_error ([TyCoVar] -> [TyCoVar]) -> [TyCoVar] -> [TyCoVar]
forall a b. (a -> b) -> a -> b
$
case SkolemInfo
info of
InstSkol -> (TyCoVar -> Bool) -> [TyCoVar] -> [TyCoVar]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (Type -> Bool
improving (Type -> Bool) -> (TyCoVar -> Type) -> TyCoVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCoVar -> Type
idType) [TyCoVar]
ev_vars
_ -> [TyCoVar]
ev_vars
is_type_error :: TyCoVar -> Bool
is_type_error = Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Type -> Bool) -> (TyCoVar -> Maybe Type) -> TyCoVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe Type
userTypeError_maybe (Type -> Maybe Type) -> (TyCoVar -> Type) -> TyCoVar -> Maybe Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCoVar -> Type
idType
improving :: Type -> Bool
improving pred :: Type
pred
= (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Type -> Bool
isImprovementPred (Type
pred Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
transSuperClasses Type
pred)
reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> Maybe SDoc -> [TcTyVar] -> TcM ()
reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> Maybe SDoc -> [TyCoVar] -> TcM ()
reportBadTelescope ctxt :: ReportErrCtxt
ctxt env :: TcLclEnv
env (Just telescope :: SDoc
telescope) skols :: [TyCoVar]
skols
= do { ErrMsg
msg <- ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg
mkErrorReport ReportErrCtxt
ctxt TcLclEnv
env (SDoc -> Report
important SDoc
doc)
; ErrMsg -> TcM ()
reportError ErrMsg
msg }
where
doc :: SDoc
doc = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "These kind and type variables:" SDoc -> SDoc -> SDoc
<+> SDoc
telescope SDoc -> SDoc -> SDoc
$$
String -> SDoc
text "are out of dependency order. Perhaps try this ordering:")
2 ([TyCoVar] -> SDoc
pprTyVars [TyCoVar]
sorted_tvs)
sorted_tvs :: [TyCoVar]
sorted_tvs = [TyCoVar] -> [TyCoVar]
scopedSort [TyCoVar]
skols
reportBadTelescope _ _ Nothing skols :: [TyCoVar]
skols
= String -> SDoc -> TcM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic "reportBadTelescope" ([TyCoVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCoVar]
skols)
reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()
reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()
reportWanteds ctxt :: ReportErrCtxt
ctxt tc_lvl :: TcLevel
tc_lvl (WC { wc_simple :: WantedConstraints -> Cts
wc_simple = Cts
simples, wc_impl :: WantedConstraints -> Bag Implication
wc_impl = Bag Implication
implics })
= do { String -> SDoc -> TcM ()
traceTc "reportWanteds" ([SDoc] -> SDoc
vcat [ String -> SDoc
text "Simples =" SDoc -> SDoc -> SDoc
<+> Cts -> SDoc
forall a. Outputable a => a -> SDoc
ppr Cts
simples
, String -> SDoc
text "Suppress =" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ReportErrCtxt -> Bool
cec_suppress ReportErrCtxt
ctxt)])
; String -> SDoc -> TcM ()
traceTc "rw2" ([Ct] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
tidy_cts)
; let ctxt_for_insols :: ReportErrCtxt
ctxt_for_insols = ReportErrCtxt
ctxt { cec_suppress :: Bool
cec_suppress = Bool
False }
; (ctxt1 :: ReportErrCtxt
ctxt1, cts1 :: [Ct]
cts1) <- ReportErrCtxt
-> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
tryReporters ReportErrCtxt
ctxt_for_insols [ReporterSpec]
report1 [Ct]
tidy_cts
; let ctxt2 :: ReportErrCtxt
ctxt2 = ReportErrCtxt
ctxt { cec_suppress :: Bool
cec_suppress = ReportErrCtxt -> Bool
cec_suppress ReportErrCtxt
ctxt Bool -> Bool -> Bool
|| ReportErrCtxt -> Bool
cec_suppress ReportErrCtxt
ctxt1 }
; (_, leftovers :: [Ct]
leftovers) <- ReportErrCtxt
-> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
tryReporters ReportErrCtxt
ctxt2 [ReporterSpec]
report2 [Ct]
cts1
; MASSERT2( null leftovers, ppr leftovers )
; (Implication -> TcM ()) -> Bag Implication -> TcM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Bag a -> m ()
mapBagM_ (ReportErrCtxt -> Implication -> TcM ()
reportImplic ReportErrCtxt
ctxt2) Bag Implication
implics }
where
env :: TidyEnv
env = ReportErrCtxt -> TidyEnv
cec_tidy ReportErrCtxt
ctxt
tidy_cts :: [Ct]
tidy_cts = Cts -> [Ct]
forall a. Bag a -> [a]
bagToList ((Ct -> Ct) -> Cts -> Cts
forall a b. (a -> b) -> Bag a -> Bag b
mapBag (TidyEnv -> Ct -> Ct
tidyCt TidyEnv
env) Cts
simples)
report1 :: [ReporterSpec]
report1 = [ ("Out of scope", Ct -> PredTree -> Bool
forall p. Ct -> p -> Bool
is_out_of_scope, Bool
True, [Ct] -> Reporter
mkHoleReporter [Ct]
tidy_cts)
, ("Holes", Ct -> PredTree -> Bool
is_hole, Bool
False, [Ct] -> Reporter
mkHoleReporter [Ct]
tidy_cts)
, ("custom_error", Ct -> PredTree -> Bool
forall p. Ct -> p -> Bool
is_user_type_error, Bool
True, Reporter
mkUserTypeErrorReporter)
, ReporterSpec
given_eq_spec
, ("insoluble2", Ct -> PredTree -> Bool
forall p. p -> PredTree -> Bool
utterly_wrong, Bool
True, (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
mkGroupReporter ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkEqErr)
, ("skolem eq1", Ct -> PredTree -> Bool
forall p. p -> PredTree -> Bool
very_wrong, Bool
True, Reporter
mkSkolReporter)
, ("skolem eq2", Ct -> PredTree -> Bool
forall p. p -> PredTree -> Bool
skolem_eq, Bool
True, Reporter
mkSkolReporter)
, ("non-tv eq", Ct -> PredTree -> Bool
forall p. p -> PredTree -> Bool
non_tv_eq, Bool
True, Reporter
mkSkolReporter)
, ("Homo eqs", Ct -> PredTree -> Bool
forall p. p -> PredTree -> Bool
is_homo_equality, Bool
True, (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
mkGroupReporter ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkEqErr)
, ("Other eqs", Ct -> PredTree -> Bool
is_equality, Bool
False, (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
mkGroupReporter ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkEqErr) ]
report2 :: [ReporterSpec]
report2 = [ ("Implicit params", Ct -> PredTree -> Bool
is_ip, Bool
False, (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
mkGroupReporter ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIPErr)
, ("Irreds", Ct -> PredTree -> Bool
is_irred, Bool
False, (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
mkGroupReporter ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIrredErr)
, ("Dicts", Ct -> PredTree -> Bool
is_dict, Bool
False, (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
mkGroupReporter ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkDictErr) ]
is_hole, is_dict,
is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool
is_given_eq :: Ct -> PredTree -> Bool
is_given_eq ct :: Ct
ct pred :: PredTree
pred
| EqPred {} <- PredTree
pred = Ct -> Bool
arisesFromGivens Ct
ct
| Bool
otherwise = Bool
False
utterly_wrong :: p -> PredTree -> Bool
utterly_wrong _ (EqPred NomEq ty1 :: Type
ty1 ty2 :: Type
ty2) = Type -> Bool
isRigidTy Type
ty1 Bool -> Bool -> Bool
&& Type -> Bool
isRigidTy Type
ty2
utterly_wrong _ _ = Bool
False
very_wrong :: p -> PredTree -> Bool
very_wrong _ (EqPred NomEq ty1 :: Type
ty1 ty2 :: Type
ty2) = TcLevel -> Type -> Bool
isSkolemTy TcLevel
tc_lvl Type
ty1 Bool -> Bool -> Bool
&& Type -> Bool
isRigidTy Type
ty2
very_wrong _ _ = Bool
False
skolem_eq :: p -> PredTree -> Bool
skolem_eq _ (EqPred NomEq ty1 :: Type
ty1 _) = TcLevel -> Type -> Bool
isSkolemTy TcLevel
tc_lvl Type
ty1
skolem_eq _ _ = Bool
False
non_tv_eq :: p -> PredTree -> Bool
non_tv_eq _ (EqPred NomEq ty1 :: Type
ty1 _) = Bool -> Bool
not (Type -> Bool
isTyVarTy Type
ty1)
non_tv_eq _ _ = Bool
False
is_out_of_scope :: Ct -> p -> Bool
is_out_of_scope ct :: Ct
ct _ = Ct -> Bool
isOutOfScopeCt Ct
ct
is_hole :: Ct -> PredTree -> Bool
is_hole ct :: Ct
ct _ = Ct -> Bool
isHoleCt Ct
ct
is_user_type_error :: Ct -> p -> Bool
is_user_type_error ct :: Ct
ct _ = Ct -> Bool
isUserTypeErrorCt Ct
ct
is_homo_equality :: p -> PredTree -> Bool
is_homo_equality _ (EqPred _ ty1 :: Type
ty1 ty2 :: Type
ty2) = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
ty1 HasDebugCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqType` HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
ty2
is_homo_equality _ _ = Bool
False
is_equality :: Ct -> PredTree -> Bool
is_equality _ (EqPred {}) = Bool
True
is_equality _ _ = Bool
False
is_dict :: Ct -> PredTree -> Bool
is_dict _ (ClassPred {}) = Bool
True
is_dict _ _ = Bool
False
is_ip :: Ct -> PredTree -> Bool
is_ip _ (ClassPred cls :: Class
cls _) = Class -> Bool
isIPClass Class
cls
is_ip _ _ = Bool
False
is_irred :: Ct -> PredTree -> Bool
is_irred _ (IrredPred {}) = Bool
True
is_irred _ _ = Bool
False
given_eq_spec :: ReporterSpec
given_eq_spec
| [Implication] -> Bool
has_gadt_match (ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt)
= ("insoluble1a", Ct -> PredTree -> Bool
is_given_eq, Bool
True, Reporter
mkGivenErrorReporter)
| Bool
otherwise
= ("insoluble1b", Ct -> PredTree -> Bool
is_given_eq, Bool
False, Reporter
ignoreErrorReporter)
has_gadt_match :: [Implication] -> Bool
has_gadt_match [] = Bool
False
has_gadt_match (implic :: Implication
implic : implics :: [Implication]
implics)
| PatSkol {} <- Implication -> SkolemInfo
ic_info Implication
implic
, Bool -> Bool
not (Implication -> Bool
ic_no_eqs Implication
implic)
, WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnInaccessibleCode (Implication -> DynFlags
implicDynFlags Implication
implic)
= Bool
True
| Bool
otherwise
= [Implication] -> Bool
has_gadt_match [Implication]
implics
isSkolemTy :: TcLevel -> Type -> Bool
isSkolemTy :: TcLevel -> Type -> Bool
isSkolemTy tc_lvl :: TcLevel
tc_lvl ty :: Type
ty
| Just tv :: TyCoVar
tv <- Type -> Maybe TyCoVar
getTyVar_maybe Type
ty
= TyCoVar -> Bool
isSkolemTyVar TyCoVar
tv
Bool -> Bool -> Bool
|| (TyCoVar -> Bool
isTyVarTyVar TyCoVar
tv Bool -> Bool -> Bool
&& TcLevel -> TyCoVar -> Bool
isTouchableMetaTyVar TcLevel
tc_lvl TyCoVar
tv)
| Bool
otherwise
= Bool
False
isTyFun_maybe :: Type -> Maybe TyCon
isTyFun_maybe :: Type -> Maybe TyCon
isTyFun_maybe ty :: Type
ty = case HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty of
Just (tc :: TyCon
tc,_) | TyCon -> Bool
isTypeFamilyTyCon TyCon
tc -> TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tc
_ -> Maybe TyCon
forall a. Maybe a
Nothing
type Reporter
= ReportErrCtxt -> [Ct] -> TcM ()
type ReporterSpec
= ( String
, Ct -> PredTree -> Bool
, Bool
, Reporter)
mkSkolReporter :: Reporter
mkSkolReporter :: Reporter
mkSkolReporter ctxt :: ReportErrCtxt
ctxt cts :: [Ct]
cts
= ([Ct] -> TcM ()) -> [[Ct]] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
reportGroup ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkEqErr ReportErrCtxt
ctxt) ([Ct] -> [[Ct]]
group [Ct]
cts)
where
group :: [Ct] -> [[Ct]]
group [] = []
group (ct :: Ct
ct:cts :: [Ct]
cts) = (Ct
ct Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: [Ct]
yeses) [Ct] -> [[Ct]] -> [[Ct]]
forall a. a -> [a] -> [a]
: [Ct] -> [[Ct]]
group [Ct]
noes
where
(yeses :: [Ct]
yeses, noes :: [Ct]
noes) = (Ct -> Bool) -> [Ct] -> ([Ct], [Ct])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Ct -> Ct -> Bool
group_with Ct
ct) [Ct]
cts
group_with :: Ct -> Ct -> Bool
group_with ct1 :: Ct
ct1 ct2 :: Ct
ct2
| Ordering
EQ <- Ct -> Ct -> Ordering
cmp_loc Ct
ct1 Ct
ct2 = Bool
True
| Ct -> Ct -> Bool
eq_lhs_type Ct
ct1 Ct
ct2 = Bool
True
| Bool
otherwise = Bool
False
mkHoleReporter :: [Ct] -> Reporter
mkHoleReporter :: [Ct] -> Reporter
mkHoleReporter tidy_simples :: [Ct]
tidy_simples ctxt :: ReportErrCtxt
ctxt
= (Ct -> TcM ()) -> [Ct] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Ct -> TcM ()) -> [Ct] -> TcM ())
-> (Ct -> TcM ()) -> [Ct] -> TcM ()
forall a b. (a -> b) -> a -> b
$ \ct :: Ct
ct -> do { ErrMsg
err <- [Ct] -> ReportErrCtxt -> Ct -> TcM ErrMsg
mkHoleError [Ct]
tidy_simples ReportErrCtxt
ctxt Ct
ct
; ReportErrCtxt -> Ct -> ErrMsg -> TcM ()
maybeReportHoleError ReportErrCtxt
ctxt Ct
ct ErrMsg
err
; ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
maybeAddDeferredHoleBinding ReportErrCtxt
ctxt ErrMsg
err Ct
ct }
mkUserTypeErrorReporter :: Reporter
mkUserTypeErrorReporter :: Reporter
mkUserTypeErrorReporter ctxt :: ReportErrCtxt
ctxt
= (Ct -> TcM ()) -> [Ct] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Ct -> TcM ()) -> [Ct] -> TcM ())
-> (Ct -> TcM ()) -> [Ct] -> TcM ()
forall a b. (a -> b) -> a -> b
$ \ct :: Ct
ct -> do { ErrMsg
err <- ReportErrCtxt -> Ct -> TcM ErrMsg
mkUserTypeError ReportErrCtxt
ctxt Ct
ct
; ReportErrCtxt -> ErrMsg -> TcM ()
maybeReportError ReportErrCtxt
ctxt ErrMsg
err
; ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
addDeferredBinding ReportErrCtxt
ctxt ErrMsg
err Ct
ct }
mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg
mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg
mkUserTypeError ctxt :: ReportErrCtxt
ctxt ct :: Ct
ct = ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct
(Report -> TcM ErrMsg) -> Report -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$ SDoc -> Report
important
(SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ Type -> SDoc
pprUserTypeErrorTy
(Type -> SDoc) -> Type -> SDoc
forall a b. (a -> b) -> a -> b
$ case Ct -> Maybe Type
getUserTypeErrorMsg Ct
ct of
Just msg :: Type
msg -> Type
msg
Nothing -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic "mkUserTypeError" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct)
mkGivenErrorReporter :: Reporter
mkGivenErrorReporter :: Reporter
mkGivenErrorReporter ctxt :: ReportErrCtxt
ctxt cts :: [Ct]
cts
= do { (ctxt :: ReportErrCtxt
ctxt, binds_msg :: SDoc
binds_msg, ct :: Ct
ct) <- Bool -> ReportErrCtxt -> Ct -> TcM (ReportErrCtxt, SDoc, Ct)
relevantBindings Bool
True ReportErrCtxt
ctxt Ct
ct
; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let (implic :: Implication
implic:_) = ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt
ct' :: Ct
ct' = Ct -> CtLoc -> Ct
setCtLoc Ct
ct (CtLoc -> TcLclEnv -> CtLoc
setCtLocEnv (Ct -> CtLoc
ctLoc Ct
ct) (Implication -> TcLclEnv
implicLclEnv Implication
implic))
inaccessible_msg :: SDoc
inaccessible_msg = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Inaccessible code in")
2 (SkolemInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Implication -> SkolemInfo
ic_info Implication
implic))
report :: Report
report = SDoc -> Report
important SDoc
inaccessible_msg Report -> Report -> Report
forall a. Monoid a => a -> a -> a
`mappend`
SDoc -> Report
relevant_bindings SDoc
binds_msg
; ErrMsg
err <- DynFlags
-> ReportErrCtxt
-> Report
-> Ct
-> Maybe SwapFlag
-> Type
-> Type
-> TcM ErrMsg
mkEqErr_help DynFlags
dflags ReportErrCtxt
ctxt Report
report Ct
ct'
Maybe SwapFlag
forall a. Maybe a
Nothing Type
ty1 Type
ty2
; String -> SDoc -> TcM ()
traceTc "mkGivenErrorReporter" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct)
; WarnReason -> ErrMsg -> TcM ()
reportWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnInaccessibleCode) ErrMsg
err }
where
(ct :: Ct
ct : _ ) = [Ct]
cts
(ty1 :: Type
ty1, ty2 :: Type
ty2) = Type -> (Type, Type)
getEqPredTys (Ct -> Type
ctPred Ct
ct)
ignoreErrorReporter :: Reporter
ignoreErrorReporter :: Reporter
ignoreErrorReporter ctxt :: ReportErrCtxt
ctxt cts :: [Ct]
cts
= do { String -> SDoc -> TcM ()
traceTc "mkGivenErrorReporter no" ([Ct] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
cts SDoc -> SDoc -> SDoc
$$ [Implication] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt))
; () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
-> Reporter
mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
mkGroupReporter mk_err :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mk_err ctxt :: ReportErrCtxt
ctxt cts :: [Ct]
cts
= (NonEmpty Ct -> TcM ()) -> [NonEmpty Ct] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
reportGroup ReportErrCtxt -> [Ct] -> TcM ErrMsg
mk_err ReportErrCtxt
ctxt ([Ct] -> TcM ()) -> (NonEmpty Ct -> [Ct]) -> NonEmpty Ct -> TcM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Ct -> [Ct]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) ((Ct -> Ct -> Ordering) -> [Ct] -> [NonEmpty Ct]
forall a. (a -> a -> Ordering) -> [a] -> [NonEmpty a]
equivClasses Ct -> Ct -> Ordering
cmp_loc [Ct]
cts)
eq_lhs_type :: Ct -> Ct -> Bool
eq_lhs_type :: Ct -> Ct -> Bool
eq_lhs_type ct1 :: Ct
ct1 ct2 :: Ct
ct2
= case (Type -> PredTree
classifyPredType (Ct -> Type
ctPred Ct
ct1), Type -> PredTree
classifyPredType (Ct -> Type
ctPred Ct
ct2)) of
(EqPred eq_rel1 :: EqRel
eq_rel1 ty1 :: Type
ty1 _, EqPred eq_rel2 :: EqRel
eq_rel2 ty2 :: Type
ty2 _) ->
(EqRel
eq_rel1 EqRel -> EqRel -> Bool
forall a. Eq a => a -> a -> Bool
== EqRel
eq_rel2) Bool -> Bool -> Bool
&& (Type
ty1 Type -> Type -> Bool
`eqType` Type
ty2)
_ -> String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic "mkSkolReporter" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct1 SDoc -> SDoc -> SDoc
$$ Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct2)
cmp_loc :: Ct -> Ct -> Ordering
cmp_loc :: Ct -> Ct -> Ordering
cmp_loc ct1 :: Ct
ct1 ct2 :: Ct
ct2 = CtLoc -> RealSrcSpan
ctLocSpan (Ct -> CtLoc
ctLoc Ct
ct1) RealSrcSpan -> RealSrcSpan -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` CtLoc -> RealSrcSpan
ctLocSpan (Ct -> CtLoc
ctLoc Ct
ct2)
reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
-> [Ct] -> TcM ()
reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
reportGroup mk_err :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mk_err ctxt :: ReportErrCtxt
ctxt cts :: [Ct]
cts =
case (Ct -> Bool) -> [Ct] -> ([Ct], [Ct])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Ct -> Bool
isMonadFailInstanceMissing [Ct]
cts of
(monadFailCts :: [Ct]
monadFailCts, []) ->
do { ErrMsg
err <- ReportErrCtxt -> [Ct] -> TcM ErrMsg
mk_err ReportErrCtxt
ctxt [Ct]
monadFailCts
; WarnReason -> ErrMsg -> TcM ()
reportWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingMonadFailInstances) ErrMsg
err }
(_, cts' :: [Ct]
cts') -> do { ErrMsg
err <- ReportErrCtxt -> [Ct] -> TcM ErrMsg
mk_err ReportErrCtxt
ctxt [Ct]
cts'
; String -> SDoc -> TcM ()
traceTc "About to maybeReportErr" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text "Constraint:" SDoc -> SDoc -> SDoc
<+> [Ct] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
cts'
, String -> SDoc
text "cec_suppress =" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ReportErrCtxt -> Bool
cec_suppress ReportErrCtxt
ctxt)
, String -> SDoc
text "cec_defer_type_errors =" SDoc -> SDoc -> SDoc
<+> TypeErrorChoice -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ReportErrCtxt -> TypeErrorChoice
cec_defer_type_errors ReportErrCtxt
ctxt) ]
; ReportErrCtxt -> ErrMsg -> TcM ()
maybeReportError ReportErrCtxt
ctxt ErrMsg
err
; String -> SDoc -> TcM ()
traceTc "reportGroup" ([Ct] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
cts')
; (Ct -> TcM ()) -> [Ct] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
addDeferredBinding ReportErrCtxt
ctxt ErrMsg
err) [Ct]
cts' }
where
isMonadFailInstanceMissing :: Ct -> Bool
isMonadFailInstanceMissing ct :: Ct
ct =
case CtLoc -> CtOrigin
ctLocOrigin (Ct -> CtLoc
ctLoc Ct
ct) of
FailablePattern _pat :: LPat GhcTcId
_pat -> Bool
True
_otherwise :: CtOrigin
_otherwise -> Bool
False
maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM ()
maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM ()
maybeReportHoleError ctxt :: ReportErrCtxt
ctxt ct :: Ct
ct err :: ErrMsg
err
| Ct -> Bool
isTypeHoleCt Ct
ct
=
case ReportErrCtxt -> HoleChoice
cec_type_holes ReportErrCtxt
ctxt of
HoleError -> ErrMsg -> TcM ()
reportError ErrMsg
err
HoleWarn -> WarnReason -> ErrMsg -> TcM ()
reportWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnPartialTypeSignatures) ErrMsg
err
HoleDefer -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Ct -> Bool
isOutOfScopeCt Ct
ct
=
case ReportErrCtxt -> HoleChoice
cec_out_of_scope_holes ReportErrCtxt
ctxt of
HoleError -> ErrMsg -> TcM ()
reportError ErrMsg
err
HoleWarn ->
WarnReason -> ErrMsg -> TcM ()
reportWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnDeferredOutOfScopeVariables) ErrMsg
err
HoleDefer -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
=
case ReportErrCtxt -> HoleChoice
cec_expr_holes ReportErrCtxt
ctxt of
HoleError -> ErrMsg -> TcM ()
reportError ErrMsg
err
HoleWarn -> WarnReason -> ErrMsg -> TcM ()
reportWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnTypedHoles) ErrMsg
err
HoleDefer -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()
maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()
maybeReportError ctxt :: ReportErrCtxt
ctxt err :: ErrMsg
err
| ReportErrCtxt -> Bool
cec_suppress ReportErrCtxt
ctxt
= () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= case ReportErrCtxt -> TypeErrorChoice
cec_defer_type_errors ReportErrCtxt
ctxt of
TypeDefer -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
TypeWarn reason :: WarnReason
reason -> WarnReason -> ErrMsg -> TcM ()
reportWarning WarnReason
reason ErrMsg
err
TypeError -> ErrMsg -> TcM ()
reportError ErrMsg
err
addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
addDeferredBinding ctxt :: ReportErrCtxt
ctxt err :: ErrMsg
err ct :: Ct
ct
| ReportErrCtxt -> Bool
deferringAnyBindings ReportErrCtxt
ctxt
, CtWanted { ctev_pred :: CtEvidence -> Type
ctev_pred = Type
pred, ctev_dest :: CtEvidence -> TcEvDest
ctev_dest = TcEvDest
dest } <- Ct -> CtEvidence
ctEvidence Ct
ct
= do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let err_msg :: SDoc
err_msg = ErrMsg -> SDoc
pprLocErrMsg ErrMsg
err
err_fs :: FastString
err_fs = String -> FastString
mkFastString (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$
SDoc
err_msg SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "(deferred type error)"
err_tm :: EvTerm
err_tm = Type -> FastString -> EvTerm
evDelayedError Type
pred FastString
err_fs
ev_binds_var :: EvBindsVar
ev_binds_var = ReportErrCtxt -> EvBindsVar
cec_binds ReportErrCtxt
ctxt
; case TcEvDest
dest of
EvVarDest evar :: TyCoVar
evar
-> EvBindsVar -> EvBind -> TcM ()
addTcEvBind EvBindsVar
ev_binds_var (EvBind -> TcM ()) -> EvBind -> TcM ()
forall a b. (a -> b) -> a -> b
$ TyCoVar -> EvTerm -> EvBind
mkWantedEvBind TyCoVar
evar EvTerm
err_tm
HoleDest hole :: CoercionHole
hole
-> do {
let co_var :: TyCoVar
co_var = CoercionHole -> TyCoVar
coHoleCoVar CoercionHole
hole
; EvBindsVar -> EvBind -> TcM ()
addTcEvBind EvBindsVar
ev_binds_var (EvBind -> TcM ()) -> EvBind -> TcM ()
forall a b. (a -> b) -> a -> b
$ TyCoVar -> EvTerm -> EvBind
mkWantedEvBind TyCoVar
co_var EvTerm
err_tm
; CoercionHole -> Coercion -> TcM ()
fillCoercionHole CoercionHole
hole (TyCoVar -> Coercion
mkTcCoVarCo TyCoVar
co_var) }}
| Bool
otherwise
= () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
maybeAddDeferredHoleBinding ctxt :: ReportErrCtxt
ctxt err :: ErrMsg
err ct :: Ct
ct
| Ct -> Bool
isExprHoleCt Ct
ct
= ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
addDeferredBinding ReportErrCtxt
ctxt ErrMsg
err Ct
ct
| Bool
otherwise
= () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
tryReporters :: ReportErrCtxt
-> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
tryReporters ctxt :: ReportErrCtxt
ctxt reporters :: [ReporterSpec]
reporters cts :: [Ct]
cts
= do { let (vis_cts :: [Ct]
vis_cts, invis_cts :: [Ct]
invis_cts) = (Ct -> Bool) -> [Ct] -> ([Ct], [Ct])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (CtOrigin -> Bool
isVisibleOrigin (CtOrigin -> Bool) -> (Ct -> CtOrigin) -> Ct -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ct -> CtOrigin
ctOrigin) [Ct]
cts
; String -> SDoc -> TcM ()
traceTc "tryReporters {" ([Ct] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
vis_cts SDoc -> SDoc -> SDoc
$$ [Ct] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
invis_cts)
; (ctxt' :: ReportErrCtxt
ctxt', cts' :: [Ct]
cts') <- ReportErrCtxt
-> [ReporterSpec] -> [Ct] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
go ReportErrCtxt
ctxt [ReporterSpec]
reporters [Ct]
vis_cts [Ct]
invis_cts
; String -> SDoc -> TcM ()
traceTc "tryReporters }" ([Ct] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
cts')
; (ReportErrCtxt, [Ct]) -> TcM (ReportErrCtxt, [Ct])
forall (m :: * -> *) a. Monad m => a -> m a
return (ReportErrCtxt
ctxt', [Ct]
cts') }
where
go :: ReportErrCtxt
-> [ReporterSpec] -> [Ct] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
go ctxt :: ReportErrCtxt
ctxt [] vis_cts :: [Ct]
vis_cts invis_cts :: [Ct]
invis_cts
= (ReportErrCtxt, [Ct]) -> TcM (ReportErrCtxt, [Ct])
forall (m :: * -> *) a. Monad m => a -> m a
return (ReportErrCtxt
ctxt, [Ct]
vis_cts [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [Ct]
invis_cts)
go ctxt :: ReportErrCtxt
ctxt (r :: ReporterSpec
r : rs :: [ReporterSpec]
rs) vis_cts :: [Ct]
vis_cts invis_cts :: [Ct]
invis_cts
= do { (ctxt' :: ReportErrCtxt
ctxt', vis_cts' :: [Ct]
vis_cts') <- ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])
tryReporter ReportErrCtxt
ctxt ReporterSpec
r [Ct]
vis_cts
; (ctxt'' :: ReportErrCtxt
ctxt'', invis_cts' :: [Ct]
invis_cts') <- ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])
tryReporter ReportErrCtxt
ctxt' ReporterSpec
r [Ct]
invis_cts
; ReportErrCtxt
-> [ReporterSpec] -> [Ct] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
go ReportErrCtxt
ctxt'' [ReporterSpec]
rs [Ct]
vis_cts' [Ct]
invis_cts' }
tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])
tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])
tryReporter ctxt :: ReportErrCtxt
ctxt (str :: String
str, keep_me :: Ct -> PredTree -> Bool
keep_me, suppress_after :: Bool
suppress_after, reporter :: Reporter
reporter) cts :: [Ct]
cts
| [Ct] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ct]
yeses
= (ReportErrCtxt, [Ct]) -> TcM (ReportErrCtxt, [Ct])
forall (m :: * -> *) a. Monad m => a -> m a
return (ReportErrCtxt
ctxt, [Ct]
cts)
| Bool
otherwise
= do { String -> SDoc -> TcM ()
traceTc "tryReporter{ " (String -> SDoc
text String
str SDoc -> SDoc -> SDoc
<+> [Ct] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
yeses)
; (_, no_errs :: Bool
no_errs) <- TcM () -> TcRn ((), Bool)
forall a. TcRn a -> TcRn (a, Bool)
askNoErrs (Reporter
reporter ReportErrCtxt
ctxt [Ct]
yeses)
; let suppress_now :: Bool
suppress_now = Bool -> Bool
not Bool
no_errs Bool -> Bool -> Bool
&& Bool
suppress_after
ctxt' :: ReportErrCtxt
ctxt' = ReportErrCtxt
ctxt { cec_suppress :: Bool
cec_suppress = Bool
suppress_now Bool -> Bool -> Bool
|| ReportErrCtxt -> Bool
cec_suppress ReportErrCtxt
ctxt }
; String -> SDoc -> TcM ()
traceTc "tryReporter end }" (String -> SDoc
text String
str SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ReportErrCtxt -> Bool
cec_suppress ReportErrCtxt
ctxt) SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
suppress_after)
; (ReportErrCtxt, [Ct]) -> TcM (ReportErrCtxt, [Ct])
forall (m :: * -> *) a. Monad m => a -> m a
return (ReportErrCtxt
ctxt', [Ct]
nos) }
where
(yeses :: [Ct]
yeses, nos :: [Ct]
nos) = (Ct -> Bool) -> [Ct] -> ([Ct], [Ct])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\ct :: Ct
ct -> Ct -> PredTree -> Bool
keep_me Ct
ct (Type -> PredTree
classifyPredType (Ct -> Type
ctPred Ct
ct))) [Ct]
cts
pprArising :: CtOrigin -> SDoc
pprArising :: CtOrigin -> SDoc
pprArising (TypeEqOrigin {}) = SDoc
empty
pprArising (KindEqOrigin {}) = SDoc
empty
pprArising (GivenOrigin {}) = SDoc
empty
pprArising orig :: CtOrigin
orig = CtOrigin -> SDoc
pprCtOrigin CtOrigin
orig
addArising :: CtOrigin -> SDoc -> SDoc
addArising :: CtOrigin -> SDoc -> SDoc
addArising orig :: CtOrigin
orig msg :: SDoc
msg = SDoc -> Int -> SDoc -> SDoc
hang SDoc
msg 2 (CtOrigin -> SDoc
pprArising CtOrigin
orig)
pprWithArising :: [Ct] -> (CtLoc, SDoc)
pprWithArising :: [Ct] -> (CtLoc, SDoc)
pprWithArising []
= String -> (CtLoc, SDoc)
forall a. String -> a
panic "pprWithArising"
pprWithArising (ct :: Ct
ct:cts :: [Ct]
cts)
| [Ct] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ct]
cts
= (CtLoc
loc, CtOrigin -> SDoc -> SDoc
addArising (CtLoc -> CtOrigin
ctLocOrigin CtLoc
loc)
([Type] -> SDoc
pprTheta [Ct -> Type
ctPred Ct
ct]))
| Bool
otherwise
= (CtLoc
loc, [SDoc] -> SDoc
vcat ((Ct -> SDoc) -> [Ct] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Ct -> SDoc
ppr_one (Ct
ctCt -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
:[Ct]
cts)))
where
loc :: CtLoc
loc = Ct -> CtLoc
ctLoc Ct
ct
ppr_one :: Ct -> SDoc
ppr_one ct' :: Ct
ct' = SDoc -> Int -> SDoc -> SDoc
hang (SDoc -> SDoc
parens (Type -> SDoc
pprType (Ct -> Type
ctPred Ct
ct')))
2 (CtLoc -> SDoc
pprCtLoc (Ct -> CtLoc
ctLoc Ct
ct'))
mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ctxt :: ReportErrCtxt
ctxt ct :: Ct
ct report :: Report
report
= ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg
mkErrorReport ReportErrCtxt
ctxt (CtLoc -> TcLclEnv
ctLocEnv (Ct -> CtLoc
ctLoc Ct
ct)) Report
report
mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg
mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg
mkErrorReport ctxt :: ReportErrCtxt
ctxt tcl_env :: TcLclEnv
tcl_env (Report important :: [SDoc]
important relevant_bindings :: [SDoc]
relevant_bindings valid_subs :: [SDoc]
valid_subs)
= do { SDoc
context <- TidyEnv -> [ErrCtxt] -> TcM SDoc
mkErrInfo (ReportErrCtxt -> TidyEnv
cec_tidy ReportErrCtxt
ctxt) (TcLclEnv -> [ErrCtxt]
tcl_ctxt TcLclEnv
tcl_env)
; SrcSpan -> ErrDoc -> TcM ErrMsg
mkErrDocAt (RealSrcSpan -> SrcSpan
RealSrcSpan (TcLclEnv -> RealSrcSpan
tcl_loc TcLclEnv
tcl_env))
([SDoc] -> [SDoc] -> [SDoc] -> ErrDoc
errDoc [SDoc]
important [SDoc
context] ([SDoc]
relevant_bindings [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
valid_subs))
}
type UserGiven = Implication
getUserGivens :: ReportErrCtxt -> [UserGiven]
getUserGivens :: ReportErrCtxt -> [Implication]
getUserGivens (CEC {cec_encl :: ReportErrCtxt -> [Implication]
cec_encl = [Implication]
implics}) = [Implication] -> [Implication]
getUserGivensFromImplics [Implication]
implics
getUserGivensFromImplics :: [Implication] -> [UserGiven]
getUserGivensFromImplics :: [Implication] -> [Implication]
getUserGivensFromImplics implics :: [Implication]
implics
= [Implication] -> [Implication]
forall a. [a] -> [a]
reverse ((Implication -> Bool) -> [Implication] -> [Implication]
forall a. (a -> Bool) -> [a] -> [a]
filterOut ([TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TyCoVar] -> Bool)
-> (Implication -> [TyCoVar]) -> Implication -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Implication -> [TyCoVar]
ic_given) [Implication]
implics)
mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIrredErr ctxt :: ReportErrCtxt
ctxt cts :: [Ct]
cts
= do { (ctxt :: ReportErrCtxt
ctxt, binds_msg :: SDoc
binds_msg, ct1 :: Ct
ct1) <- Bool -> ReportErrCtxt -> Ct -> TcM (ReportErrCtxt, SDoc, Ct)
relevantBindings Bool
True ReportErrCtxt
ctxt Ct
ct1
; let orig :: CtOrigin
orig = Ct -> CtOrigin
ctOrigin Ct
ct1
msg :: SDoc
msg = [Implication] -> ([Type], CtOrigin) -> SDoc
couldNotDeduce (ReportErrCtxt -> [Implication]
getUserGivens ReportErrCtxt
ctxt) ((Ct -> Type) -> [Ct] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Ct -> Type
ctPred [Ct]
cts, CtOrigin
orig)
; ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct1 (Report -> TcM ErrMsg) -> Report -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$
SDoc -> Report
important SDoc
msg Report -> Report -> Report
forall a. Monoid a => a -> a -> a
`mappend` SDoc -> Report
relevant_bindings SDoc
binds_msg }
where
(ct1 :: Ct
ct1:_) = [Ct]
cts
mkHoleError :: [Ct] -> ReportErrCtxt -> Ct -> TcM ErrMsg
mkHoleError :: [Ct] -> ReportErrCtxt -> Ct -> TcM ErrMsg
mkHoleError _ _ ct :: Ct
ct@(CHoleCan { cc_hole :: Ct -> Hole
cc_hole = ExprHole (OutOfScope occ :: OccName
occ rdr_env0 :: GlobalRdrEnv
rdr_env0) })
= do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; ImportAvails
imp_info <- TcRn ImportAvails
getImports
; Module
curr_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; HomePackageTable
hpt <- TcRnIf TcGblEnv TcLclEnv HomePackageTable
forall gbl lcl. TcRnIf gbl lcl HomePackageTable
getHpt
; let suggs_msg :: SDoc
suggs_msg = DynFlags
-> HomePackageTable
-> Module
-> GlobalRdrEnv
-> LocalRdrEnv
-> ImportAvails
-> RdrName
-> SDoc
unknownNameSuggestions DynFlags
dflags HomePackageTable
hpt Module
curr_mod GlobalRdrEnv
rdr_env0
(TcLclEnv -> LocalRdrEnv
tcl_rdr TcLclEnv
lcl_env) ImportAvails
imp_info RdrName
rdr
; GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
; Set RealSrcSpan
splice_locs <- TcM (Set RealSrcSpan)
getTopLevelSpliceLocs
; let match_msgs :: [SDoc]
match_msgs = GlobalRdrEnv -> Set RealSrcSpan -> [SDoc]
mk_match_msgs GlobalRdrEnv
rdr_env Set RealSrcSpan
splice_locs
; SrcSpan -> ErrDoc -> TcM ErrMsg
mkErrDocAt (RealSrcSpan -> SrcSpan
RealSrcSpan RealSrcSpan
err_loc) (ErrDoc -> TcM ErrMsg) -> ErrDoc -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$
[SDoc] -> [SDoc] -> [SDoc] -> ErrDoc
errDoc [SDoc
out_of_scope_msg] [] ([SDoc]
match_msgs [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc
suggs_msg]) }
where
rdr :: RdrName
rdr = OccName -> RdrName
mkRdrUnqual OccName
occ
ct_loc :: CtLoc
ct_loc = Ct -> CtLoc
ctLoc Ct
ct
lcl_env :: TcLclEnv
lcl_env = CtLoc -> TcLclEnv
ctLocEnv CtLoc
ct_loc
err_loc :: RealSrcSpan
err_loc = TcLclEnv -> RealSrcSpan
tcl_loc TcLclEnv
lcl_env
hole_ty :: Type
hole_ty = CtEvidence -> Type
ctEvPred (Ct -> CtEvidence
ctEvidence Ct
ct)
boring_type :: Bool
boring_type = Type -> Bool
isTyVarTy Type
hole_ty
out_of_scope_msg :: SDoc
out_of_scope_msg
| Bool
boring_type = SDoc -> Int -> SDoc -> SDoc
hang SDoc
herald 2 (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ)
| Bool
otherwise = SDoc -> Int -> SDoc -> SDoc
hang SDoc
herald 2 (OccName -> Type -> SDoc
pp_with_type OccName
occ Type
hole_ty)
herald :: SDoc
herald | OccName -> Bool
isDataOcc OccName
occ = String -> SDoc
text "Data constructor not in scope:"
| Bool
otherwise = String -> SDoc
text "Variable not in scope:"
mk_match_msgs :: GlobalRdrEnv -> Set RealSrcSpan -> [SDoc]
mk_match_msgs rdr_env :: GlobalRdrEnv
rdr_env splice_locs :: Set RealSrcSpan
splice_locs
= let gres :: [GlobalRdrElt]
gres = (GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> [GlobalRdrElt]
forall a. (a -> Bool) -> [a] -> [a]
filter GlobalRdrElt -> Bool
isLocalGRE (GlobalRdrEnv -> OccName -> [GlobalRdrElt]
lookupGlobalRdrEnv GlobalRdrEnv
rdr_env OccName
occ)
in case [GlobalRdrElt]
gres of
[gre :: GlobalRdrElt
gre]
| RealSrcSpan bind_loc :: RealSrcSpan
bind_loc <- GlobalRdrElt -> SrcSpan
greSrcSpan GlobalRdrElt
gre
, Just th_loc :: RealSrcSpan
th_loc <- RealSrcSpan -> Set RealSrcSpan -> Maybe RealSrcSpan
forall a. Ord a => a -> Set a -> Maybe a
Set.lookupLE RealSrcSpan
bind_loc Set RealSrcSpan
splice_locs
, RealSrcSpan
err_loc RealSrcSpan -> RealSrcSpan -> Bool
forall a. Ord a => a -> a -> Bool
< RealSrcSpan
th_loc
-> [RealSrcSpan -> RealSrcSpan -> SDoc
mk_bind_scope_msg RealSrcSpan
bind_loc RealSrcSpan
th_loc]
_ -> []
mk_bind_scope_msg :: RealSrcSpan -> RealSrcSpan -> SDoc
mk_bind_scope_msg bind_loc :: RealSrcSpan
bind_loc th_loc :: RealSrcSpan
th_loc
| Bool
is_th_bind
= SDoc -> Int -> SDoc -> SDoc
hang (SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ) SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (String -> SDoc
text "splice on" SDoc -> SDoc -> SDoc
<+> SDoc
th_rng))
2 (String -> SDoc
text "is not in scope before line" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
th_start_ln)
| Bool
otherwise
= SDoc -> Int -> SDoc -> SDoc
hang (SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ) SDoc -> SDoc -> SDoc
<+> SDoc
bind_rng SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is not in scope")
2 (String -> SDoc
text "before the splice on" SDoc -> SDoc -> SDoc
<+> SDoc
th_rng)
where
bind_rng :: SDoc
bind_rng = SDoc -> SDoc
parens (String -> SDoc
text "line" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
bind_ln)
th_rng :: SDoc
th_rng
| Int
th_start_ln Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
th_end_ln = SDoc
single
| Bool
otherwise = SDoc
multi
single :: SDoc
single = String -> SDoc
text "line" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
th_start_ln
multi :: SDoc
multi = String -> SDoc
text "lines" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
th_start_ln SDoc -> SDoc -> SDoc
<> String -> SDoc
text "-" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
th_end_ln
bind_ln :: Int
bind_ln = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
bind_loc
th_start_ln :: Int
th_start_ln = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
th_loc
th_end_ln :: Int
th_end_ln = RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
th_loc
is_th_bind :: Bool
is_th_bind = RealSrcSpan
th_loc RealSrcSpan -> RealSrcSpan -> Bool
`containsSpan` RealSrcSpan
bind_loc
mkHoleError tidy_simples :: [Ct]
tidy_simples ctxt :: ReportErrCtxt
ctxt ct :: Ct
ct@(CHoleCan { cc_hole :: Ct -> Hole
cc_hole = Hole
hole })
= do { (ctxt :: ReportErrCtxt
ctxt, binds_msg :: SDoc
binds_msg, ct :: Ct
ct) <- Bool -> ReportErrCtxt -> Ct -> TcM (ReportErrCtxt, SDoc, Ct)
relevantBindings Bool
False ReportErrCtxt
ctxt Ct
ct
; Bool
show_hole_constraints <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_ShowHoleConstraints
; let constraints_msg :: SDoc
constraints_msg
| Ct -> Bool
isExprHoleCt Ct
ct, Bool
show_hole_constraints
= ReportErrCtxt -> SDoc
givenConstraintsMsg ReportErrCtxt
ctxt
| Bool
otherwise = SDoc
empty
; Bool
show_valid_hole_fits <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_ShowValidHoleFits
; (ctxt :: ReportErrCtxt
ctxt, sub_msg :: SDoc
sub_msg) <- if Bool
show_valid_hole_fits
then ReportErrCtxt -> [Ct] -> Ct -> TcM (ReportErrCtxt, SDoc)
validHoleFits ReportErrCtxt
ctxt [Ct]
tidy_simples Ct
ct
else (ReportErrCtxt, SDoc) -> TcM (ReportErrCtxt, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (ReportErrCtxt
ctxt, SDoc
empty)
; ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct (Report -> TcM ErrMsg) -> Report -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$
SDoc -> Report
important SDoc
hole_msg Report -> Report -> Report
forall a. Monoid a => a -> a -> a
`mappend`
SDoc -> Report
relevant_bindings (SDoc
binds_msg SDoc -> SDoc -> SDoc
$$ SDoc
constraints_msg) Report -> Report -> Report
forall a. Monoid a => a -> a -> a
`mappend`
SDoc -> Report
valid_hole_fits SDoc
sub_msg}
where
occ :: OccName
occ = Hole -> OccName
holeOcc Hole
hole
hole_ty :: Type
hole_ty = CtEvidence -> Type
ctEvPred (Ct -> CtEvidence
ctEvidence Ct
ct)
hole_kind :: Type
hole_kind = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
hole_ty
tyvars :: [TyCoVar]
tyvars = Type -> [TyCoVar]
tyCoVarsOfTypeList Type
hole_ty
hole_msg :: SDoc
hole_msg = case Hole
hole of
ExprHole {} -> [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Found hole:")
2 (OccName -> Type -> SDoc
pp_with_type OccName
occ Type
hole_ty)
, SDoc
tyvars_msg, SDoc
expr_hole_hint ]
TypeHole {} -> [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Found type wildcard" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ))
2 (String -> SDoc
text "standing for" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes SDoc
pp_hole_type_with_kind)
, SDoc
tyvars_msg, SDoc
type_hole_hint ]
pp_hole_type_with_kind :: SDoc
pp_hole_type_with_kind
| Type -> Bool
isLiftedTypeKind Type
hole_kind
Bool -> Bool -> Bool
|| Type -> Bool
isCoVarType Type
hole_ty
= Type -> SDoc
pprType Type
hole_ty
| Bool
otherwise
= Type -> SDoc
pprType Type
hole_ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprKind Type
hole_kind
tyvars_msg :: SDoc
tyvars_msg = Bool -> SDoc -> SDoc
ppUnless ([TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
tyvars) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text "Where:" SDoc -> SDoc -> SDoc
<+> ([SDoc] -> SDoc
vcat ((TyCoVar -> SDoc) -> [TyCoVar] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map TyCoVar -> SDoc
loc_msg [TyCoVar]
other_tvs)
SDoc -> SDoc -> SDoc
$$ ReportErrCtxt -> [TyCoVar] -> SDoc
pprSkols ReportErrCtxt
ctxt [TyCoVar]
skol_tvs)
where
(skol_tvs :: [TyCoVar]
skol_tvs, other_tvs :: [TyCoVar]
other_tvs) = (TyCoVar -> Bool) -> [TyCoVar] -> ([TyCoVar], [TyCoVar])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition TyCoVar -> Bool
is_skol [TyCoVar]
tyvars
is_skol :: TyCoVar -> Bool
is_skol tv :: TyCoVar
tv = TyCoVar -> Bool
isTcTyVar TyCoVar
tv Bool -> Bool -> Bool
&& TyCoVar -> Bool
isSkolemTyVar TyCoVar
tv
type_hole_hint :: SDoc
type_hole_hint
| HoleChoice
HoleError <- ReportErrCtxt -> HoleChoice
cec_type_holes ReportErrCtxt
ctxt
= String -> SDoc
text "To use the inferred type, enable PartialTypeSignatures"
| Bool
otherwise
= SDoc
empty
expr_hole_hint :: SDoc
expr_hole_hint
| FastString -> Int
lengthFS (OccName -> FastString
occNameFS OccName
occ) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1
= String -> SDoc
text "Or perhaps" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is mis-spelled, or not in scope"
| Bool
otherwise
= SDoc
empty
loc_msg :: TyCoVar -> SDoc
loc_msg tv :: TyCoVar
tv
| TyCoVar -> Bool
isTyVar TyCoVar
tv
= case TyCoVar -> TcTyVarDetails
tcTyVarDetails TyCoVar
tv of
MetaTv {} -> SDoc -> SDoc
quotes (TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVar
tv) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is an ambiguous type variable"
_ -> SDoc
empty
| Bool
otherwise
= (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PrintExplicitCoercions DynFlags
dflags
then SDoc -> SDoc
quotes (TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVar
tv) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is a coercion variable"
else SDoc
empty
mkHoleError _ _ ct :: Ct
ct = String -> SDoc -> TcM ErrMsg
forall a. HasCallStack => String -> SDoc -> a
pprPanic "mkHoleError" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct)
validHoleFits :: ReportErrCtxt
-> [Ct]
-> Ct
-> TcM (ReportErrCtxt, SDoc)
validHoleFits :: ReportErrCtxt -> [Ct] -> Ct -> TcM (ReportErrCtxt, SDoc)
validHoleFits ctxt :: ReportErrCtxt
ctxt@(CEC {cec_encl :: ReportErrCtxt -> [Implication]
cec_encl = [Implication]
implics
, cec_tidy :: ReportErrCtxt -> TidyEnv
cec_tidy = TidyEnv
lcl_env}) simps :: [Ct]
simps ct :: Ct
ct
= do { (tidy_env :: TidyEnv
tidy_env, msg :: SDoc
msg) <- TidyEnv -> [Implication] -> [Ct] -> Ct -> TcM (TidyEnv, SDoc)
findValidHoleFits TidyEnv
lcl_env [Implication]
implics [Ct]
simps Ct
ct
; (ReportErrCtxt, SDoc) -> TcM (ReportErrCtxt, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (ReportErrCtxt
ctxt {cec_tidy :: TidyEnv
cec_tidy = TidyEnv
tidy_env}, SDoc
msg) }
givenConstraintsMsg :: ReportErrCtxt -> SDoc
givenConstraintsMsg :: ReportErrCtxt -> SDoc
givenConstraintsMsg ctxt :: ReportErrCtxt
ctxt =
let constraints :: [(Type, RealSrcSpan)]
constraints :: [(Type, RealSrcSpan)]
constraints =
do { implic :: Implication
implic@Implic{ ic_given :: Implication -> [TyCoVar]
ic_given = [TyCoVar]
given } <- ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt
; TyCoVar
constraint <- [TyCoVar]
given
; (Type, RealSrcSpan) -> [(Type, RealSrcSpan)]
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCoVar -> Type
varType TyCoVar
constraint, TcLclEnv -> RealSrcSpan
tcl_loc (Implication -> TcLclEnv
implicLclEnv Implication
implic)) }
pprConstraint :: (a, a) -> SDoc
pprConstraint (constraint :: a
constraint, loc :: a
loc) =
a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
constraint SDoc -> SDoc -> SDoc
<+> Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc
parens (String -> SDoc
text "from" SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
loc))
in Bool -> SDoc -> SDoc
ppUnless ([(Type, RealSrcSpan)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Type, RealSrcSpan)]
constraints) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Constraints include")
2 ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ ((Type, RealSrcSpan) -> SDoc) -> [(Type, RealSrcSpan)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Type, RealSrcSpan) -> SDoc
forall a a. (Outputable a, Outputable a) => (a, a) -> SDoc
pprConstraint [(Type, RealSrcSpan)]
constraints)
pp_with_type :: OccName -> Type -> SDoc
pp_with_type :: OccName -> Type -> SDoc
pp_with_type occ :: OccName
occ ty :: Type
ty = SDoc -> Int -> SDoc -> SDoc
hang (OccName -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc OccName
occ) 2 (SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprType Type
ty)
mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIPErr ctxt :: ReportErrCtxt
ctxt cts :: [Ct]
cts
= do { (ctxt :: ReportErrCtxt
ctxt, binds_msg :: SDoc
binds_msg, ct1 :: Ct
ct1) <- Bool -> ReportErrCtxt -> Ct -> TcM (ReportErrCtxt, SDoc, Ct)
relevantBindings Bool
True ReportErrCtxt
ctxt Ct
ct1
; let orig :: CtOrigin
orig = Ct -> CtOrigin
ctOrigin Ct
ct1
preds :: [Type]
preds = (Ct -> Type) -> [Ct] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Ct -> Type
ctPred [Ct]
cts
givens :: [Implication]
givens = ReportErrCtxt -> [Implication]
getUserGivens ReportErrCtxt
ctxt
msg :: SDoc
msg | [Implication] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Implication]
givens
= CtOrigin -> SDoc -> SDoc
addArising CtOrigin
orig (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [ String -> SDoc
text "Unbound implicit parameter" SDoc -> SDoc -> SDoc
<> [Ct] -> SDoc
forall a. [a] -> SDoc
plural [Ct]
cts
, Int -> SDoc -> SDoc
nest 2 ([Type] -> SDoc
pprParendTheta [Type]
preds) ]
| Bool
otherwise
= [Implication] -> ([Type], CtOrigin) -> SDoc
couldNotDeduce [Implication]
givens ([Type]
preds, CtOrigin
orig)
; ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct1 (Report -> TcM ErrMsg) -> Report -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$
SDoc -> Report
important SDoc
msg Report -> Report -> Report
forall a. Monoid a => a -> a -> a
`mappend` SDoc -> Report
relevant_bindings SDoc
binds_msg }
where
(ct1 :: Ct
ct1:_) = [Ct]
cts
mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkEqErr ctxt :: ReportErrCtxt
ctxt (ct :: Ct
ct:_) = ReportErrCtxt -> Ct -> TcM ErrMsg
mkEqErr1 ReportErrCtxt
ctxt Ct
ct
mkEqErr _ [] = String -> TcM ErrMsg
forall a. String -> a
panic "mkEqErr"
mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
mkEqErr1 ctxt :: ReportErrCtxt
ctxt ct :: Ct
ct
= do { (ctxt :: ReportErrCtxt
ctxt, binds_msg :: SDoc
binds_msg, ct :: Ct
ct) <- Bool -> ReportErrCtxt -> Ct -> TcM (ReportErrCtxt, SDoc, Ct)
relevantBindings Bool
True ReportErrCtxt
ctxt Ct
ct
; GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
; FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; Bool
exp_syns <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_PrintExpandedSynonyms
; let (keep_going :: Bool
keep_going, is_oriented :: Maybe SwapFlag
is_oriented, wanted_msg :: SDoc
wanted_msg)
= CtLoc -> Bool -> (Bool, Maybe SwapFlag, SDoc)
mk_wanted_extra (Ct -> CtLoc
ctLoc Ct
ct) Bool
exp_syns
coercible_msg :: SDoc
coercible_msg = case Ct -> EqRel
ctEqRel Ct
ct of
NomEq -> SDoc
empty
ReprEq -> GlobalRdrEnv -> FamInstEnvs -> Type -> Type -> SDoc
mkCoercibleExplanation GlobalRdrEnv
rdr_env FamInstEnvs
fam_envs Type
ty1 Type
ty2
; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; String -> SDoc -> TcM ()
traceTc "mkEqErr1" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct SDoc -> SDoc -> SDoc
$$ CtOrigin -> SDoc
pprCtOrigin (Ct -> CtOrigin
ctOrigin Ct
ct) SDoc -> SDoc -> SDoc
$$ Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
keep_going)
; let report :: Report
report = [Report] -> Report
forall a. Monoid a => [a] -> a
mconcat [SDoc -> Report
important SDoc
wanted_msg, SDoc -> Report
important SDoc
coercible_msg,
SDoc -> Report
relevant_bindings SDoc
binds_msg]
; if Bool
keep_going
then DynFlags
-> ReportErrCtxt
-> Report
-> Ct
-> Maybe SwapFlag
-> Type
-> Type
-> TcM ErrMsg
mkEqErr_help DynFlags
dflags ReportErrCtxt
ctxt Report
report Ct
ct Maybe SwapFlag
is_oriented Type
ty1 Type
ty2
else ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct Report
report }
where
(ty1 :: Type
ty1, ty2 :: Type
ty2) = Type -> (Type, Type)
getEqPredTys (Ct -> Type
ctPred Ct
ct)
mk_wanted_extra :: CtLoc -> Bool -> (Bool, Maybe SwapFlag, SDoc)
mk_wanted_extra :: CtLoc -> Bool -> (Bool, Maybe SwapFlag, SDoc)
mk_wanted_extra loc :: CtLoc
loc expandSyns :: Bool
expandSyns
= case CtLoc -> CtOrigin
ctLocOrigin CtLoc
loc of
orig :: CtOrigin
orig@TypeEqOrigin {} -> Type
-> Type
-> CtOrigin
-> Maybe TypeOrKind
-> Bool
-> (Bool, Maybe SwapFlag, SDoc)
mkExpectedActualMsg Type
ty1 Type
ty2 CtOrigin
orig
Maybe TypeOrKind
t_or_k Bool
expandSyns
where
t_or_k :: Maybe TypeOrKind
t_or_k = CtLoc -> Maybe TypeOrKind
ctLocTypeOrKind_maybe CtLoc
loc
KindEqOrigin cty1 :: Type
cty1 mb_cty2 :: Maybe Type
mb_cty2 sub_o :: CtOrigin
sub_o sub_t_or_k :: Maybe TypeOrKind
sub_t_or_k
-> (Bool
True, Maybe SwapFlag
forall a. Maybe a
Nothing, SDoc
msg1 SDoc -> SDoc -> SDoc
$$ SDoc
msg2)
where
sub_what :: SDoc
sub_what = case Maybe TypeOrKind
sub_t_or_k of Just KindLevel -> String -> SDoc
text "kinds"
_ -> String -> SDoc
text "types"
msg1 :: SDoc
msg1 = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
case Maybe Type
mb_cty2 of
Just cty2 :: Type
cty2
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PrintExplicitCoercions DynFlags
dflags
Bool -> Bool -> Bool
|| Bool -> Bool
not (Type
cty1 Type -> Type -> Bool
`pickyEqType` Type
cty2)
-> SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "When matching" SDoc -> SDoc -> SDoc
<+> SDoc
sub_what)
2 ([SDoc] -> SDoc
vcat [ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
cty1 SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+>
Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
cty1)
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
cty2 SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+>
Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
cty2) ])
_ -> String -> SDoc
text "When matching the kind of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
cty1)
msg2 :: SDoc
msg2 = case CtOrigin
sub_o of
TypeEqOrigin {}
| Just cty2 :: Type
cty2 <- Maybe Type
mb_cty2 ->
(Bool, Maybe SwapFlag, SDoc) -> SDoc
forall a b c. (a, b, c) -> c
thdOf3 (Type
-> Type
-> CtOrigin
-> Maybe TypeOrKind
-> Bool
-> (Bool, Maybe SwapFlag, SDoc)
mkExpectedActualMsg Type
cty1 Type
cty2 CtOrigin
sub_o Maybe TypeOrKind
sub_t_or_k
Bool
expandSyns)
_ -> SDoc
empty
_ -> (Bool
True, Maybe SwapFlag
forall a. Maybe a
Nothing, SDoc
empty)
mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs
-> TcType -> TcType -> SDoc
mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs -> Type -> Type -> SDoc
mkCoercibleExplanation rdr_env :: GlobalRdrEnv
rdr_env fam_envs :: FamInstEnvs
fam_envs ty1 :: Type
ty1 ty2 :: Type
ty2
| Just (tc :: TyCon
tc, tys :: [Type]
tys) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty1
, (rep_tc :: TyCon
rep_tc, _, _) <- FamInstEnvs -> TyCon -> [Type] -> (TyCon, [Type], Coercion)
tcLookupDataFamInst FamInstEnvs
fam_envs TyCon
tc [Type]
tys
, Just msg :: SDoc
msg <- TyCon -> Maybe SDoc
coercible_msg_for_tycon TyCon
rep_tc
= SDoc
msg
| Just (tc :: TyCon
tc, tys :: [Type]
tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty2
, (rep_tc :: TyCon
rep_tc, _, _) <- FamInstEnvs -> TyCon -> [Type] -> (TyCon, [Type], Coercion)
tcLookupDataFamInst FamInstEnvs
fam_envs TyCon
tc [Type]
tys
, Just msg :: SDoc
msg <- TyCon -> Maybe SDoc
coercible_msg_for_tycon TyCon
rep_tc
= SDoc
msg
| Just (s1 :: Type
s1, _) <- Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
ty1
, Just (s2 :: Type
s2, _) <- Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
ty2
, Type
s1 Type -> Type -> Bool
`eqType` Type
s2
, Type -> Bool
has_unknown_roles Type
s1
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "NB: We cannot know what roles the parameters to" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
s1) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "have;")
2 (String -> SDoc
text "we must assume that the role is nominal")
| Bool
otherwise
= SDoc
empty
where
coercible_msg_for_tycon :: TyCon -> Maybe SDoc
coercible_msg_for_tycon tc :: TyCon
tc
| TyCon -> Bool
isAbstractTyCon TyCon
tc
= SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep [ String -> SDoc
text "NB: The type constructor"
, SDoc -> SDoc
quotes (TyCon -> SDoc
pprSourceTyCon TyCon
tc)
, String -> SDoc
text "is abstract" ]
| TyCon -> Bool
isNewTyCon TyCon
tc
, [data_con :: DataCon
data_con] <- TyCon -> [DataCon]
tyConDataCons TyCon
tc
, let dc_name :: Name
dc_name = DataCon -> Name
dataConName DataCon
data_con
, Maybe GlobalRdrElt -> Bool
forall a. Maybe a -> Bool
isNothing (GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
lookupGRE_Name GlobalRdrEnv
rdr_env Name
dc_name)
= SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "The data constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
dc_name))
2 ([SDoc] -> SDoc
sep [ String -> SDoc
text "of newtype" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
pprSourceTyCon TyCon
tc)
, String -> SDoc
text "is not in scope" ])
| Bool
otherwise = Maybe SDoc
forall a. Maybe a
Nothing
has_unknown_roles :: Type -> Bool
has_unknown_roles ty :: Type
ty
| Just (tc :: TyCon
tc, tys :: [Type]
tys) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
= [Type]
tys [Type] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtLeast` TyCon -> Int
tyConArity TyCon
tc
| Just (s :: Type
s, _) <- Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
ty
= Type -> Bool
has_unknown_roles Type
s
| Type -> Bool
isTyVarTy Type
ty
= Bool
True
| Bool
otherwise
= Bool
False
mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report
-> Ct
-> Maybe SwapFlag
-> TcType -> TcType -> TcM ErrMsg
mkEqErr_help :: DynFlags
-> ReportErrCtxt
-> Report
-> Ct
-> Maybe SwapFlag
-> Type
-> Type
-> TcM ErrMsg
mkEqErr_help dflags :: DynFlags
dflags ctxt :: ReportErrCtxt
ctxt report :: Report
report ct :: Ct
ct oriented :: Maybe SwapFlag
oriented ty1 :: Type
ty1 ty2 :: Type
ty2
| Just (tv1 :: TyCoVar
tv1, co1 :: Coercion
co1) <- Type -> Maybe (TyCoVar, Coercion)
tcGetCastedTyVar_maybe Type
ty1
= DynFlags
-> ReportErrCtxt
-> Report
-> Ct
-> Maybe SwapFlag
-> TyCoVar
-> Coercion
-> Type
-> TcM ErrMsg
mkTyVarEqErr DynFlags
dflags ReportErrCtxt
ctxt Report
report Ct
ct Maybe SwapFlag
oriented TyCoVar
tv1 Coercion
co1 Type
ty2
| Just (tv2 :: TyCoVar
tv2, co2 :: Coercion
co2) <- Type -> Maybe (TyCoVar, Coercion)
tcGetCastedTyVar_maybe Type
ty2
= DynFlags
-> ReportErrCtxt
-> Report
-> Ct
-> Maybe SwapFlag
-> TyCoVar
-> Coercion
-> Type
-> TcM ErrMsg
mkTyVarEqErr DynFlags
dflags ReportErrCtxt
ctxt Report
report Ct
ct Maybe SwapFlag
swapped TyCoVar
tv2 Coercion
co2 Type
ty1
| Bool
otherwise
= ReportErrCtxt
-> Report -> Ct -> Maybe SwapFlag -> Type -> Type -> TcM ErrMsg
reportEqErr ReportErrCtxt
ctxt Report
report Ct
ct Maybe SwapFlag
oriented Type
ty1 Type
ty2
where
swapped :: Maybe SwapFlag
swapped = (SwapFlag -> SwapFlag) -> Maybe SwapFlag -> Maybe SwapFlag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SwapFlag -> SwapFlag
flipSwap Maybe SwapFlag
oriented
reportEqErr :: ReportErrCtxt -> Report
-> Ct
-> Maybe SwapFlag
-> TcType -> TcType -> TcM ErrMsg
reportEqErr :: ReportErrCtxt
-> Report -> Ct -> Maybe SwapFlag -> Type -> Type -> TcM ErrMsg
reportEqErr ctxt :: ReportErrCtxt
ctxt report :: Report
report ct :: Ct
ct oriented :: Maybe SwapFlag
oriented ty1 :: Type
ty1 ty2 :: Type
ty2
= ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct ([Report] -> Report
forall a. Monoid a => [a] -> a
mconcat [Report
misMatch, Report
report, Report
eqInfo])
where misMatch :: Report
misMatch = SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ ReportErrCtxt -> Ct -> Maybe SwapFlag -> Type -> Type -> SDoc
misMatchOrCND ReportErrCtxt
ctxt Ct
ct Maybe SwapFlag
oriented Type
ty1 Type
ty2
eqInfo :: Report
eqInfo = SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ Ct -> Type -> Type -> SDoc
mkEqInfoMsg Ct
ct Type
ty1 Type
ty2
mkTyVarEqErr, mkTyVarEqErr'
:: DynFlags -> ReportErrCtxt -> Report -> Ct
-> Maybe SwapFlag -> TcTyVar -> TcCoercionN -> TcType -> TcM ErrMsg
mkTyVarEqErr :: DynFlags
-> ReportErrCtxt
-> Report
-> Ct
-> Maybe SwapFlag
-> TyCoVar
-> Coercion
-> Type
-> TcM ErrMsg
mkTyVarEqErr dflags :: DynFlags
dflags ctxt :: ReportErrCtxt
ctxt report :: Report
report ct :: Ct
ct oriented :: Maybe SwapFlag
oriented tv1 :: TyCoVar
tv1 co1 :: Coercion
co1 ty2 :: Type
ty2
= do { String -> SDoc -> TcM ()
traceTc "mkTyVarEqErr" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct SDoc -> SDoc -> SDoc
$$ TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVar
tv1 SDoc -> SDoc -> SDoc
$$ Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co1 SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty2)
; DynFlags
-> ReportErrCtxt
-> Report
-> Ct
-> Maybe SwapFlag
-> TyCoVar
-> Coercion
-> Type
-> TcM ErrMsg
mkTyVarEqErr' DynFlags
dflags ReportErrCtxt
ctxt Report
report Ct
ct Maybe SwapFlag
oriented TyCoVar
tv1 Coercion
co1 Type
ty2 }
mkTyVarEqErr' :: DynFlags
-> ReportErrCtxt
-> Report
-> Ct
-> Maybe SwapFlag
-> TyCoVar
-> Coercion
-> Type
-> TcM ErrMsg
mkTyVarEqErr' dflags :: DynFlags
dflags ctxt :: ReportErrCtxt
ctxt report :: Report
report ct :: Ct
ct oriented :: Maybe SwapFlag
oriented tv1 :: TyCoVar
tv1 co1 :: Coercion
co1 ty2 :: Type
ty2
| Bool -> Bool
not Bool
insoluble_occurs_check
, ReportErrCtxt -> TyCoVar -> Bool
isUserSkolem ReportErrCtxt
ctxt TyCoVar
tv1
Bool -> Bool -> Bool
|| TyCoVar -> Bool
isTyVarTyVar TyCoVar
tv1 Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
isTyVarTy Type
ty2)
Bool -> Bool -> Bool
|| Ct -> EqRel
ctEqRel Ct
ct EqRel -> EqRel -> Bool
forall a. Eq a => a -> a -> Bool
== EqRel
ReprEq
= ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct (Report -> TcM ErrMsg) -> Report -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$ [Report] -> Report
forall a. Monoid a => [a] -> a
mconcat
[ SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ ReportErrCtxt -> Ct -> Maybe SwapFlag -> Type -> Type -> SDoc
misMatchOrCND ReportErrCtxt
ctxt Ct
ct Maybe SwapFlag
oriented Type
ty1 Type
ty2
, SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ ReportErrCtxt -> TyCoVar -> Type -> SDoc
extraTyVarEqInfo ReportErrCtxt
ctxt TyCoVar
tv1 Type
ty2
, Report
report
]
| OccCheckResult ()
OC_Occurs <- OccCheckResult ()
occ_check_expand
= do { let main_msg :: SDoc
main_msg = CtOrigin -> SDoc -> SDoc
addArising (Ct -> CtOrigin
ctOrigin Ct
ct) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Occurs check: cannot construct the infinite" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<> SDoc
colon)
2 ([SDoc] -> SDoc
sep [Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty1, Char -> SDoc
char '~', Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty2])
extra2 :: Report
extra2 = SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ Ct -> Type -> Type -> SDoc
mkEqInfoMsg Ct
ct Type
ty1 Type
ty2
interesting_tyvars :: [TyCoVar]
interesting_tyvars = (TyCoVar -> Bool) -> [TyCoVar] -> [TyCoVar]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (TyCoVar -> Bool) -> TyCoVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Bool
noFreeVarsOfType (Type -> Bool) -> (TyCoVar -> Type) -> TyCoVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCoVar -> Type
tyVarKind) ([TyCoVar] -> [TyCoVar]) -> [TyCoVar] -> [TyCoVar]
forall a b. (a -> b) -> a -> b
$
(TyCoVar -> Bool) -> [TyCoVar] -> [TyCoVar]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCoVar -> Bool
isTyVar ([TyCoVar] -> [TyCoVar]) -> [TyCoVar] -> [TyCoVar]
forall a b. (a -> b) -> a -> b
$
FV -> [TyCoVar]
fvVarList (FV -> [TyCoVar]) -> FV -> [TyCoVar]
forall a b. (a -> b) -> a -> b
$
Type -> FV
tyCoFVsOfType Type
ty1 FV -> FV -> FV
`unionFV` Type -> FV
tyCoFVsOfType Type
ty2
extra3 :: Report
extra3 = SDoc -> Report
relevant_bindings (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$
Bool -> SDoc -> SDoc
ppWhen (Bool -> Bool
not ([TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
interesting_tyvars)) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Type variable kinds:") 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat ((TyCoVar -> SDoc) -> [TyCoVar] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (TyCoVar -> SDoc
tyvar_binding (TyCoVar -> SDoc) -> (TyCoVar -> TyCoVar) -> TyCoVar -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TidyEnv -> TyCoVar -> TyCoVar
tidyTyCoVarOcc (ReportErrCtxt -> TidyEnv
cec_tidy ReportErrCtxt
ctxt))
[TyCoVar]
interesting_tyvars)
tyvar_binding :: TyCoVar -> SDoc
tyvar_binding tv :: TyCoVar
tv = TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVar
tv SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCoVar -> Type
tyVarKind TyCoVar
tv)
; ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct (Report -> TcM ErrMsg) -> Report -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$
[Report] -> Report
forall a. Monoid a => [a] -> a
mconcat [SDoc -> Report
important SDoc
main_msg, Report
extra2, Report
extra3, Report
report] }
| OccCheckResult ()
OC_Bad <- OccCheckResult ()
occ_check_expand
= do { let msg :: SDoc
msg = [SDoc] -> SDoc
vcat [ String -> SDoc
text "Cannot instantiate unification variable"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVar
tv1)
, SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "with a" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "involving foralls:") 2 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty2)
, Int -> SDoc -> SDoc
nest 2 (String -> SDoc
text "GHC doesn't yet support impredicative polymorphism") ]
; ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct (Report -> TcM ErrMsg) -> Report -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$ Report
report { report_important :: [SDoc]
report_important = [SDoc
msg] } }
| Bool -> Bool
not (Type
k1 HasDebugCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqType` Type
k2)
= do { let main_msg :: SDoc
main_msg = CtOrigin -> SDoc -> SDoc
addArising (Ct -> CtOrigin
ctOrigin Ct
ct) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Kind mismatch: cannot unify" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
parens (TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVar
tv1 SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCoVar -> Type
tyVarKind TyCoVar
tv1)) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text "with:")
2 ([SDoc] -> SDoc
sep [Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty2, SDoc
dcolon, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
k2])
, String -> SDoc
text "Their kinds differ." ]
cast_msg :: SDoc
cast_msg
| Coercion -> Bool
isTcReflexiveCo Coercion
co1 = SDoc
empty
| Bool
otherwise = String -> SDoc
text "NB:" SDoc -> SDoc -> SDoc
<+> TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVar
tv1 SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text "was casted to have kind" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
k1)
; ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct ([Report] -> Report
forall a. Monoid a => [a] -> a
mconcat [SDoc -> Report
important SDoc
main_msg, SDoc -> Report
important SDoc
cast_msg, Report
report]) }
| (implic :: Implication
implic:_) <- ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt
, Implic { ic_skols :: Implication -> [TyCoVar]
ic_skols = [TyCoVar]
skols } <- Implication
implic
, TyCoVar
tv1 TyCoVar -> [TyCoVar] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TyCoVar]
skols
= ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct (Report -> TcM ErrMsg) -> Report -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$ [Report] -> Report
forall a. Monoid a => [a] -> a
mconcat
[ SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ Ct -> Maybe SwapFlag -> Type -> Type -> SDoc
misMatchMsg Ct
ct Maybe SwapFlag
oriented Type
ty1 Type
ty2
, SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ ReportErrCtxt -> TyCoVar -> Type -> SDoc
extraTyVarEqInfo ReportErrCtxt
ctxt TyCoVar
tv1 Type
ty2
, Report
report
]
| (implic :: Implication
implic:_) <- ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt
, Implic { ic_skols :: Implication -> [TyCoVar]
ic_skols = [TyCoVar]
skols, ic_info :: Implication -> SkolemInfo
ic_info = SkolemInfo
skol_info } <- Implication
implic
, let esc_skols :: [TyCoVar]
esc_skols = (TyCoVar -> Bool) -> [TyCoVar] -> [TyCoVar]
forall a. (a -> Bool) -> [a] -> [a]
filter (TyCoVar -> VarSet -> Bool
`elemVarSet` (Type -> VarSet
tyCoVarsOfType Type
ty2)) [TyCoVar]
skols
, Bool -> Bool
not ([TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
esc_skols)
= do { let msg :: Report
msg = SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ Ct -> Maybe SwapFlag -> Type -> Type -> SDoc
misMatchMsg Ct
ct Maybe SwapFlag
oriented Type
ty1 Type
ty2
esc_doc :: SDoc
esc_doc = [SDoc] -> SDoc
sep [ String -> SDoc
text "because" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "variable" SDoc -> SDoc -> SDoc
<> [TyCoVar] -> SDoc
forall a. [a] -> SDoc
plural [TyCoVar]
esc_skols
SDoc -> SDoc -> SDoc
<+> [TyCoVar] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [TyCoVar]
esc_skols
, String -> SDoc
text "would escape" SDoc -> SDoc -> SDoc
<+>
if [TyCoVar] -> Bool
forall a. [a] -> Bool
isSingleton [TyCoVar]
esc_skols then String -> SDoc
text "its scope"
else String -> SDoc
text "their scope" ]
tv_extra :: Report
tv_extra = SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc
esc_doc
, [SDoc] -> SDoc
sep [ (if [TyCoVar] -> Bool
forall a. [a] -> Bool
isSingleton [TyCoVar]
esc_skols
then String -> SDoc
text "This (rigid, skolem)" SDoc -> SDoc -> SDoc
<+>
SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "variable is"
else String -> SDoc
text "These (rigid, skolem)" SDoc -> SDoc -> SDoc
<+>
SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "variables are")
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "bound by"
, Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ SkolemInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfo
skol_info
, Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "at" SDoc -> SDoc -> SDoc
<+>
RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcLclEnv -> RealSrcSpan
tcl_loc (Implication -> TcLclEnv
implicLclEnv Implication
implic)) ] ]
; ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct ([Report] -> Report
forall a. Monoid a => [a] -> a
mconcat [Report
msg, Report
tv_extra, Report
report]) }
| (implic :: Implication
implic:_) <- ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt
, Implic { ic_given :: Implication -> [TyCoVar]
ic_given = [TyCoVar]
given, ic_tclvl :: Implication -> TcLevel
ic_tclvl = TcLevel
lvl, ic_info :: Implication -> SkolemInfo
ic_info = SkolemInfo
skol_info } <- Implication
implic
= ASSERT2( not (isTouchableMetaTyVar lvl tv1)
, ppr tv1 $$ ppr lvl )
do { let msg :: Report
msg = SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ Ct -> Maybe SwapFlag -> Type -> Type -> SDoc
misMatchMsg Ct
ct Maybe SwapFlag
oriented Type
ty1 Type
ty2
tclvl_extra :: Report
tclvl_extra = SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$
Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [ SDoc -> SDoc
quotes (TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVar
tv1) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is untouchable"
, Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "inside the constraints:" SDoc -> SDoc -> SDoc
<+> [TyCoVar] -> SDoc
pprEvVarTheta [TyCoVar]
given
, Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "bound by" SDoc -> SDoc -> SDoc
<+> SkolemInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfo
skol_info
, Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "at" SDoc -> SDoc -> SDoc
<+>
RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcLclEnv -> RealSrcSpan
tcl_loc (Implication -> TcLclEnv
implicLclEnv Implication
implic)) ]
tv_extra :: Report
tv_extra = SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ ReportErrCtxt -> TyCoVar -> Type -> SDoc
extraTyVarEqInfo ReportErrCtxt
ctxt TyCoVar
tv1 Type
ty2
add_sig :: Report
add_sig = SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ ReportErrCtxt -> Type -> Type -> SDoc
suggestAddSig ReportErrCtxt
ctxt Type
ty1 Type
ty2
; ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct (Report -> TcM ErrMsg) -> Report -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$ [Report] -> Report
forall a. Monoid a => [a] -> a
mconcat
[Report
msg, Report
tclvl_extra, Report
tv_extra, Report
add_sig, Report
report] }
| Bool
otherwise
= ReportErrCtxt
-> Report -> Ct -> Maybe SwapFlag -> Type -> Type -> TcM ErrMsg
reportEqErr ReportErrCtxt
ctxt Report
report Ct
ct Maybe SwapFlag
oriented (TyCoVar -> Type
mkTyVarTy TyCoVar
tv1) Type
ty2
where
Pair _ k1 :: Type
k1 = Coercion -> Pair Type
tcCoercionKind Coercion
co1
k2 :: Type
k2 = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
ty2
ty1 :: Type
ty1 = TyCoVar -> Type
mkTyVarTy TyCoVar
tv1
occ_check_expand :: OccCheckResult ()
occ_check_expand = DynFlags -> TyCoVar -> Type -> OccCheckResult ()
occCheckForErrors DynFlags
dflags TyCoVar
tv1 Type
ty2
insoluble_occurs_check :: Bool
insoluble_occurs_check = EqRel -> TyCoVar -> Type -> Bool
isInsolubleOccursCheck (Ct -> EqRel
ctEqRel Ct
ct) TyCoVar
tv1 Type
ty2
what :: SDoc
what = case CtLoc -> Maybe TypeOrKind
ctLocTypeOrKind_maybe (Ct -> CtLoc
ctLoc Ct
ct) of
Just KindLevel -> String -> SDoc
text "kind"
_ -> String -> SDoc
text "type"
mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc
mkEqInfoMsg :: Ct -> Type -> Type -> SDoc
mkEqInfoMsg ct :: Ct
ct ty1 :: Type
ty1 ty2 :: Type
ty2
= SDoc
tyfun_msg SDoc -> SDoc -> SDoc
$$ SDoc
ambig_msg
where
mb_fun1 :: Maybe TyCon
mb_fun1 = Type -> Maybe TyCon
isTyFun_maybe Type
ty1
mb_fun2 :: Maybe TyCon
mb_fun2 = Type -> Maybe TyCon
isTyFun_maybe Type
ty2
ambig_msg :: SDoc
ambig_msg | Maybe TyCon -> Bool
forall a. Maybe a -> Bool
isJust Maybe TyCon
mb_fun1 Bool -> Bool -> Bool
|| Maybe TyCon -> Bool
forall a. Maybe a -> Bool
isJust Maybe TyCon
mb_fun2
= (Bool, SDoc) -> SDoc
forall a b. (a, b) -> b
snd (Bool -> Ct -> (Bool, SDoc)
mkAmbigMsg Bool
False Ct
ct)
| Bool
otherwise = SDoc
empty
tyfun_msg :: SDoc
tyfun_msg | Just tc1 :: TyCon
tc1 <- Maybe TyCon
mb_fun1
, Just tc2 :: TyCon
tc2 <- Maybe TyCon
mb_fun2
, TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2
, Bool -> Bool
not (TyCon -> Role -> Bool
isInjectiveTyCon TyCon
tc1 Role
Nominal)
= String -> SDoc
text "NB:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc1)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is a non-injective type family"
| Bool
otherwise = SDoc
empty
isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool
isUserSkolem :: ReportErrCtxt -> TyCoVar -> Bool
isUserSkolem ctxt :: ReportErrCtxt
ctxt tv :: TyCoVar
tv
= TyCoVar -> Bool
isSkolemTyVar TyCoVar
tv Bool -> Bool -> Bool
&& (Implication -> Bool) -> [Implication] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Implication -> Bool
is_user_skol_tv (ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt)
where
is_user_skol_tv :: Implication -> Bool
is_user_skol_tv (Implic { ic_skols :: Implication -> [TyCoVar]
ic_skols = [TyCoVar]
sks, ic_info :: Implication -> SkolemInfo
ic_info = SkolemInfo
skol_info })
= TyCoVar
tv TyCoVar -> [TyCoVar] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TyCoVar]
sks Bool -> Bool -> Bool
&& SkolemInfo -> Bool
is_user_skol_info SkolemInfo
skol_info
is_user_skol_info :: SkolemInfo -> Bool
is_user_skol_info (InferSkol {}) = Bool
False
is_user_skol_info _ = Bool
True
misMatchOrCND :: ReportErrCtxt -> Ct
-> Maybe SwapFlag -> TcType -> TcType -> SDoc
misMatchOrCND :: ReportErrCtxt -> Ct -> Maybe SwapFlag -> Type -> Type -> SDoc
misMatchOrCND ctxt :: ReportErrCtxt
ctxt ct :: Ct
ct oriented :: Maybe SwapFlag
oriented ty1 :: Type
ty1 ty2 :: Type
ty2
| [Implication] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Implication]
givens Bool -> Bool -> Bool
||
(Type -> Bool
isRigidTy Type
ty1 Bool -> Bool -> Bool
&& Type -> Bool
isRigidTy Type
ty2) Bool -> Bool -> Bool
||
Ct -> Bool
isGivenCt Ct
ct
= Ct -> Maybe SwapFlag -> Type -> Type -> SDoc
misMatchMsg Ct
ct Maybe SwapFlag
oriented Type
ty1 Type
ty2
| Bool
otherwise
= [Implication] -> ([Type], CtOrigin) -> SDoc
couldNotDeduce [Implication]
givens ([Type
eq_pred], CtOrigin
orig)
where
ev :: CtEvidence
ev = Ct -> CtEvidence
ctEvidence Ct
ct
eq_pred :: Type
eq_pred = CtEvidence -> Type
ctEvPred CtEvidence
ev
orig :: CtOrigin
orig = CtEvidence -> CtOrigin
ctEvOrigin CtEvidence
ev
givens :: [Implication]
givens = [ Implication
given | Implication
given <- ReportErrCtxt -> [Implication]
getUserGivens ReportErrCtxt
ctxt, Bool -> Bool
not (Implication -> Bool
ic_no_eqs Implication
given)]
couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
couldNotDeduce :: [Implication] -> ([Type], CtOrigin) -> SDoc
couldNotDeduce givens :: [Implication]
givens (wanteds :: [Type]
wanteds, orig :: CtOrigin
orig)
= [SDoc] -> SDoc
vcat [ CtOrigin -> SDoc -> SDoc
addArising CtOrigin
orig (String -> SDoc
text "Could not deduce:" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
pprTheta [Type]
wanteds)
, [SDoc] -> SDoc
vcat ([Implication] -> [SDoc]
pp_givens [Implication]
givens)]
pp_givens :: [UserGiven] -> [SDoc]
pp_givens :: [Implication] -> [SDoc]
pp_givens givens :: [Implication]
givens
= case [Implication]
givens of
[] -> []
(g :: Implication
g:gs :: [Implication]
gs) -> SDoc -> Implication -> SDoc
ppr_given (String -> SDoc
text "from the context:") Implication
g
SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: (Implication -> SDoc) -> [Implication] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> Implication -> SDoc
ppr_given (String -> SDoc
text "or from:")) [Implication]
gs
where
ppr_given :: SDoc -> Implication -> SDoc
ppr_given herald :: SDoc
herald implic :: Implication
implic@(Implic { ic_given :: Implication -> [TyCoVar]
ic_given = [TyCoVar]
gs, ic_info :: Implication -> SkolemInfo
ic_info = SkolemInfo
skol_info })
= SDoc -> Int -> SDoc -> SDoc
hang (SDoc
herald SDoc -> SDoc -> SDoc
<+> [TyCoVar] -> SDoc
pprEvVarTheta ((TyCoVar -> Type) -> [TyCoVar] -> [TyCoVar]
forall a. (a -> Type) -> [a] -> [a]
mkMinimalBySCs TyCoVar -> Type
evVarPred [TyCoVar]
gs))
2 ([SDoc] -> SDoc
sep [ String -> SDoc
text "bound by" SDoc -> SDoc -> SDoc
<+> SkolemInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfo
skol_info
, String -> SDoc
text "at" SDoc -> SDoc -> SDoc
<+> RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcLclEnv -> RealSrcSpan
tcl_loc (Implication -> TcLclEnv
implicLclEnv Implication
implic)) ])
extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc
ctxt :: ReportErrCtxt
ctxt tv1 :: TyCoVar
tv1 ty2 :: Type
ty2
= ReportErrCtxt -> TyCoVar -> SDoc
extraTyVarInfo ReportErrCtxt
ctxt TyCoVar
tv1 SDoc -> SDoc -> SDoc
$$ Type -> SDoc
ty_extra Type
ty2
where
ty_extra :: Type -> SDoc
ty_extra ty :: Type
ty = case Type -> Maybe TyCoVar
tcGetTyVar_maybe Type
ty of
Just tv :: TyCoVar
tv -> ReportErrCtxt -> TyCoVar -> SDoc
extraTyVarInfo ReportErrCtxt
ctxt TyCoVar
tv
Nothing -> SDoc
empty
extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc
ctxt :: ReportErrCtxt
ctxt tv :: TyCoVar
tv
= ASSERT2( isTyVar tv, ppr tv )
case TyCoVar -> TcTyVarDetails
tcTyVarDetails TyCoVar
tv of
SkolemTv {} -> ReportErrCtxt -> [TyCoVar] -> SDoc
pprSkols ReportErrCtxt
ctxt [TyCoVar
tv]
RuntimeUnk {} -> SDoc -> SDoc
quotes (TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVar
tv) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is an interactive-debugger skolem"
MetaTv {} -> SDoc
empty
suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc
suggestAddSig :: ReportErrCtxt -> Type -> Type -> SDoc
suggestAddSig ctxt :: ReportErrCtxt
ctxt ty1 :: Type
ty1 ty2 :: Type
ty2
| [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
inferred_bndrs
= SDoc
empty
| [bndr :: Name
bndr] <- [Name]
inferred_bndrs
= String -> SDoc
text "Possible fix: add a type signature for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
bndr)
| Bool
otherwise
= String -> SDoc
text "Possible fix: add type signatures for some or all of" SDoc -> SDoc -> SDoc
<+> ([Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
inferred_bndrs)
where
inferred_bndrs :: [Name]
inferred_bndrs = [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub (Type -> [Name]
get_inf Type
ty1 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Type -> [Name]
get_inf Type
ty2)
get_inf :: Type -> [Name]
get_inf ty :: Type
ty | Just tv :: TyCoVar
tv <- Type -> Maybe TyCoVar
tcGetTyVar_maybe Type
ty
, TyCoVar -> Bool
isSkolemTyVar TyCoVar
tv
, (implic :: Implication
implic, _) : _ <- [Implication] -> [TyCoVar] -> [(Implication, [TyCoVar])]
getSkolemInfo (ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt) [TyCoVar
tv]
, InferSkol prs :: [(Name, Type)]
prs <- Implication -> SkolemInfo
ic_info Implication
implic
= ((Name, Type) -> Name) -> [(Name, Type)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Type) -> Name
forall a b. (a, b) -> a
fst [(Name, Type)]
prs
| Bool
otherwise
= []
misMatchMsg :: Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc
misMatchMsg :: Ct -> Maybe SwapFlag -> Type -> Type -> SDoc
misMatchMsg ct :: Ct
ct oriented :: Maybe SwapFlag
oriented ty1 :: Type
ty1 ty2 :: Type
ty2
| Just NotSwapped <- Maybe SwapFlag
oriented
= Ct -> Maybe SwapFlag -> Type -> Type -> SDoc
misMatchMsg Ct
ct (SwapFlag -> Maybe SwapFlag
forall a. a -> Maybe a
Just SwapFlag
IsSwapped) Type
ty2 Type
ty1
| Type -> Bool
isLiftedRuntimeRep Type
ty1
= SDoc
lifted_vs_unlifted
| Type -> Bool
isLiftedRuntimeRep Type
ty2
= SDoc
lifted_vs_unlifted
| Bool
otherwise
= CtOrigin -> SDoc -> SDoc
addArising CtOrigin
orig (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
Type -> Type -> CtOrigin -> SDoc -> SDoc
pprWithExplicitKindsWhenMismatch Type
ty1 Type
ty2 (Ct -> CtOrigin
ctOrigin Ct
ct) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [ String -> SDoc
text String
herald1 SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty1)
, Int -> SDoc -> SDoc
nest Int
padding (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
herald2 SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty2)
, Type -> Type -> SDoc
sameOccExtra Type
ty2 Type
ty1 ]
where
herald1 :: String
herald1 = [String] -> String
conc [ "Couldn't match"
, if Bool
is_repr then "representation of" else ""
, if Bool
is_oriented then "expected" else ""
, String
what ]
herald2 :: String
herald2 = [String] -> String
conc [ "with"
, if Bool
is_repr then "that of" else ""
, if Bool
is_oriented then ("actual " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
what) else "" ]
padding :: Int
padding = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
herald1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
herald2
is_repr :: Bool
is_repr = case Ct -> EqRel
ctEqRel Ct
ct of { ReprEq -> Bool
True; NomEq -> Bool
False }
is_oriented :: Bool
is_oriented = Maybe SwapFlag -> Bool
forall a. Maybe a -> Bool
isJust Maybe SwapFlag
oriented
orig :: CtOrigin
orig = Ct -> CtOrigin
ctOrigin Ct
ct
what :: String
what = case CtLoc -> Maybe TypeOrKind
ctLocTypeOrKind_maybe (Ct -> CtLoc
ctLoc Ct
ct) of
Just KindLevel -> "kind"
_ -> "type"
conc :: [String] -> String
conc :: [String] -> String
conc = (String -> String -> String) -> [String] -> String
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 String -> String -> String
add_space
add_space :: String -> String -> String
add_space :: String -> String -> String
add_space s1 :: String
s1 s2 :: String
s2 | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s1 = String
s2
| String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s2 = String
s1
| Bool
otherwise = String
s1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ (' ' Char -> String -> String
forall a. a -> [a] -> [a]
: String
s2)
lifted_vs_unlifted :: SDoc
lifted_vs_unlifted
= CtOrigin -> SDoc -> SDoc
addArising CtOrigin
orig (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text "Couldn't match a lifted type with an unlifted type"
pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin
-> SDoc -> SDoc
pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin -> SDoc -> SDoc
pprWithExplicitKindsWhenMismatch ty1 :: Type
ty1 ty2 :: Type
ty2 ct :: CtOrigin
ct =
Bool -> SDoc -> SDoc
pprWithExplicitKindsWhen Bool
mismatch
where
(act_ty :: Type
act_ty, exp_ty :: Type
exp_ty) = case CtOrigin
ct of
TypeEqOrigin { uo_actual :: CtOrigin -> Type
uo_actual = Type
act
, uo_expected :: CtOrigin -> Type
uo_expected = Type
exp } -> (Type
act, Type
exp)
_ -> (Type
ty1, Type
ty2)
mismatch :: Bool
mismatch | Just vis :: Bool
vis <- Type -> Type -> Maybe Bool
tcEqTypeVis Type
act_ty Type
exp_ty
= Bool -> Bool
not Bool
vis
| Bool
otherwise
= Bool
False
mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool
-> (Bool, Maybe SwapFlag, SDoc)
mkExpectedActualMsg :: Type
-> Type
-> CtOrigin
-> Maybe TypeOrKind
-> Bool
-> (Bool, Maybe SwapFlag, SDoc)
mkExpectedActualMsg ty1 :: Type
ty1 ty2 :: Type
ty2 ct :: CtOrigin
ct@(TypeEqOrigin { uo_actual :: CtOrigin -> Type
uo_actual = Type
act
, uo_expected :: CtOrigin -> Type
uo_expected = Type
exp
, uo_thing :: CtOrigin -> Maybe SDoc
uo_thing = Maybe SDoc
maybe_thing })
m_level :: Maybe TypeOrKind
m_level printExpanded :: Bool
printExpanded
| TypeOrKind
KindLevel <- TypeOrKind
level, Bool
occurs_check_error = (Bool
True, Maybe SwapFlag
forall a. Maybe a
Nothing, SDoc
empty)
| Type -> Bool
isUnliftedTypeKind Type
act, Type -> Bool
isLiftedTypeKind Type
exp = (Bool
False, Maybe SwapFlag
forall a. Maybe a
Nothing, SDoc
msg2)
| Type -> Bool
isLiftedTypeKind Type
act, Type -> Bool
isUnliftedTypeKind Type
exp = (Bool
False, Maybe SwapFlag
forall a. Maybe a
Nothing, SDoc
msg3)
| Type -> Bool
tcIsLiftedTypeKind Type
exp = (Bool
False, Maybe SwapFlag
forall a. Maybe a
Nothing, SDoc
msg4)
| Just msg :: SDoc
msg <- Maybe SDoc
num_args_msg = (Bool
False, Maybe SwapFlag
forall a. Maybe a
Nothing, SDoc
msg SDoc -> SDoc -> SDoc
$$ SDoc
msg1)
| TypeOrKind
KindLevel <- TypeOrKind
level, Just th :: SDoc
th <- Maybe SDoc
maybe_thing = (Bool
False, Maybe SwapFlag
forall a. Maybe a
Nothing, SDoc -> SDoc
msg5 SDoc
th)
| Type
act Type -> Type -> Bool
`pickyEqType` Type
ty1, Type
exp Type -> Type -> Bool
`pickyEqType` Type
ty2 = (Bool
True, SwapFlag -> Maybe SwapFlag
forall a. a -> Maybe a
Just SwapFlag
NotSwapped, SDoc
empty)
| Type
exp Type -> Type -> Bool
`pickyEqType` Type
ty1, Type
act Type -> Type -> Bool
`pickyEqType` Type
ty2 = (Bool
True, SwapFlag -> Maybe SwapFlag
forall a. a -> Maybe a
Just SwapFlag
IsSwapped, SDoc
empty)
| Bool
otherwise = (Bool
True, Maybe SwapFlag
forall a. Maybe a
Nothing, SDoc
msg1)
where
level :: TypeOrKind
level = Maybe TypeOrKind
m_level Maybe TypeOrKind -> TypeOrKind -> TypeOrKind
forall a. Maybe a -> a -> a
`orElse` TypeOrKind
TypeLevel
occurs_check_error :: Bool
occurs_check_error
| Just act_tv :: TyCoVar
act_tv <- Type -> Maybe TyCoVar
tcGetTyVar_maybe Type
act
, TyCoVar
act_tv TyCoVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
exp
= Bool
True
| Just exp_tv :: TyCoVar
exp_tv <- Type -> Maybe TyCoVar
tcGetTyVar_maybe Type
exp
, TyCoVar
exp_tv TyCoVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
act
= Bool
True
| Bool
otherwise
= Bool
False
sort :: SDoc
sort = case TypeOrKind
level of
TypeLevel -> String -> SDoc
text "type"
KindLevel -> String -> SDoc
text "kind"
msg1 :: SDoc
msg1 = case TypeOrKind
level of
KindLevel
| Just th :: SDoc
th <- Maybe SDoc
maybe_thing
-> SDoc -> SDoc
msg5 SDoc
th
_ | Bool -> Bool
not (Type
act Type -> Type -> Bool
`pickyEqType` Type
exp)
-> Type -> Type -> CtOrigin -> SDoc -> SDoc
pprWithExplicitKindsWhenMismatch Type
ty1 Type
ty2 CtOrigin
ct (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text "Expected" SDoc -> SDoc -> SDoc
<+> SDoc
sort SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp
, String -> SDoc
text " Actual" SDoc -> SDoc -> SDoc
<+> SDoc
sort SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
act
, if Bool
printExpanded then SDoc
expandedTys else SDoc
empty ]
| Bool
otherwise
-> SDoc
empty
thing_msg :: Bool -> SDoc
thing_msg = case Maybe SDoc
maybe_thing of
Just thing :: SDoc
thing -> \_ -> SDoc -> SDoc
quotes SDoc
thing SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is"
Nothing -> \vowel :: Bool
vowel -> String -> SDoc
text "got a" SDoc -> SDoc -> SDoc
<>
if Bool
vowel then Char -> SDoc
char 'n' else SDoc
empty
msg2 :: SDoc
msg2 = [SDoc] -> SDoc
sep [ String -> SDoc
text "Expecting a lifted type, but"
, Bool -> SDoc
thing_msg Bool
True, String -> SDoc
text "unlifted" ]
msg3 :: SDoc
msg3 = [SDoc] -> SDoc
sep [ String -> SDoc
text "Expecting an unlifted type, but"
, Bool -> SDoc
thing_msg Bool
False, String -> SDoc
text "lifted" ]
msg4 :: SDoc
msg4 = SDoc
maybe_num_args_msg SDoc -> SDoc -> SDoc
$$
[SDoc] -> SDoc
sep [ String -> SDoc
text "Expected a type, but"
, SDoc -> (SDoc -> SDoc) -> Maybe SDoc -> SDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> SDoc
text "found something with kind")
(\thing :: SDoc
thing -> SDoc -> SDoc
quotes SDoc
thing SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "has kind")
Maybe SDoc
maybe_thing
, SDoc -> SDoc
quotes (Type -> SDoc
pprWithTYPE Type
act) ]
msg5 :: SDoc -> SDoc
msg5 th :: SDoc
th = Type -> Type -> CtOrigin -> SDoc -> SDoc
pprWithExplicitKindsWhenMismatch Type
ty1 Type
ty2 CtOrigin
ct (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Expected" SDoc -> SDoc -> SDoc
<+> SDoc
kind_desc SDoc -> SDoc -> SDoc
<> SDoc
comma)
2 (String -> SDoc
text "but" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes SDoc
th SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "has kind" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
act))
where
kind_desc :: SDoc
kind_desc | Type -> Bool
tcIsConstraintKind Type
exp = String -> SDoc
text "a constraint"
| Just arg :: Type
arg <- HasDebugCallStack => Type -> Maybe Type
Type -> Maybe Type
kindRep_maybe Type
exp
, Type -> Bool
tcIsTyVarTy Type
arg = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PrintExplicitRuntimeReps DynFlags
dflags
then String -> SDoc
text "kind" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp)
else String -> SDoc
text "a type"
| Bool
otherwise = String -> SDoc
text "kind" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp)
num_args_msg :: Maybe SDoc
num_args_msg = case TypeOrKind
level of
KindLevel
| Bool -> Bool
not (Type -> Bool
isMetaTyVarTy Type
exp) Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
isMetaTyVarTy Type
act)
-> let n_act :: Int
n_act = Type -> Int
count_args Type
act
n_exp :: Int
n_exp = Type -> Int
count_args Type
exp in
case Int
n_act Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n_exp of
n :: Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
, Just thing :: SDoc
thing <- Maybe SDoc
maybe_thing
-> SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "Expecting" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
speakN (Int -> Int
forall a. Num a => a -> a
abs Int
n) SDoc -> SDoc -> SDoc
<+>
SDoc
more SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes SDoc
thing
where
more :: SDoc
more
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 = String -> SDoc
text "more argument to"
| Bool
otherwise = String -> SDoc
text "more arguments to"
_ -> Maybe SDoc
forall a. Maybe a
Nothing
_ -> Maybe SDoc
forall a. Maybe a
Nothing
maybe_num_args_msg :: SDoc
maybe_num_args_msg = case Maybe SDoc
num_args_msg of
Nothing -> SDoc
empty
Just m :: SDoc
m -> SDoc
m
count_args :: Type -> Int
count_args ty :: Type
ty = (TyCoBinder -> Bool) -> [TyCoBinder] -> Int
forall a. (a -> Bool) -> [a] -> Int
count TyCoBinder -> Bool
isVisibleBinder ([TyCoBinder] -> Int) -> [TyCoBinder] -> Int
forall a b. (a -> b) -> a -> b
$ ([TyCoBinder], Type) -> [TyCoBinder]
forall a b. (a, b) -> a
fst (([TyCoBinder], Type) -> [TyCoBinder])
-> ([TyCoBinder], Type) -> [TyCoBinder]
forall a b. (a -> b) -> a -> b
$ Type -> ([TyCoBinder], Type)
splitPiTys Type
ty
expandedTys :: SDoc
expandedTys =
Bool -> SDoc -> SDoc
ppUnless (Type
expTy1 Type -> Type -> Bool
`pickyEqType` Type
exp Bool -> Bool -> Bool
&& Type
expTy2 Type -> Type -> Bool
`pickyEqType` Type
act) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text "Type synonyms expanded:"
, String -> SDoc
text "Expected type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
expTy1
, String -> SDoc
text " Actual type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
expTy2
]
(expTy1 :: Type
expTy1, expTy2 :: Type
expTy2) = Type -> Type -> (Type, Type)
expandSynonymsToMatch Type
exp Type
act
mkExpectedActualMsg _ _ _ _ _ = String -> (Bool, Maybe SwapFlag, SDoc)
forall a. String -> a
panic "mkExpectedAcutalMsg"
expandSynonymsToMatch :: Type -> Type -> (Type, Type)
expandSynonymsToMatch :: Type -> Type -> (Type, Type)
expandSynonymsToMatch ty1 :: Type
ty1 ty2 :: Type
ty2 = (Type
ty1_ret, Type
ty2_ret)
where
(ty1_ret :: Type
ty1_ret, ty2_ret :: Type
ty2_ret) = Type -> Type -> (Type, Type)
go Type
ty1 Type
ty2
go :: Type -> Type -> (Type, Type)
go :: Type -> Type -> (Type, Type)
go t1 :: Type
t1 t2 :: Type
t2
| Type
t1 Type -> Type -> Bool
`pickyEqType` Type
t2 =
(Type
t1, Type
t2)
go (TyConApp tc1 :: TyCon
tc1 tys1 :: [Type]
tys1) (TyConApp tc2 :: TyCon
tc2 tys2 :: [Type]
tys2)
| TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2 =
let (tys1' :: [Type]
tys1', tys2' :: [Type]
tys2') =
[(Type, Type)] -> ([Type], [Type])
forall a b. [(a, b)] -> ([a], [b])
unzip ((Type -> Type -> (Type, Type))
-> [Type] -> [Type] -> [(Type, Type)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ty1 :: Type
ty1 ty2 :: Type
ty2 -> Type -> Type -> (Type, Type)
go Type
ty1 Type
ty2) [Type]
tys1 [Type]
tys2)
in (TyCon -> [Type] -> Type
TyConApp TyCon
tc1 [Type]
tys1', TyCon -> [Type] -> Type
TyConApp TyCon
tc2 [Type]
tys2')
go (AppTy t1_1 :: Type
t1_1 t1_2 :: Type
t1_2) (AppTy t2_1 :: Type
t2_1 t2_2 :: Type
t2_2) =
let (t1_1' :: Type
t1_1', t2_1' :: Type
t2_1') = Type -> Type -> (Type, Type)
go Type
t1_1 Type
t2_1
(t1_2' :: Type
t1_2', t2_2' :: Type
t2_2') = Type -> Type -> (Type, Type)
go Type
t1_2 Type
t2_2
in (Type -> Type -> Type
mkAppTy Type
t1_1' Type
t1_2', Type -> Type -> Type
mkAppTy Type
t2_1' Type
t2_2')
go (FunTy t1_1 :: Type
t1_1 t1_2 :: Type
t1_2) (FunTy t2_1 :: Type
t2_1 t2_2 :: Type
t2_2) =
let (t1_1' :: Type
t1_1', t2_1' :: Type
t2_1') = Type -> Type -> (Type, Type)
go Type
t1_1 Type
t2_1
(t1_2' :: Type
t1_2', t2_2' :: Type
t2_2') = Type -> Type -> (Type, Type)
go Type
t1_2 Type
t2_2
in (Type -> Type -> Type
mkFunTy Type
t1_1' Type
t1_2', Type -> Type -> Type
mkFunTy Type
t2_1' Type
t2_2')
go (ForAllTy b1 :: TyCoVarBinder
b1 t1 :: Type
t1) (ForAllTy b2 :: TyCoVarBinder
b2 t2 :: Type
t2) =
let (t1' :: Type
t1', t2' :: Type
t2') = Type -> Type -> (Type, Type)
go Type
t1 Type
t2
in (TyCoVarBinder -> Type -> Type
ForAllTy TyCoVarBinder
b1 Type
t1', TyCoVarBinder -> Type -> Type
ForAllTy TyCoVarBinder
b2 Type
t2')
go (CastTy ty1 :: Type
ty1 _) ty2 :: Type
ty2 = Type -> Type -> (Type, Type)
go Type
ty1 Type
ty2
go ty1 :: Type
ty1 (CastTy ty2 :: Type
ty2 _) = Type -> Type -> (Type, Type)
go Type
ty1 Type
ty2
go t1 :: Type
t1 t2 :: Type
t2 =
let
t1_exp_tys :: [Type]
t1_exp_tys = Type
t1 Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
tyExpansions Type
t1
t2_exp_tys :: [Type]
t2_exp_tys = Type
t2 Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
tyExpansions Type
t2
t1_exps :: Int
t1_exps = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
t1_exp_tys
t2_exps :: Int
t2_exps = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
t2_exp_tys
dif :: Int
dif = Int -> Int
forall a. Num a => a -> a
abs (Int
t1_exps Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
t2_exps)
in
[(Type, Type)] -> (Type, Type)