{-# LANGUAGE
    ViewPatterns
  , OverloadedStrings
  , LambdaCase
  , TupleSections
  , ScopedTypeVariables
  , TypeApplications
  , RecordWildCards
#-}

module Control.Monad.CheckedExcept.Plugin.Defaulting
  ( mkDefaultingPlugin
  ) where

import GHC.Plugins hiding ((<>), DefaultingPlugin)
import GHC.Tc.Types (DefaultingPlugin (..), DefaultingProposal (..))
import GHC.Tc.Types.Constraint (WantedConstraints (..), Ct, Implication (..), ctPred)
import qualified GHC.Tc.Plugin as TC
import GHC.Tc.Plugin (tcPluginTrace)
import GHC.Tc.Utils.TcType (eqType, isMetaTyVarTy)
import GHC.Core.Predicate (getClassPredTys_maybe)
import GHC.Core.Class (Class, classKey)
import GHC.Types.Unique (hasKey)
import GHC.Builtin.Names (consDataConKey)
import GHC.Data.Bag (bagToList)
import Data.List (nubBy)
import qualified GHC.Driver.Plugins as DP

data Environment = Environment
  { Environment -> Class
containsClass :: Class
  , Environment -> Class
elemClass :: Class
  , Environment -> TyCon
nubTyFam :: TyCon
  , Environment -> Bool
verbose :: Bool
  }

data MetaBounds = MetaBounds
  { MetaBounds -> [Type]
lowerBounds :: [Type]
  , MetaBounds -> [Type]
upperBounds :: [Type]
  , MetaBounds -> [Ct]
proposalCts :: [Ct]
  }

type BoundsMap = [(TcTyVar, MetaBounds)]

mkDefaultingPlugin :: DP.DefaultingPlugin
mkDefaultingPlugin :: DefaultingPlugin
mkDefaultingPlugin [CommandLineOption]
opts = DefaultingPlugin
checkedExceptDefaultingPlugin [CommandLineOption]
opts

checkedExceptDefaultingPlugin :: DP.DefaultingPlugin
checkedExceptDefaultingPlugin :: DefaultingPlugin
checkedExceptDefaultingPlugin [CommandLineOption]
opts = DefaultingPlugin -> Maybe DefaultingPlugin
forall a. a -> Maybe a
Just (DefaultingPlugin -> Maybe DefaultingPlugin)
-> DefaultingPlugin -> Maybe DefaultingPlugin
forall a b. (a -> b) -> a -> b
$ DefaultingPlugin
  { dePluginInit :: TcPluginM Environment
dePluginInit = do
      checkedExceptMod <- TcPluginM Module
lookupCheckedExceptMod
      containsClass <- lookupClass checkedExceptMod "Contains"
      elemClass <- lookupClass checkedExceptMod "Elem"
      nubTyFam <- lookupTyFam checkedExceptMod "Nub"
      let verbose = CommandLineOption
"verbose" CommandLineOption -> [CommandLineOption] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CommandLineOption]
opts
      pure Environment {..}
  , dePluginRun :: Environment -> FillDefaulting
dePluginRun = Environment -> FillDefaulting
runDefaulting
  , dePluginStop :: Environment -> TcPluginM ()
dePluginStop = TcPluginM () -> Environment -> TcPluginM ()
forall a b. a -> b -> a
const (TcPluginM () -> Environment -> TcPluginM ())
-> TcPluginM () -> Environment -> TcPluginM ()
forall a b. (a -> b) -> a -> b
$ () -> TcPluginM ()
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  }

lookupCheckedExceptMod :: TC.TcPluginM Module
lookupCheckedExceptMod :: TcPluginM Module
lookupCheckedExceptMod = do
  findResult <- ModuleName -> PkgQual -> TcPluginM FindResult
TC.findImportedModule (CommandLineOption -> ModuleName
mkModuleName CommandLineOption
"Control.Monad.CheckedExcept") PkgQual
NoPkgQual
  case findResult of
    TC.Found ModLocation
_ Module
modCE -> Module -> TcPluginM Module
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Module
modCE
    FindResult
_ -> CommandLineOption -> TcPluginM Module
forall a. HasCallStack => CommandLineOption -> TcPluginM a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
CommandLineOption -> m a
fail CommandLineOption
"checked-exceptions: could not find Control.Monad.CheckedExcept"

lookupClass :: Module -> String -> TC.TcPluginM Class
lookupClass :: Module -> CommandLineOption -> TcPluginM Class
lookupClass Module
modCE CommandLineOption
name = do
  name' <- Module -> OccName -> TcPluginM Name
TC.lookupOrig Module
modCE (CommandLineOption -> OccName
mkClsOcc CommandLineOption
name)
  TC.tcLookupClass name'

lookupTyFam :: Module -> String -> TC.TcPluginM TyCon
lookupTyFam :: Module -> CommandLineOption -> TcPluginM TyCon
lookupTyFam Module
modCE CommandLineOption
name = do
  name' <- Module -> OccName -> TcPluginM Name
TC.lookupOrig Module
modCE (CommandLineOption -> OccName
mkTcOcc CommandLineOption
name)
  TC.tcLookupTyCon name'

runDefaulting :: Environment -> WantedConstraints -> TC.TcPluginM [DefaultingProposal]
runDefaulting :: Environment -> FillDefaulting
runDefaulting env :: Environment
env@Environment {Bool
TyCon
Class
containsClass :: Environment -> Class
elemClass :: Environment -> Class
nubTyFam :: Environment -> TyCon
verbose :: Environment -> Bool
containsClass :: Class
elemClass :: Class
nubTyFam :: TyCon
verbose :: Bool
..} WantedConstraints
wc = do
  let cts :: [Ct]
cts = WantedConstraints -> [Ct]
gatherCts WantedConstraints
wc
      givens :: [TcTyVar]
givens = WantedConstraints -> [TcTyVar]
gatherGivens WantedConstraints
wc
      bounds :: BoundsMap
bounds = (TcTyVar -> BoundsMap -> BoundsMap)
-> BoundsMap -> [TcTyVar] -> BoundsMap
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Environment -> TcTyVar -> BoundsMap -> BoundsMap
insertGiven Environment
env) ((Ct -> BoundsMap -> BoundsMap) -> BoundsMap -> [Ct] -> BoundsMap
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Environment -> Ct -> BoundsMap -> BoundsMap
insertCt Environment
env) [] [Ct]
cts) [TcTyVar]
givens
  proposals <- ((TcTyVar, MetaBounds) -> TcPluginM DefaultingProposal)
-> BoundsMap -> TcPluginM [DefaultingProposal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((TcTyVar -> MetaBounds -> TcPluginM DefaultingProposal)
-> (TcTyVar, MetaBounds) -> TcPluginM DefaultingProposal
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Environment
-> TcTyVar -> MetaBounds -> TcPluginM DefaultingProposal
mkProposal Environment
env)) BoundsMap
bounds
  when verbose $ tcTrace "proposals" (length proposals)
  pure proposals

gatherCts :: WantedConstraints -> [Ct]
gatherCts :: WantedConstraints -> [Ct]
gatherCts WantedConstraints
wc =
  Bag Ct -> [Ct]
forall a. Bag a -> [a]
bagToList (WantedConstraints -> Bag Ct
wc_simple WantedConstraints
wc) [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ (Implication -> [Ct]) -> [Implication] -> [Ct]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Implication -> [Ct]
gatherImplCts (Bag Implication -> [Implication]
forall a. Bag a -> [a]
bagToList (WantedConstraints -> Bag Implication
wc_impl WantedConstraints
wc))

gatherImplCts :: Implication -> [Ct]
gatherImplCts :: Implication -> [Ct]
gatherImplCts Implication
implic = WantedConstraints -> [Ct]
gatherCts (Implication -> WantedConstraints
ic_wanted Implication
implic)

-- | Implication givens can mention the same exception-list metavariables as

-- wanteds in nested contexts.

gatherGivens :: WantedConstraints -> [EvVar]
gatherGivens :: WantedConstraints -> [TcTyVar]
gatherGivens WantedConstraints
wc = (Implication -> [TcTyVar]) -> [Implication] -> [TcTyVar]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Implication -> [TcTyVar]
gatherImplGivens (Bag Implication -> [Implication]
forall a. Bag a -> [a]
bagToList (WantedConstraints -> Bag Implication
wc_impl WantedConstraints
wc))

gatherImplGivens :: Implication -> [EvVar]
gatherImplGivens :: Implication -> [TcTyVar]
gatherImplGivens Implication
implic =
  Implication -> [TcTyVar]
ic_given Implication
implic [TcTyVar] -> [TcTyVar] -> [TcTyVar]
forall a. [a] -> [a] -> [a]
++ (Implication -> [TcTyVar]) -> [Implication] -> [TcTyVar]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Implication -> [TcTyVar]
gatherImplGivens (Bag Implication -> [Implication]
forall a. Bag a -> [a]
bagToList (WantedConstraints -> Bag Implication
wc_impl (Implication -> WantedConstraints
ic_wanted Implication
implic)))

insertCt :: Environment -> Ct -> BoundsMap -> BoundsMap
insertCt :: Environment -> Ct -> BoundsMap -> BoundsMap
insertCt Environment
env Ct
ct BoundsMap
acc = Environment -> Maybe Ct -> Type -> BoundsMap -> BoundsMap
insertFromPred Environment
env (Ct -> Maybe Ct
forall a. a -> Maybe a
Just Ct
ct) (Ct -> Type
ctPred Ct
ct) BoundsMap
acc

insertGiven :: Environment -> EvVar -> BoundsMap -> BoundsMap
insertGiven :: Environment -> TcTyVar -> BoundsMap -> BoundsMap
insertGiven Environment
env TcTyVar
ev BoundsMap
acc = Environment -> Maybe Ct -> Type -> BoundsMap -> BoundsMap
insertFromPred Environment
env Maybe Ct
forall a. Maybe a
Nothing (TcTyVar -> Type
varType TcTyVar
ev) BoundsMap
acc

insertFromPred :: Environment -> Maybe Ct -> Type -> BoundsMap -> BoundsMap
insertFromPred :: Environment -> Maybe Ct -> Type -> BoundsMap -> BoundsMap
insertFromPred Environment {Class
containsClass :: Environment -> Class
containsClass :: Class
containsClass, Class
elemClass :: Environment -> Class
elemClass :: Class
elemClass} Maybe Ct
mct Type
classPred BoundsMap
acc =
  case Type -> Maybe (Class, [Type])
getClassPredTys_maybe Type
classPred of
    Just (Class
cls, [Type
es1, Type
es2]) ->
      if Class -> Unique
classKey Class
cls Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Class -> Unique
classKey Class
containsClass
        then (TcTyVar -> BoundsMap -> BoundsMap)
-> BoundsMap -> [TcTyVar] -> BoundsMap
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Maybe Ct -> Type -> Type -> TcTyVar -> BoundsMap -> BoundsMap
addContainsBound Maybe Ct
mct Type
es1 Type
es2) BoundsMap
acc (Type -> [TcTyVar]
metaListVars Type
es1 [TcTyVar] -> [TcTyVar] -> [TcTyVar]
forall a. [a] -> [a] -> [a]
++ Type -> [TcTyVar]
metaListVars Type
es2)
        else if Class -> Unique
classKey Class
cls Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Class -> Unique
classKey Class
elemClass
        then (TcTyVar -> BoundsMap -> BoundsMap)
-> BoundsMap -> [TcTyVar] -> BoundsMap
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Maybe Ct -> Type -> Type -> TcTyVar -> BoundsMap -> BoundsMap
addElemBound Maybe Ct
mct Type
es1 Type
es2) BoundsMap
acc (Type -> [TcTyVar]
metaListVars Type
es2)
        else BoundsMap
acc
    Maybe (Class, [Type])
_ -> BoundsMap
acc

lookupBounds :: TcTyVar -> BoundsMap -> MetaBounds
lookupBounds :: TcTyVar -> BoundsMap -> MetaBounds
lookupBounds TcTyVar
alpha BoundsMap
bounds =
  case TcTyVar -> BoundsMap -> Maybe MetaBounds
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TcTyVar
alpha BoundsMap
bounds of
    Just MetaBounds
b -> MetaBounds
b
    Maybe MetaBounds
Nothing -> [Type] -> [Type] -> [Ct] -> MetaBounds
MetaBounds [] [] []

upsertBounds :: TcTyVar -> MetaBounds -> BoundsMap -> BoundsMap
upsertBounds :: TcTyVar -> MetaBounds -> BoundsMap -> BoundsMap
upsertBounds TcTyVar
alpha MetaBounds
new BoundsMap
bounds =
  case ((TcTyVar, MetaBounds) -> Bool)
-> BoundsMap -> (BoundsMap, BoundsMap)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((TcTyVar -> TcTyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TcTyVar
alpha) (TcTyVar -> Bool)
-> ((TcTyVar, MetaBounds) -> TcTyVar)
-> (TcTyVar, MetaBounds)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TcTyVar, MetaBounds) -> TcTyVar
forall a b. (a, b) -> a
fst) BoundsMap
bounds of
    (BoundsMap
_, (TcTyVar
_, MetaBounds
old) : BoundsMap
rest) -> (TcTyVar
alpha, MetaBounds -> MetaBounds -> MetaBounds
mergeBounds MetaBounds
old MetaBounds
new) (TcTyVar, MetaBounds) -> BoundsMap -> BoundsMap
forall a. a -> [a] -> [a]
: BoundsMap
rest
    (BoundsMap
_, []) -> (TcTyVar
alpha, MetaBounds
new) (TcTyVar, MetaBounds) -> BoundsMap -> BoundsMap
forall a. a -> [a] -> [a]
: BoundsMap
bounds

mergeBounds :: MetaBounds -> MetaBounds -> MetaBounds
mergeBounds :: MetaBounds -> MetaBounds -> MetaBounds
mergeBounds MetaBounds
old MetaBounds
new =
  MetaBounds
    { lowerBounds :: [Type]
lowerBounds = MetaBounds -> [Type]
lowerBounds MetaBounds
old [Type] -> [Type] -> [Type]
forall a. Semigroup a => a -> a -> a
<> MetaBounds -> [Type]
lowerBounds MetaBounds
new
    , upperBounds :: [Type]
upperBounds = MetaBounds -> [Type]
upperBounds MetaBounds
old [Type] -> [Type] -> [Type]
forall a. Semigroup a => a -> a -> a
<> MetaBounds -> [Type]
upperBounds MetaBounds
new
    , proposalCts :: [Ct]
proposalCts = MetaBounds -> [Ct]
proposalCts MetaBounds
old [Ct] -> [Ct] -> [Ct]
forall a. Semigroup a => a -> a -> a
<> MetaBounds -> [Ct]
proposalCts MetaBounds
new
    }

addContainsBound :: Maybe Ct -> Type -> Type -> TcTyVar -> BoundsMap -> BoundsMap
addContainsBound :: Maybe Ct -> Type -> Type -> TcTyVar -> BoundsMap -> BoundsMap
addContainsBound Maybe Ct
mct Type
es1 Type
es2 TcTyVar
alpha BoundsMap
acc =
  let old :: MetaBounds
old = TcTyVar -> BoundsMap -> MetaBounds
lookupBounds TcTyVar
alpha BoundsMap
acc
      new :: MetaBounds
new =
        if Type -> Bool
isMetaTyVarTy Type
es1
          then MetaBounds
old {upperBounds = es2 : upperBounds old, proposalCts = maybeToList mct <> proposalCts old}
          else if Type -> Bool
isMetaTyVarTy Type
es2
            then MetaBounds
old {lowerBounds = es1 : lowerBounds old, proposalCts = maybeToList mct <> proposalCts old}
            else MetaBounds
old
  in TcTyVar -> MetaBounds -> BoundsMap -> BoundsMap
upsertBounds TcTyVar
alpha MetaBounds
new BoundsMap
acc

addElemBound :: Maybe Ct -> Type -> Type -> TcTyVar -> BoundsMap -> BoundsMap
addElemBound :: Maybe Ct -> Type -> Type -> TcTyVar -> BoundsMap -> BoundsMap
addElemBound Maybe Ct
mct Type
ty Type
_es TcTyVar
alpha BoundsMap
acc =
  let old :: MetaBounds
old = TcTyVar -> BoundsMap -> MetaBounds
lookupBounds TcTyVar
alpha BoundsMap
acc
      singletonLi :: Type
singletonLi = Type -> [Type] -> Type
mkPromotedListTy Type
tYPEKind [Type
ty]
      new :: MetaBounds
new = MetaBounds
old {lowerBounds = singletonLi : lowerBounds old, proposalCts = maybeToList mct <> proposalCts old}
  in TcTyVar -> MetaBounds -> BoundsMap -> BoundsMap
upsertBounds TcTyVar
alpha MetaBounds
new BoundsMap
acc

maybeToList :: Maybe a -> [a]
maybeToList :: forall a. Maybe a -> [a]
maybeToList = [a] -> (a -> [a]) -> Maybe a -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] a -> [a]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

metaListVars :: Type -> [TcTyVar]
metaListVars :: Type -> [TcTyVar]
metaListVars Type
ty =
  case Type -> Maybe TcTyVar
getTyVar_maybe Type
ty of
    Just TcTyVar
tv ->
      if Type -> Bool
isMetaTyVarTy Type
ty Bool -> Bool -> Bool
&& HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
eqType (TcTyVar -> Type
tyVarKind TcTyVar
tv) (Type -> [Type] -> Type
mkPromotedListTy Type
tYPEKind [])
        then [TcTyVar
tv]
        else []
    Maybe TcTyVar
_ -> []

mkProposal ::
  Environment ->
  TcTyVar ->
  MetaBounds ->
  TC.TcPluginM DefaultingProposal
mkProposal :: Environment
-> TcTyVar -> MetaBounds -> TcPluginM DefaultingProposal
mkProposal Environment {TyCon
nubTyFam :: Environment -> TyCon
nubTyFam :: TyCon
nubTyFam, Bool
verbose :: Environment -> Bool
verbose :: Bool
verbose} TcTyVar
alpha MetaBounds {[Type]
lowerBounds :: MetaBounds -> [Type]
lowerBounds :: [Type]
lowerBounds, [Type]
upperBounds :: MetaBounds -> [Type]
upperBounds :: [Type]
upperBounds, [Ct]
proposalCts :: MetaBounds -> [Ct]
proposalCts :: [Ct]
proposalCts} = do
  zonkedLower <- (Type -> TcPluginM Type) -> [Type] -> TcPluginM [Type]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Type -> TcPluginM Type
TC.zonkTcType [Type]
lowerBounds
  zonkedUpper <- traverse TC.zonkTcType upperBounds
  let lowerElems = (Type -> [Type]) -> [Type] -> [Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> [Type]
lowerBoundElems [Type]
zonkedLower
      emptyLower = Type -> [Type] -> Type
mkPromotedListTy Type
tYPEKind []
      unionLower = [Type] -> Type
uniquePromotedList [Type]
lowerElems
      nubLower = TyCon -> [Type] -> Type
mkTyConApp TyCon
nubTyFam [Type
unionLower]
      -- Only propose Nub union (not raw unionLower): an early non-nub default

      -- can fail the whole defaulting block before later bounds arrive.

      proposals =
        [ [(TcTyVar
alpha, Type
emptyLower)]
        , [(TcTyVar
alpha, Type
nubLower)]
        , [(TcTyVar
alpha, Type
ub) | Type
ub <- [Type]
zonkedUpper]
        ]
  when verbose $
    tcTrace "defaulting" (ppr alpha, ppr unionLower, length proposalCts)
  pure $
    DefaultingProposal
      { deProposals = proposals
      , deProposalCts = proposalCts
      }

uniquePromotedList :: [Type] -> Type
uniquePromotedList :: [Type] -> Type
uniquePromotedList [Type]
tys = Type -> [Type] -> Type
mkPromotedListTy Type
tYPEKind ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Bool) -> [Type] -> [Type]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
eqType [Type]
tys

-- | Peel list elements from a promoted list, or @[]@ when @ty@ is still an

-- unresolved metavar (the plugin is re-run as more constraints land).

lowerBoundElems :: Type -> [Type]
lowerBoundElems :: Type -> [Type]
lowerBoundElems Type
ty =
  case Type -> Maybe [Type]
extractMPromotedList Type
ty of
    Just [Type]
ts -> [Type]
ts
    Maybe [Type]
Nothing ->
      if Type -> Bool
isMetaTyVarTy Type
ty
        then []
        else case Type -> Maybe (TyCon, [Type], [Type])
splitTyConAppIgnoringKind Type
ty of
          Just (TyCon
tc, [Type]
_, [Type
t, Type
ts]) ->
            if TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
consDataConKey
              then Type
t Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
lowerBoundElems Type
ts
              else []
          Just (TyCon
tc, [Type]
_, []) ->
            if TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
nilDataConKey then [] else []
          Maybe (TyCon, [Type], [Type])
_ -> []

extractMPromotedList :: Type -> Maybe [Type]
extractMPromotedList :: Type -> Maybe [Type]
extractMPromotedList = Type -> Maybe [Type]
go
  where
    go :: Type -> Maybe [Type]
go Type
listTy =
      case Type -> Maybe (TyCon, [Type], [Type])
splitTyConAppIgnoringKind Type
listTy of
        Just (TyCon
tc, [Type]
_, [Type
t, Type
ts]) ->
          Bool -> Maybe [Type] -> Maybe [Type]
forall a. HasCallStack => Bool -> a -> a
assert (TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
consDataConKey) (Maybe [Type] -> Maybe [Type]) -> Maybe [Type] -> Maybe [Type]
forall a b. (a -> b) -> a -> b
$
            case Type -> Maybe [Type]
go Type
ts of
              Maybe [Type]
Nothing -> Maybe [Type]
forall a. Maybe a
Nothing
              Just [Type]
ts' -> [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just (Type
t Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
ts')
        Just (TyCon
tc, [Type]
_, []) ->
          Bool -> Maybe [Type] -> Maybe [Type]
forall a. HasCallStack => Bool -> a -> a
assert (TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
nilDataConKey) (Maybe [Type] -> Maybe [Type]) -> Maybe [Type] -> Maybe [Type]
forall a b. (a -> b) -> a -> b
$
            [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just []
        Maybe (TyCon, [Type], [Type])
_ -> Maybe [Type]
forall a. Maybe a
Nothing

splitTyConAppIgnoringKind :: Type -> Maybe (TyCon, [Type], [Type])
splitTyConAppIgnoringKind :: Type -> Maybe (TyCon, [Type], [Type])
splitTyConAppIgnoringKind Type
ty = do
  (tyCon, tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
  let (invisTys, visTys) = partitionInvisibleTypes tyCon tys
  pure (tyCon, invisTys, visTys)

tcTrace :: Outputable a => String -> a -> TC.TcPluginM ()
tcTrace :: forall a. Outputable a => CommandLineOption -> a -> TcPluginM ()
tcTrace CommandLineOption
label a
x =
  CommandLineOption -> SDoc -> TcPluginM ()
tcPluginTrace (CommandLineOption
"[checked-exceptions] " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. Semigroup a => a -> a -> a
<> CommandLineOption
label) (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
x)

when :: Applicative f => Bool -> f () -> f ()
when :: forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
p f ()
act = if Bool
p then f ()
act else () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()