diff --git a/README.md b/README.md index 6048011..ca58d15 100644 --- a/README.md +++ b/README.md @@ -120,10 +120,7 @@ Other 'Alternative'-style functors lead to very different results: ```haskell eg1 :: Labels Triple eg1 = mempty --- Triple --- Const "" --- Const "" --- Const "" +-- Triple (Const {getConst = ""}) (Const {getConst = ""}) (Const { getConst = ""}) ``` Of course, this method requires every field to be monoidal. If we try with @@ -156,10 +153,7 @@ behaviours: ```haskell eg4 :: Partial Triple eg4 = deconstruct @Last triple --- Triple --- Last {getLast = Just 123} --- Last {getLast = Just ()} --- Last {getLast = Just "ABC"} +-- Triple (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 @@ -214,8 +208,8 @@ eg10 :: Partial User eg10 = eg0 & field @"name" .~ pure "Evil Tom" & field @"likesDogs" .~ pure False -- User --- { name = Last {getLast = Just "Evil Tom"} --- , age = Last {getLast = Nothing} +-- { name = Last {getLast = Just "Evil Tom"} +-- , age = Last {getLast = Nothing} -- , likesDogs = Last {getLast = Just False} -- } ``` @@ -249,10 +243,7 @@ product types: eg13 :: Labels Triple eg13 = mempty & position @1 .~ Const "hello" & position @2 .~ Const "world" --- Triple --- Const "hello" --- Const "world" --- Const "" +-- Triple (Const {getConst = "hello"}) (Const {getConst = "world"}) (Const {getConst = ""}) ``` 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 = eg10 & position @2 .~ pure 25 -- User --- { name = Last {getLast = Just "Evil Tom"} --- , age = Last {getLast = Just 25} +-- { name = Last {getLast = Just "Evil Tom"} +-- , age = Last {getLast = Just 25} -- , likesDogs = Last {getLast = Just False} -- } ``` diff --git a/higgledy.cabal b/higgledy.cabal index 42aad36..4418365 100644 --- a/higgledy.cabal +++ b/higgledy.cabal @@ -25,6 +25,7 @@ library -- other-extensions: build-depends: base ^>= 4.12 , barbies ^>= 1.1.0 + , generic-deriving ^>= 1.12 , generic-lens ^>= 1.1.0 , QuickCheck >= 2.12.6 && < 2.14 hs-source-dirs: src diff --git a/src/Data/Generic/HKD/Construction.hs b/src/Data/Generic/HKD/Construction.hs index 425ee33..45476eb 100644 --- a/src/Data/Generic/HKD/Construction.hs +++ b/src/Data/Generic/HKD/Construction.hs @@ -47,7 +47,7 @@ import GHC.Generics -- We can also /deconstruct/ a tuple into a partial structure: -- -- >>> deconstruct @[] ("Hello", True) --- (,) ["Hello"] [True] +-- (,) (["Hello"],[True]) -- -- These two methods also satisfy the round-tripping property: -- diff --git a/src/Data/Generic/HKD/Labels.hs b/src/Data/Generic/HKD/Labels.hs index 91996df..5ea6122 100644 --- a/src/Data/Generic/HKD/Labels.hs +++ b/src/Data/Generic/HKD/Labels.hs @@ -32,7 +32,7 @@ import GHC.TypeLits (ErrorMessage (..), KnownSymbol, TypeError, symbolVal) -- -- >>> data User = User { name :: String, age :: Int } deriving Generic -- >>> label @User --- User {name = Const "name", age = Const "age"} +-- User {name = Const {getConst = "name"}, age = Const {getConst = "age"}} class Label (structure :: Type) where label :: HKD structure (Const String) diff --git a/src/Data/Generic/HKD/Types.hs b/src/Data/Generic/HKD/Types.hs index 7f9f8e6..5e838bd 100644 --- a/src/Data/Generic/HKD/Types.hs +++ b/src/Data/Generic/HKD/Types.hs @@ -41,6 +41,7 @@ import Data.Proxy (Proxy (..)) import Data.Void (Void) import GHC.Generics import GHC.TypeLits (KnownSymbol, symbolVal) +import Generics.Deriving.Show (GShow' (..), gshowsPrecdefault) import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..)) 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}} -- -- >>> mempty @(HKD (Int, Bool) []) --- (,) [] [] +-- (,) ([],[]) newtype HKD (structure :: Type) (f :: Type -> Type) = 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 - 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)) +instance (Generic (HKD structure f), GShow' (GHKD_ f (Rep structure))) => Show (HKD structure f) where - show (HKD x) = gshow @'True x + showsPrec = gshowsPrecdefault -------------------------------------------------------------------------------