Semigroups, Monoids, Zips, and AsRecord (#13)

* Monoids, Semigroups, and Zips

* AsRecord

* tests

* changelog, version bump

* stylin

* hmm

ChangeLog.md

@@ -1,5 +1,13 @@
 # Changelog for prairie
 
+## 0.0.4.0
+
+- [#13](https://github.com/parsonsmatt/prairie/pull/13)
+    - Introduce `Prairie.Semigroup`, allowing you to combine two records by semigroup-appending their fields together.
+    - Introduce `Prairie.Zip`, allowing you to combine two records by specifying how to combine their fields. This fuels `Prairie.Semigroup`.
+    - Introduce `Prairie.Monoid`, allowing you to make an `emptyRecord` with `mempty` at each field.
+    - Introduce `Prairie.AsRecord`, allowing you to derive instances for records based on their `Record` and `FieldDict` instances.
+
 ## 0.0.3.0
 
 - [#8](https://github.com/parsonsmatt/prairie/pull/8)

prairie.cabal

@@ -1,7 +1,7 @@
 cabal-version: 1.12
 
 name:           prairie
-version:        0.0.3.0
+version:        0.0.4.0
 description:    Please see the README on GitHub at <https://github.com/parsonsmatt/prairie#readme>
 homepage:       https://github.com/parsonsmatt/prairie#readme
 bug-reports:    https://github.com/parsonsmatt/prairie/issues
@@ -24,12 +24,16 @@ source-repository head
 library
   exposed-modules:
       Prairie
+      Prairie.AsRecord
       Prairie.Class
       Prairie.Update
       Prairie.Diff
       Prairie.Fold
+      Prairie.Zip
       Prairie.Traverse
       Prairie.TH
+      Prairie.Semigroup
+      Prairie.Monoid
 
   build-depends:
       base              >= 4.13 && < 5

src/Prairie.hs

@@ -7,7 +7,10 @@ module Prairie
     , module Prairie.Diff
     , module Prairie.Fold
     , module Prairie.Traverse
+    , module Prairie.Zip
     , module Prairie.TH
+    , module Prairie.Semigroup
+    , module Prairie.Monoid
     ) where
 
 import Prairie.Class
@@ -16,3 +19,6 @@ import Prairie.Fold
 import Prairie.TH
 import Prairie.Traverse
 import Prairie.Update
+import Prairie.Zip
+import Prairie.Semigroup
+import Prairie.Monoid

src/Prairie/AsRecord.hs

@@ -0,0 +1,51 @@
+-- | This module contains a newtype 'AsRecord' which is used to provide
+-- a variety of default instances for types based on their 'Record'
+-- instance.
+module Prairie.AsRecord where
+
+import Prairie.Class
+import Prairie.Monoid
+import Prairie.Semigroup
+
+-- | This @newtype@ is intended for use with @DerivingVia@.
+--
+-- For an example use, let's consider this @User@ datatype:
+--
+-- > data Foo = Foo
+-- >     { ints :: [Int]
+-- >     , char :: First Char
+-- >     }
+-- >
+-- > mkRecord ''Foo
+--
+-- Let's say we want to define an instance of 'Semigroup' for this type, so
+-- that we can combine two of them. Ordinarily, we'd need to write
+-- a boilerplate-y instance:
+--
+-- > instance Semigroup Foo where
+-- >     f0 <> f1 = Foo
+-- >         { ints = f0.ints <> f1.ints
+-- >         , char = f0.char <> f1.char
+-- >         }
+--
+-- With @DerivingVia@, we can use 'AsRecord' to provide it easily:
+--
+-- @
+-- deriving via AsRecord Foo instance Semigroup Foo
+-- @
+--
+-- @since 0.0.4.0
+newtype AsRecord rec = AsRecord { unAsRecord :: rec }
+
+-- |
+--
+-- @since 0.0.4.0
+instance (Record rec, FieldDict Semigroup rec) => Semigroup (AsRecord rec) where
+    AsRecord r0 <> AsRecord r1 =
+        AsRecord (appendRecord r0 r1)
+
+-- |
+--
+-- @since 0.0.4.0
+instance (Record rec, FieldDict Semigroup rec, FieldDict Monoid rec) => Monoid (AsRecord rec) where
+    mempty = AsRecord emptyRecord

src/Prairie/Monoid.hs

@@ -0,0 +1,10 @@
+module Prairie.Monoid where
+
+import Prairie.Class
+
+-- | Create a 'mempty' 'Record' assuming that all of the fields of the
+-- record have a 'Monoid' instance.
+--
+-- @since 0.0.4.0
+emptyRecord :: (Record rec, FieldDict Monoid rec) => rec
+emptyRecord = tabulateRecord (\field -> withFieldDict @Monoid field mempty)

src/Prairie/Semigroup.hs

@@ -0,0 +1,17 @@
+-- | This module provides the ability to append two records using '(<>)',
+-- provided that all of their fields have an instance of 'Semigroup'.
+module Prairie.Semigroup where
+
+import Prairie.Class
+import Prairie.Zip
+
+-- | Zip two records together using a 'Semigroup' append.
+--
+-- @since 0.0.4.0
+appendRecord
+    :: forall rec. (Record rec, FieldDict Semigroup rec)
+    => rec
+    -> rec
+    -> rec
+appendRecord =
+    zipWithRecord (\a b field -> withFieldDict @Semigroup field (a <> b))

src/Prairie/Zip.hs

@@ -0,0 +1,34 @@
+module Prairie.Zip where
+
+import Prairie.Class
+import Prairie.Fold
+
+-- | Take two records and zip them together with the provided function.
+--
+-- The field is given for the final parameter in the function, allowing you to use @LambdaCase@.
+--
+-- @
+-- zipWithRecord
+--     (\a b ->
+--         \case
+--             UserName ->
+--                 a <> b
+--             UserAge ->
+--                 a + b
+--     )
+-- @
+--
+-- @since 0.0.4.0
+zipWithRecord
+    :: forall rec. (Record rec)
+    => (forall ty. ty -> ty -> Field rec ty -> ty)
+    -> rec
+    -> rec
+    -> rec
+zipWithRecord k r0 r1 =
+    foldRecord f r0 r0
+  where
+      f :: ty -> rec -> Field rec ty -> rec
+      f v0 rec field =
+          let v1 = getRecordField field r1
+           in setRecordField field (k v0 v1 field) rec

test/Spec.hs

@@ -1,12 +1,18 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
@@ -24,6 +30,8 @@ import Control.Monad
 import Data.Aeson
 import Data.Kind (Type)
 import Data.Monoid
+import GHC.Records
+import Prairie.AsRecord
 import Test.Hspec
 
 data User = User { name :: String, age :: Int }
@@ -36,6 +44,17 @@ deriving instance Show (Field User a)
 
 exampleUser = User "Alice" 30
 
+data Foo = Foo
+    { ints :: [Int]
+    , char :: First Char
+    }
+    deriving (Show, Eq)
+
+mkRecord ''Foo
+
+deriving via AsRecord Foo instance Semigroup Foo
+deriving via AsRecord Foo instance Monoid Foo
+
 data T a = T { x :: a, y :: Int }
 
 instance Record (T a) where
@@ -197,3 +216,31 @@ main = hspec $ do
                     User { name = "", age = 30 }
                     `shouldBe`
                         Nothing
+
+        describe "Semigroup" do
+            it "can combine two records" do
+                let f0 = Foo [1] (First Nothing)
+                    f1 = Foo [2,3] (First (Just 'a'))
+                f0 <> f1
+                    `shouldBe`
+                        Foo [1,2,3] (First (Just 'a'))
+
+        describe "Monoid" do
+            it "can produce an empty record" do
+                let obvious =
+                        Foo mempty mempty
+                mempty `shouldBe` obvious
+
+        describe "Zip" do
+            it "can combine two records" do
+                let u0 = User "Matt" 35
+                    u1 = User "ttaM" 53
+                zipWithRecord (\a b -> \case
+                    UserName ->
+                        a <> b
+                    UserAge ->
+                        a + b
+                    ) u0 u1
+                    `shouldBe`
+                        User "MattttaM" (35 + 53)
+