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

{-|
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`.
-}
module Language.Haskell.TH.Lift.Generics (
    -- * "GHC.Generics"-based 'lift' implementations
    --
    -- $genericLiftFunctions
      genericLift
    , genericLiftTyped
    , genericLiftTypedTExp
    , genericLiftTypedCompat

    -- * '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

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

-- $genericLiftFunctions
--
-- These functions leverage "GHC.Generics" to automatically implement 'lift'
-- implementations. These serve as 'Generic'-based alternatives to @DeriveLift@.
-- Here is an example of how to use them:
--
-- @
-- {-# LANGUAGE DeriveGeneric #-}
-- 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
-- #if MIN_VERSION_template_haskell(2,9,0)
--   liftTyped = genericLiftTypedCompat
-- #endif
-- @
--
-- Now you can splice @Foo@ values directly into Haskell source code:
--
-- @
-- {-# LANGUAGE TemplateHaskell #-}
-- module Bar where
--
-- import Foo
-- import Language.Haskell.TH.Syntax
--
-- foo :: Foo
-- foo = $(lift (Foo 1 \'a\' \"baz\"))
-- @

-- | Produce a generic definition of 'lift'.
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

-- | Like 'genericLift', but returns a 'Code' instead of an 'Exp'.
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

-- | Like 'genericLift', but returns a 'TExp' instead of an 'Exp'.
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

-- | 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@.
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 of generic representation types which can be converted to Template
-- Haskell expressions.
class GLift f where
    glift :: Quote m
          => f a    -- ^ The generic value
          -> m Exp  -- ^ The resulting Template Haskell expression

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 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 :: 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 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 :: 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))))