union (empty) → 0.1.0.0

raw patch · 5 files changed

+269/−0 lines, 5 filesdep +basedep +criteriondep +lenssetup-changed

Dependencies added: base, criterion, lens, union, vinyl

Files

LICENSE +30/−0
Setup.hs +2/−0
bench/Benchmark.hs +32/−0
src/Data/Union.hs +155/−0
union.cabal +50/−0

+ LICENSE view

@@ -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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ bench/Benchmark.hs view

@@ -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+    ]

+ src/Data/Union.hs view

@@ -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

+ union.cabal view

@@ -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 <vlad.z.4096@gmail.com>+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