{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
module Language.Haskell.TH.Desugar.Reify (
reifyWithLocals_maybe, reifyWithLocals, reifyWithWarning, reifyInDecs,
qReifyFixity, reifyFixity, reifyFixityWithLocals, reifyFixityInDecs,
qReifyType, reifyType,
reifyTypeWithLocals_maybe, reifyTypeWithLocals, reifyTypeInDecs,
getDataD, dataConNameToCon, dataConNameToDataName,
lookupValueNameWithLocals, lookupTypeNameWithLocals,
mkDataNameWithLocals, mkTypeNameWithLocals,
reifyNameSpace,
DsMonad(..), DsM, withLocalDeclarations
) where
import Control.Applicative
import qualified Control.Monad.Fail as Fail
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.RWS
import Control.Monad.Trans.Instances ()
import qualified Data.Foldable as F
import Data.Function (on)
import qualified Data.List as List
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe
import qualified Data.Set as Set
import Data.Set (Set)
import Language.Haskell.TH.Datatype ( freeVariables, freeVariablesWellScoped
, quantifyType, resolveTypeSynonyms )
import Language.Haskell.TH.Datatype.TyVarBndr
import Language.Haskell.TH.Instances ()
import Language.Haskell.TH.Syntax hiding ( lift )
import Language.Haskell.TH.Desugar.Util as Util
reifyWithLocals_maybe :: DsMonad q => Name -> q (Maybe Info)
reifyWithLocals_maybe :: forall (q :: * -> *). DsMonad q => Name -> q (Maybe Info)
reifyWithLocals_maybe Name
name = q (Maybe Info) -> q (Maybe Info) -> q (Maybe Info)
forall a. q a -> q a -> q a
forall (m :: * -> *) a. Quasi m => m a -> m a -> m a
qRecover
(Maybe Info -> q (Maybe Info)
forall a. a -> q a
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 a b. (a -> b) -> q a -> q b
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 :: forall (q :: * -> *). DsMonad q => Name -> q Info
reifyWithLocals Name
name = do
Maybe Info
m_info <- Name -> q (Maybe Info)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe Info)
reifyWithLocals_maybe Name
name
case Maybe Info
m_info of
Maybe Info
Nothing -> Name -> q Info
forall (m :: * -> *) a. MonadFail m => Name -> m a
reifyFail Name
name
Just Info
i -> Info -> q Info
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Info
i
reifyWithWarning :: (Quasi q, Fail.MonadFail q) => Name -> q Info
reifyWithWarning :: forall (q :: * -> *). (Quasi q, MonadFail q) => Name -> q Info
reifyWithWarning Name
name = q Info -> q Info -> q Info
forall a. q a -> q a -> q a
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 :: forall (m :: * -> *) a. MonadFail m => Name -> m a
reifyFail Name
name =
String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Looking up " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Name -> String
forall a. Show a => a -> String
show Name
name) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in the list of available " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"declarations failed.\nThis lookup fails if the declaration " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"referenced was made in the same Template\nHaskell splice as the use " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"of the declaration. If this is the case, put\nthe reference to " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"the declaration in a new splice."
getDataD :: DsMonad q
=> String
-> Name
-> q (DataFlavor, [TyVarBndrUnit], [Con])
getDataD :: forall (q :: * -> *).
DsMonad q =>
String -> Name -> q (DataFlavor, [TyVarBndrUnit], [Con])
getDataD String
err Name
name = do
Info
info <- Name -> q Info
forall (q :: * -> *). DsMonad q => Name -> q Info
reifyWithLocals Name
name
Dec
dec <- case Info
info of
TyConI Dec
dec -> Dec -> q Dec
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
dec
Info
_ -> q Dec
forall {a}. q a
badDeclaration
case Dec
dec of
DataD Cxt
_cxt Name
_name [TyVarBndrUnit]
tvbs Maybe Kind
mk [Con]
cons [DerivClause]
_derivings -> DataFlavor
-> [TyVarBndrUnit]
-> Maybe Kind
-> [Con]
-> q (DataFlavor, [TyVarBndrUnit], [Con])
forall {m :: * -> *} {a} {c}.
Quasi m =>
a
-> [TyVarBndrUnit] -> Maybe Kind -> c -> m (a, [TyVarBndrUnit], c)
go DataFlavor
Data [TyVarBndrUnit]
tvbs Maybe Kind
mk [Con]
cons
NewtypeD Cxt
_cxt Name
_name [TyVarBndrUnit]
tvbs Maybe Kind
mk Con
con [DerivClause]
_derivings -> DataFlavor
-> [TyVarBndrUnit]
-> Maybe Kind
-> [Con]
-> q (DataFlavor, [TyVarBndrUnit], [Con])
forall {m :: * -> *} {a} {c}.
Quasi m =>
a
-> [TyVarBndrUnit] -> Maybe Kind -> c -> m (a, [TyVarBndrUnit], c)
go DataFlavor
Newtype [TyVarBndrUnit]
tvbs Maybe Kind
mk [Con
con]
#if __GLASGOW_HASKELL__ >= 906
TypeDataD Name
_name [TyVarBndrUnit]
tvbs Maybe Kind
mk [Con]
cons -> DataFlavor
-> [TyVarBndrUnit]
-> Maybe Kind
-> [Con]
-> q (DataFlavor, [TyVarBndrUnit], [Con])
forall {m :: * -> *} {a} {c}.
Quasi m =>
a
-> [TyVarBndrUnit] -> Maybe Kind -> c -> m (a, [TyVarBndrUnit], c)
go DataFlavor
Util.TypeData [TyVarBndrUnit]
tvbs Maybe Kind
mk [Con]
cons
#endif
Dec
_ -> q (DataFlavor, [TyVarBndrUnit], [Con])
forall {a}. q a
badDeclaration
where
go :: a
-> [TyVarBndrUnit] -> Maybe Kind -> c -> m (a, [TyVarBndrUnit], c)
go a
df [TyVarBndrUnit]
tvbs Maybe Kind
mk c
cons = do
let k :: Kind
k = Kind -> Maybe Kind -> Kind
forall a. a -> Maybe a -> a
fromMaybe (Name -> Kind
ConT Name
typeKindName) Maybe Kind
mk
[TyVarBndrUnit]
extra_tvbs <- Kind -> m [TyVarBndrUnit]
forall (q :: * -> *). Quasi q => Kind -> q [TyVarBndrUnit]
mkExtraKindBinders Kind
k
let all_tvbs :: [TyVarBndrUnit]
all_tvbs = [TyVarBndrUnit]
tvbs [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a] -> [a]
++ [TyVarBndrUnit]
extra_tvbs
(a, [TyVarBndrUnit], c) -> m (a, [TyVarBndrUnit], c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
df, [TyVarBndrUnit]
all_tvbs, c
cons)
badDeclaration :: q a
badDeclaration =
String -> q a
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q a) -> String -> q a
forall a b. (a -> b) -> a -> b
$ String
"The name (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Name -> String
forall a. Show a => a -> String
show Name
name) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") refers to something " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"other than a datatype. " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
mkExtraKindBinders :: forall q. Quasi q => Kind -> q [TyVarBndrUnit]
Kind
k = do
Kind
k' <- Q Kind -> q Kind
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ (Q Kind -> q Kind) -> Q Kind -> q Kind
forall a b. (a -> b) -> a -> b
$ Kind -> Q Kind
resolveTypeSynonyms Kind
k
let (FunArgs
fun_args, Kind
_) = Kind -> (FunArgs, Kind)
unravelType Kind
k'
vis_fun_args :: [VisFunArg]
vis_fun_args = FunArgs -> [VisFunArg]
filterVisFunArgs FunArgs
fun_args
(VisFunArg -> q TyVarBndrUnit) -> [VisFunArg] -> q [TyVarBndrUnit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM VisFunArg -> q TyVarBndrUnit
mk_tvb [VisFunArg]
vis_fun_args
where
mk_tvb :: VisFunArg -> q TyVarBndrUnit
mk_tvb :: VisFunArg -> q TyVarBndrUnit
mk_tvb (VisFADep TyVarBndrUnit
tvb) = TyVarBndrUnit -> q TyVarBndrUnit
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return TyVarBndrUnit
tvb
mk_tvb (VisFAAnon Kind
ki) = Name -> Kind -> TyVarBndrUnit
kindedTV (Name -> Kind -> TyVarBndrUnit)
-> q Name -> q (Kind -> TyVarBndrUnit)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> q Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"a" q (Kind -> TyVarBndrUnit) -> q Kind -> q TyVarBndrUnit
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Kind -> q Kind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
ki
dataConNameToDataName :: DsMonad q => Name -> q Name
dataConNameToDataName :: forall (q :: * -> *). DsMonad q => Name -> q Name
dataConNameToDataName Name
con_name = do
Info
info <- Name -> q Info
forall (q :: * -> *). DsMonad q => Name -> q Info
reifyWithLocals Name
con_name
case Info
info of
DataConI Name
_name Kind
_type Name
parent_name -> Name -> q Name
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
parent_name
Info
_ -> String -> q Name
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q Name) -> String -> q Name
forall a b. (a -> b) -> a -> b
$ String
"The name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
con_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not appear to be " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"a data constructor."
dataConNameToCon :: DsMonad q => Name -> q Con
dataConNameToCon :: forall (q :: * -> *). DsMonad q => Name -> q Con
dataConNameToCon Name
con_name = do
Name
type_name <- Name -> q Name
forall (q :: * -> *). DsMonad q => Name -> q Name
dataConNameToDataName Name
con_name
(DataFlavor
_, [TyVarBndrUnit]
_, [Con]
cons) <- String -> Name -> q (DataFlavor, [TyVarBndrUnit], [Con])
forall (q :: * -> *).
DsMonad q =>
String -> Name -> q (DataFlavor, [TyVarBndrUnit], [Con])
getDataD String
"This seems to be an error in GHC." Name
type_name
let m_con :: Maybe Con
m_con = (Con -> Bool) -> [Con] -> Maybe Con
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name
con_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
==) ([Name] -> Bool) -> (Con -> [Name]) -> Con -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Con -> [Name]
get_con_name) [Con]
cons
case Maybe Con
m_con of
Just Con
con -> Con -> q Con
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Con
con
Maybe Con
Nothing -> String -> q Con
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Datatype does not contain one of its own constructors."
where
get_con_name :: Con -> [Name]
get_con_name (NormalC Name
name [BangType]
_) = [Name
name]
get_con_name (RecC Name
name [VarBangType]
_) = [Name
name]
get_con_name (InfixC BangType
_ Name
name BangType
_) = [Name
name]
get_con_name (ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
con) = Con -> [Name]
get_con_name Con
con
get_con_name (GadtC [Name]
names [BangType]
_ Kind
_) = [Name]
names
get_con_name (RecGadtC [Name]
names [VarBangType]
_ Kind
_) = [Name]
names
class (Quasi m, Fail.MonadFail m) => DsMonad m where
localDeclarations :: m [Dec]
instance DsMonad Q where
localDeclarations :: Q [Dec]
localDeclarations = [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
instance DsMonad IO where
localDeclarations :: IO [Dec]
localDeclarations = [Dec] -> IO [Dec]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
newtype DsM q a = DsM (ReaderT [Dec] q a)
deriving ( (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
$cfmap :: forall (q :: * -> *) a b.
Functor q =>
(a -> b) -> DsM q a -> DsM q b
fmap :: forall a b. (a -> b) -> DsM q a -> DsM q b
$c<$ :: forall (q :: * -> *) a b. Functor q => a -> DsM q b -> DsM q a
<$ :: forall a b. a -> DsM q b -> DsM q a
Functor, Functor (DsM q)
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)
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
$cpure :: forall (q :: * -> *) a. Applicative q => a -> DsM q a
pure :: forall a. a -> DsM q a
$c<*> :: forall (q :: * -> *) a b.
Applicative q =>
DsM q (a -> b) -> DsM q a -> DsM q b
<*> :: forall a b. DsM q (a -> b) -> DsM q a -> DsM q b
$cliftA2 :: forall (q :: * -> *) a b c.
Applicative q =>
(a -> b -> c) -> DsM q a -> DsM q b -> DsM q c
liftA2 :: forall a b c. (a -> b -> c) -> DsM q a -> DsM q b -> DsM q c
$c*> :: forall (q :: * -> *) a b.
Applicative q =>
DsM q a -> DsM q b -> DsM q b
*> :: forall a b. DsM q a -> DsM q b -> DsM q b
$c<* :: forall (q :: * -> *) a b.
Applicative q =>
DsM q a -> DsM q b -> DsM q a
<* :: forall a b. DsM q a -> DsM q b -> DsM q a
Applicative, Applicative (DsM q)
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)
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
$c>>= :: forall (q :: * -> *) a b.
Monad q =>
DsM q a -> (a -> DsM q b) -> DsM q b
>>= :: forall a b. DsM q a -> (a -> DsM q b) -> DsM q b
$c>> :: forall (q :: * -> *) a b. Monad q => DsM q a -> DsM q b -> DsM q b
>> :: forall a b. DsM q a -> DsM q b -> DsM q b
$creturn :: forall (q :: * -> *) a. Monad q => a -> DsM q a
return :: forall a. a -> DsM q a
Monad, (forall (q :: * -> *). Monad q => Monad (DsM q)) =>
(forall (m :: * -> *) a. Monad m => m a -> DsM m a)
-> MonadTrans DsM
forall (q :: * -> *). Monad q => Monad (DsM q)
forall (m :: * -> *) a. Monad m => m a -> DsM m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (m :: * -> *) a. Monad m => m a -> DsM m a
lift :: forall (m :: * -> *) a. Monad m => m a -> DsM m a
MonadTrans, MonadFail (DsM q)
MonadIO (DsM q)
DsM q String
DsM q [Extension]
DsM q Loc
Bool -> String -> DsM q (Maybe Name)
Bool -> String -> DsM q ()
String -> DsM q String
String -> DsM q Name
String -> DsM q ()
[Dec] -> DsM q ()
Q () -> DsM q ()
Name -> DsM q [Role]
Name -> DsM q [DecidedStrictness]
Name -> DsM q (Maybe Fixity)
Name -> DsM q Kind
Name -> DsM q Info
Name -> Cxt -> DsM q [Dec]
(MonadIO (DsM q), MonadFail (DsM q)) =>
(String -> DsM q Name)
-> (Bool -> String -> DsM q ())
-> (forall a. DsM q a -> DsM q a -> DsM q a)
-> (Bool -> String -> DsM q (Maybe Name))
-> (Name -> DsM q Info)
-> (Name -> DsM q (Maybe Fixity))
-> (Name -> DsM q Kind)
-> (Name -> Cxt -> DsM q [Dec])
-> (Name -> DsM q [Role])
-> (forall a. Data a => AnnLookup -> DsM q [a])
-> (Module -> DsM q ModuleInfo)
-> (Name -> DsM q [DecidedStrictness])
-> DsM q Loc
-> (forall a. IO a -> DsM q a)
-> DsM q String
-> (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]
-> (DocLoc -> String -> DsM q ())
-> (DocLoc -> DsM q (Maybe String))
-> Quasi (DsM q)
ForeignSrcLang -> String -> DsM q ()
Extension -> DsM q Bool
DocLoc -> DsM q (Maybe String)
DocLoc -> String -> DsM q ()
Module -> DsM q ModuleInfo
forall a. Data a => AnnLookup -> DsM q [a]
forall a. Typeable a => DsM q (Maybe a)
forall a. Typeable a => a -> DsM q ()
forall a. IO a -> DsM q a
forall a. DsM q a -> DsM q a -> DsM q a
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
(String -> m Name)
-> (Bool -> String -> m ())
-> (forall a. m a -> m a -> m a)
-> (Bool -> String -> m (Maybe Name))
-> (Name -> m Info)
-> (Name -> m (Maybe Fixity))
-> (Name -> m Kind)
-> (Name -> Cxt -> m [Dec])
-> (Name -> m [Role])
-> (forall a. Data a => AnnLookup -> m [a])
-> (Module -> m ModuleInfo)
-> (Name -> m [DecidedStrictness])
-> m Loc
-> (forall a. IO a -> m a)
-> m String
-> (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]
-> (DocLoc -> String -> m ())
-> (DocLoc -> m (Maybe String))
-> Quasi m
forall (q :: * -> *). Quasi q => MonadFail (DsM q)
forall (q :: * -> *). Quasi q => MonadIO (DsM q)
forall (q :: * -> *). Quasi q => DsM q String
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 [Role]
forall (q :: * -> *). Quasi q => Name -> DsM q [DecidedStrictness]
forall (q :: * -> *). Quasi q => Name -> DsM q (Maybe Fixity)
forall (q :: * -> *). Quasi q => Name -> DsM q Kind
forall (q :: * -> *). Quasi q => Name -> DsM q Info
forall (q :: * -> *). Quasi q => Name -> Cxt -> DsM q [Dec]
forall (q :: * -> *).
Quasi q =>
ForeignSrcLang -> String -> DsM q ()
forall (q :: * -> *). Quasi q => Extension -> DsM q Bool
forall (q :: * -> *). Quasi q => DocLoc -> DsM q (Maybe String)
forall (q :: * -> *). Quasi q => DocLoc -> 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
$cqNewName :: forall (q :: * -> *). Quasi q => String -> DsM q Name
qNewName :: String -> DsM q Name
$cqReport :: forall (q :: * -> *). Quasi q => Bool -> String -> DsM q ()
qReport :: Bool -> String -> DsM q ()
$cqRecover :: forall (q :: * -> *) a. Quasi q => DsM q a -> DsM q a -> DsM q a
qRecover :: forall a. DsM q a -> DsM q a -> DsM q a
$cqLookupName :: forall (q :: * -> *).
Quasi q =>
Bool -> String -> DsM q (Maybe Name)
qLookupName :: Bool -> String -> DsM q (Maybe Name)
$cqReify :: forall (q :: * -> *). Quasi q => Name -> DsM q Info
qReify :: Name -> DsM q Info
$cqReifyFixity :: forall (q :: * -> *). Quasi q => Name -> DsM q (Maybe Fixity)
qReifyFixity :: Name -> DsM q (Maybe Fixity)
$cqReifyType :: forall (q :: * -> *). Quasi q => Name -> DsM q Kind
qReifyType :: Name -> DsM q Kind
$cqReifyInstances :: forall (q :: * -> *). Quasi q => Name -> Cxt -> DsM q [Dec]
qReifyInstances :: Name -> Cxt -> DsM q [Dec]
$cqReifyRoles :: forall (q :: * -> *). Quasi q => Name -> DsM q [Role]
qReifyRoles :: Name -> DsM q [Role]
$cqReifyAnnotations :: forall (q :: * -> *) a. (Quasi q, Data a) => AnnLookup -> DsM q [a]
qReifyAnnotations :: forall a. Data a => AnnLookup -> DsM q [a]
$cqReifyModule :: forall (q :: * -> *). Quasi q => Module -> DsM q ModuleInfo
qReifyModule :: Module -> DsM q ModuleInfo
$cqReifyConStrictness :: forall (q :: * -> *). Quasi q => Name -> DsM q [DecidedStrictness]
qReifyConStrictness :: Name -> DsM q [DecidedStrictness]
$cqLocation :: forall (q :: * -> *). Quasi q => DsM q Loc
qLocation :: DsM q Loc
$cqRunIO :: forall (q :: * -> *) a. Quasi q => IO a -> DsM q a
qRunIO :: forall a. IO a -> DsM q a
$cqGetPackageRoot :: forall (q :: * -> *). Quasi q => DsM q String
qGetPackageRoot :: DsM q String
$cqAddDependentFile :: forall (q :: * -> *). Quasi q => String -> DsM q ()
qAddDependentFile :: String -> DsM q ()
$cqAddTempFile :: forall (q :: * -> *). Quasi q => String -> DsM q String
qAddTempFile :: String -> DsM q String
$cqAddTopDecls :: forall (q :: * -> *). Quasi q => [Dec] -> DsM q ()
qAddTopDecls :: [Dec] -> DsM q ()
$cqAddForeignFilePath :: forall (q :: * -> *).
Quasi q =>
ForeignSrcLang -> String -> DsM q ()
qAddForeignFilePath :: ForeignSrcLang -> String -> DsM q ()
$cqAddModFinalizer :: forall (q :: * -> *). Quasi q => Q () -> DsM q ()
qAddModFinalizer :: Q () -> DsM q ()
$cqAddCorePlugin :: forall (q :: * -> *). Quasi q => String -> DsM q ()
qAddCorePlugin :: String -> DsM q ()
$cqGetQ :: forall (q :: * -> *) a. (Quasi q, Typeable a) => DsM q (Maybe a)
qGetQ :: forall a. Typeable a => DsM q (Maybe a)
$cqPutQ :: forall (q :: * -> *) a. (Quasi q, Typeable a) => a -> DsM q ()
qPutQ :: forall a. Typeable a => a -> DsM q ()
$cqIsExtEnabled :: forall (q :: * -> *). Quasi q => Extension -> DsM q Bool
qIsExtEnabled :: Extension -> DsM q Bool
$cqExtsEnabled :: forall (q :: * -> *). Quasi q => DsM q [Extension]
qExtsEnabled :: DsM q [Extension]
$cqPutDoc :: forall (q :: * -> *). Quasi q => DocLoc -> String -> DsM q ()
qPutDoc :: DocLoc -> String -> DsM q ()
$cqGetDoc :: forall (q :: * -> *). Quasi q => DocLoc -> DsM q (Maybe String)
qGetDoc :: DocLoc -> DsM q (Maybe String)
Quasi, Monad (DsM q)
Monad (DsM q) => (forall a. String -> DsM q a) -> MonadFail (DsM q)
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
$cfail :: forall (q :: * -> *) a. MonadFail q => String -> DsM q a
fail :: forall a. String -> DsM q a
Fail.MonadFail
#if __GLASGOW_HASKELL__ >= 803
, Monad (DsM q)
Monad (DsM q) => (forall a. IO a -> DsM q a) -> MonadIO (DsM q)
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
$cliftIO :: forall (q :: * -> *) a. MonadIO q => IO a -> DsM q a
liftIO :: forall a. IO a -> DsM q a
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 (m :: * -> *) a. Monad m => m a -> ReaderT r m a
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 (m :: * -> *) a. Monad m => m a -> StateT s m a
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 (m :: * -> *) a. Monad m => m a -> WriterT w m a
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 (m :: * -> *) a. Monad m => m a -> RWST r w s m a
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 :: forall (q :: * -> *) a. DsMonad q => [Dec] -> DsM q a -> q a
withLocalDeclarations [Dec]
new_decs (DsM ReaderT [Dec] q a
x) = do
[Dec]
orig_decs <- q [Dec]
forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations
ReaderT [Dec] q a -> [Dec] -> q a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT [Dec] q a
x ([Dec]
orig_decs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
new_decs)
reifyInDecs :: Name -> [Dec] -> Maybe Info
reifyInDecs :: Name -> [Dec] -> Maybe Info
reifyInDecs Name
n [Dec]
decs = (Name, Info) -> Info
forall a b. (a, b) -> b
snd ((Name, Info) -> Info) -> Maybe (Name, Info) -> Maybe Info
forall a b. (a -> b) -> Maybe a -> Maybe b
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 Name
n = (Dec -> Maybe Fixity) -> [Dec] -> Maybe Fixity
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch Dec -> Maybe Fixity
match_fixity
where
match_fixity :: Dec -> Maybe Fixity
match_fixity (InfixD Fixity
fixity Name
n') | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
= Fixity -> Maybe Fixity
forall a. a -> Maybe a
Just Fixity
fixity
match_fixity (ClassD Cxt
_ Name
_ [TyVarBndrUnit]
_ [FunDep]
_ [Dec]
sub_decs) = (Dec -> Maybe Fixity) -> [Dec] -> Maybe Fixity
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch Dec -> Maybe Fixity
match_fixity [Dec]
sub_decs
match_fixity Dec
_ = Maybe Fixity
forall a. Maybe a
Nothing
type Named a = (Name, a)
reifyInDec :: Name -> [Dec] -> Dec -> Maybe (Named Info)
reifyInDec :: Name -> [Dec] -> Dec -> Maybe (Name, Info)
reifyInDec Name
n [Dec]
decs (FunD Name
n' [Clause]
_) | Name
n Name -> Name -> Bool
`nameMatches` Name
n' = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Name -> [Dec] -> Info
mkVarI Name
n [Dec]
decs)
reifyInDec Name
n [Dec]
decs (ValD Pat
pat Body
_ [Dec]
_)
| Just Name
n' <- (Name -> Bool) -> [Name] -> Maybe Name
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Name -> Name -> Bool
nameMatches Name
n) (OSet Name -> [Name]
forall a. OSet a -> [a]
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)
reifyInDec Name
n [Dec]
_ dec :: Dec
dec@(DataD Cxt
_ Name
n' [TyVarBndrUnit]
_ Maybe Kind
_ [Con]
_ [DerivClause]
_) | Name
n Name -> Name -> Bool
`nameMatches` Name
n' = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Dec -> Info
TyConI Dec
dec)
reifyInDec Name
n [Dec]
_ dec :: Dec
dec@(NewtypeD Cxt
_ Name
n' [TyVarBndrUnit]
_ Maybe Kind
_ Con
_ [DerivClause]
_) | Name
n Name -> Name -> Bool
`nameMatches` Name
n' = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Dec -> Info
TyConI Dec
dec)
reifyInDec Name
n [Dec]
_ dec :: Dec
dec@(TySynD Name
n' [TyVarBndrUnit]
_ Kind
_) | Name
n Name -> Name -> Bool
`nameMatches` Name
n' = (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Dec -> Info
TyConI Dec
dec)
reifyInDec Name
n [Dec]
decs dec :: Dec
dec@(ClassD Cxt
_ Name
n' [TyVarBndrUnit]
_ [FunDep]
_ [Dec]
_) | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
= (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Dec -> [Dec] -> Info
ClassI (Dec -> Dec
quantifyClassDecMethods Dec
dec) (Name -> [Dec] -> [Dec]
findInstances Name
n [Dec]
decs))
reifyInDec Name
n [Dec]
_ (ForeignD (ImportF Callconv
_ Safety
_ String
_ Name
n' Kind
ty)) | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
= (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Name -> Kind -> Info
mkVarITy Name
n Kind
ty)
reifyInDec Name
n [Dec]
_ (ForeignD (ExportF Callconv
_ String
_ Name
n' Kind
ty)) | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
= (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Name -> Kind -> Info
mkVarITy Name
n Kind
ty)
reifyInDec Name
n [Dec]
decs dec :: Dec
dec@(OpenTypeFamilyD (TypeFamilyHead Name
n' [TyVarBndrUnit]
_ FamilyResultSig
_ Maybe InjectivityAnn
_)) | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
= (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Dec -> [Dec] -> Info
FamilyI Dec
dec (Name -> [Dec] -> [Dec]
findInstances Name
n [Dec]
decs))
reifyInDec Name
n [Dec]
decs dec :: Dec
dec@(DataFamilyD Name
n' [TyVarBndrUnit]
_ Maybe Kind
_) | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
= (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Dec -> [Dec] -> Info
FamilyI Dec
dec (Name -> [Dec] -> [Dec]
findInstances Name
n [Dec]
decs))
reifyInDec Name
n [Dec]
_ dec :: Dec
dec@(ClosedTypeFamilyD (TypeFamilyHead Name
n' [TyVarBndrUnit]
_ FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
_) | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
= (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Dec -> [Dec] -> Info
FamilyI Dec
dec [])
#if __GLASGOW_HASKELL__ >= 801
reifyInDec Name
n [Dec]
decs (PatSynD Name
n' PatSynArgs
_ PatSynDir
_ Pat
_) | Name
n Name -> Name -> Bool
`nameMatches` Name
n'
= (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Name -> [Dec] -> Info
mkPatSynI Name
n [Dec]
decs)
#endif
#if __GLASGOW_HASKELL__ >= 906
reifyInDec Name
n [Dec]
_ dec :: Dec
dec@(TypeDataD Name
n' [TyVarBndrUnit]
_ Maybe Kind
_ [Con]
_) | 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)
#endif
reifyInDec Name
n [Dec]
decs (DataD Cxt
_ Name
ty_name [TyVarBndrUnit]
tvbs Maybe Kind
_mk [Con]
cons [DerivClause]
_)
| Just (Name, Info)
info <- Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Name, Info)
maybeReifyCon Name
n [Dec]
decs Name
ty_name ((TyVarBndrUnit -> TypeArg) -> [TyVarBndrUnit] -> [TypeArg]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> TypeArg
forall flag. TyVarBndr_ flag -> TypeArg
tvbToTANormalWithSig [TyVarBndrUnit]
tvbs) [Con]
cons
= (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name, Info)
info
reifyInDec Name
n [Dec]
decs (NewtypeD Cxt
_ Name
ty_name [TyVarBndrUnit]
tvbs Maybe Kind
_mk Con
con [DerivClause]
_)
| Just (Name, Info)
info <- Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Name, Info)
maybeReifyCon Name
n [Dec]
decs Name
ty_name ((TyVarBndrUnit -> TypeArg) -> [TyVarBndrUnit] -> [TypeArg]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> TypeArg
forall flag. TyVarBndr_ flag -> TypeArg
tvbToTANormalWithSig [TyVarBndrUnit]
tvbs) [Con
con]
= (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name, Info)
info
reifyInDec Name
n [Dec]
_decs (ClassD Cxt
_ Name
ty_name [TyVarBndrUnit]
tvbs [FunDep]
_ [Dec]
sub_decs)
| Just (Name
n', Kind
ty) <- Name -> [Dec] -> Maybe (Named Kind)
findType Name
n [Dec]
sub_decs
= (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Name -> Kind -> Name -> Info
ClassOpI Name
n (Name -> [TyVarBndrUnit] -> Bool -> Kind -> Kind
quantifyClassMethodType Name
ty_name [TyVarBndrUnit]
tvbs Bool
True Kind
ty) Name
ty_name)
reifyInDec Name
n [Dec]
decs (ClassD Cxt
_ Name
_ [TyVarBndrUnit]
_ [FunDep]
_ [Dec]
sub_decs)
| Just (Name, Info)
info <- (Dec -> Maybe (Name, Info)) -> [Dec] -> Maybe (Name, Info)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch (Name -> [Dec] -> Dec -> Maybe (Name, Info)
reifyInDec Name
n [Dec]
decs) [Dec]
sub_decs
= (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name, Info)
info
reifyInDec Name
n [Dec]
decs (InstanceD Maybe Overlap
_ Cxt
_ Kind
_ [Dec]
sub_decs)
| Just (Name, Info)
info <- (Dec -> Maybe (Name, Info)) -> [Dec] -> Maybe (Name, Info)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch Dec -> Maybe (Name, Info)
reify_in_instance [Dec]
sub_decs
= (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name, Info)
info
where
reify_in_instance :: Dec -> Maybe (Name, Info)
reify_in_instance dec :: Dec
dec@(DataInstD {}) = Name -> [Dec] -> Dec -> Maybe (Name, Info)
reifyInDec Name
n ([Dec]
sub_decs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
decs) Dec
dec
reify_in_instance dec :: Dec
dec@(NewtypeInstD {}) = Name -> [Dec] -> Dec -> Maybe (Name, Info)
reifyInDec Name
n ([Dec]
sub_decs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
decs) Dec
dec
reify_in_instance Dec
_ = Maybe (Name, Info)
forall a. Maybe a
Nothing
#if __GLASGOW_HASKELL__ >= 801
reifyInDec Name
n [Dec]
decs (PatSynD Name
pat_syn_name PatSynArgs
args PatSynDir
_ Pat
_)
| Just (Name
n', Kind
full_sel_ty) <- Name -> [Dec] -> Name -> PatSynArgs -> Maybe (Named Kind)
maybeReifyPatSynRecSelector Name
n [Dec]
decs Name
pat_syn_name PatSynArgs
args
= (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Name -> Kind -> Maybe Dec -> Info
VarI Name
n Kind
full_sel_ty Maybe Dec
forall a. Maybe a
Nothing)
#endif
#if __GLASGOW_HASKELL__ >= 807
reifyInDec Name
n [Dec]
decs (DataInstD Cxt
_ Maybe [TyVarBndrUnit]
_ Kind
lhs Maybe Kind
_ [Con]
cons [DerivClause]
_)
| (ConT Name
ty_name, [TypeArg]
tys) <- Kind -> (Kind, [TypeArg])
unfoldType Kind
lhs
, Just (Name, Info)
info <- Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Name, Info)
maybeReifyCon Name
n [Dec]
decs Name
ty_name [TypeArg]
tys [Con]
cons
= (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name, Info)
info
reifyInDec Name
n [Dec]
decs (NewtypeInstD Cxt
_ Maybe [TyVarBndrUnit]
_ Kind
lhs Maybe Kind
_ Con
con [DerivClause]
_)
| (ConT Name
ty_name, [TypeArg]
tys) <- Kind -> (Kind, [TypeArg])
unfoldType Kind
lhs
, Just (Name, Info)
info <- Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Name, Info)
maybeReifyCon Name
n [Dec]
decs Name
ty_name [TypeArg]
tys [Con
con]
= (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name, Info)
info
#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
#if __GLASGOW_HASKELL__ >= 906
reifyInDec Name
n [Dec]
decs (TypeDataD Name
ty_name [TyVarBndrUnit]
tvbs Maybe Kind
_mk [Con]
cons)
| Just (Name, Info)
info <- Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Name, Info)
maybeReifyCon Name
n [Dec]
decs Name
ty_name ((TyVarBndrUnit -> TypeArg) -> [TyVarBndrUnit] -> [TypeArg]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> TypeArg
forall flag. TyVarBndr_ flag -> TypeArg
tvbToTANormalWithSig [TyVarBndrUnit]
tvbs) [Con]
cons
= (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name, Info)
info
#endif
reifyInDec Name
_ [Dec]
_ Dec
_ = Maybe (Name, Info)
forall a. Maybe a
Nothing
maybeReifyCon :: Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Named Info)
maybeReifyCon :: Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Name, Info)
maybeReifyCon Name
n [Dec]
_decs Name
ty_name [TypeArg]
ty_args [Con]
cons
| Just (Name
n', Con
con) <- Name -> [Con] -> Maybe (Named Con)
findCon Name
n [Con]
cons
, let full_con_ty :: Kind
full_con_ty = Kind -> Kind
unSigType (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$ [TyVarBndrUnit] -> Kind -> Con -> Kind
con_to_type [TyVarBndrUnit]
h98_tvbs Kind
h98_res_ty Con
con
= (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Name -> Kind -> Name -> Info
DataConI Name
n Kind
full_con_ty Name
ty_name)
| Just (Name
n', RecSelInfo
rec_sel_info) <- Name -> [Con] -> Maybe (Named RecSelInfo)
findRecSelector Name
n [Con]
cons
, let ([TyVarBndr Specificity]
tvbs, Kind
sel_ty, Kind
con_res_ty) = RecSelInfo -> ([TyVarBndr Specificity], Kind, Kind)
extract_rec_sel_info RecSelInfo
rec_sel_info
full_sel_ty :: Kind
full_sel_ty = Kind -> Kind
unSigType (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$ [TyVarBndr Specificity] -> Cxt -> Kind -> Kind
maybeForallT [TyVarBndr Specificity]
tvbs [] (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$ Cxt -> Kind -> Kind
mkArrows [Kind
con_res_ty] Kind
sel_ty
= (Name, Info) -> Maybe (Name, Info)
forall a. a -> Maybe a
Just (Name
n', Name -> Kind -> Maybe Dec -> Info
VarI Name
n Kind
full_sel_ty Maybe Dec
forall a. Maybe a
Nothing)
where
extract_rec_sel_info :: RecSelInfo -> ([TyVarBndrSpec], Type, Type)
extract_rec_sel_info :: RecSelInfo -> ([TyVarBndr Specificity], Kind, Kind)
extract_rec_sel_info RecSelInfo
rec_sel_info =
case RecSelInfo
rec_sel_info of
RecSelH98 Kind
sel_ty ->
( Specificity -> [TyVarBndrUnit] -> [TyVarBndr Specificity]
forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags Specificity
SpecifiedSpec [TyVarBndrUnit]
h98_tvbs
, Kind
sel_ty
, Kind
h98_res_ty
)
RecSelGADT Maybe [TyVarBndr Specificity]
mb_con_tvbs Kind
sel_ty Kind
con_res_ty ->
let
con_tvbs' :: [TyVarBndr Specificity]
con_tvbs' =
case Maybe [TyVarBndr Specificity]
mb_con_tvbs of
Just [TyVarBndr Specificity]
con_tvbs -> [TyVarBndr Specificity]
con_tvbs
Maybe [TyVarBndr Specificity]
Nothing ->
Specificity -> [TyVarBndrUnit] -> [TyVarBndr Specificity]
forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags Specificity
SpecifiedSpec ([TyVarBndrUnit] -> [TyVarBndr Specificity])
-> [TyVarBndrUnit] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> a -> b
$
Cxt -> [TyVarBndrUnit]
freeVariablesWellScoped [Kind
con_res_ty, Kind
sel_ty] in
( [TyVarBndr Specificity]
con_tvbs'
, Kind
sel_ty
, Kind
con_res_ty
)
h98_tvbs :: [TyVarBndrUnit]
h98_tvbs = Cxt -> [TyVarBndrUnit]
freeVariablesWellScoped (Cxt -> [TyVarBndrUnit]) -> Cxt -> [TyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$
(TypeArg -> Kind) -> [TypeArg] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map TypeArg -> Kind
probablyWrongUnTypeArg [TypeArg]
ty_args
h98_res_ty :: Kind
h98_res_ty = Kind -> [TypeArg] -> Kind
applyType (Name -> Kind
ConT Name
ty_name) [TypeArg]
ty_args
maybeReifyCon Name
_ [Dec]
_ Name
_ [TypeArg]
_ [Con]
_ = Maybe (Name, Info)
forall a. Maybe a
Nothing
#if __GLASGOW_HASKELL__ >= 801
maybeReifyPatSynRecSelector ::
Name -> [Dec] -> Name -> PatSynArgs -> Maybe (Named Type)
maybeReifyPatSynRecSelector :: Name -> [Dec] -> Name -> PatSynArgs -> Maybe (Named Kind)
maybeReifyPatSynRecSelector Name
n [Dec]
decs Name
pat_syn_name PatSynArgs
pat_syn_args =
case PatSynArgs
pat_syn_args of
RecordPatSyn [Name]
fld_names
-> (Named Kind -> Maybe (Named Kind))
-> [Named Kind] -> Maybe (Named Kind)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch Named Kind -> Maybe (Named Kind)
match_pat_syn_rec_sel ([Named Kind] -> Maybe (Named Kind))
-> [Named Kind] -> Maybe (Named Kind)
forall a b. (a -> b) -> a -> b
$
[Name] -> Cxt -> [Named Kind]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
fld_names Cxt
pat_syn_ty_vis_args
PatSynArgs
_ -> Maybe (Named Kind)
forall a. Maybe a
Nothing
where
match_pat_syn_rec_sel :: (Name, Type) -> Maybe (Named Type)
match_pat_syn_rec_sel :: Named Kind -> Maybe (Named Kind)
match_pat_syn_rec_sel (Name
n', Kind
field_ty)
| Name
n Name -> Name -> Bool
`nameMatches` Name
n'
= Named Kind -> Maybe (Named Kind)
forall a. a -> Maybe a
Just ( Name
n'
,
Kind -> Kind
unSigType (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
[TyVarBndr Specificity] -> Cxt -> Kind -> Kind
maybeForallT [TyVarBndr Specificity]
pat_syn_ty_tvbs Cxt
pat_syn_ty_req_cxt (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
Kind
ArrowT Kind -> Kind -> Kind
`AppT` Kind
pat_syn_ty_res Kind -> Kind -> Kind
`AppT` Kind
field_ty
)
match_pat_syn_rec_sel Named Kind
_
= Maybe (Named Kind)
forall a. Maybe a
Nothing
pat_syn_ty :: Type
pat_syn_ty :: Kind
pat_syn_ty =
case Name -> [Dec] -> Maybe Kind
findPatSynType Name
pat_syn_name [Dec]
decs of
Just Kind
ty -> Kind
ty
Maybe Kind
Nothing -> Name -> Kind
no_type Name
n
pat_syn_ty_args :: FunArgs
pat_syn_ty_res :: Type
(FunArgs
pat_syn_ty_args, Kind
pat_syn_ty_res) =
Kind -> (FunArgs, Kind)
unravelType Kind
pat_syn_ty
pat_syn_ty_tvbs :: [TyVarBndrSpec]
pat_syn_ty_req_cxt :: Cxt
pat_syn_ty_vis_args :: [Type]
([TyVarBndr Specificity]
pat_syn_ty_tvbs, Cxt
pat_syn_ty_req_cxt, Cxt
pat_syn_ty_vis_args) =
case FunArgs
pat_syn_ty_args of
FAForalls (ForallInvis [TyVarBndr Specificity]
req_tvbs) (FACxt Cxt
req_cxt FunArgs
args) ->
( [TyVarBndr Specificity]
req_tvbs
, Cxt
req_cxt
, (VisFunArg -> Maybe Kind) -> [VisFunArg] -> Cxt
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VisFunArg -> Maybe Kind
vis_arg_anon_maybe ([VisFunArg] -> Cxt) -> [VisFunArg] -> Cxt
forall a b. (a -> b) -> a -> b
$ FunArgs -> [VisFunArg]
filterVisFunArgs FunArgs
args
)
FAForalls (ForallInvis [TyVarBndr Specificity]
req_tvbs) FunArgs
args ->
( [TyVarBndr Specificity]
req_tvbs
, []
, (VisFunArg -> Maybe Kind) -> [VisFunArg] -> Cxt
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VisFunArg -> Maybe Kind
vis_arg_anon_maybe ([VisFunArg] -> Cxt) -> [VisFunArg] -> Cxt
forall a b. (a -> b) -> a -> b
$ FunArgs -> [VisFunArg]
filterVisFunArgs FunArgs
args
)
FACxt Cxt
req_cxt FunArgs
args ->
( Specificity -> [TyVarBndrUnit] -> [TyVarBndr Specificity]
forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags Specificity
SpecifiedSpec ([TyVarBndrUnit] -> [TyVarBndr Specificity])
-> [TyVarBndrUnit] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> a -> b
$
Cxt -> [TyVarBndrUnit]
freeVariablesWellScoped [Kind
pat_syn_ty]
, Cxt
req_cxt
, (VisFunArg -> Maybe Kind) -> [VisFunArg] -> Cxt
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VisFunArg -> Maybe Kind
vis_arg_anon_maybe ([VisFunArg] -> Cxt) -> [VisFunArg] -> Cxt
forall a b. (a -> b) -> a -> b
$ FunArgs -> [VisFunArg]
filterVisFunArgs FunArgs
args
)
FunArgs
args ->
( Specificity -> [TyVarBndrUnit] -> [TyVarBndr Specificity]
forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags Specificity
SpecifiedSpec ([TyVarBndrUnit] -> [TyVarBndr Specificity])
-> [TyVarBndrUnit] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> a -> b
$
Cxt -> [TyVarBndrUnit]
freeVariablesWellScoped [Kind
pat_syn_ty]
, []
, (VisFunArg -> Maybe Kind) -> [VisFunArg] -> Cxt
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VisFunArg -> Maybe Kind
vis_arg_anon_maybe ([VisFunArg] -> Cxt) -> [VisFunArg] -> Cxt
forall a b. (a -> b) -> a -> b
$ FunArgs -> [VisFunArg]
filterVisFunArgs FunArgs
args
)
vis_arg_anon_maybe :: VisFunArg -> Maybe Type
vis_arg_anon_maybe :: VisFunArg -> Maybe Kind
vis_arg_anon_maybe (VisFAAnon Kind
ty) = Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
ty
vis_arg_anon_maybe (VisFADep{}) = Maybe Kind
forall a. Maybe a
Nothing
#endif
con_to_type :: [TyVarBndrUnit]
-> Type
-> Con -> Type
con_to_type :: [TyVarBndrUnit] -> Kind -> Con -> Kind
con_to_type [TyVarBndrUnit]
h98_tvbs Kind
h98_result_ty Con
con =
case Con -> (Bool, Kind)
go Con
con of
(Bool
is_gadt, Kind
ty) | Bool
is_gadt -> Kind
ty
| Bool
otherwise -> [TyVarBndr Specificity] -> Cxt -> Kind -> Kind
maybeForallT
(Specificity -> [TyVarBndrUnit] -> [TyVarBndr Specificity]
forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags Specificity
SpecifiedSpec [TyVarBndrUnit]
h98_tvbs)
[] Kind
ty
where
go :: Con -> (Bool, Type)
go :: Con -> (Bool, Kind)
go (NormalC Name
_ [BangType]
stys) = (Bool
False, Cxt -> Kind -> Kind
mkArrows ((BangType -> Kind) -> [BangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Kind
forall a b. (a, b) -> b
snd [BangType]
stys) Kind
h98_result_ty)
go (RecC Name
_ [VarBangType]
vstys) = (Bool
False, Cxt -> Kind -> Kind
mkArrows ((VarBangType -> Kind) -> [VarBangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Kind
forall a b c. (a, b, c) -> c
thdOf3 [VarBangType]
vstys) Kind
h98_result_ty)
go (InfixC BangType
t1 Name
_ BangType
t2) = (Bool
False, Cxt -> Kind -> Kind
mkArrows ((BangType -> Kind) -> [BangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Kind
forall a b. (a, b) -> b
snd [BangType
t1, BangType
t2]) Kind
h98_result_ty)
go (ForallC [TyVarBndr Specificity]
bndrs Cxt
cxt Con
c) = (Kind -> Kind) -> (Bool, Kind) -> (Bool, Kind)
forall a b c. (a -> b) -> (c, a) -> (c, b)
liftSnd ([TyVarBndr Specificity] -> Cxt -> Kind -> Kind
ForallT [TyVarBndr Specificity]
bndrs Cxt
cxt) (Con -> (Bool, Kind)
go Con
c)
go (GadtC [Name]
_ [BangType]
stys Kind
rty) = (Bool
True, Cxt -> Kind -> Kind
mkArrows ((BangType -> Kind) -> [BangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Kind
forall a b. (a, b) -> b
snd [BangType]
stys) Kind
rty)
go (RecGadtC [Name]
_ [VarBangType]
vstys Kind
rty) = (Bool
True, Cxt -> Kind -> Kind
mkArrows ((VarBangType -> Kind) -> [VarBangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Kind
forall a b c. (a, b, c) -> c
thdOf3 [VarBangType]
vstys) Kind
rty)
mkVarI :: Name -> [Dec] -> Info
mkVarI :: Name -> [Dec] -> Info
mkVarI Name
n [Dec]
decs = Name -> Kind -> Info
mkVarITy Name
n (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 -> Type -> Info
mkVarITy :: Name -> Kind -> Info
mkVarITy Name
n Kind
ty = Name -> Kind -> Maybe Dec -> Info
VarI Name
n Kind
ty Maybe Dec
forall a. Maybe a
Nothing
findType :: Name -> [Dec] -> Maybe (Named Type)
findType :: Name -> [Dec] -> Maybe (Named Kind)
findType Name
n = (Dec -> Maybe (Named Kind)) -> [Dec] -> Maybe (Named Kind)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch Dec -> Maybe (Named Kind)
match_type
where
match_type :: Dec -> Maybe (Named Kind)
match_type (SigD Name
n' Kind
ty) | Name
n Name -> Name -> Bool
`nameMatches` Name
n' = Named Kind -> Maybe (Named Kind)
forall a. a -> Maybe a
Just (Name
n', Kind
ty)
match_type Dec
_ = Maybe (Named Kind)
forall a. Maybe a
Nothing
#if __GLASGOW_HASKELL__ >= 801
mkPatSynI :: Name -> [Dec] -> Info
mkPatSynI :: Name -> [Dec] -> Info
mkPatSynI Name
n [Dec]
decs = Name -> Kind -> Info
PatSynI Name
n (Kind -> Maybe Kind -> Kind
forall a. a -> Maybe a -> a
fromMaybe (Name -> Kind
no_type Name
n) (Maybe Kind -> Kind) -> Maybe Kind -> Kind
forall a b. (a -> b) -> a -> b
$ Name -> [Dec] -> Maybe Kind
findPatSynType Name
n [Dec]
decs)
findPatSynType :: Name -> [Dec] -> Maybe PatSynType
findPatSynType :: Name -> [Dec] -> Maybe Kind
findPatSynType Name
n = (Dec -> Maybe Kind) -> [Dec] -> Maybe Kind
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch Dec -> Maybe Kind
match_pat_syn_type
where
match_pat_syn_type :: Dec -> Maybe Kind
match_pat_syn_type (PatSynSigD Name
n' Kind
psty) | Name
n Name -> Name -> Bool
`nameMatches` Name
n' = Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
psty
match_pat_syn_type Dec
_ = Maybe Kind
forall a. Maybe a
Nothing
#endif
no_type :: Name -> Type
no_type :: Name -> Kind
no_type Name
n = String -> Kind
forall a. HasCallStack => String -> a
error (String -> Kind) -> String -> Kind
forall a b. (a -> b) -> a -> b
$ String
"No type information found in local declaration for "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n
findInstances :: Name -> [Dec] -> [Dec]
findInstances :: Name -> [Dec] -> [Dec]
findInstances Name
n = (Dec -> Dec) -> [Dec] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Dec
stripInstanceDec ([Dec] -> [Dec]) -> ([Dec] -> [Dec]) -> [Dec] -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dec -> [Dec]) -> [Dec] -> [Dec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Dec -> [Dec]
match_instance
where
match_instance :: Dec -> [Dec]
match_instance d :: Dec
d@(InstanceD Maybe Overlap
_ Cxt
_ Kind
ty [Dec]
_) | ConT Name
n' <- Kind -> Kind
ty_head Kind
ty
, Name
n Name -> Name -> Bool
`nameMatches` Name
n' = [Dec
d]
#if __GLASGOW_HASKELL__ >= 807
match_instance (DataInstD Cxt
ctxt Maybe [TyVarBndrUnit]
_ Kind
lhs Maybe Kind
mk [Con]
cons [DerivClause]
derivs)
| ConT Name
n' <- Kind -> Kind
ty_head Kind
lhs
, Name
n Name -> Name -> Bool
`nameMatches` Name
n' = [Dec
d]
where
mtvbs :: Maybe [TyVarBndrUnit]
mtvbs = Cxt -> Kind -> Maybe Kind -> Maybe [TyVarBndrUnit]
rejig_data_inst_tvbs Cxt
ctxt Kind
lhs Maybe Kind
mk
d :: Dec
d = Cxt
-> Maybe [TyVarBndrUnit]
-> Kind
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataInstD Cxt
ctxt Maybe [TyVarBndrUnit]
mtvbs Kind
lhs Maybe Kind
mk [Con]
cons [DerivClause]
derivs
match_instance (NewtypeInstD Cxt
ctxt Maybe [TyVarBndrUnit]
_ Kind
lhs Maybe Kind
mk Con
con [DerivClause]
derivs)
| ConT Name
n' <- Kind -> Kind
ty_head Kind
lhs
, Name
n Name -> Name -> Bool
`nameMatches` Name
n' = [Dec
d]
where
mtvbs :: Maybe [TyVarBndrUnit]
mtvbs = Cxt -> Kind -> Maybe Kind -> Maybe [TyVarBndrUnit]
rejig_data_inst_tvbs Cxt
ctxt Kind
lhs Maybe Kind
mk
d :: Dec
d = Cxt
-> Maybe [TyVarBndrUnit]
-> Kind
-> Maybe Kind
-> Con
-> [DerivClause]
-> Dec
NewtypeInstD Cxt
ctxt Maybe [TyVarBndrUnit]
mtvbs Kind
lhs Maybe Kind
mk Con
con [DerivClause]
derivs
#else
match_instance d@(DataInstD _ n' _ _ _ _) | n `nameMatches` n' = [d]
match_instance d@(NewtypeInstD _ n' _ _ _ _) | n `nameMatches` n' = [d]
#endif
#if __GLASGOW_HASKELL__ >= 807
match_instance (TySynInstD (TySynEqn Maybe [TyVarBndrUnit]
_ Kind
lhs Kind
rhs))
| ConT Name
n' <- Kind -> Kind
ty_head Kind
lhs
, Name
n Name -> Name -> Bool
`nameMatches` Name
n' = [Dec
d]
where
mtvbs :: Maybe [TyVarBndrUnit]
mtvbs = Cxt -> Maybe [TyVarBndrUnit]
rejig_tvbs [Kind
lhs, Kind
rhs]
d :: Dec
d = TySynEqn -> Dec
TySynInstD (Maybe [TyVarBndrUnit] -> Kind -> Kind -> TySynEqn
TySynEqn Maybe [TyVarBndrUnit]
mtvbs Kind
lhs Kind
rhs)
#else
match_instance d@(TySynInstD n' _) | n `nameMatches` n' = [d]
#endif
match_instance (InstanceD Maybe Overlap
_ Cxt
_ Kind
_ [Dec]
decs)
= (Dec -> [Dec]) -> [Dec] -> [Dec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Dec -> [Dec]
match_instance [Dec]
decs
match_instance Dec
_ = []
#if __GLASGOW_HASKELL__ >= 807
rejig_tvbs :: [Type] -> Maybe [TyVarBndrUnit]
rejig_tvbs :: Cxt -> Maybe [TyVarBndrUnit]
rejig_tvbs Cxt
ts =
let tvbs :: [TyVarBndrUnit]
tvbs = Cxt -> [TyVarBndrUnit]
freeVariablesWellScoped Cxt
ts
in if [TyVarBndrUnit] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndrUnit]
tvbs
then Maybe [TyVarBndrUnit]
forall a. Maybe a
Nothing
else [TyVarBndrUnit] -> Maybe [TyVarBndrUnit]
forall a. a -> Maybe a
Just [TyVarBndrUnit]
tvbs
rejig_data_inst_tvbs :: Cxt -> Type -> Maybe Kind -> Maybe [TyVarBndrUnit]
rejig_data_inst_tvbs :: Cxt -> Kind -> Maybe Kind -> Maybe [TyVarBndrUnit]
rejig_data_inst_tvbs Cxt
cxt Kind
lhs Maybe Kind
mk =
Cxt -> Maybe [TyVarBndrUnit]
rejig_tvbs (Cxt -> Maybe [TyVarBndrUnit]) -> Cxt -> Maybe [TyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$ Cxt
cxt Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ [Kind
lhs] Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Maybe Kind -> Cxt
forall a. Maybe a -> [a]
maybeToList Maybe Kind
mk
#endif
ty_head :: Kind -> Kind
ty_head = (Kind, [TypeArg]) -> Kind
forall a b. (a, b) -> a
fst ((Kind, [TypeArg]) -> Kind)
-> (Kind -> (Kind, [TypeArg])) -> Kind -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> (Kind, [TypeArg])
unfoldType
quantifyClassDecMethods :: Dec -> Dec
quantifyClassDecMethods :: Dec -> Dec
quantifyClassDecMethods (ClassD Cxt
cxt Name
cls_name [TyVarBndrUnit]
cls_tvbs [FunDep]
fds [Dec]
sub_decs)
= Cxt -> Name -> [TyVarBndrUnit] -> [FunDep] -> [Dec] -> Dec
ClassD Cxt
cxt Name
cls_name [TyVarBndrUnit]
cls_tvbs [FunDep]
fds [Dec]
sub_decs'
where
sub_decs' :: [Dec]
sub_decs' = (Dec -> Maybe Dec) -> [Dec] -> [Dec]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Dec -> Maybe Dec
go [Dec]
sub_decs
go :: Dec -> Maybe Dec
go (SigD Name
n Kind
ty) =
Dec -> Maybe Dec
forall a. a -> Maybe a
Just (Dec -> Maybe Dec) -> Dec -> Maybe Dec
forall a b. (a -> b) -> a -> b
$ Name -> Kind -> Dec
SigD Name
n
(Kind -> Dec) -> Kind -> Dec
forall a b. (a -> b) -> a -> b
$ Name -> [TyVarBndrUnit] -> Bool -> Kind -> Kind
quantifyClassMethodType Name
cls_name [TyVarBndrUnit]
cls_tvbs Bool
prepend_cls Kind
ty
go d :: Dec
d@(TySynInstD {}) = Dec -> Maybe Dec
forall a. a -> Maybe a
Just Dec
d
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
go Dec
_ = 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
quantifyClassMethodType
:: Name
-> [TyVarBndrUnit]
-> Bool
-> Type
-> Type
quantifyClassMethodType :: Name -> [TyVarBndrUnit] -> Bool -> Kind -> Kind
quantifyClassMethodType Name
cls_name [TyVarBndrUnit]
cls_tvbs Bool
prepend Kind
meth_ty =
Kind -> Kind
add_cls_cxt Kind
quantified_meth_ty
where
add_cls_cxt :: Type -> Type
add_cls_cxt :: Kind -> Kind
add_cls_cxt
| Bool
prepend = [TyVarBndr Specificity] -> Cxt -> Kind -> Kind
ForallT (Specificity -> [TyVarBndrUnit] -> [TyVarBndr Specificity]
forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags Specificity
SpecifiedSpec [TyVarBndrUnit]
all_cls_tvbs) Cxt
cls_cxt
| Bool
otherwise = Kind -> Kind
forall a. a -> a
id
cls_cxt :: Cxt
cls_cxt :: Cxt
cls_cxt = [(Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
cls_name) ((TyVarBndrUnit -> Kind) -> [TyVarBndrUnit] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> Kind
forall flag. TyVarBndr_ flag -> Kind
tvbToType [TyVarBndrUnit]
cls_tvbs)]
quantified_meth_ty :: Type
quantified_meth_ty :: Kind
quantified_meth_ty
| [TyVarBndr Specificity] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr Specificity]
meth_tvbs
= Kind
meth_ty
| ForallT [TyVarBndr Specificity]
meth_tvbs' Cxt
meth_ctxt Kind
meth_tau <- Kind
meth_ty
= [TyVarBndr Specificity] -> Cxt -> Kind -> Kind
ForallT ([TyVarBndr Specificity]
meth_tvbs [TyVarBndr Specificity]
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. [a] -> [a] -> [a]
++ [TyVarBndr Specificity]
meth_tvbs') Cxt
meth_ctxt Kind
meth_tau
| Bool
otherwise
= [TyVarBndr Specificity] -> Cxt -> Kind -> Kind
ForallT [TyVarBndr Specificity]
meth_tvbs [] Kind
meth_ty
meth_tvbs :: [TyVarBndrSpec]
meth_tvbs :: [TyVarBndr Specificity]
meth_tvbs = Specificity -> [TyVarBndrUnit] -> [TyVarBndr Specificity]
forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags Specificity
SpecifiedSpec ([TyVarBndrUnit] -> [TyVarBndr Specificity])
-> [TyVarBndrUnit] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> a -> b
$
(TyVarBndrUnit -> TyVarBndrUnit -> Bool)
-> [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
List.deleteFirstsBy (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Name -> Name -> Bool)
-> (TyVarBndrUnit -> Name)
-> TyVarBndrUnit
-> TyVarBndrUnit
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName)
(Cxt -> [TyVarBndrUnit]
freeVariablesWellScoped [Kind
meth_ty]) [TyVarBndrUnit]
all_cls_tvbs
all_cls_tvbs :: [TyVarBndrUnit]
all_cls_tvbs :: [TyVarBndrUnit]
all_cls_tvbs = Cxt -> [TyVarBndrUnit]
freeVariablesWellScoped (Cxt -> [TyVarBndrUnit]) -> Cxt -> [TyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$ (TyVarBndrUnit -> Kind) -> [TyVarBndrUnit] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> Kind
forall flag. TyVarBndr_ flag -> Kind
tvbToTypeWithSig [TyVarBndrUnit]
cls_tvbs
stripInstanceDec :: Dec -> Dec
stripInstanceDec :: Dec -> Dec
stripInstanceDec (InstanceD Maybe Overlap
over Cxt
cxt Kind
ty [Dec]
_) = Maybe Overlap -> Cxt -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
over Cxt
cxt Kind
ty []
stripInstanceDec Dec
dec = Dec
dec
mkArrows :: [Type] -> Type -> Type
mkArrows :: Cxt -> Kind -> Kind
mkArrows [] Kind
res_ty = Kind
res_ty
mkArrows (Kind
t:Cxt
ts) Kind
res_ty = Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind
AppT Kind
ArrowT Kind
t) (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$ Cxt -> Kind -> Kind
mkArrows Cxt
ts Kind
res_ty
maybeForallT :: [TyVarBndrSpec] -> Cxt -> Type -> Type
maybeForallT :: [TyVarBndr Specificity] -> Cxt -> Kind -> Kind
maybeForallT [TyVarBndr Specificity]
tvbs Cxt
cxt Kind
ty
| [TyVarBndr Specificity] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr Specificity]
tvbs Bool -> Bool -> Bool
&& Cxt -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
cxt = Kind
ty
| ForallT [TyVarBndr Specificity]
tvbs2 Cxt
cxt2 Kind
ty2 <- Kind
ty = [TyVarBndr Specificity] -> Cxt -> Kind -> Kind
ForallT ([TyVarBndr Specificity]
tvbs [TyVarBndr Specificity]
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. [a] -> [a] -> [a]
++ [TyVarBndr Specificity]
tvbs2) (Cxt
cxt Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Cxt
cxt2) Kind
ty2
| Bool
otherwise = [TyVarBndr Specificity] -> Cxt -> Kind -> Kind
ForallT [TyVarBndr Specificity]
tvbs Cxt
cxt Kind
ty
findCon :: Name -> [Con] -> Maybe (Named Con)
findCon :: Name -> [Con] -> Maybe (Named Con)
findCon Name
n = (Con -> Maybe (Named Con)) -> [Con] -> Maybe (Named Con)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch Con -> Maybe (Named Con)
match_con
where
match_con :: Con -> Maybe (Named Con)
match_con :: Con -> Maybe (Named Con)
match_con Con
con =
case Con
con of
NormalC Name
n' [BangType]
_ | Name
n Name -> Name -> Bool
`nameMatches` Name
n' -> Named Con -> Maybe (Named Con)
forall a. a -> Maybe a
Just (Name
n', Con
con)
RecC Name
n' [VarBangType]
_ | Name
n Name -> Name -> Bool
`nameMatches` Name
n' -> Named Con -> Maybe (Named Con)
forall a. a -> Maybe a
Just (Name
n', Con
con)
InfixC BangType
_ Name
n' BangType
_ | Name
n Name -> Name -> Bool
`nameMatches` Name
n' -> Named Con -> Maybe (Named Con)
forall a. a -> Maybe a
Just (Name
n', Con
con)
ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
c -> case Con -> Maybe (Named Con)
match_con Con
c of
Just (Name
n', Con
_) -> Named Con -> Maybe (Named Con)
forall a. a -> Maybe a
Just (Name
n', Con
con)
Maybe (Named Con)
Nothing -> Maybe (Named Con)
forall a. Maybe a
Nothing
GadtC [Name]
nms [BangType]
_ Kind
_ -> Con -> [Name] -> Maybe (Named Con)
gadt_case Con
con [Name]
nms
RecGadtC [Name]
nms [VarBangType]
_ Kind
_ -> Con -> [Name] -> Maybe (Named Con)
gadt_case Con
con [Name]
nms
Con
_ -> Maybe (Named Con)
forall a. Maybe a
Nothing
gadt_case :: Con -> [Name] -> Maybe (Named Con)
gadt_case :: Con -> [Name] -> Maybe (Named Con)
gadt_case Con
con [Name]
nms = case (Name -> Bool) -> [Name] -> Maybe Name
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Name
n Name -> Name -> Bool
`nameMatches`) [Name]
nms of
Just Name
n' -> Named Con -> Maybe (Named Con)
forall a. a -> Maybe a
Just (Name
n', Con
con)
Maybe Name
Nothing -> Maybe (Named Con)
forall a. Maybe a
Nothing
data RecSelInfo
= RecSelH98 Type
| RecSelGADT (Maybe [TyVarBndrSpec])
Type
Type
findRecSelector :: Name -> [Con] -> Maybe (Named RecSelInfo)
findRecSelector :: Name -> [Con] -> Maybe (Named RecSelInfo)
findRecSelector Name
n = (Con -> Maybe (Named RecSelInfo))
-> [Con] -> Maybe (Named RecSelInfo)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch (Maybe [TyVarBndr Specificity] -> Con -> Maybe (Named RecSelInfo)
match_con Maybe [TyVarBndr Specificity]
forall a. Maybe a
Nothing)
where
match_con :: Maybe [TyVarBndrSpec] -> Con -> Maybe (Named RecSelInfo)
match_con :: Maybe [TyVarBndr Specificity] -> Con -> Maybe (Named RecSelInfo)
match_con Maybe [TyVarBndr Specificity]
mb_tvbs Con
con =
case Con
con of
RecC Name
_ [VarBangType]
vstys ->
(Named Kind -> Named RecSelInfo)
-> Maybe (Named Kind) -> Maybe (Named RecSelInfo)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Kind -> RecSelInfo) -> Named Kind -> Named RecSelInfo
forall a b c. (a -> b) -> (c, a) -> (c, b)
liftSnd Kind -> RecSelInfo
RecSelH98) (Maybe (Named Kind) -> Maybe (Named RecSelInfo))
-> Maybe (Named Kind) -> Maybe (Named RecSelInfo)
forall a b. (a -> b) -> a -> b
$
(VarBangType -> Maybe (Named Kind))
-> [VarBangType] -> Maybe (Named Kind)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch VarBangType -> Maybe (Named Kind)
forall {b} {b}. (Name, b, b) -> Maybe (Name, b)
match_rec_sel [VarBangType]
vstys
RecGadtC [Name]
_ [VarBangType]
vstys Kind
ret_ty ->
(Named Kind -> Named RecSelInfo)
-> Maybe (Named Kind) -> Maybe (Named RecSelInfo)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Kind -> RecSelInfo) -> Named Kind -> Named RecSelInfo
forall a b c. (a -> b) -> (c, a) -> (c, b)
liftSnd (\Kind
field_ty ->
Maybe [TyVarBndr Specificity] -> Kind -> Kind -> RecSelInfo
RecSelGADT (([TyVarBndr Specificity] -> [TyVarBndr Specificity])
-> Maybe [TyVarBndr Specificity] -> Maybe [TyVarBndr Specificity]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Kind -> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
filter_ret_tvs Kind
ret_ty) Maybe [TyVarBndr Specificity]
mb_tvbs) Kind
field_ty Kind
ret_ty)) (Maybe (Named Kind) -> Maybe (Named RecSelInfo))
-> Maybe (Named Kind) -> Maybe (Named RecSelInfo)
forall a b. (a -> b) -> a -> b
$
(VarBangType -> Maybe (Named Kind))
-> [VarBangType] -> Maybe (Named Kind)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch VarBangType -> Maybe (Named Kind)
forall {b} {b}. (Name, b, b) -> Maybe (Name, b)
match_rec_sel [VarBangType]
vstys
ForallC [TyVarBndr Specificity]
tvbs Cxt
_ Con
c ->
Maybe [TyVarBndr Specificity] -> Con -> Maybe (Named RecSelInfo)
match_con ([TyVarBndr Specificity] -> Maybe [TyVarBndr Specificity]
forall a. a -> Maybe a
Just [TyVarBndr Specificity]
tvbs) Con
c
Con
_ -> Maybe (Named RecSelInfo)
forall a. Maybe a
Nothing
match_rec_sel :: (Name, b, b) -> Maybe (Name, b)
match_rec_sel (Name
n', b
_, b
sel_ty)
| Name
n Name -> Name -> Bool
`nameMatches` Name
n' = (Name, b) -> Maybe (Name, b)
forall a. a -> Maybe a
Just (Name
n', b
sel_ty)
match_rec_sel (Name, b, b)
_ = Maybe (Name, b)
forall a. Maybe a
Nothing
filter_ret_tvs :: Type -> [TyVarBndrSpec] -> [TyVarBndrSpec]
filter_ret_tvs :: Kind -> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
filter_ret_tvs Kind
ret_ty =
(TyVarBndr Specificity -> Bool)
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TyVarBndr Specificity
tvb -> TyVarBndr Specificity -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndr Specificity
tvb Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
ret_fvs)
where
ret_fvs :: Set Name
ret_fvs = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ Cxt -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [Kind
ret_ty]
reifyFixityWithLocals :: DsMonad q => Name -> q (Maybe Fixity)
reifyFixityWithLocals :: forall (q :: * -> *). DsMonad q => Name -> q (Maybe Fixity)
reifyFixityWithLocals Name
name = q (Maybe Fixity) -> q (Maybe Fixity) -> q (Maybe Fixity)
forall a. q a -> q a -> q a
forall (m :: * -> *) a. Quasi m => m a -> m a -> m a
qRecover
(Maybe Fixity -> q (Maybe Fixity)
forall a. a -> q a
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)
#if __GLASGOW_HASKELL__ < 809
qReifyType :: forall m. Quasi m => Name -> m Type
qReifyType name = do
info <- qReify name
case infoType info <|> info_kind info of
Just t -> return t
Nothing -> fail $ "Could not reify the full type of " ++ nameBase name
where
info_kind :: Info -> Maybe Kind
info_kind info = do
dec <- case info of
ClassI d _ -> Just d
TyConI d -> Just d
FamilyI d _ -> Just d
_ -> Nothing
match_cusk name dec
reifyType :: Name -> Q Type
reifyType = qReifyType
#endif
reifyTypeWithLocals :: DsMonad q => Name -> q Type
reifyTypeWithLocals :: forall (q :: * -> *). DsMonad q => Name -> q Kind
reifyTypeWithLocals Name
name = do
Maybe Kind
m_info <- Name -> q (Maybe Kind)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe Kind)
reifyTypeWithLocals_maybe Name
name
case Maybe Kind
m_info of
Maybe Kind
Nothing -> Name -> q Kind
forall (m :: * -> *) a. MonadFail m => Name -> m a
reifyFail Name
name
Just Kind
i -> Kind -> q Kind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
i
reifyTypeWithLocals_maybe :: DsMonad q => Name -> q (Maybe Type)
reifyTypeWithLocals_maybe :: forall (q :: * -> *). DsMonad q => Name -> q (Maybe Kind)
reifyTypeWithLocals_maybe Name
name = do
#if __GLASGOW_HASKELL__ >= 809
Bool
cusks <- Extension -> q Bool
forall (m :: * -> *). Quasi m => Extension -> m Bool
qIsExtEnabled Extension
CUSKs
#else
let cusks = True
#endif
q (Maybe Kind) -> q (Maybe Kind) -> q (Maybe Kind)
forall a. q a -> q a -> q a
forall (m :: * -> *) a. Quasi m => m a -> m a -> m a
qRecover (Maybe Kind -> q (Maybe Kind)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Kind -> q (Maybe Kind))
-> ([Dec] -> Maybe Kind) -> [Dec] -> q (Maybe Kind)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Name -> [Dec] -> Maybe Kind
reifyTypeInDecs Bool
cusks Name
name ([Dec] -> q (Maybe Kind)) -> q [Dec] -> q (Maybe Kind)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< q [Dec]
forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations)
(Kind -> Maybe Kind
forall a. a -> Maybe a
Just (Kind -> Maybe Kind) -> q Kind -> q (Maybe Kind)
forall a b. (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> q Kind
forall (m :: * -> *). Quasi m => Name -> m Kind
qReifyType Name
name)
reifyTypeInDecs :: Bool -> Name -> [Dec] -> Maybe Type
reifyTypeInDecs :: Bool -> Name -> [Dec] -> Maybe Kind
reifyTypeInDecs Bool
cusks Name
name [Dec]
decs =
(Name -> [Dec] -> Maybe Info
reifyInDecs Name
name [Dec]
decs Maybe Info -> (Info -> Maybe Kind) -> Maybe Kind
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Info -> Maybe Kind
infoType) Maybe Kind -> Maybe Kind -> Maybe Kind
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Name -> [Dec] -> Maybe Kind
findKind Bool
cusks Name
name [Dec]
decs
infoType :: Info -> Maybe Type
infoType :: Info -> Maybe Kind
infoType Info
info =
case Info
info of
ClassOpI Name
_ Kind
t Name
_ -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
t
DataConI Name
_ Kind
t Name
_ -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
t
VarI Name
_ Kind
t Maybe Dec
_ -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
t
TyVarI Name
_ Kind
t -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
t
#if __GLASGOW_HASKELL__ >= 802
PatSynI Name
_ Kind
t -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
t
#endif
Info
_ -> Maybe Kind
forall a. Maybe a
Nothing
findKind :: Bool
-> Name -> [Dec] -> Maybe Kind
findKind :: Bool -> Name -> [Dec] -> Maybe Kind
findKind Bool
cusks Name
name [Dec]
decls =
(Dec -> Maybe Kind) -> [Dec] -> Maybe Kind
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch (Name -> [Dec] -> Dec -> Maybe Kind
match_kind_sig Name
name [Dec]
decls) [Dec]
decls
Maybe Kind -> Maybe Kind -> Maybe Kind
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Maybe Kind -> Maybe Kind
forall (f :: * -> *) a. Alternative f => Bool -> f a -> f a
whenAlt Bool
cusks ((Dec -> Maybe Kind) -> [Dec] -> Maybe Kind
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch (Name -> Dec -> Maybe Kind
match_cusk Name
name) [Dec]
decls)
match_kind_sig :: Name -> [Dec] -> Dec -> Maybe Kind
match_kind_sig :: Name -> [Dec] -> Dec -> Maybe Kind
match_kind_sig Name
n [Dec]
decs (ClassD Cxt
_ Name
n' [TyVarBndrUnit]
tvbs [FunDep]
_ [Dec]
sub_decs)
| Just Kind
ki <- (Dec -> Maybe Kind) -> [Dec] -> Maybe Kind
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch (Name -> Dec -> Maybe Kind
find_kind_sig Name
n') [Dec]
decs
, let (FunArgs
arg_kis, Kind
_res_ki) = Kind -> (FunArgs, Kind)
unravelType Kind
ki
mb_vis_arg_kis :: [Maybe Kind]
mb_vis_arg_kis = (VisFunArg -> Maybe Kind) -> [VisFunArg] -> [Maybe Kind]
forall a b. (a -> b) -> [a] -> [b]
map VisFunArg -> Maybe Kind
vis_arg_kind_maybe ([VisFunArg] -> [Maybe Kind]) -> [VisFunArg] -> [Maybe Kind]
forall a b. (a -> b) -> a -> b
$ FunArgs -> [VisFunArg]
filterVisFunArgs FunArgs
arg_kis
cls_tvb_kind_map :: Map Name Kind
cls_tvb_kind_map =
[Named Kind] -> Map Name Kind
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
tvb, Kind
tvb_kind)
| (TyVarBndrUnit
tvb, Maybe Kind
mb_vis_arg_ki) <- [TyVarBndrUnit] -> [Maybe Kind] -> [(TyVarBndrUnit, Maybe Kind)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TyVarBndrUnit]
tvbs [Maybe Kind]
mb_vis_arg_kis
, Just Kind
tvb_kind <- [Maybe Kind
mb_vis_arg_ki Maybe Kind -> Maybe Kind -> Maybe Kind
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TyVarBndrUnit -> Maybe Kind
forall flag. TyVarBndr_ flag -> Maybe Kind
tvb_kind_maybe TyVarBndrUnit
tvb]
]
= (Dec -> Maybe Kind) -> [Dec] -> Maybe Kind
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch (Name -> Map Name Kind -> Dec -> Maybe Kind
find_assoc_type_kind Name
n Map Name Kind
cls_tvb_kind_map) [Dec]
sub_decs
match_kind_sig Name
n [Dec]
_ Dec
dec = Name -> Dec -> Maybe Kind
find_kind_sig Name
n Dec
dec
find_kind_sig :: Name -> Dec -> Maybe Kind
#if __GLASGOW_HASKELL__ >= 809
find_kind_sig :: Name -> Dec -> Maybe Kind
find_kind_sig Name
n (KiSigD Name
n' Kind
ki)
| Name
n Name -> Name -> Bool
`nameMatches` Name
n' = Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
ki
#endif
find_kind_sig Name
_ Dec
_ = Maybe Kind
forall a. Maybe a
Nothing
match_cusk :: Name -> Dec -> Maybe Kind
match_cusk :: Name -> Dec -> Maybe Kind
match_cusk Name
n (DataD Cxt
_ Name
n' [TyVarBndrUnit]
tvbs Maybe Kind
m_ki [Con]
_ [DerivClause]
_)
| Name
n Name -> Name -> Bool
`nameMatches` Name
n'
= [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
datatype_kind [TyVarBndrUnit]
tvbs Maybe Kind
m_ki
match_cusk Name
n (NewtypeD Cxt
_ Name
n' [TyVarBndrUnit]
tvbs Maybe Kind
m_ki Con
_ [DerivClause]
_)
| Name
n Name -> Name -> Bool
`nameMatches` Name
n'
= [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
datatype_kind [TyVarBndrUnit]
tvbs Maybe Kind
m_ki
match_cusk Name
n (DataFamilyD Name
n' [TyVarBndrUnit]
tvbs Maybe Kind
m_ki)
| Name
n Name -> Name -> Bool
`nameMatches` Name
n'
= [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
open_ty_fam_kind [TyVarBndrUnit]
tvbs Maybe Kind
m_ki
match_cusk Name
n (OpenTypeFamilyD (TypeFamilyHead Name
n' [TyVarBndrUnit]
tvbs FamilyResultSig
res_sig Maybe InjectivityAnn
_))
| Name
n Name -> Name -> Bool
`nameMatches` Name
n'
= [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
open_ty_fam_kind [TyVarBndrUnit]
tvbs (FamilyResultSig -> Maybe Kind
res_sig_to_kind FamilyResultSig
res_sig)
match_cusk Name
n (ClosedTypeFamilyD (TypeFamilyHead Name
n' [TyVarBndrUnit]
tvbs FamilyResultSig
res_sig Maybe InjectivityAnn
_) [TySynEqn]
_)
| Name
n Name -> Name -> Bool
`nameMatches` Name
n'
= [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
closed_ty_fam_kind [TyVarBndrUnit]
tvbs (FamilyResultSig -> Maybe Kind
res_sig_to_kind FamilyResultSig
res_sig)
match_cusk Name
n (TySynD Name
n' [TyVarBndrUnit]
tvbs Kind
rhs)
| Name
n Name -> Name -> Bool
`nameMatches` Name
n'
= [TyVarBndrUnit] -> Kind -> Maybe Kind
ty_syn_kind [TyVarBndrUnit]
tvbs Kind
rhs
match_cusk Name
n (ClassD Cxt
_ Name
n' [TyVarBndrUnit]
tvbs [FunDep]
_ [Dec]
sub_decs)
| Name
n Name -> Name -> Bool
`nameMatches` Name
n'
= [TyVarBndrUnit] -> Maybe Kind
class_kind [TyVarBndrUnit]
tvbs
|
(TyVarBndrUnit -> Bool) -> [TyVarBndrUnit] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TyVarBndrUnit -> Bool
forall flag. TyVarBndr_ flag -> Bool
tvb_is_kinded [TyVarBndrUnit]
tvbs
, let cls_tvb_kind_map :: Map Name Kind
cls_tvb_kind_map = [Named Kind] -> Map Name Kind
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
tvb, Kind
tvb_kind)
| TyVarBndrUnit
tvb <- [TyVarBndrUnit]
tvbs
, Just Kind
tvb_kind <- [TyVarBndrUnit -> Maybe Kind
forall flag. TyVarBndr_ flag -> Maybe Kind
tvb_kind_maybe TyVarBndrUnit
tvb]
]
= (Dec -> Maybe Kind) -> [Dec] -> Maybe Kind
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch (Name -> Map Name Kind -> Dec -> Maybe Kind
find_assoc_type_kind Name
n Map Name Kind
cls_tvb_kind_map) [Dec]
sub_decs
#if __GLASGOW_HASKELL__ >= 906
match_cusk Name
n (TypeDataD Name
n' [TyVarBndrUnit]
tvbs Maybe Kind
m_ki [Con]
_)
| Name
n Name -> Name -> Bool
`nameMatches` Name
n'
= [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
datatype_kind [TyVarBndrUnit]
tvbs Maybe Kind
m_ki
#endif
match_cusk Name
_ Dec
_ = Maybe Kind
forall a. Maybe a
Nothing
find_assoc_type_kind :: Name -> Map Name Kind -> Dec -> Maybe Kind
find_assoc_type_kind :: Name -> Map Name Kind -> Dec -> Maybe Kind
find_assoc_type_kind Name
n Map Name Kind
cls_tvb_kind_map Dec
sub_dec =
case Dec
sub_dec of
DataFamilyD Name
n' [TyVarBndrUnit]
tf_tvbs Maybe Kind
m_ki
| Name
n Name -> Name -> Bool
`nameMatches` Name
n'
-> [TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind ((TyVarBndrUnit -> TyVarBndrUnit)
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> TyVarBndrUnit
ascribe_tf_tvb_kind [TyVarBndrUnit]
tf_tvbs) (Maybe Kind -> Kind
default_res_ki Maybe Kind
m_ki)
OpenTypeFamilyD (TypeFamilyHead Name
n' [TyVarBndrUnit]
tf_tvbs FamilyResultSig
res_sig Maybe InjectivityAnn
_)
| Name
n Name -> Name -> Bool
`nameMatches` Name
n'
-> [TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind ((TyVarBndrUnit -> TyVarBndrUnit)
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> TyVarBndrUnit
ascribe_tf_tvb_kind [TyVarBndrUnit]
tf_tvbs)
(Maybe Kind -> Kind
default_res_ki (Maybe Kind -> Kind) -> Maybe Kind -> Kind
forall a b. (a -> b) -> a -> b
$ FamilyResultSig -> Maybe Kind
res_sig_to_kind FamilyResultSig
res_sig)
Dec
_ -> Maybe Kind
forall a. Maybe a
Nothing
where
ascribe_tf_tvb_kind :: TyVarBndrUnit -> TyVarBndrUnit
ascribe_tf_tvb_kind :: TyVarBndrUnit -> TyVarBndrUnit
ascribe_tf_tvb_kind TyVarBndrUnit
tvb =
(Name -> TyVarBndrUnit)
-> (Name -> Kind -> TyVarBndrUnit)
-> TyVarBndrUnit
-> TyVarBndrUnit
forall r flag.
(Name -> r) -> (Name -> Kind -> r) -> TyVarBndr_ flag -> r
elimTV (\Name
tvn -> Name -> Kind -> TyVarBndrUnit
kindedTV Name
tvn (Kind -> TyVarBndrUnit) -> Kind -> TyVarBndrUnit
forall a b. (a -> b) -> a -> b
$ Kind -> Maybe Kind -> Kind
forall a. a -> Maybe a -> a
fromMaybe Kind
StarT (Maybe Kind -> Kind) -> Maybe Kind -> Kind
forall a b. (a -> b) -> a -> b
$ Name -> Map Name Kind -> Maybe Kind
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
tvn Map Name Kind
cls_tvb_kind_map)
(\Name
_ Kind
_ -> TyVarBndrUnit
tvb)
TyVarBndrUnit
tvb
datatype_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
datatype_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
datatype_kind [TyVarBndrUnit]
tvbs Maybe Kind
m_ki =
Bool -> Maybe Kind -> Maybe Kind
forall (f :: * -> *) a. Alternative f => Bool -> f a -> f a
whenAlt ((TyVarBndrUnit -> Bool) -> [TyVarBndrUnit] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TyVarBndrUnit -> Bool
forall flag. TyVarBndr_ flag -> Bool
tvb_is_kinded [TyVarBndrUnit]
tvbs Bool -> Bool -> Bool
&& Bool
ki_fvs_are_bound) (Maybe Kind -> Maybe Kind) -> Maybe Kind -> Maybe Kind
forall a b. (a -> b) -> a -> b
$
[TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind [TyVarBndrUnit]
tvbs (Maybe Kind -> Kind
default_res_ki Maybe Kind
m_ki)
where
ki_fvs_are_bound :: Bool
ki_fvs_are_bound :: Bool
ki_fvs_are_bound =
let ki_fvs :: Set Name
ki_fvs = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ (Kind -> [Name]) -> Maybe Kind -> [Name]
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Kind -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Maybe Kind
m_ki
tvb_vars :: Set Name
tvb_vars = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ Cxt -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables (Cxt -> [Name]) -> Cxt -> [Name]
forall a b. (a -> b) -> a -> b
$ (TyVarBndrUnit -> Kind) -> [TyVarBndrUnit] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> Kind
forall flag. TyVarBndr_ flag -> Kind
tvbToTypeWithSig [TyVarBndrUnit]
tvbs
in Set Name
ki_fvs Set Name -> Set Name -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set Name
tvb_vars
class_kind :: [TyVarBndrUnit] -> Maybe Kind
class_kind :: [TyVarBndrUnit] -> Maybe Kind
class_kind [TyVarBndrUnit]
tvbs = Bool -> Maybe Kind -> Maybe Kind
forall (f :: * -> *) a. Alternative f => Bool -> f a -> f a
whenAlt ((TyVarBndrUnit -> Bool) -> [TyVarBndrUnit] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TyVarBndrUnit -> Bool
forall flag. TyVarBndr_ flag -> Bool
tvb_is_kinded [TyVarBndrUnit]
tvbs) (Maybe Kind -> Maybe Kind) -> Maybe Kind -> Maybe Kind
forall a b. (a -> b) -> a -> b
$
[TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind [TyVarBndrUnit]
tvbs Kind
ConstraintT
open_ty_fam_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
open_ty_fam_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
open_ty_fam_kind [TyVarBndrUnit]
tvbs Maybe Kind
m_ki =
[TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind ((TyVarBndrUnit -> TyVarBndrUnit)
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> TyVarBndrUnit
default_tvb [TyVarBndrUnit]
tvbs) (Maybe Kind -> Kind
default_res_ki Maybe Kind
m_ki)
closed_ty_fam_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
closed_ty_fam_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
closed_ty_fam_kind [TyVarBndrUnit]
tvbs Maybe Kind
m_ki =
case Maybe Kind
m_ki of
Just Kind
ki -> Bool -> Maybe Kind -> Maybe Kind
forall (f :: * -> *) a. Alternative f => Bool -> f a -> f a
whenAlt ((TyVarBndrUnit -> Bool) -> [TyVarBndrUnit] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TyVarBndrUnit -> Bool
forall flag. TyVarBndr_ flag -> Bool
tvb_is_kinded [TyVarBndrUnit]
tvbs) (Maybe Kind -> Maybe Kind) -> Maybe Kind -> Maybe Kind
forall a b. (a -> b) -> a -> b
$
[TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind [TyVarBndrUnit]
tvbs Kind
ki
Maybe Kind
Nothing -> Maybe Kind
forall a. Maybe a
Nothing
ty_syn_kind :: [TyVarBndrUnit] -> Type -> Maybe Kind
ty_syn_kind :: [TyVarBndrUnit] -> Kind -> Maybe Kind
ty_syn_kind [TyVarBndrUnit]
tvbs Kind
rhs =
case Kind
rhs of
SigT Kind
_ Kind
ki -> Bool -> Maybe Kind -> Maybe Kind
forall (f :: * -> *) a. Alternative f => Bool -> f a -> f a
whenAlt ((TyVarBndrUnit -> Bool) -> [TyVarBndrUnit] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TyVarBndrUnit -> Bool
forall flag. TyVarBndr_ flag -> Bool
tvb_is_kinded [TyVarBndrUnit]
tvbs) (Maybe Kind -> Maybe Kind) -> Maybe Kind -> Maybe Kind
forall a b. (a -> b) -> a -> b
$
[TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind [TyVarBndrUnit]
tvbs Kind
ki
Kind
_ -> Maybe Kind
forall a. Maybe a
Nothing
build_kind :: [TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind :: [TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind [TyVarBndrUnit]
arg_kinds Kind
res_kind =
(Kind -> Kind) -> Maybe Kind -> Maybe Kind
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Kind -> Kind
quantifyType (Maybe Kind -> Maybe Kind) -> Maybe Kind -> Maybe Kind
forall a b. (a -> b) -> a -> b
$ (Maybe Kind, Set Name) -> Maybe Kind
forall a b. (a, b) -> a
fst ((Maybe Kind, Set Name) -> Maybe Kind)
-> (Maybe Kind, Set Name) -> Maybe Kind
forall a b. (a -> b) -> a -> b
$
(TyVarBndrUnit -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name))
-> (Maybe Kind, Set Name)
-> [TyVarBndrUnit]
-> (Maybe Kind, Set Name)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TyVarBndrUnit -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name)
go (Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
res_kind, [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList (Kind -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Kind
res_kind)) [TyVarBndrUnit]
arg_kinds
where
go :: TyVarBndrUnit -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name)
go :: TyVarBndrUnit -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name)
go TyVarBndrUnit
tvb (Maybe Kind
res, Set Name
res_fvs) =
(Name -> (Maybe Kind, Set Name))
-> (Name -> Kind -> (Maybe Kind, Set Name))
-> TyVarBndrUnit
-> (Maybe Kind, Set Name)
forall r flag.
(Name -> r) -> (Name -> Kind -> r) -> TyVarBndr_ flag -> r
elimTV (\Name
n ->
( if Name
n Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
res_fvs
then TyVarBndrUnit -> Maybe Kind -> Maybe Kind
forall_vis TyVarBndrUnit
tvb Maybe Kind
res
else Maybe Kind
forall a. Maybe a
Nothing
, Set Name
res_fvs
))
(\Name
n Kind
k ->
( if Name
n Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
res_fvs
then TyVarBndrUnit -> Maybe Kind -> Maybe Kind
forall_vis TyVarBndrUnit
tvb Maybe Kind
res
else (Kind -> Kind) -> Maybe Kind -> Maybe Kind
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Kind
ArrowT Kind -> Kind -> Kind
`AppT` Kind
k Kind -> Kind -> Kind
`AppT`) Maybe Kind
res
, [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList (Kind -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Kind
k) Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Name
res_fvs
))
TyVarBndrUnit
tvb
forall_vis :: TyVarBndrUnit -> Maybe Kind -> Maybe Kind
#if __GLASGOW_HASKELL__ >= 809
forall_vis :: TyVarBndrUnit -> Maybe Kind -> Maybe Kind
forall_vis TyVarBndrUnit
tvb Maybe Kind
m_ki = (Kind -> Kind) -> Maybe Kind -> Maybe Kind
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([TyVarBndrUnit] -> Kind -> Kind
ForallVisT [TyVarBndrUnit
tvb]) Maybe Kind
m_ki
#else
forall_vis _ _ = Nothing
#endif
tvb_is_kinded :: TyVarBndr_ flag -> Bool
tvb_is_kinded :: forall flag. TyVarBndr_ flag -> Bool
tvb_is_kinded = Maybe Kind -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Kind -> Bool)
-> (TyVarBndr_ flag -> Maybe Kind) -> TyVarBndr_ flag -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr_ flag -> Maybe Kind
forall flag. TyVarBndr_ flag -> Maybe Kind
tvb_kind_maybe
tvb_kind_maybe :: TyVarBndr_ flag -> Maybe Kind
tvb_kind_maybe :: forall flag. TyVarBndr_ flag -> Maybe Kind
tvb_kind_maybe = (Name -> Maybe Kind)
-> (Name -> Kind -> Maybe Kind) -> TyVarBndr_ flag -> Maybe Kind
forall r flag.
(Name -> r) -> (Name -> Kind -> r) -> TyVarBndr_ flag -> r
elimTV (\Name
_ -> Maybe Kind
forall a. Maybe a
Nothing) (\Name
_ Kind
k -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
k)
vis_arg_kind_maybe :: VisFunArg -> Maybe Kind
vis_arg_kind_maybe :: VisFunArg -> Maybe Kind
vis_arg_kind_maybe (VisFADep TyVarBndrUnit
tvb) = TyVarBndrUnit -> Maybe Kind
forall flag. TyVarBndr_ flag -> Maybe Kind
tvb_kind_maybe TyVarBndrUnit
tvb
vis_arg_kind_maybe (VisFAAnon Kind
k) = Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
k
default_tvb :: TyVarBndrUnit -> TyVarBndrUnit
default_tvb :: TyVarBndrUnit -> TyVarBndrUnit
default_tvb TyVarBndrUnit
tvb = (Name -> TyVarBndrUnit)
-> (Name -> Kind -> TyVarBndrUnit)
-> TyVarBndrUnit
-> TyVarBndrUnit
forall r flag.
(Name -> r) -> (Name -> Kind -> r) -> TyVarBndr_ flag -> r
elimTV (\Name
n -> Name -> Kind -> TyVarBndrUnit
kindedTV Name
n Kind
StarT) (\Name
_ Kind
_ -> TyVarBndrUnit
tvb) TyVarBndrUnit
tvb
default_res_ki :: Maybe Kind -> Kind
default_res_ki :: Maybe Kind -> Kind
default_res_ki = Kind -> Maybe Kind -> Kind
forall a. a -> Maybe a -> a
fromMaybe Kind
StarT
res_sig_to_kind :: FamilyResultSig -> Maybe Kind
res_sig_to_kind :: FamilyResultSig -> Maybe Kind
res_sig_to_kind FamilyResultSig
NoSig = Maybe Kind
forall a. Maybe a
Nothing
res_sig_to_kind (KindSig Kind
k) = Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
k
res_sig_to_kind (TyVarSig TyVarBndrUnit
tvb) = TyVarBndrUnit -> Maybe Kind
forall flag. TyVarBndr_ flag -> Maybe Kind
tvb_kind_maybe TyVarBndrUnit
tvb
whenAlt :: Alternative f => Bool -> f a -> f a
whenAlt :: forall (f :: * -> *) a. Alternative f => Bool -> f a -> f a
whenAlt Bool
b f a
fa = if Bool
b then f a
fa else f a
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty
lookupValueNameWithLocals :: DsMonad q => String -> q (Maybe Name)
lookupValueNameWithLocals :: forall (q :: * -> *). DsMonad q => 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 :: forall (q :: * -> *). DsMonad q => String -> q (Maybe Name)
lookupTypeNameWithLocals = Bool -> String -> q (Maybe Name)
forall (q :: * -> *). DsMonad q => Bool -> String -> q (Maybe Name)
lookupNameWithLocals Bool
True
lookupNameWithLocals :: forall q. DsMonad q => Bool -> String -> q (Maybe Name)
lookupNameWithLocals :: forall (q :: * -> *). DsMonad q => Bool -> String -> q (Maybe Name)
lookupNameWithLocals Bool
ns String
s = do
Maybe Name
mb_name <- Bool -> String -> q (Maybe Name)
forall (m :: * -> *). Quasi m => Bool -> String -> m (Maybe Name)
qLookupName Bool
ns String
s
case Maybe Name
mb_name of
j_name :: Maybe Name
j_name@(Just{}) -> Maybe Name -> q (Maybe Name)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Name
j_name
Maybe Name
Nothing -> q (Maybe Name)
consult_locals
where
built_name :: Name
built_name = String -> Name
mkName String
s
consult_locals :: q (Maybe Name)
consult_locals = do
[Dec]
decs <- q [Dec]
forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations
let mb_infos :: [Maybe (Name, Info)]
mb_infos = (Dec -> Maybe (Name, Info)) -> [Dec] -> [Maybe (Name, Info)]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> [Dec] -> Dec -> Maybe (Name, Info)
reifyInDec Name
built_name [Dec]
decs) [Dec]
decs
infos :: [(Name, Info)]
infos = [Maybe (Name, Info)] -> [(Name, Info)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Name, Info)]
mb_infos
((Name, Info) -> q (Maybe Name))
-> [(Name, Info)] -> q (Maybe Name)
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstMatchM (if Bool
ns then (Name, Info) -> q (Maybe Name)
find_type_name
else (Name, Info) -> q (Maybe Name)
find_value_name) [(Name, Info)]
infos
find_type_name, find_value_name :: Named Info -> q (Maybe Name)
find_type_name :: (Name, Info) -> q (Maybe Name)
find_type_name (Name
n, Info
info) = do
NameSpace
name_space <- Info -> q NameSpace
forall (q :: * -> *). DsMonad q => Info -> q NameSpace
lookupInfoNameSpace Info
info
Maybe Name -> q (Maybe Name)
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Name -> q (Maybe Name)) -> Maybe Name -> q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ case NameSpace
name_space of
NameSpace
TcClsName -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
NameSpace
VarName -> Maybe Name
forall a. Maybe a
Nothing
NameSpace
DataName -> Maybe Name
forall a. Maybe a
Nothing
find_value_name :: (Name, Info) -> q (Maybe Name)
find_value_name (Name
n, Info
info) = do
NameSpace
name_space <- Info -> q NameSpace
forall (q :: * -> *). DsMonad q => Info -> q NameSpace
lookupInfoNameSpace Info
info
Maybe Name -> q (Maybe Name)
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Name -> q (Maybe Name)) -> Maybe Name -> q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ case NameSpace
name_space of
NameSpace
VarName -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
NameSpace
DataName -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
NameSpace
TcClsName -> Maybe Name
forall a. Maybe a
Nothing
mkDataNameWithLocals :: DsMonad q => String -> q Name
mkDataNameWithLocals :: forall (q :: * -> *). DsMonad q => 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 :: forall (q :: * -> *). DsMonad q => 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 :: forall (q :: * -> *). DsMonad q => Name -> q (Maybe NameSpace)
reifyNameSpace n :: Name
n@(Name OccName
_ NameFlavour
nf) =
case NameFlavour
nf of
NameG NameSpace
ns PkgName
_ ModName
_ -> Maybe NameSpace -> q (Maybe NameSpace)
forall a. a -> q a
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
NameFlavour
_ -> do Maybe Info
mb_info <- Name -> q (Maybe Info)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe Info)
reifyWithLocals_maybe Name
n
(Info -> q NameSpace) -> Maybe Info -> q (Maybe NameSpace)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Info -> q NameSpace
forall (q :: * -> *). DsMonad q => Info -> q NameSpace
lookupInfoNameSpace Maybe Info
mb_info
lookupInfoNameSpace :: DsMonad q => Info -> q NameSpace
lookupInfoNameSpace :: forall (q :: * -> *). DsMonad q => Info -> q NameSpace
lookupInfoNameSpace Info
info =
case Info
info of
ClassI{} -> NameSpace -> q NameSpace
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameSpace
TcClsName
TyConI{} -> NameSpace -> q NameSpace
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameSpace
TcClsName
FamilyI{} -> NameSpace -> q NameSpace
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameSpace
TcClsName
PrimTyConI{} -> NameSpace -> q NameSpace
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameSpace
TcClsName
TyVarI{} -> NameSpace -> q NameSpace
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameSpace
TcClsName
ClassOpI{} -> NameSpace -> q NameSpace
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameSpace
VarName
VarI{} -> NameSpace -> q NameSpace
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameSpace
VarName
DataConI Name
_dc_name Kind
_dc_ty Name
parent_name -> do
Maybe Info
mb_parent_info <- Name -> q (Maybe Info)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe Info)
reifyWithLocals_maybe Name
parent_name
NameSpace -> q NameSpace
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NameSpace -> q NameSpace) -> NameSpace -> q NameSpace
forall a b. (a -> b) -> a -> b
$ case Maybe Info
mb_parent_info of
#if __GLASGOW_HASKELL__ >= 906
Just (TyConI (TypeDataD {}))
-> NameSpace
TcClsName
#endif
Maybe Info
_ -> NameSpace
DataName
#if __GLASGOW_HASKELL__ >= 801
PatSynI{} -> NameSpace -> q NameSpace
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameSpace
DataName
#endif