diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Index Int + +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 Index Int 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.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs new file mode 100644 --- /dev/null +++ b/bench/Benchmark.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DataKinds #-} +module Main (main) where + +import Control.Lens +import Criterion.Main +import Data.Proxy +import Data.Union + +union1 :: OpenUnion '[(), Proxy 0, Proxy 1] +union1 = openUnion # () +{-# NOINLINE union1 #-} + +union3 :: OpenUnion '[Proxy 0, Proxy 1, ()] +union3 = openUnion # () +{-# NOINLINE union3 #-} + +union7 :: OpenUnion + '[ Proxy 0, Proxy 1, Proxy 2, Proxy 3 + , Proxy 4 , Proxy 5, Proxy 6, () ] +union7 = openUnion # () +{-# NOINLINE union7 #-} + +main :: IO () +main = do + defaultMain + [ bench "openUnion matching 1st" $ + 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 + ] diff --git a/src/Data/Union.hs b/src/Data/Union.hs new file mode 100644 --- /dev/null +++ b/src/Data/Union.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | + +Extensible type-safe unions. + +-} + +module Data.Union + ( Union(..) + , union + , absurdUnion + , umap + , _This + , _That + , UElem(..) + , USubset(..) + , OpenUnion + , openUnion + ) where + +import Control.Applicative +import Control.Exception +import Data.Function +import Data.Functor.Identity +import Data.Typeable +import Data.Vinyl.TypeLevel +import Control.Lens + +-- | 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 +-- inhabitants of the kind @u@; the type of values at any label @a :: +-- u@ is given by its interpretation @f a :: *@. +data Union (f :: u -> *) (as :: [u]) where + This :: !(f a) -> Union f (a ': as) + That :: !(Union f as) -> Union f (a ': as) + +-- | Case analysis for unions. +union :: (Union f as -> c) -> (f a -> c) -> Union f (a ': as) -> c +union onThat onThis = \case + This a -> onThis a + That u -> onThat u + +-- | Since a union with an empty list of labels is uninhabited, we +-- can recover any type from it. +absurdUnion :: Union f '[] -> a +absurdUnion = \case{} + +umap :: (forall a . f a -> g a) -> Union f as -> Union g as +umap f = \case + This a -> This (f a) + That u -> That (umap f u) + +_This :: Prism (Union f (a ': as)) (Union f (b ': as)) (f a) (f b) +_This = prism This (union (Left . That) Right) +{-# INLINE _This #-} + +_That :: Prism (Union f (a ': as)) (Union f (a ': bs)) (Union f as) (Union f bs) +_That = prism That (union Right (Left . This)) +{-# INLINE _That #-} + +class i ~ RIndex a as => UElem (a :: u) (as :: [u]) (i :: Nat) where + uprism :: Prism' (Union f as) (f a) + +instance UElem a (a ': as) 'Z where + uprism = _This + {-# INLINE uprism #-} + +instance + ( RIndex a (b ': as) ~ 'S i + , UElem a as i + ) => UElem a (b ': as) ('S i) + where + uprism = _That . uprism + {-# INLINE uprism #-} + +class is ~ RImage as bs => USubset (as :: [u]) (bs :: [u]) is where + usubset :: Prism' (Union f bs) (Union f as) + +instance USubset '[] bs '[] where + usubset = prism absurdUnion Left + +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) + +type OpenUnion = Union Identity + +openUnion :: UElem a as (RIndex a as) => Prism' (OpenUnion as) a +openUnion = uprism . iso runIdentity Identity +{-# INLINE openUnion #-} + +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 + +instance Eq (Union f '[]) where + (==) = absurdUnion + +instance + ( Eq (f a) + , Eq (Union f as) + ) => Eq (Union f (a ': as)) + where + (==) = (==) `on` unionToEither + +instance Ord (Union f '[]) where + compare = absurdUnion + +instance + ( Ord (f a) + , Ord (Union f as) + ) => Ord (Union f (a ': as)) + where + compare = compare `on` unionToEither + +instance f ~ Identity => Exception (Union f '[]) + +instance + ( f ~ Identity + , Exception a + , Typeable as + , Exception (Union f as) + ) => Exception (Union f (a ': as)) + where + toException = union toException (toException . runIdentity) + fromException sE = matchR <|> matchL + where + matchR = This . Identity <$> fromException sE + matchL = That <$> fromException sE diff --git a/union.cabal b/union.cabal new file mode 100644 --- /dev/null +++ b/union.cabal @@ -0,0 +1,50 @@ +name: union +version: 0.1.0.0 +synopsis: Extensible type-safe unions +description: + + Extensible type-safe unions for Haskell with prisms using modern + GHC features. Dual to vinyl records. Unions are also known as + corecords or polymorphic variants. + + Neither requires a @Typeable@ constraint nor uses unsafe coercions + at the cost of a performance hit. + +license: BSD3 +license-file: LICENSE +author: Index Int +maintainer: Index Int +category: Data +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Data.Union + other-extensions: DataKinds + EmptyCase + FlexibleContexts + FlexibleInstances + GADTs + LambdaCase + MultiParamTypeClasses + PolyKinds + RankNTypes + ScopedTypeVariables + TypeOperators + build-depends: base >=4.8 && <4.10 + , vinyl >=0.5 && <0.6 + , lens >=4.13 && <4.14 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +benchmark bench + type: exitcode-stdio-1.0 + main-is: Benchmark.hs + build-depends: base + , union + , lens + , criterion + hs-source-dirs: bench + default-language: Haskell2010 + ghc-options: -Wall