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