{-# LANGUAGE CPP #-}

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

module Unsafe.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 Name -> [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 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Type -> [Name]
typNames Type
typ
    RecGadtC [Name]
names [VarBangType]
vbts Type
typ -> [Name]
names [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Type -> [Name]
typNames Type
typ
         [Name] -> [Name] -> [Name]
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 (Dec -> [Name]) -> [Dec] -> [Name]
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 (Type -> [Name]) -> Cxt -> [Name]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Cxt
cxt) [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Type -> [Name]
typNames Type
typ [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ (Dec -> [Name]
decNames (Dec -> [Name]) -> [Dec] -> [Name]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Dec]
decs)
    SigD Name
name Type
typ -> Name
name Name -> [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 Name -> [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 Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Type -> [Name]
typNames Type
t
        ExportF Callconv
_ String
_ Name
name Type
t -> Name
name Name -> [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 (Con -> [Name]) -> [Con] -> [Name]
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  [Name] -> [Name] -> [Name]
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] [Name] -> [Name] -> [Name]
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 (TySynEqn -> [Name]) -> [TySynEqn] -> [Name]
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 (Type -> [Name]) -> Cxt -> [Name]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Cxt
cxt) [Name] -> [Name] -> [Name]
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 (Con -> [Name]) -> [Con] -> [Name]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Con]
cons) [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ (Type -> [Name]
predNames (Type -> [Name]) -> Cxt -> [Name]
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 (Type -> [Name]) -> Cxt -> [Name]
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 [Name] -> [Name] -> [Name]
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 (Type -> [Name]) -> Cxt -> [Name]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Cxt
c) [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Type -> [Name]
typNames Type
t
    AppT Type
s Type
t -> Type -> [Name]
typNames Type
s [Name] -> [Name] -> [Name]
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 Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Type -> [Name]
typNames Type
s [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Type -> [Name]
typNames Type
t
    UInfixT Type
s Name
n Type
t -> Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Type -> [Name]
typNames Type
s [Name] -> [Name] -> [Name]
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 [Name] -> [Name] -> [Name]
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 Type
s Name
n Type
t -> Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Type -> [Name]
typNames Type
s [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Type -> [Name]
typNames Type
t
    PromotedUInfixT Type
s Name
n Type
t -> Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Type -> [Name]
typNames Type
s [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Type -> [Name]
typNames Type
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 (Dec -> [Name]) -> [Dec] -> [Name]
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 Name -> [Name] -> [Name]
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 = [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub (Info -> [Name]
infoNames Info
info)
    case (Name -> Unlifted) -> [Name] -> [Name]
forall a. (a -> Unlifted) -> [a] -> [a]
filter (\ Name
n -> String
name String -> String -> Unlifted
forall a. Eq a => a -> a -> Unlifted
== Name -> String
nameBase Name
n Unlifted -> Unlifted -> Unlifted
|| String
name String -> String -> Unlifted
forall a. Eq a => a -> a -> Unlifted
== Name -> String
forall a. Show a => a -> String
show Name
n) [Name]
ns of
        [Name
n] -> Name -> Q Name
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
        [Name]
_ -> String -> Q Name
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"summon: you wanted " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", but I have:\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (String -> String -> String
forall a. [a] -> [a] -> [a]
(++) String
"        " (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
namespace (Name -> String) -> [Name] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
ns)
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    reify " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
thing String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" returned:\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Int -> Doc -> Doc
nest Int
8 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Info -> Doc
forall a. Ppr a => a -> Doc
ppr Info
info)
  where
    namespace :: Name -> String
namespace n :: Name
n@(Name OccName
_ NameFlavour
flavour) = Name -> String
forall a. Show a => a -> String
show Name
n String -> String -> String
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 ((Name, [String]) -> Q Exp)
-> (String -> Q (Name, [String])) -> String -> Q Exp
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 ((Name, [String]) -> Q Pat)
-> (String -> Q (Name, [String])) -> String -> Q Pat
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 ((Name, [String]) -> Q Type)
-> (String -> Q (Name, [String])) -> String -> Q Type
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
_ -> String -> Q [Dec]
forall a. String -> Q a
err String
"I'm not sure how this would work"
    } where
    err :: String -> Q a
err = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q a) -> (String -> String) -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
forall a. [a] -> [a] -> [a]
(++) String
"truename: "
    noPat :: [String] -> Q a
noPat = String -> Q a
forall a. String -> Q a
err (String -> Q a) -> ([String] -> String) -> [String] -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
forall a. [a] -> [a] -> [a]
(++) String
"unexpected pattern variables: " (String -> String) -> ([String] -> String) -> [String] -> String
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 Type -> Q () -> Q Type
forall a b. a -> Q b -> Q a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Unlifted -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Unlifted -> f () -> f ()
unless ([String] -> Unlifted
forall a. [a] -> Unlifted
forall (t :: * -> *) a. Foldable t => t a -> Unlifted
null [String]
vars) ([String] -> Q ()
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 Exp -> Q () -> Q Exp
forall a b. a -> Q b -> Q a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Unlifted -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Unlifted -> f () -> f ()
unless ([String] -> Unlifted
forall a. [a] -> Unlifted
forall (t :: * -> *) a. Foldable t => t a -> Unlifted
null [String]
vars) ([String] -> Q ()
forall {a}. [String] -> Q a
noPat [String]
vars)
        NameG NameSpace
DataName PkgName
_ ModName
_ -> case [String]
vars of
            [] -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
ConE Name
name)
            [String
".."] -> Name -> [FieldExp] -> Exp
RecConE Name
name ([FieldExp] -> Exp) -> ([Name] -> [FieldExp]) -> [Name] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Exp) -> [Name] -> [FieldExp]
forall {b}. (Name -> b) -> [Name] -> [(Name, b)]
capture Name -> Exp
VarE ([Name] -> Exp) -> Q [Name] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [Name]
recFields Name
name
            [String]
_ -> [String] -> Q Exp
forall {a}. [String] -> Q a
noPat [String]
vars
        NameFlavour
_ -> String -> Q Exp
forall a. String -> Q a
err (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ OccName -> String
occString OccName
occ String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has a strange flavour"
    makeP :: (Name, [String]) -> Q Pat
makeP (Name
name, [String]
vars) = if [String]
vars [String] -> [String] -> Unlifted
forall a. Eq a => a -> a -> Unlifted
== [String
".."]
            then Name -> [FieldPat] -> Pat
RecP Name
name ([FieldPat] -> Pat) -> ([Name] -> [FieldPat]) -> [Name] -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Pat) -> [Name] -> [FieldPat]
forall {b}. (Name -> b) -> [Name] -> [(Name, b)]
capture Name -> Pat
VarP ([Name] -> Pat) -> Q [Name] -> Q Pat
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)
              Pat -> Q Pat
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat -> Q Pat) -> Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Cxt -> [Pat] -> Pat
ConP Name
name [] ((String -> Pat) -> [String] -> [Pat]
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 = (Name -> (Name, b)) -> [Name] -> [(Name, b)]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> (Name, b)) -> [Name] -> [(Name, b)])
-> (Name -> (Name, b)) -> [Name] -> [(Name, b)]
forall a b. (a -> b) -> a -> b
$ \ Name
f -> (Name
f, Name -> b
v (String -> Name
mkName (String -> Name) -> String -> Name
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 Q Info -> (Info -> Q Name) -> Q Name
forall a b. Q a -> (a -> Q b) -> Q b
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 -> Name -> Q Name
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
p
#else
            DataConI _ _ p _ -> return p
#endif
            Info
_ -> String -> Q Name
forall a. String -> Q a
err (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Show a => a -> String
show Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a data constructor"
        Dec
dec <- Name -> Q Info
reify Name
parent Q Info -> (Info -> Q Dec) -> Q Dec
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Info
info -> case Info
info of
            TyConI Dec
d -> Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
d
            Info
_ -> String -> Q Dec
forall a. String -> Q a
err (String -> Q Dec) -> String -> Q Dec
forall a b. (a -> b) -> a -> b
$ String
"parent " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
parent String -> String -> String
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]
_ -> [Name] -> Q [Name]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Con -> [Name]
fields (Con -> [Name]) -> [Con] -> [Name]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Con]
cs)
            NewtypeD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Type
_ Con
c [DerivClause]
_ -> [Name] -> Q [Name]
forall a. a -> Q a
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
_ -> String -> Q [Name]
forall a. String -> Q a
err (String -> Q [Name]) -> String -> Q [Name]
forall a b. (a -> b) -> a -> b
$ String
"parent " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
parent String -> String -> String
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 Name -> Name -> Unlifted
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 Name -> [Name] -> Unlifted
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 -> String -> String -> Maybe Name -> Q Name
forall {a} {a}. Show a => a -> String -> Maybe a -> Q a
hmm String
s2 String
"lookupTypeName" (Maybe Name -> Q Name) -> Q (Maybe Name) -> Q Name
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Q (Maybe Name)
lookupTypeName String
s2
            String
_ -> String -> String -> Maybe Name -> Q Name
forall {a} {a}. Show a => a -> String -> Maybe a -> Q a
hmm String
s1 String
"lookupValueName" (Maybe Name -> Q Name) -> Q (Maybe Name) -> Q Name
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Q (Maybe Name)
lookupValueName String
s1
        String
_ -> String -> Q Name
forall a. String -> Q a
err (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"please specify either '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s0 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" or ''" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s0
      where
        hmm :: a -> String -> Maybe a -> Q a
hmm a
s String
l = Q a -> (a -> Q a) -> Maybe a -> Q a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Q a
forall a. String -> Q a
err (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
l, a -> String
forall a. Show a => a -> String
show a
s, String
"failed"]) a -> Q a
forall a. a -> Q a
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
        [] -> String -> Q (Name, [String])
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) = (String -> Unlifted) -> [String] -> ([String], [String])
forall a. (a -> Unlifted) -> [a] -> ([a], [a])
break (String
"|" String -> String -> Unlifted
forall a. Eq a => a -> a -> Unlifted
==) [String]
rest
            Name
name <- (Name -> String -> Q Name) -> Name -> [String] -> Q Name
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((String -> Name -> Q Name) -> Name -> String -> Q Name
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> Name -> Q Name
summon) Name
thing [String]
names
            (Name, [String]) -> Q (Name, [String])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, (String -> Unlifted) -> [String] -> [String]
forall a. (a -> Unlifted) -> [a] -> [a]
dropWhile (String
"|" String -> String -> Unlifted
forall a. Eq a => a -> a -> Unlifted
==) [String]
vars)
{- }}} -}