diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,14 @@ +# 0.8.2.0 + +- Add microsurgery `CopyRep`. +- Improve documentation of `Microsurgery` module. +- Fix a bug where `gshowsPrec` would incorrectly display prefix uses of + symbol data constructors or record selectors (e.g., `data R = (:!:) Int Int` + or `data S = MkS { (##) :: Int -> Int }`). Thanks to RyanGlScott. +- Fix a bug where `gshowsPrec` would incorrectly display infix uses of + alphanumeric data constructors (e.g., ```data T = Int `MkT` Int```). + Thanks to RyanGlScott. + # 0.8.1.0 - Add `Old` type family mapping newtypes to their underlying type. 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.8.1.0 +version: 0.8.2.0 synopsis: Deriving instances with GHC.Generics and related utilities description: Generic implementations of standard type classes. @@ -40,6 +40,7 @@ build-depends: base-orphans >= 0.8, contravariant, + ghc-boot-th, show-combinators, base >= 4.9 && < 5 hs-source-dirs: orphans @@ -55,6 +56,7 @@ tasty, tasty-hunit, generic-data, + show-combinators >= 0.2, base ghc-options: -Wall default-language: Haskell2010 diff --git a/src/Generic/Data/Internal/Microsurgery.hs b/src/Generic/Data/Internal/Microsurgery.hs --- a/src/Generic/Data/Internal/Microsurgery.hs +++ b/src/Generic/Data/Internal/Microsurgery.hs @@ -27,14 +27,16 @@ import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError) import Generic.Data.Types (Data) -import Generic.Data.Internal.Generically (Generically(..)) +import Generic.Data.Internal.Generically (Generically(..), GenericProduct(..)) -- * Surgery -- | Apply a microsurgery @s@ to a type @a@ for @DerivingVia@. -- --- === __Example__ +-- For the 'Data.Monoid.Monoid' class, see 'ProductSurgery'. -- +-- === Example +-- -- @ -- {-\# LANGUAGE DerivingVia \#-} -- @@ -50,6 +52,10 @@ -- @ type Surgery (s :: *) (a :: *) = Generically (Surgery' s a) +-- | Apply a microsurgery @s@ to a type @a@ for @DerivingVia@ for the +-- 'Data.Monoid.Monoid' class. +type ProductSurgery (s :: *) (a :: *) = GenericProduct (Surgery' s a) + -- | See 'Surgery'. newtype Surgery' (s :: *) (a :: *) = Surgery' { unSurgery' :: a } @@ -260,6 +266,18 @@ -- | Apply a type constructor @f@ to every field type of a generic -- representation @r@. -- +-- > data Color = RGB +-- > { r :: Int +-- > , g :: Int +-- > , b :: Int } +-- > +-- > -- becomes -- +-- > +-- > data Color f = RGB +-- > { r :: f Int +-- > , g :: f Int +-- > , b :: f Int } +-- -- This is a defunctionalized symbol, applied using 'GSurgery' or 'Surgery'. data OnFields (f :: * -> *) :: * type instance GSurgery (OnFields f) g = GOnFields f g @@ -275,3 +293,17 @@ -- | Apply a type constructor to every field type of a type @a@ to make a -- synthetic type. type DOnFields (f :: * -> *) (a :: *) = Data (GSurgery (OnFields f) (Rep a)) () + +-- | Change the generic representation to that of another type @a@. +data CopyRep (a :: *) :: * +type instance GSurgery (CopyRep a) _ = Rep a + +copyRep :: forall a f p. + Coercible (GSurgery (CopyRep a) f) f => + Data f p -> Data (GSurgery (CopyRep a) f) p +copyRep = coerce + +uncopyRep :: forall a f p. + Coercible f (GSurgery (CopyRep a) f) => + Data (GSurgery (CopyRep a) f) p -> Data f p +uncopyRep = coerce diff --git a/src/Generic/Data/Internal/Show.hs b/src/Generic/Data/Internal/Show.hs --- a/src/Generic/Data/Internal/Show.hs +++ b/src/Generic/Data/Internal/Show.hs @@ -23,6 +23,7 @@ import Data.Functor.Classes (Show1(..)) import Data.Functor.Identity import Data.Proxy +import GHC.Lexeme (startsConSym, startsVarSym) import GHC.Generics import Text.Show.Combinators @@ -82,20 +83,16 @@ instance GShowFields p f => GShowC p ('MetaCons s y 'False) f where gPrecShowsC p name fixity (M1 x) | Infix _ fy <- fixity, k1 : k2 : ks <- fields = - foldl' showApp (showInfix name fy k1 k2) ks + foldl' showApp (showInfix cname fy k1 k2) ks | otherwise = foldl' showApp (showCon cname) fields where - cname = case fixity of - Prefix -> name - Infix _ _ -> "(" ++ name ++ ")" + cname = surroundConName fixity name fields = gPrecShowsFields p x instance GShowNamed p f => GShowC p ('MetaCons s y 'True) f where gPrecShowsC p name fixity (M1 x) = showRecord cname fields where - cname = case fixity of - Prefix -> name - Infix _ _ -> "(" ++ name ++ ")" + cname = surroundConName fixity name fields = gPrecShowsNamed p x class GShowFields p f where @@ -117,7 +114,11 @@ gPrecShowsNamed p (x :*: y) = gPrecShowsNamed p x &| gPrecShowsNamed p y instance (Selector c, GShowSingle p f) => GShowNamed p (M1 S c f) where - gPrecShowsNamed p x'@(M1 x) = selName x' `showField` gPrecShowsSingle p x + gPrecShowsNamed p x'@(M1 x) = snameParen `showField` gPrecShowsSingle p x + where + sname = selName x' + snameParen | isSymVar sname = "(" ++ sname ++ ")" + | otherwise = sname instance GShowNamed p U1 where gPrecShowsNamed _ U1 = noFields @@ -142,3 +143,25 @@ where showsPrec_ = flip (gPrecShowsSingle p) showList_ = showListWith (showsPrec_ 0) + +-- Helpers + +surroundConName :: Fixity -> String -> String +surroundConName fixity name = + case fixity of + Prefix + | isSymName -> "(" ++ name ++ ")" + | otherwise -> name + Infix _ _ + | isSymName -> name + | otherwise -> "`" ++ name ++ "`" + where + isSymName = isSymDataCon name + +isSymDataCon :: String -> Bool +isSymDataCon "" = False +isSymDataCon (c:_) = startsConSym c + +isSymVar :: String -> Bool +isSymVar "" = False +isSymVar (c:_) = startsVarSym c diff --git a/src/Generic/Data/Internal/Utils.hs b/src/Generic/Data/Internal/Utils.hs --- a/src/Generic/Data/Internal/Utils.hs +++ b/src/Generic/Data/Internal/Utils.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns, + EmptyCase, FlexibleContexts, PolyKinds #-} @@ -40,7 +41,7 @@ -- | Elimination of @V1@. absurd1 :: V1 x -> a -absurd1 !_ = error "impossible" +absurd1 x = case x of {} -- | A helper for better type inference. from' :: Generic a => a -> Rep a () diff --git a/src/Generic/Data/Microsurgery.hs b/src/Generic/Data/Microsurgery.hs --- a/src/Generic/Data/Microsurgery.hs +++ b/src/Generic/Data/Microsurgery.hs @@ -1,14 +1,32 @@ {-# LANGUAGE ExplicitNamespaces #-} --- | Simple operations on generic representations, that only change the --- type-level metadata used by certain generic functions. +-- | Simple operations on generic representations: +-- modify 'GHC.Generics.Generic' instances to tweak the behavior of generic +-- implementations as if you had declared a slightly different type. -- --- More complex ones can be found in +-- This module provides the following microsurgeries: +-- +-- - 'RenameFields': rename the fields of a record type. +-- - 'RenameConstrs': rename the constructors. +-- - 'OnFields': apply a type constructor @f :: Type -> Type@ to every field. +-- - 'CopyRep': use the generic representation of another type of the same shape. +-- - 'Typeage': treat a @newtype@ as a @data@ type. +-- - 'Derecordify': treat a type as if it weren't a record. +-- +-- More complex surgeries can be found in -- -- but also, perhaps surprisingly, -- in -- (read more about this just below) and -- . +-- +-- Surgeries can be used: +-- +-- - to derive type class instances with the @DerivingVia@ extension, +-- using the 'Surgery' or 'ProductSurgery' type synonyms +-- (for classes with instances for 'Generically' or 'GenericProduct'); +-- - with the 'Data' \"synthetic type\" for more involved transformations, +-- for example using lenses in the next section. module Generic.Data.Microsurgery ( -- * Surgeries with generic-lens @@ -18,9 +36,11 @@ -- * Deriving via Surgery + , ProductSurgery , Surgery'(..) , GSurgery , Generically(..) + , GenericProduct(..) -- * Synthetic types @@ -49,18 +69,6 @@ -- 'fromData' . unf . genericDeserialize -- @ - -- ** Derecordify - - , Derecordify() - , derecordify - , underecordify - - -- ** Type aging ("denewtypify") - - , Typeage() - , typeage - , untypeage - -- ** Renaming of fields and constructors -- | These surgeries require @DataKinds@ and @TypeApplications@. -- @@ -107,9 +115,91 @@ -- See also the file @test/one-liner-surgery.hs@ in this package for an -- example of using one-liner and generic-lens with a synthetic type -- constructed with 'DOnFields'. + -- + -- === Example + -- + -- Derive 'Data.Semigroup.Semigroup' and 'Data.Monoid.Monoid' for + -- a product of 'Prelude.Num' types: + -- + -- @ + -- {-\# LANGUAGE DeriveGeneric, DerivingVia \#-} + -- import "Data.Monoid" ('Data.Monoid.Sum'(..)) -- Constructors must be in scope + -- import "GHC.Generics" ('GHC.Generics.Generic') + -- import "Generic.Data.Microsurgery" + -- ( 'ProductSurgery' + -- , 'OnFields' + -- , 'GenericProduct'(..) -- Constructors must be in scope + -- , 'Surgery''(..) -- + -- ) + -- + -- data TwoCounters = MkTwoCounters { c1 :: Int, c2 :: Int } + -- deriving 'GHC.Generics.Generic' + -- deriving ('Data.Semigroup.Semigroup', 'Data.Monoid.Monoid') + -- via ('ProductSurgery' ('OnFields' 'Data.Monoid.Sum') TwoCounters) -- Surgery here + -- @ , OnFields() , DOnFields + + -- ** Substitute a generic representation from another type + + -- | + -- === Example + -- + -- Derive 'Data.Semigroup.Semigroup' and 'Data.Monoid.Monoid' for + -- a product of 'Prelude.Num' types, but using 'Data.Monoid.Sum' for one + -- field and 'Data.Monoid.Product' for the other. + -- In other words, we use the fact that @Polar a@ below is isomorphic to + -- the monoid @('Data.Monoid.Product' a, 'Data.Monoid.Sum' a)@. + -- + -- @ + -- {-\# LANGUAGE DeriveGeneric, DerivingVia \#-} + -- import "Data.Monoid" ('Data.Monoid.Sum'(..), 'Data.Monoid.Product'(..)) -- Constructors must be in scope + -- import "GHC.Generics" ('GHC.Generics.Generic') + -- import "Generic.Data.Microsurgery" + -- ( 'ProductSurgery' + -- , 'CopyRep' + -- , 'GenericProduct'(..) -- Constructors must be in scope + -- , 'Surgery''(..) -- + -- ) + -- + -- data Polar a = Exp { modulus :: a, argument :: a } + -- deriving 'GHC.Generics.Generic' + -- deriving ('Data.Semigroup.Semigroup', 'Data.Monoid.Monoid') + -- via ('ProductSurgery' ('CopyRep' ('Data.Monoid.Product' a, 'Data.Monoid.Sum' a)) (Polar a)) -- Surgery here + -- @ + -- + -- That is the polar representation of a complex number: + -- + -- > z = modulus * exp(i * argument) + -- + -- The product of complex numbers defines a monoid isomorphic to + -- the monoid product @(Product Double, Sum Double)@ + -- (multiply the moduli, add the arguments). + -- + -- @ + -- z1 'Data.Semigroup.<>' z2 + -- = z1 'Prelude.*' z2 + -- = Exp (modulus z1 'Prelude.*' modulus z2) (argument z1 'Prelude.+' argument z2) + -- + -- 'Data.Monoid.mempty' = 1 = Exp 1 0 + -- @ + + , CopyRep + , copyRep + , uncopyRep + + -- ** Type aging ("denewtypify") + + , Typeage() + , typeage + , untypeage + + -- ** Derecordify + + , Derecordify() + , derecordify + , underecordify ) where diff --git a/test/microsurgery.hs b/test/microsurgery.hs --- a/test/microsurgery.hs +++ b/test/microsurgery.hs @@ -22,10 +22,13 @@ ) #if __GLASGOW_HASKELL__ >= 806 +import Data.Monoid (Sum(..), Product(..)) + -- DerivingVia test -- Constructors must be visible for Coercible import Generic.Data.Microsurgery - ( Surgery, Surgery'(..), Generically(..), Derecordify + ( Surgery, ProductSurgery, Surgery'(..), Generically(..), GenericProduct(..) + , Derecordify, OnFields, CopyRep ) #endif @@ -50,6 +53,12 @@ data V = V { v1 :: Int, v2 :: Int } deriving Generic deriving Show via (Surgery Derecordify V) + deriving (Semigroup, Monoid) via (ProductSurgery (OnFields Sum) V) + +data Polar a = Exp { modulus :: a, argument :: a } + deriving Generic + deriving Show via (Surgery Derecordify (Polar a)) + deriving (Semigroup, Monoid) via (ProductSurgery (CopyRep (Product a, Sum a)) (Polar a)) #endif main :: IO () @@ -61,5 +70,8 @@ , testCase "Show U" $ "V {unV = 3}" @?= show (U 3) #if __GLASGOW_HASKELL__ >= 806 , testCase "Show V" $ "V 3 4" @?= show (V 3 4) + , testCase "Semigroup V" $ "V 5 6" @?= show (V 2 3 <> V 3 3) + , testCase "Monoid Polar" $ "Exp 1 0" @?= show (mempty :: Polar Int) + , testCase "Semigroup Polar" $ "Exp 9 6" @?= show (Exp 3 4 <> Exp 3 2 :: Polar Int) #endif ] diff --git a/test/unit.hs b/test/unit.hs --- a/test/unit.hs +++ b/test/unit.hs @@ -65,7 +65,7 @@ eLast = last allEs allEs :: [FiniteE] -allEs = +allEs = [ SE0 False False , SE0 False True , SE0 True False @@ -84,6 +84,20 @@ instance (Functor f, Show1 f, Show1 g, Show a) => Show (MyCompose f g a) where showsPrec = showsPrec1 +-- Regression tests for T30 +data T30a = MkT30a { (##) :: () } + deriving Generic + +data T30b = (:!:) () () + | () `MkT30b` () + deriving Generic + +instance Show T30a where + showsPrec = gshowsPrec + +instance Show T30b where + showsPrec = gshowsPrec + maybeModuleName :: String #if MIN_VERSION_base(4,12,0) maybeModuleName = "GHC.Maybe" @@ -157,7 +171,7 @@ ] ] , testGroup "Ix" - [ testGroup "only nullary constructors" + [ testGroup "only nullary constructors" [ testCase "range" $ [E0, E1, E2] @=? grange (E0, E2) , testCase "index" $ 1 @=? gindex (E1, E3) E2 , testCase "inRange (within)" $ True @=? ginRange (E1, E3) E2 @@ -175,6 +189,11 @@ , testGroup "Show" [ testCase "show" $ "P 1 2" @=? show (p' 1 2) , testCase "showsPrec" $ "(P 1 2)" @=? showsPrec 11 (p' 1 2) "" + , testGroup "T30" + [ testCase "MkT30a" $ "(MkT30a {(##) = ()})" @=? showsPrec 11 (MkT30a {(##) = ()}) "" + , testCase "(:!:)" $ "(:!:) () ()" @=? show ((:!:) () ()) + , testCase "MkT30b" $ "() `MkT30b` ()" @=? show (() `MkT30b` ()) + ] ] , testGroup "Show1"