{-# 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 = forall (m :: * -> *) a. Quasi m => m a -> m a -> m a
qRecover
(forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Dec] -> Maybe Info
reifyInDecs Name
name forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations)
(forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` 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 <- forall (q :: * -> *). DsMonad q => Name -> q (Maybe Info)
reifyWithLocals_maybe Name
name
case Maybe Info
m_info of
Maybe Info
Nothing -> forall (m :: * -> *) a. MonadFail m => Name -> m a
reifyFail Name
name
Just Info
i -> 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 = forall (m :: * -> *) a. Quasi m => m a -> m a -> m a
qRecover (forall (m :: * -> *) a. MonadFail m => Name -> m a
reifyFail Name
name) (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 =
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ String
"Looking up " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> String
show Name
name) forall a. [a] -> [a] -> [a]
++ String
" in the list of available " forall a. [a] -> [a] -> [a]
++
String
"declarations failed.\nThis lookup fails if the declaration " forall a. [a] -> [a] -> [a]
++
String
"referenced was made in the same Template\nHaskell splice as the use " forall a. [a] -> [a] -> [a]
++
String
"of the declaration. If this is the case, put\nthe reference to " 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 <- forall (q :: * -> *). DsMonad q => Name -> q Info
reifyWithLocals Name
name
Dec
dec <- case Info
info of
TyConI Dec
dec -> forall (m :: * -> *) a. Monad m => a -> m a
return Dec
dec
Info
_ -> forall {a}. q a
badDeclaration
case Dec
dec of
DataD Cxt
_cxt Name
_name [TyVarBndrUnit]
tvbs Maybe Kind
mk [Con]
cons [DerivClause]
_derivings -> 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 -> 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 tvbs mk cons -> go Util.TypeData tvbs mk cons
#endif
Dec
_ -> 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 = forall a. a -> Maybe a -> a
fromMaybe (Name -> Kind
ConT Name
typeKindName) Maybe Kind
mk
[TyVarBndrUnit]
extra_tvbs <- forall (q :: * -> *). Quasi q => Kind -> q [TyVarBndrUnit]
mkExtraKindBinders Kind
k
let all_tvbs :: [TyVarBndrUnit]
all_tvbs = [TyVarBndrUnit]
tvbs forall a. [a] -> [a] -> [a]
++ [TyVarBndrUnit]
extra_tvbs
forall (m :: * -> *) a. Monad m => a -> m a
return (a
df, [TyVarBndrUnit]
all_tvbs, c
cons)
badDeclaration :: q a
badDeclaration =
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"The name (" forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> String
show Name
name) forall a. [a] -> [a] -> [a]
++ String
") refers to something " forall a. [a] -> [a] -> [a]
++
String
"other than a datatype. " forall a. [a] -> [a] -> [a]
++ String
err
mkExtraKindBinders :: forall q. Quasi q => Kind -> q [TyVarBndrUnit]
Kind
k = do
Kind
k' <- forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ 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
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM VisFunArg -> q TyVarBndrUnit
mk_tvb [VisFunArg]
vis_fun_args
where
mk_tvb :: VisFunArg -> q TyVarBndrUnit
mk_tvb :: VisFunArg -> q TyVarBndrUnit
mk_tvb (VisFADep TyVarBndrUnit
tvb) = forall (m :: * -> *) a. Monad m => a -> m a
return TyVarBndrUnit
tvb
mk_tvb (VisFAAnon Kind
ki) = Name -> Kind -> TyVarBndrUnit
kindedTV forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"a" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 <- forall (q :: * -> *). DsMonad q => Name -> q Info
reifyWithLocals Name
con_name
case Info
info of
DataConI Name
_name Kind
_type Name
parent_name -> forall (m :: * -> *) a. Monad m => a -> m a
return Name
parent_name
Info
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"The name " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
con_name forall a. [a] -> [a] -> [a]
++ String
" does not appear to be " 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 <- forall (q :: * -> *). DsMonad q => Name -> q Name
dataConNameToDataName Name
con_name
(DataFlavor
_, [TyVarBndrUnit]
_, [Con]
cons) <- 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name
con_name forall a. Eq a => a -> a -> 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return Con
con
Maybe Con
Nothing -> 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 = forall (m :: * -> *) a. Monad m => a -> m a
return []
instance DsMonad IO where
localDeclarations :: IO [Dec]
localDeclarations = forall (m :: * -> *) a. Monad m => a -> m a
return []
newtype DsM q a = DsM (ReaderT [Dec] q a)
deriving ( 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
<$ :: forall a b. a -> DsM q b -> DsM q a
$c<$ :: forall (q :: * -> *) a b. Functor q => a -> DsM q b -> DsM q a
fmap :: forall a b. (a -> b) -> DsM q a -> DsM q b
$cfmap :: forall (q :: * -> *) a b.
Functor q =>
(a -> b) -> DsM q a -> DsM q b
Functor, 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
<* :: forall a b. DsM q a -> DsM q b -> DsM q a
$c<* :: forall (q :: * -> *) a b.
Applicative q =>
DsM q a -> DsM q b -> DsM q a
*> :: 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 b
liftA2 :: forall a b c. (a -> b -> c) -> DsM q a -> DsM q b -> DsM q c
$cliftA2 :: forall (q :: * -> *) a b c.
Applicative q =>
(a -> b -> c) -> DsM q a -> DsM q b -> DsM q c
<*> :: forall a b. DsM q (a -> b) -> DsM q a -> DsM q b
$c<*> :: forall (q :: * -> *) a b.
Applicative q =>
DsM q (a -> b) -> DsM q a -> DsM q b
pure :: forall a. a -> DsM q a
$cpure :: forall (q :: * -> *) a. Applicative q => a -> DsM q a
Applicative, forall a. a -> DsM q a
forall a b. DsM q a -> DsM q b -> DsM q b
forall a b. DsM q a -> (a -> DsM q b) -> DsM q b
forall {q :: * -> *}. Monad q => Applicative (DsM q)
forall (q :: * -> *) a. Monad q => a -> DsM q a
forall (q :: * -> *) a b. Monad q => DsM q a -> DsM q b -> DsM q b
forall (q :: * -> *) a b.
Monad q =>
DsM q a -> (a -> DsM q b) -> DsM q b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> DsM q a
$creturn :: forall (q :: * -> *) a. Monad q => a -> DsM q a
>> :: forall a b. DsM q a -> DsM q b -> DsM q b
$c>> :: forall (q :: * -> *) a b. Monad q => DsM q a -> DsM q b -> DsM q b
>>= :: forall a b. DsM q a -> (a -> DsM q b) -> DsM q b
$c>>= :: forall (q :: * -> *) a b.
Monad q =>
DsM q a -> (a -> DsM q b) -> DsM q b
Monad, forall (m :: * -> *) a. Monad m => m a -> DsM m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: forall (m :: * -> *) a. Monad m => m a -> DsM m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> DsM m a
MonadTrans, 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]
Extension -> DsM q Bool
ForeignSrcLang -> String -> DsM q ()
Module -> DsM q ModuleInfo
DocLoc -> DsM q (Maybe String)
DocLoc -> String -> DsM q ()
forall a. Data a => AnnLookup -> DsM q [a]
forall a. Typeable a => DsM q (Maybe a)
forall a. Typeable a => a -> DsM q ()
forall a. IO a -> DsM q a
forall a. DsM q a -> DsM q a -> DsM q a
forall (m :: * -> *).
MonadIO m
-> MonadFail m
-> (String -> m Name)
-> (Bool -> String -> m ())
-> (forall a. m a -> m a -> m a)
-> (Bool -> String -> m (Maybe Name))
-> (Name -> m Info)
-> (Name -> m (Maybe Fixity))
-> (Name -> m Kind)
-> (Name -> Cxt -> m [Dec])
-> (Name -> m [Role])
-> (forall a. Data a => AnnLookup -> m [a])
-> (Module -> m ModuleInfo)
-> (Name -> m [DecidedStrictness])
-> m Loc
-> (forall a. IO a -> m a)
-> (String -> m ())
-> (String -> m String)
-> ([Dec] -> m ())
-> (ForeignSrcLang -> String -> m ())
-> (Q () -> m ())
-> (String -> m ())
-> (forall a. Typeable a => m (Maybe a))
-> (forall a. Typeable a => a -> m ())
-> (Extension -> m Bool)
-> m [Extension]
-> (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 [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 => Extension -> DsM q Bool
forall (q :: * -> *).
Quasi q =>
ForeignSrcLang -> String -> DsM q ()
forall (q :: * -> *). Quasi q => Module -> DsM q ModuleInfo
forall (q :: * -> *). Quasi q => DocLoc -> DsM q (Maybe String)
forall (q :: * -> *). Quasi q => DocLoc -> String -> DsM q ()
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
qGetDoc :: DocLoc -> DsM q (Maybe String)
$cqGetDoc :: forall (q :: * -> *). Quasi q => DocLoc -> DsM q (Maybe String)
qPutDoc :: DocLoc -> String -> DsM q ()
$cqPutDoc :: forall (q :: * -> *). Quasi q => DocLoc -> String -> DsM q ()
qExtsEnabled :: DsM q [Extension]
$cqExtsEnabled :: forall (q :: * -> *). Quasi q => DsM q [Extension]
qIsExtEnabled :: Extension -> DsM q Bool
$cqIsExtEnabled :: forall (q :: * -> *). Quasi q => Extension -> DsM q Bool
qPutQ :: forall a. Typeable a => a -> DsM q ()
$cqPutQ :: forall (q :: * -> *) a. (Quasi q, Typeable a) => a -> DsM q ()
qGetQ :: forall a. Typeable a => DsM q (Maybe a)
$cqGetQ :: forall (q :: * -> *) a. (Quasi q, Typeable a) => DsM q (Maybe a)
qAddCorePlugin :: String -> DsM q ()
$cqAddCorePlugin :: forall (q :: * -> *). Quasi q => String -> DsM q ()
qAddModFinalizer :: Q () -> DsM q ()
$cqAddModFinalizer :: forall (q :: * -> *). Quasi q => Q () -> DsM q ()
qAddForeignFilePath :: ForeignSrcLang -> String -> DsM q ()
$cqAddForeignFilePath :: forall (q :: * -> *).
Quasi q =>
ForeignSrcLang -> String -> DsM q ()
qAddTopDecls :: [Dec] -> DsM q ()
$cqAddTopDecls :: forall (q :: * -> *). Quasi q => [Dec] -> DsM q ()
qAddTempFile :: String -> DsM q String
$cqAddTempFile :: forall (q :: * -> *). Quasi q => String -> DsM q String
qAddDependentFile :: String -> DsM q ()
$cqAddDependentFile :: forall (q :: * -> *). Quasi q => String -> DsM q ()
qRunIO :: forall a. IO a -> DsM q a
$cqRunIO :: forall (q :: * -> *) a. Quasi q => IO a -> DsM q a
qLocation :: DsM q Loc
$cqLocation :: forall (q :: * -> *). Quasi q => DsM q Loc
qReifyConStrictness :: Name -> DsM q [DecidedStrictness]
$cqReifyConStrictness :: forall (q :: * -> *). Quasi q => Name -> DsM q [DecidedStrictness]
qReifyModule :: Module -> DsM q ModuleInfo
$cqReifyModule :: forall (q :: * -> *). Quasi q => Module -> DsM q ModuleInfo
qReifyAnnotations :: forall a. Data a => AnnLookup -> DsM q [a]
$cqReifyAnnotations :: forall (q :: * -> *) a. (Quasi q, Data a) => AnnLookup -> DsM q [a]
qReifyRoles :: Name -> DsM q [Role]
$cqReifyRoles :: forall (q :: * -> *). Quasi q => Name -> DsM q [Role]
qReifyInstances :: Name -> Cxt -> DsM q [Dec]
$cqReifyInstances :: forall (q :: * -> *). Quasi q => Name -> Cxt -> DsM q [Dec]
qReifyType :: Name -> DsM q Kind
$cqReifyType :: forall (q :: * -> *). Quasi q => Name -> DsM q Kind
qReifyFixity :: Name -> DsM q (Maybe Fixity)
$cqReifyFixity :: forall (q :: * -> *). Quasi q => Name -> DsM q (Maybe Fixity)
qReify :: Name -> DsM q Info
$cqReify :: forall (q :: * -> *). Quasi q => Name -> DsM q Info
qLookupName :: Bool -> String -> DsM q (Maybe Name)
$cqLookupName :: forall (q :: * -> *).
Quasi q =>
Bool -> String -> DsM q (Maybe Name)
qRecover :: forall a. DsM q a -> DsM q a -> DsM q a
$cqRecover :: forall (q :: * -> *) a. Quasi q => DsM q a -> DsM q a -> DsM q a
qReport :: Bool -> String -> DsM q ()
$cqReport :: forall (q :: * -> *). Quasi q => Bool -> String -> DsM q ()
qNewName :: String -> DsM q Name
$cqNewName :: forall (q :: * -> *). Quasi q => String -> DsM q Name
Quasi, forall a. String -> DsM q a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
forall {q :: * -> *}. MonadFail q => Monad (DsM q)
forall (q :: * -> *) a. MonadFail q => String -> DsM q a
fail :: forall a. String -> DsM q a
$cfail :: forall (q :: * -> *) a. MonadFail q => String -> DsM q a
Fail.MonadFail
#if __GLASGOW_HASKELL__ >= 803
, forall a. IO a -> DsM q a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {q :: * -> *}. MonadIO q => Monad (DsM q)
forall (q :: * -> *) a. MonadIO q => IO a -> DsM q a
liftIO :: forall a. IO a -> DsM q a
$cliftIO :: forall (q :: * -> *) a. MonadIO q => IO a -> DsM q a
MonadIO
#endif
)
instance (Quasi q, Fail.MonadFail q) => DsMonad (DsM q) where
localDeclarations :: DsM q [Dec]
localDeclarations = forall (q :: * -> *) a. ReaderT [Dec] q a -> DsM q a
DsM forall r (m :: * -> *). MonadReader r m => m r
ask
instance DsMonad m => DsMonad (ReaderT r m) where
localDeclarations :: ReaderT r m [Dec]
localDeclarations = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations
instance DsMonad m => DsMonad (StateT s m) where
localDeclarations :: StateT s m [Dec]
localDeclarations = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations
instance (DsMonad m, Monoid w) => DsMonad (WriterT w m) where
localDeclarations :: WriterT w m [Dec]
localDeclarations = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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 <- forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT [Dec] q a
x ([Dec]
orig_decs forall a. [a] -> [a] -> [a]
++ [Dec]
new_decs)
reifyInDecs :: Name -> [Dec] -> Maybe Info
reifyInDecs :: Name -> [Dec] -> Maybe Info
reifyInDecs Name
n [Dec]
decs = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch (Name -> [Dec] -> Dec -> Maybe (Named Info)
reifyInDec Name
n [Dec]
decs) [Dec]
decs
reifyFixityInDecs :: Name -> [Dec] -> Maybe Fixity
reifyFixityInDecs :: Name -> [Dec] -> Maybe Fixity
reifyFixityInDecs Name
n = 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'
= forall a. a -> Maybe a
Just Fixity
fixity
match_fixity (ClassD Cxt
_ Name
_ [TyVarBndrUnit]
_ [FunDep]
_ [Dec]
sub_decs) = forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch Dec -> Maybe Fixity
match_fixity [Dec]
sub_decs
match_fixity Dec
_ = forall a. Maybe a
Nothing
type Named a = (Name, a)
reifyInDec :: Name -> [Dec] -> Dec -> Maybe (Named Info)
reifyInDec :: Name -> [Dec] -> Dec -> Maybe (Named Info)
reifyInDec Name
n [Dec]
decs (FunD Name
n' [Clause]
_) | Name
n Name -> Name -> Bool
`nameMatches` Name
n' = 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' <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Name -> Name -> Bool
nameMatches Name
n) (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Pat -> OSet Name
extractBoundNamesPat Pat
pat))
= 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' = 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' = 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' = 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'
= 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'
= 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'
= 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'
= 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'
= 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'
= 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'
= forall a. a -> Maybe a
Just (Name
n', Name -> [Dec] -> Info
mkPatSynI Name
n [Dec]
decs)
#endif
#if __GLASGOW_HASKELL__ >= 906
reifyInDec n _ dec@(TypeDataD n' _ _ _) | n `nameMatches` n' = Just (n', TyConI dec)
#endif
reifyInDec Name
n [Dec]
decs (DataD Cxt
_ Name
ty_name [TyVarBndrUnit]
tvbs Maybe Kind
_mk [Con]
cons [DerivClause]
_)
| Just Named Info
info <- Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Named Info)
maybeReifyCon Name
n [Dec]
decs Name
ty_name (forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> TypeArg
tvbToTANormalWithSig [TyVarBndrUnit]
tvbs) [Con]
cons
= forall a. a -> Maybe a
Just Named Info
info
reifyInDec Name
n [Dec]
decs (NewtypeD Cxt
_ Name
ty_name [TyVarBndrUnit]
tvbs Maybe Kind
_mk Con
con [DerivClause]
_)
| Just Named Info
info <- Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Named Info)
maybeReifyCon Name
n [Dec]
decs Name
ty_name (forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> TypeArg
tvbToTANormalWithSig [TyVarBndrUnit]
tvbs) [Con
con]
= forall a. a -> Maybe a
Just Named 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
= 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 Named Info
info <- forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch (Name -> [Dec] -> Dec -> Maybe (Named Info)
reifyInDec Name
n [Dec]
decs) [Dec]
sub_decs
= forall a. a -> Maybe a
Just Named Info
info
reifyInDec Name
n [Dec]
decs (InstanceD Maybe Overlap
_ Cxt
_ Kind
_ [Dec]
sub_decs)
| Just Named Info
info <- forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch Dec -> Maybe (Named Info)
reify_in_instance [Dec]
sub_decs
= forall a. a -> Maybe a
Just Named Info
info
where
reify_in_instance :: Dec -> Maybe (Named Info)
reify_in_instance dec :: Dec
dec@(DataInstD {}) = Name -> [Dec] -> Dec -> Maybe (Named Info)
reifyInDec Name
n ([Dec]
sub_decs forall a. [a] -> [a] -> [a]
++ [Dec]
decs) Dec
dec
reify_in_instance dec :: Dec
dec@(NewtypeInstD {}) = Name -> [Dec] -> Dec -> Maybe (Named Info)
reifyInDec Name
n ([Dec]
sub_decs forall a. [a] -> [a] -> [a]
++ [Dec]
decs) Dec
dec
reify_in_instance Dec
_ = 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
= forall a. a -> Maybe a
Just (Name
n', Name -> Kind -> Maybe Dec -> Info
VarI Name
n Kind
full_sel_ty 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 Named Info
info <- Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Named Info)
maybeReifyCon Name
n [Dec]
decs Name
ty_name [TypeArg]
tys [Con]
cons
= forall a. a -> Maybe a
Just Named 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 Named Info
info <- Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Named Info)
maybeReifyCon Name
n [Dec]
decs Name
ty_name [TypeArg]
tys [Con
con]
= forall a. a -> Maybe a
Just Named 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 n decs (TypeDataD ty_name tvbs _mk cons)
| Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) cons
= Just info
#endif
reifyInDec Name
_ [Dec]
_ Dec
_ = forall a. Maybe a
Nothing
maybeReifyCon :: Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Named Info)
maybeReifyCon :: Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Named 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 forall a b. (a -> b) -> a -> b
$ [TyVarBndrUnit] -> Kind -> Con -> Kind
con_to_type [TyVarBndrUnit]
h98_tvbs Kind
h98_res_ty Con
con
= 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 forall a b. (a -> b) -> a -> b
$ [TyVarBndr Specificity] -> Cxt -> Kind -> Kind
maybeForallT [TyVarBndr Specificity]
tvbs [] forall a b. (a -> b) -> a -> b
$ Cxt -> Kind -> Kind
mkArrows [Kind
con_res_ty] Kind
sel_ty
= forall a. a -> Maybe a
Just (Name
n', Name -> Kind -> Maybe Dec -> Info
VarI Name
n Kind
full_sel_ty 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 ->
( 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 ->
forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags Specificity
SpecifiedSpec 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 forall a b. (a -> b) -> a -> b
$
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]
_ = 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
-> forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch Named Kind -> Maybe (Named Kind)
match_pat_syn_rec_sel forall a b. (a -> b) -> a -> b
$
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
fld_names Cxt
pat_syn_ty_vis_args
PatSynArgs
_ -> 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'
= forall a. a -> Maybe a
Just ( Name
n'
,
Kind -> Kind
unSigType 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 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
_
= 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
, forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VisFunArg -> Maybe Kind
vis_arg_anon_maybe forall a b. (a -> b) -> a -> b
$ FunArgs -> [VisFunArg]
filterVisFunArgs FunArgs
args
)
FAForalls (ForallInvis [TyVarBndr Specificity]
req_tvbs) FunArgs
args ->
( [TyVarBndr Specificity]
req_tvbs
, []
, forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VisFunArg -> Maybe Kind
vis_arg_anon_maybe forall a b. (a -> b) -> a -> b
$ FunArgs -> [VisFunArg]
filterVisFunArgs FunArgs
args
)
FACxt Cxt
req_cxt FunArgs
args ->
( forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags Specificity
SpecifiedSpec forall a b. (a -> b) -> a -> b
$
Cxt -> [TyVarBndrUnit]
freeVariablesWellScoped [Kind
pat_syn_ty]
, Cxt
req_cxt
, forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VisFunArg -> Maybe Kind
vis_arg_anon_maybe forall a b. (a -> b) -> a -> b
$ FunArgs -> [VisFunArg]
filterVisFunArgs FunArgs
args
)
FunArgs
args ->
( forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags Specificity
SpecifiedSpec forall a b. (a -> b) -> a -> b
$
Cxt -> [TyVarBndrUnit]
freeVariablesWellScoped [Kind
pat_syn_ty]
, []
, forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VisFunArg -> Maybe Kind
vis_arg_anon_maybe 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) = forall a. a -> Maybe a
Just Kind
ty
vis_arg_anon_maybe (VisFADep{}) = 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
(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 (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [BangType]
stys) Kind
h98_result_ty)
go (RecC Name
_ [VarBangType]
vstys) = (Bool
False, Cxt -> Kind -> Kind
mkArrows (forall a b. (a -> b) -> [a] -> [b]
map 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 (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [BangType
t1, BangType
t2]) Kind
h98_result_ty)
go (ForallC [TyVarBndr Specificity]
bndrs Cxt
cxt Con
c) = 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 (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [BangType]
stys) Kind
rty)
go (RecGadtC [Name]
_ [VarBangType]
vstys Kind
rty) = (Bool
True, Cxt -> Kind -> Kind
mkArrows (forall a b. (a -> b) -> [a] -> [b]
map 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 (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> Kind
no_type Name
n) forall a b. (a, b) -> b
snd 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 forall a. Maybe a
Nothing
findType :: Name -> [Dec] -> Maybe (Named Type)
findType :: Name -> [Dec] -> Maybe (Named Kind)
findType Name
n = 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' = forall a. a -> Maybe a
Just (Name
n', Kind
ty)
match_type Dec
_ = 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 (forall a. a -> Maybe a -> a
fromMaybe (Name -> Kind
no_type Name
n) 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 = 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' = forall a. a -> Maybe a
Just Kind
psty
match_pat_syn_type Dec
_ = forall a. Maybe a
Nothing
#endif
no_type :: Name -> Type
no_type :: Name -> Kind
no_type Name
n = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"No type information found in local declaration for "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
n
findInstances :: Name -> [Dec] -> [Dec]
findInstances :: Name -> [Dec] -> [Dec]
findInstances Name
n = forall a b. (a -> b) -> [a] -> [b]
map Dec -> Dec
stripInstanceDec forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
= 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndrUnit]
tvbs
then forall a. Maybe a
Nothing
else 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 forall a b. (a -> b) -> a -> b
$ Cxt
cxt forall a. [a] -> [a] -> [a]
++ [Kind
lhs] forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList Maybe Kind
mk
#endif
ty_head :: Kind -> Kind
ty_head = forall a b. (a, b) -> a
fst 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' = 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) =
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Kind -> Dec
SigD Name
n
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 {}) = forall a. a -> Maybe a
Just Dec
d
go d :: Dec
d@(OpenTypeFamilyD {}) = forall a. a -> Maybe a
Just Dec
d
go d :: Dec
d@(DataFamilyD {}) = forall a. a -> Maybe a
Just Dec
d
go 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 (forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags Specificity
SpecifiedSpec [TyVarBndrUnit]
all_cls_tvbs) Cxt
cls_cxt
| Bool
otherwise = forall a. a -> a
id
cls_cxt :: Cxt
cls_cxt :: Cxt
cls_cxt = [forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
cls_name) (forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Kind
tvbToType [TyVarBndrUnit]
cls_tvbs)]
quantified_meth_ty :: Type
quantified_meth_ty :: Kind
quantified_meth_ty
| 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 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 = forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags Specificity
SpecifiedSpec forall a b. (a -> b) -> a -> b
$
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
List.deleteFirstsBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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) 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
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr Specificity]
tvbs Bool -> Bool -> 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 forall a. [a] -> [a] -> [a]
++ [TyVarBndr Specificity]
tvbs2) (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 = 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' -> forall a. a -> Maybe a
Just (Name
n', Con
con)
RecC Name
n' [VarBangType]
_ | Name
n Name -> Name -> Bool
`nameMatches` Name
n' -> forall a. a -> Maybe a
Just (Name
n', Con
con)
InfixC BangType
_ Name
n' BangType
_ | Name
n Name -> Name -> Bool
`nameMatches` Name
n' -> 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
_) -> forall a. a -> Maybe a
Just (Name
n', Con
con)
Maybe (Named Con)
Nothing -> 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
_ -> 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 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' -> forall a. a -> Maybe a
Just (Name
n', Con
con)
Maybe Name
Nothing -> 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 = forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch (Maybe [TyVarBndr Specificity] -> Con -> Maybe (Named RecSelInfo)
match_con 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 ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b) -> (c, a) -> (c, b)
liftSnd Kind -> RecSelInfo
RecSelH98) forall a b. (a -> b) -> a -> b
$
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch forall {b} {b}. (Name, b, b) -> Maybe (Name, b)
match_rec_sel [VarBangType]
vstys
RecGadtC [Name]
_ [VarBangType]
vstys Kind
ret_ty ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b) -> (c, a) -> (c, b)
liftSnd (\Kind
field_ty ->
Maybe [TyVarBndr Specificity] -> Kind -> Kind -> RecSelInfo
RecSelGADT (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)) forall a b. (a -> b) -> a -> b
$
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch 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 (forall a. a -> Maybe a
Just [TyVarBndr Specificity]
tvbs) Con
c
Con
_ -> 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' = forall a. a -> Maybe a
Just (Name
n', b
sel_ty)
match_rec_sel (Name, b, 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 =
forall a. (a -> Bool) -> [a] -> [a]
filter (\TyVarBndr Specificity
tvb -> forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndr Specificity
tvb forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
ret_fvs)
where
ret_fvs :: Set Name
ret_fvs = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *) a. Quasi m => m a -> m a -> m a
qRecover
(forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Dec] -> Maybe Fixity
reifyFixityInDecs Name
name forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations)
(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 <- forall (q :: * -> *). DsMonad q => Name -> q (Maybe Kind)
reifyTypeWithLocals_maybe Name
name
case Maybe Kind
m_info of
Maybe Kind
Nothing -> forall (m :: * -> *) a. MonadFail m => Name -> m a
reifyFail Name
name
Just Kind
i -> 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 <- forall (m :: * -> *). Quasi m => Extension -> m Bool
qIsExtEnabled Extension
CUSKs
#else
let cusks = True
#endif
forall (m :: * -> *) a. Quasi m => m a -> m a -> m a
qRecover (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Name -> [Dec] -> Maybe Kind
reifyTypeInDecs Bool
cusks Name
name forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations)
(forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Info -> Maybe Kind
infoType) 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
_ -> forall a. a -> Maybe a
Just Kind
t
DataConI Name
_ Kind
t Name
_ -> forall a. a -> Maybe a
Just Kind
t
VarI Name
_ Kind
t Maybe Dec
_ -> forall a. a -> Maybe a
Just Kind
t
TyVarI Name
_ Kind
t -> forall a. a -> Maybe a
Just Kind
t
#if __GLASGOW_HASKELL__ >= 802
PatSynI Name
_ Kind
t -> forall a. a -> Maybe a
Just Kind
t
#endif
Info
_ -> forall a. Maybe a
Nothing
findKind :: Bool
-> Name -> [Dec] -> Maybe Kind
findKind :: Bool -> Name -> [Dec] -> Maybe Kind
findKind Bool
cusks Name
name [Dec]
decls =
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMatch (Name -> [Dec] -> Dec -> Maybe Kind
match_kind_sig Name
name [Dec]
decls) [Dec]
decls
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Alternative f => Bool -> f a -> f a
whenAlt Bool
cusks (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 <- 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 = forall a b. (a -> b) -> [a] -> [b]
map VisFunArg -> Maybe Kind
vis_arg_kind_maybe forall a b. (a -> b) -> a -> b
$ FunArgs -> [VisFunArg]
filterVisFunArgs FunArgs
arg_kis
cls_tvb_kind_map :: Map Name Kind
cls_tvb_kind_map =
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
tvb, Kind
tvb_kind)
| (TyVarBndrUnit
tvb, Maybe Kind
mb_vis_arg_ki) <- 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall flag. TyVarBndr_ flag -> Maybe Kind
tvb_kind_maybe TyVarBndrUnit
tvb]
]
= 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' = forall a. a -> Maybe a
Just Kind
ki
#endif
find_kind_sig Name
_ Dec
_ = 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
|
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall flag. TyVarBndr_ flag -> Bool
tvb_is_kinded [TyVarBndrUnit]
tvbs
, let cls_tvb_kind_map :: Map Name Kind
cls_tvb_kind_map = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
tvb, Kind
tvb_kind)
| TyVarBndrUnit
tvb <- [TyVarBndrUnit]
tvbs
, Just Kind
tvb_kind <- [forall flag. TyVarBndr_ flag -> Maybe Kind
tvb_kind_maybe TyVarBndrUnit
tvb]
]
= 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 n (TypeDataD n' tvbs m_ki _)
| n `nameMatches` n'
= datatype_kind tvbs m_ki
#endif
match_cusk Name
_ Dec
_ = 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 (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 (forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> TyVarBndrUnit
ascribe_tf_tvb_kind [TyVarBndrUnit]
tf_tvbs)
(Maybe Kind -> Kind
default_res_ki forall a b. (a -> b) -> a -> b
$ FamilyResultSig -> Maybe Kind
res_sig_to_kind FamilyResultSig
res_sig)
Dec
_ -> forall a. Maybe a
Nothing
where
ascribe_tf_tvb_kind :: TyVarBndrUnit -> TyVarBndrUnit
ascribe_tf_tvb_kind :: TyVarBndrUnit -> TyVarBndrUnit
ascribe_tf_tvb_kind TyVarBndrUnit
tvb =
forall r flag.
(Name -> r) -> (Name -> Kind -> r) -> TyVarBndr_ flag -> r
elimTV (\Name
tvn -> Name -> Kind -> TyVarBndrUnit
kindedTV Name
tvn forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Kind
StarT forall a b. (a -> b) -> a -> b
$ 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 =
forall (f :: * -> *) a. Alternative f => Bool -> f a -> f a
whenAlt (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall flag. TyVarBndr_ flag -> Bool
tvb_is_kinded [TyVarBndrUnit]
tvbs Bool -> Bool -> Bool
&& Bool
ki_fvs_are_bound) 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 = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. TypeSubstitution a => a -> [Name]
freeVariables Maybe Kind
m_ki
tvb_vars :: Set Name
tvb_vars = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a. TypeSubstitution a => a -> [Name]
freeVariables forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Kind
tvbToTypeWithSig [TyVarBndrUnit]
tvbs
in Set Name
ki_fvs 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 = forall (f :: * -> *) a. Alternative f => Bool -> f a -> f a
whenAlt (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall flag. TyVarBndr_ flag -> Bool
tvb_is_kinded [TyVarBndrUnit]
tvbs) 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 (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 -> forall (f :: * -> *) a. Alternative f => Bool -> f a -> f a
whenAlt (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall flag. TyVarBndr_ flag -> Bool
tvb_is_kinded [TyVarBndrUnit]
tvbs) forall a b. (a -> b) -> a -> b
$
[TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind [TyVarBndrUnit]
tvbs Kind
ki
Maybe Kind
Nothing -> 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 -> forall (f :: * -> *) a. Alternative f => Bool -> f a -> f a
whenAlt (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall flag. TyVarBndr_ flag -> Bool
tvb_is_kinded [TyVarBndrUnit]
tvbs) forall a b. (a -> b) -> a -> b
$
[TyVarBndrUnit] -> Kind -> Maybe Kind
build_kind [TyVarBndrUnit]
tvbs Kind
ki
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 =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Kind -> Kind
quantifyType forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> 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 (forall a. a -> Maybe a
Just Kind
res_kind, forall a. Ord a => [a] -> Set a
Set.fromList (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) =
forall r flag.
(Name -> r) -> (Name -> Kind -> r) -> TyVarBndr_ flag -> r
elimTV (\Name
n ->
( if Name
n 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 forall a. Maybe a
Nothing
, Set Name
res_fvs
))
(\Name
n Kind
k ->
( if Name
n 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 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
, forall a. Ord a => [a] -> Set a
Set.fromList (forall a. TypeSubstitution a => a -> [Name]
freeVariables Kind
k) 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 = 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 = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall r flag.
(Name -> r) -> (Name -> Kind -> r) -> TyVarBndr_ flag -> r
elimTV (\Name
_ -> forall a. Maybe a
Nothing) (\Name
_ Kind
k -> 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) = forall flag. TyVarBndr_ flag -> Maybe Kind
tvb_kind_maybe TyVarBndrUnit
tvb
vis_arg_kind_maybe (VisFAAnon Kind
k) = forall a. a -> Maybe a
Just Kind
k
default_tvb :: TyVarBndrUnit -> TyVarBndrUnit
default_tvb :: TyVarBndrUnit -> TyVarBndrUnit
default_tvb TyVarBndrUnit
tvb = 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 = 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 = forall a. Maybe a
Nothing
res_sig_to_kind (KindSig Kind
k) = forall a. a -> Maybe a
Just Kind
k
res_sig_to_kind (TyVarSig TyVarBndrUnit
tvb) = 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 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 = 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 = 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 <- 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{}) -> 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 <- forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations
let mb_infos :: [Maybe (Named Info)]
mb_infos = forall a b. (a -> b) -> [a] -> [b]
map (Name -> [Dec] -> Dec -> Maybe (Named Info)
reifyInDec Name
built_name [Dec]
decs) [Dec]
decs
infos :: [Named Info]
infos = forall a. [Maybe a] -> [a]
catMaybes [Maybe (Named Info)]
mb_infos
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstMatchM (if Bool
ns then Named Info -> q (Maybe Name)
find_type_name
else Named Info -> q (Maybe Name)
find_value_name) [Named Info]
infos
find_type_name, find_value_name :: Named Info -> q (Maybe Name)
find_type_name :: Named Info -> q (Maybe Name)
find_type_name (Name
n, Info
info) = do
NameSpace
name_space <- forall (q :: * -> *). DsMonad q => Info -> q NameSpace
lookupInfoNameSpace Info
info
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case NameSpace
name_space of
NameSpace
TcClsName -> forall a. a -> Maybe a
Just Name
n
NameSpace
VarName -> forall a. Maybe a
Nothing
NameSpace
DataName -> forall a. Maybe a
Nothing
find_value_name :: Named Info -> q (Maybe Name)
find_value_name (Name
n, Info
info) = do
NameSpace
name_space <- forall (q :: * -> *). DsMonad q => Info -> q NameSpace
lookupInfoNameSpace Info
info
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case NameSpace
name_space of
NameSpace
VarName -> forall a. a -> Maybe a
Just Name
n
NameSpace
DataName -> forall a. a -> Maybe a
Just Name
n
NameSpace
TcClsName -> forall a. Maybe a
Nothing
mkDataNameWithLocals :: DsMonad q => String -> q Name
mkDataNameWithLocals :: forall (q :: * -> *). DsMonad q => String -> q Name
mkDataNameWithLocals = forall (q :: * -> *).
Quasi q =>
(String -> q (Maybe Name))
-> (String -> String -> String -> Name) -> String -> q Name
mkNameWith 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 = forall (q :: * -> *).
Quasi q =>
(String -> q (Maybe Name))
-> (String -> String -> String -> Name) -> String -> q Name
mkNameWith 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
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just NameSpace
ns
NameFlavour
_ -> do Maybe Info
mb_info <- forall (q :: * -> *). DsMonad q => Name -> q (Maybe Info)
reifyWithLocals_maybe Name
n
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse 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{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NameSpace
TcClsName
TyConI{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NameSpace
TcClsName
FamilyI{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NameSpace
TcClsName
PrimTyConI{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NameSpace
TcClsName
TyVarI{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NameSpace
TcClsName
ClassOpI{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NameSpace
VarName
VarI{} -> 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 <- forall (q :: * -> *). DsMonad q => Name -> q (Maybe Info)
reifyWithLocals_maybe Name
parent_name
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Maybe Info
mb_parent_info of
#if __GLASGOW_HASKELL__ >= 906
Just (TyConI (TypeDataD {}))
-> TcClsName
#endif
Maybe Info
_ -> NameSpace
DataName
#if __GLASGOW_HASKELL__ >= 801
PatSynI{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NameSpace
DataName
#endif