diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs --- a/bench/Benchmark.hs +++ b/bench/Benchmark.hs @@ -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 ] diff --git a/src/Data/Union.hs b/src/Data/Union.hs --- a/src/Data/Union.hs +++ b/src/Data/Union.hs @@ -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 -:7:6: error: - • No instance for (UElem Char '[] (RIndex Char '[])) +: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)) diff --git a/src/Data/Union/Prism.hs b/src/Data/Union/Prism.hs --- a/src/Data/Union/Prism.hs +++ b/src/Data/Union/Prism.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RankNTypes #-} module Data.Union.Prism ( Prism , prism diff --git a/union.cabal b/union.cabal --- a/union.cabal +++ b/union.cabal @@ -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 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