diff --git a/Data/Proxy.hs b/Data/Proxy.hs new file mode 100644 --- /dev/null +++ b/Data/Proxy.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} +---------------------------------------------------------------------------- +-- | +-- Module : Data.Proxy +-- Copyright : 2009-2011 Edward Kmett +-- License : BSD3 +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : generalized newtype deriving +-- +------------------------------------------------------------------------------- + +module Data.Proxy + ( + -- * Tagged values + Proxy(..) + , reproxy + , asProxyTypeOf + -- * Conversion + , proxy + , unproxy + ) where + +import Control.Applicative (Applicative(..)) +import Data.Traversable (Traversable(..)) +import Data.Foldable (Foldable(..)) +import Data.Monoid (Monoid(..)) +import Data.Default (Default(..)) +import Data.Data (Data,Typeable) +import Data.Ix (Ix(..)) +import Data.Tagged +#ifdef __GLASGOW_HASKELL__ +import GHC.Arr (unsafeIndex, unsafeRangeSize) +#endif + +data Proxy p = Proxy deriving + ( Eq, Ord, Show, Read +#ifdef LANGUAGE_DeriveDataTypeable + , Data,Typeable +#endif + ) + +instance Enum (Proxy s) where + succ _ = error "Proxy.succ" + pred _ = error "Proxy.pred" + fromEnum _ = 0 + toEnum 0 = Proxy + toEnum _ = error "Proxy.toEnum: 0 expected" + enumFrom _ = [Proxy] + enumFromThen _ _ = [Proxy] + enumFromThenTo _ _ _ = [Proxy] + enumFromTo _ _ = [Proxy] + +{- +Work around for the following GHC bug with deriving Ix instances with a phantom type: + +Data/Tagged.hs:1:0: + Expecting an ordinary type, but found a type of kind * -> * + In an expression type signature: Proxy + In the expression: ghc-prim:GHC.Prim.tagToEnum# a :: Proxy + In the definition of `Data.Tagged.$tag2con_Proxy': + Data.Tagged.$tag2con_Proxy (ghc-prim:GHC.Types.I# a) + = ghc-prim:GHC.Prim.tagToEnum# a :: Proxy + +-} + +instance Ix (Proxy s) where + range _ = [Proxy] + index _ _ = 0 + inRange _ _ = True + rangeSize _ = 1 +#ifdef __GLASGOW_HASKELL__ + unsafeIndex _ _ = 0 + unsafeRangeSize _ = 1 +#endif + +instance Bounded (Proxy s) where + minBound = Proxy + maxBound = Proxy + +instance Functor Proxy where + fmap _ _ = Proxy + {-# INLINE fmap #-} + +instance Applicative Proxy where + pure _ = Proxy + {-# INLINE pure #-} + _ <*> _ = Proxy + {-# INLINE (<*>) #-} + +instance Monoid (Proxy s) where + mempty = Proxy + {-# INLINE mempty #-} + mappend _ _ = Proxy + {-# INLINE mappend #-} + mconcat _ = Proxy + {-# INLINE mconcat #-} + +instance Monad Proxy where + return _ = Proxy + {-# INLINE return #-} + _ >>= _ = Proxy + {-# INLINE (>>=) #-} + +instance Foldable Proxy where + foldMap _ _ = mempty + {-# INLINE foldMap #-} + fold _ = mempty + {-# INLINE fold #-} + foldr _ z _ = z + {-# INLINE foldr #-} + foldl _ z _ = z + {-# INLINE foldl #-} + foldl1 _ _ = error "foldl1: Proxy" + {-# INLINE foldl1 #-} + foldr1 _ _ = error "foldr1: Proxy" + {-# INLINE foldr1 #-} + +instance Traversable Proxy where + traverse _ _ = pure Proxy + {-# INLINE traverse #-} + sequenceA _ = pure Proxy + {-# INLINE sequenceA #-} + mapM _ _ = return Proxy + {-# INLINE mapM #-} + sequence _ = return Proxy + {-# INLINE sequence #-} + +instance Default (Proxy s) where + def = Proxy + {-# INLINE def #-} + +-- | Some times you need to change the tag you have lying around. +-- Idiomatic usage is to make a new combinator for the relationship +-- between the tags that you want to enforce, and define that +-- combinator using 'retag'. +-- +-- > data Succ n +-- > reproxySucc :: Proxy n -> Proxy (Succ n) +-- > reproxySucc = reproxy +reproxy :: Proxy s -> Proxy t +reproxy _ = Proxy +{-# INLINE reproxy #-} + +-- | Convert from a 'Tagged' representation to a representation +-- based on a 'Proxy'. +proxy :: Tagged s a -> Proxy s -> a +proxy (Tagged x) _ = x +{-# INLINE proxy #-} + +-- | Convert from a representation based on a 'Proxy' to a 'Tagged' +-- representation. +unproxy :: (Proxy s -> a) -> Tagged s a +unproxy f = Tagged (f Proxy) +{-# INLINE unproxy #-} + +-- | 'asProxyTypeOf' is a type-restricted version of 'const'. +-- It is usually used as an infix operator, and its typing forces its first +-- argument (which is usually overloaded) to have the same type as the tag +-- of the second. +asProxyTypeOf :: a -> Proxy a -> a +asProxyTypeOf = const +{-# INLINE asProxyTypeOf #-} diff --git a/Data/Tagged.hs b/Data/Tagged.hs --- a/Data/Tagged.hs +++ b/Data/Tagged.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} ---------------------------------------------------------------------------- -- | -- Module : Data.Tagged --- Copyright : 2009 Edward Kmett +-- Copyright : 2009-2011 Edward Kmett -- License : BSD3 -- -- Maintainer : Edward Kmett -- Stability : experimental --- Portability : portable +-- Portability : generalized newtype deriving -- ------------------------------------------------------------------------------- @@ -20,24 +20,14 @@ , tagSelf , untagSelf , asTaggedTypeOf - -- * Proxy values - , Proxy(..) - , reproxy - , asProxyTypeOf - -- * Conversion - , proxy - , unproxy ) where import Control.Applicative ((<$>), Applicative(..)) import Control.Monad (liftM) import Data.Traversable (Traversable(..)) import Data.Foldable (Foldable(..)) -import Data.Monoid (Monoid(..)) -import Data.Default (Default(..)) import Data.Data (Data,Typeable) import Data.Ix (Ix(..)) -import GHC.Arr (unsafeIndex, unsafeRangeSize) import Text.Read -- | A @'Tagged' s b@ value is a value @b@ with an attached phantom type @s@. @@ -48,13 +38,17 @@ -- Moreover, you don't have to rely on the compiler to inline away the extra -- argument, because the newtype is "free" -newtype Tagged s b = Tagged { unTagged :: b } - deriving (Eq,Ord,Ix,Enum,Bounded,Data,Typeable,Num,Real,Integral,Fractional,Floating,RealFrac,RealFloat) +newtype Tagged s b = Tagged { unTagged :: b } deriving + ( Eq, Ord, Ix, Enum, Bounded, Num, Real, Integral, Fractional, Floating, RealFrac, RealFloat +#ifdef LANGUAGE_DeriveDataTypeable + , Data, Typeable +#endif + ) instance Show b => Show (Tagged s b) where showsPrec n (Tagged b) = showParen (n > 10) $ showString "Tagged " . - showsPrec 10 b + showsPrec 11 b instance Read b => Read (Tagged s b) where readPrec = parens $ prec 10 $ do @@ -133,125 +127,3 @@ untagSelf (Tagged x) = x {-# INLINE untagSelf #-} -data Proxy p = Proxy - deriving (Eq,Ord,Show,Read,Data,Typeable) - -instance Enum (Proxy s) where - succ _ = error "Proxy.succ" - pred _ = error "Proxy.pred" - fromEnum _ = 0 - toEnum 0 = Proxy - toEnum _ = error "Proxy.toEnum: 0 expected" - enumFrom _ = [Proxy] - enumFromThen _ _ = [Proxy] - enumFromThenTo _ _ _ = [Proxy] - enumFromTo _ _ = [Proxy] - -{- -Work around for the following GHC bug with deriving Ix instances with a phantom type: - -Data/Tagged.hs:1:0: - Expecting an ordinary type, but found a type of kind * -> * - In an expression type signature: Proxy - In the expression: ghc-prim:GHC.Prim.tagToEnum# a :: Proxy - In the definition of `Data.Tagged.$tag2con_Proxy': - Data.Tagged.$tag2con_Proxy (ghc-prim:GHC.Types.I# a) - = ghc-prim:GHC.Prim.tagToEnum# a :: Proxy - --} - -instance Ix (Proxy s) where - range _ = [Proxy] - index _ _ = 0 - unsafeIndex _ _ = 0 - inRange _ _ = True - rangeSize _ = 1 - unsafeRangeSize _ = 1 - -instance Bounded (Proxy s) where - minBound = Proxy - maxBound = Proxy - -instance Functor Proxy where - fmap _ _ = Proxy - {-# INLINE fmap #-} - -instance Applicative Proxy where - pure _ = Proxy - {-# INLINE pure #-} - _ <*> _ = Proxy - {-# INLINE (<*>) #-} - -instance Monoid (Proxy s) where - mempty = Proxy - {-# INLINE mempty #-} - mappend _ _ = Proxy - {-# INLINE mappend #-} - mconcat _ = Proxy - {-# INLINE mconcat #-} - -instance Monad Proxy where - return _ = Proxy - {-# INLINE return #-} - _ >>= _ = Proxy - {-# INLINE (>>=) #-} - -instance Foldable Proxy where - foldMap _ _ = mempty - {-# INLINE foldMap #-} - fold _ = mempty - {-# INLINE fold #-} - foldr _ z _ = z - {-# INLINE foldr #-} - foldl _ z _ = z - {-# INLINE foldl #-} - foldl1 _ _ = error "foldl1: Proxy" - {-# INLINE foldl1 #-} - foldr1 _ _ = error "foldr1: Proxy" - {-# INLINE foldr1 #-} - -instance Traversable Proxy where - traverse _ _ = pure Proxy - {-# INLINE traverse #-} - sequenceA _ = pure Proxy - {-# INLINE sequenceA #-} - mapM _ _ = return Proxy - {-# INLINE mapM #-} - sequence _ = return Proxy - {-# INLINE sequence #-} - -instance Default (Proxy s) where - def = Proxy - {-# INLINE def #-} - --- | Some times you need to change the tag you have lying around. --- Idiomatic usage is to make a new combinator for the relationship --- between the tags that you want to enforce, and define that --- combinator using 'retag'. --- --- > data Succ n --- > reproxySucc :: Proxy n -> Proxy (Succ n) --- > reproxySucc = reproxy -reproxy :: Proxy s -> Proxy t -reproxy _ = Proxy -{-# INLINE reproxy #-} - --- | Convert from a 'Tagged' representation to a representation --- based on a 'Proxy'. -proxy :: Tagged s a -> Proxy s -> a -proxy (Tagged x) _ = x -{-# INLINE proxy #-} - --- | Convert from a representation based on a 'Proxy' to a 'Tagged' --- representation. -unproxy :: (Proxy s -> a) -> Tagged s a -unproxy f = Tagged (f Proxy) -{-# INLINE unproxy #-} - --- | 'asProxyTypeOf' is a type-restricted version of 'const'. --- It is usually used as an infix operator, and its typing forces its first --- argument (which is usually overloaded) to have the same type as the tag --- of the second. -asProxyTypeOf :: a -> Proxy a -> a -asProxyTypeOf = const -{-# INLINE asProxyTypeOf #-} diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009 Edward Kmett +Copyright (c) 2009-2011 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/tagged.cabal b/tagged.cabal --- a/tagged.cabal +++ b/tagged.cabal @@ -1,22 +1,34 @@ -name: tagged -version: 0.1.1 -license: BSD3 +name: tagged +version: 0.2 +license: BSD3 license-file: LICENSE -author: Edward A. Kmett -maintainer: Edward A. Kmett -stability: experimental -category: Data, Phantom Types -synopsis: Provides newtype wrappers for phantom types to avoid unsafely passing dummy arguments +author: Edward A. Kmett +maintainer: Edward A. Kmett +stability: experimental +category: Data, Phantom Types +synopsis: Provides newtype wrappers for phantom types to avoid unsafely passing dummy arguments homepage: http://github.com/ekmett/tagged -copyright: 2009 Edward A. Kmett +copyright: 2009-2011 Edward A. Kmett description: Provides newtype wrappers for phantom types to avoid unsafely passing dummy arguments build-type: Simple -cabal-version: >=1.2 +cabal-version: >=1.6 +source-repository head + type: git + location: git://github.com/ekmett/tagged.git + +flag DeriveDataTypeable + default: True + manual: False + library + if flag(DeriveDataTypeable) + cpp-options: -DLANGUAGE_DeriveDataTypeable + extensions: DeriveDataTypeable build-depends: base >= 4 && < 5, data-default >= 0.2 && < 3 exposed-modules: Data.Tagged + Data.Proxy ghc-options: -Wall