{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
module Instances.TH.Lift
(
) where
import Language.Haskell.TH.Syntax (Lift(..))
import Language.Haskell.TH
import qualified Data.Foldable as F
#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
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)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Text.Lazy
#endif
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
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
import Control.Applicative (Const (..))
import Data.Functor.Identity (Identity (..))
#if !MIN_VERSION_template_haskell(2,9,1)
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
instance Lift v => Lift (IntMap.IntMap v) where
lift :: IntMap v -> Q Exp
lift 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
instance Lift IntSet.IntSet where
lift :: IntSet -> Q Exp
lift IntSet
s = [| IntSet.fromList s' |] where
s' :: [Key]
s' = IntSet -> [Key]
IntSet.toList IntSet
s
instance (Lift k, Lift v) => Lift (Map.Map k v) where
lift :: Map k v -> Q Exp
lift 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
instance Lift a => Lift (Sequence.Seq a) where
lift :: Seq a -> Q Exp
lift 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
instance Lift a => Lift (Set.Set a) where
lift :: Set a -> Q Exp
lift Set a
s = [| Set.fromList s' |] where
s' :: [a]
s' = Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
s
instance Lift a => Lift (Tree.Tree a) where
lift :: Tree a -> Q Exp
lift (Tree.Node a
x Forest a
xs) = [| Tree.Node x xs |]
#if !MIN_VERSION_text(1,2,4)
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
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
#endif
instance Lift ByteString.ByteString where
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
$ 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
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
instance (Vector.Primitive.Prim a, Lift a) => Lift (Vector.Primitive.Vector a) where
lift :: Vector a -> Q Exp
lift Vector a
v = [| Vector.Primitive.fromList v' |] where
v' :: [a]
v' = Vector a -> [a]
forall a. Prim a => Vector a -> [a]
Vector.Primitive.toList Vector a
v
instance (Vector.Storable.Storable a, Lift a) => Lift (Vector.Storable.Vector a) where
lift :: Vector a -> Q Exp
lift Vector a
v = [| Vector.Storable.fromList v' |] where
v' :: [a]
v' = Vector a -> [a]
forall a. Storable a => Vector a -> [a]
Vector.Storable.toList Vector a
v
instance (Vector.Unboxed.Unbox a, Lift a) => Lift (Vector.Unboxed.Vector a) where
lift :: Vector a -> Q Exp
lift Vector a
v = [| Vector.Unboxed.fromList v' |] where
v' :: [a]
v' = Vector a -> [a]
forall a. Unbox a => Vector a -> [a]
Vector.Unboxed.toList Vector a
v
instance Lift a => Lift (Vector.Boxed.Vector a) where
lift :: Vector a -> Q Exp
lift Vector a
v = [| Vector.Boxed.fromList v' |] where
v' :: [a]
v' = Vector a -> [a]
forall a. Vector a -> [a]
Vector.Boxed.toList Vector a
v
instance Lift a => Lift (Identity a) where
lift :: Identity a -> Q Exp
lift (Identity a
a) = [| Identity a |]
instance Lift a => Lift (Const a b) where
lift :: Const a b -> Q Exp
lift (Const a
a) = [| Const a |]