diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain 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.4.0 +version: 0.1.0.0 description: Please see the README on GitHub at 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 diff --git a/src/Prairie.hs b/src/Prairie.hs --- a/src/Prairie.hs +++ b/src/Prairie.hs @@ -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 diff --git a/src/Prairie/AsRecord.hs b/src/Prairie/AsRecord.hs --- a/src/Prairie/AsRecord.hs +++ b/src/Prairie/AsRecord.hs @@ -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 diff --git a/src/Prairie/Class.hs b/src/Prairie/Class.hs --- a/src/Prairie/Class.hs +++ b/src/Prairie/Class.hs @@ -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 diff --git a/src/Prairie/Diff.hs b/src/Prairie/Diff.hs --- a/src/Prairie/Diff.hs +++ b/src/Prairie/Diff.hs @@ -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 [] diff --git a/src/Prairie/Distributed.hs b/src/Prairie/Distributed.hs new file mode 100644 --- /dev/null +++ b/src/Prairie/Distributed.hs @@ -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) diff --git a/src/Prairie/Fold.hs b/src/Prairie/Fold.hs --- a/src/Prairie/Fold.hs +++ b/src/Prairie/Fold.hs @@ -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) diff --git a/src/Prairie/Internal.hs b/src/Prairie/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Prairie/Internal.hs @@ -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 #-} diff --git a/src/Prairie/Semigroup.hs b/src/Prairie/Semigroup.hs --- a/src/Prairie/Semigroup.hs +++ b/src/Prairie/Semigroup.hs @@ -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 diff --git a/src/Prairie/TH.hs b/src/Prairie/TH.hs --- a/src/Prairie/TH.hs +++ b/src/Prairie/TH.hs @@ -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 diff --git a/src/Prairie/Traverse.hs b/src/Prairie/Traverse.hs --- a/src/Prairie/Traverse.hs +++ b/src/Prairie/Traverse.hs @@ -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 @[]) diff --git a/src/Prairie/Update.hs b/src/Prairie/Update.hs --- a/src/Prairie/Update.hs +++ b/src/Prairie/Update.hs @@ -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 diff --git a/src/Prairie/Zip.hs b/src/Prairie/Zip.hs --- a/src/Prairie/Zip.hs +++ b/src/Prairie/Zip.hs @@ -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 diff --git a/test/Prairie/DuplicateFieldSpec.hs b/test/Prairie/DuplicateFieldSpec.hs new file mode 100644 --- /dev/null +++ b/test/Prairie/DuplicateFieldSpec.hs @@ -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 diff --git a/test/Prairie/NoFieldSelectorSpec.hs b/test/Prairie/NoFieldSelectorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Prairie/NoFieldSelectorSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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)