{-# 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 (
#if MIN_VERSION_base(4,5,0)
genericLift
# if MIN_VERSION_template_haskell(2,9,0)
, genericLiftTyped
, genericLiftTypedTExp
, genericLiftTypedCompat
# endif
,
#endif
genericLiftWithPkgFallback
#if MIN_VERSION_template_haskell(2,9,0)
, genericLiftTypedWithPkgFallback
, genericLiftTypedTExpWithPkgFallback
, genericLiftTypedCompatWithPkgFallback
#endif
, genericLiftWithPkg
#if MIN_VERSION_template_haskell(2,9,0)
, genericLiftTypedWithPkg
, genericLiftTypedTExpWithPkg
, genericLiftTypedCompatWithPkg
#endif
, GLift(..)
, GLiftDatatype(..)
, GLiftArgs(..)
, 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
#undef CURRENT_PACKAGE_KEY
#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)
# 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
# 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
# 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
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)
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
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
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)
# 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)
# 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
# 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
# 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 GLift f where
glift :: Quote m
=> String
-> f a
-> m Exp
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 GLiftDatatype f where
gliftWith :: Quote m
=> String
-> String
-> f a
-> m Exp
instance GLiftDatatype V1 where
gliftWith :: String -> String -> V1 a -> m Exp
gliftWith String
_ String
_ V1 a
x =
case V1 a
x of
#if __GLASGOW_HASKELL__ >= 708
{}
#else
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 GLiftArgs f where
gliftArgs :: Quote m => f a -> Exp -> m Exp
instance GLiftArgs U1 where
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))))