diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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) diff --git a/data-diverse.cabal b/data-diverse.cabal --- a/data-diverse.cabal +++ b/data-diverse.cabal @@ -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). diff --git a/src/Data/Diverse/Many.hs b/src/Data/Diverse/Many.hs --- a/src/Data/Diverse/Many.hs +++ b/src/Data/Diverse/Many.hs @@ -14,13 +14,15 @@ , prefix , (./) , postfix + , postfix' , (\.) , append + , append' , (/./) -- * Simple queries - , sliceL - , sliceR + , viewf + , viewb , front , back , aft diff --git a/src/Data/Diverse/Many/Internal.hs b/src/Data/Diverse/Many/Internal.hs --- a/src/Data/Diverse/Many/Internal.hs +++ b/src/Data/Diverse/Many/Internal.hs @@ -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 diff --git a/src/Data/Diverse/TypeLevel.hs b/src/Data/Diverse/TypeLevel.hs --- a/src/Data/Diverse/TypeLevel.hs +++ b/src/Data/Diverse/TypeLevel.hs @@ -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 diff --git a/src/Data/Diverse/TypeLevel/Internal.hs b/src/Data/Diverse/TypeLevel/Internal.hs --- a/src/Data/Diverse/TypeLevel/Internal.hs +++ b/src/Data/Diverse/TypeLevel/Internal.hs @@ -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 diff --git a/src/Data/Diverse/Which/Internal.hs b/src/Data/Diverse/Which/Internal.hs --- a/src/Data/Diverse/Which/Internal.hs +++ b/src/Data/Diverse/Which/Internal.hs @@ -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. diff --git a/test/Data/Diverse/ManySpec.hs b/test/Data/Diverse/ManySpec.hs --- a/test/Data/Diverse/ManySpec.hs +++ b/test/Data/Diverse/ManySpec.hs @@ -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