{-# LANGUAGE BangPatterns         #-}
{-# LANGUAGE CPP                  #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE MagicHash            #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE TypeSynonymInstances #-}

#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE EmptyCase            #-}
#endif

{-|
Module:      Language.Haskell.TH.Lift.Generics
Copyright:   (C) 2015-2017 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott

"GHC.Generics"-based approach to implementing `lift`. Different sets of
functions are available for use with different GHC and @template-haskell@
versions.

=== General recommendations

* If you only need to support GHC 8.0 (@base@ 4.9.0) and later, then you may
either use the \"friendly\" functions here or skip this package entirely and use
the built-in `DeriveLift` mechanism, which has the advantage of working for
GADTs and existential types.

* If you only need to support GHC 7.4 (@base@ 4.5) and later, and you have
'Typeable' instances for the relevant type constructors (or can derive them),
then you should use the \"friendly\" functions here.

* If you must support GHC versions before 7.4 (@base@ 4.5), or types in other
packages without 'Typeable' instances, then you should seriously consider using
the
<https://hackage.haskell.org/package/th-lift th-lift>
package to derive 'Lift' instances. If you choose to continue with this package:

    * If you have 'Typeable' instances, then you should use the \"less friendly\"
    functions here. These take an argument for the package name, but they ignore it
    (acting just like the friendly ones) for GHC 7.4 (@base@ 4.5) and later.

    * If you lack a 'Typeable' instance for a type constructor, then you'll
    need to use the \"unfriendly\" functions. These rely solely on the
    user-provided package name. On GHC 7.10, it is extremely difficult to
    obtain the correct package name for an external package.

=== A note on 'Typeable' constraints

For relevant versions, the \"friendly\" and \"less friendly\" functions require
the type to satisfy an @OuterTypeable@ constraint.  A type is @OuterTypable@ if
its /type constructor/ (applied to any /kind/ arguments) is 'Typeable'. For
example, @'Maybe' a@ is only 'Typeable' if @a@ is 'Typeable', but it is always
@OuterTypeable@. For @'Control.Applicative.Const' a b@ to be 'OuterTypeable',
the /kinds/ of @a@ and @b@ must be 'Typeable'.

Before GHC 7.8, 'Typeable' can only be derived for types with seven
or fewer parameters, all of kind @*@. Types with more parameters that
manually instantiate the now-defunct @Typeable7@ class should work,
but there may be some loss of polymorphism in the first arguments.
Types whose 'Typeable' instances can't be derived because of kind issues
will not work with these GHC versions.
-}
module Language.Haskell.TH.Lift.Generics (
#if MIN_VERSION_base(4,5,0)
    -- * Friendly "GHC.Generics"-based 'lift' implementations
    --
    -- $friendlyFunctions
      genericLift
# if MIN_VERSION_template_haskell(2,9,0)
    , genericLiftTyped
    , genericLiftTypedTExp
    , genericLiftTypedCompat
# endif
    ,
#endif

    -- * Less friendly and unfriendly "GHC.Generics"-based 'lift'
    -- implementations
    --
    -- $lessFriendlyFunctions

    -- ** Less friendly implementations
    --
    -- | These implementations should be used when support for versions
    -- before GHC 7.4 (@base@ 4.5) is required, but a 'Data.Typeable.Typeable'
    -- instance is available. The 'Data.Typeable.Typeable' instance will be used
    -- to get the package name for GHC 7.4 and later.
      genericLiftWithPkgFallback
#if MIN_VERSION_template_haskell(2,9,0)
    , genericLiftTypedWithPkgFallback
    , genericLiftTypedTExpWithPkgFallback
    , genericLiftTypedCompatWithPkgFallback
#endif

    -- ** Unfriendly implementations
    --
    -- | These implementations should be used when support for versions
    -- before GHC 8.0 (@base@ 4.9) is required and a 'Data.Typeable.Typeable' instance
    -- is /not/ available. These functions are termed "unfriendly" because
    -- they're extremely hard to use under GHC 7.10 when working with types
    -- defined in other packages. The only way to do so is to use a 'Typeable'
    -- type in the same package to get the \"package name\", which will be a
    -- hash value.
    , genericLiftWithPkg
#if MIN_VERSION_template_haskell(2,9,0)
    , genericLiftTypedWithPkg
    , genericLiftTypedTExpWithPkg
    , genericLiftTypedCompatWithPkg
#endif
    -- * 'Generic' classes
    --
    -- | You shouldn't need to use any of these
    -- classes directly; they are only exported for educational purposes.
    , GLift(..)
    , GLiftDatatype(..)
    , GLiftArgs(..)
    -- * 'Lift' reexport
    , Lift(..)
    ) where

#if MIN_VERSION_base(4,5,0) && !MIN_VERSION_base(4,9,0)
import Language.Haskell.TH.Lift.Generics.Internal.OuterTypeable
#endif

import Control.Monad (liftM, (>=>))

import Generics.Deriving

import GHC.Base (unpackCString#)
import GHC.Exts (Double(..), Float(..), Int(..), Word(..))
#if __GLASGOW_HASKELL__ < 708
import GHC.Conc (pseq)
#endif

import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Syntax.Compat

#if MIN_VERSION_template_haskell(2,8,0)
import Data.Char (ord)
import Data.Word (Word8)
#endif

#if MIN_VERSION_template_haskell(2,11,0)
import GHC.Exts (Char(..))
#endif

#if MIN_VERSION_base(4,5,0) && !MIN_VERSION_base(4,9,0)
import qualified Data.Typeable as T
#endif

#if MIN_VERSION_base(4,5,0) && !MIN_VERSION_base(4,9,0)
import Data.Proxy (Proxy (..))
#endif

-- We don't want to expand this in the Haddocks!
#undef CURRENT_PACKAGE_KEY

-- $lessFriendlyFunctions
--
-- API limitations of early versions of GHC (7.2 and earlier) require the user
-- to produce the package name themselves. This is also occasionally necessary
-- for later versions of GHC when dealing with types from other packages that
-- lack 'Data.Typeable.Typeable' instances. The package name isn't always as easy to come
-- up with as it sounds, especially because GHC 7.10 uses a hashed package ID
-- for that name. To make things worse, if you produce the wrong package name,
-- you might get bizarre compilation errors!
--
-- There's no need to fear, though—in most cases it's possible to obtain the
-- correct package name anyway, at least for types defined /in the current package/.
-- When compiling a library with @Cabal@, the current package
-- name is obtained using the CPP macro @CURRENT_PACKAGE_KEY@. When compiling
-- an application, or compiling without Cabal, it takes a bit more work to get
-- the name. The code sample below shows an example of how to
-- properly use 'genericLiftWithPkgFallback' or 'genericLiftWithPkg' without
-- shooting yourself in the foot:
--
-- @
-- &#123;-&#35; LANGUAGE CPP, DeriveGeneric, DeriveDataTypeable &#35;-&#125;
-- -- part of package foobar
-- module Foo where
--
-- import GHC.Generics
-- import Data.Typeable
-- import Language.Haskell.Lift.Generics
--
-- &#35;ifndef CURRENT_PACKAGE_KEY
-- import Data.Version (showVersion)
-- import Paths_foobar (version)
-- &#35;endif
--
-- pkgName :: String
-- &#35;ifdef CURRENT_PACKAGE_KEY
-- pkgName = CURRENT_PACKAGE_KEY
-- &#35;else
-- pkgName = "foobar-" ++ showVersion version
-- &#35;endif
--
-- data Foo = Foo Int Char String
--   deriving (Generic, Typeable)
--
-- instance Lift Foo where
--   lift = genericLiftWithPkgFallback pkgName
-- &#35;if MIN&#95;VERSION&#95;template_haskell(2,9,0)
--   liftTyped = genericLiftTypedCompatWithPkgFallback pkgName
-- &#35;endif
-- @
--
-- As you can see, this trick only works if (1) the current package key is known
-- (i.e., the 'Lift' instance is defined in the same package as the datatype), or
-- (2) you're dealing with a package that has a fixed package name (e.g., @base@,
-- @ghc-prim@, @template-haskell@, etc.).
--
-- Once the @Lift Foo@ instance is defined, you can splice @Foo@ values directly
-- into Haskell source code:
--
-- @
-- &#123;-&#35; LANGUAGE TemplateHaskell &#35;-&#125;
-- module Bar where
--
-- import Foo
-- import Language.Haskell.TH.Syntax
--
-- foo :: Foo
-- foo = $(lift (Foo 1 \'a\' \"baz\"))
-- @

-- | Generically produce an implementation of 'lift', given a user-provided
-- (but correct!) package name. The provided package name is ignored for
-- GHC 7.4 (@base@ 4.5) and later.
--
-- === Note
--
-- A @'Data.Typeable.Typeable' a@ instance is required for 7.4 <= GHC < 8.0 (4.5 <= @base@ < 4.9).
--
-- @since 0.2.1
#if MIN_VERSION_base (4,9,0) || !MIN_VERSION_base (4,5,0)
genericLiftWithPkgFallback :: (Quote m, Generic a, GLift (Rep a)) => String -> a -> m Exp
#else
genericLiftWithPkgFallback :: (Quote m, Generic a, GLift (Rep a), OuterTypeable a) => String -> a -> m Exp
#endif
#if MIN_VERSION_base(4,5,0)
genericLiftWithPkgFallback :: String -> a -> m Exp
genericLiftWithPkgFallback String
_pkg = a -> m Exp
forall (m :: * -> *) a.
(Quote m, Generic a, GLift (Rep a)) =>
a -> m Exp
genericLift
#else
genericLiftWithPkgFallback = genericLiftWithPkg
#endif

#if MIN_VERSION_template_haskell(2,9,0)
-- | Like 'genericLiftWithPkgFallback', but returns a 'Code' instead of an 'Exp'.
--
-- @since 0.2.1
# if MIN_VERSION_base (4,9,0) || !MIN_VERSION_base (4,5,0)
genericLiftTypedWithPkgFallback :: (Quote m, Generic a, GLift (Rep a)) => String -> a -> Code m a
# else
genericLiftTypedWithPkgFallback :: (Quote m, Generic a, GLift (Rep a), OuterTypeable a) => String -> a -> Code m a
# endif
# if MIN_VERSION_base(4,5,0)
genericLiftTypedWithPkgFallback :: String -> a -> Code m a
genericLiftTypedWithPkgFallback String
_pkg = a -> Code m a
forall (m :: * -> *) a.
(Quote m, Generic a, GLift (Rep a)) =>
a -> Code m a
genericLiftTyped
# else
genericLiftTypedWithPkgFallback = genericLiftTypedWithPkg
# endif

-- | Like 'genericLiftWithPkgFallback', but returns a 'TExp' instead of an 'Exp'.
--
-- @since 0.2.1
# if MIN_VERSION_base (4,9,0) || !MIN_VERSION_base (4,5,0)
genericLiftTypedTExpWithPkgFallback :: (Quote m, Generic a, GLift (Rep a)) => String -> a -> m (TExp a)
# else
genericLiftTypedTExpWithPkgFallback :: (Quote m, Generic a, GLift (Rep a), OuterTypeable a) => String -> a -> m (TExp a)
# endif
# if MIN_VERSION_base(4,5,0)
genericLiftTypedTExpWithPkgFallback :: String -> a -> m (TExp a)
genericLiftTypedTExpWithPkgFallback String
_pkg = a -> m (TExp a)
forall (m :: * -> *) a.
(Quote m, Generic a, GLift (Rep a)) =>
a -> m (TExp a)
genericLiftTypedTExp
# else
genericLiftTypedTExpWithPkgFallback = genericLiftTypedTExpWithPkg
# endif

-- | Like 'genericLiftWithPkg', but returns:
--
-- * A 'Code' (if using @template-haskell-2.17.0.0@ or later), or
-- * A 'TExp' (if using an older version of @template-haskell@)
--
-- This function is ideal for implementing the 'liftTyped' method of 'Lift'
-- directly, as its type changed in @template-haskell-2.17.0.0@.
--
-- @since 0.2.1
# if MIN_VERSION_base (4,9,0) || !MIN_VERSION_base (4,5,0)
genericLiftTypedCompatWithPkgFallback :: (Quote m, Generic a, GLift (Rep a)) => String -> a -> Splice m a
# else
genericLiftTypedCompatWithPkgFallback :: (Quote m, Generic a, GLift (Rep a), OuterTypeable a) => String -> a -> Splice m a
# endif
# if MIN_VERSION_template_haskell(2,17,0)
genericLiftTypedCompatWithPkgFallback = genericLiftTypedWithPkgFallback
# else
genericLiftTypedCompatWithPkgFallback :: String -> a -> Splice m a
genericLiftTypedCompatWithPkgFallback = String -> a -> Splice m a
forall (m :: * -> *) a.
(Quote m, Generic a, GLift (Rep a)) =>
String -> a -> m (TExp a)
genericLiftTypedTExpWithPkgFallback
# endif
#endif

-- ---

-- | Generically produce an implementation of 'lift', given a user-provided
-- (but correct!) package name. The provided package name is ignored for
-- GHC 8.0 (@base@ 4.9) and later.
genericLiftWithPkg :: (Quote m, Generic a, GLift (Rep a)) => String -> a -> m Exp
genericLiftWithPkg :: String -> a -> m Exp
genericLiftWithPkg String
pkg = String -> Rep a Any -> m Exp
forall (f :: * -> *) (m :: * -> *) a.
(GLift f, Quote m) =>
String -> f a -> m Exp
glift String
pkg (Rep a Any -> m Exp) -> (a -> Rep a Any) -> a -> m Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from

#if MIN_VERSION_template_haskell(2,9,0)
-- | Like 'genericLiftWithPkg', but returns a 'Code' instead of an 'Exp'.
genericLiftTypedWithPkg :: (Quote m, Generic a, GLift (Rep a)) => String -> a -> Code m a
genericLiftTypedWithPkg :: String -> a -> Code m a
genericLiftTypedWithPkg String
pkg = m Exp -> Code m a
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (m Exp -> Code m a) -> (a -> m Exp) -> a -> Code m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a -> m Exp
forall (m :: * -> *) a.
(Quote m, Generic a, GLift (Rep a)) =>
String -> a -> m Exp
genericLiftWithPkg String
pkg

-- | Like 'genericLiftWithPkg', but returns a 'TExp' instead of an 'Exp'.
genericLiftTypedTExpWithPkg :: (Quote m, Generic a, GLift (Rep a)) => String -> a -> m (TExp a)
genericLiftTypedTExpWithPkg :: String -> a -> m (TExp a)
genericLiftTypedTExpWithPkg String
pkg = m Exp -> m (TExp a)
forall a (m :: * -> *). Quote m => m Exp -> m (TExp a)
unsafeTExpCoerceQuote (m Exp -> m (TExp a)) -> (a -> m Exp) -> a -> m (TExp a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a -> m Exp
forall (m :: * -> *) a.
(Quote m, Generic a, GLift (Rep a)) =>
String -> a -> m Exp
genericLiftWithPkg String
pkg

-- | Like 'genericLiftWithPkg', but returns:
--
-- * A 'Code' (if using @template-haskell-2.17.0.0@ or later), or
-- * A 'TExp' (if using an older version of @template-haskell@)
--
-- This function is ideal for implementing the 'liftTyped' method of 'Lift'
-- directly, as its type changed in @template-haskell-2.17.0.0@.
genericLiftTypedCompatWithPkg :: (Quote m, Generic a, GLift (Rep a)) => String -> a -> Splice m a
# if MIN_VERSION_template_haskell(2,17,0)
genericLiftTypedCompatWithPkg = genericLiftTypedWithPkg
# else
genericLiftTypedCompatWithPkg :: String -> a -> Splice m a
genericLiftTypedCompatWithPkg = String -> a -> Splice m a
forall (m :: * -> *) a.
(Quote m, Generic a, GLift (Rep a)) =>
String -> a -> m (TExp a)
genericLiftTypedTExpWithPkg
# endif
#endif

#if MIN_VERSION_base (4,5,0)
-- $friendlyFunctions
--
-- The functions in this section are nice and simple, but are only available on
-- GHC 7.4.1 (@base@ 4.5) and later due to API limitations of earlier GHC
-- versions. The types of these functions depend slightly on the GHC version.
-- In particular, before GHC 8.0 (@base@ 4.9), these functions have
-- 'Data.Typeable.Typeable' constraints in addition to 'GHC.Generic.Generic'
-- ones.
--
-- These functions do all of the work for you:
--
-- @
-- &#123;-&#35; LANGUAGE DeriveGeneric &#35;-&#125;
-- module Foo where
--
-- import GHC.Generics
-- import Language.Haskell.Lift.Generics
--
-- data Foo = Foo Int Char String
--   deriving Generic
--
-- instance Lift Foo where
--   lift = genericLift
-- &#35;if MIN&#95;VERSION&#95;template_haskell(2,9,0)
--   liftTyped = genericLiftTypedCompat
-- &#35;endif
-- @
--
-- Now you can splice @Foo@ values directly into Haskell source code:
--
-- @
-- &#123;-&#35; LANGUAGE TemplateHaskell &#35;-&#125;
-- module Bar where
--
-- import Foo
-- import Language.Haskell.TH.Syntax
--
-- foo :: Foo
-- foo = $(lift (Foo 1 \'a\' \"baz\"))
-- @

-- | Produce a generic definition of 'lift'.
--
-- === Note
--
-- A @'Data.Typeable.Typeable' a@ instance is required for GHC < 8.0 (@base@ < 4.9).
# if MIN_VERSION_base (4,9,0)
genericLift :: (Quote m, Generic a, GLift (Rep a)) => a -> m Exp
genericLift :: a -> m Exp
genericLift = String -> Rep a Any -> m Exp
forall (f :: * -> *) (m :: * -> *) a.
(GLift f, Quote m) =>
String -> f a -> m Exp
glift String
"" (Rep a Any -> m Exp) -> (a -> Rep a Any) -> a -> m Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from
# else
genericLift :: forall m a. (Quote m, Generic a, GLift (Rep a), OuterTypeable a) => a -> m Exp
genericLift =
  glift (T.tyConPackage (T.typeRepTyCon (getConTR (Proxy :: Proxy a))))
    . from
# endif

# if MIN_VERSION_template_haskell(2,9,0)
-- | Like 'genericLift', but returns a 'Code' instead of an 'Exp'.
#  if MIN_VERSION_base (4,9,0)
genericLiftTyped :: (Quote m, Generic a, GLift (Rep a)) => a -> Code m a
#  else
genericLiftTyped :: (Quote m, Generic a, GLift (Rep a), OuterTypeable a) => a -> Code m a
#  endif
genericLiftTyped :: a -> Code m a
genericLiftTyped = m Exp -> Code m a
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (m Exp -> Code m a) -> (a -> m Exp) -> a -> Code m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m Exp
forall (m :: * -> *) a.
(Quote m, Generic a, GLift (Rep a)) =>
a -> m Exp
genericLift

-- | Like 'genericLift', but returns a 'TExp' instead of an 'Exp'.
#  if MIN_VERSION_base (4,9,0)
genericLiftTypedTExp :: (Quote m, Generic a, GLift (Rep a)) => a -> m (TExp a)
#  else
genericLiftTypedTExp :: (Quote m, Generic a, GLift (Rep a), OuterTypeable a) => a -> m (TExp a)
#  endif
genericLiftTypedTExp :: a -> m (TExp a)
genericLiftTypedTExp = m Exp -> m (TExp a)
forall a (m :: * -> *). Quote m => m Exp -> m (TExp a)
unsafeTExpCoerceQuote (m Exp -> m (TExp a)) -> (a -> m Exp) -> a -> m (TExp a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m Exp
forall (m :: * -> *) a.
(Quote m, Generic a, GLift (Rep a)) =>
a -> m Exp
genericLift

-- | Lift 'genericLift', but returns:
--
-- * A 'Code' (if using @template-haskell-2.17.0.0@ or later), or
-- * A 'TExp' (if using an older version of @template-haskell@)
--
-- This function is ideal for implementing the 'liftTyped' method of 'Lift'
-- directly, as its type changed in @template-haskell-2.17.0.0@.
#  if MIN_VERSION_base (4,9,0)
genericLiftTypedCompat :: (Quote m, Generic a, GLift (Rep a)) => a -> Splice m a
#  else
genericLiftTypedCompat :: (Quote m, Generic a, GLift (Rep a), OuterTypeable a) => a -> Splice m a
#  endif
#  if MIN_VERSION_template_haskell(2,17,0)
genericLiftTypedCompat = genericLiftTyped
#  else
genericLiftTypedCompat :: a -> Splice m a
genericLiftTypedCompat = a -> Splice m a
forall (m :: * -> *) a.
(Quote m, Generic a, GLift (Rep a)) =>
a -> m (TExp a)
genericLiftTypedTExp
#  endif
# endif
#endif

-- | Class of generic representation types which can be converted to Template
-- Haskell expressions.
class GLift f where
    glift :: Quote m
          => String -- ^ The package name (not used on GHC 8.0 and later)
          -> f a    -- ^ The generic value
          -> m Exp  -- ^ The resulting Template Haskell expression

instance (Datatype d, GLiftDatatype f) => GLift (D1 d f) where
    glift :: String -> D1 d f a -> m Exp
glift String
_pkg d :: D1 d f a
d@(M1 f a
x) = String -> String -> f a -> m Exp
forall (f :: * -> *) (m :: * -> *) a.
(GLiftDatatype f, Quote m) =>
String -> String -> f a -> m Exp
gliftWith String
pName String
mName f a
x
      where
        pName, mName :: String
#if __GLASGOW_HASKELL__ >= 711
        pName :: String
pName = D1 d f a -> String
forall k (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
packageName D1 d f a
d
#else
        pName = _pkg
#endif
        mName :: String
mName = D1 d f a -> String
forall k (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
moduleName D1 d f a
d

-- | Class of generic representation types which can be converted to Template
-- Haskell expressions, given a package and module name.
class GLiftDatatype f where
    gliftWith :: Quote m
              => String -- ^ The package name
              -> String -- ^ The module name
              -> f a    -- ^ The generic value
              -> m Exp  -- ^ The resulting Template Haskell expression

instance GLiftDatatype V1 where
    -- While many instances for void types produce the laziest possible result
    -- (here, something like pure undefined), we choose to be stricter. There
    -- seems little if any benefit to delaying exceptions in this context.
    gliftWith :: String -> String -> V1 a -> m Exp
gliftWith String
_ String
_ V1 a
x =
      case V1 a
x of
#if __GLASGOW_HASKELL__ >= 708
        {}
#else
        -- pseq ensures that we'll get the exception/non-termination
        -- of v, rather than allowing GHC to "optimize" the function
        -- to gliftWith _ _ _ = undefined, which it would be permitted
        -- to do if we used seq or a bang pattern.
        v -> v `pseq` undefined
#endif

instance (Constructor c, GLiftArgs f) => GLiftDatatype (C1 c f) where
    gliftWith :: String -> String -> C1 c f a -> m Exp
gliftWith String
pName String
mName c :: C1 c f a
c@(M1 f a
x) =
      f a -> Exp -> m Exp
forall (f :: * -> *) (m :: * -> *) a.
(GLiftArgs f, Quote m) =>
f a -> Exp -> m Exp
gliftArgs f a
x (Name -> Exp
ConE (String -> String -> String -> Name
mkNameG_d String
pName String
mName String
cName))
      where
        cName :: String
        cName :: String
cName = C1 c f a -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName C1 c f a
c

instance (GLiftDatatype f, GLiftDatatype g) => GLiftDatatype (f :+: g) where
    gliftWith :: String -> String -> (:+:) f g a -> m Exp
gliftWith String
pName String
mName (L1 f a
l) = String -> String -> f a -> m Exp
forall (f :: * -> *) (m :: * -> *) a.
(GLiftDatatype f, Quote m) =>
String -> String -> f a -> m Exp
gliftWith String
pName String
mName f a
l
    gliftWith String
pName String
mName (R1 g a
r) = String -> String -> g a -> m Exp
forall (f :: * -> *) (m :: * -> *) a.
(GLiftDatatype f, Quote m) =>
String -> String -> f a -> m Exp
gliftWith String
pName String
mName g a
r

-- | Class of generic representation types which can conceptually be converted
-- to a list of Template Haskell expressions (which represent a constructors'
-- arguments).
class GLiftArgs f where
    -- | @gliftArgs e f@ applies @f@ to the zero or more arguments represented
    -- by @e@.
    gliftArgs :: Quote m => f a -> Exp -> m Exp

instance GLiftArgs U1 where
    -- This pattern match must be strict, because
    -- lift undefined really shouldn't just happen
    -- to work for unit types.
    gliftArgs :: U1 a -> Exp -> m Exp
gliftArgs U1 a
U1 = Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return

instance Lift c => GLiftArgs (K1 i c) where
    gliftArgs :: K1 i c a -> Exp -> m Exp
gliftArgs (K1 c
x) Exp
h = Exp -> Exp -> Exp
AppE Exp
h (Exp -> Exp) -> m Exp -> m Exp
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` c -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
liftQuote c
x

instance GLiftArgs f => GLiftArgs (S1 s f) where
    gliftArgs :: S1 s f a -> Exp -> m Exp
gliftArgs (M1 f a
x) = f a -> Exp -> m Exp
forall (f :: * -> *) (m :: * -> *) a.
(GLiftArgs f, Quote m) =>
f a -> Exp -> m Exp
gliftArgs f a
x

instance (GLiftArgs f, GLiftArgs g) => GLiftArgs (f :*: g) where
    gliftArgs :: (:*:) f g a -> Exp -> m Exp
gliftArgs (f a
f :*: g a
g) = f a -> Exp -> m Exp
forall (f :: * -> *) (m :: * -> *) a.
(GLiftArgs f, Quote m) =>
f a -> Exp -> m Exp
gliftArgs f a
f (Exp -> m Exp) -> (Exp -> m Exp) -> Exp -> m Exp
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> g a -> Exp -> m Exp
forall (f :: * -> *) (m :: * -> *) a.
(GLiftArgs f, Quote m) =>
f a -> Exp -> m Exp
gliftArgs g a
g

instance GLiftArgs UAddr where
    gliftArgs :: UAddr a -> Exp -> m Exp
gliftArgs (UAddr a) Exp
h = Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
h (Lit -> Exp
LitE ([Word8] -> Lit
StringPrimL (String -> [Word8]
word8ify (Addr# -> String
unpackCString# Addr#
a))))
      where
#if MIN_VERSION_template_haskell(2,8,0)
        word8ify :: String -> [Word8]
        word8ify :: String -> [Word8]
word8ify = (Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord)
#else
        word8ify :: String -> String
        word8ify = id
#endif

#if MIN_VERSION_template_haskell(2,11,0)
instance GLiftArgs UChar where
    gliftArgs :: UChar a -> Exp -> m Exp
gliftArgs (UChar c) Exp
h = Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
h (Lit -> Exp
LitE (Char -> Lit
CharPrimL (Char# -> Char
C# Char#
c)))
#endif

instance GLiftArgs UDouble where
    gliftArgs :: UDouble a -> Exp -> m Exp
gliftArgs (UDouble d) Exp
h = Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
h (Lit -> Exp
LitE (Rational -> Lit
DoublePrimL (Double -> Rational
forall a. Real a => a -> Rational
toRational (Double# -> Double
D# Double#
d))))

instance GLiftArgs UFloat where
    gliftArgs :: UFloat a -> Exp -> m Exp
gliftArgs (UFloat f) Exp
h = Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
h (Lit -> Exp
LitE (Rational -> Lit
floatPrimL (Float -> Rational
forall a. Real a => a -> Rational
toRational (Float# -> Float
F# Float#
f))))

instance GLiftArgs UInt where
    gliftArgs :: UInt a -> Exp -> m Exp
gliftArgs (UInt i) Exp
h = Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
h (Lit -> Exp
LitE (Integer -> Lit
IntPrimL (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int# -> Int
I# Int#
i))))

instance GLiftArgs UWord where
    gliftArgs :: UWord a -> Exp -> m Exp
gliftArgs (UWord w) Exp
h = Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
h (Lit -> Exp
LitE (Integer -> Lit
WordPrimL (Word -> Integer
forall a. Integral a => a -> Integer
toInteger (Word# -> Word
W# Word#
w))))