data-diverse 0.8.1.0 → 0.9.0.0

raw patch · 8 files changed

+123/−50 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README.md +17/−10
• data-diverse.cabal +1/−1
• src/Data/Diverse/Many.hs +4/−2
• src/Data/Diverse/Many/Internal.hs +59/−25
• src/Data/Diverse/TypeLevel.hs +12/−0
• src/Data/Diverse/TypeLevel/Internal.hs +11/−11
• src/Data/Diverse/Which/Internal.hs +9/−1
• test/Data/Diverse/ManySpec.hs +10/−0

@@ -16,25 +16,32 @@ # Changelog  * 0.1.0.0-    Initial version represented as (Int, Data.Map Int Any)+  - Initial version represented as (Int, Data.Map Int Any)  * 0.4.0.0-    Removed Emit typeclass, breaking renames. Added label accessors.+  - Removed Emit typeclass, breaking renames. Added label accessors.  * 0.5.0.0-    Renamed type level functions module from Type to TypeLevel+  - Renamed type level functions module from Type to TypeLevel  * 0.6.0.0-    Moved lens to data-diverse-lens+  - Moved lens to data-diverse-lens  * 0.7.0.0-    Removed NOINLINE pragmas.-    Changed internal representation to (Int, Data.IntMap Any) for a 2.5x append speedup.+  - Removed NOINLINE pragmas.+  - Changed internal representation to (Int, Data.IntMap Any) for a 2.5x append speedup.  * 0.8.0.0-    Changed internal representation to (Data.Seq Any) for a further 2x append speedup.-    Added NFData instance for Many+  - Changed internal representation to (Data.Seq Any) for a further 2x append speedup.+  - Added NFData instance for Many.  * 0.8.1.0-    Added NFData instance for Which-    Forgot to expose Many.sliceL and Many.sliceR+  - Added NFData instance for Which.+  - Forgot to expose Many.sliceL and Many.sliceR.++* 0.9.0.0+  - Breaking changes: Renamed Many.sliceL/R to Many.viewf/b+  - Renamed TypeLevel.Internal.MissingImpl to IsUniqueImpl.+  - Added postifx' with SnocUnique and append' with AppendUnique.+  - Added Semigroup & Monoid instances for `Many '[]` and `Which '[]`+  - Fixed GHC 8.2 compile error with importing GHC.Prim (Any)

@@ -1,5 +1,5 @@ name:                data-diverse-version:             0.8.1.0+version:             0.9.0.0 synopsis:            Extensible records and polymorphic variants. description:         "Data.Diverse.Many" is an extensible record for any size encoded efficiently as (Seq Any).                      "Data.Diverse.Which" is a polymorphic variant of possibilities encoded as (Int, Any).

@@ -14,13 +14,15 @@     , prefix     , (./)     , postfix+    , postfix'     , (\.)     , append+    , append'     , (/./)      -- * Simple queries-    , sliceL-    , sliceR+    , viewf+    , viewb     , front     , back     , aft

@@ -31,13 +31,15 @@     , prefix     , (./)     , postfix+    , postfix'     , (\.)     , append+    , append'     , (/./)      -- * Simple queries-    , sliceL-    , sliceR+    , viewf+    , viewb     , front     , back     , aft@@ -95,9 +97,10 @@ import Data.Kind import Data.Proxy import qualified Data.Sequence as S+import Data.Semigroup (Semigroup(..)) import Data.Tagged import qualified GHC.Generics as G-import GHC.Prim (Any, coerce)+import GHC.Exts (Any, coerce) import GHC.TypeLits import Text.ParserCombinators.ReadPrec import Text.Read@@ -276,6 +279,13 @@  ----------------------------------------------------------------------- +instance Semigroup (Many '[]) where+    _ <> _ = nil++instance Monoid (Many '[]) where+    mempty = nil+    mappend = (<>)+ -- | Analogous to 'Prelude.null'. Named 'nil' to avoid conflicting with 'Prelude.null'. nil :: Many '[] nil = Many S.empty@@ -290,8 +300,8 @@ prefix x (Many rs) = Many ((unsafeCoerce x) S.<| rs) infixr 5 `prefix` -prefix' :: x -> Many_ xs -> Many_ (x ': xs)-prefix' x (Many_ xs) = Many_ (unsafeCoerce x : xs)+prefix_ :: x -> Many_ xs -> Many_ (x ': xs)+prefix_ x (Many_ xs) = Many_ (unsafeCoerce x : xs)  -- | Infix version of 'prefix'. --@@ -306,6 +316,16 @@ postfix (Many ls) y = Many (ls S.|> (unsafeCoerce y)) infixl 5 `postfix` +-- | Add an element to the right of a Many iff the field doesn't already exist.+postfix'+    :: forall xs y n.+       MaybeUniqueMemberAt n y xs+    => Many xs -> y -> Many (SnocUnique xs y)+postfix'(Many ls) y = if i /= 0 then Many ls else Many (ls S.|> (unsafeCoerce y))+  where+    i = fromInteger (natVal @n Proxy) :: Int+infixl 5 `postfix'`+ -- | Infix version of 'postfix'. -- -- Mnemonic: Many is larger '\.' than the smaller element@@ -325,47 +345,61 @@ append (Many ls) (Many rs) = Many (ls S.>< rs) infixr 5 `append` -- like Data.List (++) +class CanAppendUnique xs ys where+   -- | Appends the unique fields fields from the right Many using 'postfix''+   append' :: Many xs -> Many ys -> Many (AppendUnique xs ys)++instance CanAppendUnique xs '[] where+   append' ls _ = ls++instance (MaybeUniqueMemberAt n y xs, CanAppendUnique (SnocUnique xs y) ys) => CanAppendUnique xs (y ': ys) where+   append' ls rs = append' (postfix' ls r) rs'+     where (r, rs') = viewf rs+   {-# INLINABLE append' #-} -- This makes compiling tests a little faster than with no pragma++infixr 5 `append'` -- like Data.List (++)+ -----------------------------------------------------------------------  -- | Split a non-empty Many into the first element, then the rest of the Many. -- Analogous to 'S.viewl'-sliceL :: Many (x ': xs) -> (x, Many xs)-sliceL (Many xs) = case S.viewl xs of+viewf :: Many (x ': xs) -> (x, Many xs)+viewf (Many xs) = case S.viewl xs of     S.EmptyL -> error "no front"-    a S.:< ys -> (unsafeCoerce a, Many ys)+    (a S.:< ys) -> (unsafeCoerce a, Many ys)  -- | Split a non-empty Many into initial part of Many, and the last element. -- Analogous to 'S.viewr'-sliceR :: Many (x ': xs) -> (Many (Init (x ': xs)), Last (x ': xs))-sliceR (Many xs) = case S.viewr xs of+viewb :: Many (x ': xs) -> (Many (Init (x ': xs)), Last (x ': xs))+viewb (Many xs) = case S.viewr xs of     S.EmptyR -> error "no back"-    ys S.:> a -> (Many ys, unsafeCoerce a)+    (ys S.:> a) -> (Many ys, unsafeCoerce a)  -- | Extract the first element of a Many, which guaranteed to be non-empty. -- Analogous to 'Partial.head' front :: Many (x ': xs) -> x-front = fst . sliceL+front = fst . viewf -front' :: Many_ (x ': xs) -> x-front' (Many_ xs) = unsafeCoerce (Partial.head xs)+front_ :: Many_ (x ': xs) -> x+front_ (Many_ xs) = unsafeCoerce (Partial.head xs)  -- | Extract the 'back' element of a Many, which guaranteed to be non-empty. -- Analogous to 'Prelude.last' back :: Many (x ': xs) -> Last (x ': xs)-back = snd . sliceR+back = snd . viewb  -- | Extract the elements after the front of a Many, which guaranteed to be non-empty. -- Analogous to 'Partial.tail' aft :: Many (x ': xs) -> Many xs-aft = snd . sliceL+aft = snd . viewf -aft' :: Many_ (x ': xs) -> Many_ xs-aft' (Many_ xs) = Many_ (Partial.tail xs)+aft_ :: Many_ (x ': xs) -> Many_ xs+aft_ (Many_ xs) = Many_ (Partial.tail xs)  -- | Return all the elements of a Many except the 'back' one, which guaranteed to be non-empty. -- Analogous to 'Prelude.init' fore :: Many (x ': xs) -> Many (Init (x ': xs))-fore = fst . sliceR+fore = fst . viewb  -------------------------------------------------- @@ -917,9 +951,9 @@     _ == _ = True  instance (Eq x, Eq (Many_ xs)) => Eq (Many_ (x ': xs)) where-    ls == rs = case front' ls == front' rs of+    ls == rs = case front_ ls == front_ rs of         False -> False-        _ -> (aft' ls) == (aft' rs)+        _ -> (aft_ ls) == (aft_ rs)     {-# INLINABLE (==) #-} -- This makes compiling tests a little faster than with no pragma  -- | Two 'Many's are equal if all their fields equal@@ -932,10 +966,10 @@     compare _ _ = EQ  instance (Ord x, Ord (Many_ xs)) => Ord (Many_ (x ': xs)) where-    compare ls rs = case compare (front' ls) (front' rs) of+    compare ls rs = case compare (front_ ls) (front_ rs) of         LT -> LT         GT -> GT-        EQ -> compare (aft' ls) (aft' rs)+        EQ -> compare (aft_ ls) (aft_ rs)     {-# INLINABLE compare #-} -- This makes compiling tests a little faster than with no pragma  -- | Two 'Many's are ordered by 'compare'ing their fields in index order@@ -954,7 +988,7 @@         showParen (d > cons_prec) $         showsPrec (cons_prec + 1) v .         showString " ./ " .-        showsPrec cons_prec (aft' ls) -- not (cons-prec+1) for right associativity+        showsPrec cons_prec (aft_ ls) -- not (cons-prec+1) for right associativity       where         cons_prec = 5 -- infixr 5 prefix         -- use of front here is safe as we are guaranteed the length from the typelist@@ -979,7 +1013,7 @@         a <- step (readPrec @x)         lift $ L.expect (Symbol "./")         as <- readPrec @(Many_ xs) -- no 'step' to allow right associatitive './'-        pure $ prefix' a as+        pure $ prefix_ a as       where         cons_prec = 5 -- infixr `prefix`     {-# INLINABLE readPrec #-} -- This makes compiling tests a little faster than with no pragma

@@ -31,6 +31,17 @@ -- | Ensures that @x@ is a member of @xs@ at @n@ if it exists, and that 'natVal' can be used. type MaybeMemberAt n x xs = (KnownNat n, KindAtPositionIs n x xs) +-- | Snoc @x@ to end of @xs@ if @x@ doesn't already exist in @xs@+type family SnocUnique (xs :: [k]) (x :: k) :: [k] where+    SnocUnique '[] x  = '[x]+    SnocUnique (x ': xs) x = x ': xs+    SnocUnique (y ': xs) x = y ': SnocUnique xs x++-- | For each @y@ in @ys@, snocs them to end of @xs@ if @y@ doesn't already exist in @xs@+type family AppendUnique (xs :: [k]) (ys :: [k]) :: [k] where+    AppendUnique xs '[] = xs+    AppendUnique xs (y ': ys) = AppendUnique (SnocUnique xs y) ys+ -- | Ensures x is a unique member in @xs@ iff it exists in @ys@ type family UniqueIfExists ys x xs :: Constraint where     UniqueIfExists '[] x xs = ()@@ -80,6 +91,7 @@     KindsAtIndices '[] xs = '[]     KindsAtIndices (n ': ns) xs = KindAtIndex n xs ': KindsAtIndices ns xs +-- | Get the types with labels @ls@ from @xs@ type family KindsAtLabels (ls :: [k1]) (xs :: [k]) :: [k] where     KindsAtLabels '[] xs = '[]     KindsAtLabels (l ': ls) xs = KindAtLabel l xs ': KindsAtLabels ls xs

@@ -39,45 +39,45 @@     NubImpl ctx y (x ': xs) = NubImpl ctx y xs  -- | Errors if a type exists in a typelist-type family MissingImpl (ctx :: [k]) (y :: k) (xs :: [k]) :: Constraint where-    MissingImpl ctx y '[] = ()-    MissingImpl ctx x (x ': xs) = TypeError ('Text "Not unique error: ‘"+type family IsUniqueImpl (ctx :: [k]) (y :: k) (xs :: [k]) :: Constraint where+    IsUniqueImpl ctx y '[] = ()+    IsUniqueImpl ctx x (x ': xs) = TypeError ('Text "Not unique error: ‘"                                              ':<>: 'ShowType x                                              ':<>: 'Text "’"                                              ':<>: 'Text " is a duplicate in "                                              ':<>: 'Text "‘"                                              ':<>: 'ShowType ctx                                              ':<>: 'Text "’")-    MissingImpl ctx y (x ': xs) = (MissingImpl ctx y xs)+    IsUniqueImpl ctx y (x ': xs) = (IsUniqueImpl ctx y xs)  -- | Errors if a label exists in a typelist-type family MissingLabelImpl (ctx :: [k]) (l :: k2) (xs :: [k]) :: Constraint where-    MissingLabelImpl ctx y '[] = ()-    MissingLabelImpl ctx l (tagged l x ': xs) = TypeError ('Text "Not unique label error: ‘"+type family IsUniqueLabelImpl (ctx :: [k]) (l :: k2) (xs :: [k]) :: Constraint where+    IsUniqueLabelImpl ctx y '[] = ()+    IsUniqueLabelImpl ctx l (tagged l x ': xs) = TypeError ('Text "Not unique label error: ‘"                                              ':<>: 'ShowType l                                              ':<>: 'Text "’"                                              ':<>: 'Text " is a duplicate in "                                              ':<>: 'Text "‘"                                              ':<>: 'ShowType ctx                                              ':<>: 'Text "’")-    MissingLabelImpl ctx l (x ': xs) = (MissingLabelImpl ctx l xs)+    IsUniqueLabelImpl ctx l (x ': xs) = (IsUniqueLabelImpl ctx l xs)  -- | Ensures that the type list contain unique types. -- Not implemented as @(xs ~ Nub xs)@ for better type error messages. type family IsDistinctImpl (ctx :: [k]) (xs :: [k]) :: Constraint where     IsDistinctImpl ctx '[] = ()-    IsDistinctImpl ctx (x ': xs) = (MissingImpl ctx x xs, IsDistinctImpl ctx xs)+    IsDistinctImpl ctx (x ': xs) = (IsUniqueImpl ctx x xs, IsDistinctImpl ctx xs)  -- | Ensures that @x@ only ever appears once in @xs@ type family UniqueImpl (ctx :: [k]) (x :: k) (xs :: [k]) :: Constraint where     UniqueImpl ctx x '[] = ()-    UniqueImpl ctx x (x ': xs) = MissingImpl ctx x xs+    UniqueImpl ctx x (x ': xs) = IsUniqueImpl ctx x xs     UniqueImpl ctx x (y ': xs) = UniqueImpl ctx x xs  -- | Ensures that the @label@ in @tagged label v@ only ever appears once in @xs@. type family UniqueLabelImpl (ctx :: [k]) (l :: k1) (xs :: [k]) :: Constraint where     UniqueLabelImpl ctx l '[] = ()-    UniqueLabelImpl ctx l (tagged l x ': xs) = MissingLabelImpl ctx l xs+    UniqueLabelImpl ctx l (tagged l x ': xs) = IsUniqueLabelImpl ctx l xs     UniqueLabelImpl ctx l (y ': xs) = UniqueLabelImpl ctx l xs  -- | Indexed access into the list

@@ -65,8 +65,9 @@ import Data.Diverse.TypeLevel import Data.Kind import Data.Proxy+import Data.Semigroup (Semigroup(..)) import qualified GHC.Generics as G-import GHC.Prim (Any, coerce)+import GHC.Exts (Any, coerce) import GHC.TypeLits import Text.ParserCombinators.ReadPrec import Text.Read@@ -141,6 +142,13 @@         G.R1 ({- G.Rec0 -} G.K1 v) -> diversify0 v  -----------------------------------------------------------------------++instance Semigroup (Which '[]) where+    _ <> _ = impossible++instance Monoid (Which '[]) where+    mempty = impossible+    mappend = (<>)  -- | A 'Which' with no alternatives. You can't do anything with 'impossible' -- except Eq, Read, and Show it.

@@ -77,6 +77,16 @@             a /./ b `shouldBe` x             a `append` b `shouldBe` x +        it "can 'postfix'' a value only if that type doesn't already exist" $ do+            let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil+                y = x `postfix'` True+            y `shouldBe` x++        it "can 'append'' the unique types from another Many" $ do+            let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil+                y = (5 :: Int) ./ Just True ./ 'X' ./ Just False ./ Just (6 :: Int) ./ Just 'O' ./ nil+            (x `append'` y) `shouldBe` (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ Just True ./ Just (6 :: Int) ./ nil+         it "can contain multiple fields of the same type" $ do             let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil                 y = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil