1{-# OPTIONS_GHC -fno-warn-orphans #-}
2{-# LANGUAGE CPP #-}
3#if __GLASGOW_HASKELL__ >= 800
4{-# LANGUAGE TemplateHaskellQuotes #-}
5{-# LANGUAGE DeriveLift #-}
6{-# LANGUAGE StandaloneDeriving #-}
7#else
8{-# LANGUAGE TemplateHaskell #-}
9#endif
10module Instances.TH.Lift
11  ( -- | This module provides orphan instances for the 'Language.Haskell.TH.Syntax.Lift' class from template-haskell. Following is a list of the provided instances.
12    --
13    -- Lift instances are useful to precompute values at compile time using template haskell. For example, if you write the following code,
14    -- you can make sure that @3 * 10@ is really computed at compile time:
15    --
16    -- > {-# LANGUAGE TemplateHaskell #-}
17    -- >
18    -- > import Language.Haskell.TH.Syntax
19    -- >
20    -- > expensiveComputation :: Word32
21    -- > expensiveComputation = $(lift $ 3 * 10) -- This will computed at compile time
22    --
23    -- This uses the Lift instance for Word32.
24    --
25    -- The following instances are provided by this package:
26
27    -- * Base
28    -- |  * 'Word8', 'Word16', 'Word32', 'Word64'
29    --
30    --    * 'Int8', 'Int16', 'Int32', 'Int64'
31    --
32    --    * 'NonEmpty' and 'Void', until provided by @template-haskell-2.15@
33
34    -- * Containers (both strict/lazy)
35    -- |  * 'Data.IntMap.IntMap'
36    --
37    --    * 'Data.IntSet.IntSet'
38    --
39    --    * 'Data.Map.Map'
40    --
41    --    * 'Data.Set.Set'
42    --
43    --    * 'Data.Tree.Tree'
44    --
45    --    * 'Data.Sequence.Seq'
46
47    -- * ByteString (both strict/lazy)
48    -- |  * 'Data.ByteString.ByteString'
49
50    -- * Text (both strict/lazy)
51    -- |  * 'Data.Text.Text'
52
53    -- * Vector (Boxed, Unboxed, Storable, Primitive)
54    -- |  * 'Data.Vector.Vector'
55
56  ) where
57
58import Language.Haskell.TH.Syntax (Lift(..))
59#if MIN_VERSION_template_haskell(2,16,0)
60import Language.Haskell.TH.Syntax (unsafeTExpCoerce)
61#endif
62import Language.Haskell.TH
63
64import qualified Data.Foldable as F
65
66-- Base
67#if !MIN_VERSION_template_haskell(2,9,1)
68import Data.Int
69import Data.Word
70#endif
71
72#if !MIN_VERSION_template_haskell(2,10,0)
73import Data.Ratio (Ratio)
74#endif
75
76#if !MIN_VERSION_template_haskell(2,15,0)
77#if MIN_VERSION_base(4,8,0)
78import Data.Void (Void, absurd)
79#endif
80#if MIN_VERSION_base(4,9,0)
81import Data.List.NonEmpty (NonEmpty (..))
82#endif
83#endif
84
85-- Containers
86import qualified Data.Tree as Tree
87
88#if MIN_VERSION_containers(5,10,1)
89-- recent enough containers exports internals,
90-- so we can use DeriveLift
91-- This way we construct the data type exactly as we have it
92-- during compile time, so there is nothing left for run-time.
93#define HAS_CONTAINERS_INTERNALS 1
94
95import qualified Data.IntMap.Internal as IntMap
96import qualified Data.IntSet.Internal as IntSet
97import qualified Data.Map.Internal as Map
98import qualified Data.Sequence.Internal as Sequence
99import qualified Data.Set.Internal as Set
100#else
101import qualified Data.IntMap as IntMap
102import qualified Data.IntSet as IntSet
103import qualified Data.Map as Map
104import qualified Data.Sequence as Sequence
105import qualified Data.Set as Set
106#endif
107
108#if !MIN_VERSION_text(1,2,4)
109-- Text
110import qualified Data.Text as Text
111import qualified Data.Text.Lazy as Text.Lazy
112#endif
113
114-- ByteString
115import qualified Data.ByteString as ByteString
116import qualified Data.ByteString.Unsafe as ByteString.Unsafe
117import qualified Data.ByteString.Lazy as ByteString.Lazy
118import           System.IO.Unsafe (unsafePerformIO)
119#if !MIN_VERSION_template_haskell(2, 8, 0)
120import qualified Data.ByteString.Char8 as ByteString.Char8
121#endif
122
123-- Vector
124import qualified Data.Vector as Vector.Boxed
125import qualified Data.Vector.Primitive as Vector.Primitive
126import qualified Data.Vector.Storable as Vector.Storable
127import qualified Data.Vector.Unboxed as Vector.Unboxed
128
129-- transformers (or base)
130import Control.Applicative (Const (..))
131import Data.Functor.Identity (Identity (..))
132
133#if MIN_VERSION_template_haskell(2,17,0)
134#define LIFT_TYPED_DEFAULT liftTyped = Code . unsafeTExpCoerce . lift
135#elif MIN_VERSION_template_haskell(2,16,0)
136#define LIFT_TYPED_DEFAULT liftTyped = unsafeTExpCoerce . lift
137#else
138#define LIFT_TYPED_DEFAULT
139#endif
140
141--------------------------------------------------------------------------------
142
143--------------------------------------------------------------------------------
144#if !MIN_VERSION_template_haskell(2,9,1)
145-- Base
146
147instance Lift Word8 where
148  lift x = [| fromInteger x' :: Word8 |] where
149    x' = toInteger x
150
151instance Lift Word16 where
152  lift x = [| fromInteger x' :: Word16 |] where
153    x' = toInteger x
154
155instance Lift Word32 where
156  lift x = [| fromInteger x' :: Word32 |] where
157    x' = toInteger x
158
159instance Lift Word64 where
160  lift x = [| fromInteger x' :: Word64 |] where
161    x' = toInteger x
162
163instance Lift Int8 where
164  lift x = [| fromInteger x' :: Int8 |] where
165    x' = toInteger x
166
167instance Lift Int16 where
168  lift x = [| fromInteger x' :: Int16 |] where
169    x' = toInteger x
170
171instance Lift Int32 where
172  lift x = [| fromInteger x' :: Int32 |] where
173    x' = toInteger x
174
175instance Lift Int64 where
176  lift x = [| fromInteger x' :: Int64 |] where
177    x' = toInteger x
178
179instance Lift Float where
180  lift x = return (LitE (RationalL (toRational x)))
181
182instance Lift Double where
183  lift x = return (LitE (RationalL (toRational x)))
184# endif
185
186#if !MIN_VERSION_template_haskell(2,10,0)
187instance Lift () where
188  lift () = [| () |]
189
190instance Integral a => Lift (Ratio a) where
191  lift x = return (LitE (RationalL (toRational x)))
192#endif
193
194#if !MIN_VERSION_template_haskell(2,15,0)
195#if MIN_VERSION_base(4,8,0)
196
197instance Lift Void where
198    lift = absurd
199
200#endif
201#if MIN_VERSION_base(4,9,0)
202instance Lift a => Lift (NonEmpty a) where
203    lift (x :| xs) = [| x :| xs |]
204#endif
205#endif
206
207--------------------------------------------------------------------------------
208-- Containers
209--
210
211#if __GLASGOW_HASKELL__ >= 800
212deriving instance Lift a => Lift (Tree.Tree a)
213#else
214instance Lift a => Lift (Tree.Tree a) where
215  lift (Tree.Node x xs) = [| Tree.Node x xs |]
216#endif
217
218#if HAS_CONTAINERS_INTERNALS
219deriving instance Lift v => Lift (IntMap.IntMap v)
220deriving instance Lift IntSet.IntSet
221deriving instance (Lift k, Lift v) => Lift (Map.Map k v)
222deriving instance Lift a => Lift (Sequence.Seq a)
223deriving instance Lift a => Lift (Set.Set a)
224#else
225instance Lift v => Lift (IntMap.IntMap v) where
226  lift m = [| IntMap.fromList m' |] where
227    m' = IntMap.toList m
228  LIFT_TYPED_DEFAULT
229
230instance Lift IntSet.IntSet where
231  lift s = [| IntSet.fromList s' |] where
232    s' = IntSet.toList s
233  LIFT_TYPED_DEFAULT
234
235instance (Lift k, Lift v) => Lift (Map.Map k v) where
236  lift m = [| Map.fromList m' |] where
237    m' = Map.toList m
238  LIFT_TYPED_DEFAULT
239
240instance Lift a => Lift (Sequence.Seq a) where
241  lift s = [| Sequence.fromList s' |] where
242    s' = F.toList s
243  LIFT_TYPED_DEFAULT
244
245instance Lift a => Lift (Set.Set a) where
246  lift s = [| Set.fromList s' |] where
247    s' = Set.toList s
248  LIFT_TYPED_DEFAULT
249#endif
250
251#if !MIN_VERSION_text(1,2,4)
252--------------------------------------------------------------------------------
253-- Text
254instance Lift Text.Text where
255  lift t = [| Text.pack t' |] where
256    t' = Text.unpack t
257  LIFT_TYPED_DEFAULT
258
259instance Lift Text.Lazy.Text where
260  lift t = [| Text.Lazy.pack t' |] where
261    t' = Text.Lazy.unpack t
262  LIFT_TYPED_DEFAULT
263#endif
264
265--------------------------------------------------------------------------------
266-- ByteString
267instance Lift ByteString.ByteString where
268  -- this is essentially what e.g. file-embed does
269  lift b = return $ AppE (VarE 'unsafePerformIO) $
270    VarE 'ByteString.Unsafe.unsafePackAddressLen `AppE` l `AppE` b'
271    where
272      l  = LitE $ IntegerL $ fromIntegral $ ByteString.length b
273      b' =
274#if MIN_VERSION_template_haskell(2, 8, 0)
275        LitE $ StringPrimL $ ByteString.unpack b
276#else
277        LitE $ StringPrimL $ ByteString.Char8.unpack b
278#endif
279  LIFT_TYPED_DEFAULT
280
281instance Lift ByteString.Lazy.ByteString where
282  lift lb = do
283    b' <- lift b
284    return  (VarE 'ByteString.Lazy.fromChunks `AppE` b')
285    where
286      b = ByteString.Lazy.toChunks lb
287  LIFT_TYPED_DEFAULT
288
289--------------------------------------------------------------------------------
290-- Vector
291instance (Vector.Primitive.Prim a, Lift a) => Lift (Vector.Primitive.Vector a) where
292  lift v = [| Vector.Primitive.fromListN n' v' |] where
293    n' = Vector.Primitive.length v
294    v' = Vector.Primitive.toList v
295  LIFT_TYPED_DEFAULT
296
297instance (Vector.Storable.Storable a, Lift a) => Lift (Vector.Storable.Vector a) where
298  lift v = [| Vector.Storable.fromListN n' v' |] where
299    n' = Vector.Storable.length v
300    v' = Vector.Storable.toList v
301  LIFT_TYPED_DEFAULT
302
303instance (Vector.Unboxed.Unbox a, Lift a) => Lift (Vector.Unboxed.Vector a) where
304  lift v = [| Vector.Unboxed.fromListN n' v' |] where
305    n' = Vector.Unboxed.length v
306    v' = Vector.Unboxed.toList v
307  LIFT_TYPED_DEFAULT
308
309instance Lift a => Lift (Vector.Boxed.Vector a) where
310  lift v = [| Vector.Boxed.fromListN n' v' |] where
311    n' = Vector.Boxed.length v
312    v' = Vector.Boxed.toList v
313  LIFT_TYPED_DEFAULT
314
315--------------------------------------------------------------------------------
316-- Transformers
317
318#if __GLASGOW_HASKELL__ >= 800
319deriving instance Lift a => Lift (Identity a)
320deriving instance Lift a => Lift (Const a b)
321#else
322instance Lift a => Lift (Identity a) where
323  lift (Identity a) = [| Identity a |]
324
325instance Lift a => Lift (Const a b) where
326  lift (Const a) = [| Const a |]
327#endif
328