{-# LANGUAGE CPP #-}
module Data.Thyme.TrueName (summon, truename) where
import Prelude
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Monad
import Data.List (nub)
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.PprLib
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
conNames :: Con -> [Name]
conNames :: Con -> [Name]
conNames Con
con = case Con
con of
NormalC Name
name [BangType]
_ -> [Name
name]
RecC Name
name [VarBangType]
vbts -> Name
name forall a. a -> [a] -> [a]
: [ Name
fname | (Name
fname, Bang
_, Type
_) <- [VarBangType]
vbts ]
InfixC BangType
_ Name
name BangType
_ -> [Name
name]
ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
con' -> Con -> [Name]
conNames Con
con'
#if MIN_VERSION_template_haskell(2,11,0)
GadtC [Name]
names [BangType]
_ Type
typ -> [Name]
names forall a. [a] -> [a] -> [a]
++ Type -> [Name]
typNames Type
typ
RecGadtC [Name]
names [VarBangType]
vbts Type
typ -> [Name]
names forall a. [a] -> [a] -> [a]
++ Type -> [Name]
typNames Type
typ
forall a. [a] -> [a] -> [a]
++ [ Name
fname | (Name
fname, Bang
_, Type
_) <- [VarBangType]
vbts]
#endif
decNames :: Dec -> [Name]
decNames :: Dec -> [Name]
decNames Dec
dec = case Dec
dec of
FunD Name
_ [Clause]
_ -> []
ValD Pat
_ Body
_ [Dec]
_ -> []
TySynD Name
_ [TyVarBndr ()]
_ Type
typ -> Type -> [Name]
typNames Type
typ
ClassD Cxt
_ Name
_ [TyVarBndr ()]
_ [FunDep]
_ [Dec]
decs -> Dec -> [Name]
decNames forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Dec]
decs
#if MIN_VERSION_template_haskell(2,11,0)
InstanceD Maybe Overlap
_ Cxt
cxt Type
typ [Dec]
decs ->
#else
InstanceD cxt typ decs ->
#endif
(Type -> [Name]
predNames forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Cxt
cxt) forall a. [a] -> [a] -> [a]
++ Type -> [Name]
typNames Type
typ forall a. [a] -> [a] -> [a]
++ (Dec -> [Name]
decNames forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Dec]
decs)
SigD Name
name Type
typ -> Name
name forall a. a -> [a] -> [a]
: Type -> [Name]
typNames Type
typ
#if MIN_VERSION_template_haskell(2,16,0)
KiSigD Name
name Type
kind -> Name
name forall a. a -> [a] -> [a]
: Type -> [Name]
typNames Type
kind
#endif
ForeignD Foreign
frgn -> case Foreign
frgn of
ImportF Callconv
_ Safety
_ String
_ Name
name Type
t -> Name
name forall a. a -> [a] -> [a]
: Type -> [Name]
typNames Type
t
ExportF Callconv
_ String
_ Name
name Type
t -> Name
name forall a. a -> [a] -> [a]
: Type -> [Name]
typNames Type
t
PragmaD Pragma
_ -> []
#if MIN_VERSION_template_haskell(2,11,0)
DataD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Type
_ [Con]
cons [DerivClause]
_ -> Con -> [Name]
conNames forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Con]
cons
NewtypeD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Type
_ Con
con [DerivClause]
_ -> Con -> [Name]
conNames Con
con
#else
DataD _ _ _ cons _ -> conNames =<< cons
NewtypeD _ _ _ con _ -> conNames con
#endif
#if MIN_VERSION_template_haskell(2,12,0)
PatSynD Name
_name PatSynArgs
_args PatSynDir
_dir Pat
_pat -> []
PatSynSigD Name
_name Type
typ -> Type -> [Name]
typNames Type
typ
#endif
#if MIN_VERSION_template_haskell(2,8,0)
InfixD Fixity
_ Name
_ -> []
#endif
#if MIN_VERSION_template_haskell(2,12,0)
DataInstD Cxt
cxt Maybe [TyVarBndr ()]
_name Type
_typs Maybe Type
_kind [Con]
cons [DerivClause]
derivs ->
Cxt -> [Con] -> [Name]
datatypeNames Cxt
cxt [Con]
cons forall a. [a] -> [a] -> [a]
++ [DerivClause] -> [Name]
derivNames [DerivClause]
derivs
NewtypeInstD Cxt
cxt Maybe [TyVarBndr ()]
_name Type
_typs Maybe Type
_kind Con
con [DerivClause]
derivs ->
Cxt -> [Con] -> [Name]
datatypeNames Cxt
cxt [Con
con] forall a. [a] -> [a] -> [a]
++ [DerivClause] -> [Name]
derivNames [DerivClause]
derivs
#elif MIN_VERSION_template_haskell(2,11,0)
DataInstD cxt _ _ _ cons derivs ->
datatypeNames cxt cons ++ (predNames =<< derivs)
NewtypeInstD cxt _ _ _ con derivs ->
datatypeNames cxt [con] ++ (predNames =<< derivs)
#else
DataInstD cxt _ _ cons derivs -> datatypeNames cxt cons ++ derivs
NewtypeInstD cxt _ _ con derivs -> datatypeNames cxt [con] ++ derivs
#endif
#if MIN_VERSION_template_haskell(2,11,0)
DataFamilyD Name
_ [TyVarBndr ()]
_ Maybe Type
_ -> []
OpenTypeFamilyD TypeFamilyHead
_ -> []
#else
FamilyD _ _ _ _ -> []
#endif
#if MIN_VERSION_template_haskell(2,11,0)
ClosedTypeFamilyD TypeFamilyHead
_ [TySynEqn]
tses -> TySynEqn -> [Name]
tseNames forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [TySynEqn]
tses
#elif MIN_VERSION_template_haskell(2,9,0)
ClosedTypeFamilyD _ _ _ tses -> tseNames =<< tses
#endif
#if MIN_VERSION_template_haskell(2,15,0)
TySynInstD TySynEqn
tse -> TySynEqn -> [Name]
tseNames TySynEqn
tse
#elif MIN_VERSION_template_haskell(2,9,0)
TySynInstD _ tse -> tseNames tse
#else
TySynInstD _ ts t -> (typNames =<< ts) ++ typNames t
#endif
#if MIN_VERSION_template_haskell(2,9,0)
RoleAnnotD Name
_ [Role]
_ -> []
#endif
#if MIN_VERSION_template_haskell(2,12,0)
StandaloneDerivD Maybe DerivStrategy
_strat Cxt
cxt Type
typ -> (Type -> [Name]
predNames forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Cxt
cxt) forall a. [a] -> [a] -> [a]
++ Type -> [Name]
typNames Type
typ
#elif MIN_VERSION_template_haskell(2,10,0)
StandaloneDerivD cxt typ -> (predNames =<< cxt) ++ typNames typ
#endif
#if MIN_VERSION_template_haskell(2,10,0)
DefaultSigD Name
_ Type
_ -> []
#endif
#if MIN_VERSION_template_haskell(2,15,0)
ImplicitParamBindD String
_ Exp
_ -> []
#endif
datatypeNames :: Cxt -> [Con] -> [Name]
datatypeNames :: Cxt -> [Con] -> [Name]
datatypeNames Cxt
cxt [Con]
cons = (Con -> [Name]
conNames forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Con]
cons) forall a. [a] -> [a] -> [a]
++ (Type -> [Name]
predNames forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Cxt
cxt)
#if MIN_VERSION_template_haskell(2,12,0)
derivNames :: [DerivClause] -> [Name]
derivNames :: [DerivClause] -> [Name]
derivNames [DerivClause]
derivs = Type -> [Name]
predNames forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
[ Type
p | DerivClause Maybe DerivStrategy
_strat Cxt
cxt <- [DerivClause]
derivs, Type
p <- Cxt
cxt ]
#endif
tseNames :: TySynEqn -> [Name]
#if MIN_VERSION_template_haskell(2,15,0)
tseNames :: TySynEqn -> [Name]
tseNames (TySynEqn Maybe [TyVarBndr ()]
_ Type
l Type
r) = Type -> [Name]
typNames Type
l forall a. [a] -> [a] -> [a]
++ Type -> [Name]
typNames Type
r
#elif MIN_VERSION_template_haskell(2,9,0)
tseNames (TySynEqn ts t) = (typNames =<< ts) ++ typNames t
#endif
predNames :: Pred -> [Name]
#if MIN_VERSION_template_haskell(2,10,0)
predNames :: Type -> [Name]
predNames = Type -> [Name]
typNames
#else
predNames p = case p of
ClassP n ts -> n : (typNames =<< ts)
EqualP s t -> typNames s ++ typNames t
#endif
typNames :: Type -> [Name]
typNames :: Type -> [Name]
typNames Type
typ = case Type
typ of
ForallT [TyVarBndr Specificity]
_ Cxt
c Type
t -> (Type -> [Name]
predNames forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Cxt
c) forall a. [a] -> [a] -> [a]
++ Type -> [Name]
typNames Type
t
AppT Type
s Type
t -> Type -> [Name]
typNames Type
s forall a. [a] -> [a] -> [a]
++ Type -> [Name]
typNames Type
t
SigT Type
t Type
_ -> Type -> [Name]
typNames Type
t
VarT Name
_ -> []
ConT Name
name -> [Name
name]
TupleT Int
_ -> []
UnboxedTupleT Int
_ -> []
Type
ArrowT -> []
Type
ListT -> []
#if MIN_VERSION_template_haskell(2,8,0)
PromotedT Name
_ -> []
PromotedTupleT Int
_ -> []
Type
PromotedNilT -> []
Type
PromotedConsT -> []
Type
StarT -> []
Type
ConstraintT -> []
LitT TyLit
_ -> []
#endif
#if MIN_VERSION_template_haskell(2,10,0)
Type
EqualityT -> []
#endif
#if MIN_VERSION_template_haskell(2,11,0)
InfixT Type
s Name
n Type
t -> Name
n forall a. a -> [a] -> [a]
: Type -> [Name]
typNames Type
s forall a. [a] -> [a] -> [a]
++ Type -> [Name]
typNames Type
t
UInfixT Type
s Name
n Type
t -> Name
n forall a. a -> [a] -> [a]
: Type -> [Name]
typNames Type
s forall a. [a] -> [a] -> [a]
++ Type -> [Name]
typNames Type
t
ParensT Type
t -> Type -> [Name]
typNames Type
t
Type
WildCardT -> []
#endif
#if MIN_VERSION_template_haskell(2,12,0)
UnboxedSumT Int
_arity -> []
#endif
#if MIN_VERSION_template_haskell(2,15,0)
AppKindT Type
k Type
t -> Type -> [Name]
typNames Type
k forall a. [a] -> [a] -> [a]
++ Type -> [Name]
typNames Type
t
ImplicitParamT String
_ Type
t -> Type -> [Name]
typNames Type
t
#endif
#if MIN_VERSION_template_haskell(2,16,0)
ForallVisT [TyVarBndr ()]
_ Type
t -> Type -> [Name]
typNames Type
t
#endif
#if MIN_VERSION_template_haskell(2,17,0)
Type
MulArrowT -> []
#endif
#if MIN_VERSION_template_haskell(2,19,0)
PromotedInfixT s n t -> n : typNames s ++ typNames t
PromotedUInfixT s n t -> n : typNames s ++ typNames t
#endif
infoNames :: Info -> [Name]
infoNames :: Info -> [Name]
infoNames Info
info = case Info
info of
ClassI Dec
dec [Dec]
_ -> Dec -> [Name]
decNames Dec
dec
TyConI Dec
dec -> Dec -> [Name]
decNames Dec
dec
FamilyI Dec
_ [Dec]
decs -> Dec -> [Name]
decNames forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Dec]
decs
PrimTyConI Name
_ Int
_ Unlifted
_ -> []
TyVarI Name
_ Type
typ -> Type -> [Name]
typNames Type
typ
#if MIN_VERSION_template_haskell(2,11,0)
ClassOpI Name
_ Type
typ Name
_ -> Type -> [Name]
typNames Type
typ
DataConI Name
_ Type
typ Name
parent -> Name
parent forall a. a -> [a] -> [a]
: Type -> [Name]
typNames Type
typ
VarI Name
_ Type
typ Maybe Dec
_ -> Type -> [Name]
typNames Type
typ
#else
ClassOpI _ typ _ _ -> typNames typ
DataConI _ typ parent _ -> parent : typNames typ
VarI _ typ _ _ -> typNames typ
#endif
#if MIN_VERSION_template_haskell(2,12,0)
PatSynI Name
_name Type
typ -> Type -> [Name]
typNames Type
typ
#endif
summon :: String -> Name -> Q Name
summon :: String -> Name -> Q Name
summon String
name Name
thing = do
Info
info <- Name -> Q Info
reify Name
thing
let ns :: [Name]
ns = forall a. Eq a => [a] -> [a]
nub (Info -> [Name]
infoNames Info
info)
case forall a. (a -> Unlifted) -> [a] -> [a]
filter (\ Name
n -> String
name forall a. Eq a => a -> a -> Unlifted
== Name -> String
nameBase Name
n Unlifted -> Unlifted -> Unlifted
|| String
name forall a. Eq a => a -> a -> Unlifted
== forall a. Show a => a -> String
show Name
n) [Name]
ns of
[Name
n] -> forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
[Name]
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"summon: you wanted " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
name forall a. [a] -> [a] -> [a]
++ String
", but I have:\n"
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (forall a. [a] -> [a] -> [a]
(++) String
" " forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
namespace forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
ns)
forall a. [a] -> [a] -> [a]
++ String
" reify " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
thing forall a. [a] -> [a] -> [a]
++ String
" returned:\n"
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int -> Doc -> Doc
nest Int
8 forall a b. (a -> b) -> a -> b
$ forall a. Ppr a => a -> Doc
ppr Info
info)
where
namespace :: Name -> String
namespace n :: Name
n@(Name OccName
_ NameFlavour
flavour) = forall a. Show a => a -> String
show Name
n forall a. [a] -> [a] -> [a]
++ case NameFlavour
flavour of
NameG NameSpace
VarName PkgName
_ ModName
_ -> String
" (var)"
NameG NameSpace
DataName PkgName
_ ModName
_ -> String
" (cons)"
NameG NameSpace
TcClsName PkgName
_ ModName
_ -> String
" (type)"
NameFlavour
_ -> String
" (?)"
truename :: QuasiQuoter
truename :: QuasiQuoter
truename = QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = (Name, [String]) -> Q Exp
makeE forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Q (Name, [String])
nameVars
, quotePat :: String -> Q Pat
quotePat = (Name, [String]) -> Q Pat
makeP forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Q (Name, [String])
nameVars
, quoteType :: String -> Q Type
quoteType = (Name, [String]) -> Q Type
makeT forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Q (Name, [String])
nameVars
, quoteDec :: String -> Q [Dec]
quoteDec = \ String
_ -> forall {a}. String -> Q a
err String
"I'm not sure how this would work"
} where
err :: String -> Q a
err = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a] -> [a]
(++) String
"truename: "
noPat :: [String] -> Q a
noPat = forall {a}. String -> Q a
err forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a] -> [a]
(++) String
"unexpected pattern variables: " forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords
makeT :: (Name, [String]) -> Q Type
makeT (Name
name, [String]
vars) = Name -> Type
ConT Name
name forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Applicative f => Unlifted -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Unlifted
null [String]
vars) (forall {a}. [String] -> Q a
noPat [String]
vars)
makeE :: (Name, [String]) -> Q Exp
makeE (name :: Name
name@(Name OccName
occ NameFlavour
flavour), [String]
vars) = case NameFlavour
flavour of
NameG NameSpace
VarName PkgName
_ ModName
_ -> Name -> Exp
VarE Name
name forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Applicative f => Unlifted -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Unlifted
null [String]
vars) (forall {a}. [String] -> Q a
noPat [String]
vars)
NameG NameSpace
DataName PkgName
_ ModName
_ -> case [String]
vars of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
ConE Name
name)
[String
".."] -> Name -> [FieldExp] -> Exp
RecConE Name
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. (Name -> b) -> [Name] -> [(Name, b)]
capture Name -> Exp
VarE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [Name]
recFields Name
name
[String]
_ -> forall {a}. [String] -> Q a
noPat [String]
vars
NameFlavour
_ -> forall {a}. String -> Q a
err forall a b. (a -> b) -> a -> b
$ OccName -> String
occString OccName
occ forall a. [a] -> [a] -> [a]
++ String
" has a strange flavour"
makeP :: (Name, [String]) -> Q Pat
makeP (Name
name, [String]
vars) = if [String]
vars forall a. Eq a => a -> a -> Unlifted
== [String
".."]
then Name -> [FieldPat] -> Pat
RecP Name
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. (Name -> b) -> [Name] -> [(Name, b)]
capture Name -> Pat
VarP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [Name]
recFields Name
name
else
#if MIN_VERSION_template_haskell(2,18,0)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Cxt -> [Pat] -> Pat
ConP Name
name [] (forall a b. (a -> b) -> [a] -> [b]
map String -> Pat
pat [String]
vars) where
#else
return $ ConP name (map pat vars) where
#endif
pat :: String -> Pat
pat String
n = case String
n of
String
"_" -> Pat
WildP
Char
'!' : String
ns -> Pat -> Pat
BangP (String -> Pat
pat String
ns)
Char
'~' : String
ns -> Pat -> Pat
TildeP (String -> Pat
pat String
ns)
String
_ -> Name -> Pat
VarP (String -> Name
mkName String
n)
capture :: (Name -> b) -> [Name] -> [(Name, b)]
capture Name -> b
v = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ \ Name
f -> (Name
f, Name -> b
v (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
f))
recFields :: Name -> Q [Name]
recFields :: Name -> Q [Name]
recFields Name
name = do
Name
parent <- Name -> Q Info
reify Name
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Info
info -> case Info
info of
#if MIN_VERSION_template_haskell(2,11,0)
DataConI Name
_ Type
_ Name
p -> forall (m :: * -> *) a. Monad m => a -> m a
return Name
p
#else
DataConI _ _ p _ -> return p
#endif
Info
_ -> forall {a}. String -> Q a
err forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Name
name forall a. [a] -> [a] -> [a]
++ String
" is not a data constructor"
Dec
dec <- Name -> Q Info
reify Name
parent forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Info
info -> case Info
info of
TyConI Dec
d -> forall (m :: * -> *) a. Monad m => a -> m a
return Dec
d
Info
_ -> forall {a}. String -> Q a
err forall a b. (a -> b) -> a -> b
$ String
"parent " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
parent forall a. [a] -> [a] -> [a]
++ String
" is not a plain type"
case Dec
dec of
#if MIN_VERSION_template_haskell(2,11,0)
DataD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Type
_ [Con]
cs [DerivClause]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (Con -> [Name]
fields forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Con]
cs)
NewtypeD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Type
_ Con
c [DerivClause]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (Con -> [Name]
fields Con
c)
#else
DataD _ _ _ cs _ -> return (fields =<< cs)
NewtypeD _ _ _ c _ -> return (fields c)
#endif
Dec
_ -> forall {a}. String -> Q a
err forall a b. (a -> b) -> a -> b
$ String
"parent " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
parent forall a. [a] -> [a] -> [a]
++ String
" neither data nor newtype"
where
fields :: Con -> [Name]
fields :: Con -> [Name]
fields Con
con = case Con
con of
NormalC Name
_ [BangType]
_ -> []
RecC Name
n [VarBangType]
vbts -> if Name
n forall a. Eq a => a -> a -> Unlifted
/= Name
name then [] else [ Name
v | (Name
v, Bang
_, Type
_) <- [VarBangType]
vbts ]
InfixC BangType
_ Name
_ BangType
_ -> []
ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
c -> Con -> [Name]
fields Con
c
#if MIN_VERSION_template_haskell(2,11,0)
GadtC [Name]
_ [BangType]
_ Type
_ -> []
RecGadtC [Name]
ns [VarBangType]
vbts Type
_ -> if Name
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Unlifted
`notElem` [Name]
ns then []
else [ Name
v | (Name
v, Bang
_, Type
_) <- [VarBangType]
vbts ]
#endif
lookupThing :: String -> Q Name
lookupThing :: String -> Q Name
lookupThing String
s0 = case String
s0 of
Char
'\'' : String
s1 -> case String
s1 of
Char
'\'' : String
s2 -> forall {a} {a}. Show a => a -> String -> Maybe a -> Q a
hmm String
s2 String
"lookupTypeName" forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Q (Maybe Name)
lookupTypeName String
s2
String
_ -> forall {a} {a}. Show a => a -> String -> Maybe a -> Q a
hmm String
s1 String
"lookupValueName" forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Q (Maybe Name)
lookupValueName String
s1
String
_ -> forall {a}. String -> Q a
err forall a b. (a -> b) -> a -> b
$ String
"please specify either '" forall a. [a] -> [a] -> [a]
++ String
s0 forall a. [a] -> [a] -> [a]
++ String
" or ''" forall a. [a] -> [a] -> [a]
++ String
s0
where
hmm :: a -> String -> Maybe a -> Q a
hmm a
s String
l = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall {a}. String -> Q a
err forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
l, forall a. Show a => a -> String
show a
s, String
"failed"]) forall (m :: * -> *) a. Monad m => a -> m a
return
nameVars :: String -> Q (Name, [String])
nameVars :: String -> Q (Name, [String])
nameVars String
spec = case String -> [String]
words String
spec of
[] -> forall {a}. String -> Q a
err String
"expecting at least one token"
String
start : [String]
rest -> do
Name
thing <- String -> Q Name
lookupThing String
start
let ([String]
names, [String]
vars) = forall a. (a -> Unlifted) -> [a] -> ([a], [a])
break (String
"|" forall a. Eq a => a -> a -> Unlifted
==) [String]
rest
Name
name <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> Name -> Q Name
summon) Name
thing [String]
names
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, forall a. (a -> Unlifted) -> [a] -> [a]
dropWhile (String
"|" forall a. Eq a => a -> a -> Unlifted
==) [String]
vars)