packages feed

reflection 1.5.2.1 → 2.1.9

raw patch · 16 files changed

Files

+ .hlint.yaml view
@@ -0,0 +1,2 @@+- ignore: {name: Unused LANGUAGE pragma}+- ignore: {name: Avoid lambda}
− .travis.yml 
@@ -1,56 +0,0 @@-language: haskell--env:-  - GHCVER=7.4.2-  - GHCVER=7.6.3-  - GHCVER=7.8.3-  - GHCVER=head--matrix:-  allow_failures:-    - env: GHCVER=head--before_install:-  # If $GHCVER is the one travis has, don't bother reinstalling it.-  # We can also have faster builds by installing some libraries with-  # `apt`. If it isn't, install the GHC we want from hvr's PPA along-  # with cabal-1.18.-  - |-    if [ $GHCVER = `ghc --numeric-version` ]; then-      # Try installing some of the build-deps with apt-get for speed.-      travis/cabal-apt-install --enable-tests $MODE-      export CABAL=cabal-    else-      # Install the GHC we want from hvr's PPA-      travis_retry sudo add-apt-repository -y ppa:hvr/ghc-      travis_retry sudo apt-get update-      travis_retry sudo apt-get install cabal-install-1.18 ghc-$GHCVER happy-      export CABAL=cabal-1.18-      export PATH=/opt/ghc/$GHCVER/bin:$PATH-    fi-  # Uncomment whenever hackage is down.-  # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && $CABAL update-  - $CABAL update--  # Update happy when building with GHC head-  - |-    if [ $GHCVER = "head" ] || [ $GHCVER = "7.8.3" ]; then-      $CABAL install happy alex-      export PATH=$HOME/.cabal/bin:$PATH-    fi--install:-  - $CABAL install --dependencies-only --enable-tests-  - $CABAL configure --enable-tests $MODE--script:-  - $CABAL build-  - $CABAL test --show-details=always--notifications:-  irc:-    channels:-      - "irc.freenode.org#haskell-lens"-    skip_join: true-    template:-      - "\x0313reflection\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"
CHANGELOG.markdown view
@@ -1,3 +1,45 @@+# 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.
README.markdown view
@@ -1,7 +1,7 @@ reflection ========== -[![Build Status](https://secure.travis-ci.org/ekmett/reflection.png?branch=master)](http://travis-ci.org/ekmett/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.
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
@@ -1,27 +1,30 @@ -- 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 +-- 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.Reflection -- from reflection-import Data.Monoid     -- from base-import Data.Proxy      -- from tagged-import Data.Text       -- from text-import Data.Monoid  -import Data.Aeson      -- from aeson     +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 Control.Lens (preview)           -- from lens-import Data.Aeson.Lens (_Value,_String) -- form lens-aeson+import Lens.Micro.Aeson (_Value)   -- form microlens-aeson+import Lens.Micro.Extras (preview) -- from microlens  data Foo = Foo     {@@ -31,19 +34,20 @@  fooParser :: Text -> Object -> Parser Foo fooParser prefix o = do-    Foo <$> o .: (prefix <> "field1") <*> o .: (prefix <> "field2")+    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 ++-- 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. +-- 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@@ -53,18 +57,18 @@ 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 - +            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,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -6,22 +7,28 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-}-#define USE_TYPE_LITS 1-#endif #ifdef MIN_VERSION_template_haskell-{-# LANGUAGE TemplateHaskell #-}+-- 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@@ -58,6 +65,9 @@     -- * Reflection       Reifies(..)     , reify+    , reifyNat+    , reifySymbol+    , reifyTypeable     -- * Given     , Given(..)     , give@@ -67,25 +77,74 @@ #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 -#if (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707) || (defined(MIN_VERSION_template_haskell) && 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 +#ifdef __HUGS__+import Hugs.IOExts+#endif+ #ifdef MIN_VERSION_template_haskell import Language.Haskell.TH hiding (reify)-import Control.Monad #endif -#ifdef __HUGS__-import Hugs.IOExts-#else+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 ------------------------------------------------------------------------------@@ -100,16 +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 #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 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 ------------------------------------------------------------------------------@@ -126,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 #-}@@ -172,9 +310,7 @@ -- 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)@. Sometimes the two will produce the same--- representation (if compiled without the @-DUSE_TYPE_LITS@ preprocessor--- directive).+-- instead of @$(int 3)@. int :: Int -> TypeQ int n = case quotRem n 2 of   (0, 0) -> conT ''Z@@ -191,12 +327,6 @@   | n >= 0 = int n   | otherwise = error "nat: negative" -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 704-instance Show (Q a) where-  show _ = "Q"-instance Eq (Q a) where-  _ == _ = False-#endif instance Num a => Num (Q a) where   (+) = liftM2 (+)   (*) = liftM2 (*)@@ -213,29 +343,13 @@  -- | 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    LitT (NumTyLit a) * LitT (NumTyLit b) = LitT (NumTyLit (a*b))-  a * b = AppT (AppT (VarT ''(*)) a) b-#if MIN_VERSION_base(4,8,0)+  (*) 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" @@ -245,7 +359,7 @@     | proxyName == ''Proxy = ConE 'Proxy `SigE` (ConT ''Proxy `AppT` f ta) onProxyType1 f a =         LamE [SigP WildP na] body `AppE` a-    where +    where           body = ConE 'Proxy `SigE` (ConT ''Proxy `AppT` f na)           na = VarT (mkName "na") @@ -270,26 +384,251 @@   signum = onProxyType1 signum   fromInteger n = ConE 'Proxy `SigE` (ConT ''Proxy `AppT` fromInteger n) -#ifdef USE_TYPE_LITS addProxy :: Proxy a -> Proxy b -> Proxy (a + b) addProxy _ _ = Proxy mulProxy :: Proxy a -> Proxy b -> Proxy (a * b) mulProxy _ _ = Proxy-#if MIN_VERSION_base(4,8,0) subProxy :: Proxy a -> Proxy b -> Proxy (a - b) subProxy _ _ = Proxy-#else-subProxy :: Proxy a -> Proxy b -> Proxy c-subProxy _ _ = error "Exp.(-): undefined"-#endif---  fromInteger = LitT . NumTyLit-#else-addProxy :: Proxy a -> Proxy b -> Proxy c-addProxy _ _ = error "Exp.(+): undefined"-mulProxy :: Proxy a -> Proxy b -> Proxy c-mulProxy _ _ = error "Exp.(*): undefined"-subProxy :: Proxy a -> Proxy b -> Proxy c-subProxy _ _ = error "Exp.(-): undefined"+ #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.5.2.1+version:        2.1.9 license:        BSD3 license-file:   LICENSE author:         Edward A. Kmett, Elliott Hird, Oleg Kiselyov and Chung-chieh Shan@@ -16,8 +16,8 @@ cabal-version:  >= 1.10 description:   This package addresses the /configuration problem/ which is-  propogating configurations that are available at run-time, allowing-  multible configurations to coexist without resorting to mutable+  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@@ -25,19 +25,35 @@   and Chung-chieh Shan (<http://okmij.org/ftp/Haskell/tr-15-04.pdf original paper>).   However, the API has been streamlined to improve performance.   .-  Austin Seipp's tutorial <https://www.fpcomplete.com/user/thoughtpolice/using-reflection Reflecting values to types and back> provides a summary of the+  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/FromJSON.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  flag slow   description:@@ -59,20 +75,18 @@  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--  if impl(ghc < 7.8)-    build-depends:-      tagged >= 0.4.4 && < 1+    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))@@ -88,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@@ -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)