{- 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 #-}

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

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

  -- * Datatype lookup
  getDataD, dataConNameToCon, dataConNameToDataName,

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

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

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
import Data.Function (on)
import Data.List
import Data.Maybe
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative
#endif

import Language.Haskell.TH.Datatype
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
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
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
    Nothing -> Name -> q Info
forall (m :: * -> *) a. MonadFail m => Name -> m a
reifyFail Name
name
    Just i :: 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
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
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
$ "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]
++ " in the list of available " String -> String -> String
forall a. [a] -> [a] -> [a]
++
              "declarations failed.\nThis lookup fails if the declaration " String -> String -> String
forall a. [a] -> [a] -> [a]
++
              "referenced was made in the same Template\nHaskell splice as the use " String -> String -> String
forall a. [a] -> [a] -> [a]
++
              "of the declaration. If this is the case, put\nthe reference to " String -> String -> String
forall a. [a] -> [a] -> [a]
++
              "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 ([TyVarBndr], [Con])
getDataD :: String -> Name -> q ([TyVarBndr], [Con])
getDataD err :: String
err name :: 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 -> Dec -> q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
dec
           _ -> q Dec
forall a. q a
badDeclaration
  case Dec
dec of
#if __GLASGOW_HASKELL__ > 710
    DataD _cxt :: Cxt
_cxt _name :: Name
_name tvbs :: [TyVarBndr]
tvbs mk :: Maybe Kind
mk cons :: [Con]
cons _derivings :: [DerivClause]
_derivings -> [TyVarBndr] -> Maybe Kind -> [Con] -> q ([TyVarBndr], [Con])
forall (m :: * -> *) b.
Quasi m =>
[TyVarBndr] -> Maybe Kind -> b -> m ([TyVarBndr], b)
go [TyVarBndr]
tvbs Maybe Kind
mk [Con]
cons
    NewtypeD _cxt :: Cxt
_cxt _name :: Name
_name tvbs :: [TyVarBndr]
tvbs mk :: Maybe Kind
mk con :: Con
con _derivings :: [DerivClause]
_derivings -> [TyVarBndr] -> Maybe Kind -> [Con] -> q ([TyVarBndr], [Con])
forall (m :: * -> *) b.
Quasi m =>
[TyVarBndr] -> Maybe Kind -> b -> m ([TyVarBndr], b)
go [TyVarBndr]
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
    _ -> q ([TyVarBndr], [Con])
forall a. q a
badDeclaration
  where
    go :: [TyVarBndr] -> Maybe Kind -> b -> m ([TyVarBndr], b)
go tvbs :: [TyVarBndr]
tvbs mk :: Maybe Kind
mk cons :: b
cons = do
      Kind
k <- m Kind -> (Kind -> m Kind) -> Maybe Kind -> m Kind
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Kind -> m Kind
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Kind
ConT Name
typeKindName)) (Q Kind -> m Kind
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ (Q Kind -> m Kind) -> (Kind -> Q Kind) -> Kind -> m Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Q Kind
resolveTypeSynonyms) Maybe Kind
mk
      [TyVarBndr]
extra_tvbs <- (Kind -> ([TyVarBndr], Cxt, Cxt, Kind))
-> (Name -> Kind -> TyVarBndr) -> Kind -> m [TyVarBndr]
forall (q :: * -> *) kind tyVarBndr pred.
Quasi q =>
(kind -> ([tyVarBndr], [pred], [kind], kind))
-> (Name -> kind -> tyVarBndr) -> kind -> q [tyVarBndr]
mkExtraKindBindersGeneric Kind -> ([TyVarBndr], Cxt, Cxt, Kind)
unravelType Name -> Kind -> TyVarBndr
KindedTV Kind
k
      let all_tvbs :: [TyVarBndr]
all_tvbs = [TyVarBndr]
tvbs [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ [TyVarBndr]
extra_tvbs
      ([TyVarBndr], b) -> m ([TyVarBndr], b)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr]
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
$ "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]
++ ") refers to something " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 "other than a datatype. " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err

-- | 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 con_name :: 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
_name _type :: Kind
_type parent_name :: 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
    _ -> 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
$ "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]
++ " does not appear to be " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                "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 con_name :: 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
  (_, cons :: [Con]
cons) <- String -> Name -> q ([TyVarBndr], [Con])
forall (q :: * -> *).
DsMonad q =>
String -> Name -> q ([TyVarBndr], [Con])
getDataD "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
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 -> Con -> q Con
forall (m :: * -> *) a. Monad m => a -> m a
return Con
con
    Nothing -> String -> q Con
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Datatype does not contain one of its own constructors."

  where
    get_con_name :: Con -> [Name]
get_con_name (NormalC name :: Name
name _)     = [Name
name]
    get_con_name (RecC name :: Name
name _)        = [Name
name]
    get_con_name (InfixC _ name :: Name
name _)    = [Name
name]
    get_con_name (ForallC _ _ con :: Con
con)    = Con -> [Name]
get_con_name Con
con
#if __GLASGOW_HASKELL__ > 710
    get_con_name (GadtC names :: [Name]
names _ _)    = [Name]
names
    get_con_name (RecGadtC names :: [Name]
names _ _) = [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 Info
Name -> Cxt -> DsM q [Dec]
Extension -> DsM q Bool
AnnLookup -> DsM q [a]
ForeignSrcLang -> String -> DsM q ()
Module -> DsM q ModuleInfo
(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 -> 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)
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 (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 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
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 -> 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
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]
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 new_decs :: [Dec]
new_decs (DsM x :: 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 n :: Name
n decs :: [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 n :: 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
fixity n' :: Name
n') | Name
n Name -> Name -> Bool
`nameMatches` Name
n' = Fixity -> Maybe Fixity
forall a. a -> Maybe a
Just Fixity
fixity
    match_fixity _                                       = 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 n :: Name
n decs :: [Dec]
decs (FunD n' :: Name
n' _) | 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 n :: Name
n decs :: [Dec]
decs (ValD pat :: Pat
pat _ _)
  | Just n' :: Name
n' <- (Name -> Bool) -> [Name] -> Maybe Name
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
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 n :: Name
n _    dec :: Dec
dec@(DataD    _ n' :: Name
n' _ _ _ _) | 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 n :: Name
n _    dec :: Dec
dec@(NewtypeD _ n' :: Name
n' _ _ _ _) | 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 n :: Name
n _    dec :: Dec
dec@(TySynD n' :: Name
n' _ _)       | 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 n :: Name
n decs :: [Dec]
decs dec :: Dec
dec@(ClassD _ n' :: Name
n' _ _ _)   | 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 n :: Name
n decs :: [Dec]
decs (ForeignD (ImportF _ _ _ n' :: Name
n' ty :: 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 n :: Name
n decs :: [Dec]
decs (ForeignD (ExportF _ _ n' :: Name
n' ty :: 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 n :: Name
n decs :: [Dec]
decs dec :: Dec
dec@(OpenTypeFamilyD (TypeFamilyHead n' :: Name
n' _ _ _)) | 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 n :: Name
n decs :: [Dec]
decs dec :: Dec
dec@(DataFamilyD n' :: Name
n' _ _) | 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 n :: Name
n _    dec :: Dec
dec@(ClosedTypeFamilyD (TypeFamilyHead n' :: Name
n' _ _ _) _) | 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 n :: Name
n decs :: [Dec]
decs (PatSynD n' :: Name
n' _ _ _) | 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 n :: Name
n decs :: [Dec]
decs (DataD _ ty_name :: Name
ty_name tvbs :: [TyVarBndr]
tvbs _mk :: Maybe Kind
_mk cons :: [Con]
cons _)
  | Just info :: (Name, Info)
info <- Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Name, Info)
maybeReifyCon Name
n [Dec]
decs Name
ty_name ((TyVarBndr -> TypeArg) -> [TyVarBndr] -> [TypeArg]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> TypeArg
tvbToTANormalWithSig [TyVarBndr]
tvbs) [Con]
cons
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name, Info)
info
reifyInDec n :: Name
n decs :: [Dec]
decs (NewtypeD _ ty_name :: Name
ty_name tvbs :: [TyVarBndr]
tvbs _mk :: Maybe Kind
_mk con :: Con
con _)
  | Just info :: (Name, Info)
info <- Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Name, Info)
maybeReifyCon Name
n [Dec]
decs Name
ty_name ((TyVarBndr -> TypeArg) -> [TyVarBndr] -> [TypeArg]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> TypeArg
tvbToTANormalWithSig [TyVarBndr]
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 n :: Name
n _decs :: [Dec]
_decs (ClassD _ ty_name :: Name
ty_name tvbs :: [TyVarBndr]
tvbs _ sub_decs :: [Dec]
sub_decs)
  | Just (n' :: Name
n', ty :: 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 -> [TyVarBndr] -> Bool -> Kind -> Kind
quantifyClassMethodType Name
ty_name [TyVarBndr]
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 n :: Name
n decs :: [Dec]
decs (ClassD _ _ _ _ sub_decs :: [Dec]
sub_decs)
  | Just info :: (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]
sub_decs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
decs)) [Dec]
sub_decs
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name, Info)
info
#if __GLASGOW_HASKELL__ >= 711
reifyInDec n :: Name
n decs :: [Dec]
decs (InstanceD _ _ _ sub_decs :: [Dec]
sub_decs)
#else
reifyInDec n decs (InstanceD _ _ sub_decs)
#endif
  | Just info :: (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 _                     = Maybe (Name, Info)
forall a. Maybe a
Nothing
#if __GLASGOW_HASKELL__ >= 807
reifyInDec n :: Name
n decs :: [Dec]
decs (DataInstD _ _ lhs :: Kind
lhs _ cons :: [Con]
cons _)
  | (ConT ty_name :: Name
ty_name, tys :: [TypeArg]
tys) <- Kind -> (Kind, [TypeArg])
unfoldType Kind
lhs
  , Just info :: (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 n :: Name
n decs :: [Dec]
decs (NewtypeInstD _ _ lhs :: Kind
lhs _ con :: Con
con _)
  | (ConT ty_name :: Name
ty_name, tys :: [TypeArg]
tys) <- Kind -> (Kind, [TypeArg])
unfoldType Kind
lhs
  , Just info :: (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 _ _ _ = Maybe (Name, Info)
forall a. Maybe a
Nothing

maybeReifyCon :: Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Named Info)
#if __GLASGOW_HASKELL__ > 710
maybeReifyCon :: Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Name, Info)
maybeReifyCon n :: Name
n _decs :: [Dec]
_decs ty_name :: Name
ty_name ty_args :: [TypeArg]
ty_args cons :: [Con]
cons
  | Just (n' :: Name
n', con :: Con
con) <- Name -> [Con] -> Maybe (Named Con)
findCon Name
n [Con]
cons
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Name -> Kind -> Name -> Info
DataConI Name
n ([TyVarBndr] -> Cxt -> Kind -> Kind
maybeForallT [TyVarBndr]
tvbs [] (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$ Con -> Kind
con_to_type Con
con) Name
ty_name)
#else
maybeReifyCon n decs ty_name ty_args cons
  | Just (n', con) <- findCon n cons
  = Just (n', DataConI n (maybeForallT tvbs [] $ con_to_type con)
                         ty_name fixity)
#endif

  | Just (n' :: Name
n', ty :: Kind
ty) <- Name -> [Con] -> Maybe (Named Kind)
findRecSelector Name
n [Con]
cons
      -- we don't try to ferret out naughty record selectors.
#if __GLASGOW_HASKELL__ > 710
  = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Name -> Kind -> Maybe Dec -> Info
VarI Name
n ([TyVarBndr] -> Cxt -> Kind -> Kind
maybeForallT [TyVarBndr]
tvbs [] (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$ Cxt -> Kind -> Kind
mkArrows [Kind
result_ty] Kind
ty) Maybe Dec
forall a. Maybe a
Nothing)
#else
  = Just (n', VarI n (maybeForallT tvbs [] $ mkArrows [result_ty] ty) Nothing fixity)
#endif
  where
    result_ty :: Kind
result_ty = Kind -> [TypeArg] -> Kind
applyType (Name -> Kind
ConT Name
ty_name) ((TypeArg -> TypeArg) -> [TypeArg] -> [TypeArg]
forall a b. (a -> b) -> [a] -> [b]
map TypeArg -> TypeArg
unSigTypeArg [TypeArg]
ty_args)
      -- Make sure to call unSigTypeArg here. 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.

    con_to_type :: Con -> Kind
con_to_type (NormalC _ stys :: [BangType]
stys) = 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
result_ty
    con_to_type (RecC _ vstys :: [VarBangType]
vstys)   = 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
result_ty
    con_to_type (InfixC t1 :: BangType
t1 _ t2 :: BangType
t2) = 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
result_ty
    con_to_type (ForallC bndrs :: [TyVarBndr]
bndrs cxt :: Cxt
cxt c :: Con
c) = [TyVarBndr] -> Cxt -> Kind -> Kind
ForallT [TyVarBndr]
bndrs Cxt
cxt (Con -> Kind
con_to_type Con
c)
#if __GLASGOW_HASKELL__ > 710
    con_to_type (GadtC _ stys :: [BangType]
stys rty :: Kind
rty)     = 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
    con_to_type (RecGadtC _ vstys :: [VarBangType]
vstys rty :: Kind
rty) = 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
#if __GLASGOW_HASKELL__ < 711
    fixity = fromMaybe defaultFixity $ reifyFixityInDecs n decs
#endif
    tvbs :: [TyVarBndr]
tvbs = Cxt -> [TyVarBndr]
freeVariablesWellScoped (Cxt -> [TyVarBndr]) -> Cxt -> [TyVarBndr]
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
maybeReifyCon _ _ _ _ _ = Maybe (Name, Info)
forall a. Maybe a
Nothing

mkVarI :: Name -> [Dec] -> Info
mkVarI :: Name -> [Dec] -> Info
mkVarI n :: Name
n decs :: [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 n :: Name
n _decs :: [Dec]
_decs ty :: 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 n :: 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 n' :: Name
n' ty :: 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 _                                 = Maybe (Named Kind)
forall a. Maybe a
Nothing

#if __GLASGOW_HASKELL__ >= 801
mkPatSynI :: Name -> [Dec] -> Info
mkPatSynI :: Name -> [Dec] -> Info
mkPatSynI n :: Name
n decs :: [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 n :: 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 n' :: Name
n' psty :: 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 _                                         = Maybe Kind
forall a. Maybe a
Nothing
#endif

no_type :: Name -> Type
no_type :: Name -> Kind
no_type n :: Name
n = String -> Kind
forall a. HasCallStack => String -> a
error (String -> Kind) -> String -> Kind
forall a b. (a -> b) -> a -> b
$ "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 n :: 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 _ _ ty :: Kind
ty _)
#else
    match_instance d@(InstanceD _ ty _)
#endif
                                               | ConT n' :: 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 ctxt :: Cxt
ctxt _ lhs :: Kind
lhs mk :: Maybe Kind
mk cons :: [Con]
cons derivs :: [DerivClause]
derivs)
                                                  | ConT n' :: Name
n' <- Kind -> Kind
ty_head Kind
lhs
                                                  , Name
n Name -> Name -> Bool
`nameMatches` Name
n' = [Dec
d]
      where
        mtvbs :: Maybe [TyVarBndr]
mtvbs = Cxt -> Kind -> Maybe Kind -> Maybe [TyVarBndr]
rejig_data_inst_tvbs Cxt
ctxt Kind
lhs Maybe Kind
mk
        d :: Dec
d = Cxt
-> Maybe [TyVarBndr]
-> Kind
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataInstD Cxt
ctxt Maybe [TyVarBndr]
mtvbs Kind
lhs Maybe Kind
mk [Con]
cons [DerivClause]
derivs
    match_instance (NewtypeInstD ctxt :: Cxt
ctxt _ lhs :: Kind
lhs mk :: Maybe Kind
mk con :: Con
con derivs :: [DerivClause]
derivs)
                                                  | ConT n' :: Name
n' <- Kind -> Kind
ty_head Kind
lhs
                                                  , Name
n Name -> Name -> Bool
`nameMatches` Name
n' = [Dec
d]
      where
        mtvbs :: Maybe [TyVarBndr]
mtvbs = Cxt -> Kind -> Maybe Kind -> Maybe [TyVarBndr]
rejig_data_inst_tvbs Cxt
ctxt Kind
lhs Maybe Kind
mk
        d :: Dec
d = Cxt
-> Maybe [TyVarBndr]
-> Kind
-> Maybe Kind
-> Con
-> [DerivClause]
-> Dec
NewtypeInstD Cxt
ctxt Maybe [TyVarBndr]
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 _ lhs :: Kind
lhs rhs :: Kind
rhs))
                                               | ConT n' :: Name
n' <- Kind -> Kind
ty_head Kind
lhs
                                               , Name
n Name -> Name -> Bool
`nameMatches` Name
n' = [Dec
d]
      where
        mtvbs :: Maybe [TyVarBndr]
mtvbs = Cxt -> Maybe [TyVarBndr]
rejig_tvbs [Kind
lhs, Kind
rhs]
        d :: Dec
d = TySynEqn -> Dec
TySynInstD (Maybe [TyVarBndr] -> Kind -> Kind -> TySynEqn
TySynEqn Maybe [TyVarBndr]
mtvbs Kind
lhs Kind
rhs)
#else
    match_instance d@(TySynInstD n' _)         | n `nameMatches` n' = [d]
#endif

#if __GLASGOW_HASKELL__ >= 711
    match_instance (InstanceD _ _ _ decs :: [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 _                    = []

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

    rejig_data_inst_tvbs :: Cxt -> Type -> Maybe Kind -> Maybe [TyVarBndr]
    rejig_data_inst_tvbs :: Cxt -> Kind -> Maybe Kind -> Maybe [TyVarBndr]
rejig_data_inst_tvbs cxt :: Cxt
cxt lhs :: Kind
lhs mk :: Maybe Kind
mk =
      Cxt -> Maybe [TyVarBndr]
rejig_tvbs (Cxt -> Maybe [TyVarBndr]) -> Cxt -> Maybe [TyVarBndr]
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
cxt cls_name :: Name
cls_name cls_tvbs :: [TyVarBndr]
cls_tvbs fds :: [FunDep]
fds sub_decs :: [Dec]
sub_decs)
  = Cxt -> Name -> [TyVarBndr] -> [FunDep] -> [Dec] -> Dec
ClassD Cxt
cxt Name
cls_name [TyVarBndr]
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 n :: Name
n ty :: 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 -> [TyVarBndr] -> Bool -> Kind -> Kind
quantifyClassMethodType Name
cls_name [TyVarBndr]
cls_tvbs Bool
prepend_cls Kind
ty
#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 _           = 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
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.
  -> [TyVarBndr] -- ^ The class's type variable binders.
  -> Bool        -- ^ If 'True', prepend a class predicate.
  -> Type        -- ^ The method type.
  -> Type
quantifyClassMethodType :: Name -> [TyVarBndr] -> Bool -> Kind -> Kind
quantifyClassMethodType cls_name :: Name
cls_name cls_tvbs :: [TyVarBndr]
cls_tvbs prepend :: Bool
prepend meth_ty :: 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   = [TyVarBndr] -> Cxt -> Kind -> Kind
ForallT [TyVarBndr]
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) ((TyVarBndr -> Kind) -> [TyVarBndr] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Kind
tvbToType [TyVarBndr]
cls_tvbs)]
#endif

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

    meth_tvbs :: [TyVarBndr]
    meth_tvbs :: [TyVarBndr]
meth_tvbs = (TyVarBndr -> TyVarBndr -> Bool)
-> [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
deleteFirstsBy (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Name -> Name -> Bool)
-> (TyVarBndr -> Name) -> TyVarBndr -> TyVarBndr -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TyVarBndr -> Name
tvName)
                  (Cxt -> [TyVarBndr]
freeVariablesWellScoped [Kind
meth_ty]) [TyVarBndr]
all_cls_tvbs

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

stripInstanceDec :: Dec -> Dec
#if __GLASGOW_HASKELL__ >= 711
stripInstanceDec :: Dec -> Dec
stripInstanceDec (InstanceD over :: Maybe Overlap
over cxt :: Cxt
cxt ty :: Kind
ty _) = 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
dec

mkArrows :: [Type] -> Type -> Type
mkArrows :: Cxt -> Kind -> Kind
mkArrows []     res_ty :: Kind
res_ty = Kind
res_ty
mkArrows (t :: Kind
t:ts :: Cxt
ts) res_ty :: 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 :: [TyVarBndr] -> Cxt -> Type -> Type
maybeForallT :: [TyVarBndr] -> Cxt -> Kind -> Kind
maybeForallT tvbs :: [TyVarBndr]
tvbs cxt :: Cxt
cxt ty :: Kind
ty
  | [TyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr]
tvbs Bool -> Bool -> Bool
&& Cxt -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
cxt        = Kind
ty
  | ForallT tvbs2 :: [TyVarBndr]
tvbs2 cxt2 :: Cxt
cxt2 ty2 :: Kind
ty2 <- Kind
ty = [TyVarBndr] -> Cxt -> Kind -> Kind
ForallT ([TyVarBndr]
tvbs [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ [TyVarBndr]
tvbs2) (Cxt
cxt Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Cxt
cxt2) Kind
ty2
  | Bool
otherwise                    = [TyVarBndr] -> Cxt -> Kind -> Kind
ForallT [TyVarBndr]
tvbs Cxt
cxt Kind
ty

findCon :: Name -> [Con] -> Maybe (Named Con)
findCon :: Name -> [Con] -> Maybe (Named Con)
findCon n :: 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
con =
      case Con
con of
        NormalC n' :: Name
n' _  | Name
n Name -> Name -> Bool
`nameMatches` Name
n' -> Named Con -> Maybe (Named Con)
forall a. a -> Maybe a
Just (Name
n', Con
con)
        RecC n' :: Name
n' _     | Name
n Name -> Name -> Bool
`nameMatches` Name
n' -> Named Con -> Maybe (Named Con)
forall a. a -> Maybe a
Just (Name
n', Con
con)
        InfixC _ n' :: Name
n' _ | Name
n Name -> Name -> Bool
`nameMatches` Name
n' -> Named Con -> Maybe (Named Con)
forall a. a -> Maybe a
Just (Name
n', Con
con)
        ForallC _ _ c :: Con
c -> case Con -> Maybe (Named Con)
match_con Con
c of
                           Just (n' :: Name
n', _) -> Named Con -> Maybe (Named Con)
forall a. a -> Maybe a
Just (Name
n', Con
con)
                           Nothing      -> Maybe (Named Con)
forall a. Maybe a
Nothing
#if __GLASGOW_HASKELL__ > 710
        GadtC nms :: [Name]
nms _ _    -> Con -> [Name] -> Maybe (Named Con)
gadt_case Con
con [Name]
nms
        RecGadtC nms :: [Name]
nms _ _ -> Con -> [Name] -> Maybe (Named Con)
gadt_case Con
con [Name]
nms
#endif
        _                -> 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
con nms :: [Name]
nms = case (Name -> Bool) -> [Name] -> Maybe Name
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Name
n Name -> Name -> Bool
`nameMatches`) [Name]
nms of
                          Just n' :: Name
n' -> Named Con -> Maybe (Named Con)
forall a. a -> Maybe a
Just (Name
n', Con
con)
                          Nothing -> Maybe (Named Con)
forall a. Maybe a
Nothing
#endif

findRecSelector :: Name -> [Con] -> Maybe (Named Type)
findRecSelector :: Name -> [Con] -> Maybe (Named Kind)
findRecSelector n :: Name
n = (Con -> Maybe (Named Kind)) -> [Con] -> Maybe (Named Kind)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch Con -> Maybe (Named Kind)
match_con
  where
    match_con :: Con -> Maybe (Named Kind)
match_con (RecC _ vstys :: [VarBangType]
vstys)       = (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 _ vstys :: [VarBangType]
vstys _) = (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 _ _ c :: Con
c)      = Con -> Maybe (Named Kind)
match_con Con
c
    match_con _                    = Maybe (Named Kind)
forall a. Maybe a
Nothing

    match_rec_sel :: (Name, b, b) -> Maybe (Name, b)
match_rec_sel (n' :: Name
n', _, ty :: b
ty) | Name
n Name -> Name -> Bool
`nameMatches` Name
n' = (Name, b) -> Maybe (Name, b)
forall a. a -> Maybe a
Just (Name
n', b
ty)
    match_rec_sel _                                = 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 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
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)

--------------------------------------
-- Lookuping 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 ns :: Bool
ns s :: 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
      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 (n :: Name
n, info :: Info
info) =
      case Info -> NameSpace
infoNameSpace Info
info of
        TcClsName -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
        VarName   -> Maybe Name
forall a. Maybe a
Nothing
        DataName  -> Maybe Name
forall a. Maybe a
Nothing

    find_value_name :: (Name, Info) -> Maybe Name
find_value_name (n :: Name
n, info :: Info
info) =
      case Info -> NameSpace
infoNameSpace Info
info of
        VarName   -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
        DataName  -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
        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 _ nf :: NameFlavour
nf) =
  case NameFlavour
nf of
    -- NameGs are simple, as they have a NameSpace attached.
    NameG ns :: NameSpace
ns _ _ -> 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).
    _ -> 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
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