1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-cse #-}
{-# OPTIONS_GHC -fno-full-laziness #-}
{-# OPTIONS_GHC -fno-float-in #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
----------------------------------------------------------------------------
-- |
-- Module : Data.Reflection
-- Copyright : 2009-2012 Edward Kmett,
-- 2012 Elliott Hird,
-- 2004 Oleg Kiselyov and Chung-chieh Shan
-- License : BSD3
--
-- Maintainer : Edward Kmett <ekmett@gmail.com>
-- Stability : experimental
-- Portability : non-portable
--
-- Reifies arbitrary terms at the type level. Based on the Functional
-- Pearl: Implicit Configurations paper by Oleg Kiselyov and
-- Chung-chieh Shan.
--
-- <http://okmij.org/ftp/Haskell/tr-15-04.pdf>
--
-- The approach from the paper was modified to work with Data.Proxy
-- and streamline the API by Edward Kmett and Elliott Hird.
--
-- Usage comes down to two combinators, 'reify' and 'reflect'.
--
-- >>> reify 6 (\p -> reflect p + reflect p)
-- 12
--
-- The argument passed along by reify is just a @data 'Proxy' t =
-- Proxy@, so all of the information needed to reconstruct your value
-- has been moved to the type level. This enables it to be used when
-- constructing instances (see @examples/Monoid.hs@).
-------------------------------------------------------------------------------
module Data.Reflection
(
Reifies(..)
, reify
) where
import Foreign.Ptr
import Foreign.StablePtr
import System.IO.Unsafe
import Control.Applicative
import Control.Exception
import Data.Proxy
import Data.Bits
import Data.Word
#ifdef __HUGS__
#define unsafeDupablePerformIO unsafePerformIO
#endif
class B s where
reflectByte :: proxy s -> IntPtr
#define CAT(a,b) a/**/b
#define BYTES(GO) \
GO(0) GO(1) GO(2) GO(3) GO(4) GO(5) GO(6) GO(7) GO(8) GO(9) GO(10) GO(11) \
GO(12) GO(13) GO(14) GO(15) GO(16) GO(17) GO(18) GO(19) GO(20) GO(21) GO(22) \
GO(23) GO(24) GO(25) GO(26) GO(27) GO(28) GO(29) GO(30) GO(31) GO(32) GO(33) \
GO(34) GO(35) GO(36) GO(37) GO(38) GO(39) GO(40) GO(41) GO(42) GO(43) GO(44) \
GO(45) GO(46) GO(47) GO(48) GO(49) GO(50) GO(51) GO(52) GO(53) GO(54) GO(55) \
GO(56) GO(57) GO(58) GO(59) GO(60) GO(61) GO(62) GO(63) GO(64) GO(65) GO(66) \
GO(67) GO(68) GO(69) GO(70) GO(71) GO(72) GO(73) GO(74) GO(75) GO(76) GO(77) \
GO(78) GO(79) GO(80) GO(81) GO(82) GO(83) GO(84) GO(85) GO(86) GO(87) GO(88) \
GO(89) GO(90) GO(91) GO(92) GO(93) GO(94) GO(95) GO(96) GO(97) GO(98) GO(99) \
GO(100) GO(101) GO(102) GO(103) GO(104) GO(105) GO(106) GO(107) GO(108) \
GO(109) GO(110) GO(111) GO(112) GO(113) GO(114) GO(115) GO(116) GO(117) \
GO(118) GO(119) GO(120) GO(121) GO(122) GO(123) GO(124) GO(125) GO(126) \
GO(127) GO(128) GO(129) GO(130) GO(131) GO(132) GO(133) GO(134) GO(135) \
GO(136) GO(137) GO(138) GO(139) GO(140) GO(141) GO(142) GO(143) GO(144) \
GO(145) GO(146) GO(147) GO(148) GO(149) GO(150) GO(151) GO(152) GO(153) \
GO(154) GO(155) GO(156) GO(157) GO(158) GO(159) GO(160) GO(161) GO(162) \
GO(163) GO(164) GO(165) GO(166) GO(167) GO(168) GO(169) GO(170) GO(171) \
GO(172) GO(173) GO(174) GO(175) GO(176) GO(177) GO(178) GO(179) GO(180) \
GO(181) GO(182) GO(183) GO(184) GO(185) GO(186) GO(187) GO(188) GO(189) \
GO(190) GO(191) GO(192) GO(193) GO(194) GO(195) GO(196) GO(197) GO(198) \
GO(199) GO(200) GO(201) GO(202) GO(203) GO(204) GO(205) GO(206) GO(207) \
GO(208) GO(209) GO(210) GO(211) GO(212) GO(213) GO(214) GO(215) GO(216) \
GO(217) GO(218) GO(219) GO(220) GO(221) GO(222) GO(223) GO(224) GO(225) \
GO(226) GO(227) GO(228) GO(229) GO(230) GO(231) GO(232) GO(233) GO(234) \
GO(235) GO(236) GO(237) GO(238) GO(239) GO(240) GO(241) GO(242) GO(243) \
GO(244) GO(245) GO(246) GO(247) GO(248) GO(249) GO(250) GO(251) GO(252) \
GO(253) GO(254) GO(255)
#define GO(n) \
newtype CAT(T,n) = CAT(T,n) CAT(T,n); \
instance B CAT(T,n) where { \
reflectByte _ = n \
};
BYTES(GO)
#undef GO
impossible :: a
impossible = error "Data.Reflection.reifyByte: impossible"
reifyByte :: Word8 -> (forall s. B s => Proxy s -> r) -> r
reifyByte w k = case w of {
#define GO(n) n -> k (Proxy :: Proxy CAT(T,n));
BYTES(GO)
#undef GO
_ -> impossible
}
class Reifies s a | s -> a where
-- | Recover a value inside a 'reify' context, given a proxy for its
-- reified type.
reflect :: proxy s -> a
newtype StableBox b0 b1 b2 b3 b4 b5 b6 b7 a =
StableBox (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a)
newtype Stable b0 b1 b2 b3 b4 b5 b6 b7 a =
Stable (Stable b0 b1 b2 b3 b4 b5 b6 b7 a)
data Box a = Box a
stableBox :: p (Stable b0 b1 b2 b3 b4 b5 b6 b7 a)
-> Proxy (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a)
stableBox _ = Proxy
{-# INLINE stableBox #-}
stable :: p b0 -> p b1 -> p b2 -> p b3 -> p b4 -> p b5 -> p b6 -> p b7
-> Proxy (Stable b0 b1 b2 b3 b4 b5 b6 b7 a)
stable _ _ _ _ _ _ _ _ = Proxy
{-# INLINE stable #-}
stablePtrToIntPtr :: StablePtr a -> IntPtr
stablePtrToIntPtr = ptrToIntPtr . castStablePtrToPtr
{-# INLINE stablePtrToIntPtr #-}
intPtrToStablePtr :: IntPtr -> StablePtr a
intPtrToStablePtr = castPtrToStablePtr . intPtrToPtr
{-# INLINE intPtrToStablePtr #-}
byte0 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b0
byte0 _ = Proxy
byte1 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b1
byte1 _ = Proxy
byte2 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b2
byte2 _ = Proxy
byte3 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b3
byte3 _ = Proxy
byte4 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b4
byte4 _ = Proxy
byte5 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b5
byte5 _ = Proxy
byte6 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b6
byte6 _ = Proxy
byte7 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b7
byte7 _ = Proxy
argument :: (p s -> r) -> Proxy s
argument _ = Proxy
instance (B b0, B b1, B b2, B b3, B b4, B b5, B b6, B b7)
=> Reifies (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) (Box a) where
reflect = r where
r = unsafePerformIO $ const <$> deRefStablePtr p <* freeStablePtr p
s = argument r
p = intPtrToStablePtr $
reflectByte (byte0 s) .|.
(reflectByte (byte1 s) `shiftL` 8) .|.
(reflectByte (byte2 s) `shiftL` 16) .|.
(reflectByte (byte3 s) `shiftL` 24) .|.
(reflectByte (byte4 s) `shiftL` 32) .|.
(reflectByte (byte5 s) `shiftL` 40) .|.
(reflectByte (byte6 s) `shiftL` 48) .|.
(reflectByte (byte7 s) `shiftL` 56)
{-# NOINLINE reflect #-}
instance Reifies (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) (Box b)
=> Reifies (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) b where
reflect p = case reflect (stableBox p) of
Box a -> a
-- Ensure that exactly one dictionary of Reifies (StableBox ...) is created and
-- evaluated per reifyTypeable call.
--
-- Evaluating the dictionary's thunk frees the allocated StablePtr, and the
-- contents of the StablePtr replace the thunk. Creating two dictionaries would
-- mean a double free upon their evaluation, and leaving a dictionary
-- unevaluated would leak the StablePtr
-- (see https://github.com/ekmett/reflection/issues/54).
--
-- To separate evaluation of the dictionary and evaluation of the actual
-- argument passed to reifyTypeable, we insert a Box in between.
withStableBox
:: Reifies (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) (Box a)
=> (Reifies (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) a
=> Proxy (Stable b0 b1 b2 b3 b4 b5 b6 b7 a)
-> r)
-> Proxy (Stable b0 b1 b2 b3 b4 b5 b6 b7 a)
-> IO r
withStableBox k p = do
_ <- evaluate $ reflect (stableBox p)
evaluate $ k p
{-# NOINLINE withStableBox #-}
-- | Reify a value at the type level, to be recovered with 'reflect'.
reify :: a -> (forall s. (Reifies s a) => Proxy s -> r) -> r
reify a k = unsafeDupablePerformIO $ do
p <- newStablePtr a
let n = stablePtrToIntPtr p
reifyByte (fromIntegral n) (\s0 ->
reifyByte (fromIntegral (n `shiftR` 8)) (\s1 ->
reifyByte (fromIntegral (n `shiftR` 16)) (\s2 ->
reifyByte (fromIntegral (n `shiftR` 24)) (\s3 ->
reifyByte (fromIntegral (n `shiftR` 32)) (\s4 ->
reifyByte (fromIntegral (n `shiftR` 40)) (\s5 ->
reifyByte (fromIntegral (n `shiftR` 48)) (\s6 ->
reifyByte (fromIntegral (n `shiftR` 56)) (\s7 ->
withStableBox k $ stable s0 s1 s2 s3 s4 s5 s6 s7))))))))
|
