diff --git a/Data/Reflection.hs b/Data/Reflection.hs new file mode 100644 --- /dev/null +++ b/Data/Reflection.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE KindSignatures, RankNTypes, ScopedTypeVariables, EmptyDataDecls, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} + +---------------------------------------------------------------------------- +-- | +-- Module : Data.Reflection +-- Copyright : 2009 Edward Kmett, 2004 Oleg Kiselyov and Chung-chieh Shan +-- License : BSD3 +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable (scoped types, MPTCs, rank-n, FFI, kinds) +-- +-- Implementation of the Functional Pearl: Implicit Configurations paper by +-- Oleg Kiselyov and Chung-chieh Shan. +-- +-- +-- +-- Packaged and updated to work with the current implementation of scoped type +-- variables by Edward Kmett. +-- +------------------------------------------------------------------------------- + +module Data.Reflection + ( + -- * Reflect Integrals + ReflectNum + , reflectNum + , reifyIntegral + -- * Reflect Lists of Integrals + , ReflectNums + , reifyIntegrals + -- * Reflect Storables + , ReflectStorable + , reflectStorable + , reifyStorable + -- * Reflect Anything + , Reflect + , 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 + +data Zero +data Twice s +data Succ s +data Pred s + +class ReflectNum s where + reflectNum :: Num a => s -> a + +instance ReflectNum Zero where + reflectNum _ = 0 + +instance ReflectNum s => ReflectNum (Twice s) where + reflectNum _ = reflectNum (undefined :: s) * 2 + +instance ReflectNum s => ReflectNum (Succ s) where + reflectNum _ = reflectNum (undefined :: s) + 1 + +instance ReflectNum s => ReflectNum (Pred s) where + reflectNum _ = reflectNum (undefined :: s) - 1 + +reifyIntegral :: Integral a => a -> (forall s. ReflectNum s => s -> w) -> w +reifyIntegral i k = case quotRem i 2 of + (0, 0) -> k (undefined :: Zero) + (j, 0) -> reifyIntegral j (\(_ :: s) -> k (undefined :: Twice s)) + (j, 1) -> reifyIntegral j (\(_ :: s) -> k (undefined :: Succ (Twice s))) + (j,-1) -> reifyIntegral j (\(_ :: s) -> k (undefined :: Pred (Twice s))) + _ -> undefined + +data Nil +data Cons s ss + +class ReflectNums ss where + reflectNums :: Num a => ss -> [a] + +instance ReflectNums Nil where + reflectNums _ = [] + +instance (ReflectNum s, ReflectNums ss) => ReflectNums (Cons s ss) where + reflectNums _ = reflectNum (undefined :: s) : reflectNums (undefined :: ss) + +reifyIntegrals :: Integral a => [a] -> (forall ss. ReflectNums ss => ss -> w) -> w +reifyIntegrals [] k = k (undefined :: Nil) +reifyIntegrals (i:ii) k = + reifyIntegral i (\(_ :: s) -> + reifyIntegrals ii (\(_ :: ss) -> + k (undefined :: Cons s ss))) + +data Store s a + +class ReflectStorable s where + reflectStorable :: Storable a => s a -> a + +instance ReflectNums s => ReflectStorable (Store s) where + {-# NOINLINE reflectStorable #-} + reflectStorable _ = unsafePerformIO . alloca $ \p -> do + pokeArray (castPtr p) bytes + peek p + where + bytes = reflectNums (undefined :: s) :: [CChar] + +reifyStorable :: Storable a => a -> (forall s. ReflectStorable s => s a -> w) -> w +reifyStorable a k = reifyIntegrals (bytes :: [CChar]) (\(_ :: s) -> k (undefined :: Store s a)) + where + bytes = unsafePerformIO $ with a (peekArray (sizeOf a) . castPtr) +{-# NOINLINE reifyStorable #-} + +class Reflect s a | s -> a where + reflect :: s -> a + +data Stable (s :: * -> *) a + +{- +instance ReflectStorable s => Reflect (Stable s a) a where + reflect = unsafePerformIO . fmap const . deRefStablePtr $ reflectStorable (undefined :: s p) + +reify :: a -> (forall s. Reflect s a => s -> w) -> w +reify (a :: a) k = unsafePerformIO $ do + p <- newStablePtr a + reifyStorable p (\(_ :: s (StablePtr a)) -> return (k (undefined :: Stable s a))) +-} + +instance ReflectStorable s => Reflect (Stable s a) a where + reflect = unsafePerformIO $ do + a <- deRefStablePtr p + freeStablePtr p + return (const a) + where + p = reflectStorable (undefined :: s p) + {-# NOINLINE reflect #-} + +reify :: a -> (forall s. Reflect s a => s -> w) -> w +reify (a :: a) k = unsafePerformIO $ do + p <- newStablePtr a + reifyStorable p (\(_ :: s (StablePtr a)) -> + let k' s = (reflect :: Stable s a -> a) `seq` return (k s) + in k' (undefined :: Stable s a)) +{-# NOINLINE reify #-} diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2009 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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/runhaskell +> module Main (main) where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/reflection.cabal b/reflection.cabal new file mode 100644 --- /dev/null +++ b/reflection.cabal @@ -0,0 +1,22 @@ +name: reflection +version: 0.0.0 +license: BSD3 +license-file: LICENSE +author: Oleg Kiselyov and Chung-chieh Shan +maintainer: Edward A. Kmett +stability: experimental +homepage: http://www.cs.rutgers.edu/~ccshan/prepose/prepose.pdf +category: Data +synopsis: Functional Pearl: Implicit Configurations +copyright: 2009 Edward A. Kmett, 2004 Oleg Kiselyov and Chung-chieh Shan +description: Implementation of the code in "Functional Pearl: Implicit Configurations" by Oleg Kiselyov and Chung-chieh Shan +build-type: Simple +cabal-version: >=1.2 + +library + build-depends: + base >= 4 && < 4.1 + exposed-modules: + Data.Reflection + + ghc-options: -Wall