generic-data 0.8.1.0 → 0.8.2.0

raw patch · 8 files changed

+220/−30 lines, 8 filesdep +ghc-boot-thdep ~show-combinatorsPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-boot-th

Dependency ranges changed: show-combinators

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• generic-data.cabal +3/−1
• src/Generic/Data/Internal/Microsurgery.hs +34/−2
• src/Generic/Data/Internal/Show.hs +31/−8
• src/Generic/Data/Internal/Utils.hs +2/−1
• src/Generic/Data/Microsurgery.hs +105/−15
• test/microsurgery.hs +13/−1
• test/unit.hs +21/−2

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

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

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

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

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

@@ -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 -- <https://hackage.haskell.org/package/generic-data-surgery generic-data-surgery> -- but also, perhaps surprisingly, -- in <https://hackage.haskell.org/package/generic-lens generic-lens> -- (read more about this just below) and -- <https://hackage.haskell.org/package/one-liner one-liner>.+--+-- 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 

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

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