diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs --- a/bench/Benchmark.hs +++ b/bench/Benchmark.hs @@ -1,11 +1,16 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} module Main (main) where +import Control.DeepSeq import Control.Lens import Criterion.Main -import Data.Proxy +import Data.Dynamic import Data.Union +instance NFData (Proxy (a :: k)) where + rnf Proxy = () + union1 :: OpenUnion '[(), Proxy 0, Proxy 1] union1 = openUnion # () {-# NOINLINE union1 #-} @@ -14,12 +19,35 @@ union3 = openUnion # () {-# NOINLINE union3 #-} -union7 :: OpenUnion +type OpenUnion12 = OpenUnion '[ Proxy 0, Proxy 1, Proxy 2, Proxy 3 - , Proxy 4 , Proxy 5, Proxy 6, () ] -union7 = openUnion # () -{-# NOINLINE union7 #-} + , Proxy 4, Proxy 5, Proxy 6, Proxy 7 + , Proxy 8, Proxy 9, Proxy 10, () ] +union12 :: OpenUnion12 +union12 = openUnion # () +{-# NOINLINE union12 #-} + +either12 :: + Either (Proxy 0) ( + Either (Proxy 1) ( + Either (Proxy 2) ( + Either (Proxy 3) ( + Either (Proxy 4) ( + Either (Proxy 5) ( + Either (Proxy 6) ( + Either (Proxy 7) ( + Either (Proxy 8) ( + Either (Proxy 9) ( + Either (Proxy 10) ( + () + ))))))))))) +either12 = + ( Right . Right . Right . Right + . Right . Right . Right . Right + . Right . Right . Right ) () +{-# NOINLINE either12 #-} + main :: IO () main = do defaultMain @@ -27,6 +55,16 @@ whnf (\a -> a ^? openUnion :: Maybe ()) union1 , bench "openUnion matching 3rd" $ whnf (\a -> a ^? openUnion :: Maybe ()) union3 - , bench "openUnion matching 7th" $ - whnf (\a -> a ^? openUnion :: Maybe ()) union7 + , bench "openUnion matching 12th" $ + whnf (\a -> a ^? openUnion :: Maybe ()) union12 + , bench "nested either matching 12th" $ + whnf (\a -> a ^? _Right . _Right . _Right . _Right + . _Right . _Right . _Right . _Right + . _Right . _Right . _Right :: Maybe ()) either12 + , bench "openUnion constructing 1st" $ + nf (\a -> openUnion # a :: OpenUnion '[()]) () + , bench "openUnion constructing 12th" $ + nf (\a -> openUnion # a :: OpenUnion12) () + , bench "dyn constructing" $ + whnf toDyn () ] diff --git a/src/Data/Union.hs b/src/Data/Union.hs --- a/src/Data/Union.hs +++ b/src/Data/Union.hs @@ -30,12 +30,12 @@ ) where import Control.Applicative +import Control.DeepSeq import Control.Exception -import Data.Function import Data.Functor.Identity import Data.Typeable import Data.Vinyl.TypeLevel -import Control.Lens +import Data.Union.Prism -- | A union is parameterized by a universe @u@, an interpretation @f@ -- and a list of labels @as@. The labels of the union are given by @@ -70,8 +70,17 @@ {-# INLINE _That #-} class i ~ RIndex a as => UElem (a :: u) (as :: [u]) (i :: Nat) where + {-# MINIMAL uprism | ulift, umatch #-} + uprism :: Prism' (Union f as) (f a) + uprism = prism' ulift umatch + ulift :: f a -> Union f as + ulift = review uprism + + umatch :: Union f as -> Maybe (f a) + umatch = preview uprism + instance UElem a (a ': as) 'Z where uprism = _This {-# INLINE uprism #-} @@ -85,39 +94,53 @@ {-# INLINE uprism #-} class is ~ RImage as bs => USubset (as :: [u]) (bs :: [u]) is where + {-# MINIMAL usubset | urelax, urestrict #-} + usubset :: Prism' (Union f bs) (Union f as) + usubset = prism' urelax urestrict + urelax :: Union f as -> Union f bs + urelax = review usubset + + urestrict :: Union f bs -> Maybe (Union f as) + urestrict = preview usubset + instance USubset '[] bs '[] where - usubset = prism absurdUnion Left + urelax = absurdUnion + urestrict _ = Nothing instance ( UElem a bs i , USubset as bs is ) => USubset (a ': as) bs (i ': is) where - usubset = prism - (union (review usubset) (review uprism)) - (\ubs -> maybe (Left ubs) Right - $ preview (uprism . re _This) ubs - <|> preview (usubset . re _That) ubs) + urelax = union urelax ulift + urestrict ubs = This <$> umatch ubs <|> That <$> urestrict ubs type OpenUnion = Union Identity -openUnion :: UElem a as (RIndex a as) => Prism' (OpenUnion as) a +openUnion :: forall a as . UElem a as (RIndex a as) => Prism' (OpenUnion as) a openUnion = uprism . iso runIdentity Identity {-# INLINE openUnion #-} +instance NFData (Union f '[]) where + rnf = absurdUnion + +instance + ( NFData (f a) + , NFData (Union f as) + ) => NFData (Union f (a ': as)) + where + rnf = union rnf rnf + instance Show (Union f '[]) where showsPrec _ = absurdUnion -unionToEither :: Union f (a ': as) -> Either (Union f as) (f a) -unionToEither = union Left Right - instance ( Show (f a) , Show (Union f as) ) => Show (Union f (a ': as)) where - showsPrec n = showsPrec n . unionToEither + showsPrec n = union (showsPrec n) (showsPrec n) instance Eq (Union f '[]) where (==) = absurdUnion @@ -127,7 +150,9 @@ , Eq (Union f as) ) => Eq (Union f (a ': as)) where - (==) = (==) `on` unionToEither + This a1 == This a2 = a1 == a2 + That u1 == That u2 = u1 == u2 + _ == _ = False instance Ord (Union f '[]) where compare = absurdUnion @@ -137,7 +162,10 @@ , Ord (Union f as) ) => Ord (Union f (a ': as)) where - compare = compare `on` unionToEither + compare (This a1) (This a2) = compare a1 a2 + compare (That u1) (That u2) = compare u1 u2 + compare (This _) (That _) = LT + compare (That _) (This _) = GT instance f ~ Identity => Exception (Union f '[]) diff --git a/src/Data/Union/Prism.hs b/src/Data/Union/Prism.hs new file mode 100644 --- /dev/null +++ b/src/Data/Union/Prism.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE RankNTypes #-} +module Data.Union.Prism + ( Prism + , prism + , Prism' + , prism' + , iso + , review + , preview + ) where + +import Control.Applicative +import Data.Functor.Identity +import Data.Monoid +import Data.Profunctor +import Data.Coerce +import Data.Tagged + +type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) +type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) +type Prism' s a = Prism s s a a + +iso :: (s -> a) -> (b -> t) -> Iso s t a b +iso sa bt = dimap sa (fmap bt) +{-# INLINE iso #-} + +prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b +prism bt seta = dimap seta (either pure (fmap bt)) . right' +{-# INLINE prism #-} + +prism' :: (a -> s) -> (s -> Maybe a) -> Prism' s a +prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s)) +{-# INLINE prism' #-} + +review :: Prism' t b -> b -> t +review p = coerce . p . Tagged . Identity +{-# INLINE review #-} + +preview :: Prism' s a -> s -> Maybe a +preview l = coerce . l (Const . First . Just) +{-# INLINE preview #-} diff --git a/union.cabal b/union.cabal --- a/union.cabal +++ b/union.cabal @@ -1,5 +1,5 @@ name: union -version: 0.1.0.0 +version: 0.1.1.0 synopsis: Extensible type-safe unions description: @@ -8,18 +8,24 @@ corecords or polymorphic variants. Neither requires a @Typeable@ constraint nor uses unsafe coercions - at the cost of a performance hit. + at the cost of linear time access (negligible in practice). license: BSD3 license-file: LICENSE author: Index Int maintainer: Index Int +bug-reports: https://github.com/int-index/union/issues category: Data build-type: Simple cabal-version: >=1.10 +source-repository head + type: git + location: git@github.com:int-index/union.git + library exposed-modules: Data.Union + other-modules: Data.Union.Prism other-extensions: DataKinds EmptyCase FlexibleContexts @@ -33,7 +39,9 @@ TypeOperators build-depends: base >=4.8 && <4.10 , vinyl >=0.5 && <0.6 - , lens >=4.13 && <4.14 + , profunctors >=5.1 && <5.3 + , tagged >=0.8 && <0.9 + , deepseq >=1.4 && <1.5 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -44,7 +52,8 @@ build-depends: base , union , lens + , deepseq , criterion hs-source-dirs: bench default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall -O2 -fno-warn-orphans