{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

#if MIN_VERSION_ghc(9,0,0)
{-# LANGUAGE StandaloneKindSignatures #-}
#endif

{-|
Module: GHC.TcPlugin.API.Names

This module provides an /optional/ framework that facilitates name lookup
in type-checking plugins, using constrained traversals (similar to the
<https://hackage.haskell.org/package/barbies barbies library>).

See the 'ResolveNames' typeclass.

Before:

> data PluginDefs =
>   PluginDefs
>     { myTyCon           :: TyCon
>     , myClass           :: Class
>     , myPromotedDataCon :: TyCon
>     }
>
> findMyModule :: MonadTcPlugin m => m Module
> findMyModule = do
>   let modlName = mkModuleName "MyModule"
>   pkgQual    <- resolveImport      modlName Nothing
>   findResult <- findImportedModule modlName pkgQual
>   case findResult of
>     Found _ res -> pure res
>     _           -> error $ "MyPlugin: could not find any module named MyModule."
>
> pluginInit :: TcPluginM Init PluginDefs
> pluginInit = do
>   myModule <- findMyModule
>   myTyCon           <-                       tcLookupTyCon   =<< lookupOrig myModule ( mkTcOcc   "MyTyCon"   )
>   myClass           <-                       tcLookupClass   =<< lookupOrig myModule ( mkClsOcc  "MyClass"   )
>   myPromotedDataCon <- fmap promoteDataCon . tcLookupDataCon =<< lookupOrig myModule ( mkDataOcc "MyDataCon" )
>   pure ( PluginDefs { .. } )

After:

> data PluginDefsHKD n =
>   PluginDefs
>     { myTyCon            :: Wear n TyCon
>     , myClass            :: Wear n Class
>     , myPromotedDataCon  :: Wear n ( Promoted DataCon )
>     }
>   deriving stock Generic
>   deriving ResolveNames
>     via Generically1 PluginDefsHKD
>
> type PluginDefs = PluginDefsHKD Resolved
>
> pluginInit :: TcPluginM Init PluginDefs
> pluginInit = resolveNames pluginNames
>   where
>     pluginNames :: PluginDefsHKD Named
>     pluginNames =
>       PluginDefs
>         { myTyCon           = mkQualified "MyTyCon"
>         , myClass           = mkQualified "MyClass"
>         , myPromotedDataCon = mkQualified "MyDataCon"
>         }
>     mkQualified :: String -> QualifiedName thing
>     mkQualified str =
>       Qualified
>         { name    = str
>         , module' = mkModuleName "MyModule"
>         , package = Nothing
>         }

-}

module GHC.TcPlugin.API.Names
  ( ResolveNames, resolveNames
  , Wear, QualifiedName(..), NameResolution(..)
  , Promoted
  , Lookupable(..)

    -- * Re-export Generically1 for compatibility.

  , Generically1(..)
  ) where

-- base

import Prelude
  hiding ( lookup )
import Data.Coerce
  ( Coercible, coerce )
import Data.Kind
  ( Type, Constraint )
import GHC.Generics
  ( Generic(..)
#if MIN_VERSION_base(4,17,0)
  , Generically1(..)
#endif
  , (:+:)(..), (:*:)(..)
  , K1(K1), M1(M1), U1(..), V1, Rec0
  )
import GHC.TypeLits
  ( TypeError, ErrorMessage(..) )

-- containers

import Data.Map
  ( Map )
import qualified Data.Map as Map

-- transformers

import Control.Monad.Trans.State.Strict
  ( StateT, evalStateT, get, modify )
import Control.Monad.Trans.Class
  ( MonadTrans(lift) )

-- ghc

#if MIN_VERSION_ghc(9,8,0)
import GHC.Iface.Errors.Ppr
  ( missingInterfaceErrorDiagnostic )
#endif
#if MIN_VERSION_ghc(9,3,0)
import GHC.Iface.Errors
  ( cannotFindModule )
#elif MIN_VERSION_ghc(9,2,0)
import GHC.Iface.Load
  ( cannotFindModule )
#else
import GHC.Driver.Types
  ( hsc_dflags )
import GHC.Driver.Finder
  ( cannotFindModule )
#endif
#if MIN_VERSION_ghc(9,5,0)
import Language.Haskell.Syntax.Module.Name
  ( moduleNameString )
#else
import GHC.Unit.Module.Name
  ( moduleNameString )
#endif
import GHC.Utils.Panic
  ( pgmErrorDoc )
import GHC.Tc.Plugin
  ( getTopEnv )
#if MIN_VERSION_ghc(9,8,0)
import GHC.Types.Error
  ( HasDefaultDiagnosticOpts(defaultOpts) )
#endif

-- ghc-tcplugin-api

import GHC.TcPlugin.API
  hiding ( Type )
import GHC.TcPlugin.API.Internal
  ( MonadTcPlugin(liftTcPluginM) )

--------------------------------------------------------------------------------


-- | A 'QualifiedName' is the name of something,

-- together with the names of the module and package it comes from.

data QualifiedName (thing :: Type)
  = Qualified
    { -- | Name of the thing (e.g. name of the 'TyCon' or 'Class').

      forall thing. QualifiedName thing -> String
name    :: String
      -- | Name of the module in which the thing can be found.

    , forall thing. QualifiedName thing -> ModuleName
module' :: ModuleName
      -- | Name of the package in which the module can be found.

    , forall thing. QualifiedName thing -> PkgQual
package :: PkgQual
    }

-- | Type-level parameter to 'Wear' type family, for higher-kinded data.

--

-- @Wear Named thing@ is the identifier data passed in as an argument.

-- @Wear Resolved thing@ is the result of name resolving the thing.

--

-- This allows users to pass a record of names, of type @MyData Named@,

-- and obtain a record of looked-up things, of type @MyData Resolved@.

--

-- Refer to 'ResolveNames' for a worked example.

data NameResolution = Named | Resolved

-- | Use this to refer to a @Promoted DataCon@.

data Promoted (thing :: k) :: Type

-- | Type-family used for higher-kinded data pattern.

--

-- This allows the same record to be re-used,

-- as explained in the worked example for 'ResolveNames'.

--

-- For instance, if one defines:

--

-- > data MyData n

-- >   = MyData

-- >   { myClass :: !( Wear n Class )

-- >   , myTyCon :: !( Wear n TyCon )

-- >   }

--

-- then a record of type @MyData Named@ is simply a record of textual names

-- (a typeclass name and a type-constructor name, with associated module & packages),

-- whereas a record of type @MyData Resolved@ contains a typeclass's @Class@

-- as well as a type-constructor's @TyCon@.

#if MIN_VERSION_ghc(9,0,0)
type Wear :: forall k. NameResolution -> k -> Type
#endif
type family Wear (n :: NameResolution) (thing :: k) :: Type where
#if MIN_VERSION_ghc(9,0,0)
  Wear @Type Named thing           = QualifiedName thing
#else
  Wear Named thing                 = QualifiedName thing
#endif
  Wear Resolved (Promoted DataCon) = TyCon
  Wear Resolved (Promoted a)
    = TypeError
      ( Text "Cannot promote " :<>: ShowType a :<>: Text "."
      :$$: Text "Can only promote 'DataCon's."
      )
  Wear Resolved thing = thing

-- | Retrieve the underlying thing being referred to by inspecting

-- the type parameter of 'QualifiedName'.

type family UnwearNamed (loc :: Type) :: Type where
  UnwearNamed (QualifiedName thing) = thing

-- | Type-class overloading things that can be looked up by name:

--

-- * classes,

-- * data constructors (as well as their promotion),

-- * type-constructors.

#if MIN_VERSION_ghc(9,0,0)
type Lookupable :: forall {k}. k -> Constraint
#endif
class Lookupable (a :: k) where
  mkOccName :: String -> OccName
  lookup :: MonadTcPlugin m => Name -> m (Wear Resolved a)

instance Lookupable TyCon where
  mkOccName :: String -> OccName
mkOccName = String -> OccName
mkTcOcc
  lookup :: forall (m :: * -> *).
MonadTcPlugin m =>
Name -> m (Wear 'Resolved TyCon)
lookup = Name -> m TyCon
Name -> m (Wear 'Resolved TyCon)
forall (m :: * -> *). MonadTcPlugin m => Name -> m TyCon
tcLookupTyCon
instance Lookupable DataCon where
  mkOccName :: String -> OccName
mkOccName = String -> OccName
mkDataOcc
  lookup :: forall (m :: * -> *).
MonadTcPlugin m =>
Name -> m (Wear 'Resolved DataCon)
lookup = Name -> m DataCon
Name -> m (Wear 'Resolved DataCon)
forall (m :: * -> *). MonadTcPlugin m => Name -> m DataCon
tcLookupDataCon
instance Lookupable Class where
  mkOccName :: String -> OccName
mkOccName = String -> OccName
mkClsOcc
  lookup :: forall (m :: * -> *).
MonadTcPlugin m =>
Name -> m (Wear 'Resolved Class)
lookup = Name -> m Class
Name -> m (Wear 'Resolved Class)
forall (m :: * -> *). MonadTcPlugin m => Name -> m Class
tcLookupClass
instance Lookupable (Promoted DataCon) where
  mkOccName :: String -> OccName
mkOccName = String -> OccName
mkDataOcc
  lookup :: forall (m :: * -> *).
MonadTcPlugin m =>
Name -> m (Wear 'Resolved (Promoted DataCon))
lookup = (DataCon -> TyCon) -> m DataCon -> m TyCon
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DataCon -> TyCon
promoteDataCon (m DataCon -> m TyCon) -> (Name -> m DataCon) -> Name -> m TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> m DataCon
forall (m :: * -> *). MonadTcPlugin m => Name -> m DataCon
tcLookupDataCon

-- | This class exposes the method 'resolveNames' which will

-- perform name resolution for all the fields in a datatype.

--

-- Example usage: we define a record that will hold

-- the things we want to look up, using the 'Wear' type family.

--

-- For example:

--

--  > data MyData n

--  >   = MyData

--  >   { myClass       :: !( Wear n Class )

--  >   , myTyCon       :: !( Wear n TyCon )

--  >   , myDataCon     :: !( Wear n DataCon )

--  >   , myPromDataCon :: !( Wear n (Promoted DataCon) )

--  >   }

--  >   deriving stock Generic

--  >   deriving ResolveNames

--  >     via Generically1 MyData

--

-- Now we can specify the names of the things which we want to look up,

-- together with the modules and packages in which they belong:

--

-- > myNames :: MyData Named

-- > myNames = MyData

-- >  { myClass = QualifiedName "MyClass" "My.Module" ( Just "my-pkg-name" )

-- >  , ...

-- >  }

--

-- Then we can call 'resolveNames':

--

-- > resolvedNames :: MonadTcPlugin m => m (MyData Resolved)

-- > resolvedNames = resolveNames myNames

--

-- This returns a record containing the looked up things we want,

-- e.g. @myClass :: Class@, @myPromDataCon :: TyCon@, etc.

class ResolveNames (f :: NameResolution -> Type) where
  resolve_names :: ( Coercible res ( f Resolved ), MonadTcPlugin m )
                => f Named -> m res
  -- Workaround: the result is anything coercible to "f Resolved" rather than just "f Resolved",

  -- because otherwise GHC complains when using DerivingVia that we don't know the role

  -- of the parameter to m, despite the quantified constraint superclass to MonadTcPlugin.

  --

  -- This unfortunately worsens type-inference, so we export

  -- 'resolveNames' separately.


-- | Resolve a collection of names.

--

-- See 'ResolveNames' for further details.

resolveNames :: ( MonadTcPlugin m, ResolveNames f )
             => f Named -> m ( f Resolved )
resolveNames :: forall (m :: * -> *) (f :: NameResolution -> *).
(MonadTcPlugin m, ResolveNames f) =>
f 'Named -> m (f 'Resolved)
resolveNames = f 'Named -> m (f 'Resolved)
forall res (m :: * -> *).
(Coercible res (f 'Resolved), MonadTcPlugin m) =>
f 'Named -> m res
forall (f :: NameResolution -> *) res (m :: * -> *).
(ResolveNames f, Coercible res (f 'Resolved), MonadTcPlugin m) =>
f 'Named -> m res
resolve_names

instance ( Generic (f Named)
         , Generic (f Resolved)
         , GTraversableC ResolveName (Rep (f Named)) (Rep (f Resolved))
         )
      => ResolveNames (Generically1 f) where
  resolve_names
    :: forall
#if MIN_VERSION_ghc(9,0,0)
         {m}
#else
          m
#endif
         res
    .  ( Coercible res ( Generically1 f Resolved ), MonadTcPlugin m )
    => Generically1 f Named -> m res
  resolve_names :: forall {m :: * -> *} res.
(Coercible res (Generically1 f 'Resolved), MonadTcPlugin m) =>
Generically1 f 'Named -> m res
resolve_names ( Generically1 f 'Named
dat )
    =  ( StateT ImportedModules m res -> ImportedModules -> m res
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` ImportedModules
emptyModules )
    (StateT ImportedModules m res -> m res)
-> StateT ImportedModules m res -> m res
forall a b. (a -> b) -> a -> b
$  f 'Resolved -> res
forall a b. Coercible a b => a -> b
coerce (f 'Resolved -> res)
-> (Rep (f 'Resolved) Any -> f 'Resolved)
-> Rep (f 'Resolved) Any
-> res
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => Rep a x -> a
to @(f Resolved)
   (Rep (f 'Resolved) Any -> res)
-> StateT ImportedModules m (Rep (f 'Resolved) Any)
-> StateT ImportedModules m res
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (c :: * -> * -> Constraint) (s :: * -> *) (t :: * -> *) x.
GTraversableC c s t =>
TraversalC c (s x) (t x)
gtraverseC @ResolveName a -> StateT ImportedModules m b
Wear 'Named (UnwearNamed a)
-> StateT ImportedModules m (Wear 'Resolved (UnwearNamed a))
forall a b. ResolveName a b => a -> StateT ImportedModules m b
forall thing (m :: * -> *).
(ResolveName (Wear 'Named thing) (Wear 'Resolved thing),
 MonadTcPlugin m) =>
Wear 'Named thing
-> StateT ImportedModules m (Wear 'Resolved thing)
resolveName ( f 'Named -> Rep (f 'Named) Any
forall x. f 'Named -> Rep (f 'Named) x
forall a x. Generic a => a -> Rep a x
from f 'Named
dat )

-- | Type-class dispatch for looking up names.

--

-- Every instance is of the form:

--

-- > ResolveName (Wear Named thing) (Wear Resolved thing)

--

-- which allows one to write 'resolveName':

--

-- > resolveName :: ... => Wear Named thing -> m ( Wear Resolved thing )

class    ( a ~ Wear Named    ( UnwearNamed a )
         , b ~ Wear Resolved ( UnwearNamed a )
         , Lookupable ( UnwearNamed a )
         )
      => ResolveName (a :: Type) (b :: Type)
instance ( a ~ Wear Named    ( UnwearNamed a )
         , b ~ Wear Resolved ( UnwearNamed a )
         , Lookupable ( UnwearNamed a )
         )
      => ResolveName a b

resolveName :: forall (thing :: Type) m
            .  ResolveName ( Wear Named thing ) ( Wear Resolved thing )
            => MonadTcPlugin m
            => Wear Named thing
            -> StateT ImportedModules m ( Wear Resolved thing )
resolveName :: forall thing (m :: * -> *).
(ResolveName (Wear 'Named thing) (Wear 'Resolved thing),
 MonadTcPlugin m) =>
Wear 'Named thing
-> StateT ImportedModules m (Wear 'Resolved thing)
resolveName (Qualified String
str ModuleName
mod_name PkgQual
pkg) = do
  Module
md <- PkgQual -> ModuleName -> StateT ImportedModules m Module
forall (m :: * -> *).
MonadTcPlugin m =>
PkgQual -> ModuleName -> StateT ImportedModules m Module
lookupModule PkgQual
pkg ModuleName
mod_name
  Name
nm <- m Name -> StateT ImportedModules m Name
forall (m :: * -> *) a.
Monad m =>
m a -> StateT ImportedModules m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Name -> StateT ImportedModules m Name)
-> m Name -> StateT ImportedModules m Name
forall a b. (a -> b) -> a -> b
$ Module -> OccName -> m Name
forall (m :: * -> *).
MonadTcPlugin m =>
Module -> OccName -> m Name
lookupOrig Module
md
                 (forall a. Lookupable a => String -> OccName
forall {k} (a :: k). Lookupable a => String -> OccName
mkOccName
#if !MIN_VERSION_ghc(9,0,0)
                   @_
#endif
                   @thing
                   String
str
                 )
  m (Wear 'Resolved thing)
-> StateT ImportedModules m (Wear 'Resolved thing)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT ImportedModules m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Wear 'Resolved thing)
 -> StateT ImportedModules m (Wear 'Resolved thing))
-> m (Wear 'Resolved thing)
-> StateT ImportedModules m (Wear 'Resolved thing)
forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(Lookupable a, MonadTcPlugin m) =>
Name -> m (Wear 'Resolved a)
forall {k} (a :: k) (m :: * -> *).
(Lookupable a, MonadTcPlugin m) =>
Name -> m (Wear 'Resolved a)
lookup
#if !MIN_VERSION_ghc(9,0,0)
           @_
#endif
           @thing Name
nm

--------------------------------------------------------------------------------

-- Caching of found modules.


newtype ImportedModules
  = ImportedModules
    { ImportedModules -> Map (PkgQual, ModuleName) Module
imported_modules :: Map (PkgQual, ModuleName) Module
    }

emptyModules :: ImportedModules
emptyModules :: ImportedModules
emptyModules =
  Map (PkgQual, ModuleName) Module -> ImportedModules
ImportedModules Map (PkgQual, ModuleName) Module
forall k a. Map k a
Map.empty

lookupCachedModule :: Monad m => PkgQual -> ModuleName -> StateT ImportedModules m (Maybe Module)
lookupCachedModule :: forall (m :: * -> *).
Monad m =>
PkgQual -> ModuleName -> StateT ImportedModules m (Maybe Module)
lookupCachedModule PkgQual
pkg ModuleName
modl = (PkgQual, ModuleName)
-> Map (PkgQual, ModuleName) Module -> Maybe Module
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PkgQual
pkg, ModuleName
modl) (Map (PkgQual, ModuleName) Module -> Maybe Module)
-> (ImportedModules -> Map (PkgQual, ModuleName) Module)
-> ImportedModules
-> Maybe Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportedModules -> Map (PkgQual, ModuleName) Module
imported_modules (ImportedModules -> Maybe Module)
-> StateT ImportedModules m ImportedModules
-> StateT ImportedModules m (Maybe Module)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT ImportedModules m ImportedModules
forall (m :: * -> *) s. Monad m => StateT s m s
get

insertCachedModule :: Monad m => PkgQual -> ModuleName -> Module -> StateT ImportedModules m ()
insertCachedModule :: forall (m :: * -> *).
Monad m =>
PkgQual -> ModuleName -> Module -> StateT ImportedModules m ()
insertCachedModule PkgQual
pkg ModuleName
modl Module
md = (ImportedModules -> ImportedModules) -> StateT ImportedModules m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((ImportedModules -> ImportedModules)
 -> StateT ImportedModules m ())
-> (ImportedModules -> ImportedModules)
-> StateT ImportedModules m ()
forall a b. (a -> b) -> a -> b
$ \ImportedModules
mods ->
   ImportedModules
mods{ imported_modules = Map.insert (pkg, modl) md (imported_modules mods) }

lookupModule :: MonadTcPlugin m => PkgQual -> ModuleName -> StateT ImportedModules m Module
lookupModule :: forall (m :: * -> *).
MonadTcPlugin m =>
PkgQual -> ModuleName -> StateT ImportedModules m Module
lookupModule PkgQual
pkg ModuleName
mod_name = do
  Maybe Module
cachedResult <- PkgQual -> ModuleName -> StateT ImportedModules m (Maybe Module)
forall (m :: * -> *).
Monad m =>
PkgQual -> ModuleName -> StateT ImportedModules m (Maybe Module)
lookupCachedModule PkgQual
pkg ModuleName
mod_name
  case Maybe Module
cachedResult of
    Just Module
res -> do
      PkgQual -> ModuleName -> Module -> StateT ImportedModules m ()
forall (m :: * -> *).
Monad m =>
PkgQual -> ModuleName -> Module -> StateT ImportedModules m ()
insertCachedModule PkgQual
pkg ModuleName
mod_name Module
res
      Module -> StateT ImportedModules m Module
forall a. a -> StateT ImportedModules m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Module
res
    Maybe Module
Nothing -> do
      FindResult
findResult <- m FindResult -> StateT ImportedModules m FindResult
forall (m :: * -> *) a.
Monad m =>
m a -> StateT ImportedModules m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m FindResult -> StateT ImportedModules m FindResult)
-> m FindResult -> StateT ImportedModules m FindResult
forall a b. (a -> b) -> a -> b
$ ModuleName -> PkgQual -> m FindResult
forall (m :: * -> *).
MonadTcPlugin m =>
ModuleName -> PkgQual -> m FindResult
findImportedModule ModuleName
mod_name PkgQual
pkg
      case FindResult
findResult of
        Found ModLocation
_ Module
res
          -> Module -> StateT ImportedModules m Module
forall a. a -> StateT ImportedModules m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Module
res
        FindResult
other -> do
          HscEnv
hsc_env <- m HscEnv -> StateT ImportedModules m HscEnv
forall (m :: * -> *) a.
Monad m =>
m a -> StateT ImportedModules m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m HscEnv -> StateT ImportedModules m HscEnv)
-> (TcPluginM HscEnv -> m HscEnv)
-> TcPluginM HscEnv
-> StateT ImportedModules m HscEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcPluginM HscEnv -> m HscEnv
forall a. TcPluginM a -> m a
forall (m :: * -> *) a. MonadTcPlugin m => TcPluginM a -> m a
liftTcPluginM (TcPluginM HscEnv -> StateT ImportedModules m HscEnv)
-> TcPluginM HscEnv -> StateT ImportedModules m HscEnv
forall a b. (a -> b) -> a -> b
$ TcPluginM HscEnv
getTopEnv
          let
            err_doc :: SDoc
            err_doc :: SDoc
err_doc =
#if MIN_VERSION_ghc(9,8,0)
              missingInterfaceErrorDiagnostic defaultOpts $
#endif
#if MIN_VERSION_ghc(9,2,0)
              HscEnv -> ModuleName -> FindResult -> SDoc
cannotFindModule HscEnv
hsc_env ModuleName
mod_name FindResult
other
#else
              cannotFindModule (hsc_dflags hsc_env) mod_name other
#endif
          String -> SDoc -> StateT ImportedModules m Module
forall a. String -> SDoc -> a
pgmErrorDoc
            (    String
"GHC.TcPlugin.API: could not find module "
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ModuleName -> String
moduleNameString ModuleName
mod_name
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> case PkgQual -> Maybe String
pkgQualToPkgName PkgQual
pkg of
                   Just String
p  -> String
" in package " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
p
                   Maybe String
Nothing -> String
forall a. Monoid a => a
mempty
            )
            SDoc
err_doc

--------------------------------------------------------------------------------

-- Constrained traversals.


type TraversalC (c :: Type -> Type -> Constraint) (s :: Type)  (t :: Type)
  =  forall f. ( Applicative f )
  => ( forall a b. c a b => a -> f b ) -> s -> f t

class GTraversableC (c :: Type -> Type -> Constraint) (s :: Type -> Type) (t :: Type -> Type) where
  gtraverseC :: TraversalC c (s x) (t x)

instance
  ( GTraversableC c l l'
  , GTraversableC c r r'
  ) => GTraversableC c (l :*: r) (l' :*: r') where
  gtraverseC :: forall x. TraversalC c ((:*:) l r x) ((:*:) l' r' x)
gtraverseC forall a b. c a b => a -> f b
f (l x
l :*: r x
r)
    = l' x -> r' x -> (:*:) l' r' x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (l' x -> r' x -> (:*:) l' r' x)
-> f (l' x) -> f (r' x -> (:*:) l' r' x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (c :: * -> * -> Constraint) (s :: * -> *) (t :: * -> *) x.
GTraversableC c s t =>
TraversalC c (s x) (t x)
gtraverseC @c a -> f b
forall a b. c a b => a -> f b
f l x
l f (r' x -> (:*:) l' r' x) -> f (r' x) -> f ((:*:) l' r' x)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (c :: * -> * -> Constraint) (s :: * -> *) (t :: * -> *) x.
GTraversableC c s t =>
TraversalC c (s x) (t x)
gtraverseC @c a -> f b
forall a b. c a b => a -> f b
f r x
r

instance
  ( GTraversableC c l l'
  , GTraversableC c r r'
  ) => GTraversableC c (l :+: r) (l' :+: r') where
  gtraverseC :: forall x. TraversalC c ((:+:) l r x) ((:+:) l' r' x)
gtraverseC forall a b. c a b => a -> f b
f (L1 l x
l) = l' x -> (:+:) l' r' x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (l' x -> (:+:) l' r' x) -> f (l' x) -> f ((:+:) l' r' x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (c :: * -> * -> Constraint) (s :: * -> *) (t :: * -> *) x.
GTraversableC c s t =>
TraversalC c (s x) (t x)
gtraverseC @c a -> f b
forall a b. c a b => a -> f b
f l x
l
  gtraverseC forall a b. c a b => a -> f b
f (R1 r x
r) = r' x -> (:+:) l' r' x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (r' x -> (:+:) l' r' x) -> f (r' x) -> f ((:+:) l' r' x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (c :: * -> * -> Constraint) (s :: * -> *) (t :: * -> *) x.
GTraversableC c s t =>
TraversalC c (s x) (t x)
gtraverseC @c a -> f b
forall a b. c a b => a -> f b
f r x
r

instance GTraversableC c s t
  => GTraversableC c (M1 i m s) (M1 i m t) where
  gtraverseC :: forall x. TraversalC c (M1 i m s x) (M1 i m t x)
gtraverseC forall a b. c a b => a -> f b
f (M1 s x
x) = t x -> M1 i m t x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (t x -> M1 i m t x) -> f (t x) -> f (M1 i m t x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (c :: * -> * -> Constraint) (s :: * -> *) (t :: * -> *) x.
GTraversableC c s t =>
TraversalC c (s x) (t x)
gtraverseC @c a -> f b
forall a b. c a b => a -> f b
f s x
x

instance GTraversableC c U1 U1 where
  gtraverseC :: forall x. TraversalC c (U1 x) (U1 x)
gtraverseC forall a b. c a b => a -> f b
_ U1 x
_ = U1 x -> f (U1 x)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 x
forall k (p :: k). U1 p
U1

instance GTraversableC c V1 V1 where
  gtraverseC :: forall x. TraversalC c (V1 x) (V1 x)
gtraverseC forall a b. c a b => a -> f b
_ = V1 x -> f (V1 x)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance c a b => GTraversableC c (Rec0 a) (Rec0 b) where
  gtraverseC :: forall x. TraversalC c (Rec0 a x) (Rec0 b x)
gtraverseC forall a b. c a b => a -> f b
f (K1 a
a) = b -> K1 R b x
forall k i c (p :: k). c -> K1 i c p
K1 (b -> K1 R b x) -> f b -> f (K1 R b x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
forall a b. c a b => a -> f b
f a
a

--------------------------------------------------------------------------------

-- Generically and Generically1 wrappers for DerivingVia.


#if !MIN_VERSION_base(4,17,0)
-- | A type whose instances are defined generically, using the

-- 'Generic1' representation. 'Generically1' is a higher-kinded

-- version of 'Generically' that uses 'Generic'.

--

-- Generic instances can be derived for type constructors via

-- @'Generically1' F@ using @-XDerivingVia@.

newtype Generically1 (f :: k -> Type) (a :: k) = Generically1 ( f a )
#endif