{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE StandaloneDeriving #-}
#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

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

#if !MIN_VERSION_containers(0,6,6)
import qualified Data.Tree as Tree

#if MIN_VERSION_containers(0,5,10)
-- recent enough containers exports internals,
-- so we can use DeriveLift
-- This way we construct the data type exactly as we have it
-- during compile time, so there is nothing left for run-time.
#define HAS_CONTAINERS_INTERNALS 1

import qualified Data.IntMap.Internal as IntMap
import qualified Data.IntSet.Internal as IntSet
import qualified Data.Map.Internal as Map
import qualified Data.Set.Internal as Set
import qualified Data.Sequence.Internal as Sequence
# if __GLASGOW_HASKELL__ >= 708
import Data.Coerce (coerce)
# else
import Unsafe.Coerce (unsafeCoerce)
# endif
#else
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Sequence as Sequence
import qualified Data.Foldable as F
#endif
# endif

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

#if !MIN_VERSION_bytestring(0,11,2)
-- 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
#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,17,0)
#define LIFT_TYPED_DEFAULT liftTyped = Code . unsafeTExpCoerce . lift
#elif 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
--

#if !MIN_VERSION_containers(0,6,6)
#if __GLASGOW_HASKELL__ >= 800
deriving instance Lift a => Lift (Tree.Tree a)
#else
instance Lift a => Lift (Tree.Tree a) where
  lift (Tree.Node x xs) = [| Tree.Node x xs |]
  LIFT_TYPED_DEFAULT
#endif

#if __GLASGOW_HASKELL__ >= 800
deriving instance Lift a => Lift (Sequence.ViewL a)
deriving instance Lift a => Lift (Sequence.ViewR a)
#else
instance Lift a => Lift (Sequence.ViewL a) where
  lift Sequence.EmptyL = [| Sequence.EmptyL |]
  lift (x Sequence.:< xs) = [| x Sequence.:< xs |]
  LIFT_TYPED_DEFAULT
instance Lift a => Lift (Sequence.ViewR a) where
  lift Sequence.EmptyR = [| Sequence.EmptyR |]
  lift (xs Sequence.:> x) = [| xs Sequence.:> x |]
  LIFT_TYPED_DEFAULT
#endif
 
#if HAS_CONTAINERS_INTERNALS
-- The coercion gunk reduces the expression size by a substantial
-- constant factor, which I imagine is good for compilation
-- speed.
instance Lift a => Lift (Sequence.Seq a) where
  lift :: Seq a -> Q Exp
lift Seq a
xs = [| fixupSeq ft' |]
    where
      -- The tree produced by zipWith has the same shape as
      -- that of its first argument. replicate produces a shallow
      -- tree, which is usually desirable.
      Sequence.Seq FingerTree (Elem a)
rebalanced =
        (() -> a -> a) -> Seq () -> Seq a -> Seq a
forall a b c. (a -> b -> c) -> Seq a -> Seq b -> Seq c
Sequence.zipWith
          ((a -> () -> a) -> () -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> () -> a
forall a b. a -> b -> a
const)
          (Int -> () -> Seq ()
forall a. Int -> a -> Seq a
Sequence.replicate (Seq a -> Int
forall a. Seq a -> Int
Sequence.length Seq a
xs) ())
          Seq a
xs
      ft' :: Sequence.FingerTree a
      ft' :: FingerTree a
ft' = FingerTree (Elem a) -> FingerTree a
forall a. FingerTree (Elem a) -> FingerTree a
stripElem FingerTree (Elem a)
rebalanced
  LIFT_TYPED_DEFAULT

fixupSeq :: Sequence.FingerTree a -> Sequence.Seq a
stripElem :: Sequence.FingerTree (Sequence.Elem a) -> Sequence.FingerTree a
# if __GLASGOW_HASKELL__ >= 708
fixupSeq :: FingerTree a -> Seq a
fixupSeq = FingerTree a -> Seq a
coerce
stripElem :: FingerTree (Elem a) -> FingerTree a
stripElem = FingerTree (Elem a) -> FingerTree a
coerce
# else
fixupSeq = unsafeCoerce
stripElem = unsafeCoerce
# endif

# if __GLASGOW_HASKELL__ >= 800
deriving instance Lift a => Lift (Sequence.Digit a)
deriving instance Lift a => Lift (Sequence.Node a)
deriving instance Lift a => Lift (Sequence.FingerTree a)
# else
instance Lift a => Lift (Sequence.Elem a) where
  lift (Sequence.Elem a) = [| Sequence.Elem a |]
  LIFT_TYPED_DEFAULT
instance Lift a => Lift (Sequence.Digit a) where
  lift (Sequence.One a) = [| Sequence.One a |]
  lift (Sequence.Two a b) = [| Sequence.Two a b |]
  lift (Sequence.Three a b c) = [| Sequence.Three a b c |]
  lift (Sequence.Four a b c d) = [| Sequence.Four a b c d |]
  LIFT_TYPED_DEFAULT
instance Lift a => Lift (Sequence.Node a) where
  lift (Sequence.Node2 s a b) = [| Sequence.Node2 s a b |]
  lift (Sequence.Node3 s a b c) = [| Sequence.Node3 s a b c |]
  LIFT_TYPED_DEFAULT
instance Lift a => Lift (Sequence.FingerTree a) where
  lift Sequence.EmptyT = [| Sequence.EmptyT |]
  lift (Sequence.Single a) = [| Sequence.Single a |]
  lift (Sequence.Deep s pr m sf) = [| Sequence.Deep s pr m sf |]
  LIFT_TYPED_DEFAULT
# endif

#endif

#if HAS_CONTAINERS_INTERNALS && __GLASGOW_HASKELL__ >= 800
deriving instance Lift v => Lift (IntMap.IntMap v)
deriving instance Lift IntSet.IntSet
deriving instance (Lift k, Lift v) => Lift (Map.Map k v)
deriving instance Lift a => Lift (Set.Set a)

#else
-- No containers internals here, or no Lift deriving

instance Lift v => Lift (IntMap.IntMap v) where
  lift m = [| IntMap.fromDistinctAscList m' |] where
    m' = IntMap.toAscList m
  LIFT_TYPED_DEFAULT

instance Lift IntSet.IntSet where
  lift s = [| IntSet.fromList s' |] where
    s' = IntSet.toList s
  LIFT_TYPED_DEFAULT

instance (Lift k, Lift v) => Lift (Map.Map k v) where
  lift m = [| Map.fromDistinctAscList m' |] where
    m' = Map.toAscList m
  LIFT_TYPED_DEFAULT

instance Lift a => Lift (Set.Set a) where
  lift s = [| Set.fromDistinctAscList s' |] where
    s' = Set.toAscList s
  LIFT_TYPED_DEFAULT
#endif

#if !HAS_CONTAINERS_INTERNALS
instance Lift a => Lift (Sequence.Seq a) where
  lift s = [| Sequence.fromList s' |] where
    s' = F.toList s
  LIFT_TYPED_DEFAULT
#endif

# endif

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

instance Lift Text.Lazy.Text where
  lift :: Text -> Q Exp
lift Text
t = [| Text.Lazy.pack t' |] where
    t' :: String
t' = Text -> String
Text.Lazy.unpack Text
t
  LIFT_TYPED_DEFAULT
#endif

#if !MIN_VERSION_bytestring(0,11,2)
--------------------------------------------------------------------------------
-- ByteString
instance Lift ByteString.ByteString where
  -- this is essentially what e.g. file-embed does
  lift :: ByteString -> Q Exp
lift 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
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
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 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
#endif

--------------------------------------------------------------------------------
-- Vector
instance (Vector.Primitive.Prim a, Lift a) => Lift (Vector.Primitive.Vector a) where
  lift :: Vector a -> Q Exp
lift Vector a
v = [| Vector.Primitive.fromListN n' v' |] where
    n' :: Int
n' = Vector a -> Int
forall a. Prim a => Vector a -> Int
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 Vector a
v = [| Vector.Storable.fromListN n' v' |] where
    n' :: Int
n' = Vector a -> Int
forall a. Storable a => Vector a -> Int
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 Vector a
v = [| Vector.Unboxed.fromListN n' v' |] where
    n' :: Int
n' = Vector a -> Int
forall a. Unbox a => Vector a -> Int
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 Vector a
v = [| Vector.Boxed.fromListN n' v' |] where
    n' :: Int
n' = Vector a -> Int
forall a. Vector a -> Int
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

#if __GLASGOW_HASKELL__ >= 800
deriving instance Lift a => Lift (Identity a)
deriving instance Lift a => Lift (Const a b)
#else
instance Lift a => Lift (Identity a) where
  lift (Identity a) = [| Identity a |]

instance Lift a => Lift (Const a b) where
  lift (Const a) = [| Const a |]
#endif