{-# LANGUAGE CPP, DeriveDataTypeable, RankNTypes, ScopedTypeVariables, TupleSections #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TypeApplications #-}
#endif
module Language.Haskell.TH.Desugar.Util (
newUniqueName,
impossible,
nameOccursIn, allNamesIn, mkTypeName, mkDataName, mkNameWith, isDataName,
stripVarP_maybe, extractBoundNamesStmt,
concatMapM, mapAccumLM, mapMaybeM, expectJustM,
stripPlainTV_maybe,
thirdOf3, splitAtList, extractBoundNamesDec,
extractBoundNamesPat,
tvbToType, tvbToTypeWithSig, tvbToTANormalWithSig,
nameMatches, thdOf3, firstMatch,
unboxedSumDegree_maybe, unboxedSumNameDegree_maybe,
tupleDegree_maybe, tupleNameDegree_maybe, unboxedTupleDegree_maybe,
unboxedTupleNameDegree_maybe, splitTuple_maybe,
topEverywhereM, isInfixDataCon,
isTypeKindName, typeKindName,
mkExtraKindBindersGeneric, unravelType, unSigType, unfoldType,
TypeArg(..), applyType, filterTANormals, unSigTypeArg, probablyWrongUnTypeArg
#if __GLASGOW_HASKELL__ >= 800
, bindIP
#endif
) where
import Prelude hiding (mapM, foldl, concatMap, any)
import Language.Haskell.TH hiding ( cxt )
import Language.Haskell.TH.Datatype (tvName)
import qualified Language.Haskell.TH.Desugar.OSet as OS
import Language.Haskell.TH.Desugar.OSet (OSet)
import Language.Haskell.TH.Syntax
import Control.Monad ( replicateM )
import qualified Control.Monad.Fail as Fail
import Data.Foldable
import Data.Generics hiding ( Fixity )
import Data.Traversable
import Data.Maybe
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
#endif
#if __GLASGOW_HASKELL__ >= 800
import qualified Data.Kind as Kind
import GHC.Classes ( IP )
import Unsafe.Coerce ( unsafeCoerce )
#endif
newUniqueName :: Quasi q => String -> q Name
newUniqueName :: String -> q Name
newUniqueName str :: String
str = do
Name
n <- String -> q Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
str
String -> q Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName (String -> q Name) -> String -> q Name
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Show a => a -> String
show Name
n
mkNameWith :: Quasi q => (String -> q (Maybe Name))
-> (String -> String -> String -> Name)
-> String -> q Name
mkNameWith :: (String -> q (Maybe Name))
-> (String -> String -> String -> Name) -> String -> q Name
mkNameWith lookup_fun :: String -> q (Maybe Name)
lookup_fun mkName_fun :: String -> String -> String -> Name
mkName_fun str :: String
str = do
Maybe Name
m_name <- String -> q (Maybe Name)
lookup_fun String
str
case Maybe Name
m_name of
Just name :: Name
name -> Name -> q Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name
Nothing -> do
Loc { loc_package :: Loc -> String
loc_package = String
pkg, loc_module :: Loc -> String
loc_module = String
modu } <- q Loc
forall (m :: * -> *). Quasi m => m Loc
qLocation
Name -> q Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> q Name) -> Name -> q Name
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> Name
mkName_fun String
pkg String
modu String
str
mkTypeName :: Quasi q => String -> q Name
mkTypeName :: String -> q Name
mkTypeName = (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 (Bool -> String -> q (Maybe Name)
forall (m :: * -> *). Quasi m => Bool -> String -> m (Maybe Name)
qLookupName Bool
True) String -> String -> String -> Name
mkNameG_tc
mkDataName :: Quasi q => String -> q Name
mkDataName :: String -> q Name
mkDataName = (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 (Bool -> String -> q (Maybe Name)
forall (m :: * -> *). Quasi m => Bool -> String -> m (Maybe Name)
qLookupName Bool
False) String -> String -> String -> Name
mkNameG_d
isDataName :: Name -> Bool
isDataName :: Name -> Bool
isDataName (Name _ (NameG DataName _ _)) = Bool
True
isDataName _ = Bool
False
stripVarP_maybe :: Pat -> Maybe Name
stripVarP_maybe :: Pat -> Maybe Name
stripVarP_maybe (VarP name :: Name
name) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name
stripVarP_maybe _ = Maybe Name
forall a. Maybe a
Nothing
stripPlainTV_maybe :: TyVarBndr -> Maybe Name
stripPlainTV_maybe :: TyVarBndr -> Maybe Name
stripPlainTV_maybe (PlainTV n :: Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
stripPlainTV_maybe _ = Maybe Name
forall a. Maybe a
Nothing
impossible :: Fail.MonadFail q => String -> q a
impossible :: String -> q a
impossible err :: String
err = String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n This should not happen in Haskell.\n Please email rae@cs.brynmawr.edu with your code if you see this.")
tvbToType :: TyVarBndr -> Type
tvbToType :: TyVarBndr -> Type
tvbToType = Name -> Type
VarT (Name -> Type) -> (TyVarBndr -> Name) -> TyVarBndr -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
tvName
tvbToTypeWithSig :: TyVarBndr -> Type
tvbToTypeWithSig :: TyVarBndr -> Type
tvbToTypeWithSig (PlainTV n :: Name
n) = Name -> Type
VarT Name
n
tvbToTypeWithSig (KindedTV n :: Name
n k :: Type
k) = Type -> Type -> Type
SigT (Name -> Type
VarT Name
n) Type
k
tvbToTANormalWithSig :: TyVarBndr -> TypeArg
tvbToTANormalWithSig :: TyVarBndr -> TypeArg
tvbToTANormalWithSig = Type -> TypeArg
TANormal (Type -> TypeArg) -> (TyVarBndr -> Type) -> TyVarBndr -> TypeArg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Type
tvbToTypeWithSig
nameMatches :: Name -> Name -> Bool
nameMatches :: Name -> Name -> Bool
nameMatches n1 :: Name
n1@(Name occ1 :: OccName
occ1 flav1 :: NameFlavour
flav1) n2 :: Name
n2@(Name occ2 :: OccName
occ2 flav2 :: NameFlavour
flav2)
| NameFlavour
NameS <- NameFlavour
flav1 = OccName
occ1 OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
occ2
| NameFlavour
NameS <- NameFlavour
flav2 = OccName
occ1 OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
occ2
| NameQ mod1 :: ModName
mod1 <- NameFlavour
flav1
, NameQ mod2 :: ModName
mod2 <- NameFlavour
flav2
= ModName
mod1 ModName -> ModName -> Bool
forall a. Eq a => a -> a -> Bool
== ModName
mod2 Bool -> Bool -> Bool
&& OccName
occ1 OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
occ2
| NameQ mod1 :: ModName
mod1 <- NameFlavour
flav1
, NameG _ _ mod2 :: ModName
mod2 <- NameFlavour
flav2
= ModName
mod1 ModName -> ModName -> Bool
forall a. Eq a => a -> a -> Bool
== ModName
mod2 Bool -> Bool -> Bool
&& OccName
occ1 OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
occ2
| NameG _ _ mod1 :: ModName
mod1 <- NameFlavour
flav1
, NameQ mod2 :: ModName
mod2 <- NameFlavour
flav2
= ModName
mod1 ModName -> ModName -> Bool
forall a. Eq a => a -> a -> Bool
== ModName
mod2 Bool -> Bool -> Bool
&& OccName
occ1 OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
occ2
| Bool
otherwise
= Name
n1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n2
tupleDegree_maybe :: String -> Maybe Int
tupleDegree_maybe :: String -> Maybe Int
tupleDegree_maybe s :: String
s = do
'(' : s1 :: String
s1 <- String -> Maybe String
forall (m :: * -> *) a. Monad m => a -> m a
return String
s
(commas :: String
commas, ")") <- (String, String) -> Maybe (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> Maybe (String, String))
-> (String, String) -> Maybe (String, String)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ',') String
s1
let degree :: Int
degree
| String
"" <- String
commas = 0
| Bool
otherwise = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
commas Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
Int -> Maybe Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
degree
tupleNameDegree_maybe :: Name -> Maybe Int
tupleNameDegree_maybe :: Name -> Maybe Int
tupleNameDegree_maybe = String -> Maybe Int
tupleDegree_maybe (String -> Maybe Int) -> (Name -> String) -> Name -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
unboxedSumDegree_maybe :: String -> Maybe Int
unboxedSumDegree_maybe :: String -> Maybe Int
unboxedSumDegree_maybe = Char -> String -> Maybe Int
unboxedSumTupleDegree_maybe '|'
unboxedSumNameDegree_maybe :: Name -> Maybe Int
unboxedSumNameDegree_maybe :: Name -> Maybe Int
unboxedSumNameDegree_maybe = String -> Maybe Int
unboxedSumDegree_maybe (String -> Maybe Int) -> (Name -> String) -> Name -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
unboxedTupleDegree_maybe :: String -> Maybe Int
unboxedTupleDegree_maybe :: String -> Maybe Int
unboxedTupleDegree_maybe = Char -> String -> Maybe Int
unboxedSumTupleDegree_maybe ','
unboxedSumTupleDegree_maybe :: Char -> String -> Maybe Int
unboxedSumTupleDegree_maybe :: Char -> String -> Maybe Int
unboxedSumTupleDegree_maybe sep :: Char
sep s :: String
s = do
'(' : '#' : s1 :: String
s1 <- String -> Maybe String
forall (m :: * -> *) a. Monad m => a -> m a
return String
s
(seps :: String
seps, "#)") <- (String, String) -> Maybe (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> Maybe (String, String))
-> (String, String) -> Maybe (String, String)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
sep) String
s1
let degree :: Int
degree
| String
"" <- String
seps = 0
| Bool
otherwise = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
seps Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
Int -> Maybe Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
degree
unboxedTupleNameDegree_maybe :: Name -> Maybe Int
unboxedTupleNameDegree_maybe :: Name -> Maybe Int
unboxedTupleNameDegree_maybe = String -> Maybe Int
unboxedTupleDegree_maybe (String -> Maybe Int) -> (Name -> String) -> Name -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
splitTuple_maybe :: Type -> Maybe [Type]
splitTuple_maybe :: Type -> Maybe [Type]
splitTuple_maybe t :: Type
t = [Type] -> Type -> Maybe [Type]
go [] Type
t
where go :: [Type] -> Type -> Maybe [Type]
go args :: [Type]
args (t1 :: Type
t1 `AppT` t2 :: Type
t2) = [Type] -> Type -> Maybe [Type]
go (Type
t2Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
args) Type
t1
go args :: [Type]
args (t1 :: Type
t1 `SigT` _k :: Type
_k) = [Type] -> Type -> Maybe [Type]
go [Type]
args Type
t1
go args :: [Type]
args (ConT con_name :: Name
con_name)
| Just degree :: Int
degree <- Name -> Maybe Int
tupleNameDegree_maybe Name
con_name
, [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
degree
= [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just [Type]
args
go args :: [Type]
args (TupleT degree :: Int
degree)
| [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
degree
= [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just [Type]
args
go _ _ = Maybe [Type]
forall a. Maybe a
Nothing
mkExtraKindBindersGeneric
:: Quasi q
=> (kind -> ([tyVarBndr], [pred], [kind], kind))
-> (Name -> kind -> tyVarBndr)
-> kind -> q [tyVarBndr]
unravel :: kind -> ([tyVarBndr], [pred], [kind], kind)
unravel mkKindedTV :: Name -> kind -> tyVarBndr
mkKindedTV k :: kind
k = do
let (_, _, args :: [kind]
args, _) = kind -> ([tyVarBndr], [pred], [kind], kind)
unravel kind
k
[Name]
names <- Int -> q Name -> q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([kind] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [kind]
args) (String -> q Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName "a")
[tyVarBndr] -> q [tyVarBndr]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name -> kind -> tyVarBndr) -> [Name] -> [kind] -> [tyVarBndr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> kind -> tyVarBndr
mkKindedTV [Name]
names [kind]
args)
unravelType :: Type -> ([TyVarBndr], [Pred], [Type], Type)
unravelType :: Type -> ([TyVarBndr], [Type], [Type], Type)
unravelType (ForallT tvbs :: [TyVarBndr]
tvbs cxt :: [Type]
cxt ty :: Type
ty) =
let (tvbs' :: [TyVarBndr]
tvbs', cxt' :: [Type]
cxt', tys :: [Type]
tys, res :: Type
res) = Type -> ([TyVarBndr], [Type], [Type], Type)
unravelType Type
ty in
([TyVarBndr]
tvbs [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ [TyVarBndr]
tvbs', [Type]
cxt [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
cxt', [Type]
tys, Type
res)
unravelType (AppT (AppT ArrowT t1 :: Type
t1) t2 :: Type
t2) =
let (tvbs :: [TyVarBndr]
tvbs, cxt :: [Type]
cxt, tys :: [Type]
tys, res :: Type
res) = Type -> ([TyVarBndr], [Type], [Type], Type)
unravelType Type
t2 in
([TyVarBndr]
tvbs, [Type]
cxt, Type
t1 Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
tys, Type
res)
unravelType t :: Type
t = ([], [], [], Type
t)
unSigType :: Type -> Type
unSigType :: Type -> Type
unSigType (SigT t :: Type
t _) = Type
t
unSigType (AppT f :: Type
f x :: Type
x) = Type -> Type -> Type
AppT (Type -> Type
unSigType Type
f) (Type -> Type
unSigType Type
x)
unSigType (ForallT tvbs :: [TyVarBndr]
tvbs ctxt :: [Type]
ctxt t :: Type
t) =
[TyVarBndr] -> [Type] -> Type -> Type
ForallT [TyVarBndr]
tvbs ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
unSigPred [Type]
ctxt) (Type -> Type
unSigType Type
t)
#if __GLASGOW_HASKELL__ >= 800
unSigType (InfixT t1 :: Type
t1 n :: Name
n t2 :: Type
t2) = Type -> Name -> Type -> Type
InfixT (Type -> Type
unSigType Type
t1) Name
n (Type -> Type
unSigType Type
t2)
unSigType (UInfixT t1 :: Type
t1 n :: Name
n t2 :: Type
t2) = Type -> Name -> Type -> Type
UInfixT (Type -> Type
unSigType Type
t1) Name
n (Type -> Type
unSigType Type
t2)
unSigType (ParensT t :: Type
t) = Type -> Type
ParensT (Type -> Type
unSigType Type
t)
#endif
#if __GLASGOW_HASKELL__ >= 807
unSigType (AppKindT t :: Type
t k :: Type
k) = Type -> Type -> Type
AppKindT (Type -> Type
unSigType Type
t) (Type -> Type
unSigType Type
k)
unSigType (ImplicitParamT n :: String
n t :: Type
t) = String -> Type -> Type
ImplicitParamT String
n (Type -> Type
unSigType Type
t)
#endif
unSigType t :: Type
t = Type
t
unSigPred :: Pred -> Pred
#if __GLASGOW_HASKELL__ >= 710
unSigPred :: Type -> Type
unSigPred = Type -> Type
unSigType
#else
unSigPred (ClassP n tys) = ClassP n (map unSigType tys)
unSigPred (EqualP t1 t2) = EqualP (unSigType t1) (unSigType t2)
#endif
unfoldType :: Type -> (Type, [TypeArg])
unfoldType :: Type -> (Type, [TypeArg])
unfoldType = [TypeArg] -> Type -> (Type, [TypeArg])
go []
where
go :: [TypeArg] -> Type -> (Type, [TypeArg])
go :: [TypeArg] -> Type -> (Type, [TypeArg])
go acc :: [TypeArg]
acc (ForallT _ _ ty :: Type
ty) = [TypeArg] -> Type -> (Type, [TypeArg])
go [TypeArg]
acc Type
ty
go acc :: [TypeArg]
acc (AppT ty1 :: Type
ty1 ty2 :: Type
ty2) = [TypeArg] -> Type -> (Type, [TypeArg])
go (Type -> TypeArg
TANormal Type
ty2TypeArg -> [TypeArg] -> [TypeArg]
forall a. a -> [a] -> [a]
:[TypeArg]
acc) Type
ty1
go acc :: [TypeArg]
acc (SigT ty :: Type
ty _) = [TypeArg] -> Type -> (Type, [TypeArg])
go [TypeArg]
acc Type
ty
#if __GLASGOW_HASKELL__ >= 800
go acc :: [TypeArg]
acc (ParensT ty :: Type
ty) = [TypeArg] -> Type -> (Type, [TypeArg])
go [TypeArg]
acc Type
ty
#endif
#if __GLASGOW_HASKELL__ >= 807
go acc :: [TypeArg]
acc (AppKindT ty :: Type
ty ki :: Type
ki) = [TypeArg] -> Type -> (Type, [TypeArg])
go (Type -> TypeArg
TyArg Type
kiTypeArg -> [TypeArg] -> [TypeArg]
forall a. a -> [a] -> [a]
:[TypeArg]
acc) Type
ty
#endif
go acc :: [TypeArg]
acc ty :: Type
ty = (Type
ty, [TypeArg]
acc)
data TypeArg
= TANormal Type
| TyArg Kind
deriving (TypeArg -> TypeArg -> Bool
(TypeArg -> TypeArg -> Bool)
-> (TypeArg -> TypeArg -> Bool) -> Eq TypeArg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeArg -> TypeArg -> Bool
$c/= :: TypeArg -> TypeArg -> Bool
== :: TypeArg -> TypeArg -> Bool
$c== :: TypeArg -> TypeArg -> Bool
Eq, Int -> TypeArg -> String -> String
[TypeArg] -> String -> String
TypeArg -> String
(Int -> TypeArg -> String -> String)
-> (TypeArg -> String)
-> ([TypeArg] -> String -> String)
-> Show TypeArg
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [TypeArg] -> String -> String
$cshowList :: [TypeArg] -> String -> String
show :: TypeArg -> String
$cshow :: TypeArg -> String
showsPrec :: Int -> TypeArg -> String -> String
$cshowsPrec :: Int -> TypeArg -> String -> String
Show, Typeable, Typeable TypeArg
DataType
Constr
Typeable TypeArg =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> TypeArg -> c TypeArg)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TypeArg)
-> (TypeArg -> Constr)
-> (TypeArg -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c TypeArg))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c TypeArg))
-> ((forall b. Data b => b -> b) -> TypeArg -> TypeArg)
-> (forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> TypeArg -> r)
-> (forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> TypeArg -> r)
-> (forall u. (forall d. Data d => d -> u) -> TypeArg -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> TypeArg -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> TypeArg -> m TypeArg)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> TypeArg -> m TypeArg)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> TypeArg -> m TypeArg)
-> Data TypeArg
TypeArg -> DataType
TypeArg -> Constr
(forall b. Data b => b -> b) -> TypeArg -> TypeArg
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> TypeArg -> c TypeArg
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TypeArg
forall a.
Typeable a =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> TypeArg -> u
forall u. (forall d. Data d => d -> u) -> TypeArg -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> TypeArg -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> TypeArg -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> TypeArg -> m TypeArg
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> TypeArg -> m TypeArg
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TypeArg
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> TypeArg -> c TypeArg
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c TypeArg)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c TypeArg)
$cTyArg :: Constr
$cTANormal :: Constr
$tTypeArg :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> TypeArg -> m TypeArg
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> TypeArg -> m TypeArg
gmapMp :: (forall d. Data d => d -> m d) -> TypeArg -> m TypeArg
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> TypeArg -> m TypeArg
gmapM :: (forall d. Data d => d -> m d) -> TypeArg -> m TypeArg
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> TypeArg -> m TypeArg
gmapQi :: Int -> (forall d. Data d => d -> u) -> TypeArg -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> TypeArg -> u
gmapQ :: (forall d. Data d => d -> u) -> TypeArg -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> TypeArg -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> TypeArg -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> TypeArg -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> TypeArg -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> TypeArg -> r
gmapT :: (forall b. Data b => b -> b) -> TypeArg -> TypeArg
$cgmapT :: (forall b. Data b => b -> b) -> TypeArg -> TypeArg
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c TypeArg)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c TypeArg)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c TypeArg)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c TypeArg)
dataTypeOf :: TypeArg -> DataType
$cdataTypeOf :: TypeArg -> DataType
toConstr :: TypeArg -> Constr
$ctoConstr :: TypeArg -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TypeArg
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TypeArg
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> TypeArg -> c TypeArg
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> TypeArg -> c TypeArg
$cp1Data :: Typeable TypeArg
Data)
applyType :: Type -> [TypeArg] -> Type
applyType :: Type -> [TypeArg] -> Type
applyType = (Type -> TypeArg -> Type) -> Type -> [TypeArg] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> TypeArg -> Type
apply
where
apply :: Type -> TypeArg -> Type
apply :: Type -> TypeArg -> Type
apply f :: Type
f (TANormal x :: Type
x) = Type
f Type -> Type -> Type
`AppT` Type
x
apply f :: Type
f (TyArg _x :: Type
_x) =
#if __GLASGOW_HASKELL__ >= 807
Type
f Type -> Type -> Type
`AppKindT` Type
_x
#else
f
#endif
filterTANormals :: [TypeArg] -> [Type]
filterTANormals :: [TypeArg] -> [Type]
filterTANormals = (TypeArg -> Maybe Type) -> [TypeArg] -> [Type]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TypeArg -> Maybe Type
getTANormal
where
getTANormal :: TypeArg -> Maybe Type
getTANormal :: TypeArg -> Maybe Type
getTANormal (TANormal t :: Type
t) = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
t
getTANormal (TyArg {}) = Maybe Type
forall a. Maybe a
Nothing
unSigTypeArg :: TypeArg -> TypeArg
unSigTypeArg :: TypeArg -> TypeArg
unSigTypeArg (TANormal t :: Type
t) = Type -> TypeArg
TANormal (Type -> Type
unSigType Type
t)
unSigTypeArg (TyArg k :: Type
k) = Type -> TypeArg
TyArg (Type -> Type
unSigType Type
k)
probablyWrongUnTypeArg :: TypeArg -> Type
probablyWrongUnTypeArg :: TypeArg -> Type
probablyWrongUnTypeArg (TANormal t :: Type
t) = Type
t
probablyWrongUnTypeArg (TyArg k :: Type
k) = Type
k
nameOccursIn :: Data a => Name -> a -> Bool
nameOccursIn :: Name -> a -> Bool
nameOccursIn n :: Name
n = (Bool -> Bool -> Bool) -> GenericQ Bool -> GenericQ Bool
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything Bool -> Bool -> Bool
(||) (GenericQ Bool -> a -> Bool) -> GenericQ Bool -> a -> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> (Name -> Bool) -> a -> Bool
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ Bool
False (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n)
allNamesIn :: Data a => a -> [Name]
allNamesIn :: a -> [Name]
allNamesIn = ([Name] -> [Name] -> [Name]) -> GenericQ [Name] -> GenericQ [Name]
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
(++) (GenericQ [Name] -> a -> [Name]) -> GenericQ [Name] -> a -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> (Name -> [Name]) -> a -> [Name]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ [] (Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[])
extractBoundNamesStmt :: Stmt -> OSet Name
(BindS pat :: Pat
pat _) = Pat -> OSet Name
extractBoundNamesPat Pat
pat
extractBoundNamesStmt (LetS decs :: [Dec]
decs) = (Dec -> OSet Name) -> [Dec] -> OSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Dec -> OSet Name
extractBoundNamesDec [Dec]
decs
extractBoundNamesStmt (NoBindS _) = OSet Name
forall a. OSet a
OS.empty
extractBoundNamesStmt (ParS stmtss :: [[Stmt]]
stmtss) = ([Stmt] -> OSet Name) -> [[Stmt]] -> OSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Stmt -> OSet Name) -> [Stmt] -> OSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Stmt -> OSet Name
extractBoundNamesStmt) [[Stmt]]
stmtss
#if __GLASGOW_HASKELL__ >= 807
extractBoundNamesStmt (RecS stmtss :: [Stmt]
stmtss) = (Stmt -> OSet Name) -> [Stmt] -> OSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Stmt -> OSet Name
extractBoundNamesStmt [Stmt]
stmtss
#endif
extractBoundNamesDec :: Dec -> OSet Name
(FunD name :: Name
name _) = Name -> OSet Name
forall a. a -> OSet a
OS.singleton Name
name
extractBoundNamesDec (ValD pat :: Pat
pat _ _) = Pat -> OSet Name
extractBoundNamesPat Pat
pat
extractBoundNamesDec _ = OSet Name
forall a. OSet a
OS.empty
extractBoundNamesPat :: Pat -> OSet Name
(LitP _) = OSet Name
forall a. OSet a
OS.empty
extractBoundNamesPat (VarP name :: Name
name) = Name -> OSet Name
forall a. a -> OSet a
OS.singleton Name
name
extractBoundNamesPat (TupP pats :: [Pat]
pats) = (Pat -> OSet Name) -> [Pat] -> OSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Pat -> OSet Name
extractBoundNamesPat [Pat]
pats
extractBoundNamesPat (UnboxedTupP pats :: [Pat]
pats) = (Pat -> OSet Name) -> [Pat] -> OSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Pat -> OSet Name
extractBoundNamesPat [Pat]
pats
extractBoundNamesPat (ConP _ pats :: [Pat]
pats) = (Pat -> OSet Name) -> [Pat] -> OSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Pat -> OSet Name
extractBoundNamesPat [Pat]
pats
extractBoundNamesPat (InfixP p1 :: Pat
p1 _ p2 :: Pat
p2) = Pat -> OSet Name
extractBoundNamesPat Pat
p1 OSet Name -> OSet Name -> OSet Name
forall a. Ord a => OSet a -> OSet a -> OSet a
`OS.union`
Pat -> OSet Name
extractBoundNamesPat Pat
p2
extractBoundNamesPat (UInfixP p1 :: Pat
p1 _ p2 :: Pat
p2) = Pat -> OSet Name
extractBoundNamesPat Pat
p1 OSet Name -> OSet Name -> OSet Name
forall a. Ord a => OSet a -> OSet a -> OSet a
`OS.union`
Pat -> OSet Name
extractBoundNamesPat Pat
p2
extractBoundNamesPat (ParensP pat :: Pat
pat) = Pat -> OSet Name
extractBoundNamesPat Pat
pat
extractBoundNamesPat (TildeP pat :: Pat
pat) = Pat -> OSet Name
extractBoundNamesPat Pat
pat
extractBoundNamesPat (BangP pat :: Pat
pat) = Pat -> OSet Name
extractBoundNamesPat Pat
pat
extractBoundNamesPat (AsP name :: Name
name pat :: Pat
pat) = Name -> OSet Name
forall a. a -> OSet a
OS.singleton Name
name OSet Name -> OSet Name -> OSet Name
forall a. Ord a => OSet a -> OSet a -> OSet a
`OS.union`
Pat -> OSet Name
extractBoundNamesPat Pat
pat
extractBoundNamesPat WildP = OSet Name
forall a. OSet a
OS.empty
extractBoundNamesPat (RecP _ field_pats :: [FieldPat]
field_pats) = let (_, pats :: [Pat]
pats) = [FieldPat] -> ([Name], [Pat])
forall a b. [(a, b)] -> ([a], [b])
unzip [FieldPat]
field_pats in
(Pat -> OSet Name) -> [Pat] -> OSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Pat -> OSet Name
extractBoundNamesPat [Pat]
pats
extractBoundNamesPat (ListP pats :: [Pat]
pats) = (Pat -> OSet Name) -> [Pat] -> OSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Pat -> OSet Name
extractBoundNamesPat [Pat]
pats
extractBoundNamesPat (SigP pat :: Pat
pat _) = Pat -> OSet Name
extractBoundNamesPat Pat
pat
extractBoundNamesPat (ViewP _ pat :: Pat
pat) = Pat -> OSet Name
extractBoundNamesPat Pat
pat
#if __GLASGOW_HASKELL__ >= 801
extractBoundNamesPat (UnboxedSumP pat :: Pat
pat _ _) = Pat -> OSet Name
extractBoundNamesPat Pat
pat
#endif
#if __GLASGOW_HASKELL__ >= 800
newtype MagicIP name a r = MagicIP (IP name a => r)
bindIP :: forall name a r. a -> (IP name a => r) -> r
bindIP :: a -> (IP name a => r) -> r
bindIP val :: a
val k :: IP name a => r
k = (MagicIP name a r -> a -> r
forall a b. a -> b
unsafeCoerce ((IP name a => r) -> MagicIP name a r
forall (name :: Symbol) a r. (IP name a => r) -> MagicIP name a r
MagicIP @name IP name a => r
k) :: a -> r) a
val
#endif
splitAtList :: [a] -> [b] -> ([b], [b])
splitAtList :: [a] -> [b] -> ([b], [b])
splitAtList [] x :: [b]
x = ([], [b]
x)
splitAtList (_ : t :: [a]
t) (x :: b
x : xs :: [b]
xs) =
let (as :: [b]
as, bs :: [b]
bs) = [a] -> [b] -> ([b], [b])
forall a b. [a] -> [b] -> ([b], [b])
splitAtList [a]
t [b]
xs in
(b
x b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
as, [b]
bs)
splitAtList (_ : _) [] = ([], [])
thdOf3 :: (a,b,c) -> c
thdOf3 :: (a, b, c) -> c
thdOf3 (_,_,c :: c
c) = c
c
thirdOf3 :: (a -> b) -> (c, d, a) -> (c, d, b)
thirdOf3 :: (a -> b) -> (c, d, a) -> (c, d, b)
thirdOf3 f :: a -> b
f (c :: c
c, d :: d
d, a :: a
a) = (c
c, d
d, a -> b
f a
a)
concatMapM :: (Monad monad, Monoid monoid, Traversable t)
=> (a -> monad monoid) -> t a -> monad monoid
concatMapM :: (a -> monad monoid) -> t a -> monad monoid
concatMapM fn :: a -> monad monoid
fn list :: t a
list = do
t monoid
bss <- (a -> monad monoid) -> t a -> monad (t monoid)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> monad monoid
fn t a
list
monoid -> monad monoid
forall (m :: * -> *) a. Monad m => a -> m a
return (monoid -> monad monoid) -> monoid -> monad monoid
forall a b. (a -> b) -> a -> b
$ t monoid -> monoid
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold t monoid
bss
mapAccumLM :: Monad m
=> (acc -> x -> m (acc, y))
-> acc
-> [x]
-> m (acc, [y])
mapAccumLM :: (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM _ s :: acc
s [] = (acc, [y]) -> m (acc, [y])
forall (m :: * -> *) a. Monad m => a -> m a
return (acc
s, [])
mapAccumLM f :: acc -> x -> m (acc, y)
f s :: acc
s (x :: x
x:xs :: [x]
xs) = do
(s1 :: acc
s1, x' :: y
x') <- acc -> x -> m (acc, y)
f acc
s x
x
(s2 :: acc
s2, xs' :: [y]
xs') <- (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM acc -> x -> m (acc, y)
f acc
s1 [x]
xs
(acc, [y]) -> m (acc, [y])
forall (m :: * -> *) a. Monad m => a -> m a
return (acc
s2, y
x' y -> [y] -> [y]
forall a. a -> [a] -> [a]
: [y]
xs')
mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM :: (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM _ [] = [b] -> m [b]
forall (m :: * -> *) a. Monad m => a -> m a
return []
mapMaybeM f :: a -> m (Maybe b)
f (x :: a
x:xs :: [a]
xs) = do
Maybe b
y <- a -> m (Maybe b)
f a
x
[b]
ys <- (a -> m (Maybe b)) -> [a] -> m [b]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM a -> m (Maybe b)
f [a]
xs
[b] -> m [b]
forall (m :: * -> *) a. Monad m => a -> m a
return ([b] -> m [b]) -> [b] -> m [b]
forall a b. (a -> b) -> a -> b
$ case Maybe b
y of
Nothing -> [b]
ys
Just z :: b
z -> b
z b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
ys
expectJustM :: Fail.MonadFail m => String -> Maybe a -> m a
expectJustM :: String -> Maybe a -> m a
expectJustM _ (Just x :: a
x) = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
expectJustM err :: String
err Nothing = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
err
firstMatch :: (a -> Maybe b) -> [a] -> Maybe b
firstMatch :: (a -> Maybe b) -> [a] -> Maybe b
firstMatch f :: a -> Maybe b
f xs :: [a]
xs = [b] -> Maybe b
forall a. [a] -> Maybe a
listToMaybe ([b] -> Maybe b) -> [b] -> Maybe b
forall a b. (a -> b) -> a -> b
$ (a -> Maybe b) -> [a] -> [b]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe a -> Maybe b
f [a]
xs
topEverywhereM :: (Typeable a, Data b, Monad m) => (a -> m a) -> b -> m b
topEverywhereM :: (a -> m a) -> b -> m b
topEverywhereM handler :: a -> m a
handler =
(forall d. Data d => d -> m d) -> b -> m b
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> a -> m a
gmapM ((a -> m a) -> d -> m d
forall a b (m :: * -> *).
(Typeable a, Data b, Monad m) =>
(a -> m a) -> b -> m b
topEverywhereM a -> m a
handler) (b -> m b) -> (a -> m a) -> b -> m b
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` a -> m a
handler
isInfixDataCon :: String -> Bool
isInfixDataCon :: String -> Bool
isInfixDataCon (':':_) = Bool
True
isInfixDataCon _ = Bool
False
isTypeKindName :: Name -> Bool
isTypeKindName :: Name -> Bool
isTypeKindName n :: Name
n = Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeKindName
#if __GLASGOW_HASKELL__ < 805
|| n == starKindName
|| n == uniStarKindName
#endif
typeKindName :: Name
#if __GLASGOW_HASKELL__ >= 800
typeKindName :: Name
typeKindName = ''Kind.Type
#else
typeKindName = starKindName
#endif
#if __GLASGOW_HASKELL__ < 805
starKindName :: Name
#if __GLASGOW_HASKELL__ >= 800
starKindName = ''(Kind.*)
#else
starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"
#endif
uniStarKindName :: Name
#if __GLASGOW_HASKELL__ >= 800
uniStarKindName = ''(Kind.★)
#else
uniStarKindName = starKindName
#endif
#endif