prairie 0.0.4.0 → 0.1.0.0

raw patch · 18 files changed

+872/−409 lines, 18 filesdep +foldable1-classes-compatdep +mtldep +semigroupoidsdep ~template-haskellsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: foldable1-classes-compat, mtl, semigroupoids

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

Files

• ChangeLog.md +24/−1
• Setup.hs +1/−0
• prairie.cabal +16/−9
• src/Prairie.hs +2/−2
• src/Prairie/AsRecord.hs +5/−2
• src/Prairie/Class.hs +124/−87
• src/Prairie/Diff.hs +18/−19
• src/Prairie/Distributed.hs +169/−0
• src/Prairie/Fold.hs +34/−9
• src/Prairie/Internal.hs +25/−0
• src/Prairie/Semigroup.hs +2/−1
• src/Prairie/TH.hs +192/−154
• src/Prairie/Traverse.hs +87/−2
• src/Prairie/Update.hs +40/−34
• src/Prairie/Zip.hs +8/−5
• test/Prairie/DuplicateFieldSpec.hs +22/−0
• test/Prairie/NoFieldSelectorSpec.hs +27/−0
• test/Spec.hs +76/−84

@@ -1,5 +1,28 @@ # Changelog for prairie +## 0.1.0.0++- [#22](https://github.com/parsonsmatt/prairie/pull/22)+    - Don't emit unused type variables+- [#20](https://github.com/parsonsmatt/prairie/pull/20)+    - Add `tabulateRecordApply` which is like `tabulateRecordA` but allows you to use non-Applicaive effects.+    - `Prairie.Fold`: `foldMapRecord` now works with any `Semigroup` instead of any `Monoid`, allowing you to fold into a `NonEmpty` list.+    - `Prairie.Traverse`:+        - `traverseRecord_` introduced as a slightly more efficient form of `void . traverseRecord f`.+        - `traverseFields` and `traverseFields_` introduced to only operate on fields, not requiring a whole record.+        - `traverseFieldsWithDict` (and `_` suffix variant) introduced to operate on fields with a constraint available.+- [#5](https://github.com/parsonsmatt/prairie/pull/5), [#21](https://github.com/parsonsmatt/prairie/pull/21)+    - The `Prairie.Distributed` module is made available.+      This allows you to define records that are constructed on a per-field basis in some effect type.+- [#23](https://github.com/parsonsmatt/prairie/pull/23)+    - Generated code is no longer ambiguous or faulty in the case of `NoFieldSelectors` or `DuplicateRecordFields`.+    - `mkRecord` now requires `TypeApplications` to compile.++## 0.0.4.1++- [#18](https://github.com/parsonsmatt/prairie/pull/18)+    - Drop `lens` dependency+ ## 0.0.4.0  - [#13](https://github.com/parsonsmatt/prairie/pull/13)@@ -25,7 +48,7 @@ - [#2](https://github.com/parsonsmatt/prairie/pull/2)     - Add `tabulateRecordA` to `Record` class. `tabulate` and `allFields` are now normal functions.     - Provide a default implementation of `recordFieldLabel` for `Show`able fields.-    + ## 0.0.1.1  * [#4](https://github.com/parsonsmatt/prairie/pull/4)

@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain

@@ -1,7 +1,7 @@ cabal-version: 1.12  name:           prairie-version:        0.0.4.0+version:        0.1.0.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@@ -26,26 +26,30 @@       Prairie       Prairie.AsRecord       Prairie.Class-      Prairie.Update       Prairie.Diff+      Prairie.Distributed       Prairie.Fold-      Prairie.Zip-      Prairie.Traverse-      Prairie.TH-      Prairie.Semigroup       Prairie.Monoid+      Prairie.Semigroup+      Prairie.TH+      Prairie.Traverse+      Prairie.Update+      Prairie.Zip    build-depends:       base              >= 4.13 && < 5-    , aeson             +    , aeson     , constraints     , containers-    , lens-    , template-haskell  >= 2.15 && < 2.22+    , mtl+    , semigroupoids+    , template-haskell  >=2.15 && <2.24     , text+    , foldable1-classes-compat    other-modules:       Paths_prairie+      Prairie.Internal   hs-source-dirs:       src   default-language: Haskell2010@@ -85,6 +89,8 @@   main-is: Spec.hs   other-modules:       Paths_prairie+      Prairie.DuplicateFieldSpec+      Prairie.NoFieldSelectorSpec   hs-source-dirs:       test   ghc-options: -threaded -rtsopts -with-rtsopts=-N@@ -94,4 +100,5 @@     , aeson     , lens     , hspec+    , semigroupoids   default-language: Haskell2010

@@ -16,9 +16,9 @@ import Prairie.Class import Prairie.Diff import Prairie.Fold+import Prairie.Monoid+import Prairie.Semigroup import Prairie.TH import Prairie.Traverse import Prairie.Update import Prairie.Zip-import Prairie.Semigroup-import Prairie.Monoid

@@ -35,7 +35,7 @@ -- @ -- -- @since 0.0.4.0-newtype AsRecord rec = AsRecord { unAsRecord :: rec }+newtype AsRecord rec = AsRecord {unAsRecord :: rec}  -- | --@@ -47,5 +47,8 @@ -- | -- -- @since 0.0.4.0-instance (Record rec, FieldDict Semigroup rec, FieldDict Monoid rec) => Monoid (AsRecord rec) where+instance+    (Record rec, FieldDict Semigroup rec, FieldDict Monoid rec)+    => Monoid (AsRecord rec)+    where     mempty = AsRecord emptyRecord

@@ -16,18 +16,23 @@ -- @since 0.0.1.0 module Prairie.Class where -import Control.Lens (Lens', set, view, Identity(..), Const(..))-import Data.Aeson (ToJSON(..), FromJSON(..), withText)-import Data.Constraint (Dict(..))+import Data.Aeson (FromJSON (..), ToJSON (..), withText)+import Data.Constraint (Dict (..))+import Data.Functor.Apply (Apply (..))+import Data.Functor.Const (Const (..))+import Data.Functor.Identity (Identity (..)) import Data.Kind (Constraint, Type)+import Data.List.NonEmpty (NonEmpty) import Data.Map (Map) import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as Text-import Data.Typeable ((:~:)(..), Typeable, eqT)-import GHC.OverloadedLabels (IsLabel(..))+import Data.Typeable (Typeable, eqT, (:~:) (..))+import GHC.OverloadedLabels (IsLabel (..)) import GHC.TypeLits (Symbol) +import Prairie.Internal (Lens', set, view)+ -- | Instances of this class have a datatype 'Field' which allow you to -- represent fields as a concrete datatype. This allows you to have -- significant flexibility in working with data.@@ -100,8 +105,12 @@     -- @     --     -- @since 0.0.2.0-    tabulateRecordA :: Applicative m => (forall ty. Field rec ty -> m ty) -> m rec+    tabulateRecordA :: (Applicative m) => (forall ty. Field rec ty -> m ty) -> m rec +    -- | Like 'tabulateRecordA', but this only requires 'Apply', which+    -- allows you to use 'Foldable1' and 'NonEmpty'.+    tabulateRecordApply :: (Apply m) => (forall ty. Field rec ty -> m ty) -> m rec+     -- | Assign a 'Text' label for a record 'Field'.     --     -- This allows 'Field's to be converted to 'Text', which is useful for@@ -113,7 +122,7 @@     --     -- @since 0.0.1.0     recordFieldLabel :: Field rec ty -> Text-    default recordFieldLabel :: Show (Field rec ty) => Field rec ty -> Text+    default recordFieldLabel :: (Show (Field rec ty)) => Field rec ty -> Text     recordFieldLabel = Text.pack . show  -- | An enumeration of fields on the record.@@ -121,43 +130,68 @@ -- This value builds the fields using 'tabulateRecordA' and the 'Const' -- type. ----- As of @0.0.2.0,@ this is an ordinary top-level function and not a class+-- As of @0.0.2.0@, this is an ordinary top-level function and not a class -- member. --+-- As of @0.1.0.0@, this functions works for any 'Semigroup' and+-- 'Applicative', allowing you to use it to create both a list and+-- a 'NonEmpty' list for it. Since this may result in ambiguity, we offer+-- 'allFieldsList' and 'allFieldsNonEmpty' as aliases with fixed types.+-- -- @since 0.0.1.0-allFields :: Record rec => [SomeField rec]-allFields = getConst $ tabulateRecordA $ \field ->-    Const [SomeField field]+allFields+    :: (Record rec, forall a. Semigroup (f a), Applicative f)+    => f (SomeField rec)+allFields = getConst $ tabulateRecordApply $ \field ->+    Const (pure (SomeField field)) +-- | Like 'allFields' but with the type specialized to lists.+--+-- @since 0.1.0.0+allFieldsList+    :: (Record rec)+    => [SomeField rec]+allFieldsList =+    allFields++-- | Like 'allFields' but with the type specialized to 'NonEmpty' lists.+--+-- @since 0.1.0.0+allFieldsNonEmpty+    :: (Record rec)+    => NonEmpty (SomeField rec)+allFieldsNonEmpty =+    allFields+ -- | This function allows you to construct a 'Record' by providing -- a value for each 'Field' on the record. -- -- As of @0.0.2.0@, this is defined in terms of 'tabulateRecordA'. -- -- @since 0.0.1.0-tabulateRecord :: Record rec => (forall ty. Field rec ty -> ty) -> rec+tabulateRecord :: (Record rec) => (forall ty. Field rec ty -> ty) -> rec tabulateRecord k = runIdentity (tabulateRecordA (Identity . k))  -- | A mapping from 'Text' record field labels to the corresponding -- 'SomeField' for that record. -- -- @since 0.0.1.0-fieldMap :: Record rec => Map Text (SomeField rec)+fieldMap :: forall rec. (Record rec) => Map Text (SomeField rec) fieldMap =-  foldMap-    (\sf@(SomeField f) -> Map.singleton (recordFieldLabel f) sf)-    allFields+    foldMap+        (\sf@(SomeField f) -> Map.singleton (recordFieldLabel f) sf)+        (allFields @rec @[])  -- | Use a 'Field' to access the corresponding value in the record. -- -- @since 0.0.1.0-getRecordField :: Record rec => Field rec ty -> rec -> ty+getRecordField :: (Record rec) => Field rec ty -> rec -> ty getRecordField f = view (recordFieldLens f)  -- | Use a 'Field' to set the corresponding value in the record. -- -- @since 0.0.1.0-setRecordField :: Record rec => Field rec ty -> ty -> rec -> rec+setRecordField :: (Record rec) => Field rec ty -> ty -> rec -> rec setRecordField f = set (recordFieldLens f)  -- | An existential wrapper on a 'Field'. This hides the type of the value@@ -167,7 +201,7 @@ -- -- @since 0.0.1.0 data SomeField rec where-  SomeField :: Field rec a -> SomeField rec+    SomeField :: Field rec a -> SomeField rec  -- | You can write a standalone deriving instance for 'Field': --@@ -186,62 +220,61 @@ deriving stock instance (forall a. Show (Field rec a)) => Show (SomeField rec)  instance-  ( forall a. Eq (Field rec a)-  , FieldDict Typeable rec-  )- =>-  Eq (SomeField rec)- where-  SomeField (f0 :: Field rec a) == SomeField (f1 :: Field rec b) =-    withFieldDict @Typeable f0 $-    withFieldDict @Typeable f1 $-    case eqT @a @b of-      Just Refl ->-          f0 == f1-      Nothing ->-        False+    ( forall a. Eq (Field rec a)+    , FieldDict Typeable rec+    )+    => Eq (SomeField rec)+    where+    SomeField (f0 :: Field rec a) == SomeField (f1 :: Field rec b) =+        withFieldDict @Typeable f0 $+            withFieldDict @Typeable f1 $+                case eqT @a @b of+                    Just Refl ->+                        f0 == f1+                    Nothing ->+                        False  -- | This instance delegates to the underlying instance of 'ToJSON' for the -- given field. -- -- @since 0.0.1.0 instance (forall a. ToJSON (Field rec a)) => ToJSON (SomeField rec) where-  toJSON (SomeField f) = toJSON f+    toJSON (SomeField f) = toJSON f  -- | This instance delegates to the underlying instance of 'FromJSON' for -- the given field. -- -- @since 0.0.1.0 instance (Record rec) => FromJSON (SomeField rec) where-  parseJSON = withText "Field" $ \txt ->-    case Map.lookup txt (fieldMap @rec) of-      Just field ->-        pure field-      Nothing ->-        fail "Field not"+    parseJSON = withText "Field" $ \txt ->+        case Map.lookup txt (fieldMap @rec) of+            Just field ->+                pure field+            Nothing ->+                fail "Field not"  -- | This delegates to 'recordFieldLabel'  from the 'Record' class. -- -- @since 0.0.1.0-instance Record rec => ToJSON (Field rec a) where-  toJSON = toJSON . recordFieldLabel+instance (Record rec) => ToJSON (Field rec a) where+    toJSON = toJSON . recordFieldLabel  -- | This parses a 'Field' from a 'Text' given by the function -- 'recordFieldLabel'. -- -- @since 0.0.1.0 instance (Record rec, FieldDict Typeable rec, Typeable a) => FromJSON (Field rec a) where-  parseJSON = withText "Field" $ \txt ->-    case Map.lookup txt (fieldMap @rec) of-      Just (SomeField (a :: Field rec b)) ->-        withFieldDict @Typeable a $-        case eqT @a @b of-          Just Refl ->-            pure a-          Nothing ->-            fail "types not same???"-      Nothing ->-        fail "Field not"+    parseJSON = withText "Field" $ \txt ->+        case Map.lookup txt (fieldMap @rec) of+            Just (SomeField (a :: Field rec b)) ->+                withFieldDict @Typeable a $+                    case eqT @a @b of+                        Just Refl ->+                            pure a+                        Nothing ->+                            fail "types not same???"+            Nothing ->+                fail "Field not"  -- | This class allows you to summon a type class instance based on a 'Field' -- of the record. Use this type class when you need to assert that all the@@ -274,20 +307,20 @@ -- -- @since 0.0.1.0 class (Record r) => FieldDict (c :: Type -> Constraint) (r :: Type) where-  -- | Return the 'Dict' for the given field.-  ---  -- An implementation of this for the 'User' type would case on each field-  -- and return 'Dict' in each branch.-  ---  -- @-  -- getFieldDict userField =-  --   case userField of-  --    UserName -> Dict-  --    UserAge -> Dict-  -- @-  ---  -- @since 0.0.1.0-  getFieldDict :: Field r a -> Dict (c a)+    -- | Return the 'Dict' for the given field.+    --+    -- An implementation of this for the 'User' type would case on each field+    -- and return 'Dict' in each branch.+    --+    -- @+    -- getFieldDict userField =+    --   case userField of+    --    UserName -> Dict+    --    UserAge -> Dict+    -- @+    --+    -- @since 0.0.1.0+    getFieldDict :: Field r a -> Dict (c a)  -- | Given a record @field :: 'Field' rec a@, this function brings the -- type class instance @c a@ into scope for the third argument.@@ -298,17 +331,17 @@ -- -- @since 0.0.1.0 withFieldDict-  :: forall c rec a r-   . FieldDict c rec-  => Field rec a-  -- ^ The record field we want to unpack. We need this value in order to-  -- know what type we want the constraint to apply to.-  -> (c a => r)-  -- ^ A value that assumes the constraint @c@ holds for the type @a@.-  -> r+    :: forall c rec a r+     . (FieldDict c rec)+    => Field rec a+    -- ^ The record field we want to unpack. We need this value in order to+    -- know what type we want the constraint to apply to.+    -> ((c a) => r)+    -- ^ A value that assumes the constraint @c@ holds for the type @a@.+    -> r withFieldDict l k =-  case getFieldDict @c l of-    Dict -> k+    case getFieldDict @c l of+        Dict -> k  -- | This type class enables you to map a 'Symbol's to a record 'Field'. --@@ -347,15 +380,19 @@ -- @ -- -- @since 0.0.1.0-class Record rec => SymbolToField (sym :: Symbol) (rec :: Type) (a :: Type) | rec sym -> a where-  -- | This function is designed to be used with a type application:-  ---  -- @-  -- symbolToField @"age"-  -- @-  ---  -- @since 0.0.1.0-  symbolToField :: Field rec a+class+    (Record rec) =>+    SymbolToField (sym :: Symbol) (rec :: Type) (a :: Type)+        | rec sym -> a+    where+    -- | This function is designed to be used with a type application:+    --+    -- @+    -- symbolToField @"age"+    -- @+    --+    -- @since 0.0.1.0+    symbolToField :: Field rec a  -- | If you've defined the relevant instances for 'SymbolToField', then you -- can use @OverloadedLabels@ to write your labels. This can be convenient@@ -370,4 +407,4 @@ -- -- @since 0.0.1.0 instance (SymbolToField sym rec a) => IsLabel sym (Field rec a) where-  fromLabel = symbolToField @sym+    fromLabel = symbolToField @sym

@@ -2,12 +2,12 @@ -- -- @since 0.0.1.0 module Prairie.Diff-  ( module Prairie.Diff-  , module Prairie.Update-  ) where+    ( module Prairie.Diff+    , module Prairie.Update+    ) where -import Prairie.Update import Prairie.Class+import Prairie.Update  -- | Given two 'Record's, this function produces a list of 'Update's that -- can be performed on the first record such that it will equal the second.@@ -22,20 +22,19 @@ -- -- @since 0.0.1.0 diffRecord-  :: (Record rec, FieldDict Eq rec)-  => rec-  -- ^ The old record.-  -> rec-  -- ^ The new record.-  -> [Update rec]-diffRecord old new = foldMap go allFields+    :: (Record rec, FieldDict Eq rec)+    => rec+    -- ^ The old record.+    -> rec+    -- ^ The new record.+    -> [Update rec]+diffRecord old new = foldMap go allFieldsList   where     go (SomeField f) =-      withFieldDict @Eq f $-        let-          newVal = getRecordField f new-         in-          if getRecordField f old /= newVal-            then [SetField f newVal]-            else []-+        withFieldDict @Eq f $+            let+                newVal = getRecordField f new+             in+                if getRecordField f old /= newVal+                    then [SetField f newVal]+                    else []

@@ -0,0 +1,169 @@+-- |  This module provides an advanced functionality for working with+-- "Prairie" 'Record's. The 'Distributed' type wraps each field in a type+-- constructor, allowing you to work flexibly with 'Record's that are+-- construted and manipulated effectfully.+--+-- As an example, consider a @'Distributed' Parser rec@. This would be+-- similar to a @'Parser' rec@, but instead of producing a complete @rec@,+-- we actually have a field-wise 'Parser' - this allows us to access the+-- result of parsing a single field without requiring that all fields parse+-- correctly.+--+-- For another example, consider a @'Distributed' DB rec@. This would+-- describe a means of producing a @rec@ by describing how to produce each+-- 'Field' of that @rec@ using the @DB@ type - possibly by fetching the+-- appropriate row.+--+-- This module provides power equivalent to the @HKD@ design pattern, but+-- without requiring any complication to the underlying datatypes.+--+-- @since 0.1.0.0+module Prairie.Distributed where++import Data.Functor.Apply (Apply (..))+import Data.Functor.Const (Const (..))+import Data.Functor.Identity (Identity (..))+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text)+import GHC.Records+import Prairie.Class++-- | A @'Distributed' f rec@ is a 'Record' with fields that are wrapped in+-- the @f@ type constructor.+--+-- The simplest example is the trivial 'Identity' - @'Distributed'+-- 'Identity' rec@ wraps each field in 'Identity', which doesn't do+-- anything.+--+-- But you can also represent a @'Distributed' 'IO' rec@, where each field+-- is an 'IO' action.+--+-- This type is equivalently powerful to the @Higher Kinded Data@ pattern,+-- but significantly more flexible, since you don't need to munge the+-- underlying datatype with the complexity of this.+--+-- You can use @OverloadedRecordDot@ to access fields on this directly, or+-- you can also use 'getRecordFieldDistributed'.+--+-- @since 0.1.0.0+newtype Distributed f rec = Distributed (forall x. Field rec x -> f x)++-- |  This instance allows you to use the @OverloadedRecordDot@ with+-- distributed records.+--+-- @+-- data User = User { name :: String }+--+-- mkRecord ''User+--+-- userIO :: Distributed IO User+-- userIO = buildDistributed \\case+--     UserName -> getLine+--+-- main :: IO ()+-- main = do+--     userName <- userIO.name+--     putStrLn userName+-- @+--+-- @since 0.1.0.0+instance (SymbolToField sym rec typ) => HasField sym (Distributed f rec) (f typ) where+    getField = getRecordFieldDistributed (symbolToField @sym @rec @typ)++-- | Use a @'Field' rec ty@ to access that field in the @'Distributed' f rec@.+--+-- @since 0.1.0.0+getRecordFieldDistributed+    :: (Record rec) => Field rec ty -> Distributed f rec -> f ty+getRecordFieldDistributed field (Distributed k) =+    k field++-- | Given a function that specifies how to construct a field of a @record@+-- wrapped in a type @f@, this constructs a @'Distributed' f record@.+--+-- @since 0.1.0.0+buildDistributed+    :: forall f rec+     . (forall ty. Field rec ty -> f ty)+    -> Distributed f rec+buildDistributed k = Distributed k++-- | Takes a 'Record' and creates a pure 'Distributed' record over any+-- 'Applicative'.+--+-- @since 0.1.0.0+distribute+    :: forall f rec. (Applicative f, Record rec) => rec -> Distributed f rec+distribute rec = Distributed \field ->+    pure (getRecordField field rec)++-- | Like 'distribute', but the record is already wrapped in a 'Functor' f.+--+-- @since 0.1.0.0+distributeF :: (Functor f, Record rec) => f rec -> Distributed f rec+distributeF fRec = Distributed $ \field ->+    fmap (getRecordField field) fRec++-- | Remove the 'Distributed' wrapper, providing an @f rec@ that can be+-- used directly.+--+-- @since 0.1.0.0+sequenceDistributedA+    :: (Applicative f, Record rec)+    => Distributed f rec+    -> f rec+sequenceDistributedA (Distributed fn) = tabulateRecordA fn++-- | Like 'sequenceDistributedA', but works on the 'Apply' class, which+-- allows for semigroup-only construction.+--+-- @since 0.1.0.0+sequenceDistributedApply :: (Apply f, Record rec) => Distributed f rec -> f rec+sequenceDistributedApply (Distributed fn) = tabulateRecordApply fn++-- | This function allows you to combine the two type wrappers into+-- a third. This merges the two records based on how you combine their+-- merging functions.+--+-- @since 0.1.0.0+zipWithDistributed+    :: (forall x. f x -> g x -> h x)+    -> Distributed f rec+    -> Distributed g rec+    -> Distributed h rec+zipWithDistributed zipFn (Distributed lhs) (Distributed rhs) = Distributed $ \field ->+    zipFn (lhs field) (rhs field)++-- | An example use of this module. The functor @'Const' 'Text'@ here means+-- that each field value is ignored, and instead we have a 'Text' value in+-- place of that record.+--+-- @since 0.1.0.0+distributedRecordFieldNames :: (Record rec) => Distributed (Const Text) rec+distributedRecordFieldNames = buildConst recordFieldLabel++-- | If you've used 'buildConst' to convert all record fields into a single+-- type, then you can use 'distributedToSemigroup' to tag each value with+-- the field name that it came from.+--+-- @since 0.1.0.0+distributedToSemigroup+    :: (Record rec, forall a. Semigroup (f a), Applicative f)+    => Distributed (Const a) rec+    -> f (Text, a)+distributedToSemigroup rec =+    getConst $+        sequenceDistributedApply $+            zipWithDistributed+                (\(Const fieldName) (Const a) -> Const (pure (fieldName, a)))+                distributedRecordFieldNames+                rec++-- | Like 'buildDistributed' but it wraps the result in 'Const'. The result+-- is a @record@ but accessing the field is+--+-- @since 0.1.0.0+buildConst+    :: forall a rec. (forall x. Field rec x -> a) -> Distributed (Const a) rec+buildConst getValue =+    buildDistributed (Const . getValue)

@@ -9,8 +9,10 @@ module Prairie.Fold where  import Control.Monad (foldM)-import Prairie.Class+import Data.Foldable1 (foldMap1) import Data.List (foldl')+import Data.List.NonEmpty (NonEmpty)+import Prairie.Class  -- | A datatype containing a 'Field' along with a value for that field. --@@ -23,9 +25,29 @@ -- -- @since 0.0.3.0 recordToFieldList :: forall rec. (Record rec) => rec -> [SomeFieldWithValue rec]-recordToFieldList rec =+recordToFieldList = recordToFieldsWithValues++-- | Convert a 'Record' into a 'NonEmpty' list of the records fields paired with the+-- value for that record.+--+-- @since 0.0.3.0+recordToFieldListNonEmpty+    :: forall rec. (Record rec) => rec -> NonEmpty (SomeFieldWithValue rec)+recordToFieldListNonEmpty = recordToFieldsWithValues++-- | Like 'recordToFieldList', but works for any 'Applicative' that's also+-- a 'Semigroup' - this means you can use this at the @[]@ type of+-- 'NonEmpty'.+--+-- @since 0.1.0.0+recordToFieldsWithValues+    :: forall rec f+     . (Record rec, forall a. Semigroup (f a), Applicative f)+    => rec+    -> f (SomeFieldWithValue rec)+recordToFieldsWithValues rec =     fmap-        (\(SomeField field) ->+        ( \(SomeField field) ->             SomeFieldWithValue field (getRecordField field rec)         )         (allFields @rec)@@ -70,7 +92,7 @@     -> r foldRecord k init rec =     foldl'-        (\acc (SomeFieldWithValue field value) ->+        ( \acc (SomeFieldWithValue field value) ->             k value acc field         )         init@@ -88,21 +110,24 @@     -> m r foldMRecord k init rec =     foldM-        (\acc (SomeFieldWithValue field value) ->+        ( \acc (SomeFieldWithValue field value) ->             k value acc field         )         init         (recordToFieldList rec) --- | Convert each field of a 'Record' into a monoidal value and combine--- them together using 'mappend'.+-- | Convert each field of a 'Record' into a semigroup value and combine+-- them together using '(<>)'. --+-- As of @0.1.0.0@, this function was relaxed from a 'Monoid' constraint to+-- a 'Semigroup' constraint, allowing you to construct more types.+-- -- @since 0.0.3.0 foldMapRecord     :: forall rec m-    . (Record rec, Monoid m)+     . (Record rec, Semigroup m)     => (forall ty. ty -> Field rec ty -> m)     -> rec     -> m foldMapRecord k rec =-    foldMap (\(SomeFieldWithValue f v) -> k v f) (recordToFieldList rec)+    foldMap1 (\(SomeFieldWithValue f v) -> k v f) (recordToFieldListNonEmpty rec)

@@ -0,0 +1,25 @@+module Prairie.Internal where++import Control.Monad.Reader (MonadReader (..), asks)+import Data.Functor.Const (Const (..))+import Data.Functor.Identity (Identity (..))++type Getting r s a = (a -> Const r a) -> s -> Const r s++type ASetter s t a b = (a -> Identity b) -> s -> Identity t++type Lens s t a b = forall f. (Functor f) => (a -> f b) -> s -> f t++type Lens' s a = Lens s s a a++set :: ASetter s t a b -> b -> s -> t+set l b = runIdentity . l (\_ -> Identity b)+{-# INLINE set #-}++lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b+lens sa sbt afb s = sbt s <$> afb (sa s)+{-# INLINE lens #-}++view :: (MonadReader s m) => Getting a s a -> m a+view l = asks (getConst . l Const)+{-# INLINE view #-}

@@ -9,7 +9,8 @@ -- -- @since 0.0.4.0 appendRecord-    :: forall rec. (Record rec, FieldDict Semigroup rec)+    :: forall rec+     . (Record rec, FieldDict Semigroup rec)     => rec     -> rec     -> rec

@@ -1,19 +1,21 @@-{-# language CPP #-}+{-# LANGUAGE CPP #-}  -- | Helpers for generating instances of the 'Record' type class. -- -- @since 0.0.1.0 module Prairie.TH where -import Data.Constraint (Dict(..))-import Language.Haskell.TH-import Control.Lens (lens)+import Data.Char (toLower, toUpper)+import Data.Constraint (Dict (..))+import Data.Functor.Apply (Apply (..)) import qualified Data.List as List-import Data.Traversable (for)-import Data.Char (toUpper, toLower) import qualified Data.Text as Text+import Data.Traversable (for)+import GHC.Records (getField)+import Language.Haskell.TH  import Prairie.Class+import Prairie.Internal (lens)  -- | Create an instance of the 'Record' type class. --@@ -73,173 +75,209 @@ -- @since 0.0.1.0 mkRecord :: Name -> DecsQ mkRecord u = do-  ty <- reify u-  (typeName, con) <--    case ty of-      TyConI dec ->-        case dec of-          DataD _cxt name _tyvars _mkind [con] _derivs ->-            pure (name, con)-          NewtypeD _cxt name _tyvars _mkind con _derivs ->-            pure (name, con)-          _ ->-            fail "unsupported data structure"-      _ ->-        fail "unsupported type"--  let-    stripTypeName n =-      let-        typeNamePrefix =-          lowerFirst (nameBase typeName)-       in-        case List.stripPrefix typeNamePrefix (nameBase n) of-          Just xs -> mkName (lowerFirst xs)-          Nothing -> n+    ty <- reify u+    (typeName, con) <-+        case ty of+            TyConI dec ->+                case dec of+                    DataD _cxt name _tyvars _mkind [con] _derivs ->+                        pure (name, con)+                    NewtypeD _cxt name _tyvars _mkind con _derivs ->+                        pure (name, con)+                    _ ->+                        fail "unsupported data structure"+            _ ->+                fail "unsupported type" -  (recordCon, names'types) <--    case con of-      RecC conName varBangTypes ->-        pure $ (conName, map (\(n, _b, t) -> (n, t)) varBangTypes)-      _ ->-        fail "only supports records"+    let+        stripTypeName n =+            let+                typeNamePrefix =+                    lowerFirst (nameBase typeName)+             in+                case List.stripPrefix typeNamePrefix (nameBase n) of+                    Just xs -> mkName (lowerFirst xs)+                    Nothing -> n -  let-    mkConstrFieldName fieldName =-      mkName (nameBase typeName <> upperFirst (nameBase (stripTypeName fieldName)))+    (recordCon, names'types) <-+        case con of+            RecC conName varBangTypes -> do+                case varBangTypes of+                    [] ->+                        reportError "Prairie records must have at least one field."+                    _ ->+                        pure ()+                pure $ (conName, map (\(n, _b, t) -> (n, t)) varBangTypes)+            _ ->+                fail "only supports records" -  fieldLensClause <- do-    arg <- newName "field"     let-      mkMatch (fieldName, _typ) = do-        recVar <- newName "rec"-        newVal <- newName "newVal"+        mkConstrFieldName fieldName =+            mkName (nameBase typeName <> upperFirst (nameBase (stripTypeName fieldName))) -        pure $-          Match-            (compatConP (mkConstrFieldName fieldName))-            (NormalB $-            VarE 'lens-            `AppE` VarE fieldName-            `AppE`-              LamE [VarP recVar, VarP newVal]-                (RecUpdE (VarE recVar) [(fieldName, VarE newVal)])-            )-            []-    body <- CaseE (VarE arg) <$> traverse mkMatch names'types-    pure $ Clause [VarP arg] (NormalB body) []-  let-    recordFieldLensDec =-      FunD 'recordFieldLens [fieldLensClause]-    fieldConstructors =-      map (\(n, t) -> (mkConstrFieldName n, t)) names'types+    fieldLensClause <- do+        arg <- newName "field"+        let+            mkMatch (fieldName, _typ) = do+                recVar <- newName "rec"+                newVal <- newName "newVal" -  mkTabulateRecord <- do-    fromFieldName <- newName "fromField"-    let body =-            List.foldl'-                (\acc (n, _) ->-                    VarE '(<*>)-                        `AppE` acc-                        `AppE` (VarE fromFieldName `AppE` ConE (mkConstrFieldName n))-                )-                (VarE 'pure `AppE` ConE recordCon)-                names'types+                pure $+                    Match+                        (compatConP (mkConstrFieldName fieldName))+                        ( NormalB $+                            VarE 'lens+                                `AppE` (VarE 'getField `AppTypeE` LitT (StrTyLit (nameBase fieldName)))+                                `AppE` LamE+                                    [VarP recVar, VarP newVal]+                                    ( SigE+                                        (RecUpdE (VarE recVar) [(fieldName, VarE newVal)])+                                        (ConT typeName)+                                    )+                        )+                        []+        body <- CaseE (VarE arg) <$> traverse mkMatch names'types+        pure $ Clause [VarP arg] (NormalB body) []+    let+        recordFieldLensDec =+            FunD 'recordFieldLens [fieldLensClause]+        fieldConstructors =+            map (\(n, t) -> (mkConstrFieldName n, t)) names'types -    pure $-      FunD 'tabulateRecordA-        [ Clause [VarP fromFieldName] (NormalB body) []-        ]+    mkTabulateRecord <- do+        fromFieldName <- newName "fromField"+        let+            body =+                List.foldl'+                    ( \acc (n, _) ->+                        VarE '(<*>)+                            `AppE` acc+                            `AppE` (VarE fromFieldName `AppE` ConE (mkConstrFieldName n))+                    )+                    (VarE 'pure `AppE` ConE recordCon)+                    names'types -  mkRecordFieldLabel <- do-    fieldName <- newName "fieldName"-    body <- pure $-      CaseE (VarE fieldName)  $-        flip map names'types $ \(n, _) ->-          let-            constrFieldName =-              mkConstrFieldName n-            pat =-                compatConP constrFieldName-            bdy =-              AppE (VarE 'Text.pack) $ LitE $ StringL $ nameBase $ stripTypeName n+        pure $+            FunD+                'tabulateRecordA+                [ Clause [VarP fromFieldName] (NormalB body) []+                ] -           in-            Match pat (NormalB bdy)  []-    pure $-      FunD 'recordFieldLabel-        [ Clause [VarP fieldName] (NormalB body) []-        ]+    mkTabulateRecordApply <- do+        fromFieldName <- newName "fromField"+        let+            body =+                fst $+                    List.foldl'+                        ( \(acc, op) fromField ->+                            ( InfixE (Just acc) op (Just fromField)+                            , VarE '(<.>)+                            )+                        )+                        (ConE recordCon, VarE '(<$>))+                        fromFieldNames+            fromFieldNames =+                map (AppE (VarE fromFieldName) . ConE . mkConstrFieldName . fst) names'types -  let-    fieldConstrs =-      map mkFieldConstr fieldConstructors-    mkFieldConstr (fieldName, typ) =-      GadtC-        [ fieldName-        ]-        []-        (ConT ''Field `AppT` ConT typeName `AppT` typ)+        pure $+            FunD+                'tabulateRecordApply+                [ Clause [VarP fromFieldName] (NormalB body) []+                ] -    recordInstance =-      InstanceD-        Nothing-        []-        (ConT ''Record `AppT` ConT typeName)-        (-          [ DataInstD-              []-              Nothing-              (ConT ''Field `AppT` ConT typeName `AppT` VarT (mkName "a"))-              Nothing-              fieldConstrs-              []-          , recordFieldLensDec-          , mkTabulateRecord-          , mkRecordFieldLabel-          ]-        )+    mkRecordFieldLabel <- do+        fieldName <- newName "fieldName"+        body <- pure $+            CaseE (VarE fieldName) $+                flip map names'types $ \(n, _) ->+                    let+                        constrFieldName =+                            mkConstrFieldName n+                        pat =+                            compatConP constrFieldName+                        bdy =+                            AppE (VarE 'Text.pack) $ LitE $ StringL $ nameBase $ stripTypeName n+                     in+                        Match pat (NormalB bdy) []+        pure $+            FunD+                'recordFieldLabel+                [ Clause [VarP fieldName] (NormalB body) []+                ] -  fieldDictInstance <- do-    constraintVar <- newName "c"-    fieldVar <- newName "field"     let-      allFieldsC =-        map (VarT constraintVar `AppT`) (map snd names'types)-      fieldDictDecl =-        [ FunD 'getFieldDict [Clause [VarP fieldVar] (NormalB fieldDictBody) []]-        ]-      fieldDictBody =-        CaseE (VarE fieldVar) $ map mkFieldDictMatches fieldConstructors-      mkFieldDictMatches (name, _type) =-        Match (compatConP name) (NormalB (ConE 'Dict)) []+        fieldConstrs =+            map mkFieldConstr fieldConstructors+        mkFieldConstr (fieldName, typ) =+            GadtC+                [ fieldName+                ]+                []+                (ConT ''Field `AppT` ConT typeName `AppT` typ) -    pure $-      InstanceD-        Nothing -- maybe overlap-        allFieldsC-        (ConT ''FieldDict `AppT` VarT constraintVar `AppT` ConT typeName)-        fieldDictDecl+        recordInstance =+            InstanceD+                Nothing+                []+                (ConT ''Record `AppT` ConT typeName)+                ( [ DataInstD+                        []+                        Nothing+                        (ConT ''Field `AppT` ConT typeName `AppT` VarT (mkName "_"))+                        Nothing+                        fieldConstrs+                        []+                  , recordFieldLensDec+                  , mkTabulateRecord+                  , mkTabulateRecordApply+                  , mkRecordFieldLabel+                  ]+                ) -  symbolToFieldInstances <--    fmap concat $ for names'types $ \(fieldName, typ) -> do-      [d|-        instance SymbolToField $(litT (strTyLit (nameBase fieldName))) $(conT typeName) $(pure typ) where-          symbolToField = $(conE (mkConstrFieldName fieldName))-        |]+    fieldDictInstance <- do+        constraintVar <- newName "c"+        fieldVar <- newName "field"+        let+            allFieldsC =+                map (VarT constraintVar `AppT`) (map snd names'types)+            fieldDictDecl =+                [ FunD 'getFieldDict [Clause [VarP fieldVar] (NormalB fieldDictBody) []]+                ]+            fieldDictBody =+                CaseE (VarE fieldVar) $ map mkFieldDictMatches fieldConstructors+            mkFieldDictMatches (name, _type) =+                Match (compatConP name) (NormalB (ConE 'Dict)) [] -  pure $-    [ recordInstance-    , fieldDictInstance-    ]-    ++-      symbolToFieldInstances+        pure $+            InstanceD+                Nothing -- maybe overlap+                allFieldsC+                (ConT ''FieldDict `AppT` VarT constraintVar `AppT` ConT typeName)+                fieldDictDecl +    symbolToFieldInstances <-+        fmap concat $ for names'types $ \(fieldName, typ) -> do+            [d|+                instance+                    SymbolToField+                        $(litT (strTyLit (nameBase fieldName)))+                        $(conT typeName)+                        $(pure typ)+                    where+                    symbolToField = $(conE (mkConstrFieldName fieldName))+                |]++    pure $+        [ recordInstance+        , fieldDictInstance+        ]+            ++ symbolToFieldInstances+ overFirst :: (Char -> Char) -> String -> String overFirst f str =-  case str of-    [] -> []-    (c:cs) -> f c : cs+    case str of+        [] -> []+        (c : cs) -> f c : cs  upperFirst, lowerFirst :: String -> String upperFirst = overFirst toUpper

@@ -4,9 +4,10 @@ -- @since 0.0.3.0 module Prairie.Traverse where +import Control.Applicative (liftA2)+import Data.Foldable (traverse_) import Data.List (foldl') import Prairie.Class-import Control.Applicative (liftA2) import Prairie.Fold  -- | Apply an effectful function over each field of a 'Record', producing@@ -49,7 +50,8 @@ -- -- @since 0.0.3.0 traverseRecord-    :: forall rec f. (Record rec, Applicative f)+    :: forall rec f+     . (Record rec, Applicative f)     => (forall ty. ty -> Field rec ty -> f ty)     -> rec     -> f rec@@ -64,3 +66,86 @@             (\(SomeFieldWithValue field' val') rec -> setRecordField field' val' rec)             (f' field val)             frec++-- | Like 'traverseRecord', but throws away it's result. This is slightly+-- more efficient than @'void' $ 'traverseRecord' f@.+--+-- @since 0.1.0.0+traverseRecord_+    :: forall rec f+     . (Record rec, Applicative f)+    => (forall ty. ty -> Field rec ty -> f ())+    -> rec+    -> f ()+traverseRecord_ f init =+    traverse_+        (\(SomeFieldWithValue field val) -> f val field)+        (recordToFieldList init)++-- | This function produces a container resulting from running the given+-- function on every field of a record.+--+-- @since 0.1.0.0+traverseFields+    :: forall rec m f a+     . ( Record rec+       , Applicative m+       , forall x. Semigroup (f x)+       , Traversable f+       , Applicative f+       )+    => (forall ty. Field rec ty -> m a)+    -> m (f a)+traverseFields k =+    traverse (\(SomeField f) -> k f) (allFields @rec)++-- | Like 'traverseFields', but just runs the given action on every field.+-- Does not return any values, so only useful for enumerating side-effects.+--+-- @since 0.1.0.0+traverseFields_+    :: forall rec m+     . (Record rec, Applicative m)+    => (forall ty. Field rec ty -> m ())+    -> m ()+traverseFields_ f =+    traverse_ (\(SomeField field) -> f field) (allFields @rec @[])++-- | Collect results of running the provided callback over each field, with+-- a specific constraint being allowed on each field. Allows you to operate+-- somewhat generically over the record fields.+--+-- @since 0.1.0.0+traverseFieldsWithDict+    :: forall r c f t a+     . ( FieldDict c r+       , Applicative f+       , forall a. Semigroup (t a)+       , Applicative t+       , Traversable t+       )+    => (forall x. (c x) => Field r x -> f a)+    -> f (t a)+traverseFieldsWithDict f =+    traverse+        ( (\(SomeField field) -> withFieldDict @c @r field (f field))+            :: SomeField r -> f a+        )+        allFields++-- | Lke 'traverseFieldsWithDict', but throws away the result values.+-- Useful when you want to enumerate all fields and perform+-- a side-effecting function for each field.+--+-- @since 0.1.0.0+traverseFieldsWithDict_+    :: forall r c f+     . (FieldDict c r, Applicative f)+    => (forall x. (c x) => Field r x -> f ())+    -> f ()+traverseFieldsWithDict_ f =+    traverse_+        ( (\(SomeField field) -> withFieldDict @c @r field (f field))+            :: SomeField r -> f ()+        )+        (allFields @r @[])

@@ -3,11 +3,11 @@ -- @since 0.0.1.0 module Prairie.Update where -import Data.Aeson (ToJSON(..), FromJSON(..), object, withObject, (.:), (.=))-import Control.Lens (set)-import Data.Typeable (Typeable, (:~:)(..), eqT)+import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=))+import Data.Typeable (Typeable, eqT, (:~:) (..))  import Prairie.Class+import Prairie.Internal (set)  -- | An operation representing an update against the 'rec' in question. --@@ -16,33 +16,36 @@ -- -- @since 0.0.1.0 data Update rec where-  SetField :: Field rec a -> a -> Update rec+    SetField :: Field rec a -> a -> Update rec  -- | -- -- @since 0.0.1.0-instance (forall a. Eq (Field rec a), FieldDict Typeable rec, FieldDict Eq rec) => Eq (Update rec) where-  SetField f0 (a0 :: a0) == SetField f1 (a1 :: a1) =-    withFieldDict @Typeable f0 $-    withFieldDict @Typeable f1 $-    case eqT @a0 @a1 of-      Nothing ->-        False-      Just Refl ->-        withFieldDict @Eq f0 $-        f0 == f1 && a0 == a1+instance+    (forall a. Eq (Field rec a), FieldDict Typeable rec, FieldDict Eq rec)+    => Eq (Update rec)+    where+    SetField f0 (a0 :: a0) == SetField f1 (a1 :: a1) =+        withFieldDict @Typeable f0 $+            withFieldDict @Typeable f1 $+                case eqT @a0 @a1 of+                    Nothing ->+                        False+                    Just Refl ->+                        withFieldDict @Eq f0 $+                            f0 == f1 && a0 == a1  -- | -- -- @since 0.0.1.0 instance (forall a. Show (Field rec a), FieldDict Show rec) => Show (Update rec) where-  showsPrec d (SetField field a) =-    withFieldDict @Show field $-      showParen (d > 10)-        $ showString "Update "-        . showsPrec 11 field-        . showString " "-        . showsPrec 11 a+    showsPrec d (SetField field a) =+        withFieldDict @Show field $+            showParen (d > 10) $+                showString "Update "+                    . showsPrec 11 field+                    . showString " "+                    . showsPrec 11 a  -- |  Renders an 'Update' in the following format: --@@ -56,9 +59,9 @@ -- -- @since 0.0.1.0 instance (FieldDict ToJSON rec, forall a. ToJSON (Field rec a)) => ToJSON (Update rec) where-  toJSON (SetField field newVal) =-    withFieldDict @ToJSON field $-      object [ "field" .= field, "value" .= newVal ]+    toJSON (SetField field newVal) =+        withFieldDict @ToJSON field $+            object ["field" .= field, "value" .= newVal]  -- | Parses an 'Update' with the following format: --@@ -71,13 +74,16 @@ -- -- -- @since 0.0.1.0-instance (FieldDict FromJSON  rec, FieldDict Typeable rec, FromJSON (SomeField rec)) => FromJSON (Update rec) where-  parseJSON = withObject "Update" $ \o -> do-    field <- o .: "field"-    case field of-      SomeField field ->-        withFieldDict @FromJSON field $-          SetField field <$> o .: "value"+instance+    (FieldDict FromJSON rec, FieldDict Typeable rec, FromJSON (SomeField rec))+    => FromJSON (Update rec)+    where+    parseJSON = withObject "Update" $ \o -> do+        field <- o .: "field"+        case field of+            SomeField field ->+                withFieldDict @FromJSON field $+                    SetField field <$> o .: "value"  -- | Run an 'Update' against the record it is for. --@@ -88,12 +94,12 @@ -- @ -- -- @since 0.0.1.0-updateSingleField :: Record rec => Update rec -> rec -> rec+updateSingleField :: (Record rec) => Update rec -> rec -> rec updateSingleField (SetField field newValue) rec =-  set (recordFieldLens field) newValue rec+    set (recordFieldLens field) newValue rec  -- | Perform an list of updates against the 'Record'. -- -- @since 0.0.1.0-updateRecord :: Record rec => [Update rec] -> rec -> rec+updateRecord :: (Record rec) => [Update rec] -> rec -> rec updateRecord upds rec = foldr updateSingleField rec upds

@@ -20,7 +20,8 @@ -- -- @since 0.0.4.0 zipWithRecord-    :: forall rec. (Record rec)+    :: forall rec+     . (Record rec)     => (forall ty. ty -> ty -> Field rec ty -> ty)     -> rec     -> rec@@ -28,7 +29,9 @@ 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+    f :: ty -> rec -> Field rec ty -> rec+    f v0 rec field =+        let+            v1 = getRecordField field r1+         in+            setRecordField field (k v0 v1 field) rec

@@ -0,0 +1,22 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Prairie.DuplicateFieldSpec where++import Prairie++data User = User {name :: String}++mkRecord ''User++data Dog = Dog {name :: String}++mkRecord ''Dog

@@ -0,0 +1,27 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++#if MIN_VERSION_base(4,16,0)+{-# LANGUAGE NoFieldSelectors #-}+#endif++module Prairie.NoFieldSelectorSpec where++import Prairie++data User = User {name :: String}++mkRecord ''User++data Dog = Dog {name :: String}++mkRecord ''Dog

@@ -18,30 +18,30 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}--{-# options_ghc -Wall #-}+{-# OPTIONS_GHC -Wall -Werror=unused-type-patterns #-}  module Main where  import Prairie -import Control.Lens+import Control.Lens hiding ((<.>)) import Control.Monad import Data.Aeson-import Data.Kind (Type)+import Data.Functor.Apply (Apply (..))+import Data.List.NonEmpty (NonEmpty (..)) import Data.Monoid-import GHC.Records import Prairie.AsRecord import Test.Hspec -data User = User { name :: String, age :: Int }-  deriving (Show, Eq)+data User = User {name :: String, age :: Int}+    deriving (Show, Eq)  mkRecord ''User  deriving instance Eq (Field User a) deriving instance Show (Field User a) +exampleUser :: User exampleUser = User "Alice" 30  data Foo = Foo@@ -55,86 +55,79 @@ deriving via AsRecord Foo instance Semigroup Foo deriving via AsRecord Foo instance Monoid Foo -data T a = T { x :: a, y :: Int }+data T a = T {x :: a, y :: Int}  instance Record (T a) where-    data Field (T a) t where+    data Field (T a) _ where         TX :: Field (T a) a         TY :: Field (T a) Int      recordFieldLens = \case-        TX -> lens x (\o n -> o { x = n })-        TY -> lens y (\o n -> o { y = n })+        TX -> lens x (\o n -> o{x = n})+        TY -> lens y (\o n -> o{y = n})      tabulateRecordA f = T <$> f TX <*> f TY +    tabulateRecordApply f = (T <$> f TX) <.> f TY+     recordFieldLabel = \case         TX -> "TX"         TY -> "TY" --class PolyLens t where-    polyLens :: (forall x. Field (t x) x) -> Lens (t a) (t b) a b--instance PolyLens T where-    polyLens = \case-        TX -> lens x (\o n -> o { x = n }) :: Lens (T a) (T b) a b--type family FieldLens (a :: Type) (p :: Type) (f :: Type -> Type) where-    FieldLens (Field (t x) x) y f = LensLike f (t x) (t y) x y-    FieldLens (Field (t x) y) y f = LensLike f (t x) (t x) y y- main :: IO () main = hspec $ do     describe "Prairie" $ do         it "getField" $ do             getRecordField UserName exampleUser `shouldBe` "Alice"         it "setField" $ do-            setRecordField UserAge 32 exampleUser `shouldBe` User { name = "Alice", age = 32 }+            setRecordField UserAge 32 exampleUser+                `shouldBe` User{name = "Alice", age = 32}         it "label" $ do             recordFieldLabel UserAge `shouldBe` "age"         it "label" $ do             recordFieldLabel UserName `shouldBe` "name" -        let t :: T Int-            t = T 3 2--            t' :: T Char-            t' = t & polyLens TX .~ 'a'-         it "update json" $             encode (diffRecord exampleUser (setRecordField UserName "Bob" exampleUser))-            `shouldBe`-            "[{\"field\":\"name\",\"value\":\"Bob\"}]"+                `shouldBe` "[{\"field\":\"name\",\"value\":\"Bob\"}]"          it "decode update" $-          decode "[{\"field\":\"name\",\"value\":\"Bob\"}]"-          `shouldBe`-          Just [SetField UserName "Bob"]+            decode "[{\"field\":\"name\",\"value\":\"Bob\"}]"+                `shouldBe` Just [SetField UserName "Bob"]          it "tabulateRecordA" $ do             user' <--              tabulateRecordA $ \case-                  UserName ->-                      print 10 >> pure "Matt"-                  UserAge ->-                      print 20 >> pure 33+                tabulateRecordA $ \case+                    UserName ->+                        print @Int 10 >> pure "Matt"+                    UserAge ->+                        print @Int 20 >> pure 33             user'-                `shouldBe`-                User+                `shouldBe` User                     { name = "Matt"                     , age = 33                     } +        it "tabulateRecordApply" do+            user' <-+                tabulateRecordApply $ \case+                    UserName ->+                        print (10 :: Int) >> pure "Matt"+                    UserAge ->+                        print (20 :: Int) >> pure 33+            user'+                `shouldBe` User+                    { name = "Matt"+                    , age = 33+                    }         describe "Fold" $ do             describe "foldRecord" $ do                 it "can count the fields" $ do                     foldRecord (\_val acc _field -> acc + 1) 0 exampleUser-                        `shouldBe`-                            2+                        `shouldBe` (2 :: Int)                 it "can distinguish fields" $ do                     foldRecord-                        (\val acc field ->+                        ( \val acc field ->                             case field of                                 UserName ->                                     length val + acc@@ -143,28 +136,29 @@                         )                         (0 :: Int)                         exampleUser-                        `shouldBe`-                            35+                        `shouldBe` 35              describe "foldMapRecord" $ do+                it "can make a nonempty list" $ do+                    foldMapRecord (\_ _ -> pure 'a') exampleUser+                        `shouldBe` ('a' :| "a")                 it "can count the fields" $ do                     foldMapRecord (\_ _ -> Sum 1) exampleUser-                        `shouldBe`-                            Sum 2+                        `shouldBe` Sum (2 :: Integer)                 it "can combine strings" $ do                     foldMapRecord-                        (\val ->+                        ( \val ->                             \case                                 UserName -> val                                 UserAge -> show val                         )                         exampleUser-                        `shouldBe`-                            ("Alice30" :: String)+                        `shouldBe` ("Alice30" :: String)          describe "Traverse" $ do             it "can validate a record" $ do-                let validateField :: ty -> Field User ty -> Maybe ty+                let+                    validateField :: ty -> Field User ty -> Maybe ty                     validateField val =                         \case                             UserName -> do@@ -174,16 +168,14 @@                                 guard (val >= 18)                                 pure val                 traverseRecord validateField exampleUser-                    `shouldBe`-                        Just User { name = "Alice", age = 30 }--                traverseRecord validateField User { name = "", age = 1 }-                    `shouldBe`-                        Nothing+                    `shouldBe` Just User{name = "Alice", age = 30} +                traverseRecord validateField User{name = "", age = 1}+                    `shouldBe` Nothing              it "can do either" $ do-                let validateField :: ty -> Field User ty -> Either String ty+                let+                    validateField :: ty -> Field User ty -> Either String ty                     validateField val =                         \case                             UserName -> do@@ -196,16 +188,14 @@                                     else Left "Age must be at least 18"                  traverseRecord validateField exampleUser-                    `shouldBe`-                        Right User { name = "Alice", age = 30 }+                    `shouldBe` Right User{name = "Alice", age = 30} -                traverseRecord validateField User { name = "", age = 1 }-                    `shouldBe`-                        Left "Age must be at least 18"+                traverseRecord validateField User{name = "", age = 1}+                    `shouldBe` Left "Age must be at least 18"              it "can target one field" $ do                 traverseRecord-                    (\val ->+                    ( \val ->                         \case                             UserName -> do                                 guard (length val >= 1)@@ -213,34 +203,36 @@                             _ ->                                 pure val                     )-                    User { name = "", age = 30 }-                    `shouldBe`-                        Nothing+                    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'))+                let+                    f0 = Foo [1] (First Nothing)+                    f1 = Foo [2, 3] (First (Just 'a'))                 f0 <> f1-                    `shouldBe`-                        Foo [1,2,3] (First (Just 'a'))+                    `shouldBe` Foo [1, 2, 3] (First (Just 'a'))          describe "Monoid" do             it "can produce an empty record" do-                let obvious =+                let+                    obvious =                         Foo mempty mempty                 mempty `shouldBe` obvious          describe "Zip" do             it "can combine two records" do-                let u0 = User "Matt" 35+                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)-+                zipWithRecord+                    ( \a b -> \case+                        UserName ->+                            a <> b+                        UserAge ->+                            a + b+                    )+                    u0+                    u1+                    `shouldBe` User "MattttaM" (35 + 53)