reflection 1.3.2 → 2.1.9
raw patch · 16 files changed
Files
- .hlint.yaml +2/−0
- .travis.yml +0/−1
- CHANGELOG.markdown +64/−0
- README.markdown +2/−2
- examples/Constraints.hs +19/−11
- examples/FromJSON.hs +74/−0
- examples/LICENSE +31/−0
- examples/Monoid.hs +14/−5
- examples/ReaderLike.hs +70/−0
- examples/reflection-examples.cabal +80/−0
- fast/Data/Reflection.hs +460/−63
- reflection.cabal +67/−19
- slow/Data/Reflection.hs +52/−18
- tests/ReifyNatSpec.hs +50/−0
- tests/Spec.hs +1/−0
- tests/T47Spec.hs +64/−0
+ .hlint.yaml view
@@ -0,0 +1,2 @@+- ignore: {name: Unused LANGUAGE pragma}+- ignore: {name: Avoid lambda}
− .travis.yml
@@ -1,1 +0,0 @@-language: haskell
CHANGELOG.markdown view
@@ -1,3 +1,67 @@+# 2.1.9 [2024.12.04]+* Drop support for pre-8.0 versions of GHC.++# 2.1.8 [2024.05.04]+* Fix a memory leak in `reifyTypeable`.++# 2.1.7 [2023.02.28]+* When building with `base-4.18` (GHC 9.6) or later, implement `reifyNat` and+ `reifySymbol` using the API provided by `GHC.TypeLits` instead of resorting+ to `unsafeCoerce`.++# 2.1.6 [2020.05.16]+* Fix a bug in which `give` (and possibly `reify`, `reifyNat`, and+ `reifySymbol`) could be unsoundly inlined by GHC 8.10 or older to produce+ incorrect runtime results.++# 2.1.5 [2019.08.27]+* Fix a bug in which `reifyNat` would yield incorrect results for very large+ `Integer`s on GHC 8.2 or later.++# 2.1.4 [2018.07.02]+* Allow building with GHC 8.6.++# 2.1.3 [2018.01.18]+* Add `Semigroup` instance for `ReflectedMonoid`.++# 2.1.2+* Support cross-compilation and unregistered GHC builds.++# 2.1.1.1+* Fixed typos in the documentation.++# 2.1.1+* Fixed support for GHC 7.0++# 2.1+* Added `ReifiedMonoid` and `ReifiedApplicative`.++# 2+* Added `reifyNat` and `reifySymbol` for GHC 7.8+, capable of reflecting into the `KnownNat` and `KnownSymbol` classes respectively for use with other APIs.+* Back-ported `reifyTypeable` from `lens`. This enables us to perform a (less efficient) form of `Typeable` reflection.++# 1.5.2+* Renamed the flag for disabling the use of `template-haskell`, to `-f-template-haskell` for consistency with my other packages.++# 1.5.1.2+* Builds warning-free on GHC 7.10.+* Added a dynamic FromJSON example.++# 1.5.1.1+* Updated the link to the paper.+* More examples.++# 1.5.1+* We no longer export Show (Q a) for GHC >= 7.4. This was causing random hangs when users tried to somehow run declaration splices from the REPL.+* We no longer depend on tagged for GHC >= 7.8, since `Proxy` is now in `base`.++# 1.5+* Added a flag to disable `template-haskell` support for GHC stage1 platforms.+* Added instances of `Reifies` for `GHC.TypeLits`++# 1.4+* Changed the behavior of the $(1) template haskell splices for Exp to use a Proxy rather than value-level numbers. This is more consistent with the role of this libraary and the other could always be generated via sa splice anyways.+ # 1.3.1 * Added a workaround for changes in the behavior of the internal 'Magic' datatype under the current GHC PolyKinds implementation.
README.markdown view
@@ -1,9 +1,9 @@ reflection ========== -[](http://travis-ci.org/ekmett/reflecton)+[](https://hackage.haskell.org/package/reflection) [](https://github.com/ekmett/reflection/actions?query=workflow%3AHaskell-CI) -This package provides an implementation of the ideas presented in [Functional Pearl: Implicit Configurations](http://www.cs.rutgers.edu/~ccshan/prepose/prepose.pdf) by Oleg Kiselyov and Chung-Chieh Shan. However, the API has been implemented in a much more efficient manner.+This package provides an implementation of the ideas presented in [Functional Pearl: Implicit Configurations](http://okmij.org/ftp/Haskell/tr-15-04.pdf) by Oleg Kiselyov and Chung-Chieh Shan. However, the API has been implemented in a much more efficient manner. Contact Information -------------------
examples/Constraints.hs view
@@ -1,19 +1,24 @@-{-# LANGUAGE Rank2Types, TypeFamilies, TypeOperators, ConstraintKinds, PolyKinds, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, FlexibleContexts, UndecidableInstances #-}-import Control.Newtype -- from newtype-import Data.Constraint -- from constraints-import Data.Constraint.Unsafe -- from constraints-import Data.Monoid -- from base-import Data.Proxy -- from tagged-import Data.Reflection -- from reflection+{-# LANGUAGE Rank2Types, TypeFamilies, TypeOperators, ConstraintKinds, PolyKinds, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, FlexibleContexts, UndecidableInstances, CPP #-}+module Constraints where --- | Values in our dynamically constructed monoid over 'a'+import Control.Newtype.Generics -- from newtype-generics+import Data.Constraint -- from constraints+import Data.Constraint.Unsafe -- from constraints+import Data.Proxy -- from tagged+import Data.Reflection -- from reflection+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup -- from semigroups+#endif++-- | Values in our dynamically constructed monoid over @a@ newtype Lift (p :: * -> Constraint) (a :: *) (s :: *) = Lift { lower :: a } class ReifiableConstraint p where data Def (p :: * -> Constraint) (a :: *) reifiedIns :: Reifies s (Def p a) :- p (Lift p a s) -instance Newtype (Lift p a s) a where+instance Newtype (Lift p a s) where+ type O (Lift p a s) = a pack = Lift unpack = lower @@ -22,7 +27,7 @@ with :: Def p a -> (forall s. Reifies s (Def p a) => Lift p a s) -> a with d v = reify d $ lower . asProxyOf v -reifyInstance :: Def p a -> (forall s. Reifies s (Def p a) => Proxy s -> r) -> r+reifyInstance :: Def p a -> (forall (s :: *). Reifies s (Def p a) => Proxy s -> r) -> r reifyInstance = reify asProxyOf :: f s -> Proxy s -> f s@@ -40,8 +45,11 @@ data Def Monoid a = Monoid { mappend_ :: a -> a -> a, mempty_ :: a } reifiedIns = Sub Dict +instance Reifies s (Def Monoid a) => Semigroup (Lift Monoid a s) where+ a <> b = Lift $ mappend_ (reflect a) (lower a) (lower b)+ instance Reifies s (Def Monoid a) => Monoid (Lift Monoid a s) where- mappend a b = Lift $ mappend_ (reflect a) (lower a) (lower b)+ mappend = (<>) mempty = a where a = Lift $ mempty_ (reflect a) data ClassProxy (p :: * -> Constraint) = ClassProxy
+ examples/FromJSON.hs view
@@ -0,0 +1,74 @@+-- Example of a dynamically generated FromJSON instance.+--+-- Can be useful when one needs to use a function with a+-- FromJSON constraint, but some detail about the+-- conversion from JSON is not known until runtime.+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}++import Data.Aeson -- from aeson+import qualified Data.Aeson.Key as Key+import Data.Aeson.Types (Parser)+import Data.Proxy -- from tagged+import Data.Reflection -- from reflection+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup -- from base+#endif+import Data.Text (Text, pack) -- from text++import Control.Applicative++-- These imports are only for constructing the example value+import Lens.Micro.Aeson (_Value) -- form microlens-aeson+import Lens.Micro.Extras (preview) -- from microlens++data Foo = Foo+ {+ field1 :: Int+ , field2 :: Int+ } deriving (Show)++fooParser :: Text -> Object -> Parser Foo+fooParser prefix o = do+ Foo <$> o .: (Key.fromText prefix <> "field1") <*> o .: (Key.fromText prefix <> "field2")++-- A wrapper over Foo carrying a phantom type s+newtype J a s = J { runJ :: a }++-- If the phantom type s reifies the parsing function, we can+-- use reflect to recover the function and implement+-- our FromJSON instance for J.+instance Reifies s (Object -> Parser a) => FromJSON (J a s) where+ parseJSON (Object v) = J <$> reflect (Proxy :: Proxy s) v+ parseJSON _ = empty++-- Convince the compiler that the phantom type in the proxy+-- supplied by reify is the same as the phantom type in J.+--+-- Otherwise the FromJSON instance for J won't kick in.+asProxyJ :: Proxy s -> J a s -> J a s+asProxyJ _ = id++exampleJSON :: Value+exampleJSON = maybe Null id (preview _Value str)+ where+ str = "{ \"zzfield1\" : 5, \"zzfield2\" : 7 }"::Text++main :: IO ()+main = do+ putStrLn "Enter prefix for the fields: "+ -- "zz" must be entered for the parse to succeed+ prefix <- fmap pack getLine++ -- fromJSON uses the dynamically generated FromJSON instance+ let result = reify (fooParser prefix) $ \proxy ->+ -- We must eliminate the J newtype before returning+ -- because, thanks to parametricity,+ -- the phantom type cannot escape the callback.+ runJ . asProxyJ proxy <$> fromJSON exampleJSON++ putStrLn (show (result :: Result Foo))
+ examples/LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2009-2013 Edward Kmett+Copyright (c) 2004 Oleg Kiselyov and Chung-chieh Shan+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Edward Kmett nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
examples/Monoid.hs view
@@ -1,16 +1,25 @@-{-# LANGUAGE Rank2Types, FlexibleContexts, UndecidableInstances #-}-import Data.Reflection -- from reflection-import Data.Monoid -- from base+{-# LANGUAGE CPP, Rank2Types, FlexibleContexts, UndecidableInstances #-}+module Monoid where+ import Data.Proxy -- from tagged+import Data.Reflection -- from reflection+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup -- from base+#endif --- | Values in our dynamically-constructed 'Monoid' over 'a'+-- | Values in our dynamically-constructed 'Monoid' over @a@ newtype M a s = M { runM :: a } deriving (Eq,Ord) -- | A dictionary describing a 'Monoid' data Monoid_ a = Monoid_ { mappend_ :: a -> a -> a, mempty_ :: a } +instance Reifies s (Monoid_ a) => Semigroup (M a s) where+ a <> b = M $ mappend_ (reflect a) (runM a) (runM b)+ instance Reifies s (Monoid_ a) => Monoid (M a s) where- mappend a b = M $ mappend_ (reflect a) (runM a) (runM b)+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<>)+#endif mempty = a where a = M $ mempty_ (reflect a) -- Construct a 'Monoid' instance out of a binary operation and unit that you have in scope!
+ examples/ReaderLike.hs view
@@ -0,0 +1,70 @@+-- The UndecidableInstances here is benign, just for the "advanced"+-- example at the end.+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}++-- I don't demonstrate the advantages over implicit parameters here,+-- like multiple reifications of the same thing coexisting in+-- different, statically-checked contexts, etc.; this is intended as a+-- comparison to Reader(T).++import Data.Proxy+import Data.Reflection+import System.IO++data MyConfig = MyConfig+ { magic :: Bool+ , volume :: Integer+ }++data Report p = Report+ { magicality :: String+ , loud :: Bool+ } deriving (Show)++-- some arbitrary thing we do calculations with+newtype Datum p = Datum Integer deriving (Read, Show)++report :: forall p. (Reifies p MyConfig) => Report p+report = Report+ { magicality = if magic conf then "Magical." else "Not so magical..."+ , loud = volume conf >= 11+ } where+ conf = reflect (Proxy :: Proxy p)++calculate :: forall p. (Reifies p MyConfig) => Datum p -> Datum p -> Datum p+calculate (Datum m) (Datum n) = Datum ((m+n) * volume conf) where+ conf = reflect (Proxy :: Proxy p)++run :: forall p. (Reifies p MyConfig) => Proxy p -> IO ()+run _ = do+ d1 <- ask "Datum 1:" :: IO (Datum p)+ d2 <- ask "Datum 2:" :: IO (Datum p)+ -- look ma, no plumbing+ print $ calculate d1 (calculate d2 d1)+ print (report :: Report p)++ask :: Read s => String -> IO s+ask prompt = do+ putStr prompt+ putChar ' '+ hFlush stdout+ readLn++main :: IO ()+main = do+ conf <- MyConfig <$> ask "Magic?" <*> ask "Volume:"+ reify conf run++-- If you're feeling adventurous, here is something we could not do+-- with ReaderT:+instance Reifies p MyConfig => Num (Datum p) where+ (+) = calculate+ m * n+ | magic conf = m + n+ | otherwise = Datum 0 -- sorry, no magic for you.+ where conf = reflect (Proxy :: Proxy p)+ abs = undefined+ signum = undefined+ (-) = undefined+ negate = undefined+ fromInteger = Datum
+ examples/reflection-examples.cabal view
@@ -0,0 +1,80 @@+name: reflection-examples+version: 0.1+license: BSD3+license-file: LICENSE+author: Edward A. Kmett, Elliott Hird, Oleg Kiselyov and Chung-chieh Shan+maintainer: Edward A. Kmett <ekmett@gmail.com>+stability: experimental+homepage: http://github.com/ekmett/reflection+bug-reports: http://github.com/ekmett/reflection/issues+category: Data, Reflection, Dependent Types+synopsis: Examples of reflection+description: Examples of reflection.+copyright: 2009-2013 Edward A. Kmett,+ 2012 Elliott Hird,+ 2004 Oleg Kiselyov and Chung-chieh Shan+build-type: Simple+cabal-version: >= 1.10+tested-with: GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.6+ , GHC == 9.8.4+ , GHC == 9.10.1+ , GHC == 9.12.1++flag examples+ default: True++library+ if !flag(examples)+ buildable: False+ exposed-modules: Constraints+ Monoid+ build-depends: base >= 4.9 && < 5,+ constraints,+ newtype-generics >= 0.5.3,+ reflection,+ semigroups,+ tagged+ hs-source-dirs: .+ ghc-options: -Wall+ if impl(ghc >= 8.6)+ ghc-options: -Wno-star-is-type+ default-language: Haskell2010++executable reflection-from-json+ if !flag(examples)+ buildable: False+ main-is: FromJSON.hs+ build-depends: aeson >= 2 && < 2.3,+ base >= 4.9 && < 5,+ microlens,+ microlens-aeson >= 2.5.1,+ reflection,+ semigroups,+ tagged,+ text+ hs-source-dirs: .+ ghc-options: -Wall -threaded -rtsopts+ default-language: Haskell2010++executable reflection-reader-like+ if !flag(examples)+ buildable: False+ main-is: ReaderLike.hs+ build-depends: base >= 4.9 && < 5,+ reflection,+ tagged+ hs-source-dirs: .+ ghc-options: -Wall -threaded -rtsopts+ if impl(ghc >= 8.6)+ ghc-options: -Wno-star-is-type+ default-language: Haskell2010+
fast/Data/Reflection.hs view
@@ -1,23 +1,34 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE TemplateHaskell #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-}-#define USE_TYPE_LITS 1+#ifdef MIN_VERSION_template_haskell+-- TH-subset that works with stage1 & unregisterised GHCs+{-# LANGUAGE TemplateHaskellQuotes #-} #endif-{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-cse #-}+{-# OPTIONS_GHC -fno-full-laziness #-}+{-# OPTIONS_GHC -fno-float-in #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-unused-binds #-}+ ---------------------------------------------------------------------------- -- | -- Module : Data.Reflection--- Copyright : 2009-2013 Edward Kmett,+-- Copyright : 2009-2015 Edward Kmett, -- 2012 Elliott Hird, -- 2004 Oleg Kiselyov and Chung-chieh Shan -- License : BSD3@@ -30,7 +41,7 @@ -- Pearl: Implicit Configurations paper by Oleg Kiselyov and -- Chung-chieh Shan. ----- <http://www.cs.rutgers.edu/~ccshan/prepose/prepose.pdf>+-- <http://okmij.org/ftp/Haskell/tr-15-04.pdf> -- -- The approach from the paper was modified to work with Data.Proxy -- and to cheat by using knowledge of GHC's internal representations@@ -54,32 +65,86 @@ -- * Reflection Reifies(..) , reify+ , reifyNat+ , reifySymbol+ , reifyTypeable -- * Given , Given(..) , give+#ifdef MIN_VERSION_template_haskell -- * Template Haskell reflection , int, nat+#endif -- * Useful compile time naturals , Z, D, SD, PD++ -- * Reified Monoids+ , ReifiedMonoid(..)+ , ReflectedMonoid(..)+ , reifyMonoid+ , foldMapBy+ , foldBy++ -- * Reified Applicatives+ , ReifiedApplicative(..)+ , ReflectedApplicative(..)+ , reifyApplicative+ , traverseBy+ , sequenceBy ) where +import Control.Applicative+import Control.Exception++#ifdef MIN_VERSION_template_haskell import Control.Monad-import Data.Functor+#endif++import Data.Bits+import Data.Coerce (Coercible, coerce) import Data.Proxy+import Data.Semigroup as Sem+import Data.Typeable+import Data.Word+import Foreign.Ptr+import Foreign.StablePtr -#ifdef USE_TYPE_LITS import GHC.TypeLits+#if MIN_VERSION_base(4,10,0)+import qualified Numeric.Natural as Numeric (Natural)+#else+import Control.Exception (ArithException(..), throw) #endif -import Language.Haskell.TH hiding (reify)- #ifdef __HUGS__ import Hugs.IOExts-#else+#endif++#ifdef MIN_VERSION_template_haskell+import Language.Haskell.TH hiding (reify)+#endif++import System.IO.Unsafe++#ifndef __HUGS__ import Unsafe.Coerce #endif +#if MIN_VERSION_base(4,18,0)+import qualified GHC.TypeNats as TN+#endif +-- Due to https://gitlab.haskell.org/ghc/ghc/issues/16893, inlining+-- unsafeCoerce too aggressively can cause optimization to become unsound on+-- old versions of GHC. As a workaround, we mark unsafeCoerce-using definitions+-- as NOINLINE where necessary.+-- See https://github.com/ekmett/reflection/issues/47.+#if __GLASGOW_HASKELL__ >= 811+# define INLINE_UNSAFE_COERCE INLINE+#else+# define INLINE_UNSAFE_COERCE NOINLINE+#endif+ ------------------------------------------------------------------------------ -- Reifies ------------------------------------------------------------------------------@@ -94,8 +159,87 @@ -- | Reify a value at the type level, to be recovered with 'reflect'. reify :: forall a r. a -> (forall (s :: *). Reifies s a => Proxy s -> r) -> r reify a k = unsafeCoerce (Magic k :: Magic a r) (const a) Proxy-{-# INLINE reify #-}+{-# INLINE_UNSAFE_COERCE reify #-} +instance KnownNat n => Reifies n Integer where+ reflect = natVal++instance KnownSymbol n => Reifies n String where+ reflect = symbolVal++--------------------------------------------------------------------------------+-- KnownNat+--------------------------------------------------------------------------------++-- | This upgraded version of 'reify' can be used to generate a 'KnownNat' suitable for use with other APIs.+--+-- Attemping to pass a negative 'Integer' as an argument will result in an+-- 'Underflow' exception.+--+-- /Available only on GHC 7.8+/+--+-- >>> import GHC.TypeLits+--+-- >>> reifyNat 4 natVal+-- 4+--+-- >>> reifyNat 4 reflect+-- 4++reifyNat :: forall r. Integer -> (forall (n :: Nat). KnownNat n => Proxy n -> r) -> r+#if MIN_VERSION_base(4,18,0)+-- With base-4.18 or later, we can use the API in GHC.TypeNats to define this+-- function directly.+reifyNat n k = TN.withSomeSNat (fromInteger n :: Numeric.Natural) $+ \(sn :: (SNat n)) -> TN.withKnownNat sn $ k (Proxy :: Proxy n)+{-# INLINE reifyNat #-}+#else+-- On older versions of base, we resort to unsafeCoerce.+reifyNat n k = unsafeCoerce (MagicNat k :: MagicNat r)+# if MIN_VERSION_base(4,10,0)+ -- Starting with base-4.10, the internal+ -- representation of KnownNat changed from Integer+ -- to Natural, so make sure to perform the same+ -- conversion before unsafeCoercing.+ (fromInteger n :: Numeric.Natural)+# else+ (if n < 0 then throw Underflow else n)+# endif+ Proxy+{-# INLINE_UNSAFE_COERCE reifyNat #-}++newtype MagicNat r = MagicNat (forall (n :: Nat). KnownNat n => Proxy n -> r)+#endif++--------------------------------------------------------------------------------+-- KnownSymbol+--------------------------------------------------------------------------------++-- | This upgraded version of 'reify' can be used to generate a 'KnownSymbol' suitable for use with other APIs.+--+-- /Available only on GHC 7.8+/+--+-- >>> import GHC.TypeLits+--+-- >>> reifySymbol "hello" symbolVal+-- "hello"+--+-- >>> reifySymbol "hello" reflect+-- "hello"+reifySymbol :: forall r. String -> (forall (n :: Symbol). KnownSymbol n => Proxy n -> r) -> r+#if MIN_VERSION_base(4,18,0)+-- With base-4.18 or later, we can use the API in GHC.TypeNats to define this+-- function directly.+reifySymbol s k = withSomeSSymbol s $ \(ss :: SSymbol s) -> withKnownSymbol ss (k (Proxy :: Proxy s))+{-# INLINE reifySymbol #-}+#else+-- On older versions of base, we resort to unsafeCoerce.+reifySymbol n k = unsafeCoerce (MagicSymbol k :: MagicSymbol r) n Proxy+{-# INLINE_UNSAFE_COERCE reifySymbol #-}+#endif++newtype MagicSymbol r = MagicSymbol (forall (n :: Symbol). KnownSymbol n => Proxy n -> r)+ ------------------------------------------------------------------------------ -- Given ------------------------------------------------------------------------------@@ -112,17 +256,25 @@ -- | Reify a value into an instance to be recovered with 'given'. ----- You should only 'give' a single value for each type. If multiple instances+-- You should /only/ 'give' a single value for each type. If multiple instances -- are in scope, then the behavior is implementation defined. give :: forall a r. a -> (Given a => r) -> r give a k = unsafeCoerce (Gift k :: Gift a r) a-{-# INLINE give #-}+{-# INLINE_UNSAFE_COERCE give #-} -data Z -- 0-data D (n :: *) -- 2n-data SD (n :: *) -- 2n+1-data PD (n :: *) -- 2n-1+--------------------------------------------------------------------------------+-- Explicit Numeric Reflection+-------------------------------------------------------------------------------- +-- | 0+data Z+-- | 2/n/+data D (n :: *)+-- | 2/n/ + 1+data SD (n :: *)+-- | 2/n/ - 1+data PD (n :: *)+ instance Reifies Z Int where reflect _ = 0 {-# INLINE reflect #-}@@ -140,21 +292,25 @@ {-# INLINE retagPD #-} instance Reifies n Int => Reifies (D n) Int where- reflect = (\n -> n + n) <$> retagD reflect+ reflect = (\n -> n + n) `fmap` retagD reflect {-# INLINE reflect #-} instance Reifies n Int => Reifies (SD n) Int where- reflect = (\n -> n + n + 1) <$> retagSD reflect+ reflect = (\n -> n + n + 1) `fmap` retagSD reflect {-# INLINE reflect #-} instance Reifies n Int => Reifies (PD n) Int where- reflect = (\n -> n + n - 1) <$> retagPD reflect+ reflect = (\n -> n + n - 1) `fmap` retagPD reflect {-# INLINE reflect #-} +#ifdef MIN_VERSION_template_haskell -- | This can be used to generate a template haskell splice for a type level version of a given 'int'. -- -- This does not use GHC TypeLits, instead it generates a numeric type by hand similar to the ones used -- in the \"Functional Pearl: Implicit Configurations\" paper by Oleg Kiselyov and Chung-Chieh Shan.+--+-- @instance Num (Q Exp)@ provided in this package allows writing @$(3)@+-- instead of @$(int 3)@. int :: Int -> TypeQ int n = case quotRem n 2 of (0, 0) -> conT ''Z@@ -171,10 +327,6 @@ | n >= 0 = int n | otherwise = error "nat: negative" -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL < 704-instance Show (Q a)-instance Eq (Q a)-#endif instance Num a => Num (Q a) where (+) = liftM2 (+) (*) = liftM2 (*)@@ -191,47 +343,292 @@ -- | This permits the use of $(5) as a type splice. instance Num Type where-#ifdef USE_TYPE_LITS+ LitT (NumTyLit a) + LitT (NumTyLit b) = LitT (NumTyLit (a+b)) a + b = AppT (AppT (VarT ''(+)) a) b- a * b = AppT (AppT (VarT ''(*)) a) b-#if MIN_VERSION_base(4,8,0)++ LitT (NumTyLit a) * LitT (NumTyLit b) = LitT (NumTyLit (a*b))+ (*) a b = AppT (AppT (VarT ''(GHC.TypeLits.*)) a) b a - b = AppT (AppT (VarT ''(-)) a) b-#else- (-) = error "Type.(-): undefined"-#endif fromInteger = LitT . NumTyLit-#else- (+) = error "Type.(+): undefined"- (*) = error "Type.(*): undefined"- (-) = error "Type.(-): undefined"- fromInteger n = case quotRem n 2 of- (0, 0) -> ConT ''Z- (q,-1) -> ConT ''PD `AppT` fromInteger q- (q, 0) -> ConT ''D `AppT` fromInteger q- (q, 1) -> ConT ''SD `AppT` fromInteger q- _ -> error "ghc is bad at math"-#endif abs = error "Type.abs" signum = error "Type.signum" -plus, times, minus :: Num a => a -> a -> a-plus = (+)-times = (*)-minus = (-)-fract :: Fractional a => a -> a -> a-fract = (/)+onProxyType1 :: (Type -> Type) -> (Exp -> Exp)+onProxyType1 f+ (SigE _ ta@(AppT (ConT proxyName) (VarT _)))+ | proxyName == ''Proxy = ConE 'Proxy `SigE` (ConT ''Proxy `AppT` f ta)+onProxyType1 f a =+ LamE [SigP WildP na] body `AppE` a+ where+ body = ConE 'Proxy `SigE` (ConT ''Proxy `AppT` f na)+ na = VarT (mkName "na") --- | This permits the use of $(5) as an expression splice.+onProxyType2 :: Name -> (Type -> Type -> Type) -> (Exp -> Exp -> Exp)+onProxyType2 _fName f+ (SigE _ (AppT (ConT proxyName) ta))+ (SigE _ (AppT (ConT proxyName') tb))+ | proxyName == ''Proxy,+ proxyName' == ''Proxy = ConE 'Proxy `SigE`+ (ConT ''Proxy `AppT` f ta tb)+-- the above case should only match for things like $(2 + 2)+onProxyType2 fName _f a b = VarE fName `AppE` a `AppE` b++-- | This permits the use of $(5) as an expression splice,+-- which stands for @Proxy :: Proxy $(5)@ instance Num Exp where- a + b = AppE (AppE (VarE 'plus) a) b- a * b = AppE (AppE (VarE 'times) a) b- a - b = AppE (AppE (VarE 'minus) a) b- negate = AppE (VarE 'negate)- signum = AppE (VarE 'signum)- abs = AppE (VarE 'abs)- fromInteger = LitE . IntegerL+ (+) = onProxyType2 'addProxy (+)+ (*) = onProxyType2 'mulProxy (*)+ (-) = onProxyType2 'subProxy (-)+ negate = onProxyType1 negate+ abs = onProxyType1 abs+ signum = onProxyType1 signum+ fromInteger n = ConE 'Proxy `SigE` (ConT ''Proxy `AppT` fromInteger n) -instance Fractional Exp where- a / b = AppE (AppE (VarE 'fract) a) b- recip = AppE (VarE 'recip)- fromRational = LitE . RationalL+addProxy :: Proxy a -> Proxy b -> Proxy (a + b)+addProxy _ _ = Proxy+mulProxy :: Proxy a -> Proxy b -> Proxy (a * b)+mulProxy _ _ = Proxy+subProxy :: Proxy a -> Proxy b -> Proxy (a - b)+subProxy _ _ = Proxy++#endif++--------------------------------------------------------------------------------+-- * Typeable Reflection+--------------------------------------------------------------------------------+++class Typeable s => B s where+ reflectByte :: proxy s -> IntPtr++#define BYTES(GO) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ 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) \+ GO(T253,253) GO(T254,254) GO(T255,255)++#define GO(Tn,n) \+ newtype Tn = Tn Tn; \+ instance B Tn 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(Tn,n) n -> k (Proxy :: Proxy Tn);+BYTES(GO)+#undef GO+_ -> impossible+}++newtype W (b0 :: *) (b1 :: *) (b2 :: *) (b3 :: *) = W (W b0 b1 b2 b3)+newtype StableBox (w0 :: *) (w1 :: *) (a :: *) = StableBox (StableBox w0 w1 a)+newtype Stable (w0 :: *) (w1 :: *) (a :: *) = Stable (Stable w0 w1 a)++data Box a = Box a++stableBox :: p (Stable w1 w2 a) -> Proxy (StableBox w1 w2 a)+stableBox _ = Proxy+{-# INLINE stableBox #-}++stable :: p b0 -> p b1 -> p b2 -> p b3 -> p b4 -> p b5 -> p b6 -> p b7+ -> Proxy (Stable (W b0 b1 b2 b3) (W 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 (W b0 b1 b2 b3) w1 a) -> Proxy b0+byte0 _ = Proxy++byte1 :: p (StableBox (W b0 b1 b2 b3) w1 a) -> Proxy b1+byte1 _ = Proxy++byte2 :: p (StableBox (W b0 b1 b2 b3) w1 a) -> Proxy b2+byte2 _ = Proxy++byte3 :: p (StableBox (W b0 b1 b2 b3) w1 a) -> Proxy b3+byte3 _ = Proxy++byte4 :: p (StableBox w0 (W b4 b5 b6 b7) a) -> Proxy b4+byte4 _ = Proxy++byte5 :: p (StableBox w0 (W b4 b5 b6 b7) a) -> Proxy b5+byte5 _ = Proxy++byte6 :: p (StableBox w0 (W b4 b5 b6 b7) a) -> Proxy b6+byte6 _ = Proxy++byte7 :: p (StableBox w0 (W 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, w0 ~ W b0 b1 b2 b3, w1 ~ W b4 b5 b6 b7)+ => Reifies (StableBox w0 w1 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 w0 w1 a) (Box b) => Reifies (Stable w0 w1 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 w0 w1 a) (Box a) => (Reifies (Stable w0 w1 a) a => Proxy (Stable w0 w1 a) -> r) -> Proxy (Stable w0 w1 a) -> IO r+withStableBox k p = do+ _ <- evaluate $ reflect (stableBox p)+ evaluate $ k p+{-# NOINLINE withStableBox #-}++-- | Reify a value at the type level in a 'Typeable'-compatible fashion, to be recovered with 'reflect'.+--+-- This can be necessary to work around the changes to @Data.Typeable@ in GHC HEAD.+reifyTypeable :: Typeable a => a -> (forall (s :: *). (Typeable s, Reifies s a) => Proxy s -> r) -> r+reifyTypeable a k = unsafeDupablePerformIO $ do+ p <- newStablePtr (Box 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))))))))++data ReifiedMonoid a = ReifiedMonoid { reifiedMappend :: a -> a -> a, reifiedMempty :: a }++instance Reifies s (ReifiedMonoid a) => Sem.Semigroup (ReflectedMonoid a s) where+ ReflectedMonoid x <> ReflectedMonoid y = reflectResult (\m -> ReflectedMonoid (reifiedMappend m x y))++instance Reifies s (ReifiedMonoid a) => Monoid (ReflectedMonoid a s) where+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<>)+#endif+ mempty = reflectResult (\m -> ReflectedMonoid (reifiedMempty m ))++reflectResult :: forall f s a. Reifies s a => (a -> f s) -> f s+reflectResult f = f (reflect (Proxy :: Proxy s))++newtype ReflectedMonoid a s = ReflectedMonoid a++unreflectedMonoid :: ReflectedMonoid a s -> proxy s -> a+unreflectedMonoid (ReflectedMonoid a) _ = a++reifyMonoid :: (a -> a -> a) -> a -> (forall (s :: *). Reifies s (ReifiedMonoid a) => t -> ReflectedMonoid a s) -> t -> a+reifyMonoid f z m xs = reify (ReifiedMonoid f z) (unreflectedMonoid (m xs))++-- | Fold a value using its 'Foldable' instance using+-- explicitly provided 'Monoid' operations. This is like 'Data.Foldable.fold'+-- where the 'Monoid' instance can be manually specified.+--+-- @+-- 'foldBy' 'mappend' 'mempty' ≡ 'fold'+-- @+--+-- >>> foldBy (++) [] ["hello","world"]+-- "helloworld"+foldBy :: Foldable t => (a -> a -> a) -> a -> t a -> a+foldBy f z = reifyMonoid f z (foldMap ReflectedMonoid)++-- | Fold a value using its 'Foldable' instance using+-- explicitly provided 'Monoid' operations. This is like 'foldMap'+-- where the 'Monoid' instance can be manually specified.+--+-- @+-- 'foldMapBy' 'mappend' 'mempty' ≡ 'foldMap'+-- @+--+-- >>> foldMapBy (+) 0 length ["hello","world"]+-- 10+foldMapBy :: Foldable t => (r -> r -> r) -> r -> (a -> r) -> t a -> r+foldMapBy f z g = reifyMonoid f z (foldMap (ReflectedMonoid #. g))++data ReifiedApplicative f = ReifiedApplicative { reifiedPure :: forall a. a -> f a, reifiedAp :: forall a b. f (a -> b) -> f a -> f b }++newtype ReflectedApplicative f s a = ReflectedApplicative (f a)++instance Reifies s (ReifiedApplicative f) => Functor (ReflectedApplicative f s) where+ fmap = liftA++instance Reifies s (ReifiedApplicative f) => Applicative (ReflectedApplicative f s) where+ pure a = reflectResult1 (\m -> ReflectedApplicative (reifiedPure m a))+ ReflectedApplicative x <*> ReflectedApplicative y = reflectResult1 (\m -> ReflectedApplicative (reifiedAp m x y))++reflectResult1 :: forall f s a b. Reifies s a => (a -> f s b) -> f s b+reflectResult1 f = f (reflect (Proxy :: Proxy s))++unreflectedApplicative :: ReflectedApplicative f s a -> proxy s -> f a+unreflectedApplicative (ReflectedApplicative a) _ = a++reifyApplicative :: (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+reifyApplicative f g m xs = reify (ReifiedApplicative f g) (unreflectedApplicative (m xs))++-- | Traverse a container using its 'Traversable' instance using+-- explicitly provided 'Applicative' operations. This is like 'traverse'+-- where the 'Applicative' instance can be manually specified.+traverseBy :: 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)+traverseBy pur app f = reifyApplicative pur app (traverse (ReflectedApplicative #. f))++-- | Sequence a container using its 'Traversable' instance using+-- explicitly provided 'Applicative' operations. This is like 'sequence'+-- where the 'Applicative' instance can be manually specified.+sequenceBy :: Traversable t => (forall x. x -> f x) -> (forall x y. f (x -> y) -> f x -> f y) -> t (f a) -> f (t a)+sequenceBy pur app = reifyApplicative pur app (traverse ReflectedApplicative)++(#.) :: Coercible c b => (b -> c) -> (a -> b) -> (a -> c)+(#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b
reflection.cabal view
@@ -1,5 +1,5 @@ name: reflection-version: 1.3.2+version: 2.1.9 license: BSD3 license-file: LICENSE author: Edward A. Kmett, Elliott Hird, Oleg Kiselyov and Chung-chieh Shan@@ -15,48 +15,80 @@ build-type: Simple cabal-version: >= 1.10 description:- This package provides an implementation of the ideas presented in the paper- \"Functional Pearl: Implicit Configurations\" by Oleg Kiselyov and- Chung-chieh Shan. However, the API has been streamlined to improve performance.+ This package addresses the /configuration problem/ which is+ propagating configurations that are available at run-time, allowing+ multiple configurations to coexist without resorting to mutable+ global variables or 'System.IO.Unsafe.unsafePerformIO'. .- The original paper can be obtained from- <http://www.cs.rutgers.edu/~ccshan/prepose/prepose.pdf>.+ That package is an implementation of the ideas presented in the+ paper \"Functional Pearl: Implicit Configurations\" by Oleg Kiselyov+ and Chung-chieh Shan (<http://okmij.org/ftp/Haskell/tr-15-04.pdf original paper>).+ However, the API has been streamlined to improve performance.+ .+ There are a handful of tutorials on how to use this library:+ .+ * Austin Seipp's tutorial <https://www.schoolofhaskell.com/user/thoughtpolice/using-reflection Reflecting values to types and back> provides a summary of the+ approach taken by this library, along with more motivating examples.+ .+ * Arnaud Spiwack's tutorial <https://www.tweag.io/posts/2017-12-21-reflection-tutorial.html All about reflection> explains how to use this library.+tested-with: GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.6+ , GHC == 9.8.4+ , GHC == 9.10.1+ , GHC == 9.12.1 extra-source-files:- examples/Monoid.hs- examples/Constraints.hs- examples/Benchmark.hs+ .hlint.yaml+ examples/reflection-examples.cabal+ examples/LICENSE+ examples/*.hs CHANGELOG.markdown README.markdown slow/Data/Reflection.hs fast/Data/Reflection.hs- .travis.yml --- If you enable this flag, we use a more portable much much slower implementation.--- Moreover, the 'Given' API is broken, so this is currently an unsupported configuration.------ If you feel the need to turn on this flag for any reason, please email the maintainer! flag slow+ description:+ If you enable this flag, we use a more portable much much slower implementation. Moreover, the 'Given' API is broken, so this is currently an unsupported configuration. If you feel the need to turn on this flag for any reason, please email the maintainer! default: False manual: False +flag template-haskell+ description:+ You can disable the use of the `template-haskell` package using `-f-template-haskell`.+ .+ Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.+ default: True+ manual: True+ source-repository head type: git location: git://github.com/ekmett/reflection.git library ghc-options: -Wall+ if impl(ghc >= 8.6)+ ghc-options: -Wno-star-is-type - if impl(ghc >= 7.2)- default-extensions: Trustworthy+ default-extensions: Trustworthy build-depends:- base >= 2 && < 5,- tagged >= 0.4.4 && < 1,- template-haskell+ base >= 4.9 && < 5 default-language: Haskell98 + if flag(template-haskell) && impl(ghc)+ -- other-extensions: TemplateHaskellQuotes -- Hackage doesn't know this extension yet+ build-depends: template-haskell+ if !flag(slow) && (impl(ghc) || impl(hugs)) hs-source-dirs: fast else@@ -70,3 +102,19 @@ CPP exposed-modules: Data.Reflection++test-suite spec+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Spec.hs+ other-modules: ReifyNatSpec+ T47Spec+ ghc-options: -Wall+ default-language: Haskell98+ build-tool-depends: hspec-discover:hspec-discover >= 1.8+ build-depends:+ base >= 4.9 && < 5,+ containers >= 0.1 && < 0.8,+ hspec >= 2 && < 3,+ QuickCheck >= 2 && < 3,+ reflection
slow/Data/Reflection.hs view
@@ -1,12 +1,15 @@ {-# 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 #-}+{-# OPTIONS_GHC -Wno-unused-binds #-} ---------------------------------------------------------------------------- -- | -- Module : Data.Reflection@@ -23,7 +26,7 @@ -- Pearl: Implicit Configurations paper by Oleg Kiselyov and -- Chung-chieh Shan. ----- <http://www.cs.rutgers.edu/~ccshan/prepose/prepose.pdf>+-- <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.@@ -49,6 +52,7 @@ import Foreign.StablePtr import System.IO.Unsafe import Control.Applicative+import Control.Exception import Data.Proxy import Data.Bits import Data.Word@@ -115,9 +119,18 @@ -- 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@@ -131,35 +144,35 @@ intPtrToStablePtr = castPtrToStablePtr . intPtrToPtr {-# INLINE intPtrToStablePtr #-} -byte0 :: p (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b0+byte0 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b0 byte0 _ = Proxy -byte1 :: p (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b1+byte1 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b1 byte1 _ = Proxy -byte2 :: p (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b2+byte2 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b2 byte2 _ = Proxy -byte3 :: p (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b3+byte3 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b3 byte3 _ = Proxy -byte4 :: p (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b4+byte4 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b4 byte4 _ = Proxy -byte5 :: p (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b5+byte5 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b5 byte5 _ = Proxy -byte6 :: p (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b6+byte6 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b6 byte6 _ = Proxy -byte7 :: p (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b7+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 (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) a where+ => 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@@ -174,12 +187,34 @@ (reflectByte (byte7 s) `shiftL` 56) {-# NOINLINE reflect #-} --- This had to be moved to the top level, due to an apparent bug in--- the ghc inliner introduced in ghc 7.0.x-reflectBefore :: Reifies s a => (Proxy s -> b) -> proxy s -> b-reflectBefore f = const $! f Proxy-{-# NOINLINE reflectBefore #-}+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@@ -193,5 +228,4 @@ reifyByte (fromIntegral (n `shiftR` 40)) (\s5 -> reifyByte (fromIntegral (n `shiftR` 48)) (\s6 -> reifyByte (fromIntegral (n `shiftR` 56)) (\s7 ->- reflectBefore (fmap return k) $- stable s0 s1 s2 s3 s4 s5 s6 s7))))))))+ withStableBox k $ stable s0 s1 s2 s3 s4 s5 s6 s7))))))))
+ tests/ReifyNatSpec.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+module ReifyNatSpec where++import Data.Reflection+import Test.Hspec.QuickCheck+import Test.QuickCheck (NonNegative(..))++#if MIN_VERSION_base(4,10,0)+import GHC.TypeNats (natVal)+import Numeric.Natural (Natural)+#endif++#if __GLASGOW_HASKELL__ != 900+import Control.Exception (ArithException(..), evaluate)+import Test.QuickCheck (Negative(..))+#endif++import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec =+ describe "reifyNat" $ do+ prop "reify positive Integers and reflect them back" $+ \(NonNegative (i :: Integer)) -> reifyNat i $ \p -> reflect p `shouldBe` i+#if __GLASGOW_HASKELL__ != 900+ -- Inexplicably, this test fails on GHC 9.0 with hspec-2.8.4 or later.+ -- Moreover, I suspect that undefined behavior is involved in some way,+ -- as the output of hspec will occasionally be swallowed entirely. I have+ -- not been able to observe this phenomenon on any other version of GHC,+ -- so I will simply disable this test on 9.0.+ prop "should throw an Underflow exception on negative inputs" $+ \(Negative (i :: Integer)) ->+ reifyNat i (evaluate . reflect) `shouldThrow` (== Underflow)+#endif+#if MIN_VERSION_base(4,10,0)+ it "should reflect very large Naturals correctly" $ do -- #41+ let d42, d2_63, d2_64 :: Natural+ d42 = 42+ d2_63 = 2^(63 :: Natural)+ d2_64 = 2^(64 :: Natural)+ reifyNat (toInteger d42) $ \p -> natVal p `shouldBe` d42+ reifyNat (toInteger (d2_63-1)) $ \p -> natVal p `shouldBe` d2_63-1+ reifyNat (toInteger d2_63) $ \p -> natVal p `shouldBe` d2_63+ reifyNat (toInteger (d2_64-1)) $ \p -> natVal p `shouldBe` d2_64-1+ reifyNat (toInteger d2_64) $ \p -> natVal p `shouldBe` d2_64+#endif
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ tests/T47Spec.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+-- | A regression test for issue #47.+module T47Spec where++import qualified Data.Map as M+import Data.Map (Map)+import Data.Reflection+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec =+ describe "Given" $ do+ it "should give Normal properly" $+ give Normal (toJSON (Foo Bar)) `shouldBe`+ Object (M.fromList [("Foo",String "Bar")])+ it "should give ViaShow properly" $+ give ViaShow (toJSON (Foo Bar)) `shouldBe`+ Object (M.fromList [("Foo",String "SHOWBAR")])++----------------------------------------------------------------------------+-- Types+----------------------------------------------------------------------------++data Foo = Foo Bar++instance Show Foo where+ show _ = "SHOWFOO"++data Bar = Bar | BarBar++instance Show Bar where+ show _ = "SHOWBAR"++----------------------------------------------------------------------------+-- ToJSON instances+----------------------------------------------------------------------------++instance Given Style => ToJSON Foo where+ toJSON (Foo x) = Object $ M.singleton "Foo" (toJSON x)++instance Given Style => ToJSON Bar where+ toJSON x = case given of+ Normal -> String $ case x of+ Bar -> "Bar"+ BarBar -> "BarBar"+ ViaShow -> String $ show x++data Style = Normal | ViaShow++----------------------------------------------------------------------------+-- Minimized aeson+----------------------------------------------------------------------------++class ToJSON a where+ toJSON :: a -> Value++data Value+ = Object !(Map String Value)+ | String !String+ deriving (Eq, Show)