{- Language/Haskell/TH/Desugar/Reify.hs

(c) Richard Eisenberg 2014
rae@cs.brynmawr.edu

Allows for reification from a list of declarations, without looking a name
up in the environment.
-}

{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}

module Language.Haskell.TH.Desugar.Reify (
  -- * Reification
  reifyWithLocals_maybe, reifyWithLocals, reifyWithWarning, reifyInDecs,

  -- ** Fixity reification
  qReifyFixity, reifyFixity, reifyFixityWithLocals, reifyFixityInDecs,

  -- ** Type reification
  qReifyType, reifyType,
  reifyTypeWithLocals_maybe, reifyTypeWithLocals, reifyTypeInDecs,

  -- * Datatype lookup
  getDataD, dataConNameToCon, dataConNameToDataName,

  -- * Value and type lookup
  lookupValueNameWithLocals, lookupTypeNameWithLocals,
  mkDataNameWithLocals, mkTypeNameWithLocals,
  reifyNameSpace,

  -- * Monad support
  DsMonad(..), DsM, withLocalDeclarations
  ) where

import Control.Applicative
import qualified Control.Monad.Fail as Fail
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.RWS
import Control.Monad.Trans.Instances ()
import qualified Data.Foldable as F
#if __GLASGOW_HASKELL__ < 710
import Data.Foldable (foldMap)
#endif
import Data.Function (on)
import qualified Data.List as List
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe
import qualified Data.Set as Set
import Data.Set (Set)

import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Datatype.TyVarBndr
import Language.Haskell.TH.Instances ()
import Language.Haskell.TH.Syntax hiding ( lift )

import Language.Haskell.TH.Desugar.Util

-- | Like @reify@ from Template Haskell, but looks also in any not-yet-typechecked
-- declarations. To establish this list of not-yet-typechecked declarations,
-- use 'withLocalDeclarations'. Returns 'Nothing' if reification fails.
-- Note that no inferred type information is available from local declarations;
-- bottoms may be used if necessary.
reifyWithLocals_maybe :: DsMonad q => Name -> q (Maybe Info)
reifyWithLocals_maybe :: Name -> q (Maybe Info)
reifyWithLocals_maybe Name
name = q (Maybe Info) -> q (Maybe Info) -> q (Maybe Info)
forall (m :: * -> *) a. Quasi m => m a -> m a -> m a
qRecover
  (Maybe Info -> q (Maybe Info)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Info -> q (Maybe Info))
-> ([Dec] -> Maybe Info) -> [Dec] -> q (Maybe Info)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Dec] -> Maybe Info
reifyInDecs Name
name ([Dec] -> q (Maybe Info)) -> q [Dec] -> q (Maybe Info)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< q [Dec]
forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations)
  (Info -> Maybe Info
forall a. a -> Maybe a
Just (Info -> Maybe Info) -> q Info -> q (Maybe Info)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> q Info
forall (m :: * -> *). Quasi m => Name -> m Info
qReify Name
name)

-- | Like 'reifyWithLocals_maybe', but throws an exception upon failure,
-- warning the user about separating splices.
reifyWithLocals :: DsMonad q => Name -> q Info
reifyWithLocals :: Name -> q Info
reifyWithLocals Name
name = do
  Maybe Info
m_info <- Name -> q (Maybe Info)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe Info)
reifyWithLocals_maybe Name
name
  case Maybe Info
m_info of
    Maybe Info
Nothing -> Name -> q Info
forall (m :: * -> *) a. MonadFail m => Name -> m a
reifyFail Name
name
    Just Info
i  -> Info -> q Info
forall (m :: * -> *) a. Monad m => a -> m a
return Info
i

-- | Reify a declaration, warning the user about splices if the reify fails.
-- The warning says that reification can fail if you try to reify a type in
-- the same splice as it is declared.
reifyWithWarning :: (Quasi q, Fail.MonadFail q) => Name -> q Info
reifyWithWarning :: Name -> q Info
reifyWithWarning Name
name = q Info -> q Info -> q Info
forall (m :: * -> *) a. Quasi m => m a -> m a -> m a
qRecover (Name -> q Info
forall (m :: * -> *) a. MonadFail m => Name -> m a
reifyFail Name
name) (Name -> q Info
forall (m :: * -> *). Quasi m => Name -> m Info
qReify Name
name)

-- | Print out a warning about separating splices and fail.
reifyFail :: Fail.MonadFail m => Name -> m a
reifyFail :: Name -> m a
reifyFail Name
name =
  String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Looking up " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Name -> String
forall a. Show a => a -> String
show Name
name) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in the list of available " String -> String -> String
forall a. [a] -> [a] -> [a]
++
              String
"declarations failed.\nThis lookup fails if the declaration " String -> String -> String
forall a. [a] -> [a] -> [a]
++
              String
"referenced was made in the same Template\nHaskell splice as the use " String -> String -> String
forall a. [a] -> [a] -> [a]
++
              String
"of the declaration. If this is the case, put\nthe reference to " String -> String -> String
forall a. [a] -> [a] -> [a]
++
              String
"the declaration in a new splice."

---------------------------------
-- Utilities
---------------------------------

-- | Extract the @TyVarBndr@s and constructors given the @Name@ of a type
getDataD :: DsMonad q
         => String       -- ^ Print this out on failure
         -> Name         -- ^ Name of the datatype (@data@ or @newtype@) of interest
         -> q ([TyVarBndrUnit], [Con])
getDataD :: String -> Name -> q ([TyVarBndrUnit], [Con])
getDataD String
err Name
name = do
  Info
info <- Name -> q Info
forall (q :: * -> *). DsMonad q => Name -> q Info
reifyWithLocals Name
name
  Dec
dec <- case Info
info of
           TyConI Dec
dec -> Dec -> q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
dec
           Info
_ -> q Dec
forall a. q a
badDeclaration
  case Dec
dec of
#if __GLASGOW_HASKELL__ > 710
    DataD Cxt
_cxt Name
_name [TyVarBndrUnit]
tvbs Maybe Kind
mk [Con]
cons [DerivClause]
_derivings -> [TyVarBndrUnit]
-> Maybe Kind -> [Con] -> q ([TyVarBndrUnit], [Con])
forall (m :: * -> *) b.
Quasi m =>
[TyVarBndrUnit] -> Maybe Kind -> b -> m ([TyVarBndrUnit], b)
go [TyVarBndrUnit]
tvbs Maybe Kind
mk [Con]
cons
    NewtypeD Cxt
_cxt Name
_name [TyVarBndrUnit]
tvbs Maybe Kind
mk Con
con [DerivClause]
_derivings -> [TyVarBndrUnit]
-> Maybe Kind -> [Con] -> q ([TyVarBndrUnit], [Con])
forall (m :: * -> *) b.
Quasi m =>
[TyVarBndrUnit] -> Maybe Kind -> b -> m ([TyVarBndrUnit], b)
go [TyVarBndrUnit]
tvbs Maybe Kind
mk [Con
con]
#else
    DataD _cxt _name tvbs cons _derivings -> go tvbs Nothing cons
    NewtypeD _cxt _name tvbs con _derivings -> go tvbs Nothing [con]
#endif
    Dec
_ -> q ([TyVarBndrUnit], [Con])
forall a. q a
badDeclaration
  where
    go :: [TyVarBndrUnit] -> Maybe Kind -> b -> m ([TyVarBndrUnit], b)
go [TyVarBndrUnit]
tvbs Maybe Kind
mk b
cons = do
      let k :: Kind
k = Kind -> Maybe Kind -> Kind
forall a. a -> Maybe a -> a
fromMaybe (Name -> Kind
ConT Name
typeKindName) Maybe Kind
mk
      [TyVarBndrUnit]
extra_tvbs <- Kind -> m [TyVarBndrUnit]
forall (q :: * -> *). Quasi q => Kind -> q [TyVarBndrUnit]
mkExtraKindBinders Kind
k
      let all_tvbs :: [TyVarBndrUnit]
all_tvbs = [TyVarBndrUnit]
tvbs [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a] -> [a]
++ [TyVarBndrUnit]
extra_tvbs
      ([TyVarBndrUnit], b) -> m ([TyVarBndrUnit], b)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndrUnit]
all_tvbs, b
cons)

    badDeclaration :: q a
badDeclaration =
          String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q a) -> String -> q a
forall a b. (a -> b) -> a -> b
$ String
"The name (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Name -> String
forall a. Show a => a -> String
show Name
name) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") refers to something " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"other than a datatype. " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err

-- | Create new kind variable binder names corresponding to the return kind of
-- a data type. This is useful when you have a data type like:
--
-- @
-- data Foo :: forall k. k -> Type -> Type where ...
-- @
--
-- But you want to be able to refer to the type @Foo a b@.
-- 'mkExtraKindBinders' will take the kind @forall k. k -> Type -> Type@,
-- discover that is has two visible argument kinds, and return as a result
-- two new kind variable binders @[a :: k, b :: Type]@, where @a@ and @b@
-- are fresh type variable names.
--
-- This expands kind synonyms if necessary.
mkExtraKindBinders :: forall q. Quasi q => Kind -> q [TyVarBndrUnit]
mkExtraKindBinders :: Kind -> q [TyVarBndrUnit]
mkExtraKindBinders Kind
k = do
  Kind
k' <- Q Kind -> q Kind
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ (Q Kind -> q Kind) -> Q Kind -> q Kind
forall a b. (a -> b) -> a -> b
$ Kind -> Q Kind
resolveTypeSynonyms Kind
k
  let (FunArgs
fun_args, Kind
_) = Kind -> (FunArgs, Kind)
unravelType Kind
k'
      vis_fun_args :: [VisFunArg]
vis_fun_args  = FunArgs -> [VisFunArg]
filterVisFunArgs FunArgs
fun_args
  (VisFunArg -> q TyVarBndrUnit) -> [VisFunArg] -> q [TyVarBndrUnit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM VisFunArg -> q TyVarBndrUnit
mk_tvb [VisFunArg]
vis_fun_args
  where
    mk_tvb :: VisFunArg -> q TyVarBndrUnit
    mk_tvb :: VisFunArg -> q TyVarBndrUnit
mk_tvb (VisFADep TyVarBndrUnit
tvb) = TyVarBndrUnit -> q TyVarBndrUnit
forall (m :: * -> *) a. Monad m => a -> m a
return TyVarBndrUnit
tvb
    mk_tvb (VisFAAnon Kind
ki) = Name -> Kind -> TyVarBndrUnit
kindedTV (Name -> Kind -> TyVarBndrUnit)
-> q Name -> q (Kind -> TyVarBndrUnit)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> q Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"a" q (Kind -> TyVarBndrUnit) -> q Kind -> q TyVarBndrUnit
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Kind -> q Kind
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
ki

-- | From the name of a data constructor, retrive the datatype definition it
-- is a part of.
dataConNameToDataName :: DsMonad q => Name -> q Name
dataConNameToDataName :: Name -> q Name
dataConNameToDataName Name
con_name = do
  Info
info <- Name -> q Info
forall (q :: * -> *). DsMonad q => Name -> q Info
reifyWithLocals Name
con_name
  case Info
info of
#if __GLASGOW_HASKELL__ > 710
    DataConI Name
_name Kind
_type Name
parent_name -> Name -> q Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
parent_name
#else
    DataConI _name _type parent_name _fixity -> return parent_name
#endif
    Info
_ -> String -> q Name
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q Name) -> String -> q Name
forall a b. (a -> b) -> a -> b
$ String
"The name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
con_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not appear to be " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                String
"a data constructor."

-- | From the name of a data constructor, retrieve its definition as a @Con@
dataConNameToCon :: DsMonad q => Name -> q Con
dataConNameToCon :: Name -> q Con
dataConNameToCon Name
con_name = do
  -- we need to get the field ordering from the constructor. We must reify
  -- the constructor to get the tycon, and then reify the tycon to get the `Con`s
  Name
type_name <- Name -> q Name
forall (q :: * -> *). DsMonad q => Name -> q Name
dataConNameToDataName Name
con_name
  ([TyVarBndrUnit]
_, [Con]
cons) <- String -> Name -> q ([TyVarBndrUnit], [Con])
forall (q :: * -> *).
DsMonad q =>
String -> Name -> q ([TyVarBndrUnit], [Con])
getDataD String
"This seems to be an error in GHC." Name
type_name
  let m_con :: Maybe Con
m_con = (Con -> Bool) -> [Con] -> Maybe Con
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name
con_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
==) ([Name] -> Bool) -> (Con -> [Name]) -> Con -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Con -> [Name]
get_con_name) [Con]
cons
  case Maybe Con
m_con of
    Just Con
con -> Con -> q Con
forall (m :: * -> *) a. Monad m => a -> m a
return Con
con
    Maybe Con
Nothing -> String -> q Con
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Datatype does not contain one of its own constructors."

  where
    get_con_name :: Con -> [Name]
get_con_name (NormalC Name
name [BangType]
_)     = [Name
name]
    get_con_name (RecC Name
name [VarBangType]
_)        = [Name
name]
    get_con_name (InfixC BangType
_ Name
name BangType
_)    = [Name
name]
    get_con_name (ForallC [TyVarBndrUnit]
_ Cxt
_ Con
con)    = Con -> [Name]
get_con_name Con
con
#if __GLASGOW_HASKELL__ > 710
    get_con_name (GadtC [Name]
names [BangType]
_ Kind
_)    = [Name]
names
    get_con_name (RecGadtC [Name]
names [VarBangType]
_ Kind
_) = [Name]
names
#endif

--------------------------------------------------
-- DsMonad
--------------------------------------------------

-- | A 'DsMonad' stores some list of declarations that should be considered
-- in scope. 'DsM' is the prototypical inhabitant of 'DsMonad'.
class (Quasi m, Fail.MonadFail m) => DsMonad m where
  -- | Produce a list of local declarations.
  localDeclarations :: m [Dec]

instance DsMonad Q where
  localDeclarations :: Q [Dec]
localDeclarations = [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
instance DsMonad IO where
  localDeclarations :: IO [Dec]
localDeclarations = [Dec] -> IO [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | A convenient implementation of the 'DsMonad' class. Use by calling
-- 'withLocalDeclarations'.
newtype DsM q a = DsM (ReaderT [Dec] q a)
  deriving ( a -> DsM q b -> DsM q a
(a -> b) -> DsM q a -> DsM q b
(forall a b. (a -> b) -> DsM q a -> DsM q b)
-> (forall a b. a -> DsM q b -> DsM q a) -> Functor (DsM q)
forall a b. a -> DsM q b -> DsM q a
forall a b. (a -> b) -> DsM q a -> DsM q b
forall (q :: * -> *) a b. Functor q => a -> DsM q b -> DsM q a
forall (q :: * -> *) a b.
Functor q =>
(a -> b) -> DsM q a -> DsM q b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> DsM q b -> DsM q a
$c<$ :: forall (q :: * -> *) a b. Functor q => a -> DsM q b -> DsM q a
fmap :: (a -> b) -> DsM q a -> DsM q b
$cfmap :: forall (q :: * -> *) a b.
Functor q =>
(a -> b) -> DsM q a -> DsM q b
Functor, Functor (DsM q)
a -> DsM q a
Functor (DsM q)
-> (forall a. a -> DsM q a)
-> (forall a b. DsM q (a -> b) -> DsM q a -> DsM q b)
-> (forall a b c. (a -> b -> c) -> DsM q a -> DsM q b -> DsM q c)
-> (forall a b. DsM q a -> DsM q b -> DsM q b)
-> (forall a b. DsM q a -> DsM q b -> DsM q a)
-> Applicative (DsM q)
DsM q a -> DsM q b -> DsM q b
DsM q a -> DsM q b -> DsM q a
DsM q (a -> b) -> DsM q a -> DsM q b
(a -> b -> c) -> DsM q a -> DsM q b -> DsM q c
forall a. a -> DsM q a
forall a b. DsM q a -> DsM q b -> DsM q a
forall a b. DsM q a -> DsM q b -> DsM q b
forall a b. DsM q (a -> b) -> DsM q a -> DsM q b
forall a b c. (a -> b -> c) -> DsM q a -> DsM q b -> DsM q c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (q :: * -> *). Applicative q => Functor (DsM q)
forall (q :: * -> *) a. Applicative q => a -> DsM q a
forall (q :: * -> *) a b.
Applicative q =>
DsM q a -> DsM q b -> DsM q a
forall (q :: * -> *) a b.
Applicative q =>
DsM q a -> DsM q b -> DsM q b
forall (q :: * -> *) a b.
Applicative q =>
DsM q (a -> b) -> DsM q a -> DsM q b
forall (q :: * -> *) a b c.
Applicative q =>
(a -> b -> c) -> DsM q a -> DsM q b -> DsM q c
<* :: DsM q a -> DsM q b -> DsM q a
$c<* :: forall (q :: * -> *) a b.
Applicative q =>
DsM q a -> DsM q b -> DsM q a
*> :: DsM q a -> DsM q b -> DsM q b
$c*> :: forall (q :: * -> *) a b.
Applicative q =>
DsM q a -> DsM q b -> DsM q b
liftA2 :: (a -> b -> c) -> DsM q a -> DsM q b -> DsM q c
$cliftA2 :: forall (q :: * -> *) a b c.
Applicative q =>
(a -> b -> c) -> DsM q a -> DsM q b -> DsM q c
<*> :: DsM q (a -> b) -> DsM q a -> DsM q b
$c<*> :: forall (q :: * -> *) a b.
Applicative q =>
DsM q (a -> b) -> DsM q a -> DsM q b
pure :: a -> DsM q a
$cpure :: forall (q :: * -> *) a. Applicative q => a -> DsM q a
$cp1Applicative :: forall (q :: * -> *). Applicative q => Functor (DsM q)
Applicative, Applicative (DsM q)
a -> DsM q a
Applicative (DsM q)
-> (forall a b. DsM q a -> (a -> DsM q b) -> DsM q b)
-> (forall a b. DsM q a -> DsM q b -> DsM q b)
-> (forall a. a -> DsM q a)
-> Monad (DsM q)
DsM q a -> (a -> DsM q b) -> DsM q b
DsM q a -> DsM q b -> DsM q b
forall a. a -> DsM q a
forall a b. DsM q a -> DsM q b -> DsM q b
forall a b. DsM q a -> (a -> DsM q b) -> DsM q b
forall (q :: * -> *). Monad q => Applicative (DsM q)
forall (q :: * -> *) a. Monad q => a -> DsM q a
forall (q :: * -> *) a b. Monad q => DsM q a -> DsM q b -> DsM q b
forall (q :: * -> *) a b.
Monad q =>
DsM q a -> (a -> DsM q b) -> DsM q b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> DsM q a
$creturn :: forall (q :: * -> *) a. Monad q => a -> DsM q a
>> :: DsM q a -> DsM q b -> DsM q b
$c>> :: forall (q :: * -> *) a b. Monad q => DsM q a -> DsM q b -> DsM q b
>>= :: DsM q a -> (a -> DsM q b) -> DsM q b
$c>>= :: forall (q :: * -> *) a b.
Monad q =>
DsM q a -> (a -> DsM q b) -> DsM q b
$cp1Monad :: forall (q :: * -> *). Monad q => Applicative (DsM q)
Monad, m a -> DsM m a
(forall (m :: * -> *) a. Monad m => m a -> DsM m a)
-> MonadTrans DsM
forall (m :: * -> *) a. Monad m => m a -> DsM m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> DsM m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> DsM m a
MonadTrans, MonadFail (DsM q)
MonadIO (DsM q)
DsM q [Extension]
DsM q (Maybe a)
DsM q Loc
a -> DsM q ()
Bool -> String -> DsM q (Maybe Name)
Bool -> String -> DsM q ()
String -> DsM q String
String -> DsM q Name
String -> DsM q ()
[Dec] -> DsM q ()
IO a -> DsM q a
Q () -> DsM q ()
Name -> DsM q [DecidedStrictness]
Name -> DsM q [Role]
Name -> DsM q (Maybe Fixity)
Name -> DsM q Kind
Name -> DsM q Info
Name -> Cxt -> DsM q [Dec]
MonadIO (DsM q)
-> MonadFail (DsM q)
-> (String -> DsM q Name)
-> (Bool -> String -> DsM q ())
-> (forall a. DsM q a -> DsM q a -> DsM q a)
-> (Bool -> String -> DsM q (Maybe Name))
-> (Name -> DsM q Info)
-> (Name -> DsM q (Maybe Fixity))
-> (Name -> DsM q Kind)
-> (Name -> Cxt -> DsM q [Dec])
-> (Name -> DsM q [Role])
-> (forall a. Data a => AnnLookup -> DsM q [a])
-> (Module -> DsM q ModuleInfo)
-> (Name -> DsM q [DecidedStrictness])
-> DsM q Loc
-> (forall a. IO a -> DsM q a)
-> (String -> DsM q ())
-> (String -> DsM q String)
-> ([Dec] -> DsM q ())
-> (ForeignSrcLang -> String -> DsM q ())
-> (Q () -> DsM q ())
-> (String -> DsM q ())
-> (forall a. Typeable a => DsM q (Maybe a))
-> (forall a. Typeable a => a -> DsM q ())
-> (Extension -> DsM q Bool)
-> DsM q [Extension]
-> Quasi (DsM q)
Extension -> DsM q Bool
ForeignSrcLang -> String -> DsM q ()
Module -> DsM q ModuleInfo
AnnLookup -> DsM q [a]
DsM q a -> DsM q a -> DsM q a
forall a. Data a => AnnLookup -> DsM q [a]
forall a. Typeable a => DsM q (Maybe a)
forall a. Typeable a => a -> DsM q ()
forall a. IO a -> DsM q a
forall a. DsM q a -> DsM q a -> DsM q a
forall (m :: * -> *).
MonadIO m
-> MonadFail m
-> (String -> m Name)
-> (Bool -> String -> m ())
-> (forall a. m a -> m a -> m a)
-> (Bool -> String -> m (Maybe Name))
-> (Name -> m Info)
-> (Name -> m (Maybe Fixity))
-> (Name -> m Kind)
-> (Name -> Cxt -> m [Dec])
-> (Name -> m [Role])
-> (forall a. Data a => AnnLookup -> m [a])
-> (Module -> m ModuleInfo)
-> (Name -> m [DecidedStrictness])
-> m Loc
-> (forall a. IO a -> m a)
-> (String -> m ())
-> (String -> m String)
-> ([Dec] -> m ())
-> (ForeignSrcLang -> String -> m ())
-> (Q () -> m ())
-> (String -> m ())
-> (forall a. Typeable a => m (Maybe a))
-> (forall a. Typeable a => a -> m ())
-> (Extension -> m Bool)
-> m [Extension]
-> Quasi m
forall (q :: * -> *). Quasi q => MonadFail (DsM q)
forall (q :: * -> *). Quasi q => MonadIO (DsM q)
forall (q :: * -> *). Quasi q => DsM q [Extension]
forall (q :: * -> *). Quasi q => DsM q Loc
forall (q :: * -> *).
Quasi q =>
Bool -> String -> DsM q (Maybe Name)
forall (q :: * -> *). Quasi q => Bool -> String -> DsM q ()
forall (q :: * -> *). Quasi q => String -> DsM q String
forall (q :: * -> *). Quasi q => String -> DsM q Name
forall (q :: * -> *). Quasi q => String -> DsM q ()
forall (q :: * -> *). Quasi q => [Dec] -> DsM q ()
forall (q :: * -> *). Quasi q => Q () -> DsM q ()
forall (q :: * -> *). Quasi q => Name -> DsM q [DecidedStrictness]
forall (q :: * -> *). Quasi q => Name -> DsM q [Role]
forall (q :: * -> *). Quasi q => Name -> DsM q (Maybe Fixity)
forall (q :: * -> *). Quasi q => Name -> DsM q Kind
forall (q :: * -> *). Quasi q => Name -> DsM q Info
forall (q :: * -> *). Quasi q => Name -> Cxt -> DsM q [Dec]
forall (q :: * -> *). Quasi q => Extension -> DsM q Bool
forall (q :: * -> *).
Quasi q =>
ForeignSrcLang -> String -> DsM q ()
forall (q :: * -> *). Quasi q => Module -> DsM q ModuleInfo
forall (q :: * -> *) a. (Quasi q, Data a) => AnnLookup -> DsM q [a]
forall (q :: * -> *) a. (Quasi q, Typeable a) => DsM q (Maybe a)
forall (q :: * -> *) a. (Quasi q, Typeable a) => a -> DsM q ()
forall (q :: * -> *) a. Quasi q => IO a -> DsM q a
forall (q :: * -> *) a. Quasi q => DsM q a -> DsM q a -> DsM q a
qExtsEnabled :: DsM q [Extension]
$cqExtsEnabled :: forall (q :: * -> *). Quasi q => DsM q [Extension]
qIsExtEnabled :: Extension -> DsM q Bool
$cqIsExtEnabled :: forall (q :: * -> *). Quasi q => Extension -> DsM q Bool
qPutQ :: a -> DsM q ()
$cqPutQ :: forall (q :: * -> *) a. (Quasi q, Typeable a) => a -> DsM q ()
qGetQ :: DsM q (Maybe a)
$cqGetQ :: forall (q :: * -> *) a. (Quasi q, Typeable a) => DsM q (Maybe a)
qAddCorePlugin :: String -> DsM q ()
$cqAddCorePlugin :: forall (q :: * -> *). Quasi q => String -> DsM q ()
qAddModFinalizer :: Q () -> DsM q ()
$cqAddModFinalizer :: forall (q :: * -> *). Quasi q => Q () -> DsM q ()
qAddForeignFilePath :: ForeignSrcLang -> String -> DsM q ()
$cqAddForeignFilePath :: forall (q :: * -> *).
Quasi q =>
ForeignSrcLang -> String -> DsM q ()
qAddTopDecls :: [Dec] -> DsM q ()
$cqAddTopDecls :: forall (q :: * -> *). Quasi q => [Dec] -> DsM q ()
qAddTempFile :: String -> DsM q String
$cqAddTempFile :: forall (q :: * -> *). Quasi q => String -> DsM q String
qAddDependentFile :: String -> DsM q ()
$cqAddDependentFile :: forall (q :: * -> *). Quasi q => String -> DsM q ()
qRunIO :: IO a -> DsM q a
$cqRunIO :: forall (q :: * -> *) a. Quasi q => IO a -> DsM q a
qLocation :: DsM q Loc
$cqLocation :: forall (q :: * -> *). Quasi q => DsM q Loc
qReifyConStrictness :: Name -> DsM q [DecidedStrictness]
$cqReifyConStrictness :: forall (q :: * -> *). Quasi q => Name -> DsM q [DecidedStrictness]
qReifyModule :: Module -> DsM q ModuleInfo
$cqReifyModule :: forall (q :: * -> *). Quasi q => Module -> DsM q ModuleInfo
qReifyAnnotations :: AnnLookup -> DsM q [a]
$cqReifyAnnotations :: forall (q :: * -> *) a. (Quasi q, Data a) => AnnLookup -> DsM q [a]
qReifyRoles :: Name -> DsM q [Role]
$cqReifyRoles :: forall (q :: * -> *). Quasi q => Name -> DsM q [Role]
qReifyInstances :: Name -> Cxt -> DsM q [Dec]
$cqReifyInstances :: forall (q :: * -> *). Quasi q => Name -> Cxt -> DsM q [Dec]
qReifyType :: Name -> DsM q Kind
$cqReifyType :: forall (q :: * -> *). Quasi q => Name -> DsM q Kind
qReifyFixity :: Name -> DsM q (Maybe Fixity)
$cqReifyFixity :: forall (q :: * -> *). Quasi q => Name -> DsM q (Maybe Fixity)
qReify :: Name -> DsM q Info
$cqReify :: forall (q :: * -> *). Quasi q => Name -> DsM q Info
qLookupName :: Bool -> String -> DsM q (Maybe Name)
$cqLookupName :: forall (q :: * -> *).
Quasi q =>
Bool -> String -> DsM q (Maybe Name)
qRecover :: DsM q a -> DsM q a -> DsM q a
$cqRecover :: forall (q :: * -> *) a. Quasi q => DsM q a -> DsM q a -> DsM q a
qReport :: Bool -> String -> DsM q ()
$cqReport :: forall (q :: * -> *). Quasi q => Bool -> String -> DsM q ()
qNewName :: String -> DsM q Name
$cqNewName :: forall (q :: * -> *). Quasi q => String -> DsM q Name
$cp2Quasi :: forall (q :: * -> *). Quasi q => MonadFail (DsM q)
$cp1Quasi :: forall (q :: * -> *). Quasi q => MonadIO (DsM q)
Quasi, Monad (DsM q)
Monad (DsM q) -> (forall a. String -> DsM q a) -> MonadFail (DsM q)
String -> DsM q a
forall a. String -> DsM q a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
forall (q :: * -> *). MonadFail q => Monad (DsM q)
forall (q :: * -> *) a. MonadFail q => String -> DsM q a
fail :: String -> DsM q a
$cfail :: forall (q :: * -> *) a. MonadFail q => String -> DsM q a
$cp1MonadFail :: forall (q :: * -> *). MonadFail q => Monad (DsM q)
Fail.MonadFail
#if __GLASGOW_HASKELL__ >= 803
           , Monad (DsM q)
Monad (DsM q) -> (forall a. IO a -> DsM q a) -> MonadIO (DsM q)
IO a -> DsM q a
forall a. IO a -> DsM q a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (q :: * -> *). MonadIO q => Monad (DsM q)
forall (q :: * -> *) a. MonadIO q => IO a -> DsM q a
liftIO :: IO a -> DsM q a
$cliftIO :: forall (q :: * -> *) a. MonadIO q => IO a -> DsM q a
$cp1MonadIO :: forall (q :: * -> *). MonadIO q => Monad (DsM q)
MonadIO
#endif
           )

instance (Quasi q, Fail.MonadFail q) => DsMonad (DsM q) where
  localDeclarations :: DsM q [Dec]
localDeclarations = ReaderT [Dec] q [Dec] -> DsM q [Dec]
forall (q :: * -> *) a. ReaderT [Dec] q a -> DsM q a
DsM ReaderT [Dec] q [Dec]
forall r (m :: * -> *). MonadReader r m => m r
ask

instance DsMonad m => DsMonad (ReaderT r m) where
  localDeclarations :: ReaderT r m [Dec]
localDeclarations = m [Dec] -> ReaderT r m [Dec]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m [Dec]
forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations

instance DsMonad m => DsMonad (StateT s m) where
  localDeclarations :: StateT s m [Dec]
localDeclarations = m [Dec] -> StateT s m [Dec]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m [Dec]
forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations

instance (DsMonad m, Monoid w) => DsMonad (WriterT w m) where
  localDeclarations :: WriterT w m [Dec]
localDeclarations = m [Dec] -> WriterT w m [Dec]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m [Dec]
forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations

instance (DsMonad m, Monoid w) => DsMonad (RWST r w s m) where
  localDeclarations :: RWST r w s m [Dec]
localDeclarations = m [Dec] -> RWST r w s m [Dec]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m [Dec]
forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations

-- | Add a list of declarations to be considered when reifying local
-- declarations.
withLocalDeclarations :: DsMonad q => [Dec] -> DsM q a -> q a
withLocalDeclarations :: [Dec] -> DsM q a -> q a
withLocalDeclarations [Dec]
new_decs (DsM ReaderT [Dec] q a
x) = do
  [Dec]
orig_decs <- q [Dec]
forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations
  ReaderT [Dec] q a -> [Dec] -> q a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT [Dec] q a
x ([Dec]
orig_decs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
new_decs)

---------------------------
-- Reifying local declarations
---------------------------

-- | Look through a list of declarations and possibly return a relevant 'Info'
reifyInDecs :: Name -> [Dec] -> Maybe Info
reifyInDecs :: Name -> [Dec] -> Maybe Info
reifyInDecs Name
n [Dec]
decs = (Name, Info) -> Info
forall a b. (a, b) -> b
snd ((Name, Info) -> Info) -> Maybe (Name, Info) -> Maybe Info
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Dec -> Maybe (Name, Info)) -> [Dec] -> Maybe (Name, Info)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch (Name -> [Dec] -> Dec -> Maybe (Name, Info)
reifyInDec Name
n [Dec]
decs) [Dec]
decs

-- | Look through a list of declarations and possibly return a fixity.
reifyFixityInDecs :: Name -> [Dec] -> Maybe Fixity
reifyFixityInDecs :: Name -> [Dec] -> Maybe Fixity
reifyFixityInDecs Name
n = (Dec -> Maybe Fixity) -> [Dec] -> Maybe Fixity
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch Dec -> Maybe Fixity
match_fixity
  where
    match_fixity :: Dec -> Maybe Fixity
match_fixity (InfixD Fixity
fixity Name
n')        | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
                                           = Fixity -> Maybe Fixity
forall a. a -> Maybe a
Just Fixity
fixity
    match_fixity (ClassD Cxt
_ Name
_ [TyVarBndrUnit]
_ [FunDep]
_ [Dec]
sub_decs) = (Dec -> Maybe Fixity) -> [Dec] -> Maybe Fixity
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch Dec -> Maybe Fixity
match_fixity [Dec]
sub_decs
    match_fixity Dec
_                         = Maybe Fixity
forall a. Maybe a
Nothing

-- | A reified thing along with the name of that thing.
type Named a = (Name, a)

reifyInDec :: Name -> [Dec] -> Dec -> Maybe (Named Info)
reifyInDec :: Name -> [Dec] -> Dec -> Maybe (Name, Info)
reifyInDec Name
n [Dec]
decs (FunD Name
n' [Clause]
_) | Name
n Name -> Name -> Bool
`nameMatches` Name
n' = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Name -> [Dec] -> Info
mkVarI Name
n [Dec]
decs)
reifyInDec Name
n [Dec]
decs (ValD Pat
pat Body
_ [Dec]
_)
  | Just Name
n' <- (Name -> Bool) -> [Name] -> Maybe Name
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Name -> Name -> Bool
nameMatches Name
n) (OSet Name -> [Name]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Pat -> OSet Name
extractBoundNamesPat Pat
pat))
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Name -> [Dec] -> Info
mkVarI Name
n [Dec]
decs)
#if __GLASGOW_HASKELL__ > 710
reifyInDec Name
n [Dec]
_    dec :: Dec
dec@(DataD    Cxt
_ Name
n' [TyVarBndrUnit]
_ Maybe Kind
_ [Con]
_ [DerivClause]
_) | Name
n Name -> Name -> Bool
`nameMatches` Name
n' = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Dec -> Info
TyConI Dec
dec)
reifyInDec Name
n [Dec]
_    dec :: Dec
dec@(NewtypeD Cxt
_ Name
n' [TyVarBndrUnit]
_ Maybe Kind
_ Con
_ [DerivClause]
_) | Name
n Name -> Name -> Bool
`nameMatches` Name
n' = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Dec -> Info
TyConI Dec
dec)
#else
reifyInDec n _    dec@(DataD    _ n' _ _ _) | n `nameMatches` n' = Just (n', TyConI dec)
reifyInDec n _    dec@(NewtypeD _ n' _ _ _) | n `nameMatches` n' = Just (n', TyConI dec)
#endif
reifyInDec Name
n [Dec]
_    dec :: Dec
dec@(TySynD Name
n' [TyVarBndrUnit]
_ Kind
_)       | Name
n Name -> Name -> Bool
`nameMatches` Name
n' = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Dec -> Info
TyConI Dec
dec)
reifyInDec Name
n [Dec]
decs dec :: Dec
dec@(ClassD Cxt
_ Name
n' [TyVarBndrUnit]
_ [FunDep]
_ [Dec]
_)   | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Dec -> [Dec] -> Info
ClassI (Dec -> Dec
quantifyClassDecMethods Dec
dec) (Name -> [Dec] -> [Dec]
findInstances Name
n [Dec]
decs))
reifyInDec Name
n [Dec]
decs (ForeignD (ImportF Callconv
_ Safety
_ String
_ Name
n' Kind
ty)) | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Name -> [Dec] -> Kind -> Info
mkVarITy Name
n [Dec]
decs Kind
ty)
reifyInDec Name
n [Dec]
decs (ForeignD (ExportF Callconv
_ String
_ Name
n' Kind
ty)) | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Name -> [Dec] -> Kind -> Info
mkVarITy Name
n [Dec]
decs Kind
ty)
#if __GLASGOW_HASKELL__ > 710
reifyInDec Name
n [Dec]
decs dec :: Dec
dec@(OpenTypeFamilyD (TypeFamilyHead Name
n' [TyVarBndrUnit]
_ FamilyResultSig
_ Maybe InjectivityAnn
_)) | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Dec -> [Dec] -> Info
FamilyI Dec
dec (Name -> [Dec] -> [Dec]
findInstances Name
n [Dec]
decs))
reifyInDec Name
n [Dec]
decs dec :: Dec
dec@(DataFamilyD Name
n' [TyVarBndrUnit]
_ Maybe Kind
_) | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Dec -> [Dec] -> Info
FamilyI Dec
dec (Name -> [Dec] -> [Dec]
findInstances Name
n [Dec]
decs))
reifyInDec Name
n [Dec]
_    dec :: Dec
dec@(ClosedTypeFamilyD (TypeFamilyHead Name
n' [TyVarBndrUnit]
_ FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
_) | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Dec -> [Dec] -> Info
FamilyI Dec
dec [])
#else
reifyInDec n decs dec@(FamilyD _ n' _ _) | n `nameMatches` n'
  = Just (n', FamilyI dec (findInstances n decs))
reifyInDec n _    dec@(ClosedTypeFamilyD n' _ _ _) | n `nameMatches` n'
  = Just (n', FamilyI dec [])
#endif
#if __GLASGOW_HASKELL__ >= 801
reifyInDec Name
n [Dec]
decs (PatSynD Name
n' PatSynArgs
_ PatSynDir
_ Pat
_) | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Name -> [Dec] -> Info
mkPatSynI Name
n [Dec]
decs)
#endif

#if __GLASGOW_HASKELL__ > 710
reifyInDec Name
n [Dec]
decs (DataD Cxt
_ Name
ty_name [TyVarBndrUnit]
tvbs Maybe Kind
_mk [Con]
cons [DerivClause]
_)
  | Just (Name, Info)
info <- Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Name, Info)
maybeReifyCon Name
n [Dec]
decs Name
ty_name ((TyVarBndrUnit -> TypeArg) -> [TyVarBndrUnit] -> [TypeArg]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> TypeArg
forall flag. TyVarBndrUnit -> TypeArg
tvbToTANormalWithSig [TyVarBndrUnit]
tvbs) [Con]
cons
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name, Info)
info
reifyInDec Name
n [Dec]
decs (NewtypeD Cxt
_ Name
ty_name [TyVarBndrUnit]
tvbs Maybe Kind
_mk Con
con [DerivClause]
_)
  | Just (Name, Info)
info <- Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Name, Info)
maybeReifyCon Name
n [Dec]
decs Name
ty_name ((TyVarBndrUnit -> TypeArg) -> [TyVarBndrUnit] -> [TypeArg]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> TypeArg
forall flag. TyVarBndrUnit -> TypeArg
tvbToTANormalWithSig [TyVarBndrUnit]
tvbs) [Con
con]
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name, Info)
info
#else
reifyInDec n decs (DataD _ ty_name tvbs cons _)
  | Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) cons
  = Just info
reifyInDec n decs (NewtypeD _ ty_name tvbs con _)
  | Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) [con]
  = Just info
#endif
#if __GLASGOW_HASKELL__ > 710
reifyInDec Name
n [Dec]
_decs (ClassD Cxt
_ Name
ty_name [TyVarBndrUnit]
tvbs [FunDep]
_ [Dec]
sub_decs)
  | Just (Name
n', Kind
ty) <- Name -> [Dec] -> Maybe (Named Kind)
findType Name
n [Dec]
sub_decs
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Name -> Kind -> Name -> Info
ClassOpI Name
n (Name -> [TyVarBndrUnit] -> Bool -> Kind -> Kind
quantifyClassMethodType Name
ty_name [TyVarBndrUnit]
tvbs Bool
True Kind
ty) Name
ty_name)
#else
reifyInDec n decs (ClassD _ ty_name tvbs _ sub_decs)
  | Just (n', ty) <- findType n sub_decs
  = Just (n', ClassOpI n (quantifyClassMethodType ty_name tvbs True ty)
                       ty_name (fromMaybe defaultFixity $
                                reifyFixityInDecs n $ sub_decs ++ decs))
#endif
reifyInDec Name
n [Dec]
decs (ClassD Cxt
_ Name
_ [TyVarBndrUnit]
_ [FunDep]
_ [Dec]
sub_decs)
  | Just (Name, Info)
info <- (Dec -> Maybe (Name, Info)) -> [Dec] -> Maybe (Name, Info)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch (Name -> [Dec] -> Dec -> Maybe (Name, Info)
reifyInDec Name
n [Dec]
decs) [Dec]
sub_decs
                 -- Important: don't pass (sub_decs ++ decs) to reifyInDec
                 -- above, or else type family defaults can be confused for
                 -- actual instances. See #134.
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name, Info)
info
#if __GLASGOW_HASKELL__ >= 711
reifyInDec Name
n [Dec]
decs (InstanceD Maybe Overlap
_ Cxt
_ Kind
_ [Dec]
sub_decs)
#else
reifyInDec n decs (InstanceD _ _ sub_decs)
#endif
  | Just (Name, Info)
info <- (Dec -> Maybe (Name, Info)) -> [Dec] -> Maybe (Name, Info)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch Dec -> Maybe (Name, Info)
reify_in_instance [Dec]
sub_decs
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name, Info)
info
  where
    reify_in_instance :: Dec -> Maybe (Name, Info)
reify_in_instance dec :: Dec
dec@(DataInstD {})    = Name -> [Dec] -> Dec -> Maybe (Name, Info)
reifyInDec Name
n ([Dec]
sub_decs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
decs) Dec
dec
    reify_in_instance dec :: Dec
dec@(NewtypeInstD {}) = Name -> [Dec] -> Dec -> Maybe (Name, Info)
reifyInDec Name
n ([Dec]
sub_decs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
decs) Dec
dec
    reify_in_instance Dec
_                     = Maybe (Name, Info)
forall a. Maybe a
Nothing
#if __GLASGOW_HASKELL__ >= 807
reifyInDec Name
n [Dec]
decs (DataInstD Cxt
_ Maybe [TyVarBndrUnit]
_ Kind
lhs Maybe Kind
_ [Con]
cons [DerivClause]
_)
  | (ConT Name
ty_name, [TypeArg]
tys) <- Kind -> (Kind, [TypeArg])
unfoldType Kind
lhs
  , Just (Name, Info)
info <- Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Name, Info)
maybeReifyCon Name
n [Dec]
decs Name
ty_name [TypeArg]
tys [Con]
cons
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name, Info)
info
reifyInDec Name
n [Dec]
decs (NewtypeInstD Cxt
_ Maybe [TyVarBndrUnit]
_ Kind
lhs Maybe Kind
_ Con
con [DerivClause]
_)
  | (ConT Name
ty_name, [TypeArg]
tys) <- Kind -> (Kind, [TypeArg])
unfoldType Kind
lhs
  , Just (Name, Info)
info <- Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Name, Info)
maybeReifyCon Name
n [Dec]
decs Name
ty_name [TypeArg]
tys [Con
con]
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name, Info)
info
#elif __GLASGOW_HASKELL__ > 710
reifyInDec n decs (DataInstD _ ty_name tys _ cons _)
  | Just info <- maybeReifyCon n decs ty_name (map TANormal tys) cons
  = Just info
reifyInDec n decs (NewtypeInstD _ ty_name tys _ con _)
  | Just info <- maybeReifyCon n decs ty_name (map TANormal tys) [con]
  = Just info
#else
reifyInDec n decs (DataInstD _ ty_name tys cons _)
  | Just info <- maybeReifyCon n decs ty_name (map TANormal tys) cons
  = Just info
reifyInDec n decs (NewtypeInstD _ ty_name tys con _)
  | Just info <- maybeReifyCon n decs ty_name (map TANormal tys) [con]
  = Just info
#endif

reifyInDec Name
_ [Dec]
_ Dec
_ = Maybe (Name, Info)
forall a. Maybe a
Nothing

maybeReifyCon :: Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Named Info)
maybeReifyCon :: Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Name, Info)
maybeReifyCon Name
n [Dec]
_decs Name
ty_name [TypeArg]
ty_args [Con]
cons
  | Just (Name
n', Con
con) <- Name -> [Con] -> Maybe (Named Con)
findCon Name
n [Con]
cons
    -- See Note [Use unSigType in maybeReifyCon]
  , let full_con_ty :: Kind
full_con_ty = Kind -> Kind
unSigType (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$ [TyVarBndrUnit] -> Kind -> Con -> Kind
con_to_type [TyVarBndrUnit]
h98_tvbs Kind
h98_res_ty Con
con
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just ( Name
n', Name -> Kind -> Name -> Info
DataConI Name
n Kind
full_con_ty Name
ty_name
#if __GLASGOW_HASKELL__ < 800
                        fixity
#endif
         )

  | Just (Name
n', RecSelInfo
rec_sel_info) <- Name -> [Con] -> Maybe (Named RecSelInfo)
findRecSelector Name
n [Con]
cons
  , let ([TyVarBndrUnit]
tvbs, Kind
sel_ty, Kind
con_res_ty) = RecSelInfo -> ([TyVarBndrUnit], Kind, Kind)
extract_rec_sel_info RecSelInfo
rec_sel_info
        -- See Note [Use unSigType in maybeReifyCon]
        full_sel_ty :: Kind
full_sel_ty = Kind -> Kind
unSigType (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$ [TyVarBndrUnit] -> Cxt -> Kind -> Kind
maybeForallT [TyVarBndrUnit]
tvbs [] (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$ Cxt -> Kind -> Kind
mkArrows [Kind
con_res_ty] Kind
sel_ty
      -- we don't try to ferret out naughty record selectors.
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just ( Name
n', Name -> Kind -> Maybe Dec -> Info
VarI Name
n Kind
full_sel_ty Maybe Dec
forall a. Maybe a
Nothing
#if __GLASGOW_HASKELL__ < 800
                    fixity
#endif
         )
  where
    extract_rec_sel_info :: RecSelInfo -> ([TyVarBndrUnit], Type, Type)
      -- Returns ( Selector type variable binders
      --         , Record field type
      --         , constructor result type )
    extract_rec_sel_info :: RecSelInfo -> ([TyVarBndrUnit], Kind, Kind)
extract_rec_sel_info RecSelInfo
rec_sel_info =
      case RecSelInfo
rec_sel_info of
        RecSelH98 Kind
sel_ty -> ([TyVarBndrUnit]
h98_tvbs, Kind
sel_ty, Kind
h98_res_ty)
        RecSelGADT Kind
sel_ty Kind
con_res_ty ->
          ( Cxt -> [TyVarBndrUnit]
freeVariablesWellScoped [Kind
con_res_ty, Kind
sel_ty]
          , Kind
sel_ty, Kind
con_res_ty)

    h98_tvbs :: [TyVarBndrUnit]
h98_tvbs   = Cxt -> [TyVarBndrUnit]
freeVariablesWellScoped (Cxt -> [TyVarBndrUnit]) -> Cxt -> [TyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$ (TypeArg -> Kind) -> [TypeArg] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map TypeArg -> Kind
probablyWrongUnTypeArg [TypeArg]
ty_args
    h98_res_ty :: Kind
h98_res_ty = Kind -> [TypeArg] -> Kind
applyType (Name -> Kind
ConT Name
ty_name) [TypeArg]
ty_args

#if __GLASGOW_HASKELL__ < 800
    fixity = fromMaybe defaultFixity $ reifyFixityInDecs n _decs
#endif
maybeReifyCon Name
_ [Dec]
_ Name
_ [TypeArg]
_ [Con]
_ = Maybe (Name, Info)
forall a. Maybe a
Nothing

{-
Note [Use unSigType in maybeReifyCon]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Make sure to call unSigType on the type of a reified data constructor or
record selector. Otherwise, if you have this:

  data D (a :: k) = MkD { unD :: Proxy a }

Then the type of unD will be reified as:

  unD :: forall k (a :: k). D (a :: k) -> Proxy a

This is contrast to GHC's own reification, which will produce `D a`
(without the explicit kind signature) as the type of the first argument.
-}

-- Reverse-engineer the type of a data constructor.
con_to_type :: [TyVarBndrUnit] -- The type variables bound by a data type head.
                               -- Only used for Haskell98-style constructors.
            -> Type            -- The constructor result type.
                               -- Only used for Haskell98-style constructors.
            -> Con -> Type
con_to_type :: [TyVarBndrUnit] -> Kind -> Con -> Kind
con_to_type [TyVarBndrUnit]
h98_tvbs Kind
h98_result_ty Con
con =
  case Con -> (Bool, Kind)
go Con
con of
    (Bool
is_gadt, Kind
ty) | Bool
is_gadt   -> Kind
ty
                  | Bool
otherwise -> [TyVarBndrUnit] -> Cxt -> Kind -> Kind
maybeForallT [TyVarBndrUnit]
h98_tvbs [] Kind
ty
  where
    -- Note that we deliberately ignore linear types and use (->) everywhere.
    -- See [Gracefully handling linear types] in L.H.TH.Desugar.Core.
    go :: Con -> (Bool, Type) -- The Bool is True when dealing with a GADT
    go :: Con -> (Bool, Kind)
go (NormalC Name
_ [BangType]
stys)       = (Bool
False, Cxt -> Kind -> Kind
mkArrows ((BangType -> Kind) -> [BangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Kind
forall a b. (a, b) -> b
snd    [BangType]
stys)  Kind
h98_result_ty)
    go (RecC Name
_ [VarBangType]
vstys)         = (Bool
False, Cxt -> Kind -> Kind
mkArrows ((VarBangType -> Kind) -> [VarBangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Kind
forall a b c. (a, b, c) -> c
thdOf3 [VarBangType]
vstys) Kind
h98_result_ty)
    go (InfixC BangType
t1 Name
_ BangType
t2)       = (Bool
False, Cxt -> Kind -> Kind
mkArrows ((BangType -> Kind) -> [BangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Kind
forall a b. (a, b) -> b
snd [BangType
t1, BangType
t2]) Kind
h98_result_ty)
    go (ForallC [TyVarBndrUnit]
bndrs Cxt
cxt Con
c)  = (Kind -> Kind) -> (Bool, Kind) -> (Bool, Kind)
forall a b c. (a -> b) -> (c, a) -> (c, b)
liftSnd ([TyVarBndrUnit] -> Cxt -> Kind -> Kind
ForallT [TyVarBndrUnit]
bndrs Cxt
cxt) (Con -> (Bool, Kind)
go Con
c)
#if __GLASGOW_HASKELL__ > 710
    go (GadtC [Name]
_ [BangType]
stys Kind
rty)     = (Bool
True, Cxt -> Kind -> Kind
mkArrows ((BangType -> Kind) -> [BangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Kind
forall a b. (a, b) -> b
snd    [BangType]
stys)  Kind
rty)
    go (RecGadtC [Name]
_ [VarBangType]
vstys Kind
rty) = (Bool
True, Cxt -> Kind -> Kind
mkArrows ((VarBangType -> Kind) -> [VarBangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Kind
forall a b c. (a, b, c) -> c
thdOf3 [VarBangType]
vstys) Kind
rty)
#endif

mkVarI :: Name -> [Dec] -> Info
mkVarI :: Name -> [Dec] -> Info
mkVarI Name
n [Dec]
decs = Name -> [Dec] -> Kind -> Info
mkVarITy Name
n [Dec]
decs (Kind -> (Named Kind -> Kind) -> Maybe (Named Kind) -> Kind
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> Kind
no_type Name
n) Named Kind -> Kind
forall a b. (a, b) -> b
snd (Maybe (Named Kind) -> Kind) -> Maybe (Named Kind) -> Kind
forall a b. (a -> b) -> a -> b
$ Name -> [Dec] -> Maybe (Named Kind)
findType Name
n [Dec]
decs)

mkVarITy :: Name -> [Dec] -> Type -> Info
#if __GLASGOW_HASKELL__ > 710
mkVarITy :: Name -> [Dec] -> Kind -> Info
mkVarITy Name
n [Dec]
_decs Kind
ty = Name -> Kind -> Maybe Dec -> Info
VarI Name
n Kind
ty Maybe Dec
forall a. Maybe a
Nothing
#else
mkVarITy n decs ty = VarI n ty Nothing (fromMaybe defaultFixity $
                                        reifyFixityInDecs n decs)
#endif

findType :: Name -> [Dec] -> Maybe (Named Type)
findType :: Name -> [Dec] -> Maybe (Named Kind)
findType Name
n = (Dec -> Maybe (Named Kind)) -> [Dec] -> Maybe (Named Kind)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch Dec -> Maybe (Named Kind)
match_type
  where
    match_type :: Dec -> Maybe (Named Kind)
match_type (SigD Name
n' Kind
ty) | Name
n Name -> Name -> Bool
`nameMatches` Name
n' = Named Kind -> Maybe (Named Kind)
forall a. a -> Maybe a
Just (Name
n', Kind
ty)
    match_type Dec
_                                 = Maybe (Named Kind)
forall a. Maybe a
Nothing

#if __GLASGOW_HASKELL__ >= 801
mkPatSynI :: Name -> [Dec] -> Info
mkPatSynI :: Name -> [Dec] -> Info
mkPatSynI Name
n [Dec]
decs = Name -> Kind -> Info
PatSynI Name
n (Kind -> Maybe Kind -> Kind
forall a. a -> Maybe a -> a
fromMaybe (Name -> Kind
no_type Name
n) (Maybe Kind -> Kind) -> Maybe Kind -> Kind
forall a b. (a -> b) -> a -> b
$ Name -> [Dec] -> Maybe Kind
findPatSynType Name
n [Dec]
decs)

findPatSynType :: Name -> [Dec] -> Maybe PatSynType
findPatSynType :: Name -> [Dec] -> Maybe Kind
findPatSynType Name
n = (Dec -> Maybe Kind) -> [Dec] -> Maybe Kind
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch Dec -> Maybe Kind
match_pat_syn_type
  where
    match_pat_syn_type :: Dec -> Maybe Kind
match_pat_syn_type (PatSynSigD Name
n' Kind
psty) | Name
n Name -> Name -> Bool
`nameMatches` Name
n' = Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
psty
    match_pat_syn_type Dec
_                                         = Maybe Kind
forall a. Maybe a
Nothing
#endif

no_type :: Name -> Type
no_type :: Name -> Kind
no_type Name
n = String -> Kind
forall a. HasCallStack => String -> a
error (String -> Kind) -> String -> Kind
forall a b. (a -> b) -> a -> b
$ String
"No type information found in local declaration for "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n

findInstances :: Name -> [Dec] -> [Dec]
findInstances :: Name -> [Dec] -> [Dec]
findInstances Name
n = (Dec -> Dec) -> [Dec] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Dec
stripInstanceDec ([Dec] -> [Dec]) -> ([Dec] -> [Dec]) -> [Dec] -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dec -> [Dec]) -> [Dec] -> [Dec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Dec -> [Dec]
match_instance
  where
#if __GLASGOW_HASKELL__ >= 711
    match_instance :: Dec -> [Dec]
match_instance d :: Dec
d@(InstanceD Maybe Overlap
_ Cxt
_ Kind
ty [Dec]
_)
#else
    match_instance d@(InstanceD _ ty _)
#endif
                                               | ConT Name
n' <- Kind -> Kind
ty_head Kind
ty
                                               , Name
n Name -> Name -> Bool
`nameMatches` Name
n' = [Dec
d]
#if __GLASGOW_HASKELL__ >= 807
    match_instance (DataInstD Cxt
ctxt Maybe [TyVarBndrUnit]
_ Kind
lhs Maybe Kind
mk [Con]
cons [DerivClause]
derivs)
                                                  | ConT Name
n' <- Kind -> Kind
ty_head Kind
lhs
                                                  , Name
n Name -> Name -> Bool
`nameMatches` Name
n' = [Dec
d]
      where
        mtvbs :: Maybe [TyVarBndrUnit]
mtvbs = Cxt -> Kind -> Maybe Kind -> Maybe [TyVarBndrUnit]
rejig_data_inst_tvbs Cxt
ctxt Kind
lhs Maybe Kind
mk
        d :: Dec
d = Cxt
-> Maybe [TyVarBndrUnit]
-> Kind
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataInstD Cxt
ctxt Maybe [TyVarBndrUnit]
mtvbs Kind
lhs Maybe Kind
mk [Con]
cons [DerivClause]
derivs
    match_instance (NewtypeInstD Cxt
ctxt Maybe [TyVarBndrUnit]
_ Kind
lhs Maybe Kind
mk Con
con [DerivClause]
derivs)
                                                  | ConT Name
n' <- Kind -> Kind
ty_head Kind
lhs
                                                  , Name
n Name -> Name -> Bool
`nameMatches` Name
n' = [Dec
d]
      where
        mtvbs :: Maybe [TyVarBndrUnit]
mtvbs = Cxt -> Kind -> Maybe Kind -> Maybe [TyVarBndrUnit]
rejig_data_inst_tvbs Cxt
ctxt Kind
lhs Maybe Kind
mk
        d :: Dec
d = Cxt
-> Maybe [TyVarBndrUnit]
-> Kind
-> Maybe Kind
-> Con
-> [DerivClause]
-> Dec
NewtypeInstD Cxt
ctxt Maybe [TyVarBndrUnit]
mtvbs Kind
lhs Maybe Kind
mk Con
con [DerivClause]
derivs
#elif __GLASGOW_HASKELL__ > 710
    match_instance d@(DataInstD _ n' _ _ _ _)    | n `nameMatches` n' = [d]
    match_instance d@(NewtypeInstD _ n' _ _ _ _) | n `nameMatches` n' = [d]
#else
    match_instance d@(DataInstD _ n' _ _ _)    | n `nameMatches` n' = [d]
    match_instance d@(NewtypeInstD _ n' _ _ _) | n `nameMatches` n' = [d]
#endif
#if __GLASGOW_HASKELL__ >= 807
    match_instance (TySynInstD (TySynEqn Maybe [TyVarBndrUnit]
_ Kind
lhs Kind
rhs))
                                               | ConT Name
n' <- Kind -> Kind
ty_head Kind
lhs
                                               , Name
n Name -> Name -> Bool
`nameMatches` Name
n' = [Dec
d]
      where
        mtvbs :: Maybe [TyVarBndrUnit]
mtvbs = Cxt -> Maybe [TyVarBndrUnit]
rejig_tvbs [Kind
lhs, Kind
rhs]
        d :: Dec
d = TySynEqn -> Dec
TySynInstD (Maybe [TyVarBndrUnit] -> Kind -> Kind -> TySynEqn
TySynEqn Maybe [TyVarBndrUnit]
mtvbs Kind
lhs Kind
rhs)
#else
    match_instance d@(TySynInstD n' _)         | n `nameMatches` n' = [d]
#endif

#if __GLASGOW_HASKELL__ >= 711
    match_instance (InstanceD Maybe Overlap
_ Cxt
_ Kind
_ [Dec]
decs)
#else
    match_instance (InstanceD _ _ decs)
#endif
                                        = (Dec -> [Dec]) -> [Dec] -> [Dec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Dec -> [Dec]
match_instance [Dec]
decs
    match_instance Dec
_                    = []

#if __GLASGOW_HASKELL__ >= 807
    -- See Note [Rejigging reified type family equations variable binders]
    -- for why this is necessary.
    rejig_tvbs :: [Type] -> Maybe [TyVarBndrUnit]
    rejig_tvbs :: Cxt -> Maybe [TyVarBndrUnit]
rejig_tvbs Cxt
ts =
      let tvbs :: [TyVarBndrUnit]
tvbs = Cxt -> [TyVarBndrUnit]
freeVariablesWellScoped Cxt
ts
      in if [TyVarBndrUnit] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndrUnit]
tvbs
         then Maybe [TyVarBndrUnit]
forall a. Maybe a
Nothing
         else [TyVarBndrUnit] -> Maybe [TyVarBndrUnit]
forall a. a -> Maybe a
Just [TyVarBndrUnit]
tvbs

    rejig_data_inst_tvbs :: Cxt -> Type -> Maybe Kind -> Maybe [TyVarBndrUnit]
    rejig_data_inst_tvbs :: Cxt -> Kind -> Maybe Kind -> Maybe [TyVarBndrUnit]
rejig_data_inst_tvbs Cxt
cxt Kind
lhs Maybe Kind
mk =
      Cxt -> Maybe [TyVarBndrUnit]
rejig_tvbs (Cxt -> Maybe [TyVarBndrUnit]) -> Cxt -> Maybe [TyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$ Cxt
cxt Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ [Kind
lhs] Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Maybe Kind -> Cxt
forall a. Maybe a -> [a]
maybeToList Maybe Kind
mk
#endif

    ty_head :: Kind -> Kind
ty_head = (Kind, [TypeArg]) -> Kind
forall a b. (a, b) -> a
fst ((Kind, [TypeArg]) -> Kind)
-> (Kind -> (Kind, [TypeArg])) -> Kind -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> (Kind, [TypeArg])
unfoldType

{-
Note [Rejigging reified type family equations variable binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When reifying a type family instance (on GHC 8.8 or later), which quantified
type variables do you use? This might seem like a strange question to ask since
these instances already come equipped with a field of type `Maybe [TyVarBndr]`,
but it's not always the case that you want to use exactly that field. Here is
an example to better explain it:

  class C a where
    type T b a
  instance C (Maybe a) where
    type forall b. T b (Maybe a) = a

If the above instance were quoted, it would give you `Just [PlainTV b]`. But if
you were to reify ''T (and therefore retrieve the instance for T), you wouldn't
want to use that as your list of type variable binders! This is because
reifiying any type family always presents the information as though the type
family were top-level. Therefore, reifying T (in GHC, at least) would yield:

  type family T b a
  type instance forall b a. T b (Maybe a) = a

Note that we quantify over `b` *and* `a` here, not just `b`. To emulate this
GHC quirk, whenever we reify any type family instance, we just ignore the field
of type `Maybe [TyVarBndr]` and quantify over the instance afresh. It's a bit
tedious, but it gets the job done. (This is accomplished by the rejig_tvbs
function.)
-}

-- Consider the following class declaration:
--
--   [d| class C a where
--         method :: a -> b -> a |]
--
-- When reifying C locally, quantifyClassDecMethods serves two purposes:
--
-- 1. It quantifies the class method's local type variables. To illustrate this
--    point, this is how GHC would reify C:
--
--      class C a where
--        method :: forall b. a -> b -> a
--
--    Notice the presence of the explicit `forall b.`. quantifyClassDecMethods
--    performs this explicit quantification if necessary (as in the case in the
--    local C declaration, where `b` is implicitly quantified.)
-- 2. It emulates a quirk in the way old versions of GHC would reify class
--    declarations (Trac #15551). On versions of GHC older than 8.8, it would
--    reify C like so:
--
--      class C a where
--        method :: forall a. C a => forall b. a -> b -> a
--
--    Notice how GHC has added the (totally extraneous) `forall a. C a =>`
--    part! This is weird, but our primary goal in this module is to mimic
--    GHC's reification, so we play the part by adding the `forall`/class
--    context to each class method in quantifyClassDecMethods.
--
--    Since Trac #15551 was fixed in GHC 8.8, this function doesn't perform
--    this step on 8.7 or later.
quantifyClassDecMethods :: Dec -> Dec
quantifyClassDecMethods :: Dec -> Dec
quantifyClassDecMethods (ClassD Cxt
cxt Name
cls_name [TyVarBndrUnit]
cls_tvbs [FunDep]
fds [Dec]
sub_decs)
  = Cxt -> Name -> [TyVarBndrUnit] -> [FunDep] -> [Dec] -> Dec
ClassD Cxt
cxt Name
cls_name [TyVarBndrUnit]
cls_tvbs [FunDep]
fds [Dec]
sub_decs'
  where
    sub_decs' :: [Dec]
sub_decs' = (Dec -> Maybe Dec) -> [Dec] -> [Dec]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Dec -> Maybe Dec
go [Dec]
sub_decs
    go :: Dec -> Maybe Dec
go (SigD Name
n Kind
ty) =
      Dec -> Maybe Dec
forall a. a -> Maybe a
Just (Dec -> Maybe Dec) -> Dec -> Maybe Dec
forall a b. (a -> b) -> a -> b
$ Name -> Kind -> Dec
SigD Name
n
           (Kind -> Dec) -> Kind -> Dec
forall a b. (a -> b) -> a -> b
$ Name -> [TyVarBndrUnit] -> Bool -> Kind -> Kind
quantifyClassMethodType Name
cls_name [TyVarBndrUnit]
cls_tvbs Bool
prepend_cls Kind
ty
    go d :: Dec
d@(TySynInstD {})      = Dec -> Maybe Dec
forall a. a -> Maybe a
Just Dec
d
#if __GLASGOW_HASKELL__ > 710
    go d :: Dec
d@(OpenTypeFamilyD {}) = Dec -> Maybe Dec
forall a. a -> Maybe a
Just Dec
d
    go d :: Dec
d@(DataFamilyD {})     = Dec -> Maybe Dec
forall a. a -> Maybe a
Just Dec
d
#endif
    go Dec
_           = Maybe Dec
forall a. Maybe a
Nothing

    -- See (2) in the comments for quantifyClassDecMethods.
    prepend_cls :: Bool
#if __GLASGOW_HASKELL__ >= 807
    prepend_cls :: Bool
prepend_cls = Bool
False
#else
    prepend_cls = True
#endif
quantifyClassDecMethods Dec
dec = Dec
dec

-- Add explicit quantification to a class method's type if necessary. In this
-- example:
--
--   [d| class C a where
--         method :: a -> b -> a |]
--
-- If one invokes `quantifyClassMethodType C [a] prepend (a -> b -> a)`, then
-- the output will be:
--
-- 1. `forall a. C a => forall b. a -> b -> a` (if `prepend` is True)
-- 2.                  `forall b. a -> b -> a` (if `prepend` is False)
--
-- Whether you want `prepend` to be True or False depends on the situation.
-- When reifying an entire type class, like C, one does not need to prepend a
-- class context to each of the bundled method types (see the comments for
-- quantifyClassDecMethods), so False is appropriate. When one is only reifying
-- a single class method, like `method`, then one needs the class context to
-- appear in the reified type, so `True` is appropriate.
quantifyClassMethodType
  :: Name            -- ^ The class name.
  -> [TyVarBndrUnit] -- ^ The class's type variable binders.
  -> Bool            -- ^ If 'True', prepend a class predicate.
  -> Type            -- ^ The method type.
  -> Type
quantifyClassMethodType :: Name -> [TyVarBndrUnit] -> Bool -> Kind -> Kind
quantifyClassMethodType Name
cls_name [TyVarBndrUnit]
cls_tvbs Bool
prepend Kind
meth_ty =
  Kind -> Kind
add_cls_cxt Kind
quantified_meth_ty
  where
    add_cls_cxt :: Type -> Type
    add_cls_cxt :: Kind -> Kind
add_cls_cxt
      | Bool
prepend   = [TyVarBndrUnit] -> Cxt -> Kind -> Kind
ForallT (Specificity -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall newFlag oldFlag.
newFlag -> [TyVarBndrUnit] -> [TyVarBndrUnit]
changeTVFlags Specificity
SpecifiedSpec [TyVarBndrUnit]
all_cls_tvbs) Cxt
cls_cxt
      | Bool
otherwise = Kind -> Kind
forall a. a -> a
id

    cls_cxt :: Cxt
#if __GLASGOW_HASKELL__ < 709
    cls_cxt = [ClassP cls_name (map tvbToType cls_tvbs)]
#else
    cls_cxt :: Cxt
cls_cxt = [(Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
cls_name) ((TyVarBndrUnit -> Kind) -> [TyVarBndrUnit] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> Kind
forall flag. TyVarBndrUnit -> Kind
tvbToType [TyVarBndrUnit]
cls_tvbs)]
#endif

    quantified_meth_ty :: Type
    quantified_meth_ty :: Kind
quantified_meth_ty
      | [TyVarBndrUnit] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndrUnit]
meth_tvbs
      = Kind
meth_ty
      | ForallT [TyVarBndrUnit]
meth_tvbs' Cxt
meth_ctxt Kind
meth_tau <- Kind
meth_ty
      = [TyVarBndrUnit] -> Cxt -> Kind -> Kind
ForallT ([TyVarBndrUnit]
meth_tvbs [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a] -> [a]
++ [TyVarBndrUnit]
meth_tvbs') Cxt
meth_ctxt Kind
meth_tau
      | Bool
otherwise
      = [TyVarBndrUnit] -> Cxt -> Kind -> Kind
ForallT [TyVarBndrUnit]
meth_tvbs [] Kind
meth_ty

    meth_tvbs :: [TyVarBndrSpec]
    meth_tvbs :: [TyVarBndrUnit]
meth_tvbs = Specificity -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall newFlag oldFlag.
newFlag -> [TyVarBndrUnit] -> [TyVarBndrUnit]
changeTVFlags Specificity
SpecifiedSpec ([TyVarBndrUnit] -> [TyVarBndrUnit])
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$
                (TyVarBndrUnit -> TyVarBndrUnit -> Bool)
-> [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
List.deleteFirstsBy (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Name -> Name -> Bool)
-> (TyVarBndrUnit -> Name)
-> TyVarBndrUnit
-> TyVarBndrUnit
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TyVarBndrUnit -> Name
forall flag. TyVarBndrUnit -> Name
tvName)
                  (Cxt -> [TyVarBndrUnit]
freeVariablesWellScoped [Kind
meth_ty]) [TyVarBndrUnit]
all_cls_tvbs

    -- Explicitly quantify any kind variables bound by the class, if any.
    all_cls_tvbs :: [TyVarBndrUnit]
    all_cls_tvbs :: [TyVarBndrUnit]
all_cls_tvbs = Cxt -> [TyVarBndrUnit]
freeVariablesWellScoped (Cxt -> [TyVarBndrUnit]) -> Cxt -> [TyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$ (TyVarBndrUnit -> Kind) -> [TyVarBndrUnit] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> Kind
forall flag. TyVarBndrUnit -> Kind
tvbToTypeWithSig [TyVarBndrUnit]
cls_tvbs

stripInstanceDec :: Dec -> Dec
#if __GLASGOW_HASKELL__ >= 711
stripInstanceDec :: Dec -> Dec
stripInstanceDec (InstanceD Maybe Overlap
over Cxt
cxt Kind
ty [Dec]
_) = Maybe Overlap -> Cxt -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
over Cxt
cxt Kind
ty []
#else
stripInstanceDec (InstanceD cxt ty _)      = InstanceD cxt ty []
#endif
stripInstanceDec Dec
dec                       = Dec
dec

mkArrows :: [Type] -> Type -> Type
mkArrows :: Cxt -> Kind -> Kind
mkArrows []     Kind
res_ty = Kind
res_ty
mkArrows (Kind
t:Cxt
ts) Kind
res_ty = Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind
AppT Kind
ArrowT Kind
t) (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$ Cxt -> Kind -> Kind
mkArrows Cxt
ts Kind
res_ty

maybeForallT :: [TyVarBndrUnit] -> Cxt -> Type -> Type
maybeForallT :: [TyVarBndrUnit] -> Cxt -> Kind -> Kind
maybeForallT [TyVarBndrUnit]
tvbs Cxt
cxt Kind
ty
  | [TyVarBndrUnit] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndrUnit]
tvbs Bool -> Bool -> Bool
&& Cxt -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
cxt        = Kind
ty
  | ForallT [TyVarBndrUnit]
tvbs2 Cxt
cxt2 Kind
ty2 <- Kind
ty = [TyVarBndrUnit] -> Cxt -> Kind -> Kind
ForallT ([TyVarBndrUnit]
tvbs_spec [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a] -> [a]
++ [TyVarBndrUnit]
tvbs2) (Cxt
cxt Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Cxt
cxt2) Kind
ty2
  | Bool
otherwise                    = [TyVarBndrUnit] -> Cxt -> Kind -> Kind
ForallT [TyVarBndrUnit]
tvbs_spec Cxt
cxt Kind
ty
  where
    tvbs_spec :: [TyVarBndrUnit]
tvbs_spec = Specificity -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall newFlag oldFlag.
newFlag -> [TyVarBndrUnit] -> [TyVarBndrUnit]
changeTVFlags Specificity
SpecifiedSpec [TyVarBndrUnit]
tvbs

findCon :: Name -> [Con] -> Maybe (Named Con)
findCon :: Name -> [Con] -> Maybe (Named Con)
findCon Name
n = (Con -> Maybe (Named Con)) -> [Con] -> Maybe (Named Con)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch Con -> Maybe (Named Con)
match_con
  where
    match_con :: Con -> Maybe (Named Con)
    match_con :: Con -> Maybe (Named Con)
match_con Con
con =
      case Con
con of
        NormalC Name
n' [BangType]
_  | Name
n Name -> Name -> Bool
`nameMatches` Name
n' -> Named Con -> Maybe (Named Con)
forall a. a -> Maybe a
Just (Name
n', Con
con)
        RecC Name
n' [VarBangType]
_     | Name
n Name -> Name -> Bool
`nameMatches` Name
n' -> Named Con -> Maybe (Named Con)
forall a. a -> Maybe a
Just (Name
n', Con
con)
        InfixC BangType
_ Name
n' BangType
_ | Name
n Name -> Name -> Bool
`nameMatches` Name
n' -> Named Con -> Maybe (Named Con)
forall a. a -> Maybe a
Just (Name
n', Con
con)
        ForallC [TyVarBndrUnit]
_ Cxt
_ Con
c -> case Con -> Maybe (Named Con)
match_con Con
c of
                           Just (Name
n', Con
_) -> Named Con -> Maybe (Named Con)
forall a. a -> Maybe a
Just (Name
n', Con
con)
                           Maybe (Named Con)
Nothing      -> Maybe (Named Con)
forall a. Maybe a
Nothing
#if __GLASGOW_HASKELL__ > 710
        GadtC [Name]
nms [BangType]
_ Kind
_    -> Con -> [Name] -> Maybe (Named Con)
gadt_case Con
con [Name]
nms
        RecGadtC [Name]
nms [VarBangType]
_ Kind
_ -> Con -> [Name] -> Maybe (Named Con)
gadt_case Con
con [Name]
nms
#endif
        Con
_                -> Maybe (Named Con)
forall a. Maybe a
Nothing

#if __GLASGOW_HASKELL__ > 710
    gadt_case :: Con -> [Name] -> Maybe (Named Con)
    gadt_case :: Con -> [Name] -> Maybe (Named Con)
gadt_case Con
con [Name]
nms = case (Name -> Bool) -> [Name] -> Maybe Name
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Name
n Name -> Name -> Bool
`nameMatches`) [Name]
nms of
                          Just Name
n' -> Named Con -> Maybe (Named Con)
forall a. a -> Maybe a
Just (Name
n', Con
con)
                          Maybe Name
Nothing -> Maybe (Named Con)
forall a. Maybe a
Nothing
#endif

data RecSelInfo
  = RecSelH98  Type -- The record field's type
  | RecSelGADT Type -- The record field's type
               Type -- The GADT return type

findRecSelector :: Name -> [Con] -> Maybe (Named RecSelInfo)
findRecSelector :: Name -> [Con] -> Maybe (Named RecSelInfo)
findRecSelector Name
n = (Con -> Maybe (Named RecSelInfo))
-> [Con] -> Maybe (Named RecSelInfo)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch Con -> Maybe (Named RecSelInfo)
match_con
  where
    match_con :: Con -> Maybe (Named RecSelInfo)
    match_con :: Con -> Maybe (Named RecSelInfo)
match_con (RecC Name
_ [VarBangType]
vstys)            = (Named Kind -> Named RecSelInfo)
-> Maybe (Named Kind) -> Maybe (Named RecSelInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Kind -> RecSelInfo) -> Named Kind -> Named RecSelInfo
forall a b c. (a -> b) -> (c, a) -> (c, b)
liftSnd Kind -> RecSelInfo
RecSelH98) (Maybe (Named Kind) -> Maybe (Named RecSelInfo))
-> Maybe (Named Kind) -> Maybe (Named RecSelInfo)
forall a b. (a -> b) -> a -> b
$
                                          (VarBangType -> Maybe (Named Kind))
-> [VarBangType] -> Maybe (Named Kind)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch VarBangType -> Maybe (Named Kind)
forall b b. (Name, b, b) -> Maybe (Name, b)
match_rec_sel [VarBangType]
vstys
#if __GLASGOW_HASKELL__ >= 800
    match_con (RecGadtC [Name]
_ [VarBangType]
vstys Kind
ret_ty) = (Named Kind -> Named RecSelInfo)
-> Maybe (Named Kind) -> Maybe (Named RecSelInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Kind -> RecSelInfo) -> Named Kind -> Named RecSelInfo
forall a b c. (a -> b) -> (c, a) -> (c, b)
liftSnd (Kind -> Kind -> RecSelInfo
`RecSelGADT` Kind
ret_ty)) (Maybe (Named Kind) -> Maybe (Named RecSelInfo))
-> Maybe (Named Kind) -> Maybe (Named RecSelInfo)
forall a b. (a -> b) -> a -> b
$
                                          (VarBangType -> Maybe (Named Kind))
-> [VarBangType] -> Maybe (Named Kind)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch VarBangType -> Maybe (Named Kind)
forall b b. (Name, b, b) -> Maybe (Name, b)
match_rec_sel [VarBangType]
vstys
#endif
    match_con (ForallC [TyVarBndrUnit]
_ Cxt
_ Con
c)           = Con -> Maybe (Named RecSelInfo)
match_con Con
c
    match_con Con
_                         = Maybe (Named RecSelInfo)
forall a. Maybe a
Nothing

    match_rec_sel :: (Name, b, b) -> Maybe (Name, b)
match_rec_sel (Name
n', b
_, b
sel_ty)
      | Name
n Name -> Name -> Bool
`nameMatches` Name
n' = (Name, b) -> Maybe (Name, b)
forall a. a -> Maybe a
Just (Name
n', b
sel_ty)
    match_rec_sel (Name, b, b)
_        = Maybe (Name, b)
forall a. Maybe a
Nothing

---------------------------------
-- Reifying fixities
---------------------------------
--
-- This section allows GHC 7.x to call reifyFixity

#if __GLASGOW_HASKELL__ < 711
qReifyFixity :: Quasi m => Name -> m (Maybe Fixity)
qReifyFixity name = do
  info <- qReify name
  return $ case info of
    ClassOpI _ _ _ fixity -> Just fixity
    DataConI _ _ _ fixity -> Just fixity
    VarI _ _ _ fixity     -> Just fixity
    _                     -> Nothing

{- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For
example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then
@reifyFixity 'foo@ would return @'Just' ('Fixity' 7 'InfixR')@. If the function
@bar@ does not have a fixity declaration, then @reifyFixity 'bar@ returns
'Nothing', so you may assume @bar@ has 'defaultFixity'.
-}
reifyFixity :: Name -> Q (Maybe Fixity)
reifyFixity = qReifyFixity
#endif

-- | Like 'reifyWithLocals_maybe', but for fixities. Note that a return value
-- of @Nothing@ might mean that the name is not in scope, or it might mean
-- that the name has no assigned fixity. (Use 'reifyWithLocals_maybe' if
-- you really need to tell the difference.)
reifyFixityWithLocals :: DsMonad q => Name -> q (Maybe Fixity)
reifyFixityWithLocals :: Name -> q (Maybe Fixity)
reifyFixityWithLocals Name
name = q (Maybe Fixity) -> q (Maybe Fixity) -> q (Maybe Fixity)
forall (m :: * -> *) a. Quasi m => m a -> m a -> m a
qRecover
  (Maybe Fixity -> q (Maybe Fixity)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Fixity -> q (Maybe Fixity))
-> ([Dec] -> Maybe Fixity) -> [Dec] -> q (Maybe Fixity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Dec] -> Maybe Fixity
reifyFixityInDecs Name
name ([Dec] -> q (Maybe Fixity)) -> q [Dec] -> q (Maybe Fixity)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< q [Dec]
forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations)
  (Name -> q (Maybe Fixity)
forall (m :: * -> *). Quasi m => Name -> m (Maybe Fixity)
qReifyFixity Name
name)

--------------------------------------
-- Reifying types
--------------------------------------
--
-- This section allows GHC <8.9 to call reifyFixity

#if __GLASGOW_HASKELL__ < 809
qReifyType :: forall m. Quasi m => Name -> m Type
qReifyType name = do
  info <- qReify name
  case infoType info <|> info_kind info of
    Just t  -> return t
    Nothing -> fail $ "Could not reify the full type of " ++ nameBase name
  where
    info_kind :: Info -> Maybe Kind
    info_kind info = do
      dec <- case info of
               ClassI d _  -> Just d
               TyConI d    -> Just d
               FamilyI d _ -> Just d
               _           -> Nothing
      match_cusk name dec

{- | @reifyType nm@ attempts to find the type or kind of @nm@. For example,
@reifyType 'not@   returns @Bool -> Bool@, and
@reifyType ''Bool@ returns @Type@.
This works even if there's no explicit signature and the type or kind is inferred.
-}
reifyType :: Name -> Q Type
reifyType = qReifyType
#endif

-- | Like 'reifyTypeWithLocals_maybe', but throws an exception upon failure,
-- warning the user about separating splices.
reifyTypeWithLocals :: DsMonad q => Name -> q Type
reifyTypeWithLocals :: Name -> q Kind
reifyTypeWithLocals Name
name = do
  Maybe Kind
m_info <- Name -> q (Maybe Kind)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe Kind)
reifyTypeWithLocals_maybe Name
name
  case Maybe Kind
m_info of
    Maybe Kind
Nothing -> Name -> q Kind
forall (m :: * -> *) a. MonadFail m => Name -> m a
reifyFail Name
name
    Just Kind
i  -> Kind -> q Kind
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
i

-- | Like 'reifyWithLocals_maybe' but for types and kinds. Note that a return
-- value of @Nothing@ might mean that the name is not in scope, or it might
-- mean that the full type of the name cannot be determined. (Use
-- 'reifyWithLocals_maybe' if you really need to tell the difference.)
reifyTypeWithLocals_maybe :: DsMonad q => Name -> q (Maybe Type)
reifyTypeWithLocals_maybe :: Name -> q (Maybe Kind)
reifyTypeWithLocals_maybe Name
name = do
#if __GLASGOW_HASKELL__ >= 809
  Bool
cusks <- Extension -> q Bool
forall (m :: * -> *). Quasi m => Extension -> m Bool
qIsExtEnabled Extension
CUSKs
#else
  -- On earlier GHCs, the behavior of -XCUSKs was the norm.
  let cusks = True
#endif
  q (Maybe Kind) -> q (Maybe Kind) -> q (Maybe Kind)
forall (m :: * -> *) a. Quasi m => m a -> m a -> m a
qRecover (Maybe Kind -> q (Maybe Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Kind -> q (Maybe Kind))
-> ([Dec] -> Maybe Kind) -> [Dec] -> q (Maybe Kind)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Name -> [Dec] -> Maybe Kind
reifyTypeInDecs Bool
cusks Name
name ([Dec] -> q (Maybe Kind)) -> q [Dec] -> q (Maybe Kind)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< q [Dec]
forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations)
           (Kind -> Maybe Kind
forall a. a -> Maybe a
Just (Kind -> Maybe Kind) -> q Kind -> q (Maybe Kind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> q Kind
forall (m :: * -> *). Quasi m => Name -> m Kind
qReifyType Name
name)

-- | Look through a list of declarations and return its full type, if
-- available.
reifyTypeInDecs :: Bool -> Name -> [Dec] -> Maybe Type
reifyTypeInDecs :: Bool -> Name -> [Dec] -> Maybe Kind
reifyTypeInDecs Bool
cusks Name
name [Dec]
decs =
  (Name -> [Dec] -> Maybe Info
reifyInDecs Name
name [Dec]
decs Maybe Info -> (Info -> Maybe Kind) -> Maybe Kind
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Info -> Maybe Kind
infoType) Maybe Kind -> Maybe Kind -> Maybe Kind
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Name -> [Dec] -> Maybe Kind
findKind Bool
cusks Name
name [Dec]
decs

-- Extract the type information (if any) contained in an Info.
infoType :: Info -> Maybe Type
infoType :: Info -> Maybe Kind
infoType Info
info =
  case Info
info of
    ClassOpI Name
_ Kind
t Name
_
#if __GLASGOW_HASKELL__ < 800
             _
#endif
                   -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
t
    DataConI Name
_ Kind
t Name
_
#if __GLASGOW_HASKELL__ < 800
             _
#endif
                   -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
t
    VarI Name
_ Kind
t Maybe Dec
_
#if __GLASGOW_HASKELL__ < 800
         _
#endif
                   -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
t
    TyVarI Name
_ Kind
t     -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
t
#if __GLASGOW_HASKELL__ >= 802
    PatSynI Name
_ Kind
t    -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
t
#endif
    Info
_              -> Maybe Kind
forall a. Maybe a
Nothing

-- Like findType, but instead searching for kind signatures.
-- This mostly searches through `KiSigD`s, but if the -XCUSKs extension is
-- enabled, this also retrieves kinds for declarations with CUSKs.
findKind :: Bool -- Is -XCUSKs enabled?
         -> Name -> [Dec] -> Maybe Kind
findKind :: Bool -> Name -> [Dec] -> Maybe Kind
findKind Bool
cusks Name
name [Dec]
decls =
      (Dec -> Maybe Kind) -> [Dec] -> Maybe Kind
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch (Name -> [Dec] -> Dec -> Maybe Kind
match_kind_sig Name
name [Dec]
decls) [Dec]
decls
  Maybe Kind -> Maybe Kind -> Maybe Kind
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Maybe Kind -> Maybe Kind
forall (f :: * -> *) a. Alternative f => Bool -> f a -> f a
whenAlt Bool
cusks ((Dec -> Maybe Kind) -> [Dec] -> Maybe Kind
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch (Name -> Dec -> Maybe Kind
match_cusk Name
name) [Dec]
decls)

-- Look for a declaration's kind by searching for its standalone kind
-- signature, if available.
match_kind_sig :: Name -> [Dec] -> Dec -> Maybe Kind
match_kind_sig :: Name -> [Dec] -> Dec -> Maybe Kind
match_kind_sig Name
n [Dec]
decs (ClassD Cxt
_ Name
n' [TyVarBndrUnit]
tvbs [FunDep]
_ [Dec]
sub_decs)
  -- If a class has a standalone kind signature, then we can determine the
  -- full kind of its associated types in 99% of cases.
  -- See Note [The limitations of standalone kind signatures] for what
  -- happens in the other 1% of cases.
  | Just Kind
ki <- (Dec -> Maybe Kind) -> [Dec] -> Maybe Kind
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch (Name -> Dec -> Maybe Kind
find_kind_sig Name
n') [Dec]
decs
  , let (FunArgs
arg_kis, Kind
_res_ki) = Kind -> (FunArgs, Kind)
unravelType Kind
ki
        mb_vis_arg_kis :: [Maybe Kind]
mb_vis_arg_kis     = (VisFunArg -> Maybe Kind) -> [VisFunArg] -> [Maybe Kind]
forall a b. (a -> b) -> [a] -> [b]
map VisFunArg -> Maybe Kind
vis_arg_kind_maybe ([VisFunArg] -> [Maybe Kind]) -> [VisFunArg] -> [Maybe Kind]
forall a b. (a -> b) -> a -> b
$ FunArgs -> [VisFunArg]
filterVisFunArgs FunArgs
arg_kis
        cls_tvb_kind_map :: Map Name Kind
cls_tvb_kind_map   =
          [Named Kind] -> Map Name Kind
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (TyVarBndrUnit -> Name
forall flag. TyVarBndrUnit -> Name
tvName TyVarBndrUnit
tvb, Kind
tvb_kind)
                       | (TyVarBndrUnit
tvb, Maybe Kind
mb_vis_arg_ki) <- [TyVarBndrUnit] -> [Maybe Kind] -> [(TyVarBndrUnit, Maybe Kind)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TyVarBndrUnit]
tvbs [Maybe Kind]
mb_vis_arg_kis
                       , Just Kind
tvb_kind <- [Maybe Kind
mb_vis_arg_ki Maybe Kind -> Maybe Kind -> Maybe Kind
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TyVarBndrUnit -> Maybe Kind
forall flag. TyVarBndrUnit -> Maybe Kind
tvb_kind_maybe TyVarBndrUnit
tvb]
                       ]
  = (Dec -> Maybe Kind) -> [Dec] -> Maybe Kind
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch (Name -> Map Name Kind -> Dec -> Maybe Kind
find_assoc_type_kind Name
n Map Name Kind
cls_tvb_kind_map) [Dec]
sub_decs
match_kind_sig Name
n [Dec]
_ Dec
dec = Name -> Dec -> Maybe Kind
find_kind_sig Name
n Dec
dec

find_kind_sig :: Name -> Dec -> Maybe Kind
#if __GLASGOW_HASKELL__ >= 809
find_kind_sig :: Name -> Dec -> Maybe Kind
find_kind_sig Name
n (KiSigD Name
n' Kind
ki)
  | Name
n Name -> Name -> Bool
`nameMatches` Name
n' = Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
ki
#endif
find_kind_sig Name
_ Dec
_ = Maybe Kind
forall a. Maybe a
Nothing

-- Compute a declaration's kind by retrieving its CUSK, if it has one.
-- This is only done when -XCUSKs is enabled, or on older GHCs where
-- CUSKs were the only means of specifying this information.
match_cusk :: Name -> Dec -> Maybe Kind
#if __GLASGOW_HASKELL__ >= 800
match_cusk :: Name -> Dec -> Maybe Kind
match_cusk Name
n (DataD Cxt
_ Name
n' [TyVarBndrUnit]
tvbs Maybe Kind
m_ki [Con]
_ [DerivClause]
_)
  | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
  = [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
datatype_kind [TyVarBndrUnit]
tvbs Maybe Kind
m_ki
match_cusk Name
n (NewtypeD Cxt
_ Name
n' [TyVarBndrUnit]
tvbs Maybe Kind
m_ki Con
_ [DerivClause]
_)
  | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
  = [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
datatype_kind [TyVarBndrUnit]
tvbs Maybe Kind
m_ki
match_cusk Name
n (DataFamilyD Name
n' [TyVarBndrUnit]
tvbs Maybe Kind
m_ki)
  | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
  = [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
open_ty_fam_kind [TyVarBndrUnit]
tvbs Maybe Kind
m_ki
match_cusk Name
n (OpenTypeFamilyD (TypeFamilyHead Name
n' [TyVarBndrUnit]
tvbs FamilyResultSig
res_sig Maybe InjectivityAnn
_))
  | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
  = [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
open_ty_fam_kind [TyVarBndrUnit]
tvbs (FamilyResultSig -> Maybe Kind
res_sig_to_kind FamilyResultSig
res_sig)
match_cusk Name
n (ClosedTypeFamilyD (TypeFamilyHead Name
n' [TyVarBndrUnit]
tvbs FamilyResultSig
res_sig Maybe InjectivityAnn
_) [TySynEqn]
_)
  | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
  = [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
closed_ty_fam_kind [TyVarBndrUnit]
tvbs (FamilyResultSig -> Maybe Kind
res_sig_to_kind FamilyResultSig
res_sig)
#else
match_cusk n (DataD _ n' tvbs _ _)
  | n `nameMatches` n'
  = datatype_kind tvbs Nothing
match_cusk n (NewtypeD _ n' tvbs _ _)
  | n `nameMatches` n'
  = datatype_kind tvbs Nothing
match_cusk n (FamilyD _ n' tvbs m_ki)
  | n `nameMatches` n'
  = open_ty_fam_kind tvbs m_ki
match_cusk n (ClosedTypeFamilyD n' tvbs m_ki _)
  | n `nameMatches` n'
  = closed_ty_fam_kind tvbs m_ki
#endif
match_cusk Name
n (TySynD Name
n' [TyVarBndrUnit]
tvbs Kind
rhs)
  | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
  = [TyVarBndrUnit] -> Kind -> Maybe Kind
ty_syn_kind [TyVarBndrUnit]
tvbs Kind
rhs
match_cusk Name
n (ClassD Cxt
_ Name
n' [TyVarBndrUnit]
tvbs [FunDep]
_ [Dec]
sub_decs)
  | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
  = [TyVarBndrUnit] -> Maybe Kind
class_kind [TyVarBndrUnit]
tvbs
  | -- An associated type family can only have a CUSK if its parent class
    -- also has a CUSK.
    (TyVarBndrUnit -> Bool) -> [TyVarBndrUnit] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TyVarBndrUnit -> Bool
forall flag. TyVarBndrUnit -> Bool
tvb_is_kinded [TyVarBndrUnit]
tvbs
  , let cls_tvb_kind_map :: Map Name Kind
cls_tvb_kind_map = [Named Kind] -> Map Name Kind
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (TyVarBndrUnit -> Name
forall flag. TyVarBndrUnit -> Name
tvName TyVarBndrUnit
tvb, Kind
tvb_kind)
                                        | TyVarBndrUnit
tvb <- [TyVarBndrUnit]
tvbs
                                        , Just Kind
tvb_kind <- [TyVarBndrUnit -> Maybe Kind
forall flag. TyVarBndrUnit -> Maybe Kind
tvb_kind_maybe TyVarBndrUnit
tvb]
                                        ]
  = (Dec -> Maybe Kind) -> [Dec] -> Maybe Kind
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch (Name -> Map Name Kind -> Dec -> Maybe Kind
find_assoc_type_kind Name
n Map Name Kind
cls_tvb_kind_map) [Dec]
sub_decs
match_cusk Name
_ Dec
_ = Maybe Kind
forall a. Maybe a
Nothing

-- Uncover the kind of an associated type family. There is an invariant
-- that this function should only ever be called when the kind of the
-- parent class is known (i.e., if it has a standalone kind signature or a
-- CUSK). Despite this, it is possible for this function to return Nothing.
-- See Note [The limitations of standalone kind signatures].
find_assoc_type_kind :: Name -> Map Name Kind -> Dec -> Maybe Kind
find_assoc_type_kind :: Name -> Map Name Kind -> Dec -> Maybe Kind
find_assoc_type_kind Name
n Map Name Kind
cls_tvb_kind_map Dec
sub_dec =
  case Dec
sub_dec of
#if __GLASGOW_HASKELL__ >= 800
    DataFamilyD Name
n' [TyVarBndrUnit]
tf_tvbs Maybe Kind
m_ki
      |  Name
n Name -> Name -> Bool
`nameMatches` Name
n'
      -> [TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind ((TyVarBndrUnit -> TyVarBndrUnit)
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> TyVarBndrUnit
ascribe_tf_tvb_kind [TyVarBndrUnit]
tf_tvbs) (Maybe Kind -> Kind
default_res_ki Maybe Kind
m_ki)
    OpenTypeFamilyD (TypeFamilyHead Name
n' [TyVarBndrUnit]
tf_tvbs FamilyResultSig
res_sig Maybe InjectivityAnn
_)
      |  Name
n Name -> Name -> Bool
`nameMatches` Name
n'
      -> [TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind ((TyVarBndrUnit -> TyVarBndrUnit)
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> TyVarBndrUnit
ascribe_tf_tvb_kind [TyVarBndrUnit]
tf_tvbs)
                    (Maybe Kind -> Kind
default_res_ki (Maybe Kind -> Kind) -> Maybe Kind -> Kind
forall a b. (a -> b) -> a -> b
$ FamilyResultSig -> Maybe Kind
res_sig_to_kind FamilyResultSig
res_sig)
#else
    FamilyD _ n' tf_tvbs m_ki
      |  n `nameMatches` n'
      -> build_kind (map ascribe_tf_tvb_kind tf_tvbs) (default_res_ki m_ki)
#endif
    Dec
_ -> Maybe Kind
forall a. Maybe a
Nothing
  where
    ascribe_tf_tvb_kind :: TyVarBndrUnit -> TyVarBndrUnit
    ascribe_tf_tvb_kind :: TyVarBndrUnit -> TyVarBndrUnit
ascribe_tf_tvb_kind TyVarBndrUnit
tvb =
      (Name -> TyVarBndrUnit)
-> (Name -> Kind -> TyVarBndrUnit)
-> TyVarBndrUnit
-> TyVarBndrUnit
forall r flag.
(Name -> r) -> (Name -> Kind -> r) -> TyVarBndrUnit -> r
elimTV (\Name
tvn -> Name -> Kind -> TyVarBndrUnit
kindedTV Name
tvn (Kind -> TyVarBndrUnit) -> Kind -> TyVarBndrUnit
forall a b. (a -> b) -> a -> b
$ Kind -> Maybe Kind -> Kind
forall a. a -> Maybe a -> a
fromMaybe Kind
StarT (Maybe Kind -> Kind) -> Maybe Kind -> Kind
forall a b. (a -> b) -> a -> b
$ Name -> Map Name Kind -> Maybe Kind
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
tvn Map Name Kind
cls_tvb_kind_map)
             (\Name
_ Kind
_ -> TyVarBndrUnit
tvb)
             TyVarBndrUnit
tvb

-- Data types have CUSKs when:
--
-- 1. All of their type variables have explicit kinds.
-- 2. All kind variables in the result kind are explicitly quantified.
datatype_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
datatype_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
datatype_kind [TyVarBndrUnit]
tvbs Maybe Kind
m_ki =
  Bool -> Maybe Kind -> Maybe Kind
forall (f :: * -> *) a. Alternative f => Bool -> f a -> f a
whenAlt ((TyVarBndrUnit -> Bool) -> [TyVarBndrUnit] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TyVarBndrUnit -> Bool
forall flag. TyVarBndrUnit -> Bool
tvb_is_kinded [TyVarBndrUnit]
tvbs Bool -> Bool -> Bool
&& Bool
ki_fvs_are_bound) (Maybe Kind -> Maybe Kind) -> Maybe Kind -> Maybe Kind
forall a b. (a -> b) -> a -> b
$
  [TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind [TyVarBndrUnit]
tvbs (Maybe Kind -> Kind
default_res_ki Maybe Kind
m_ki)
  where
    ki_fvs_are_bound :: Bool
    ki_fvs_are_bound :: Bool
ki_fvs_are_bound =
      let ki_fvs :: Set Name
ki_fvs   = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ (Kind -> [Name]) -> Maybe Kind -> [Name]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Kind -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Maybe Kind
m_ki
          tvb_vars :: Set Name
tvb_vars = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ Cxt -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables (Cxt -> [Name]) -> Cxt -> [Name]
forall a b. (a -> b) -> a -> b
$ (TyVarBndrUnit -> Kind) -> [TyVarBndrUnit] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> Kind
forall flag. TyVarBndrUnit -> Kind
tvbToTypeWithSig [TyVarBndrUnit]
tvbs
      in Set Name
ki_fvs Set Name -> Set Name -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set Name
tvb_vars

-- Classes have CUSKs when all of their type variables have explicit kinds.
class_kind :: [TyVarBndrUnit] -> Maybe Kind
class_kind :: [TyVarBndrUnit] -> Maybe Kind
class_kind [TyVarBndrUnit]
tvbs = Bool -> Maybe Kind -> Maybe Kind
forall (f :: * -> *) a. Alternative f => Bool -> f a -> f a
whenAlt ((TyVarBndrUnit -> Bool) -> [TyVarBndrUnit] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TyVarBndrUnit -> Bool
forall flag. TyVarBndrUnit -> Bool
tvb_is_kinded [TyVarBndrUnit]
tvbs) (Maybe Kind -> Maybe Kind) -> Maybe Kind -> Maybe Kind
forall a b. (a -> b) -> a -> b
$
                  [TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind [TyVarBndrUnit]
tvbs Kind
ConstraintT

-- Open type families and data families always have CUSKs. Type variables
-- without explicit kinds default to Type, as does the return kind if it
-- is not specified.
open_ty_fam_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
open_ty_fam_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
open_ty_fam_kind [TyVarBndrUnit]
tvbs Maybe Kind
m_ki =
  [TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind ((TyVarBndrUnit -> TyVarBndrUnit)
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> TyVarBndrUnit
default_tvb [TyVarBndrUnit]
tvbs) (Maybe Kind -> Kind
default_res_ki Maybe Kind
m_ki)

-- Closed type families have CUSKs when:
--
-- 1. All of their type variables have explicit kinds.
-- 2. An explicit return kind is supplied.
closed_ty_fam_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
closed_ty_fam_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
closed_ty_fam_kind [TyVarBndrUnit]
tvbs Maybe Kind
m_ki =
  case Maybe Kind
m_ki of
    Just Kind
ki -> Bool -> Maybe Kind -> Maybe Kind
forall (f :: * -> *) a. Alternative f => Bool -> f a -> f a
whenAlt ((TyVarBndrUnit -> Bool) -> [TyVarBndrUnit] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TyVarBndrUnit -> Bool
forall flag. TyVarBndrUnit -> Bool
tvb_is_kinded [TyVarBndrUnit]
tvbs) (Maybe Kind -> Maybe Kind) -> Maybe Kind -> Maybe Kind
forall a b. (a -> b) -> a -> b
$
               [TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind [TyVarBndrUnit]
tvbs Kind
ki
    Maybe Kind
Nothing -> Maybe Kind
forall a. Maybe a
Nothing

-- Type synonyms have CUSKs when:
--
-- 1. All of their type variables have explicit kinds.
-- 2. The right-hand-side type is annotated with an explicit kind.
ty_syn_kind :: [TyVarBndrUnit] -> Type -> Maybe Kind
ty_syn_kind :: [TyVarBndrUnit] -> Kind -> Maybe Kind
ty_syn_kind [TyVarBndrUnit]
tvbs Kind
rhs =
  case Kind
rhs of
    SigT Kind
_ Kind
ki -> Bool -> Maybe Kind -> Maybe Kind
forall (f :: * -> *) a. Alternative f => Bool -> f a -> f a
whenAlt ((TyVarBndrUnit -> Bool) -> [TyVarBndrUnit] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TyVarBndrUnit -> Bool
forall flag. TyVarBndrUnit -> Bool
tvb_is_kinded [TyVarBndrUnit]
tvbs) (Maybe Kind -> Maybe Kind) -> Maybe Kind -> Maybe Kind
forall a b. (a -> b) -> a -> b
$
                 [TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind [TyVarBndrUnit]
tvbs Kind
ki
    Kind
_         -> Maybe Kind
forall a. Maybe a
Nothing

-- Attempt to construct the full kind of a type-level declaration from its
-- type variable binders and return kind. Do note that the result type of
-- this function is `Maybe Kind` because there are situations where even
-- this amount of information is not sufficient to determine the full kind.
-- See Note [The limitations of standalone kind signatures].
build_kind :: [TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind :: [TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind [TyVarBndrUnit]
arg_kinds Kind
res_kind =
  (Kind -> Kind) -> Maybe Kind -> Maybe Kind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Kind -> Kind
quantifyType (Maybe Kind -> Maybe Kind) -> Maybe Kind -> Maybe Kind
forall a b. (a -> b) -> a -> b
$ (Maybe Kind, Set Name) -> Maybe Kind
forall a b. (a, b) -> a
fst ((Maybe Kind, Set Name) -> Maybe Kind)
-> (Maybe Kind, Set Name) -> Maybe Kind
forall a b. (a -> b) -> a -> b
$
  (TyVarBndrUnit -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name))
-> (Maybe Kind, Set Name)
-> [TyVarBndrUnit]
-> (Maybe Kind, Set Name)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TyVarBndrUnit -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name)
go (Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
res_kind, [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList (Kind -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Kind
res_kind)) [TyVarBndrUnit]
arg_kinds
  where
    go :: TyVarBndrUnit -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name)
    go :: TyVarBndrUnit -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name)
go TyVarBndrUnit
tvb (Maybe Kind
res, Set Name
res_fvs) =
      (Name -> (Maybe Kind, Set Name))
-> (Name -> Kind -> (Maybe Kind, Set Name))
-> TyVarBndrUnit
-> (Maybe Kind, Set Name)
forall r flag.
(Name -> r) -> (Name -> Kind -> r) -> TyVarBndrUnit -> r
elimTV (\Name
n ->
               ( if Name
n Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
res_fvs
                 then TyVarBndrUnit -> Maybe Kind -> Maybe Kind
forall_vis TyVarBndrUnit
tvb Maybe Kind
res
                 else Maybe Kind
forall a. Maybe a
Nothing -- We have a type variable binder without an
                              -- explicit kind that is not used dependently, so
                              -- we cannot build a kind from it. This is the
                              -- only case where we return Nothing.
               , Set Name
res_fvs
               ))
             (\Name
n Kind
k ->
               ( if Name
n Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
res_fvs
                 then TyVarBndrUnit -> Maybe Kind -> Maybe Kind
forall_vis TyVarBndrUnit
tvb Maybe Kind
res
                 else (Kind -> Kind) -> Maybe Kind -> Maybe Kind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Kind
ArrowT Kind -> Kind -> Kind
`AppT` Kind
k Kind -> Kind -> Kind
`AppT`) Maybe Kind
res
               , [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList (Kind -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Kind
k) Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Name
res_fvs
               ))
             TyVarBndrUnit
tvb

    forall_vis :: TyVarBndrUnit -> Maybe Kind -> Maybe Kind
#if __GLASGOW_HASKELL__ >= 809
    forall_vis :: TyVarBndrUnit -> Maybe Kind -> Maybe Kind
forall_vis TyVarBndrUnit
tvb Maybe Kind
m_ki = (Kind -> Kind) -> Maybe Kind -> Maybe Kind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([TyVarBndrUnit] -> Kind -> Kind
ForallVisT [TyVarBndrUnit
tvb]) Maybe Kind
m_ki
      -- One downside of this approach is that we generate kinds like this:
      --
      --   forall a -> forall b -> forall c -> (a, b, c)
      --
      -- Instead of this more compact kind:
      --
      --   forall a b c -> (a, b, c)
      --
      -- Thankfully, the difference is only cosmetic.
#else
    forall_vis _   _    = Nothing
#endif

tvb_is_kinded :: TyVarBndr_ flag -> Bool
tvb_is_kinded :: TyVarBndrUnit -> Bool
tvb_is_kinded = Maybe Kind -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Kind -> Bool)
-> (TyVarBndrUnit -> Maybe Kind) -> TyVarBndrUnit -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndrUnit -> Maybe Kind
forall flag. TyVarBndrUnit -> Maybe Kind
tvb_kind_maybe

tvb_kind_maybe :: TyVarBndr_ flag -> Maybe Kind
tvb_kind_maybe :: TyVarBndrUnit -> Maybe Kind
tvb_kind_maybe = (Name -> Maybe Kind)
-> (Name -> Kind -> Maybe Kind) -> TyVarBndrUnit -> Maybe Kind
forall r flag.
(Name -> r) -> (Name -> Kind -> r) -> TyVarBndrUnit -> r
elimTV (\Name
_ -> Maybe Kind
forall a. Maybe a
Nothing) (\Name
_ Kind
k -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
k)

vis_arg_kind_maybe :: VisFunArg -> Maybe Kind
vis_arg_kind_maybe :: VisFunArg -> Maybe Kind
vis_arg_kind_maybe (VisFADep TyVarBndrUnit
tvb) = TyVarBndrUnit -> Maybe Kind
forall flag. TyVarBndrUnit -> Maybe Kind
tvb_kind_maybe TyVarBndrUnit
tvb
vis_arg_kind_maybe (VisFAAnon Kind
k)  = Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
k

default_tvb :: TyVarBndrUnit -> TyVarBndrUnit
default_tvb :: TyVarBndrUnit -> TyVarBndrUnit
default_tvb TyVarBndrUnit
tvb = (Name -> TyVarBndrUnit)
-> (Name -> Kind -> TyVarBndrUnit)
-> TyVarBndrUnit
-> TyVarBndrUnit
forall r flag.
(Name -> r) -> (Name -> Kind -> r) -> TyVarBndrUnit -> r
elimTV (\Name
n -> Name -> Kind -> TyVarBndrUnit
kindedTV Name
n Kind
StarT) (\Name
_ Kind
_ -> TyVarBndrUnit
tvb) TyVarBndrUnit
tvb

default_res_ki :: Maybe Kind -> Kind
default_res_ki :: Maybe Kind -> Kind
default_res_ki = Kind -> Maybe Kind -> Kind
forall a. a -> Maybe a -> a
fromMaybe Kind
StarT

#if __GLASGOW_HASKELL__ >= 800
res_sig_to_kind :: FamilyResultSig -> Maybe Kind
res_sig_to_kind :: FamilyResultSig -> Maybe Kind
res_sig_to_kind FamilyResultSig
NoSig          = Maybe Kind
forall a. Maybe a
Nothing
res_sig_to_kind (KindSig Kind
k)    = Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
k
res_sig_to_kind (TyVarSig TyVarBndrUnit
tvb) = TyVarBndrUnit -> Maybe Kind
forall flag. TyVarBndrUnit -> Maybe Kind
tvb_kind_maybe TyVarBndrUnit
tvb
#endif

whenAlt :: Alternative f => Bool -> f a -> f a
whenAlt :: Bool -> f a -> f a
whenAlt Bool
b f a
fa = if Bool
b then f a
fa else f a
forall (f :: * -> *) a. Alternative f => f a
empty

{-
Note [The limitations of standalone kind signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A current limitation of StandaloneKindSignatures is that they cannot be applied
to associated type families. This can have some surprising consequences.
Consider the following code, taken from
https://gitlab.haskell.org/ghc/ghc/issues/17072#note_221324:

  type C :: forall a -> a -> Constraint
  class C a b where
    type T a :: Type

The parent class C has a standalone kind signature, so GHC treats its
associated types as if they had CUSKs. Can th-desugar figure out the kind
that GHC gives to T?

Unfortunately, the answer is "not easily". This is because `type T a` says
nothing about the kind of `a`, so th-desugar's only other option is to inspect
the kind signature for C. Even this is for naught, as the `forall a -> ...`
part doesn't state the kind of `a` either! The only way to know that the kind
of `a` should be Type is to infer that from the rest of the kind
(`a -> Constraint`), but this gets perilously close to requiring full kind
inference, which is rather unwieldy in Template Haskell.

In cases like T, we simply give up and return Nothing when trying to reify
its kind. It's not ideal, but them's the breaks when you try to extract kinds
from syntax. There is a rather simple workaround available: just write
`type C :: forall (a :: Type) -> a -> Constraint` instead.
-}

--------------------------------------
-- Looking up name value and type names
--------------------------------------

-- | Like 'lookupValueName' from Template Haskell, but looks also in 'Names' of
-- not-yet-typechecked declarations. To establish this list of not-yet-typechecked
-- declarations, use 'withLocalDeclarations'. Returns 'Nothing' if no value
-- with the same name can be found.
lookupValueNameWithLocals :: DsMonad q => String -> q (Maybe Name)
lookupValueNameWithLocals :: String -> q (Maybe Name)
lookupValueNameWithLocals = Bool -> String -> q (Maybe Name)
forall (q :: * -> *). DsMonad q => Bool -> String -> q (Maybe Name)
lookupNameWithLocals Bool
False

-- | Like 'lookupTypeName' from Template Haskell, but looks also in 'Names' of
-- not-yet-typechecked declarations. To establish this list of not-yet-typechecked
-- declarations, use 'withLocalDeclarations'. Returns 'Nothing' if no type
-- with the same name can be found.
lookupTypeNameWithLocals :: DsMonad q => String -> q (Maybe Name)
lookupTypeNameWithLocals :: String -> q (Maybe Name)
lookupTypeNameWithLocals = Bool -> String -> q (Maybe Name)
forall (q :: * -> *). DsMonad q => Bool -> String -> q (Maybe Name)
lookupNameWithLocals Bool
True

lookupNameWithLocals :: DsMonad q => Bool -> String -> q (Maybe Name)
lookupNameWithLocals :: Bool -> String -> q (Maybe Name)
lookupNameWithLocals Bool
ns String
s = do
    Maybe Name
mb_name <- Bool -> String -> q (Maybe Name)
forall (m :: * -> *). Quasi m => Bool -> String -> m (Maybe Name)
qLookupName Bool
ns String
s
    case Maybe Name
mb_name of
      j_name :: Maybe Name
j_name@(Just{}) -> Maybe Name -> q (Maybe Name)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Name
j_name
      Maybe Name
Nothing         -> q (Maybe Name)
consult_locals
  where
    built_name :: Name
built_name = String -> Name
mkName String
s

    consult_locals :: q (Maybe Name)
consult_locals = do
      [Dec]
decs <- q [Dec]
forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations
      let mb_infos :: [Maybe (Name, Info)]
mb_infos = (Dec -> Maybe (Name, Info)) -> [Dec] -> [Maybe (Name, Info)]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> [Dec] -> Dec -> Maybe (Name, Info)
reifyInDec Name
built_name [Dec]
decs) [Dec]
decs
          infos :: [(Name, Info)]
infos = [Maybe (Name, Info)] -> [(Name, Info)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Name, Info)]
mb_infos
      Maybe Name -> q (Maybe Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Name -> q (Maybe Name)) -> Maybe Name -> q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ ((Name, Info) -> Maybe Name) -> [(Name, Info)] -> Maybe Name
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch (if Bool
ns then (Name, Info) -> Maybe Name
find_type_name
                                 else (Name, Info) -> Maybe Name
find_value_name) [(Name, Info)]
infos

    -- These functions work over Named Infos so we can avoid performing
    -- tiresome pattern-matching to retrieve the name associated with each Info.
    find_type_name, find_value_name :: Named Info -> Maybe Name
    find_type_name :: (Name, Info) -> Maybe Name
find_type_name (Name
n, Info
info) =
      case Info -> NameSpace
infoNameSpace Info
info of
        NameSpace
TcClsName -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
        NameSpace
VarName   -> Maybe Name
forall a. Maybe a
Nothing
        NameSpace
DataName  -> Maybe Name
forall a. Maybe a
Nothing

    find_value_name :: (Name, Info) -> Maybe Name
find_value_name (Name
n, Info
info) =
      case Info -> NameSpace
infoNameSpace Info
info of
        NameSpace
VarName   -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
        NameSpace
DataName  -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
        NameSpace
TcClsName -> Maybe Name
forall a. Maybe a
Nothing

-- | Like TH's @lookupValueName@, but if this name is not bound, then we assume
-- it is declared in the current module.
--
-- Unlike 'mkDataName', this also consults the local declarations in scope when
-- determining if the name is currently bound.
mkDataNameWithLocals :: DsMonad q => String -> q Name
mkDataNameWithLocals :: String -> q Name
mkDataNameWithLocals = (String -> q (Maybe Name))
-> (String -> String -> String -> Name) -> String -> q Name
forall (q :: * -> *).
Quasi q =>
(String -> q (Maybe Name))
-> (String -> String -> String -> Name) -> String -> q Name
mkNameWith String -> q (Maybe Name)
forall (q :: * -> *). DsMonad q => String -> q (Maybe Name)
lookupValueNameWithLocals String -> String -> String -> Name
mkNameG_d

-- | Like TH's @lookupTypeName@, but if this name is not bound, then we assume
-- it is declared in the current module.
--
-- Unlike 'mkTypeName', this also consults the local declarations in scope when
-- determining if the name is currently bound.
mkTypeNameWithLocals :: DsMonad q => String -> q Name
mkTypeNameWithLocals :: String -> q Name
mkTypeNameWithLocals = (String -> q (Maybe Name))
-> (String -> String -> String -> Name) -> String -> q Name
forall (q :: * -> *).
Quasi q =>
(String -> q (Maybe Name))
-> (String -> String -> String -> Name) -> String -> q Name
mkNameWith String -> q (Maybe Name)
forall (q :: * -> *). DsMonad q => String -> q (Maybe Name)
lookupTypeNameWithLocals String -> String -> String -> Name
mkNameG_tc

-- | Determines a `Name`'s 'NameSpace'. If the 'NameSpace' is attached to
-- the 'Name' itself (i.e., it is unambiguous), then that 'NameSpace' is
-- immediately returned. Otherwise, reification is used to lookup up the
-- 'NameSpace' (consulting local declarations if necessary).
--
-- Note that if a 'Name' lives in two different 'NameSpaces' (which can
-- genuinely happen--for instance, @'mkName' \"==\"@, where @==@ is both
-- a function and a type family), then this function will simply return
-- whichever 'NameSpace' is discovered first via reification. If you wish
-- to find a 'Name' in a particular 'NameSpace', use the
-- 'lookupValueNameWithLocals' or 'lookupTypeNameWithLocals' functions.
reifyNameSpace :: DsMonad q => Name -> q (Maybe NameSpace)
reifyNameSpace :: Name -> q (Maybe NameSpace)
reifyNameSpace n :: Name
n@(Name OccName
_ NameFlavour
nf) =
  case NameFlavour
nf of
    -- NameGs are simple, as they have a NameSpace attached.
    NameG NameSpace
ns PkgName
_ ModName
_ -> Maybe NameSpace -> q (Maybe NameSpace)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe NameSpace -> q (Maybe NameSpace))
-> Maybe NameSpace -> q (Maybe NameSpace)
forall a b. (a -> b) -> a -> b
$ NameSpace -> Maybe NameSpace
forall a. a -> Maybe a
Just NameSpace
ns

    -- For other names, we must use reification to determine what NameSpace
    -- it lives in (if any).
    NameFlavour
_ -> do Maybe Info
mb_info <- Name -> q (Maybe Info)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe Info)
reifyWithLocals_maybe Name
n
            Maybe NameSpace -> q (Maybe NameSpace)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe NameSpace -> q (Maybe NameSpace))
-> Maybe NameSpace -> q (Maybe NameSpace)
forall a b. (a -> b) -> a -> b
$ (Info -> NameSpace) -> Maybe Info -> Maybe NameSpace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Info -> NameSpace
infoNameSpace Maybe Info
mb_info

-- | Determine a name's 'NameSpace' from its 'Info'.
infoNameSpace :: Info -> NameSpace
infoNameSpace :: Info -> NameSpace
infoNameSpace Info
info =
  case Info
info of
    ClassI{}     -> NameSpace
TcClsName
    TyConI{}     -> NameSpace
TcClsName
    FamilyI{}    -> NameSpace
TcClsName
    PrimTyConI{} -> NameSpace
TcClsName
    TyVarI{}     -> NameSpace
TcClsName

    ClassOpI{}   -> NameSpace
VarName
    VarI{}       -> NameSpace
VarName

    DataConI{}   -> NameSpace
DataName
#if __GLASGOW_HASKELL__ >= 801
    PatSynI{}    -> NameSpace
DataName
#endif