diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +# 0.4.0.0 + +- Created `Microsurgery` module. Initial set of surgeries: + + + `Derecordify` + + `Typeage` + + `RenameFields`, `RenameConstrs` + + Some doc about using generic-lens for surgeries + # 0.3.0.0 - Add generic implementations of `enumFrom`, `enumFromThen`, `enumFromTo`, diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,6 +4,35 @@ ## Generic deriving for standard classes +```haskell +{-# LANGUAGE DeriveGeneric #-} + +-- base +import Data.Semigroup (Semigroup(..)) +import GHC.Generics + +-- generic-data +import Generic.Data (gmappend, Generically(..)) +import Generic.Data.Orphans () + +data Foo a = Bar [a] [a] deriving Generic + +instance Semigroup (Foo a) where + (<>) = gmappend + +-- also with some additional extensions -- + +{-# LANGUAGE + DerivingStrategies, + DerivingVia #-} -- since GHC 8.6.1 + +data Foo a = Bar [a] [a] + deriving Generic + deriving Semigroup via (Generically (Foo a)) + +-- This example can be found in test/example.hs +``` + Supported classes that GHC currently can't derive: `Semigroup`, `Monoid`, `Applicative`, `Alternative`, `Eq1`, `Ord1`, `Show1`. @@ -15,13 +44,45 @@ (`Read` is currently not implemented.) -To derive type classes defined elsewhere, it might be worth taking a look at -[one-liner](https://hackage.haskell.org/package/one-liner). +To derive type classes outside of the standard library, it might be worth +taking a look at [one-liner](https://hackage.haskell.org/package/one-liner). ## Type metadata Extract type names, constructor names, number and arities of constructors, etc.. +## Type surgery + +generic-data offers simple operations on generic representations. + +More surgeries can be found in +[generic-data-surgery](https://hackage.haskell.org/package/generic-data-surgery). + +```haskell +{-# LANGUAGE DeriveGeneric #-} + +import GHC.Generic + +import Generic.Data (gshowsPrec) +import Generic.Data.Microsurgery (unrecordify) + +newtype T = T { unT :: Int } deriving Generic + +-- Naively deriving Show would result in this being shown: +-- +-- show (T 3) = "T {unT = 3}" +-- +-- But instead, with a simple surgery, unrecordify, we can forget T was +-- declared as a record: +-- +-- show (T 3) = "T 3" + +instance Show T where + showsPrec n = gshowsPrec n . unrecordify . toData + +-- This example can be found in test/microsurgery.hs +``` + --- ## Related links @@ -49,6 +110,16 @@ [first-class-families](https://hackage.haskell.org/package/first-class-families) (second one written by me) libraries for dependently-typed programming in Haskell. + +--- + +## Internal module policy + +Modules under `Generic.Data.Internal` are not subject to any versioning policy. +Breaking changes may apply to them at any time. + +If something in those modules seems useful, please report it or create a pull +request to export it from an external module. --- diff --git a/generic-data.cabal b/generic-data.cabal --- a/generic-data.cabal +++ b/generic-data.cabal @@ -1,5 +1,5 @@ name: generic-data -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Utilities for GHC.Generics description: This package provides common functions on generic types. See README. @@ -13,19 +13,21 @@ build-type: Simple extra-source-files: README.md, CHANGELOG.md cabal-version: >=1.10 -tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1 +tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1, GHC == 8.6.3 library hs-source-dirs: src exposed-modules: Generic.Data Generic.Data.Types + Generic.Data.Microsurgery Generic.Data.Internal.Compat Generic.Data.Internal.Data Generic.Data.Internal.Enum Generic.Data.Internal.Functions Generic.Data.Internal.Generically Generic.Data.Internal.Meta + Generic.Data.Internal.Microsurgery Generic.Data.Internal.Newtype Generic.Data.Internal.Prelude Generic.Data.Internal.Resolvers @@ -59,6 +61,41 @@ main-is: record.hs build-depends: generic-data, + base + ghc-options: -Wall + default-language: Haskell2010 + type: exitcode-stdio-1.0 + +test-suite example-test + hs-source-dirs: test + main-is: example.hs + build-depends: + generic-data, + base + ghc-options: -Wall + default-language: Haskell2010 + type: exitcode-stdio-1.0 + +test-suite microsurgery-test + hs-source-dirs: test + main-is: microsurgery.hs + build-depends: + tasty, + tasty-hunit, + generic-data, + base + ghc-options: -Wall + default-language: Haskell2010 + type: exitcode-stdio-1.0 + +test-suite lens-surgery-test + hs-source-dirs: test + main-is: lens-surgery.hs + build-depends: + tasty, + tasty-hunit, + generic-data, + generic-lens >= 1.1.0.0, base ghc-options: -Wall default-language: Haskell2010 diff --git a/src/Generic/Data/Internal/Enum.hs b/src/Generic/Data/Internal/Enum.hs --- a/src/Generic/Data/Internal/Enum.hs +++ b/src/Generic/Data/Internal/Enum.hs @@ -123,7 +123,7 @@ genumMin :: Int genumMin = 0 --- | > genumMin == gfromEnum gmaxBound +-- | > genumMax == gfromEnum gmaxBound genumMax :: forall opts a. (Generic a, GEnum opts (Rep a)) => Int genumMax = gCardinality @opts @(Rep a) - 1 @@ -199,36 +199,36 @@ -- Particularly 'Int' is an unfit field type, because the enumeration of the -- negative values starts before 0. -- --- * Since 'GEnum' represents the cardinality explicitly as an 'Int', there can --- only be up to 'maxBound' values. This restriction makes 'Word' an invalid field --- type. Notably it is insufficient for each individual field types to stay --- below this limit. Instead it applies to the generic type as a whole. --- --- The resulting 'GEnum' instance starts enumerating from @0@ up to --- @(cardinality - 1)@ and respects the generic 'Ord' instance. --- Implied by this the values from different constructors are enumerated --- sequentially. They are not interleaved. +-- * There can only be up to 'maxBound' values (because the implementation +-- represents the cardinality explicitly as an 'Int'). This restriction makes +-- 'Word' an invalid field type. Notably, it is insufficient for each +-- individual field types to stay below this limit. Instead it applies to the +-- generic type as a whole. -- --- To be very exact: The aforementioned generic 'Ord' instance can be determined --- by constraining the field types to 'Enum' instead of 'Ord'. Each field's --- order on its values is given by their enumeration. --- --- > data Example = C0 Bool Bool | C1 Bool --- > deriving (Eq, Ord, Show, Generic) --- > --- > gCardinality == 6 -- 2 * 2 + 2 --- > --- > enumeration = --- > [ C0 False False --- > , C0 False True --- > , C0 True False --- > , C0 True True --- > , C1 False --- > , C1 True --- > ] --- > --- > enumeration == map gtoFiniteEnum [0 .. 5] --- > [0 .. 5] == map gfromFiniteEnum enumeration +-- The resulting 'GEnum' instance starts enumerating from @0@ up to +-- @(cardinality - 1)@ and respects the generic 'Ord' instance (defined by +-- 'Generic.Data.gcompare'). The values from different constructors are enumerated +-- sequentially; they are not interleaved. +-- +-- @ +-- data Example = C0 Bool Bool | C1 Bool +-- deriving ('Eq', 'Ord', 'Show', 'Generic') +-- +-- cardinality = 6 -- 2 * 2 + 2 +-- -- Bool * Bool | Bool +-- +-- enumeration = +-- [ C0 False False +-- , C0 False True +-- , C0 True False +-- , C0 True True +-- , C1 False +-- , C1 True +-- ] +-- +-- enumeration == map 'gtoFiniteEnum' [0 .. 5] +-- [0 .. 5] == map 'gfromFiniteEnum' enumeration +-- @ data FiniteEnum instance GEnum opts f => GEnum opts (M1 i c f) where diff --git a/src/Generic/Data/Internal/Microsurgery.hs b/src/Generic/Data/Internal/Microsurgery.hs new file mode 100644 --- /dev/null +++ b/src/Generic/Data/Internal/Microsurgery.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE + AllowAmbiguousTypes, + DataKinds, + FlexibleContexts, + FlexibleInstances, + MultiParamTypeClasses, + PolyKinds, + ScopedTypeVariables, + TypeFamilies, + TypeOperators, + UndecidableInstances #-} + +-- | Surgeries that are just 'coerce'. + +module Generic.Data.Internal.Microsurgery where + +import Data.Coerce (Coercible, coerce) +import GHC.Generics +import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError) + +import Generic.Data.Types + +-- * Derecordify + +derecordify :: + Coercible (Derecordify f) f => + -- Coercible is not symmetric!?? + Data f p -> Data (Derecordify f) p +derecordify = coerce + +underecordify :: + Coercible f (Derecordify f) => + Data (Derecordify f) p -> Data f p +underecordify = coerce + +-- | Forget that a type was declared using record syntax. +-- +-- > data Foo = Bar { baz :: Zap } +-- > +-- > -- becomes -- +-- > +-- > data Foo = Bar Zap +-- +-- Concretely, set the last field of 'MetaCons' to 'False' and forget field +-- names. +type family Derecordify (f :: k -> *) :: k -> * +type instance Derecordify (M1 D m f) = M1 D m (Derecordify f) +type instance Derecordify (f :+: g) = Derecordify f :+: Derecordify g +type instance Derecordify (f :*: g) = Derecordify f :*: Derecordify g +type instance Derecordify (M1 C ('MetaCons nm fx _isRecord) f) = M1 C ('MetaCons nm fx 'False) (Derecordify f) +type instance Derecordify (M1 S ('MetaSel _nm su ss ds) f) = M1 S ('MetaSel 'Nothing su ss ds) f +type instance Derecordify V1 = V1 +type instance Derecordify U1 = U1 + +-- * Type aging ("denewtypify") + +typeage :: + Coercible (Typeage f) f => + Data f p -> Data (Typeage f) p +typeage = coerce + +untypeage :: + Coercible f (Typeage f) => + Data (Typeage f) p -> Data f p +untypeage = coerce + +-- | Forget that a type is a @newtype@. +-- +-- > newtype Foo = Bar Baz +-- > +-- > -- becomes -- +-- > +-- > data Foo = Bar Baz +type family Typeage (f :: k -> *) :: k -> * +type instance Typeage (M1 D ('MetaData nm md pk _nt) f) = M1 D ('MetaData nm md pk 'False) f + +-- * Renaming + +renameFields :: + forall rnm f p. + Coercible (RenameFields rnm f) f => + Data f p -> Data (RenameFields rnm f) p +renameFields = coerce + +unrenameFields :: + forall rnm f p. + Coercible (RenameFields rnm f) f => + Data f p -> Data (RenameFields rnm f) p +unrenameFields = coerce + +renameConstrs :: + forall rnm f p. + Coercible (RenameConstrs rnm f) f => + Data f p -> Data (RenameConstrs rnm f) p +renameConstrs = coerce + +unrenameConstrs :: + forall rnm f p. + Coercible (RenameConstrs rnm f) f => + Data f p -> Data (RenameConstrs rnm f) p +unrenameConstrs = coerce + +-- | Rename fields using the function @rnm@ given as a parameter. +-- +-- > data Foo = Bar { baz :: Zap } +-- > +-- > -- becomes, renaming "baz" to "bag" -- +-- > +-- > data Foo = Bar { bag :: Zap } +type family RenameFields (rnm :: *) (f :: k -> *) :: k -> * +type instance RenameFields rnm (M1 D m f) = M1 D m (RenameFields rnm f) +type instance RenameFields rnm (f :+: g) = RenameFields rnm f :+: RenameFields rnm g +type instance RenameFields rnm (f :*: g) = RenameFields rnm f :*: RenameFields rnm g +type instance RenameFields rnm (M1 C m f) = M1 C m (RenameFields rnm f) +type instance RenameFields rnm (M1 S ('MetaSel ('Just nm) su ss ds) f) = M1 S ('MetaSel ('Just (rnm @@ nm)) su ss ds) f + +-- | Rename constructors using the function @rnm@ given as a parameter. +-- +-- > data Foo = Bar { baz :: Zap } +-- > +-- > -- becomes, renaming "Bar" to "Car" -- +-- > +-- > data Foo = Car { baz :: Zap } +type family RenameConstrs (rnm :: *) (f :: k -> *) :: k -> * +type instance RenameConstrs rnm (M1 D m f) = M1 D m (RenameConstrs rnm f) +type instance RenameConstrs rnm (f :+: g) = RenameConstrs rnm f :+: RenameConstrs rnm g +type instance RenameConstrs rnm (f :*: g) = RenameConstrs rnm f :*: RenameConstrs rnm g +type instance RenameConstrs rnm (M1 C ('MetaCons nm fi ir) f) = M1 C ('MetaCons (rnm @@ nm) fi ir) f + +-- ** Defining symbol functions + +-- | @f \@\@ s@ is the application of a type-level function symbolized by @f@ +-- to a @s :: 'Symbol'@. +-- +-- A function @FooToBar@ can be defined as follows: +-- +-- @ +-- data FooToBar +-- type instance FooToBar '@@' \"foo\" = \"bar\" +-- @ +type family (f :: *) @@ (s :: Symbol) :: Symbol + +-- | Identity function @'Symbol' -> 'Symbol'@. +data SId +type instance SId @@ s = s + +-- | Empty function (compile-time error when applied). +data SError +type instance SError @@ s = TypeError ('Text "Invalid name: " ':<>: 'ShowType s) + +-- | Constant function. +data SConst (s :: Symbol) +type instance SConst z @@ _s = z + +-- | Define a function for a fixed set of strings, and fall back to @f@ for the others. +data SRename (xs :: [(Symbol, Symbol)]) (f :: *) +type instance SRename xs f @@ s = SRename' xs f s + +-- | Closed type family for 'SRename'. +type family SRename' (xs :: [(Symbol, Symbol)]) (f :: *) (s :: Symbol) where + SRename' '[] f s = f @@ s + SRename' ('( s, t) ': _xs) _f s = t + SRename' ('(_r, _t) ': xs) f s = SRename' xs f s + +-- * Other + +-- This can be used with generic-lens (see Generic.Data.Microsurgery) + +-- | Unify the "spines" of two generic representations (the "spine" is +-- everything except the field types). +class UnifyRep (f :: k -> *) (g :: k -> *) +instance (g' ~ M1 s c g, UnifyRep f g) => UnifyRep (M1 s c f) g' +instance (g' ~ (g1 :+: g2), UnifyRep f1 g1, UnifyRep f2 g2) + => UnifyRep (f1 :+: f2) g' +instance (g' ~ (g1 :*: g2), UnifyRep f1 g1, UnifyRep f2 g2) + => UnifyRep (f1 :*: f2) g' +instance (g' ~ K1 i b) => UnifyRep (K1 i a) g' +instance (g' ~ U1) => UnifyRep U1 g' +instance (g' ~ V1) => UnifyRep V1 g' + +-- | +-- +-- > onData :: _ => (a -> b) -> (a -> b) -- possible specialization +-- +-- Can be used with @generic-lens@ for type-changing field updates with @field_@ +-- (and possibly other generic optics). +-- +-- A specialization of the identity function to be used to fix types +-- of functions using 'Data' as input or output, unifying the "spines" of input +-- and output generic representations (the "spine" is everything except field +-- types, which may thus change). +onData + :: (UnifyRep (Rep a) (Rep b), UnifyRep (Rep a) (Rep b)) + => p a b -> p a b +onData = id diff --git a/src/Generic/Data/Microsurgery.hs b/src/Generic/Data/Microsurgery.hs new file mode 100644 --- /dev/null +++ b/src/Generic/Data/Microsurgery.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +-- | Simple operations on generic representations, that only change the +-- type-level metadata used by certain generic functions. +-- +-- More complex ones can be found in +-- +-- and, surprisingly, in +-- (read more about this just below). + +module Generic.Data.Microsurgery + ( -- * Surgeries with generic-lens + + -- $lens-surgery + + -- * Synthetic types + + Data + , toData + , fromData + , onData + + -- * Microsurgeries + -- + -- | Each microsurgery consists of a type family @F@ to modify metadata in + -- GHC Generic representations, and two mappings (that are just + -- 'Data.Coerce.coerce'): + -- + -- @ + -- f :: 'Data' ('GHC.Generics.Rep' a) p -> 'Data' (F ('GHC.Generics.Rep' a)) p + -- unf :: 'Data' (F ('GHC.Generics.Rep' a)) p -> 'Data' ('GHC.Generics.Rep' a) p + -- @ + -- + -- Use @f@ with 'toData' for generic functions that consume generic values, + -- and @unf@ with 'fromData' for generic functions that produce generic + -- values. Abstract example: + -- + -- @ + -- genericSerialize . f . 'toData' + -- 'fromData' . unf . genericDeserialize + -- @ + + -- ** Derecordify + + , Derecordify + , derecordify + , underecordify + + -- ** Type aging ("denewtypify") + + , Typeage + , typeage + , untypeage + + -- ** Renaming of fields and constructors + -- | These surgeries require @DataKinds@ and @TypeApplications@. + -- + -- ==== Examples + -- + -- @ + -- {-# LANGUAGE + -- DataKinds, + -- TypeApplications #-} + -- + -- -- Rename all fields to \"foo\" + -- 'renameFields' \@('SConst' \"foo\") + -- + -- -- Rename constructor \"Bar\" to \"Baz\", and leave all others the same + -- 'renameConstrs' \@('SRename' '[ '(\"Bar\", \"Baz\") ] 'SId') + -- @ + + , RenameFields + , renameFields + , unrenameFields + + , RenameConstrs + , renameConstrs + , unrenameConstrs + + -- *** Renaming functions + + , type (@@) + , SId + , SError + , SConst + , SRename + + ) where + +import Generic.Data.Internal.Data +import Generic.Data.Internal.Microsurgery + +-- $lens-surgery +-- One common and simple situation is to modify the type of some fields, +-- for example wrapping them in a newtype. +-- +-- We can leverage the @generic-lens@ library, with the two functions below. +-- +-- @ +-- -- Lens to a field named @fd@ in a Generic record. +-- field_ :: HasField_ fd s t a b => Lens s t a b -- from generic-lens +-- +-- -- Update a value through a lens (ASetter is a specialization of Lens). +-- over :: ASetter s t a b -> (a -> b) -> s -> t -- from lens or microlens +-- @ +-- +-- For example, here is a record type: +-- +-- @ +-- data R = R { myField :: Int } deriving 'GHC.Generics.Generic' +-- @ +-- +-- The function @over (field_ \@\"myField\") 'Generic.Data.Opaque'@ +-- applies the newtype constructor 'Generic.Data.Opaque' to the field +-- @\"myField\"@, but this actually doesn't typecheck as-is. With a bit of help +-- from this module, we can wrap that function as follows: +-- +-- @ +-- 'onData' (over (field_ \@\"myField\") 'Generic.Data.Opaque') . 'toData' +-- :: R -> 'Data' _ _ -- type arguments hidden +-- @ +-- +-- The result has a type @'Data' _ _@, that from the point of view of "GHC.Generics" +-- looks just like @R@ but with the field @\"myField\"@ wrapped in +-- 'Generic.Data.Opaque', as if we had defined: +-- +-- @ +-- data R = R { myField :: 'Generic.Data.Opaque' Int } deriving 'GHC.Generics.Generic' +-- @ +-- +-- ==== Example usage +-- +-- We derive an instance of 'Show' that hides the @\"myField\"@ field, +-- whatever its type. +-- +-- @ +-- instance 'Show' R where +-- 'showsPrec' n = 'Generic.Data.gshowsPrec' n +-- . 'onData' (over (field_ \@\"myField\") 'Generic.Data.Opaque') +-- . 'toData' +-- +-- 'show' (R 3) = \"R {myField = _}\" +-- @ diff --git a/test/example.hs b/test/example.hs new file mode 100644 --- /dev/null +++ b/test/example.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE + CPP, + DeriveGeneric #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE + DerivingStrategies, + DerivingVia #-} +#endif + +import Data.Semigroup (Semigroup(..)) +import GHC.Generics +import Generic.Data (gmappend, Generically(..)) +import Generic.Data.Orphans () + +data Foo a = Bar [a] [a] deriving Generic + +instance Semigroup (Foo a) where + (<>) = gmappend + +#if __GLASGOW_HASKELL__ >= 806 +data Foo2 a = Bar2 [a] [a] + deriving Generic + deriving Semigroup via (Generically (Foo2 a)) +#endif + +main :: IO () +main = pure () diff --git a/test/lens-surgery.hs b/test/lens-surgery.hs new file mode 100644 --- /dev/null +++ b/test/lens-surgery.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE + DataKinds, + DeriveGeneric, + TypeApplications, + TypeOperators #-} + +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +import Data.Coerce (coerce) +import Data.Functor.Identity (Identity(..)) +import GHC.Generics (Generic) +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Generics.Product (field_) + +import Generic.Data (gshowsPrec, Opaque(Opaque)) +import Generic.Data.Microsurgery (onData, toData) + +data T = R { f :: Int -> Int } deriving Generic + +instance Show T where + showsPrec n = gshowsPrec n + . onData (field_ @"f" %~ Opaque) + . toData + +(%~) :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t +(%~) = coerce + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "lens-surgery" + [ testCase "update" $ + "R {f = _}" @?= show (R id) + ] diff --git a/test/microsurgery.hs b/test/microsurgery.hs new file mode 100644 --- /dev/null +++ b/test/microsurgery.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE + DeriveGeneric, + DataKinds, + TypeApplications #-} + +-- @DataKinds@ and @TypeApplications@ for @renameFields@ and @renameConstrs@ + +import GHC.Generics -- We need to import the constructors for Coercible to resolve +import Test.Tasty +import Test.Tasty.HUnit + +import Generic.Data +import Generic.Data.Microsurgery + +-- From https://stackoverflow.com/questions/53864911/derive-positional-show + +newtype T = T { _unT :: Int } deriving Generic + +instance Show T where + showsPrec n = gshowsPrec n . derecordify . toData + +newtype U = U { _unU :: Int } deriving Generic + +instance Show U where + showsPrec n = + gshowsPrec n + . renameFields @(SRename '[ '("_unU", "unV")] SError) + . renameConstrs @(SConst "V") + . typeage -- doesn't change anything, just a sanity check. + . toData + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "microsurgery" + [ testCase "Show T" $ "T 3" @?= show (T 3) + , testCase "Show U" $ "V {unV = 3}" @?= show (U 3) + ]