1{-# LANGUAGE CPP #-} 2{-# LANGUAGE EmptyDataDecls #-} 3{-# LANGUAGE FlexibleContexts #-} 4{-# LANGUAGE FlexibleInstances #-} 5{-# LANGUAGE FunctionalDependencies #-} 6{-# LANGUAGE KindSignatures #-} 7{-# LANGUAGE MultiParamTypeClasses #-} 8{-# LANGUAGE PatternGuards #-} 9{-# LANGUAGE Rank2Types #-} 10{-# LANGUAGE ScopedTypeVariables #-} 11#if __GLASGOW_HASKELL__ >= 706 12{-# LANGUAGE DataKinds #-} 13{-# LANGUAGE PolyKinds #-} 14{-# LANGUAGE TypeOperators #-} 15#define USE_TYPE_LITS 1 16#endif 17#ifdef MIN_VERSION_template_haskell 18# if __GLASGOW_HASKELL__ >= 800 19-- TH-subset that works with stage1 & unregisterised GHCs 20{-# LANGUAGE TemplateHaskellQuotes #-} 21# else 22{-# LANGUAGE TemplateHaskell #-} 23# endif 24#endif 25 26{-# LANGUAGE TypeFamilies #-} 27{-# LANGUAGE DeriveDataTypeable #-} 28{-# LANGUAGE UndecidableInstances #-} 29 30{-# OPTIONS_GHC -fno-cse #-} 31{-# OPTIONS_GHC -fno-full-laziness #-} 32{-# OPTIONS_GHC -fno-float-in #-} 33{-# OPTIONS_GHC -fno-warn-orphans #-} 34{-# OPTIONS_GHC -fno-warn-unused-binds #-} 35 36#ifndef MIN_VERSION_base 37#define MIN_VERSION_base(x,y,z) 1 38#endif 39 40---------------------------------------------------------------------------- 41-- | 42-- Module : Data.Reflection 43-- Copyright : 2009-2015 Edward Kmett, 44-- 2012 Elliott Hird, 45-- 2004 Oleg Kiselyov and Chung-chieh Shan 46-- License : BSD3 47-- 48-- Maintainer : Edward Kmett <ekmett@gmail.com> 49-- Stability : experimental 50-- Portability : non-portable 51-- 52-- Reifies arbitrary terms at the type level. Based on the Functional 53-- Pearl: Implicit Configurations paper by Oleg Kiselyov and 54-- Chung-chieh Shan. 55-- 56-- <http://okmij.org/ftp/Haskell/tr-15-04.pdf> 57-- 58-- The approach from the paper was modified to work with Data.Proxy 59-- and to cheat by using knowledge of GHC's internal representations 60-- by Edward Kmett and Elliott Hird. 61-- 62-- Usage comes down to two combinators, 'reify' and 'reflect'. 63-- 64-- >>> reify 6 (\p -> reflect p + reflect p) 65-- 12 66-- 67-- The argument passed along by reify is just a @data 'Proxy' t = 68-- Proxy@, so all of the information needed to reconstruct your value 69-- has been moved to the type level. This enables it to be used when 70-- constructing instances (see @examples/Monoid.hs@). 71-- 72-- In addition, a simpler API is offered for working with singleton 73-- values such as a system configuration, etc. 74------------------------------------------------------------------------------- 75module Data.Reflection 76 ( 77 -- * Reflection 78 Reifies(..) 79 , reify 80#if __GLASGOW_HASKELL__ >= 708 81 , reifyNat 82 , reifySymbol 83#endif 84 , reifyTypeable 85 -- * Given 86 , Given(..) 87 , give 88#ifdef MIN_VERSION_template_haskell 89 -- * Template Haskell reflection 90 , int, nat 91#endif 92 -- * Useful compile time naturals 93 , Z, D, SD, PD 94 95 -- * Reified Monoids 96 , ReifiedMonoid(..) 97 , ReflectedMonoid(..) 98 , reifyMonoid 99 , foldMapBy 100 , foldBy 101 102 -- * Reified Applicatives 103 , ReifiedApplicative(..) 104 , ReflectedApplicative(..) 105 , reifyApplicative 106 , traverseBy 107 , sequenceBy 108 ) where 109 110import Control.Applicative 111 112#ifdef MIN_VERSION_template_haskell 113import Control.Monad 114#endif 115 116import Data.Bits 117 118#if __GLASGOW_HASKELL__ < 710 119import Data.Foldable 120#endif 121 122import Data.Semigroup as Sem 123import Data.Proxy 124 125#if __GLASGOW_HASKELL__ < 710 126import Data.Traversable 127#endif 128 129import Data.Typeable 130import Data.Word 131import Foreign.Ptr 132import Foreign.StablePtr 133 134#if (__GLASGOW_HASKELL__ >= 707) || (defined(MIN_VERSION_template_haskell) && USE_TYPE_LITS) 135import GHC.TypeLits 136# if MIN_VERSION_base(4,10,0) 137import Numeric.Natural (Natural) 138# elif __GLASGOW_HASKELL__ >= 707 139import Control.Exception (ArithException(..), throw) 140# endif 141#endif 142 143#ifdef __HUGS__ 144import Hugs.IOExts 145#endif 146 147#ifdef MIN_VERSION_template_haskell 148import Language.Haskell.TH hiding (reify) 149#endif 150 151import System.IO.Unsafe 152 153#ifndef __HUGS__ 154import Unsafe.Coerce 155#endif 156 157#ifdef HLINT 158{-# ANN module "HLint: ignore Avoid lambda" #-} 159#endif 160 161-- Due to https://gitlab.haskell.org/ghc/ghc/issues/16893, inlining 162-- unsafeCoerce too aggressively can cause optimization to become unsound on 163-- old versions of GHC. As a workaround, we mark unsafeCoerce-using definitions 164-- as NOINLINE where necessary. 165-- See https://github.com/ekmett/reflection/issues/47. 166#if __GLASGOW_HASKELL__ >= 811 167# define INLINE_UNSAFE_COERCE INLINE 168#else 169# define INLINE_UNSAFE_COERCE NOINLINE 170#endif 171 172------------------------------------------------------------------------------ 173-- Reifies 174------------------------------------------------------------------------------ 175 176class Reifies s a | s -> a where 177 -- | Recover a value inside a 'reify' context, given a proxy for its 178 -- reified type. 179 reflect :: proxy s -> a 180 181newtype Magic a r = Magic (forall (s :: *). Reifies s a => Proxy s -> r) 182 183-- | Reify a value at the type level, to be recovered with 'reflect'. 184reify :: forall a r. a -> (forall (s :: *). Reifies s a => Proxy s -> r) -> r 185reify a k = unsafeCoerce (Magic k :: Magic a r) (const a) Proxy 186{-# INLINE_UNSAFE_COERCE reify #-} 187 188#if __GLASGOW_HASKELL__ >= 707 189instance KnownNat n => Reifies n Integer where 190 reflect = natVal 191 192instance KnownSymbol n => Reifies n String where 193 reflect = symbolVal 194#endif 195 196#if __GLASGOW_HASKELL__ >= 708 197 198-------------------------------------------------------------------------------- 199-- KnownNat 200-------------------------------------------------------------------------------- 201 202newtype MagicNat r = MagicNat (forall (n :: Nat). KnownNat n => Proxy n -> r) 203 204-- | This upgraded version of 'reify' can be used to generate a 'KnownNat' suitable for use with other APIs. 205-- 206-- Attemping to pass a negative 'Integer' as an argument will result in an 207-- 'Underflow' exception. 208-- 209-- /Available only on GHC 7.8+/ 210-- 211-- >>> reifyNat 4 natVal 212-- 4 213-- 214-- >>> reifyNat 4 reflect 215-- 4 216 217reifyNat :: forall r. Integer -> (forall (n :: Nat). KnownNat n => Proxy n -> r) -> r 218reifyNat n k = unsafeCoerce (MagicNat k :: MagicNat r) 219# if MIN_VERSION_base(4,10,0) 220 -- Starting with base-4.10, the internal 221 -- representation of KnownNat changed from Integer 222 -- to Natural, so make sure to perform the same 223 -- conversion before unsafeCoercing. 224 (fromInteger n :: Natural) 225# else 226 (if n < 0 then throw Underflow else n) 227# endif 228 Proxy 229{-# INLINE_UNSAFE_COERCE reifyNat #-} 230 231-------------------------------------------------------------------------------- 232-- KnownSymbol 233-------------------------------------------------------------------------------- 234 235newtype MagicSymbol r = MagicSymbol (forall (n :: Symbol). KnownSymbol n => Proxy n -> r) 236 237-- | This upgraded version of 'reify' can be used to generate a 'KnownSymbol' suitable for use with other APIs. 238-- 239-- /Available only on GHC 7.8+/ 240-- 241-- >>> reifySymbol "hello" symbolVal 242-- "hello" 243-- 244-- >>> reifySymbol "hello" reflect 245-- "hello" 246reifySymbol :: forall r. String -> (forall (n :: Symbol). KnownSymbol n => Proxy n -> r) -> r 247reifySymbol n k = unsafeCoerce (MagicSymbol k :: MagicSymbol r) n Proxy 248{-# INLINE_UNSAFE_COERCE reifySymbol #-} 249#endif 250 251------------------------------------------------------------------------------ 252-- Given 253------------------------------------------------------------------------------ 254 255-- | This is a version of 'Reifies' that allows for only a single value. 256-- 257-- This is easier to work with than 'Reifies' and permits extended defaulting, 258-- but it only offers a single reflected value of a given type at a time. 259class Given a where 260 -- | Recover the value of a given type previously encoded with 'give'. 261 given :: a 262 263newtype Gift a r = Gift (Given a => r) 264 265-- | Reify a value into an instance to be recovered with 'given'. 266-- 267-- You should /only/ 'give' a single value for each type. If multiple instances 268-- are in scope, then the behavior is implementation defined. 269give :: forall a r. a -> (Given a => r) -> r 270give a k = unsafeCoerce (Gift k :: Gift a r) a 271{-# INLINE_UNSAFE_COERCE give #-} 272 273-------------------------------------------------------------------------------- 274-- Explicit Numeric Reflection 275-------------------------------------------------------------------------------- 276 277-- | 0 278data Z 279-- | 2/n/ 280data D (n :: *) 281-- | 2/n/ + 1 282data SD (n :: *) 283-- | 2/n/ - 1 284data PD (n :: *) 285 286instance Reifies Z Int where 287 reflect _ = 0 288 {-# INLINE reflect #-} 289 290retagD :: (Proxy n -> a) -> proxy (D n) -> a 291retagD f _ = f Proxy 292{-# INLINE retagD #-} 293 294retagSD :: (Proxy n -> a) -> proxy (SD n) -> a 295retagSD f _ = f Proxy 296{-# INLINE retagSD #-} 297 298retagPD :: (Proxy n -> a) -> proxy (PD n) -> a 299retagPD f _ = f Proxy 300{-# INLINE retagPD #-} 301 302instance Reifies n Int => Reifies (D n) Int where 303 reflect = (\n -> n + n) `fmap` retagD reflect 304 {-# INLINE reflect #-} 305 306instance Reifies n Int => Reifies (SD n) Int where 307 reflect = (\n -> n + n + 1) `fmap` retagSD reflect 308 {-# INLINE reflect #-} 309 310instance Reifies n Int => Reifies (PD n) Int where 311 reflect = (\n -> n + n - 1) `fmap` retagPD reflect 312 {-# INLINE reflect #-} 313 314#ifdef MIN_VERSION_template_haskell 315-- | This can be used to generate a template haskell splice for a type level version of a given 'int'. 316-- 317-- This does not use GHC TypeLits, instead it generates a numeric type by hand similar to the ones used 318-- in the \"Functional Pearl: Implicit Configurations\" paper by Oleg Kiselyov and Chung-Chieh Shan. 319-- 320-- @instance Num (Q Exp)@ provided in this package allows writing @$(3)@ 321-- instead of @$(int 3)@. Sometimes the two will produce the same 322-- representation (if compiled without the @-DUSE_TYPE_LITS@ preprocessor 323-- directive). 324int :: Int -> TypeQ 325int n = case quotRem n 2 of 326 (0, 0) -> conT ''Z 327 (q,-1) -> conT ''PD `appT` int q 328 (q, 0) -> conT ''D `appT` int q 329 (q, 1) -> conT ''SD `appT` int q 330 _ -> error "ghc is bad at math" 331 332-- | This is a restricted version of 'int' that can only generate natural numbers. Attempting to generate 333-- a negative number results in a compile time error. Also the resulting sequence will consist entirely of 334-- Z, D, and SD constructors representing the number in zeroless binary. 335nat :: Int -> TypeQ 336nat n 337 | n >= 0 = int n 338 | otherwise = error "nat: negative" 339 340#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 704 341instance Show (Q a) where 342 show _ = "Q" 343instance Eq (Q a) where 344 _ == _ = False 345#endif 346instance Num a => Num (Q a) where 347 (+) = liftM2 (+) 348 (*) = liftM2 (*) 349 (-) = liftM2 (-) 350 negate = fmap negate 351 abs = fmap abs 352 signum = fmap signum 353 fromInteger = return . fromInteger 354 355instance Fractional a => Fractional (Q a) where 356 (/) = liftM2 (/) 357 recip = fmap recip 358 fromRational = return . fromRational 359 360-- | This permits the use of $(5) as a type splice. 361instance Num Type where 362#ifdef USE_TYPE_LITS 363 LitT (NumTyLit a) + LitT (NumTyLit b) = LitT (NumTyLit (a+b)) 364 a + b = AppT (AppT (VarT ''(+)) a) b 365 366 LitT (NumTyLit a) * LitT (NumTyLit b) = LitT (NumTyLit (a*b)) 367 (*) a b = AppT (AppT (VarT ''(GHC.TypeLits.*)) a) b 368#if MIN_VERSION_base(4,8,0) 369 a - b = AppT (AppT (VarT ''(-)) a) b 370#else 371 (-) = error "Type.(-): undefined" 372#endif 373 fromInteger = LitT . NumTyLit 374#else 375 (+) = error "Type.(+): undefined" 376 (*) = error "Type.(*): undefined" 377 (-) = error "Type.(-): undefined" 378 fromInteger n = case quotRem n 2 of 379 (0, 0) -> ConT ''Z 380 (q,-1) -> ConT ''PD `AppT` fromInteger q 381 (q, 0) -> ConT ''D `AppT` fromInteger q 382 (q, 1) -> ConT ''SD `AppT` fromInteger q 383 _ -> error "ghc is bad at math" 384#endif 385 abs = error "Type.abs" 386 signum = error "Type.signum" 387 388onProxyType1 :: (Type -> Type) -> (Exp -> Exp) 389onProxyType1 f 390 (SigE _ ta@(AppT (ConT proxyName) (VarT _))) 391 | proxyName == ''Proxy = ConE 'Proxy `SigE` (ConT ''Proxy `AppT` f ta) 392onProxyType1 f a = 393 LamE [SigP WildP na] body `AppE` a 394 where 395 body = ConE 'Proxy `SigE` (ConT ''Proxy `AppT` f na) 396 na = VarT (mkName "na") 397 398onProxyType2 :: Name -> (Type -> Type -> Type) -> (Exp -> Exp -> Exp) 399onProxyType2 _fName f 400 (SigE _ (AppT (ConT proxyName) ta)) 401 (SigE _ (AppT (ConT proxyName') tb)) 402 | proxyName == ''Proxy, 403 proxyName' == ''Proxy = ConE 'Proxy `SigE` 404 (ConT ''Proxy `AppT` f ta tb) 405-- the above case should only match for things like $(2 + 2) 406onProxyType2 fName _f a b = VarE fName `AppE` a `AppE` b 407 408-- | This permits the use of $(5) as an expression splice, 409-- which stands for @Proxy :: Proxy $(5)@ 410instance Num Exp where 411 (+) = onProxyType2 'addProxy (+) 412 (*) = onProxyType2 'mulProxy (*) 413 (-) = onProxyType2 'subProxy (-) 414 negate = onProxyType1 negate 415 abs = onProxyType1 abs 416 signum = onProxyType1 signum 417 fromInteger n = ConE 'Proxy `SigE` (ConT ''Proxy `AppT` fromInteger n) 418 419#ifdef USE_TYPE_LITS 420addProxy :: Proxy a -> Proxy b -> Proxy (a + b) 421addProxy _ _ = Proxy 422mulProxy :: Proxy a -> Proxy b -> Proxy (a * b) 423mulProxy _ _ = Proxy 424#if MIN_VERSION_base(4,8,0) 425subProxy :: Proxy a -> Proxy b -> Proxy (a - b) 426subProxy _ _ = Proxy 427#else 428subProxy :: Proxy a -> Proxy b -> Proxy c 429subProxy _ _ = error "Exp.(-): undefined" 430#endif 431-- fromInteger = LitT . NumTyLit 432#else 433addProxy :: Proxy a -> Proxy b -> Proxy c 434addProxy _ _ = error "Exp.(+): undefined" 435mulProxy :: Proxy a -> Proxy b -> Proxy c 436mulProxy _ _ = error "Exp.(*): undefined" 437subProxy :: Proxy a -> Proxy b -> Proxy c 438subProxy _ _ = error "Exp.(-): undefined" 439#endif 440 441#endif 442 443-------------------------------------------------------------------------------- 444-- * Typeable Reflection 445-------------------------------------------------------------------------------- 446 447 448class Typeable s => B s where 449 reflectByte :: proxy s -> IntPtr 450 451#define BYTES(GO) \ 452 GO(T0,0) GO(T1,1) GO(T2,2) GO(T3,3) GO(T4,4) GO(T5,5) GO(T6,6) GO(T7,7) GO(T8,8) GO(T9,9) GO(T10,10) GO(T11,11) \ 453 GO(T12,12) GO(T13,13) GO(T14,14) GO(T15,15) GO(T16,16) GO(T17,17) GO(T18,18) GO(T19,19) GO(T20,20) GO(T21,21) GO(T22,22) \ 454 GO(T23,23) GO(T24,24) GO(T25,25) GO(T26,26) GO(T27,27) GO(T28,28) GO(T29,29) GO(T30,30) GO(T31,31) GO(T32,32) GO(T33,33) \ 455 GO(T34,34) GO(T35,35) GO(T36,36) GO(T37,37) GO(T38,38) GO(T39,39) GO(T40,40) GO(T41,41) GO(T42,42) GO(T43,43) GO(T44,44) \ 456 GO(T45,45) GO(T46,46) GO(T47,47) GO(T48,48) GO(T49,49) GO(T50,50) GO(T51,51) GO(T52,52) GO(T53,53) GO(T54,54) GO(T55,55) \ 457 GO(T56,56) GO(T57,57) GO(T58,58) GO(T59,59) GO(T60,60) GO(T61,61) GO(T62,62) GO(T63,63) GO(T64,64) GO(T65,65) GO(T66,66) \ 458 GO(T67,67) GO(T68,68) GO(T69,69) GO(T70,70) GO(T71,71) GO(T72,72) GO(T73,73) GO(T74,74) GO(T75,75) GO(T76,76) GO(T77,77) \ 459 GO(T78,78) GO(T79,79) GO(T80,80) GO(T81,81) GO(T82,82) GO(T83,83) GO(T84,84) GO(T85,85) GO(T86,86) GO(T87,87) GO(T88,88) \ 460 GO(T89,89) GO(T90,90) GO(T91,91) GO(T92,92) GO(T93,93) GO(T94,94) GO(T95,95) GO(T96,96) GO(T97,97) GO(T98,98) GO(T99,99) \ 461 GO(T100,100) GO(T101,101) GO(T102,102) GO(T103,103) GO(T104,104) GO(T105,105) GO(T106,106) GO(T107,107) GO(T108,108) \ 462 GO(T109,109) GO(T110,110) GO(T111,111) GO(T112,112) GO(T113,113) GO(T114,114) GO(T115,115) GO(T116,116) GO(T117,117) \ 463 GO(T118,118) GO(T119,119) GO(T120,120) GO(T121,121) GO(T122,122) GO(T123,123) GO(T124,124) GO(T125,125) GO(T126,126) \ 464 GO(T127,127) GO(T128,128) GO(T129,129) GO(T130,130) GO(T131,131) GO(T132,132) GO(T133,133) GO(T134,134) GO(T135,135) \ 465 GO(T136,136) GO(T137,137) GO(T138,138) GO(T139,139) GO(T140,140) GO(T141,141) GO(T142,142) GO(T143,143) GO(T144,144) \ 466 GO(T145,145) GO(T146,146) GO(T147,147) GO(T148,148) GO(T149,149) GO(T150,150) GO(T151,151) GO(T152,152) GO(T153,153) \ 467 GO(T154,154) GO(T155,155) GO(T156,156) GO(T157,157) GO(T158,158) GO(T159,159) GO(T160,160) GO(T161,161) GO(T162,162) \ 468 GO(T163,163) GO(T164,164) GO(T165,165) GO(T166,166) GO(T167,167) GO(T168,168) GO(T169,169) GO(T170,170) GO(T171,171) \ 469 GO(T172,172) GO(T173,173) GO(T174,174) GO(T175,175) GO(T176,176) GO(T177,177) GO(T178,178) GO(T179,179) GO(T180,180) \ 470 GO(T181,181) GO(T182,182) GO(T183,183) GO(T184,184) GO(T185,185) GO(T186,186) GO(T187,187) GO(T188,188) GO(T189,189) \ 471 GO(T190,190) GO(T191,191) GO(T192,192) GO(T193,193) GO(T194,194) GO(T195,195) GO(T196,196) GO(T197,197) GO(T198,198) \ 472 GO(T199,199) GO(T200,200) GO(T201,201) GO(T202,202) GO(T203,203) GO(T204,204) GO(T205,205) GO(T206,206) GO(T207,207) \ 473 GO(T208,208) GO(T209,209) GO(T210,210) GO(T211,211) GO(T212,212) GO(T213,213) GO(T214,214) GO(T215,215) GO(T216,216) \ 474 GO(T217,217) GO(T218,218) GO(T219,219) GO(T220,220) GO(T221,221) GO(T222,222) GO(T223,223) GO(T224,224) GO(T225,225) \ 475 GO(T226,226) GO(T227,227) GO(T228,228) GO(T229,229) GO(T230,230) GO(T231,231) GO(T232,232) GO(T233,233) GO(T234,234) \ 476 GO(T235,235) GO(T236,236) GO(T237,237) GO(T238,238) GO(T239,239) GO(T240,240) GO(T241,241) GO(T242,242) GO(T243,243) \ 477 GO(T244,244) GO(T245,245) GO(T246,246) GO(T247,247) GO(T248,248) GO(T249,249) GO(T250,250) GO(T251,251) GO(T252,252) \ 478 GO(T253,253) GO(T254,254) GO(T255,255) 479 480#define GO(Tn,n) \ 481 newtype Tn = Tn Tn deriving Typeable; \ 482 instance B Tn where { \ 483 reflectByte _ = n \ 484 }; 485BYTES(GO) 486#undef GO 487 488impossible :: a 489impossible = error "Data.Reflection.reifyByte: impossible" 490 491reifyByte :: Word8 -> (forall (s :: *). B s => Proxy s -> r) -> r 492reifyByte w k = case w of { 493#define GO(Tn,n) n -> k (Proxy :: Proxy Tn); 494BYTES(GO) 495#undef GO 496_ -> impossible 497} 498 499newtype W (b0 :: *) (b1 :: *) (b2 :: *) (b3 :: *) = W (W b0 b1 b2 b3) deriving Typeable 500newtype Stable (w0 :: *) (w1 :: *) (a :: *) = Stable (Stable w0 w1 a) deriving Typeable 501 502stable :: p b0 -> p b1 -> p b2 -> p b3 -> p b4 -> p b5 -> p b6 -> p b7 503 -> Proxy (Stable (W b0 b1 b2 b3) (W b4 b5 b6 b7) a) 504stable _ _ _ _ _ _ _ _ = Proxy 505{-# INLINE stable #-} 506 507stablePtrToIntPtr :: StablePtr a -> IntPtr 508stablePtrToIntPtr = ptrToIntPtr . castStablePtrToPtr 509{-# INLINE stablePtrToIntPtr #-} 510 511intPtrToStablePtr :: IntPtr -> StablePtr a 512intPtrToStablePtr = castPtrToStablePtr . intPtrToPtr 513{-# INLINE intPtrToStablePtr #-} 514 515byte0 :: p (Stable (W b0 b1 b2 b3) w1 a) -> Proxy b0 516byte0 _ = Proxy 517 518byte1 :: p (Stable (W b0 b1 b2 b3) w1 a) -> Proxy b1 519byte1 _ = Proxy 520 521byte2 :: p (Stable (W b0 b1 b2 b3) w1 a) -> Proxy b2 522byte2 _ = Proxy 523 524byte3 :: p (Stable (W b0 b1 b2 b3) w1 a) -> Proxy b3 525byte3 _ = Proxy 526 527byte4 :: p (Stable w0 (W b4 b5 b6 b7) a) -> Proxy b4 528byte4 _ = Proxy 529 530byte5 :: p (Stable w0 (W b4 b5 b6 b7) a) -> Proxy b5 531byte5 _ = Proxy 532 533byte6 :: p (Stable w0 (W b4 b5 b6 b7) a) -> Proxy b6 534byte6 _ = Proxy 535 536byte7 :: p (Stable w0 (W b4 b5 b6 b7) a) -> Proxy b7 537byte7 _ = Proxy 538 539argument :: (p s -> r) -> Proxy s 540argument _ = Proxy 541 542instance (B b0, B b1, B b2, B b3, B b4, B b5, B b6, B b7, w0 ~ W b0 b1 b2 b3, w1 ~ W b4 b5 b6 b7) 543 => Reifies (Stable w0 w1 a) a where 544 reflect = r where 545 r = unsafePerformIO $ const <$> deRefStablePtr p <* freeStablePtr p 546 s = argument r 547 p = intPtrToStablePtr $ 548 reflectByte (byte0 s) .|. 549 (reflectByte (byte1 s) `shiftL` 8) .|. 550 (reflectByte (byte2 s) `shiftL` 16) .|. 551 (reflectByte (byte3 s) `shiftL` 24) .|. 552 (reflectByte (byte4 s) `shiftL` 32) .|. 553 (reflectByte (byte5 s) `shiftL` 40) .|. 554 (reflectByte (byte6 s) `shiftL` 48) .|. 555 (reflectByte (byte7 s) `shiftL` 56) 556 {-# NOINLINE reflect #-} 557 558-- This had to be moved to the top level, due to an apparent bug in 559-- the ghc inliner introduced in ghc 7.0.x 560reflectBefore :: forall (proxy :: * -> *) s b. (Proxy s -> b) -> proxy s -> b 561reflectBefore f = const $! f Proxy 562{-# NOINLINE reflectBefore #-} 563 564-- | Reify a value at the type level in a 'Typeable'-compatible fashion, to be recovered with 'reflect'. 565-- 566-- This can be necessary to work around the changes to @Data.Typeable@ in GHC HEAD. 567reifyTypeable :: Typeable a => a -> (forall (s :: *). (Typeable s, Reifies s a) => Proxy s -> r) -> r 568#if MIN_VERSION_base(4,4,0) 569reifyTypeable a k = unsafeDupablePerformIO $ do 570#else 571reifyTypeable a k = unsafePerformIO $ do 572#endif 573 p <- newStablePtr a 574 let n = stablePtrToIntPtr p 575 reifyByte (fromIntegral n) (\s0 -> 576 reifyByte (fromIntegral (n `shiftR` 8)) (\s1 -> 577 reifyByte (fromIntegral (n `shiftR` 16)) (\s2 -> 578 reifyByte (fromIntegral (n `shiftR` 24)) (\s3 -> 579 reifyByte (fromIntegral (n `shiftR` 32)) (\s4 -> 580 reifyByte (fromIntegral (n `shiftR` 40)) (\s5 -> 581 reifyByte (fromIntegral (n `shiftR` 48)) (\s6 -> 582 reifyByte (fromIntegral (n `shiftR` 56)) (\s7 -> 583 reflectBefore (fmap return k) $ 584 stable s0 s1 s2 s3 s4 s5 s6 s7)))))))) 585 586 587data ReifiedMonoid a = ReifiedMonoid { reifiedMappend :: a -> a -> a, reifiedMempty :: a } 588 589instance Reifies s (ReifiedMonoid a) => Sem.Semigroup (ReflectedMonoid a s) where 590 ReflectedMonoid x <> ReflectedMonoid y = reflectResult (\m -> ReflectedMonoid (reifiedMappend m x y)) 591 592instance Reifies s (ReifiedMonoid a) => Monoid (ReflectedMonoid a s) where 593#if !(MIN_VERSION_base(4,11,0)) 594 mappend = (<>) 595#endif 596 mempty = reflectResult (\m -> ReflectedMonoid (reifiedMempty m )) 597 598reflectResult :: forall f s a. Reifies s a => (a -> f s) -> f s 599reflectResult f = f (reflect (Proxy :: Proxy s)) 600 601newtype ReflectedMonoid a s = ReflectedMonoid a 602 603unreflectedMonoid :: ReflectedMonoid a s -> proxy s -> a 604unreflectedMonoid (ReflectedMonoid a) _ = a 605 606reifyMonoid :: (a -> a -> a) -> a -> (forall (s :: *). Reifies s (ReifiedMonoid a) => t -> ReflectedMonoid a s) -> t -> a 607reifyMonoid f z m xs = reify (ReifiedMonoid f z) (unreflectedMonoid (m xs)) 608 609-- | Fold a value using its 'Foldable' instance using 610-- explicitly provided 'Monoid' operations. This is like 'fold' 611-- where the 'Monoid' instance can be manually specified. 612-- 613-- @ 614-- 'foldBy' 'mappend' 'mempty' ≡ 'fold' 615-- @ 616-- 617-- >>> foldBy (++) [] ["hello","world"] 618-- "helloworld" 619foldBy :: Foldable t => (a -> a -> a) -> a -> t a -> a 620foldBy f z = reifyMonoid f z (foldMap ReflectedMonoid) 621 622-- | Fold a value using its 'Foldable' instance using 623-- explicitly provided 'Monoid' operations. This is like 'foldMap' 624-- where the 'Monoid' instance can be manually specified. 625-- 626-- @ 627-- 'foldMapBy' 'mappend' 'mempty' ≡ 'foldMap' 628-- @ 629-- 630-- >>> foldMapBy (+) 0 length ["hello","world"] 631-- 10 632foldMapBy :: Foldable t => (r -> r -> r) -> r -> (a -> r) -> t a -> r 633foldMapBy f z g = reifyMonoid f z (foldMap (ReflectedMonoid #. g)) 634 635data ReifiedApplicative f = ReifiedApplicative { reifiedPure :: forall a. a -> f a, reifiedAp :: forall a b. f (a -> b) -> f a -> f b } 636 637newtype ReflectedApplicative f s a = ReflectedApplicative (f a) 638 639instance Reifies s (ReifiedApplicative f) => Functor (ReflectedApplicative f s) where 640 fmap = liftA 641 642instance Reifies s (ReifiedApplicative f) => Applicative (ReflectedApplicative f s) where 643 pure a = reflectResult1 (\m -> ReflectedApplicative (reifiedPure m a)) 644 ReflectedApplicative x <*> ReflectedApplicative y = reflectResult1 (\m -> ReflectedApplicative (reifiedAp m x y)) 645 646reflectResult1 :: forall f s a b. Reifies s a => (a -> f s b) -> f s b 647reflectResult1 f = f (reflect (Proxy :: Proxy s)) 648 649unreflectedApplicative :: ReflectedApplicative f s a -> proxy s -> f a 650unreflectedApplicative (ReflectedApplicative a) _ = a 651 652reifyApplicative :: (forall x. x -> f x) -> (forall x y. f (x -> y) -> f x -> f y) -> (forall (s :: *). Reifies s (ReifiedApplicative f) => t -> ReflectedApplicative f s a) -> t -> f a 653reifyApplicative f g m xs = reify (ReifiedApplicative f g) (unreflectedApplicative (m xs)) 654 655-- | Traverse a container using its 'Traversable' instance using 656-- explicitly provided 'Applicative' operations. This is like 'traverse' 657-- where the 'Applicative' instance can be manually specified. 658traverseBy :: Traversable t => (forall x. x -> f x) -> (forall x y. f (x -> y) -> f x -> f y) -> (a -> f b) -> t a -> f (t b) 659traverseBy pur app f = reifyApplicative pur app (traverse (ReflectedApplicative #. f)) 660 661-- | Sequence a container using its 'Traversable' instance using 662-- explicitly provided 'Applicative' operations. This is like 'sequence' 663-- where the 'Applicative' instance can be manually specified. 664sequenceBy :: Traversable t => (forall x. x -> f x) -> (forall x y. f (x -> y) -> f x -> f y) -> t (f a) -> f (t a) 665sequenceBy pur app = reifyApplicative pur app (traverse ReflectedApplicative) 666 667(#.) :: (b -> c) -> (a -> b) -> a -> c 668(#.) _ = unsafeCoerce 669