module GHC.Tc.Types.CtLoc (
CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin,
ctLocTypeOrKind_maybe, toInvisibleLoc,
ctLocDepth, bumpCtLocDepth, isGivenLoc, mkGivenLoc, mkKindEqLoc,
setCtLocOrigin, updateCtLocOrigin, setCtLocEnv, setCtLocSpan,
pprCtLoc, adjustCtLoc, adjustCtLocTyConBinder,
CtLocEnv(..),
getCtLocEnvLoc, setCtLocEnvLoc, setCtLocRealLoc,
getCtLocEnvLvl, setCtLocEnvLvl,
ctLocEnvInGeneratedCode,
SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth,
bumpSubGoalDepth, subGoalDepthExceeded
) where
import GHC.Prelude
import GHC.Tc.Types.BasicTypes
import GHC.Tc.Types.ErrCtxt
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType
import GHC.Types.SrcLoc
import GHC.Types.Name.Reader
import GHC.Types.Basic( IntWithInf, mkIntWithInf, TypeOrKind(..) )
import GHC.Core.TyCon( TyConBinder, isVisibleTyConBinder, isNamedTyConBinder )
import GHC.Utils.Outputable
newtype SubGoalDepth = SubGoalDepth Int
deriving (SubGoalDepth -> SubGoalDepth -> Bool
(SubGoalDepth -> SubGoalDepth -> Bool)
-> (SubGoalDepth -> SubGoalDepth -> Bool) -> Eq SubGoalDepth
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SubGoalDepth -> SubGoalDepth -> Bool
== :: SubGoalDepth -> SubGoalDepth -> Bool
$c/= :: SubGoalDepth -> SubGoalDepth -> Bool
/= :: SubGoalDepth -> SubGoalDepth -> Bool
Eq, Eq SubGoalDepth
Eq SubGoalDepth =>
(SubGoalDepth -> SubGoalDepth -> Ordering)
-> (SubGoalDepth -> SubGoalDepth -> Bool)
-> (SubGoalDepth -> SubGoalDepth -> Bool)
-> (SubGoalDepth -> SubGoalDepth -> Bool)
-> (SubGoalDepth -> SubGoalDepth -> Bool)
-> (SubGoalDepth -> SubGoalDepth -> SubGoalDepth)
-> (SubGoalDepth -> SubGoalDepth -> SubGoalDepth)
-> Ord SubGoalDepth
SubGoalDepth -> SubGoalDepth -> Bool
SubGoalDepth -> SubGoalDepth -> Ordering
SubGoalDepth -> SubGoalDepth -> SubGoalDepth
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SubGoalDepth -> SubGoalDepth -> Ordering
compare :: SubGoalDepth -> SubGoalDepth -> Ordering
$c< :: SubGoalDepth -> SubGoalDepth -> Bool
< :: SubGoalDepth -> SubGoalDepth -> Bool
$c<= :: SubGoalDepth -> SubGoalDepth -> Bool
<= :: SubGoalDepth -> SubGoalDepth -> Bool
$c> :: SubGoalDepth -> SubGoalDepth -> Bool
> :: SubGoalDepth -> SubGoalDepth -> Bool
$c>= :: SubGoalDepth -> SubGoalDepth -> Bool
>= :: SubGoalDepth -> SubGoalDepth -> Bool
$cmax :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth
max :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth
$cmin :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth
min :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth
Ord, SubGoalDepth -> SDoc
(SubGoalDepth -> SDoc) -> Outputable SubGoalDepth
forall a. (a -> SDoc) -> Outputable a
$cppr :: SubGoalDepth -> SDoc
ppr :: SubGoalDepth -> SDoc
Outputable)
initialSubGoalDepth :: SubGoalDepth
initialSubGoalDepth :: SubGoalDepth
initialSubGoalDepth = Int -> SubGoalDepth
SubGoalDepth Int
0
bumpSubGoalDepth :: SubGoalDepth -> SubGoalDepth
bumpSubGoalDepth :: SubGoalDepth -> SubGoalDepth
bumpSubGoalDepth (SubGoalDepth Int
n) = Int -> SubGoalDepth
SubGoalDepth (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
maxSubGoalDepth :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth
maxSubGoalDepth :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth
maxSubGoalDepth (SubGoalDepth Int
n) (SubGoalDepth Int
m) = Int -> SubGoalDepth
SubGoalDepth (Int
n Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` Int
m)
subGoalDepthExceeded :: IntWithInf -> SubGoalDepth -> Bool
subGoalDepthExceeded :: IntWithInf -> SubGoalDepth -> Bool
subGoalDepthExceeded IntWithInf
reductionDepth (SubGoalDepth Int
d)
= Int -> IntWithInf
mkIntWithInf Int
d IntWithInf -> IntWithInf -> Bool
forall a. Ord a => a -> a -> Bool
> IntWithInf
reductionDepth
data CtLoc = CtLoc { CtLoc -> CtOrigin
ctl_origin :: CtOrigin
, CtLoc -> CtLocEnv
ctl_env :: CtLocEnv
, CtLoc -> Maybe TypeOrKind
ctl_t_or_k :: Maybe TypeOrKind
, CtLoc -> SubGoalDepth
ctl_depth :: !SubGoalDepth }
mkKindEqLoc :: TcType -> TcType
-> CtLoc -> CtLoc
mkKindEqLoc :: TcType -> TcType -> CtLoc -> CtLoc
mkKindEqLoc TcType
s1 TcType
s2 CtLoc
ctloc
| CtLoc { ctl_t_or_k :: CtLoc -> Maybe TypeOrKind
ctl_t_or_k = Maybe TypeOrKind
t_or_k, ctl_origin :: CtLoc -> CtOrigin
ctl_origin = CtOrigin
origin } <- CtLoc
ctloc
= CtLoc
ctloc { ctl_origin = KindEqOrigin s1 s2 origin t_or_k
, ctl_t_or_k = Just KindLevel }
adjustCtLocTyConBinder :: TyConBinder -> CtLoc -> CtLoc
adjustCtLocTyConBinder :: TyConBinder -> CtLoc -> CtLoc
adjustCtLocTyConBinder TyConBinder
tc_bndr CtLoc
loc
= Bool -> Bool -> CtLoc -> CtLoc
adjustCtLoc Bool
is_vis Bool
is_kind CtLoc
loc
where
is_vis :: Bool
is_vis = TyConBinder -> Bool
forall tv. VarBndr tv TyConBndrVis -> Bool
isVisibleTyConBinder TyConBinder
tc_bndr
is_kind :: Bool
is_kind = TyConBinder -> Bool
isNamedTyConBinder TyConBinder
tc_bndr
adjustCtLoc :: Bool
-> Bool
-> CtLoc -> CtLoc
adjustCtLoc :: Bool -> Bool -> CtLoc -> CtLoc
adjustCtLoc Bool
is_vis Bool
is_kind CtLoc
loc
= CtLoc
loc2
where
loc1 :: CtLoc
loc1 | Bool
is_kind = CtLoc -> CtLoc
toKindLoc CtLoc
loc
| Bool
otherwise = CtLoc
loc
loc2 :: CtLoc
loc2 | Bool
is_vis = CtLoc
loc1
| Bool
otherwise = CtLoc -> CtLoc
toInvisibleLoc CtLoc
loc1
toKindLoc :: CtLoc -> CtLoc
toKindLoc :: CtLoc -> CtLoc
toKindLoc CtLoc
loc = CtLoc
loc { ctl_t_or_k = Just KindLevel }
toInvisibleLoc :: CtLoc -> CtLoc
toInvisibleLoc :: CtLoc -> CtLoc
toInvisibleLoc CtLoc
loc = CtLoc -> (CtOrigin -> CtOrigin) -> CtLoc
updateCtLocOrigin CtLoc
loc CtOrigin -> CtOrigin
toInvisibleOrigin
mkGivenLoc :: TcLevel -> SkolemInfoAnon -> CtLocEnv -> CtLoc
mkGivenLoc :: TcLevel -> SkolemInfoAnon -> CtLocEnv -> CtLoc
mkGivenLoc TcLevel
tclvl SkolemInfoAnon
skol_info CtLocEnv
env
= CtLoc { ctl_origin :: CtOrigin
ctl_origin = SkolemInfoAnon -> CtOrigin
GivenOrigin SkolemInfoAnon
skol_info
, ctl_env :: CtLocEnv
ctl_env = CtLocEnv -> TcLevel -> CtLocEnv
setCtLocEnvLvl CtLocEnv
env TcLevel
tclvl
, ctl_t_or_k :: Maybe TypeOrKind
ctl_t_or_k = Maybe TypeOrKind
forall a. Maybe a
Nothing
, ctl_depth :: SubGoalDepth
ctl_depth = SubGoalDepth
initialSubGoalDepth }
ctLocEnv :: CtLoc -> CtLocEnv
ctLocEnv :: CtLoc -> CtLocEnv
ctLocEnv = CtLoc -> CtLocEnv
ctl_env
ctLocLevel :: CtLoc -> TcLevel
ctLocLevel :: CtLoc -> TcLevel
ctLocLevel CtLoc
loc = CtLocEnv -> TcLevel
getCtLocEnvLvl (CtLoc -> CtLocEnv
ctLocEnv CtLoc
loc)
ctLocDepth :: CtLoc -> SubGoalDepth
ctLocDepth :: CtLoc -> SubGoalDepth
ctLocDepth = CtLoc -> SubGoalDepth
ctl_depth
ctLocOrigin :: CtLoc -> CtOrigin
ctLocOrigin :: CtLoc -> CtOrigin
ctLocOrigin = CtLoc -> CtOrigin
ctl_origin
ctLocSpan :: CtLoc -> RealSrcSpan
ctLocSpan :: CtLoc -> RealSrcSpan
ctLocSpan (CtLoc { ctl_env :: CtLoc -> CtLocEnv
ctl_env = CtLocEnv
lcl}) = CtLocEnv -> RealSrcSpan
getCtLocEnvLoc CtLocEnv
lcl
ctLocTypeOrKind_maybe :: CtLoc -> Maybe TypeOrKind
ctLocTypeOrKind_maybe :: CtLoc -> Maybe TypeOrKind
ctLocTypeOrKind_maybe = CtLoc -> Maybe TypeOrKind
ctl_t_or_k
setCtLocSpan :: CtLoc -> RealSrcSpan -> CtLoc
setCtLocSpan :: CtLoc -> RealSrcSpan -> CtLoc
setCtLocSpan ctl :: CtLoc
ctl@(CtLoc { ctl_env :: CtLoc -> CtLocEnv
ctl_env = CtLocEnv
lcl }) RealSrcSpan
loc = CtLoc -> CtLocEnv -> CtLoc
setCtLocEnv CtLoc
ctl (CtLocEnv -> RealSrcSpan -> CtLocEnv
setCtLocRealLoc CtLocEnv
lcl RealSrcSpan
loc)
bumpCtLocDepth :: CtLoc -> CtLoc
bumpCtLocDepth :: CtLoc -> CtLoc
bumpCtLocDepth loc :: CtLoc
loc@(CtLoc { ctl_depth :: CtLoc -> SubGoalDepth
ctl_depth = SubGoalDepth
d }) = CtLoc
loc { ctl_depth = bumpSubGoalDepth d }
setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc
setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc
setCtLocOrigin CtLoc
ctl CtOrigin
orig = CtLoc
ctl { ctl_origin = orig }
updateCtLocOrigin :: CtLoc -> (CtOrigin -> CtOrigin) -> CtLoc
updateCtLocOrigin :: CtLoc -> (CtOrigin -> CtOrigin) -> CtLoc
updateCtLocOrigin ctl :: CtLoc
ctl@(CtLoc { ctl_origin :: CtLoc -> CtOrigin
ctl_origin = CtOrigin
orig }) CtOrigin -> CtOrigin
upd
= CtLoc
ctl { ctl_origin = upd orig }
setCtLocEnv :: CtLoc -> CtLocEnv -> CtLoc
setCtLocEnv :: CtLoc -> CtLocEnv -> CtLoc
setCtLocEnv CtLoc
ctl CtLocEnv
env = CtLoc
ctl { ctl_env = env }
isGivenLoc :: CtLoc -> Bool
isGivenLoc :: CtLoc -> Bool
isGivenLoc CtLoc
loc = CtOrigin -> Bool
isGivenOrigin (CtLoc -> CtOrigin
ctLocOrigin CtLoc
loc)
pprCtLoc :: CtLoc -> SDoc
pprCtLoc :: CtLoc -> SDoc
pprCtLoc (CtLoc { ctl_origin :: CtLoc -> CtOrigin
ctl_origin = CtOrigin
o, ctl_env :: CtLoc -> CtLocEnv
ctl_env = CtLocEnv
lcl})
= [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ CtOrigin -> SDoc
pprCtOrigin CtOrigin
o
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"at" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CtLocEnv -> RealSrcSpan
getCtLocEnvLoc CtLocEnv
lcl)]
data CtLocEnv = CtLocEnv { CtLocEnv -> [ErrCtxt]
ctl_ctxt :: ![ErrCtxt]
, CtLocEnv -> RealSrcSpan
ctl_loc :: !RealSrcSpan
, CtLocEnv -> TcBinderStack
ctl_bndrs :: !TcBinderStack
, CtLocEnv -> TcLevel
ctl_tclvl :: !TcLevel
, CtLocEnv -> Bool
ctl_in_gen_code :: !Bool
, CtLocEnv -> LocalRdrEnv
ctl_rdr :: !LocalRdrEnv }
getCtLocEnvLoc :: CtLocEnv -> RealSrcSpan
getCtLocEnvLoc :: CtLocEnv -> RealSrcSpan
getCtLocEnvLoc = CtLocEnv -> RealSrcSpan
ctl_loc
getCtLocEnvLvl :: CtLocEnv -> TcLevel
getCtLocEnvLvl :: CtLocEnv -> TcLevel
getCtLocEnvLvl = CtLocEnv -> TcLevel
ctl_tclvl
setCtLocEnvLvl :: CtLocEnv -> TcLevel -> CtLocEnv
setCtLocEnvLvl :: CtLocEnv -> TcLevel -> CtLocEnv
setCtLocEnvLvl CtLocEnv
env TcLevel
lvl = CtLocEnv
env { ctl_tclvl = lvl }
setCtLocRealLoc :: CtLocEnv -> RealSrcSpan -> CtLocEnv
setCtLocRealLoc :: CtLocEnv -> RealSrcSpan -> CtLocEnv
setCtLocRealLoc CtLocEnv
env RealSrcSpan
ss = CtLocEnv
env { ctl_loc = ss }
setCtLocEnvLoc :: CtLocEnv -> SrcSpan -> CtLocEnv
setCtLocEnvLoc :: CtLocEnv -> SrcSpan -> CtLocEnv
setCtLocEnvLoc CtLocEnv
env (RealSrcSpan RealSrcSpan
loc Maybe BufSpan
_)
= CtLocEnv
env { ctl_loc = loc, ctl_in_gen_code = False }
setCtLocEnvLoc CtLocEnv
env loc :: SrcSpan
loc@(UnhelpfulSpan UnhelpfulSpanReason
_)
| SrcSpan -> Bool
isGeneratedSrcSpan SrcSpan
loc
= CtLocEnv
env { ctl_in_gen_code = True }
| Bool
otherwise
= CtLocEnv
env
ctLocEnvInGeneratedCode :: CtLocEnv -> Bool
ctLocEnvInGeneratedCode :: CtLocEnv -> Bool
ctLocEnvInGeneratedCode = CtLocEnv -> Bool
ctl_in_gen_code