{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
module Instances.TH.Lift
  ( -- | This module provides orphan instances for the 'Language.Haskell.TH.Syntax.Lift' class from template-haskell. Following is a list of the provided instances.
    --
    -- Lift instances are useful to precompute values at compile time using template haskell. For example, if you write the following code,
    -- you can make sure that @3 * 10@ is really computed at compile time:
    --
    -- > {-# LANGUAGE TemplateHaskell #-}
    -- >
    -- > import Language.Haskell.TH.Syntax
    -- >
    -- > expensiveComputation :: Word32
    -- > expensiveComputation = $(lift $ 3 * 10) -- This will computed at compile time
    --
    -- This uses the Lift instance for Word32.
    --
    -- The following instances are provided by this package:

    -- * Base
    -- |  * 'Word8', 'Word16', 'Word32', 'Word64'
    --
    --    * 'Int8', 'Int16', 'Int32', 'Int64'
    --
    --    * 'NonEmpty' and 'Void', until provided by @template-haskell-2.15@

    -- * Containers (both strict/lazy)
    -- |  * 'Data.IntMap.IntMap'
    --
    --    * 'Data.IntSet.IntSet'
    --
    --    * 'Data.Map.Map'
    --
    --    * 'Data.Set.Set'
    --
    --    * 'Data.Tree.Tree'
    --
    --    * 'Data.Sequence.Seq'

    -- * ByteString (both strict/lazy)
    -- |  * 'Data.ByteString.ByteString'

    -- * Text (both strict/lazy)
    -- |  * 'Data.Text.Text'

    -- * Vector (Boxed, Unboxed, Storable, Primitive)
    -- |  * 'Data.Vector.Vector'

  ) where

import Language.Haskell.TH.Syntax (Lift(..))
#if MIN_VERSION_template_haskell(2,16,0)
import Language.Haskell.TH.Syntax (unsafeTExpCoerce)
#endif
import Language.Haskell.TH

import qualified Data.Foldable as F

-- Base
#if !MIN_VERSION_template_haskell(2,9,1)
import Data.Int
import Data.Word
#endif

#if !MIN_VERSION_template_haskell(2,10,0)
import Data.Ratio (Ratio)
#endif

#if !MIN_VERSION_template_haskell(2,15,0)
#if MIN_VERSION_base(4,8,0)
import Data.Void (Void, absurd)
#endif
#if MIN_VERSION_base(4,9,0)
import Data.List.NonEmpty (NonEmpty (..))
#endif
#endif

-- Containers
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Map as Map
import qualified Data.Sequence as Sequence
import qualified Data.Set as Set
import qualified Data.Tree as Tree

#if !MIN_VERSION_text(1,2,4)
-- Text
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Text.Lazy
#endif

-- ByteString
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Unsafe as ByteString.Unsafe
import qualified Data.ByteString.Lazy as ByteString.Lazy
import           System.IO.Unsafe (unsafePerformIO)
#if !MIN_VERSION_template_haskell(2, 8, 0)
import qualified Data.ByteString.Char8 as ByteString.Char8
#endif

-- Vector
import qualified Data.Vector as Vector.Boxed
import qualified Data.Vector.Primitive as Vector.Primitive
import qualified Data.Vector.Storable as Vector.Storable
import qualified Data.Vector.Unboxed as Vector.Unboxed

-- transformers (or base)
import Control.Applicative (Const (..))
import Data.Functor.Identity (Identity (..))

#if MIN_VERSION_template_haskell(2,16,0)
#define LIFT_TYPED_DEFAULT liftTyped = unsafeTExpCoerce . lift
#else
#define LIFT_TYPED_DEFAULT
#endif

--------------------------------------------------------------------------------

--------------------------------------------------------------------------------
#if !MIN_VERSION_template_haskell(2,9,1)
-- Base

instance Lift Word8 where
  lift x = [| fromInteger x' :: Word8 |] where
    x' = toInteger x

instance Lift Word16 where
  lift x = [| fromInteger x' :: Word16 |] where
    x' = toInteger x

instance Lift Word32 where
  lift x = [| fromInteger x' :: Word32 |] where
    x' = toInteger x

instance Lift Word64 where
  lift x = [| fromInteger x' :: Word64 |] where
    x' = toInteger x

instance Lift Int8 where
  lift x = [| fromInteger x' :: Int8 |] where
    x' = toInteger x

instance Lift Int16 where
  lift x = [| fromInteger x' :: Int16 |] where
    x' = toInteger x

instance Lift Int32 where
  lift x = [| fromInteger x' :: Int32 |] where
    x' = toInteger x

instance Lift Int64 where
  lift x = [| fromInteger x' :: Int64 |] where
    x' = toInteger x

instance Lift Float where
  lift x = return (LitE (RationalL (toRational x)))

instance Lift Double where
  lift x = return (LitE (RationalL (toRational x)))
# endif

#if !MIN_VERSION_template_haskell(2,10,0)
instance Lift () where
  lift () = [| () |]

instance Integral a => Lift (Ratio a) where
  lift x = return (LitE (RationalL (toRational x)))
#endif

#if !MIN_VERSION_template_haskell(2,15,0)
#if MIN_VERSION_base(4,8,0)

instance Lift Void where
    lift = absurd

#endif
#if MIN_VERSION_base(4,9,0)
instance Lift a => Lift (NonEmpty a) where
    lift (x :| xs) = [| x :| xs |]
#endif
#endif

--------------------------------------------------------------------------------
-- Containers
instance Lift v => Lift (IntMap.IntMap v) where
  lift :: IntMap v -> Q Exp
lift m :: IntMap v
m = [| IntMap.fromList m' |] where
    m' :: [(Key, v)]
m' = IntMap v -> [(Key, v)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap v
m
  LIFT_TYPED_DEFAULT

instance Lift IntSet.IntSet where
  lift :: IntSet -> Q Exp
lift s :: IntSet
s = [| IntSet.fromList s' |] where
    s' :: [Key]
s' = IntSet -> [Key]
IntSet.toList IntSet
s
  LIFT_TYPED_DEFAULT

instance (Lift k, Lift v) => Lift (Map.Map k v) where
  lift :: Map k v -> Q Exp
lift m :: Map k v
m = [| Map.fromList m' |] where
    m' :: [(k, v)]
m' = Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
Map.toList Map k v
m
  LIFT_TYPED_DEFAULT

instance Lift a => Lift (Sequence.Seq a) where
  lift :: Seq a -> Q Exp
lift s :: Seq a
s = [| Sequence.fromList s' |] where
    s' :: [a]
s' = Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq a
s
  LIFT_TYPED_DEFAULT

instance Lift a => Lift (Set.Set a) where
  lift :: Set a -> Q Exp
lift s :: Set a
s = [| Set.fromList s' |] where
    s' :: [a]
s' = Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
s
  LIFT_TYPED_DEFAULT

instance Lift a => Lift (Tree.Tree a) where
  lift :: Tree a -> Q Exp
lift (Tree.Node x :: a
x xs :: Forest a
xs) = [| Tree.Node x xs |]
  LIFT_TYPED_DEFAULT

#if !MIN_VERSION_text(1,2,4)
--------------------------------------------------------------------------------
-- Text
instance Lift Text.Text where
  lift t = [| Text.pack t' |] where
    t' = Text.unpack t
  LIFT_TYPED_DEFAULT

instance Lift Text.Lazy.Text where
  lift t = [| Text.Lazy.pack t' |] where
    t' = Text.Lazy.unpack t
  LIFT_TYPED_DEFAULT
#endif

--------------------------------------------------------------------------------
-- ByteString
instance Lift ByteString.ByteString where
  -- this is essentially what e.g. file-embed does
  lift :: ByteString -> Q Exp
lift b :: ByteString
b = Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'unsafePerformIO) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$
    Name -> Exp
VarE 'ByteString.Unsafe.unsafePackAddressLen Exp -> Exp -> Exp
`AppE` Exp
l Exp -> Exp -> Exp
`AppE` Exp
b'
    where
      l :: Exp
l  = Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ Key -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Key -> Integer) -> Key -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Key
ByteString.length ByteString
b
      b' :: Exp
b' =
#if MIN_VERSION_template_haskell(2, 8, 0)
        Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ [Word8] -> Lit
StringPrimL ([Word8] -> Lit) -> [Word8] -> Lit
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
ByteString.unpack ByteString
b
#else
        LitE $ StringPrimL $ ByteString.Char8.unpack b
#endif
  LIFT_TYPED_DEFAULT

instance Lift ByteString.Lazy.ByteString where
  lift :: ByteString -> Q Exp
lift lb :: ByteString
lb = do
    Exp
b' <- [ByteString] -> Q Exp
forall t. Lift t => t -> Q Exp
lift [ByteString]
b
    Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return  (Name -> Exp
VarE 'ByteString.Lazy.fromChunks Exp -> Exp -> Exp
`AppE` Exp
b')
    where
      b :: [ByteString]
b = ByteString -> [ByteString]
ByteString.Lazy.toChunks ByteString
lb
  LIFT_TYPED_DEFAULT

--------------------------------------------------------------------------------
-- Vector
instance (Vector.Primitive.Prim a, Lift a) => Lift (Vector.Primitive.Vector a) where
  lift :: Vector a -> Q Exp
lift v :: Vector a
v = [| Vector.Primitive.fromListN n' v' |] where
    n' :: Key
n' = Vector a -> Key
forall a. Prim a => Vector a -> Key
Vector.Primitive.length Vector a
v
    v' :: [a]
v' = Vector a -> [a]
forall a. Prim a => Vector a -> [a]
Vector.Primitive.toList Vector a
v
  LIFT_TYPED_DEFAULT

instance (Vector.Storable.Storable a, Lift a) => Lift (Vector.Storable.Vector a) where
  lift :: Vector a -> Q Exp
lift v :: Vector a
v = [| Vector.Storable.fromListN n' v' |] where
    n' :: Key
n' = Vector a -> Key
forall a. Storable a => Vector a -> Key
Vector.Storable.length Vector a
v
    v' :: [a]
v' = Vector a -> [a]
forall a. Storable a => Vector a -> [a]
Vector.Storable.toList Vector a
v
  LIFT_TYPED_DEFAULT

instance (Vector.Unboxed.Unbox a, Lift a) => Lift (Vector.Unboxed.Vector a) where
  lift :: Vector a -> Q Exp
lift v :: Vector a
v = [| Vector.Unboxed.fromListN n' v' |] where
    n' :: Key
n' = Vector a -> Key
forall a. Unbox a => Vector a -> Key
Vector.Unboxed.length Vector a
v
    v' :: [a]
v' = Vector a -> [a]
forall a. Unbox a => Vector a -> [a]
Vector.Unboxed.toList Vector a
v
  LIFT_TYPED_DEFAULT

instance Lift a => Lift (Vector.Boxed.Vector a) where
  lift :: Vector a -> Q Exp
lift v :: Vector a
v = [| Vector.Boxed.fromListN n' v' |] where
    n' :: Key
n' = Vector a -> Key
forall a. Vector a -> Key
Vector.Boxed.length Vector a
v
    v' :: [a]
v' = Vector a -> [a]
forall a. Vector a -> [a]
Vector.Boxed.toList Vector a
v
  LIFT_TYPED_DEFAULT

--------------------------------------------------------------------------------
-- Transformers
instance Lift a => Lift (Identity a) where
  lift :: Identity a -> Q Exp
lift (Identity a :: a
a) = [| Identity a |]
  LIFT_TYPED_DEFAULT

instance Lift a => Lift (Const a b) where
  lift :: Const a b -> Q Exp
lift (Const a :: a
a) = [| Const a |]
  LIFT_TYPED_DEFAULT