From 049af746be5a23d47cf81fb16024bc084c01a7de Mon Sep 17 00:00:00 2001 From: Tom Harding Date: Fri, 27 Sep 2019 14:47:12 +0100 Subject: [PATCH 1/2] Add named field construction The `named` library seems to make a lot of this look much prettier, so I'm very excited about this change! --- README.md | 66 +++++++++++++-------- higgledy.cabal | 3 + src/Data/Generic/HKD.hs | 1 + src/Data/Generic/HKD/Named.hs | 106 ++++++++++++++++++++++++++++++++++ 4 files changed, 153 insertions(+), 23 deletions(-) create mode 100644 src/Data/Generic/HKD/Named.hs diff --git a/README.md b/README.md index 6048011..6467b88 100644 --- a/README.md +++ b/README.md @@ -50,6 +50,8 @@ example data types: {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TypeOperators #-} module Main where import Control.Applicative (Alternative (empty)) @@ -61,6 +63,7 @@ import Data.Generic.HKD import Data.Maybe (isJust, isNothing) import Data.Monoid (Last (..)) import GHC.Generics (Generic) +import Named ((:!), (!)) -- An example of a record (with named fields): data User @@ -72,7 +75,7 @@ data User deriving (Generic, Show) user :: User -user = User "Tom" 25 True +user = User "Tom" 26 True -- An example of a product (without named fields): data Triple @@ -145,7 +148,7 @@ eg3 :: Bare User eg3 = deconstruct user -- User -- { name = Identity "Tom" --- , age = Identity 25 +-- , age = Identity 26 -- , likesDogs = Identity True -- } ``` @@ -184,13 +187,30 @@ eg7 = eg6 [1] [] ["Tom", "Tim"] -- Triple [1] [] ["Tom","Tim"] ``` +Should we need to work with records, we can exploit the label trickery of the +[`named`](http://hackage.haskell.org/package/named) package. The `record` +function behaves exactly as `build` does, but produces a function compatible +with the `named` interface. After that, we can use the function with labels +(and with no regard for the internal order): + +```haskell +eg8 :: "name" :! f [Char] + -> "age" :! f Int + -> "likesDogs" :! f Bool + -> HKD User f +eg8 = record @User + +eg9 :: HKD User Maybe +eg9 = eg8 ! #name (Just "Tom") ! #likesDogs (Just True) ! #age (Just 26) +``` + If you're _still_ not satisfied, check out the [`buniq`](https://hackage.haskell.org/package/barbies-1.1.2.1/docs/Data-Barbie.html#v:buniq) method hiding in `barbies`: ```haskell -eg8 :: HKD Triple [] -eg8 = buniq empty +eg10 :: HKD Triple [] +eg10 = buniq empty -- Triple [] [] [] ``` @@ -200,8 +220,8 @@ The `field` lens, when given a type-applied field name, allows us to focus on fields within a record: ```haskell -eg9 :: Last Int -eg9 = eg0 ^. field @"age" +eg11 :: Last Int +eg11 = eg0 ^. field @"age" -- Last {getLast = Nothing} ``` @@ -210,8 +230,8 @@ record (note that these set values will _also_ need to be in our functor of choice): ```haskell -eg10 :: Partial User -eg10 = eg0 & field @"name" .~ pure "Evil Tom" +eg12 :: Partial User +eg12 = eg0 & field @"name" .~ pure "Evil Tom" & field @"likesDogs" .~ pure False -- User -- { name = Last {getLast = Just "Evil Tom"} @@ -224,8 +244,8 @@ This also means, for example, we can check whether a particular value has been completed for a given partial type: ```haskell -eg11 :: Bool -eg11 = anyOf (field @"name") (isJust . getLast) eg0 +eg13 :: Bool +eg13 = anyOf (field @"name") (isJust . getLast) eg0 -- False ``` @@ -234,8 +254,8 @@ Finally, thanks to the fact that this library exploits some of the internals of doesn't exist in our type: ```{haskell, ignore} -eg12 :: Identity () -eg12 = eg3 ^. field @"oops" +eg14 :: Identity () +eg14 = eg3 ^. field @"oops" -- error: -- • The type User does not contain a field named 'oops'. ``` @@ -246,8 +266,8 @@ Just as with field names, we can use positions when working with non-record product types: ```haskell -eg13 :: Labels Triple -eg13 = mempty & position @1 .~ Const "hello" +eg15 :: Labels Triple +eg15 = mempty & position @1 .~ Const "hello" & position @2 .~ Const "world" -- Triple -- Const "hello" @@ -258,11 +278,11 @@ eg13 = mempty & position @1 .~ Const "hello" Again, this is a `Lens`, so we can just as easily _set_ values: ```haskell -eg14 :: Partial User -eg14 = eg10 & position @2 .~ pure 25 +eg16 :: Partial User +eg16 = eg12 & position @2 .~ pure 26 -- User -- { name = Last {getLast = Just "Evil Tom"} --- , age = Last {getLast = Just 25} +-- , age = Last {getLast = Just 26} -- , likesDogs = Last {getLast = Just False} -- } ``` @@ -271,8 +291,8 @@ Similarly, the internals here come to us courtesy of `generic-lens`, so the type errors are a delight: ```{haskell, ignore} -eg15 :: Identity () -eg15 = deconstruct @Identity triple ^. position @4 +eg17 :: Identity () +eg17 = deconstruct @Identity triple ^. position @4 -- error: -- • The type Triple does not contain a field at position 4 ``` @@ -284,8 +304,8 @@ names of the fields into the functor we're using. The `label` value gives us this interface: ```haskell -eg16 :: Labels User -eg16 = label +eg18 :: Labels User +eg18 = label -- User -- { name = Const "name" -- , age = Const "age" @@ -300,8 +320,8 @@ can implement functions such as `labelsWhere`, which returns the names of all fields whose values satisfy some predicate: ```haskell -eg17 :: [String] -eg17 = labelsWhere (isNothing . getLast) eg10 +eg19 :: [String] +eg19 = labelsWhere (isNothing . getLast) eg12 -- ["age"] ``` diff --git a/higgledy.cabal b/higgledy.cabal index 42aad36..3db06c9 100644 --- a/higgledy.cabal +++ b/higgledy.cabal @@ -20,6 +20,7 @@ library Data.Generic.HKD.Build Data.Generic.HKD.Construction Data.Generic.HKD.Labels + Data.Generic.HKD.Named Data.Generic.HKD.Types -- other-modules: -- other-extensions: @@ -27,6 +28,7 @@ library , barbies ^>= 1.1.0 , generic-lens ^>= 1.1.0 , QuickCheck >= 2.12.6 && < 2.14 + , named ^>= 0.3.0.0 hs-source-dirs: src default-language: Haskell2010 @@ -48,6 +50,7 @@ test-suite readme , barbies ^>= 1.1.0 , lens ^>= 4.17 , higgledy + , named ^>= 0.3.0.0 main-is: README.lhs type: exitcode-stdio-1.0 default-language: Haskell2010 diff --git a/src/Data/Generic/HKD.hs b/src/Data/Generic/HKD.hs index 489027a..8317e98 100644 --- a/src/Data/Generic/HKD.hs +++ b/src/Data/Generic/HKD.hs @@ -27,6 +27,7 @@ module Data.Generic.HKD import Data.Generic.HKD.Build as Exports import Data.Generic.HKD.Construction as Exports import Data.Generic.HKD.Labels as Exports +import Data.Generic.HKD.Named as Exports import Data.Generic.HKD.Types as Exports import qualified Data.Barbie as Barbie diff --git a/src/Data/Generic/HKD/Named.hs b/src/Data/Generic/HKD/Named.hs new file mode 100644 index 0000000..060aad1 --- /dev/null +++ b/src/Data/Generic/HKD/Named.hs @@ -0,0 +1,106 @@ +{-# OPTIONS_HADDOCK not-home #-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module : Data.Generic.HKD.Named +Description : Construct an HKD record with named parameters. +Copyright : (c) Tom Harding, 2019 +License : MIT +Maintainer : tom.harding@habito.com +Stability : experimental +-} +module Data.Generic.HKD.Named + ( Record (..) + ) where + +import Data.Functor.Contravariant (Contravariant (..)) +import Data.Generic.HKD.Types (HKD, HKD_) +import Data.GenericLens.Internal (GUpcast (..)) +import Data.Kind (Type) +import GHC.Generics +import Named ((:!), NamedF (..)) + +class Append (xs :: Type -> Type) (ys :: Type -> Type) (zs :: Type -> Type) + | xs ys -> zs where + +instance Append (S1 m h) t (S1 m h :*: t) +instance Append x y z => Append (w :*: x) y (w :*: z) + +class Rearrange (i :: Type -> Type) (o :: Type -> Type) | i -> o +instance Rearrange i o => Rearrange (D1 m i) (D1 m o) +instance Rearrange i o => Rearrange (C1 m i) (C1 m o) +instance Rearrange i o => Rearrange (S1 m i) (S1 m o) +instance Rearrange (Rec0 x) (Rec0 x) +instance (Rearrange l l', Rearrange r r', Append l' r' o) + => Rearrange (l :*: r) o where + +-- | The 'Data.Generic.HKD.build' function lets us supply arguments to a type +-- one by one, but can cause confusion when working with a record. If the +-- record contains two fields of the same type, for example, we've introduced +-- an opportunity for bugs and confusion. The @record@ function uses the +-- wonderful @named@ package to help us: +-- +-- >>> :set -XDeriveGeneric -XTypeApplications +-- +-- >>> :{ +-- data User +-- = User { name :: String, age :: Int, likesDogs :: Bool } +-- deriving Generic +-- :} +-- +-- >>> :{ +-- test :: _ +-- test = record @User +-- :} +-- ... +-- ... Found type wildcard ... +-- ... standing for ...("name" :! f [Char]) +-- ... -> ("age" :! f Int) -> ("likesDogs" :! f Bool) -> HKD User f... +-- ... +class Record (structure :: Type) (f :: Type -> Type) (k :: Type) + | f structure -> k where + record :: k + +class GRecord (rep :: Type -> Type) (f :: Type -> Type) (structure :: Type) (k :: Type) + | f structure rep -> k where + grecord :: (forall p. rep p -> HKD structure f) -> k + +instance GRecord inner f structure k + => GRecord (D1 meta inner) f structure k where + grecord rebuild = grecord (rebuild . M1) + +instance GRecord inner f structure k + => GRecord (C1 meta inner) f structure k where + grecord rebuild = grecord (rebuild . M1) + +instance (rec ~ (Rec0 inner), k ~ (name :! inner -> HKD structure f)) + => GRecord (S1 ('MetaSel ('Just name) i d c) rec) f structure k where + grecord fill = \(Arg inner) -> fill (M1 (K1 inner)) + +instance (GRecord right f structure k, rec ~ Rec0 x) + => GRecord (S1 ('MetaSel ('Just name) i d c) rec :*: right) f structure (name :! x -> k) where + grecord fill = \(Arg left) -> grecord \right -> fill (M1 (K1 left) :*: right) + +instance + ( Contravariant (HKD_ f structure) + , Functor (HKD_ f structure) + + , Rearrange (HKD_ f structure) list + , GUpcast list (HKD_ f structure) + , GRecord list f structure k + ) + => Record structure f k where + record = grecord @_ @f @structure (to . gupcast @list @(HKD_ f structure)) From ba5fc87669e55431d29c5f233df4d1fb4aef2b81 Mon Sep 17 00:00:00 2001 From: Tom Harding Date: Sun, 29 Sep 2019 22:05:17 +0100 Subject: [PATCH 2/2] Code review changes Thanks @neongreen and @int-index! --- README.md | 10 ++++---- src/Data/Generic/HKD/Named.hs | 45 +++++++++++++++++++---------------- 2 files changed, 31 insertions(+), 24 deletions(-) diff --git a/README.md b/README.md index 6467b88..ac32196 100644 --- a/README.md +++ b/README.md @@ -38,7 +38,7 @@ type UserF f = HKD User f ``` As an added little bonus, any `HKD`-wrapped object is automatically an instance -of all the [Barbie](http://hackage.haskell.org/package/barbies) classes, so no +of all the [Barbie](https://hackage.haskell.org/package/barbies) classes, so no need to derive anything more than `Generic`! ## API @@ -188,7 +188,7 @@ eg7 = eg6 [1] [] ["Tom", "Tim"] ``` Should we need to work with records, we can exploit the label trickery of the -[`named`](http://hackage.haskell.org/package/named) package. The `record` +[`named`](https://hackage.haskell.org/package/named) package. The `record` function behaves exactly as `build` does, but produces a function compatible with the `named` interface. After that, we can use the function with labels (and with no regard for the internal order): @@ -201,7 +201,9 @@ eg8 :: "name" :! f [Char] eg8 = record @User eg9 :: HKD User Maybe -eg9 = eg8 ! #name (Just "Tom") ! #likesDogs (Just True) ! #age (Just 26) +eg9 = eg8 ! #name (Just "Tom") + ! #likesDogs (Just True) + ! #age (Just 26) ``` If you're _still_ not satisfied, check out the @@ -314,7 +316,7 @@ eg18 = label ``` By combining this with some of the -[Barbies](http://hackage.haskell.org/package/barbies) interface (the entirety +[Barbies](https://hackage.haskell.org/package/barbies) interface (the entirety of which is available to any `HKD`-wrapped type) such as `bprod` and `bmap`, we can implement functions such as `labelsWhere`, which returns the names of all fields whose values satisfy some predicate: diff --git a/src/Data/Generic/HKD/Named.hs b/src/Data/Generic/HKD/Named.hs index 060aad1..6d9d2b7 100644 --- a/src/Data/Generic/HKD/Named.hs +++ b/src/Data/Generic/HKD/Named.hs @@ -33,21 +33,17 @@ import Data.Kind (Type) import GHC.Generics import Named ((:!), NamedF (..)) -class Append (xs :: Type -> Type) (ys :: Type -> Type) (zs :: Type -> Type) - | xs ys -> zs where +type family Append (xs :: Type -> Type) (ys :: Type -> Type) :: Type -> Type where + Append (S1 meta head) tail = S1 meta head :*: tail + Append (left :*: right) other = left :*: Append right other -instance Append (S1 m h) t (S1 m h :*: t) -instance Append x y z => Append (w :*: x) y (w :*: z) +type family Rearrange (i :: Type -> Type) :: Type -> Type where + Rearrange (S1 m inner) = S1 m (Rearrange inner) + Rearrange (M1 index m inner) = M1 index m (Rearrange inner) + Rearrange (left :*: right) = Append (Rearrange left) (Rearrange right) + Rearrange (Rec0 inner) = Rec0 inner -class Rearrange (i :: Type -> Type) (o :: Type -> Type) | i -> o -instance Rearrange i o => Rearrange (D1 m i) (D1 m o) -instance Rearrange i o => Rearrange (C1 m i) (C1 m o) -instance Rearrange i o => Rearrange (S1 m i) (S1 m o) -instance Rearrange (Rec0 x) (Rec0 x) -instance (Rearrange l l', Rearrange r r', Append l' r' o) - => Rearrange (l :*: r) o where - --- | The 'Data.Generic.HKD.build' function lets us supply arguments to a type +-- | The 'Data.Generic.HKD.record' function lets us supply arguments to a type -- one by one, but can cause confusion when working with a record. If the -- record contains two fields of the same type, for example, we've introduced -- an opportunity for bugs and confusion. The @record@ function uses the @@ -57,7 +53,7 @@ instance (Rearrange l l', Rearrange r r', Append l' r' o) -- -- >>> :{ -- data User --- = User { name :: String, age :: Int, likesDogs :: Bool } +-- = User { name :: String, enemy :: String } -- deriving Generic -- :} -- @@ -68,7 +64,7 @@ instance (Rearrange l l', Rearrange r r', Append l' r' o) -- ... -- ... Found type wildcard ... -- ... standing for ...("name" :! f [Char]) --- ... -> ("age" :! f Int) -> ("likesDogs" :! f Bool) -> HKD User f... +-- ... -> ("enemy" :! f [Char]) -> HKD User f... -- ... class Record (structure :: Type) (f :: Type -> Type) (k :: Type) | f structure -> k where @@ -86,19 +82,28 @@ instance GRecord inner f structure k => GRecord (C1 meta inner) f structure k where grecord rebuild = grecord (rebuild . M1) -instance (rec ~ (Rec0 inner), k ~ (name :! inner -> HKD structure f)) - => GRecord (S1 ('MetaSel ('Just name) i d c) rec) f structure k where +instance + ( rec ~ (Rec0 inner) + , k ~ (name :! inner -> HKD structure f) + , meta ~ 'MetaSel ('Just name) i d c + ) + => GRecord (S1 meta rec) f structure k where grecord fill = \(Arg inner) -> fill (M1 (K1 inner)) -instance (GRecord right f structure k, rec ~ Rec0 x) - => GRecord (S1 ('MetaSel ('Just name) i d c) rec :*: right) f structure (name :! x -> k) where +instance + ( GRecord right f structure k' + , rec ~ Rec0 x + , left ~ S1 ('MetaSel ('Just name) i d c) rec + , k ~ (name :! x -> k') + ) + => GRecord (left :*: right) f structure k where grecord fill = \(Arg left) -> grecord \right -> fill (M1 (K1 left) :*: right) instance ( Contravariant (HKD_ f structure) , Functor (HKD_ f structure) - , Rearrange (HKD_ f structure) list + , list ~ Rearrange (HKD_ f structure) , GUpcast list (HKD_ f structure) , GRecord list f structure k )