union 0.1.2 → 0.1.3
raw patch · 4 files changed
+81/−97 lines, 4 filesdep ~base
Dependency ranges changed: base
Files
- bench/Benchmark.hs +30/−25
- src/Data/Union.hs +40/−49
- src/Data/Union/Prism.hs +0/−1
- union.cabal +11/−22
bench/Benchmark.hs view
@@ -1,28 +1,34 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}+{-# OPTIONS -Wno-missing-signatures #-}+{-# LANGUAGE NoListTuplePuns #-} module Main (main) where -import Control.Lens-import Criterion.Main-import Data.Dynamic-import Data.Union-import Data.Proxy+import Control.Lens ((#), (^?), _Right)+import Control.DeepSeq (NFData(rnf), rwhnf)+import Criterion.Main (whnf, nf, bench, defaultMain)+import Data.Dynamic (toDyn)+import Data.Union (OpenUnion, openUnion)+import Data.Proxy (Proxy) -union1 :: OpenUnion '[(), Proxy 0, Proxy 1]-union1 = openUnion # ()+data Unit = MkUnit++instance NFData Unit where+ rnf = rwhnf++union1 :: OpenUnion [Unit, Proxy 0, Proxy 1]+union1 = openUnion # MkUnit {-# NOINLINE union1 #-} -union3 :: OpenUnion '[Proxy 0, Proxy 1, ()]-union3 = openUnion # ()+union3 :: OpenUnion [Proxy 0, Proxy 1, Unit]+union3 = openUnion # MkUnit {-# NOINLINE union3 #-} type OpenUnion12 = OpenUnion- '[ Proxy 0, Proxy 1, Proxy 2, Proxy 3- , Proxy 4, Proxy 5, Proxy 6, Proxy 7- , Proxy 8, Proxy 9, Proxy 10, () ]+ [ Proxy 0, Proxy 1, Proxy 2, Proxy 3+ , Proxy 4, Proxy 5, Proxy 6, Proxy 7+ , Proxy 8, Proxy 9, Proxy 10, Unit ] union12 :: OpenUnion12-union12 = openUnion # ()+union12 = openUnion # MkUnit {-# NOINLINE union12 #-} either12 ::@@ -37,31 +43,30 @@ Either (Proxy 8) ( Either (Proxy 9) ( Either (Proxy 10) (- ()+ Unit ))))))))))) either12 = ( Right . Right . Right . Right . Right . Right . Right . Right- . Right . Right . Right ) ()+ . Right . Right . Right ) MkUnit {-# NOINLINE either12 #-} -main :: IO () main = do defaultMain [ bench "openUnion matching 1st" $- whnf (\a -> a ^? openUnion :: Maybe ()) union1+ whnf (\a -> a ^? openUnion :: Maybe Unit) union1 , bench "openUnion matching 3rd" $- whnf (\a -> a ^? openUnion :: Maybe ()) union3+ whnf (\a -> a ^? openUnion :: Maybe Unit) union3 , bench "openUnion matching 12th" $- whnf (\a -> a ^? openUnion :: Maybe ()) union12+ whnf (\a -> a ^? openUnion :: Maybe Unit) union12 , bench "nested either matching 12th" $ whnf (\a -> a ^? _Right . _Right . _Right . _Right . _Right . _Right . _Right . _Right- . _Right . _Right . _Right :: Maybe ()) either12+ . _Right . _Right . _Right :: Maybe Unit) either12 , bench "openUnion constructing 1st" $- nf (\a -> openUnion # a :: OpenUnion '[()]) ()+ nf (\a -> openUnion # a :: OpenUnion [Unit]) MkUnit , bench "openUnion constructing 12th" $- nf (\a -> openUnion # a :: OpenUnion12) ()+ nf (\a -> openUnion # a :: OpenUnion12) MkUnit , bench "dyn constructing" $- whnf toDyn ()+ whnf toDyn MkUnit ]
src/Data/Union.hs view
@@ -1,21 +1,11 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoListTuplePuns #-} {-# LANGUAGE TypeFamilies #-} {- | Extensible type-safe unions. ->>> let a = openUnion # (5 :: Int) :: OpenUnion '[Bool, Int]+>>> let a = openUnion # (5 :: Int) :: OpenUnion [Bool, Int] >>> a ^? openUnion @Int Just 5@@ -24,13 +14,12 @@ Nothing >>> a ^? openUnion @Char-<interactive>:7:6: error:- • No instance for (UElem Char '[] (RIndex Char '[]))+<interactive>:10:6: error: [GHC-39999]+ • No instance for ‘UElem Char [] (RIndex Char [])’ arising from a use of ‘openUnion’ • In the second argument of ‘(^?)’, namely ‘openUnion @Char’ In the expression: a ^? openUnion @Char In an equation for ‘it’: it = a ^? openUnion @Char- -} module Data.Union@@ -49,6 +38,8 @@ import Control.Applicative import Control.DeepSeq import Control.Exception+import Data.List (List)+import Data.Kind (Type) import Data.Functor.Identity import Data.Typeable import Data.Vinyl.TypeLevel@@ -58,21 +49,21 @@ -- | 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)+-- inhabitants of the kind @u@; the type of values at any label @a :: u@+-- is given by its interpretation @f a :: Type@.+data Union (f :: u -> Type) (as :: List 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 :: (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 :: Union f [] -> a absurdUnion = \case{} umap :: (forall a . f a -> g a) -> Union f as -> Union g as@@ -80,15 +71,15 @@ 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 (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 (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+class i ~ RIndex a as => UElem (a :: u) (as :: List u) (i :: Nat) where {-# MINIMAL uprism | ulift, umatch #-} uprism :: Prism' (Union f as) (f a)@@ -100,19 +91,19 @@ umatch :: Union f as -> Maybe (f a) umatch = preview uprism -instance UElem a (a ': as) 'Z where+instance UElem a (a : as) Z where uprism = _This {-# INLINE uprism #-} instance- ( RIndex a (b ': as) ~ 'S i+ ( RIndex a (b : as) ~ S i , UElem a as i- ) => UElem a (b ': as) ('S 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+class is ~ RImage as bs => USubset (as :: List u) (bs :: List u) is where {-# MINIMAL usubset | urelax, urestrict #-} usubset :: Prism' (Union f bs) (Union f as)@@ -124,14 +115,14 @@ urestrict :: Union f bs -> Maybe (Union f as) urestrict = preview usubset -instance USubset '[] bs '[] where+instance USubset [] bs [] where urelax = absurdUnion urestrict _ = Nothing instance ( UElem a bs i , USubset as bs is- ) => USubset (a ': as) bs (i ': is) where+ ) => USubset (a : as) bs (i : is) where urelax = union urelax ulift urestrict ubs = This <$> umatch ubs <|> That <$> urestrict ubs @@ -141,59 +132,59 @@ openUnion = uprism . iso runIdentity Identity {-# INLINE openUnion #-} -instance NFData (Union f '[]) where+instance NFData (Union f []) where rnf = absurdUnion instance ( NFData (f a) , NFData (Union f as)- ) => NFData (Union f (a ': as))+ ) => NFData (Union f (a : as)) where rnf = union rnf rnf -instance Show (Union f '[]) where+instance Show (Union f []) where showsPrec _ = absurdUnion instance ( Show (f a) , Show (Union f as)- ) => Show (Union f (a ': as))+ ) => Show (Union f (a : as)) where showsPrec n = union (showsPrec n) (showsPrec n) -instance Eq (Union f '[]) where+instance Eq (Union f []) where (==) = absurdUnion instance ( Eq (f a) , Eq (Union f as)- ) => Eq (Union f (a ': as))+ ) => Eq (Union f (a : as)) where This a1 == This a2 = a1 == a2 That u1 == That u2 = u1 == u2 _ == _ = False -instance Ord (Union f '[]) where+instance Ord (Union f []) where compare = absurdUnion instance ( Ord (f a) , Ord (Union f as)- ) => Ord (Union f (a ': as))+ ) => Ord (Union f (a : as)) where 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 '[])+instance f ~ Identity => Exception (Union f []) instance ( f ~ Identity , Exception a , Typeable as , Exception (Union f as)- ) => Exception (Union f (a ': as))+ ) => Exception (Union f (a : as)) where toException = union toException (toException . runIdentity) fromException sE = matchR <|> matchL@@ -201,19 +192,19 @@ matchR = This . Identity <$> fromException sE matchL = That <$> fromException sE -instance G.Generic (Union f '[]) where- type Rep (Union f '[]) = G.V1+instance G.Generic (Union f []) where+ type Rep (Union f []) = G.V1 from = absurdUnion to = \case{} -instance G.Generic (Union f (a ': as)) where- type Rep (Union f (a ': as)) =- G.C1 ('G.MetaCons "This" 'G.PrefixI 'False) (G.Rec0 (f a)) G.:+:- G.C1 ('G.MetaCons "That" 'G.PrefixI 'False) (G.Rec0 (Union f as))+instance G.Generic (Union f (a : as)) where+ type Rep (Union f (a : as)) =+ G.C1 (G.MetaCons "This" G.PrefixI False) (G.Rec0 (f a)) G.:+:+ G.C1 (G.MetaCons "That" G.PrefixI False) (G.Rec0 (Union f as)) from = union (G.R1 . G.M1 . G.K1) (G.L1 . G.M1 . G.K1) to = \case G.L1 (G.M1 (G.K1 a)) -> This a G.R1 (G.M1 (G.K1 u)) -> That u -instance Hashable (Union f '[])-instance (Hashable (f a), Hashable (Union f as)) => Hashable (Union f (a ': as))+instance Hashable (Union f [])+instance (Hashable (f a), Hashable (Union f as)) => Hashable (Union f (a : as))
src/Data/Union/Prism.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE RankNTypes #-} module Data.Union.Prism ( Prism , prism
union.cabal view
@@ -1,5 +1,6 @@+cabal-version: 2.2 name: union-version: 0.1.2+version: 0.1.3 synopsis: Extensible type-safe unions description: @@ -10,14 +11,13 @@ Neither requires a @Typeable@ constraint nor uses unsafe coercions at the cost of linear time access (negligible in practice). -license: BSD3+license: BSD-3-Clause license-file: LICENSE author: Vladislav Zavialov maintainer: Vladislav Zavialov <vlad.z.4096@gmail.com> bug-reports: https://github.com/int-index/union/issues category: Data build-type: Simple-cabal-version: >=1.10 source-repository head type: git@@ -26,25 +26,14 @@ library exposed-modules: Data.Union other-modules: Data.Union.Prism- other-extensions: DataKinds- EmptyCase- FlexibleContexts- FlexibleInstances- GADTs- LambdaCase- MultiParamTypeClasses- PolyKinds- RankNTypes- ScopedTypeVariables- TypeOperators- build-depends: base >=4.8 && <4.13- , vinyl >=0.5 && <0.11- , profunctors >=5.1 && <5.4+ build-depends: base >=4.20 && <4.22+ , vinyl >= 0.14.3 && <0.15+ , profunctors >=5.1 && <5.7 , tagged >=0.8 && <0.9- , deepseq >=1.4 && <1.5- , hashable >=1.2 && <1.3+ , deepseq >=1.4 && <1.7+ , hashable >=1.2 && <1.6 hs-source-dirs: src- default-language: Haskell2010+ default-language: GHC2024 ghc-options: -Wall benchmark bench@@ -56,5 +45,5 @@ , deepseq >=1.4.2 , criterion hs-source-dirs: bench- default-language: Haskell2010- ghc-options: -Wall -O2 -fno-warn-orphans+ default-language: GHC2024+ ghc-options: -Wall -O2 -Wno-orphans