mirror of
https://github.com/i-am-tom/higgledy.git
synced 2024-09-11 16:16:43 +03:00
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:
parent
4aaa49e406
commit
90d7fde513
23
README.md
23
README.md
@ -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}
|
||||||
-- }
|
-- }
|
||||||
```
|
```
|
||||||
|
@ -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
|
||||||
|
@ -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:
|
||||||
--
|
--
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user