union 0.1.0.0 → 0.1.1.0

raw patch · 4 files changed

+142/−26 lines, 4 filesdep +deepseqdep +profunctorsdep +taggeddep ~lensPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: deepseq, profunctors, tagged

Dependency ranges changed: lens

API changes (from Hackage documentation)

Files

• bench/Benchmark.hs +45/−7
• src/Data/Union.hs +43/−15
• src/Data/Union/Prism.hs +41/−0
• union.cabal +13/−4

@@ -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 ()     ]

@@ -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 '[]) 

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

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