Use generic-deriving for Show instance

It's quite possible that more of the classes can be removed in favour of
generic-deriving, but this fixes #12 regardless.
This commit is contained in:
Tom Harding 2019-08-05 09:55:20 +01:00
parent 4aaa49e406
commit 90d7fde513
5 changed files with 14 additions and 53 deletions

View File

@ -120,10 +120,7 @@ Other 'Alternative'-style functors lead to very different results:
```haskell ```haskell
eg1 :: Labels Triple eg1 :: Labels Triple
eg1 = mempty eg1 = mempty
-- Triple -- Triple (Const {getConst = ""}) (Const {getConst = ""}) (Const { getConst = ""})
-- Const ""
-- Const ""
-- Const ""
``` ```
Of course, this method requires every field to be monoidal. If we try with Of course, this method requires every field to be monoidal. If we try with
@ -156,10 +153,7 @@ behaviours:
```haskell ```haskell
eg4 :: Partial Triple eg4 :: Partial Triple
eg4 = deconstruct @Last triple eg4 = deconstruct @Last triple
-- Triple -- Triple (Last {getLast = Just 123}) (Last {getLast = Just ()}) (Last {getLast = Just "ABC"})
-- Last {getLast = Just 123}
-- Last {getLast = Just ()}
-- Last {getLast = Just "ABC"}
``` ```
There's also `construct` for when we want to escape our `HKD` wrapper, and There's also `construct` for when we want to escape our `HKD` wrapper, and
@ -214,8 +208,8 @@ eg10 :: Partial User
eg10 = eg0 & field @"name" .~ pure "Evil Tom" eg10 = eg0 & field @"name" .~ pure "Evil Tom"
& field @"likesDogs" .~ pure False & field @"likesDogs" .~ pure False
-- User -- User
-- { name = Last {getLast = Just "Evil Tom"} -- { name = Last {getLast = Just "Evil Tom"}
-- , age = Last {getLast = Nothing} -- , age = Last {getLast = Nothing}
-- , likesDogs = Last {getLast = Just False} -- , likesDogs = Last {getLast = Just False}
-- } -- }
``` ```
@ -249,10 +243,7 @@ product types:
eg13 :: Labels Triple eg13 :: Labels Triple
eg13 = mempty & position @1 .~ Const "hello" eg13 = mempty & position @1 .~ Const "hello"
& position @2 .~ Const "world" & position @2 .~ Const "world"
-- Triple -- Triple (Const {getConst = "hello"}) (Const {getConst = "world"}) (Const {getConst = ""})
-- Const "hello"
-- Const "world"
-- Const ""
``` ```
Again, this is a `Lens`, so we can just as easily _set_ values: Again, this is a `Lens`, so we can just as easily _set_ values:
@ -261,8 +252,8 @@ Again, this is a `Lens`, so we can just as easily _set_ values:
eg14 :: Partial User eg14 :: Partial User
eg14 = eg10 & position @2 .~ pure 25 eg14 = eg10 & position @2 .~ pure 25
-- User -- User
-- { name = Last {getLast = Just "Evil Tom"} -- { name = Last {getLast = Just "Evil Tom"}
-- , age = Last {getLast = Just 25} -- , age = Last {getLast = Just 25}
-- , likesDogs = Last {getLast = Just False} -- , likesDogs = Last {getLast = Just False}
-- } -- }
``` ```

View File

@ -25,6 +25,7 @@ library
-- other-extensions: -- other-extensions:
build-depends: base ^>= 4.12 build-depends: base ^>= 4.12
, barbies ^>= 1.1.0 , barbies ^>= 1.1.0
, generic-deriving ^>= 1.12
, generic-lens ^>= 1.1.0 , generic-lens ^>= 1.1.0
, QuickCheck >= 2.12.6 && < 2.14 , QuickCheck >= 2.12.6 && < 2.14
hs-source-dirs: src hs-source-dirs: src

View File

@ -47,7 +47,7 @@ import GHC.Generics
-- We can also /deconstruct/ a tuple into a partial structure: -- We can also /deconstruct/ a tuple into a partial structure:
-- --
-- >>> deconstruct @[] ("Hello", True) -- >>> deconstruct @[] ("Hello", True)
-- (,) ["Hello"] [True] -- (,) (["Hello"],[True])
-- --
-- These two methods also satisfy the round-tripping property: -- These two methods also satisfy the round-tripping property:
-- --

View File

@ -32,7 +32,7 @@ import GHC.TypeLits (ErrorMessage (..), KnownSymbol, TypeError, symbolVal)
-- --
-- >>> data User = User { name :: String, age :: Int } deriving Generic -- >>> data User = User { name :: String, age :: Int } deriving Generic
-- >>> label @User -- >>> label @User
-- User {name = Const "name", age = Const "age"} -- User {name = Const {getConst = "name"}, age = Const {getConst = "age"}}
class Label (structure :: Type) where class Label (structure :: Type) where
label :: HKD structure (Const String) label :: HKD structure (Const String)

View File

@ -41,6 +41,7 @@ import Data.Proxy (Proxy (..))
import Data.Void (Void) import Data.Void (Void)
import GHC.Generics import GHC.Generics
import GHC.TypeLits (KnownSymbol, symbolVal) import GHC.TypeLits (KnownSymbol, symbolVal)
import Generics.Deriving.Show (GShow' (..), gshowsPrecdefault)
import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..)) import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..))
import Test.QuickCheck.Function (Function (..), functionMap) import Test.QuickCheck.Function (Function (..), functionMap)
@ -79,7 +80,7 @@ import Test.QuickCheck.Function (Function (..), functionMap)
-- User {name = Last {getLast = Nothing}, age = Last {getLast = Nothing}} -- User {name = Last {getLast = Nothing}, age = Last {getLast = Nothing}}
-- --
-- >>> mempty @(HKD (Int, Bool) []) -- >>> mempty @(HKD (Int, Bool) [])
-- (,) [] [] -- (,) ([],[])
newtype HKD (structure :: Type) (f :: Type -> Type) newtype HKD (structure :: Type) (f :: Type -> Type)
= HKD { runHKD :: HKD_ f structure Void } = HKD { runHKD :: HKD_ f structure Void }
@ -138,41 +139,9 @@ instance (Generic structure, Function tuple, Tuple f structure tuple)
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
class GShow (named :: Bool) (rep :: Type -> Type) where instance (Generic (HKD structure f), GShow' (GHKD_ f (Rep structure)))
gshow :: rep p -> String
instance GShow named inner => GShow named (D1 meta inner) where
gshow = gshow @named . unM1
instance (GShow 'True inner, KnownSymbol name)
=> GShow any (C1 ('MetaCons name fixity 'True) inner) where
gshow (M1 x) = symbolVal (Proxy @name) <> " {" <> gshow @'True x <> "}"
instance (GShow 'False inner, KnownSymbol name)
=> GShow any (C1 ('MetaCons name fixity 'False) inner) where
gshow (M1 x) = symbolVal (Proxy @name) <> " " <> gshow @'False x
instance (GShow 'True left, GShow 'True right)
=> GShow 'True (left :*: right) where
gshow (left :*: right) = gshow @'True left <> ", " <> gshow @'True right
instance (GShow 'False left, GShow 'False right)
=> GShow 'False (left :*: right) where
gshow (left :*: right) = gshow @'False left <> " " <> gshow @'False right
instance (GShow 'True inner, KnownSymbol field)
=> GShow 'True (S1 ('MetaSel ('Just field) i d c) inner) where
gshow (M1 inner) = symbolVal (Proxy @field) <> " = " <> gshow @'True inner
instance GShow 'False inner => GShow 'False (S1 meta inner) where
gshow (M1 inner) = gshow @'False inner
instance (Show (f inner)) => GShow named (K1 R (f inner)) where
gshow (K1 x) = show x
instance (Generic structure, GShow 'True (HKD_ f structure))
=> Show (HKD structure f) where => Show (HKD structure f) where
show (HKD x) = gshow @'True x showsPrec = gshowsPrecdefault
------------------------------------------------------------------------------- -------------------------------------------------------------------------------