{-# LANGUAGE CPP #-}

-- | Refer to <https://github.com/liyang/true-name/blob/master/test/sanity.hs these examples>.

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
{- }}} -}

{- {{{ -}
-- | Summons a 'Name' using @template-haskell@'s 'reify' function.
--
-- The first argument is a 'String' matching the 'Name' we want: either its
-- 'nameBase', or qualified with its module. The second argument gives the
-- 'Name' to 'reify'.
--
-- If no match is found or there is some ambiguity, 'summon' will fail with
-- a list of 'Name's found, along with the output of 'reify' for reference.
--
-- Suppose we are given a module @M@ that exports a function @s@, but not
-- the type @T@, the constrcutor @C@, nor the field @f@:
--
-- > module M (s) where
-- > newtype T = C { f :: Int }
-- > s :: T -> T
-- > s = C . succ . f
--
-- In our own module we have no legitimate way of passing @s@ an argument of
-- type @T@. We can get around this in a type-safe way with 'summon':
--
-- >{-# LANGUAGE TemplateHaskell #-}
-- >module Main where
-- >import Language.Haskell.TH.Syntax
-- >import Unsafe.TrueName
-- >import M
-- >
-- >type T = $(fmap ConT $ summon "T" 's)
-- >mkC :: Int -> T; unC :: T -> Int; f :: T -> Int
-- >mkC = $(fmap ConE $ summon "C" =<< summon "T" 's)
-- >unC $(fmap (`ConP` [VarP $ mkName "n"]) $ summon "C" =<< summon "T" 's) = n
-- >f = $(fmap VarE $ summon "f" =<< summon "T" 's)
-- >
-- >main :: IO ()
-- >main = print (unC t, n) where
-- >    t = s (mkC 42 :: T)
-- >    n = f (s t)
--
-- Note that 'summon' cannot obtain the 'Name' for an unexported function,
-- since GHC <http://hackage.haskell.org/package/template-haskell/docs/Language-Haskell-TH.html#v:VarI does not currently return the RHS of function definitons>.
-- The only workaround is to copypasta the definition. D:
{- }}} -}
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
" (?)"
{- }}} -}

{- {{{ -}
-- | A more convenient 'QuasiQuoter' interface to 'summon'.
--
-- The first space-delimited token gives the initial 'Name' passed to
-- 'summon': it must be ‘quoted’ with a @'@ or @''@ prefix to indicate
-- whether it should be interpreted in an expression or a type context,
-- as per <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/template-haskell.html#th-syntax the usual TH syntax>.
-- Subsequent tokens correspond to the 'String' argument of 'summon', and
-- are iterated over. Thus
--
-- > [truename| ''A B C D |]
--
-- is roughly equivalent to:
--
-- > summon "D" =<< summon "C" =<< summon "B" ''A
--
-- but with the resulting 'Name' wrapped up in 'ConE', 'VarE', 'ConP', or
-- 'ConT', depending on the context. (There is no 'quoteDec'.)
--
-- Variable bindings are given after a @|@ token in a 'Pat' context:
--
-- > [truename| ''Chan Chan | chanR chanW |] <- newChan
--
-- These may be prefixed with @!@ or @~@ to give the usual semantics.
-- A single @..@ token invokes @RecordWildCards@ in 'Pat' contexts, and for
-- record construction in 'Exp' contexts.
-- Nested or more exotic patterns are not supported.
--
-- With this, the example from 'summon' may be more succinctly written:
--
-- >{-# LANGUAGE QuasiQuotes #-}
-- >module Main where
-- >import Unsafe.TrueName
-- >import M
-- >
-- >type T = [truename| 's T |]
-- >mkC :: Int -> T; unC :: T -> Int; f :: T -> Int
-- >mkC = [truename| 's T C |]
-- >unC [truename| 's T C | n |] = n
-- >f = [truename| 's T f |]
-- >
-- >main :: IO ()
-- >main = print (unC t, n) where
-- >    t = s (mkC 42 :: T)
-- >    n = f (s t)
{- }}} -}
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)
{- }}} -}