Merge pull request #16 from i-am-tom/named

Add named field construction

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
@@ -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,32 @@ 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`](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):
+
+```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 []
+eg10 :: HKD Triple []
-eg8 = buniq empty
+eg10 = buniq empty
 -- Triple [] [] []
 ```
 
@@ -200,8 +222,8 @@ The `field` lens, when given a type-applied field name, allows us to focus on
 fields within a record:
 
 ```haskell
-eg9 :: Last Int
+eg11 :: Last Int
-eg9 = eg0 ^. field @"age"
+eg11 = eg0 ^. field @"age"
 -- Last {getLast = Nothing}
 ```
 
@@ -210,8 +232,8 @@ record (note that these set values will _also_ need to be in our functor of
 choice):
 
 ```haskell
-eg10 :: Partial User
+eg12 :: Partial User
-eg10 = eg0 & field @"name"      .~ pure "Evil Tom"
+eg12 = eg0 & field @"name"      .~ pure "Evil Tom"
            & field @"likesDogs" .~ pure False
 -- User
 --   { name      = Last {getLast = Just "Evil Tom"}
@@ -224,8 +246,8 @@ This also means, for example, we can check whether a particular value has been
 completed for a given partial type:
 
 ```haskell
-eg11 :: Bool
+eg13 :: Bool
-eg11 = anyOf (field @"name") (isJust . getLast) eg0
+eg13 = anyOf (field @"name") (isJust . getLast) eg0
 -- False
 ```
 
@@ -234,8 +256,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 ()
+eg14 :: Identity ()
-eg12 = eg3 ^. field @"oops"
+eg14 = eg3 ^. field @"oops"
 -- error:
 -- • The type User does not contain a field named 'oops'.
 ```
@@ -246,8 +268,8 @@ Just as with field names, we can use positions when working with non-record
 product types:
 
 ```haskell
-eg13 :: Labels Triple
+eg15 :: Labels Triple
-eg13 = mempty & position @1 .~ Const "hello"
+eg15 = mempty & position @1 .~ Const "hello"
               & position @2 .~ Const "world"
 -- Triple
 --   Const "hello"
@@ -258,11 +280,11 @@ eg13 = mempty & position @1 .~ Const "hello"
 Again, this is a `Lens`, so we can just as easily _set_ values:
 
 ```haskell
-eg14 :: Partial User
+eg16 :: Partial User
-eg14 = eg10 & position @2 .~ pure 25
+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 +293,8 @@ Similarly, the internals here come to us courtesy of `generic-lens`, so the
 type errors are a delight:
 
 ```{haskell, ignore}
-eg15 :: Identity ()
+eg17 :: Identity ()
-eg15 = deconstruct @Identity triple ^. position @4
+eg17 = deconstruct @Identity triple ^. position @4
 -- error:
 -- • The type Triple does not contain a field at position 4
 ```
@@ -284,8 +306,8 @@ names of the fields into the functor we're using. The `label` value gives us
 this interface:
 
 ```haskell
-eg16 :: Labels User
+eg18 :: Labels User
-eg16 = label
+eg18 = label
 -- User
 --   { name = Const "name"
 --   , age = Const "age"
@@ -294,14 +316,14 @@ eg16 = 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:
 
 ```haskell
-eg17 :: [String]
+eg19 :: [String]
-eg17 = labelsWhere (isNothing . getLast) eg10
+eg19 = labelsWhere (isNothing . getLast) eg12
 -- ["age"]
 ```
 

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

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

src/Data/Generic/HKD/Named.hs

@@ -0,0 +1,111 @@
+{-# 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 (..))
+
+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
+
+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
+
+-- | 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
+-- wonderful @named@ package to help us:
+--
+-- >>> :set -XDeriveGeneric -XTypeApplications
+--
+-- >>> :{
+-- data User
+--   = User { name :: String, enemy :: String }
+--   deriving Generic
+-- :}
+--
+-- >>> :{
+-- test :: _
+-- test = record @User
+-- :}
+-- ...
+-- ... Found type wildcard ...
+-- ... standing for ...("name" :! f [Char])
+-- ...   -> ("enemy" :! f [Char]) -> 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)
+    , 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
+    , 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)
+
+    , list ~ Rearrange (HKD_ f structure)
+    , 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))