{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Language.Haskell.TH.Lift.Generics (
genericLift
, genericLiftTyped
, genericLiftTypedTExp
, genericLiftTypedCompat
, GLift(..)
, GLiftDatatype(..)
, GLiftArgs(..)
, Lift(..)
) where
import Control.Monad (liftM, (>=>))
import Data.Char (ord)
import Data.Word (Word8)
import GHC.Generics
import GHC.Base (unpackCString#)
import GHC.Exts (Char(..), Double(..), Float(..), Int(..), Word(..))
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Syntax.Compat
genericLift :: (Quote m, Generic a, GLift (Rep a)) => a -> m Exp
genericLift :: forall (m :: * -> *) a.
(Quote m, Generic a, GLift (Rep a)) =>
a -> m Exp
genericLift = Rep a Any -> m Exp
forall (f :: * -> *) (m :: * -> *) a.
(GLift f, Quote m) =>
f a -> m Exp
forall (m :: * -> *) a. Quote m => Rep a a -> m Exp
glift (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 x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from
genericLiftTyped :: (Quote m, Generic a, GLift (Rep a)) => a -> Code m a
genericLiftTyped :: forall (m :: * -> *) a.
(Quote m, Generic a, GLift (Rep a)) =>
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
genericLiftTypedTExp :: (Quote m, Generic a, GLift (Rep a)) => a -> m (TExp a)
genericLiftTypedTExp :: forall (m :: * -> *) a.
(Quote m, Generic a, GLift (Rep a)) =>
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
genericLiftTypedCompat :: (Quote m, Generic a, GLift (Rep a)) => a -> Splice m a
#if MIN_VERSION_template_haskell(2,17,0)
genericLiftTypedCompat :: forall (m :: * -> *) a.
(Quote m, Generic a, GLift (Rep a)) =>
a -> Code m a
genericLiftTypedCompat = a -> Code m a
forall (m :: * -> *) a.
(Quote m, Generic a, GLift (Rep a)) =>
a -> Code m a
genericLiftTyped
#else
genericLiftTypedCompat = genericLiftTypedTExp
#endif
class GLift f where
glift :: Quote m
=> f a
-> m Exp
instance (Datatype d, GLiftDatatype f) => GLift (D1 d f) where
glift :: forall (m :: * -> *) a. Quote m => D1 d f a -> m Exp
glift 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
forall (m :: * -> *) a. Quote m => String -> String -> f a -> m Exp
gliftWith String
pName String
mName f a
x
where
pName, mName :: String
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
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
(a :: k1).
t d f a -> String
packageName D1 d f a
d
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
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
(a :: k1).
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 :: forall (m :: * -> *) a.
Quote m =>
String -> String -> V1 a -> m Exp
gliftWith String
_ String
_ V1 a
x = case V1 a
x of {}
instance (Constructor c, GLiftArgs f) => GLiftDatatype (C1 c f) where
gliftWith :: forall (m :: * -> *) a.
Quote m =>
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
forall (m :: * -> *) a. 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
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
(a :: k1).
t c f a -> String
conName C1 c f a
c
instance (GLiftDatatype f, GLiftDatatype g) => GLiftDatatype (f :+: g) where
gliftWith :: forall (m :: * -> *) a.
Quote m =>
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
forall (m :: * -> *) a. 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
forall (m :: * -> *) a. Quote m => String -> String -> g 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 :: forall (m :: * -> *) a. Quote m => U1 a -> Exp -> m Exp
gliftArgs U1 a
U1 = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
instance Lift c => GLiftArgs (K1 i c) where
gliftArgs :: forall (m :: * -> *) a. Quote m => 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 :: forall (m :: * -> *) a. Quote m => 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
forall (m :: * -> *) a. Quote m => f a -> Exp -> m Exp
gliftArgs f a
x
instance (GLiftArgs f, GLiftArgs g) => GLiftArgs (f :*: g) where
gliftArgs :: forall (m :: * -> *) a. Quote m => (:*:) 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
forall (m :: * -> *) a. 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
forall (m :: * -> *) a. Quote m => g a -> Exp -> m Exp
gliftArgs g a
g
instance GLiftArgs UAddr where
gliftArgs :: forall (m :: * -> *) a. Quote m => UAddr a -> Exp -> m Exp
gliftArgs (UAddr Addr#
a) Exp
h = Exp -> m Exp
forall a. a -> m a
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
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)
instance GLiftArgs UChar where
gliftArgs :: forall (m :: * -> *) a. Quote m => UChar a -> Exp -> m Exp
gliftArgs (UChar Char#
c) Exp
h = Exp -> m Exp
forall a. a -> m a
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)))
instance GLiftArgs UDouble where
gliftArgs :: forall (m :: * -> *) a. Quote m => UDouble a -> Exp -> m Exp
gliftArgs (UDouble Double#
d) Exp
h = Exp -> m Exp
forall a. a -> m a
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 :: forall (m :: * -> *) a. Quote m => UFloat a -> Exp -> m Exp
gliftArgs (UFloat Float#
f) Exp
h = Exp -> m Exp
forall a. a -> m a
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 :: forall (m :: * -> *) a. Quote m => UInt a -> Exp -> m Exp
gliftArgs (UInt Int#
i) Exp
h = Exp -> m Exp
forall a. a -> m a
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 :: forall (m :: * -> *) a. Quote m => UWord a -> Exp -> m Exp
gliftArgs (UWord Word#
w) Exp
h = Exp -> m Exp
forall a. a -> m a
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))))