packages feed

reflection 0.3.5 → 2.1.9

raw patch · 18 files changed

Files

+ .hlint.yaml view
@@ -0,0 +1,2 @@+- ignore: {name: Unused LANGUAGE pragma}+- ignore: {name: Avoid lambda}
+ CHANGELOG.markdown view
@@ -0,0 +1,103 @@+# 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.++# 1.3+* Merged some functionality from Data.Analytics.Reflection. Notably the ability to use type nats to reflect numbers, and to splice numbers directly. This reduces orphan instances somewhat.++# 1.2+* Added `Given` and give.++# 1.1.7+* Fixed an issue caused by changes in GHC 7.7's typechecker by using explicit `ScopedTypeVariables`.++# 1.1.6:+* Relaxed an unnecessary strictness annotation in the fast implementation++# 1.1.5+* Both implementations now work on Hugs; the fast implementation ascends+  from the ranks of completely unportable black magic to being merely+  /mostly/ unportable black magic.++# From 0.5 to 1.1:++* Much faster implementation available that is about 50 /times/ faster than+  0.9 and which runs purely on black magic. This version is now used by+  default. To turn it off install with the `slow` flag. If you encounter a+  problem with the implementation, please contact the author.+* Removed `ReifiedNum`, `reflectNum`, and `reifyIntegral`; `reify` and+  `reflect` are about 3 orders of magnitude faster than the special case+  combinators were.++# 0.5+* Generalized the type signatures in reflect to allow you to pass any type+  with kind `* -> *` wrapped around the desired type as the phantom type+  argument rather than just a `Proxy`.++# 0.4+* Converted from `Data.Tagged` to using `Data.Proxy` for reflection. This+  reduces the need for helper functions and scoped type variables in user+  code.
− Data/Reflection.hs 
@@ -1,183 +0,0 @@-{-# LANGUAGE RankNTypes, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeOperators #-}-{-# OPTIONS_GHC -fno-cse -fno-full-laziness -fno-float-in #-}--------------------------------------------------------------------------------- |--- Module     : Data.Reflection--- Copyright  : 2009-2011 Edward Kmett, 2004 Oleg Kiselyov and Chung-chieh Shan--- License    : BSD3------ Maintainer  : Edward Kmett <ekmett@gmail.com>--- Stability   : experimental--- Portability : non-portable (scoped types, MPTCs, rank-n, FFI, kinds)------ Based on the Functional Pearl: Implicit Configurations paper by--- Oleg Kiselyov and Chung-chieh Shan.------ <http://www.cs.rutgers.edu/~ccshan/prepose/prepose.pdf>------ Modified to minimize extensions and work with Data.Tagged rather than --- explicit scoped type variables by Edward Kmett.-------------------------------------------------------------------------------------module Data.Reflection -    ( -    -- * Reflect Integrals-      ReifiesNum-    , reflectNum-    , reifyIntegral-    -- * Reflect Lists of Integrals-    , ReifiesNums-    , reifyIntegrals-    -- * Reflect Storables-    , ReifiesStorable-    , reflectStorable-    , reifyStorable-    -- * Reflect Anything-    , Reifies-    , reflect-    , reify-    ) where--import Foreign.C.Types-import Foreign.Marshal.Alloc-import Foreign.Marshal.Array-import Foreign.Marshal.Utils-import Foreign.Ptr-import Foreign.StablePtr-import Foreign.Storable-import System.IO.Unsafe-import Control.Applicative -import Prelude hiding (succ, pred)-import Data.Tagged--class Unused t where unused :: t -> ()--type Retag f g = forall b. Tagged g b -> Tagged f b--newtype Zero = Zero Zero deriving (Show)-newtype Twice s = Twice (Twice s) deriving (Show)-newtype Succ s = Succ (Succ s) deriving (Show)-newtype Pred s = Pred (Pred s) deriving (Show)-instance Unused Zero where unused Zero{} = ()-instance Unused (Twice s) where unused Twice{} = ()-instance Unused (Succ s) where unused Succ{} = ()-instance Unused (Pred s) where unused Pred{} = ()--pop :: Retag (f s) s-pop = retag-{-# INLINE pop #-} --class ReifiesNum s where-    reflectNum :: Num a => Tagged s a--instance ReifiesNum Zero where-    reflectNum = pure 0--instance ReifiesNum s => ReifiesNum (Twice s) where-    reflectNum = (2*) <$> pop reflectNum --instance ReifiesNum s => ReifiesNum (Succ s) where-    reflectNum = (1+) <$> pop reflectNum--instance ReifiesNum s => ReifiesNum (Pred s) where-    reflectNum = subtract 1 <$> pop reflectNum--reifyIntegral :: Integral a => a -> (forall s. ReifiesNum s => Tagged s w) -> w-reifyIntegral i k = case quotRem i 2 of-    (0, 0) -> zero k -    (j, 0) -> reifyIntegral j (twice k)-    (j, 1) -> reifyIntegral j (twice (succ k))-    (j,-1) -> reifyIntegral j (twice (pred k))-    _      -> undefined -  where-    twice :: Retag s (Twice s)-    twice = retag-    succ :: Retag s (Succ s)-    succ = retag-    pred :: Retag s (Pred s)-    pred = retag-    zero :: Tagged Zero a -> a-    zero = unTagged--newtype Nil = Nil Nil-newtype Cons s ss = Cons (Cons s ss)-instance Unused Nil where unused Nil{} = ()-instance Unused (Cons s ss) where unused Cons{} = ()--class ReifiesNums ss where-    reflectNums :: Num a => Tagged ss [a]--instance ReifiesNums Nil where-    reflectNums = pure []--instance (ReifiesNum s, ReifiesNums ss) => ReifiesNums (Cons s ss) where-    reflectNums = (:) <$> car reflectNum <*> cdr reflectNums where-        car :: Retag (Cons s ss) s-        car = retag-        cdr :: Retag (Cons s ss) ss-        cdr = retag--reifyIntegrals :: Integral a => [a] -> (forall ss. ReifiesNums ss => Tagged ss w) -> w-reifyIntegrals [] k = nil k where-    nil :: Tagged Nil a' -> a'-    nil = unTagged -reifyIntegrals (i:ii) k = reifyIntegral i (reifyIntegrals ii (cons k)) where-    cons :: Tagged (Cons s' ss') a' -> Tagged ss' (Tagged s' a')-    cons = pure . retag-    -newtype Store s a = Store (Store s a)-instance Unused (Store s a) where unused Store{} = ()--class ReifiesStorable s where-    reflectStorable :: Storable a => Tagged (s a) a--instance ReifiesNums s => ReifiesStorable (Store s) where-    reflectStorable = r where -        r = unsafePerformIO $ alloca $ \p -> do -            pokeArray (castPtr p) (bytes reflectNums r)-            pure <$> peek p -        bytes :: Tagged s' [CChar] -> Tagged (Store s' b) b -> [CChar]-        bytes (Tagged a) _ = a-    {-# NOINLINE reflectStorable #-}--store :: Retag s' (Store s' c)-store = retag--reifyStorable :: Storable a => a -> (forall s. ReifiesStorable s => Tagged (s a) w) -> w-reifyStorable a k = reifyIntegrals bytes (store k)-  where-    bytes :: [CChar]-    bytes = unsafePerformIO $ with a (peekArray (sizeOf a) . castPtr) -{-# NOINLINE reifyStorable #-}--class Reifies s a | s -> a where -    reflect :: Tagged s a--newtype Stable s a = Stable (s (Stable s a))-instance Unused (Stable s a) where unused Stable{} = ()--instance ReifiesStorable s => Reifies (Stable s a) a where-    reflect = r where-        r = unsafePerformIO $ -                 pure <$> deRefStablePtr p <* freeStablePtr p-        p = pointer reflectStorable r--        pointer :: Tagged (s' p) p -> Tagged (Stable s' a') a' -> p-        pointer (Tagged a) _ = a-    {-# 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 => Tagged s b -> Tagged s b-reflectBefore = liftA2 seq reflect-{-# NOINLINE reflectBefore #-}--reify :: a -> (forall s. Reifies s a => Tagged s w) -> w-reify a k = unsafePerformIO $ do-        p <- newStablePtr a-        reifyStorable p (stable (reflectBefore (return <$> k)))-    where-        stable :: Retag (s' (StablePtr a')) (Stable s' a')-        stable = retag-{-# NOINLINE reify #-}
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2009 Edward Kmett+Copyright (c) 2009-2013 Edward Kmett Copyright (c) 2004 Oleg Kiselyov and Chung-chieh Shan All rights reserved.
+ README.markdown view
@@ -0,0 +1,15 @@+reflection+==========++[![Hackage](https://img.shields.io/hackage/v/reflection.svg)](https://hackage.haskell.org/package/reflection) [![Build Status](https://github.com/ekmett/reflection/workflows/Haskell-CI/badge.svg)](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://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+-------------------++Contributions and bug reports are welcome!++Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.++-Edward Kmett
+ examples/Benchmark.hs view
@@ -0,0 +1,16 @@+import Criterion.Main++import qualified Data.Reflection as Old+import qualified Data.NewReflection as New++old :: [Int] -> [Int]+old = map (\x -> Old.reify x Old.reflect)++new :: [Int] -> [Int]+new = map (\x -> New.reify x New.reflect)++main :: IO ()+main = defaultMain+    [ bench "old" $ nf old [1..100000]+    , bench "new" $ nf new [1..100000]+    ]
+ examples/Constraints.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE Rank2Types, TypeFamilies, TypeOperators, ConstraintKinds, PolyKinds, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, FlexibleContexts, UndecidableInstances, CPP #-}+module Constraints where++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) where+  type O (Lift p a s) = a+  pack = Lift+  unpack = lower++-- > ghci> with (Monoid (+) 0) $ mempty <> Lift 2+-- > 2+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 = reify++asProxyOf :: f s -> Proxy s -> f s+asProxyOf a _ = a++-- > using (Monoid (+) 0) $ mappend mempty 12+-- > 12+using :: forall p a. ReifiableConstraint p => Def p a -> (p a => a) -> a+using d m = reify d $ \(_ :: Proxy s) -> m \\ trans (unsafeCoerceConstraint :: (p (Lift p a s) :- p a)) reifiedIns++usingT :: forall p f a. ReifiableConstraint p => Def p a -> (p a => f a) -> f a+usingT d m = reify d $ \(_ :: Proxy s) -> m \\ trans (unsafeCoerceConstraint :: (p (Lift p a s) :- p a)) reifiedIns++instance ReifiableConstraint Monoid where+  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            = (<>)+  mempty = a where a = Lift $ mempty_ (reflect a)++data ClassProxy (p :: * -> Constraint) = ClassProxy++given :: ClassProxy c -> p s -> a -> Lift c a s+given _ _ = Lift++eq :: ClassProxy Eq+eq = ClassProxy++ord :: ClassProxy Ord+ord = ClassProxy++monoid :: ClassProxy Monoid+monoid = ClassProxy++instance ReifiableConstraint Eq where+  data Def Eq a = Eq { eq_ :: a -> a -> Bool }+  reifiedIns = Sub Dict++instance Reifies s (Def Eq a) => Eq (Lift Eq a s) where+  a == b = eq_ (reflect a) (lower a) (lower b)++instance ReifiableConstraint Ord where+  data Def Ord a = Ord { compare_ :: a -> a -> Ordering }+  reifiedIns = Sub Dict++instance Reifies s (Def Ord a) => Eq (Lift Ord a s) where+  a == b = compare a b == EQ++instance Reifies s (Def Ord a) => Ord (Lift Ord a s) where+  compare a b = compare_ (reflect a) (lower a) (lower b)+
+ 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
@@ -0,0 +1,33 @@+{-# 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@+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+#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!+--+-- > ghci> withMonoid (+) 0 $ mempty <> M 2+-- > 2+withMonoid :: (a -> a -> a) -> a -> (forall s. Reifies s (Monoid_ a) => M a s) -> a+withMonoid f z v = reify (Monoid_ f z) (runM . asProxyOf v)++asProxyOf :: f s -> Proxy s -> f s+asProxyOf a _ = a
+ 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
@@ -0,0 +1,634 @@+{-# 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 TypeOperators #-}+#ifdef MIN_VERSION_template_haskell+-- TH-subset that works with stage1 & unregisterised GHCs+{-# LANGUAGE TemplateHaskellQuotes #-}+#endif++{-# 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-2015 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 to cheat by using knowledge of GHC's internal representations+-- 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@).+--+-- In addition, a simpler API is offered for working with singleton+-- values such as a system configuration, etc.+-------------------------------------------------------------------------------+module Data.Reflection+    (+    -- * 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+#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++import GHC.TypeLits+#if MIN_VERSION_base(4,10,0)+import qualified Numeric.Natural as Numeric (Natural)+#else+import Control.Exception (ArithException(..), throw)+#endif++#ifdef __HUGS__+import Hugs.IOExts+#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+------------------------------------------------------------------------------++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 Magic a r = Magic (forall (s :: *). Reifies s a => Proxy s -> r)++-- | 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_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+------------------------------------------------------------------------------++-- | This is a version of 'Reifies' that allows for only a single value.+--+-- This is easier to work with than 'Reifies' and permits extended defaulting,+-- but it only offers a single reflected value of a given type at a time.+class Given a where+  -- | Recover the value of a given type previously encoded with 'give'.+  given :: a++newtype Gift a r = Gift (Given a => r)++-- | Reify a value into an instance to be recovered with 'given'.+--+-- 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_UNSAFE_COERCE give #-}++--------------------------------------------------------------------------------+-- 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 #-}++retagD :: (Proxy n -> a) -> proxy (D n) -> a+retagD f _ = f Proxy+{-# INLINE retagD #-}++retagSD :: (Proxy n -> a) -> proxy (SD n) -> a+retagSD f _ = f Proxy+{-# INLINE retagSD #-}++retagPD :: (Proxy n -> a) -> proxy (PD n) -> a+retagPD f _ = f Proxy+{-# INLINE retagPD #-}++instance Reifies n Int => Reifies (D n) Int where+  reflect = (\n -> n + n) `fmap` retagD reflect+  {-# INLINE reflect #-}++instance Reifies n Int => Reifies (SD n) Int where+  reflect = (\n -> n + n + 1) `fmap` retagSD reflect+  {-# INLINE reflect #-}++instance Reifies n Int => Reifies (PD n) Int where+  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+  (q,-1) -> conT ''PD `appT` int q+  (q, 0) -> conT ''D  `appT` int q+  (q, 1) -> conT ''SD `appT` int q+  _     -> error "ghc is bad at math"++-- | This is a restricted version of 'int' that can only generate natural numbers. Attempting to generate+-- a negative number results in a compile time error. Also the resulting sequence will consist entirely of+-- Z, D, and SD constructors representing the number in zeroless binary.+nat :: Int -> TypeQ+nat n+  | n >= 0 = int n+  | otherwise = error "nat: negative"++instance Num a => Num (Q a) where+  (+) = liftM2 (+)+  (*) = liftM2 (*)+  (-) = liftM2 (-)+  negate = fmap negate+  abs = fmap abs+  signum = fmap signum+  fromInteger = return . fromInteger++instance Fractional a => Fractional (Q a) where+  (/) = liftM2 (/)+  recip = fmap recip+  fromRational = return . fromRational++-- | This permits the use of $(5) as a type splice.+instance Num Type where+  LitT (NumTyLit a) + LitT (NumTyLit b) = LitT (NumTyLit (a+b))+  a + b = AppT (AppT (VarT ''(+)) a) b++  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+  fromInteger = LitT . NumTyLit+  abs = error "Type.abs"+  signum = error "Type.signum"++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")++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+  (+) = 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)++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,24 +1,120 @@-name:		    reflection-version:	    0.3.5-license:	    BSD3+name:           reflection+version:        2.1.9+license:        BSD3 license-file:   LICENSE-author:		    Edward A. Kmett, Oleg Kiselyov and Chung-chieh Shan-maintainer:	    Edward A. Kmett <ekmett@gmail.com>-stability:	    experimental-homepage:	    http://www.cs.rutgers.edu/~ccshan/prepose/prepose.pdf-category:	    Data, Reflection, Dependent Types-synopsis:	    Functional Pearl: Implicit Configurations-copyright:      2009 Edward A. Kmett, 2004 Oleg Kiselyov and Chung-chieh Shan-description:    Implementation of the ideas presented in the paper "Functional Pearl: Implicit Configurations" by Oleg Kiselyov and Chung-chieh Shan.-                Modified to avoid the use of scoped type variables, and to use a phantom type wrapper rather than dummy arguments.+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:       Reifies arbitrary terms into types that can be reflected back into terms+copyright:      2009-2013 Edward A. Kmett,+                2012 Elliott Hird,+                2004 Oleg Kiselyov and Chung-chieh Shan build-type:     Simple-cabal-version:  >=1.2+cabal-version:  >= 1.10+description:+  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'.+  .+  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:+  .hlint.yaml+  examples/reflection-examples.cabal+  examples/LICENSE+  examples/*.hs+  CHANGELOG.markdown+  README.markdown+  slow/Data/Reflection.hs+  fast/Data/Reflection.hs++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-  build-depends: -    base >= 4 && < 5,-    tagged >= 0.2.2 && < 0.3-  exposed-modules:-    Data.Reflection-       ghc-options: -Wall+  if impl(ghc >= 8.6)+    ghc-options: -Wno-star-is-type++  default-extensions: Trustworthy++  build-depends:+    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+    other-extensions: ScopedTypeVariables, FlexibleInstances+    hs-source-dirs: slow++  other-extensions:+    MultiParamTypeClasses,+    FunctionalDependencies,+    Rank2Types,+    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
@@ -0,0 +1,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 -Wno-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))))))))
+ 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)