diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/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) diff --git a/prairie.cabal b/prairie.cabal --- a/prairie.cabal +++ b/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 homepage: https://github.com/parsonsmatt/prairie#readme bug-reports: https://github.com/parsonsmatt/prairie/issues @@ -24,12 +24,16 @@ 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 diff --git a/src/Prairie.hs b/src/Prairie.hs --- a/src/Prairie.hs +++ b/src/Prairie.hs @@ -7,7 +7,10 @@ , 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.TH import Prairie.Traverse import Prairie.Update +import Prairie.Zip +import Prairie.Semigroup +import Prairie.Monoid diff --git a/src/Prairie/AsRecord.hs b/src/Prairie/AsRecord.hs new file mode 100644 --- /dev/null +++ b/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 diff --git a/src/Prairie/Monoid.hs b/src/Prairie/Monoid.hs new file mode 100644 --- /dev/null +++ b/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) diff --git a/src/Prairie/Semigroup.hs b/src/Prairie/Semigroup.hs new file mode 100644 --- /dev/null +++ b/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)) diff --git a/src/Prairie/Zip.hs b/src/Prairie/Zip.hs new file mode 100644 --- /dev/null +++ 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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/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 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 @@ 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 @@ 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) +