{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}
module Language.Haskell.TH.Desugar.Reify (
reifyWithLocals_maybe, reifyWithLocals, reifyWithWarning, reifyInDecs,
qReifyFixity, reifyFixity, reifyFixityWithLocals, reifyFixityInDecs,
getDataD, dataConNameToCon, dataConNameToDataName,
lookupValueNameWithLocals, lookupTypeNameWithLocals,
mkDataNameWithLocals, mkTypeNameWithLocals,
reifyNameSpace,
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
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)
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
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)
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."
getDataD :: DsMonad q
=> String
-> Name
-> 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
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."
dataConNameToCon :: DsMonad q => Name -> q Con
dataConNameToCon :: Name -> q Con
dataConNameToCon con_name :: Name
con_name = do
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
class (Quasi m, Fail.MonadFail m) => DsMonad m where
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 []
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
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)
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
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
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
#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)
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
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
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
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
quantifyClassMethodType
:: Name
-> [TyVarBndr]
-> Bool
-> 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
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
#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 :: Name -> Q (Maybe Fixity)
reifyFixity = qReifyFixity
#endif
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)
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
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
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
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
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
reifyNameSpace :: DsMonad q => Name -> q (Maybe NameSpace)
reifyNameSpace :: Name -> q (Maybe NameSpace)
reifyNameSpace n :: Name
n@(Name _ nf :: NameFlavour
nf) =
case NameFlavour
nf of
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
_ -> 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
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