{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module TH.Utilities where
import Data.Data
import Data.Generics
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
tyVarBndrName :: TyVarBndr -> Name
tyVarBndrName :: TyVarBndr -> Name
tyVarBndrName (PlainTV Name
n) = Name
n
tyVarBndrName (KindedTV Name
n Kind
_) = Name
n
appsT :: Type -> [Type] -> Type
appsT :: Kind -> [Kind] -> Kind
appsT Kind
x [] = Kind
x
appsT Kind
x (Kind
y:[Kind]
xs) = Kind -> [Kind] -> Kind
appsT (Kind -> Kind -> Kind
AppT Kind
x Kind
y) [Kind]
xs
unAppsT :: Type -> [Type]
unAppsT :: Kind -> [Kind]
unAppsT = [Kind] -> Kind -> [Kind]
go []
where
go :: [Kind] -> Kind -> [Kind]
go [Kind]
xs (AppT Kind
l Kind
x) = [Kind] -> Kind -> [Kind]
go (Kind
x Kind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
: [Kind]
xs) Kind
l
go [Kind]
xs Kind
ty = Kind
ty Kind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
: [Kind]
xs
typeToNamedCon :: Type -> Maybe (Name, [Type])
#if MIN_VERSION_template_haskell(2,11,0)
typeToNamedCon :: Kind -> Maybe (Name, [Kind])
typeToNamedCon (InfixT Kind
l Name
n Kind
r) = (Name, [Kind]) -> Maybe (Name, [Kind])
forall a. a -> Maybe a
Just (Name
n, [Kind
l, Kind
r])
typeToNamedCon (UInfixT Kind
l Name
n Kind
r) = (Name, [Kind]) -> Maybe (Name, [Kind])
forall a. a -> Maybe a
Just (Name
n, [Kind
l, Kind
r])
#endif
typeToNamedCon (Kind -> [Kind]
unAppsT -> (ConT Name
n : [Kind]
args)) = (Name, [Kind]) -> Maybe (Name, [Kind])
forall a. a -> Maybe a
Just (Name
n, [Kind]
args)
typeToNamedCon Kind
_ = Maybe (Name, [Kind])
forall a. Maybe a
Nothing
expectTyCon1 :: Name -> Type -> Q Type
expectTyCon1 :: Name -> Kind -> Q Kind
expectTyCon1 Name
expected (AppT (ConT Name
n) Kind
x) | Name
expected Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n = Kind -> Q Kind
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
x
expectTyCon1 Name
expected (AppT (PromotedT Name
n) Kind
x) | Name
expected Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n = Kind -> Q Kind
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
x
expectTyCon1 Name
expected Kind
x = String -> Q Kind
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Kind) -> String -> Q Kind
forall a b. (a -> b) -> a -> b
$
String
"Expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Ppr a => a -> String
pprint Name
expected String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
", applied to one argument, but instead got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Ppr a => a -> String
pprint Kind
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
expectTyCon2 :: Name -> Type -> Q (Type, Type)
expectTyCon2 :: Name -> Kind -> Q (Kind, Kind)
expectTyCon2 Name
expected (AppT (AppT (ConT Name
n) Kind
x) Kind
y) | Name
expected Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n = (Kind, Kind) -> Q (Kind, Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind
x, Kind
y)
expectTyCon2 Name
expected (AppT (AppT (PromotedT Name
n) Kind
x) Kind
y) | Name
expected Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n = (Kind, Kind) -> Q (Kind, Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind
x, Kind
y)
#if MIN_VERSION_template_haskell(2,11,0)
expectTyCon2 Name
expected (InfixT Kind
x Name
n Kind
y) | Name
expected Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n = (Kind, Kind) -> Q (Kind, Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind
x, Kind
y)
expectTyCon2 Name
expected (UInfixT Kind
x Name
n Kind
y) | Name
expected Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n = (Kind, Kind) -> Q (Kind, Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind
x, Kind
y)
#endif
expectTyCon2 Name
expected Kind
x = String -> Q (Kind, Kind)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Kind, Kind)) -> String -> Q (Kind, Kind)
forall a b. (a -> b) -> a -> b
$
String
"Expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Ppr a => a -> String
pprint Name
expected String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
", applied to two arguments, but instead got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Ppr a => a -> String
pprint Kind
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
proxyE :: TypeQ -> ExpQ
proxyE :: Q Kind -> ExpQ
proxyE Q Kind
ty = [| Proxy :: Proxy $(ty) |]
everywhereButStrings :: Data a => (forall b. Data b => b -> b) -> a -> a
everywhereButStrings :: (forall b. Data b => b -> b) -> a -> a
everywhereButStrings forall b. Data b => b -> b
f =
(a -> a
forall b. Data b => b -> b
f (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b. Data b => b -> b) -> a -> a
forall a. Data a => (forall b. Data b => b -> b) -> a -> a
gmapT ((forall b. Data b => b -> b) -> b -> b
forall a. Data a => (forall b. Data b => b -> b) -> a -> a
everywhereButStrings forall b. Data b => b -> b
f)) (a -> a) -> (String -> String) -> a -> a
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` (String -> String
forall a. a -> a
id :: String -> String)
everywhereButStringsM :: forall a m. (Data a, Monad m) => GenericM m -> a -> m a
everywhereButStringsM :: GenericM m -> a -> m a
everywhereButStringsM GenericM m
f a
x = do
a
x' <- GenericM m -> a -> m a
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> a -> m a
gmapM (GenericM m -> d -> m d
forall a (m :: * -> *). (Data a, Monad m) => GenericM m -> a -> m a
everywhereButStringsM GenericM m
f) a
x
(a -> m a
GenericM m
f (a -> m a) -> (String -> m String) -> a -> m a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` (String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return :: String -> m String)) a
x'
toSimpleName :: Name -> Name
toSimpleName :: Name -> Name
toSimpleName = String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Ppr a => a -> String
pprint
dequalify :: Name -> Name
dequalify :: Name -> Name
dequalify = String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
dequalifyTyVars :: Data a => a -> a
dequalifyTyVars :: a -> a
dequalifyTyVars = (forall b. Data b => b -> b) -> forall b. Data b => b -> b
everywhere (a -> a
forall a. a -> a
id (a -> a) -> (Kind -> Kind) -> a -> a
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` Kind -> Kind
modifyType)
where
modifyType :: Kind -> Kind
modifyType (VarT Name
n) = Name -> Kind
VarT (Name -> Name
dequalify Name
n)
modifyType Kind
ty = Kind
ty
freeVarsT :: Type -> [Name]
freeVarsT :: Kind -> [Name]
freeVarsT (ForallT [TyVarBndr]
tvs [Kind]
_ Kind
ty) = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ((TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tyVarBndrName [TyVarBndr]
tvs)) (Kind -> [Name]
freeVarsT Kind
ty)
freeVarsT (VarT Name
n) = [Name
n]
freeVarsT Kind
ty = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Name]] -> [Name]) -> [[Name]] -> [Name]
forall a b. (a -> b) -> a -> b
$ (forall d. Data d => d -> [Name]) -> Kind -> [[Name]]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ ([Name] -> d -> [Name]
forall a b. a -> b -> a
const [] (d -> [Name]) -> (Kind -> [Name]) -> d -> [Name]
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` Kind -> [Name]
freeVarsT) Kind
ty
plainInstanceD :: Cxt -> Type -> [Dec] -> Dec
plainInstanceD :: [Kind] -> Kind -> [Dec] -> Dec
plainInstanceD =
#if MIN_VERSION_template_haskell(2,11,0)
Maybe Overlap -> [Kind] -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing
#else
InstanceD
#endif
fromPlainInstanceD :: Dec -> Maybe (Cxt, Type, [Dec])
#if MIN_VERSION_template_haskell(2,11,0)
fromPlainInstanceD :: Dec -> Maybe ([Kind], Kind, [Dec])
fromPlainInstanceD (InstanceD Maybe Overlap
_ [Kind]
a Kind
b [Dec]
c) = ([Kind], Kind, [Dec]) -> Maybe ([Kind], Kind, [Dec])
forall a. a -> Maybe a
Just ([Kind]
a, Kind
b, [Dec]
c)
#else
fromPlainInstanceD (InstanceD a b c) = Just (a, b, c)
#endif
fromPlainInstanceD Dec
_ = Maybe ([Kind], Kind, [Dec])
forall a. Maybe a
Nothing
typeRepToType :: TypeRep -> Q Type
typeRepToType :: TypeRep -> Q Kind
typeRepToType TypeRep
tr = do
let (TyCon
con, [TypeRep]
args) = TypeRep -> (TyCon, [TypeRep])
splitTyConApp TypeRep
tr
name :: Name
name = OccName -> NameFlavour -> Name
Name (String -> OccName
OccName (TyCon -> String
tyConName TyCon
con)) (NameSpace -> PkgName -> ModName -> NameFlavour
NameG NameSpace
TcClsName (String -> PkgName
PkgName (TyCon -> String
tyConPackage TyCon
con)) (String -> ModName
ModName (TyCon -> String
tyConModule TyCon
con)))
[Kind]
resultArgs <- (TypeRep -> Q Kind) -> [TypeRep] -> Q [Kind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeRep -> Q Kind
typeRepToType [TypeRep]
args
Kind -> Q Kind
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> [Kind] -> Kind
appsT (Name -> Kind
ConT Name
name) [Kind]
resultArgs)
data ExpLifter = ExpLifter
#if __GLASGOW_HASKELL__ >= 811
(forall m. Quote m => m Exp)
#else
ExpQ
#endif
deriving (Typeable)
instance Lift ExpLifter where
lift :: ExpLifter -> ExpQ
lift (ExpLifter ExpQ
e) = ExpQ
e
#if MIN_VERSION_template_haskell(2,16,0)
liftTyped :: ExpLifter -> Q (TExp ExpLifter)
liftTyped = String -> ExpLifter -> Q (TExp ExpLifter)
forall a. HasCallStack => String -> a
error (String -> ExpLifter -> Q (TExp ExpLifter))
-> String -> ExpLifter -> Q (TExp ExpLifter)
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"'liftTyped' is not implemented for 'ExpLifter', "
, String
"because it would require the generated code to have type 'ExpLifter'"
]
#endif
dumpSplices :: DecsQ -> DecsQ
dumpSplices :: DecsQ -> DecsQ
dumpSplices DecsQ
x = do
[Dec]
ds <- DecsQ
x
let code :: [String]
code = String -> [String]
lines ([Dec] -> String
forall a. Ppr a => a -> String
pprint [Dec]
ds)
String -> Q ()
reportWarning (String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
code))
[Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
ds