diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for prairie + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# prairie + +[![Build Status](https://travis-ci.org/parsonsmatt/prairie.svg?branch=main)](https://travis-ci.org/parsonsmatt/prairie) + +A library for first class record fields. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/prairie.cabal b/prairie.cabal new file mode 100644 --- /dev/null +++ b/prairie.cabal @@ -0,0 +1,89 @@ +cabal-version: 1.12 + +name: prairie +version: 0.0.1.0 +description: Please see the README on GitHub at +homepage: https://github.com/parsonsmatt/prairie#readme +bug-reports: https://github.com/parsonsmatt/prairie/issues +author: Matt Parsons +maintainer: parsonsmatt@gmail.com +copyright: 2020 Matt Parsons +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md +synopsis: A first class record field library +category: Data + +source-repository head + type: git + location: https://github.com/parsonsmatt/prairie + +library + exposed-modules: + Prairie + Prairie.Class + Prairie.Update + Prairie.Diff + Prairie.TH + + build-depends: + base >= 4.13 && < 5 + , aeson + , constraints + , containers + , lens + , template-haskell >= 2.15 && < 2.17 + , text + + other-modules: + Paths_prairie + hs-source-dirs: + src + default-language: Haskell2010 + + default-extensions: + AllowAmbiguousTypes + BlockArguments + DataKinds + DefaultSignatures + DeriveGeneric + DerivingStrategies + ExplicitForAll + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + KindSignatures + MultiParamTypeClasses + NamedFieldPuns + NoStarIsType + OverloadedStrings + QuantifiedConstraints + RankNTypes + RecordWildCards + ScopedTypeVariables + TemplateHaskell + TypeApplications + TypeFamilies + TypeOperators + StandaloneDeriving + UndecidableInstances + ConstraintKinds + ViewPatterns + +test-suite prairie-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_prairie + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , prairie + , aeson + default-language: Haskell2010 diff --git a/src/Prairie.hs b/src/Prairie.hs new file mode 100644 --- /dev/null +++ b/src/Prairie.hs @@ -0,0 +1,14 @@ +-- | A library for first-class record fields. +-- +-- @since 0.0.1.0 +module Prairie + ( module Prairie.Class + , module Prairie.Update + , module Prairie.Diff + , module Prairie.TH + ) where + +import Prairie.Class +import Prairie.Update +import Prairie.Diff +import Prairie.TH diff --git a/src/Prairie/Class.hs b/src/Prairie/Class.hs new file mode 100644 --- /dev/null +++ b/src/Prairie/Class.hs @@ -0,0 +1,353 @@ +-- | This module defines the type class 'Record' which enables much of the +-- functionality of the library. You can define instances of this record +-- manually, or you may use the @TemplateHaskell@ deriving function in +-- "Prairie.TH". +-- +-- We'll use an example type @User@ throughout the documentation in this +-- module. +-- +-- @ +-- data User = User +-- { name :: String +-- , age :: Int +-- } +-- @ +-- +-- @since 0.0.1.0 +module Prairie.Class where + +import Control.Lens (Lens', set, view) +import Data.Aeson (ToJSON(..), FromJSON(..), withText) +import Data.Constraint (Dict(..)) +import Data.Kind (Constraint, Type) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) +import Data.Typeable ((:~:)(..), Typeable, eqT) +import GHC.OverloadedLabels (IsLabel(..)) +import GHC.TypeLits (Symbol) + +-- | 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. +-- +-- @since 0.0.1.0 +class Record rec where + -- | A datatype representing fields on the record. + -- + -- This will be a @GADT@ with one constructor for each record field. By + -- convention, it's best to name the constructors as with the type name + -- leading and the field name following. This convention prevents any + -- possible conflicts from different instances of 'Field'. + -- + -- Using our example type @User@, we would define this as: + -- + -- @ + -- data Field User ty where + -- UserName :: Field User String + -- UserAge :: Field User Int + -- @ + -- + -- Now, we have a value @UserName@ that corresponds with the @name@ field + -- on a @User@. The type of @User@ and @name@ are interesting to compare: + -- + -- @ + -- UserName :: Field User String + -- name :: User -> String + -- @ + -- + -- @since 0.0.1.0 + data Field rec :: Type -> Type + + -- | Given a 'Field' on the record, this function acts as a 'Lens'' into + -- the record. This allows you to use a 'Field' as a getter or setter. + -- + -- An example implementation for our 'User' type might look like this: + -- + -- @ + -- recordFieldLens field = + -- case field of + -- UserName -> + -- 'lens' name (\\u n -> u { name = n }) + -- UserAge -> + -- 'lens' age (\\u a -> u { age = a }) + -- @ + -- + -- If you have derived lenses (either from Template Haskell or + -- @generic-lens@, then you can provide those directly. + -- + -- @since 0.0.1.0 + recordFieldLens :: Field rec ty -> Lens' rec ty + + -- | An enumeration of fields on the record. + -- + -- This value uses the 'SomeField' existential wrapper, which allows + -- 'Field's containing different types to be in the same list. + -- + -- Our @User@ example would have this implementation: + -- + -- @ + -- allFields = [SomeField UserAge, SomeField UserName] + -- @ + -- + -- @since 0.0.1.0 + allFields :: [SomeField rec] + + -- | This function allows you to construct a 'Record' by providing + -- a value for each 'Field' on the record. + -- + -- Our @User@ would have an implementation like this: + -- + -- @ + -- tabulateRecord fromField = + -- User + -- { name = fromField UserName + -- , age = fromField UserAge + -- } + -- @ + -- + -- @since 0.0.1.0 + tabulateRecord :: (forall ty. Field rec ty -> ty) -> rec + + -- | Assign a 'Text' label for a record 'Field'. + -- + -- This allows 'Field's to be converted to 'Text', which is useful for + -- serialization concerns. For derserializing a 'Field', consider using + -- @'fieldMap' :: 'Map' 'Text' ('SomeField' rec)@. + -- + -- @since 0.0.1.0 + recordFieldLabel :: Field rec ty -> Text + +-- | 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 = + foldMap + (\sf@(SomeField f) -> Map.singleton (recordFieldLabel f) sf) + allFields + +-- | 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 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 f = set (recordFieldLens f) + +-- | An existential wrapper on a 'Field'. This hides the type of the value +-- of the field. This wrapper allows you to have a collection of 'Field's +-- for a record, or to have useful instances for classes like 'Eq' where +-- the type of the values being compared must be the same. +-- +-- @since 0.0.1.0 +data SomeField rec where + SomeField :: Field rec a -> SomeField rec + +-- | You can write a standalone deriving instance for 'Field': +-- +-- @ +-- deriving stock instance 'Show' ('Field' User a) +-- @ +-- +-- This instance is derived, so it'll result in: +-- +-- @ +-- >>> show (SomeField UserAge) +-- SomeField UserAge +-- @ +-- +-- @since 0.0.1.0 +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 + +-- | 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 + +-- | 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" + +-- | This delegates to 'recordFieldLabel' from the 'Record' class. +-- +-- @since 0.0.1.0 +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" + +-- | 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 +-- fields of a record satisfy some type class instance. +-- +-- For example, suppose we want to write a generic logging utility for all +-- records where all fields on the record is loggable. +-- +-- @ +-- class Loggable a where +-- toLog :: a -> LogMessage +-- @ +-- +-- We can implement a function based on 'Record' to log it: +-- +-- @ +-- logRecord :: (FieldDict Loggable rec) => rec -> LogMessage +-- logRecord record = foldMap go 'allFields' +-- where +-- go ('SomeField' field) = +-- 'withFieldDict' @Loggable $ +-- toLog ('getRecordField' field record) +-- @ +-- +-- The second parameter to 'withFieldDict' will have the instance of +-- 'Loggable a' in scope. +-- +-- You can define instances polymorphic in the constraint with the +-- @ConstraintKinds@ language extension. +-- +-- @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) + +-- | Given a record @field :: 'Field' rec a@, this function brings the +-- type class instance @c a@ into scope for the third argument. +-- +-- This function is intended to be used with a @TypeApplication@ for the +-- constraint you want to instantiate. It is most useful for working with +-- generic records in type class instances. +-- +-- @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 +withFieldDict l k = + case getFieldDict @c l of + Dict -> k + +-- | This type class enables you to map a 'Symbol's to a record 'Field'. +-- +-- To use this, you'll define an instance +-- +-- @ +-- instance 'SymbolToField' "age" User Int where +-- symbolToField = UserAge +-- +-- instance 'SymbolToField' "name" User String where +-- symbolToField = UserName +-- @ +-- +-- The main utility here is that you can then write @OverloadedSymbols@ +-- that correspond to record fields. +-- +-- @ +-- nameField :: ('SymbolToField'' "name" rec a) => 'Field' rec a +-- nameField = #name +-- +-- userNameField :: 'Field' User String +-- userNameField = #name +-- @ +-- +-- Note that there's nothing forcing you to use a symbol that exactly +-- matches the type. You can write multiple instances of this for each +-- constructor. The following two instances are perfectly happy to live +-- together. +-- +-- @ +-- instance 'SymbolToField' "name" User String where +-- symbolToField = UserName +-- +-- instance 'SymbolToField' "userName" User String where +-- symbolToField = UserName +-- @ +-- +-- @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 + +-- | If you've defined the relevant instances for 'SymbolToField', then you +-- can use @OverloadedLabels@ to write your labels. This can be convenient +-- if you want to avoid a lot of duplication and verbosity in the types. +-- +-- Given the instances for the @User@ example type, we are able to write: +-- +-- @ +-- getUserName :: User -> String +-- getUserName = getRecordField #name +-- @ +-- +-- @since 0.0.1.0 +instance (SymbolToField sym rec a) => IsLabel sym (Field rec a) where + fromLabel = symbolToField @sym diff --git a/src/Prairie/Diff.hs b/src/Prairie/Diff.hs new file mode 100644 --- /dev/null +++ b/src/Prairie/Diff.hs @@ -0,0 +1,41 @@ +-- | This module contains a utility for diffing two records. +-- +-- @since 0.0.1.0 +module Prairie.Diff + ( module Prairie.Diff + , module Prairie.Update + ) where + +import Prairie.Update +import Prairie.Class + +-- | 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. +-- +-- @ +-- 'updateRecord' ('diffRecord' old new) old == new +-- @ +-- +-- A @['Update' rec]@ can be serialized with 'ToJSON', sent over the wire, and +-- parsed with 'FromJSON', so you can efficiently and easily represent +-- patches to 'Record's. +-- +-- @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 + where + go (SomeField f) = + withFieldDict @Eq f $ + let + newVal = getRecordField f new + in + if getRecordField f old /= newVal + then [SetField f newVal] + else [] + diff --git a/src/Prairie/TH.hs b/src/Prairie/TH.hs new file mode 100644 --- /dev/null +++ b/src/Prairie/TH.hs @@ -0,0 +1,247 @@ +-- | 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 qualified Data.List as List +import Data.Traversable (for) +import Data.Char (toUpper, toLower) +import qualified Data.Text as Text + +import Prairie.Class + +-- | Create an instance of the 'Record' type class. +-- +-- @ +-- data User +-- = User +-- { name :: String +-- , age :: Int +-- } +-- +-- mkRecord ''User +-- +-- ====> +-- +-- instance Record User where +-- data Field User a where +-- UserName :: String +-- UserAge :: Int +-- +-- recordFieldLens fl = +-- case fl of +-- UserName -> lens name (\u n -> u { name = n) +-- UserAge -> lens age (\u n -> u { age = n) +-- +-- instance SymbolToField "age" User Int where symbolToField = UserName +-- instance SymbolToField "name" User String where symbolToField = UserAge +-- @ +-- +-- If the fields are prefixed with the type's name, this function figures +-- it out and won't duplicate the field. +-- +-- @ +-- data User +-- = User +-- { userName :: String +-- , userAge :: Int +-- } +-- +-- mkRecord ''User +-- +-- ====> +-- +-- instance Record User where +-- data Field User a where +-- UserName :: String +-- UserAge :: Int +-- +-- recordFieldLens fl = +-- case fl of +-- UserName -> lens name (\u n -> u { name = n) +-- UserAge -> lens age (\u n -> u { age = n) +-- +-- instance SymbolToField "name" User Int where symbolToField = UserName +-- instance SymbolToField "age" User String where symbolToField = UserAge +-- @ +-- +-- @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 + + (recordCon, names'types) <- + case con of + RecC conName varBangTypes -> + pure $ (conName, map (\(n, _b, t) -> (n, t)) varBangTypes) + _ -> + fail "only supports records" + + let + mkConstrFieldName fieldName = + mkName (nameBase typeName <> upperFirst (nameBase (stripTypeName fieldName))) + + fieldLensClause <- do + arg <- newName "field" + let + mkMatch (fieldName, _typ) = do + recVar <- newName "rec" + newVal <- newName "newVal" + + pure $ + Match + (ConP (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 + + mkAllFields <- pure $ + ValD + (VarP 'allFields) + (NormalB $ ListE (map (AppE (ConE 'SomeField) . ConE . fst) fieldConstructors)) + [] + + mkTabulateRecord <- do + fromFieldName <- newName "fromField" + body <- pure $ + RecConE recordCon $ + map + (\(n, _) -> (n, VarE fromFieldName `AppE` ConE (mkConstrFieldName n))) + names'types + + pure $ + FunD 'tabulateRecord + [ Clause [VarP fromFieldName] (NormalB body) [] + ] + + mkRecordFieldLabel <- do + fieldName <- newName "fieldName" + body <- pure $ + CaseE (VarE fieldName) $ + flip map names'types $ \(n, _) -> + let + constrFieldName = + mkConstrFieldName n + pat = + ConP constrFieldName [] + bdy = + AppE (VarE 'Text.pack) $ LitE $ StringL $ nameBase $ stripTypeName n + + in + Match pat (NormalB bdy) [] + pure $ + FunD 'recordFieldLabel + [ Clause [VarP fieldName] (NormalB body) [] + ] + + let + fieldConstrs = + map mkFieldConstr fieldConstructors + mkFieldConstr (fieldName, typ) = + GadtC + [ fieldName + ] + [] + (ConT ''Field `AppT` ConT typeName `AppT` typ) + + recordInstance = + InstanceD + Nothing + [] + (ConT ''Record `AppT` ConT typeName) + ( + [ DataInstD + [] + Nothing + (ConT ''Field `AppT` ConT typeName `AppT` VarT (mkName "a")) + Nothing + fieldConstrs + [] + , recordFieldLensDec + , mkAllFields + , mkTabulateRecord + , mkRecordFieldLabel + ] + ) + + 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 (ConP name []) (NormalB (ConE 'Dict)) [] + + 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 + +upperFirst, lowerFirst :: String -> String +upperFirst = overFirst toUpper +lowerFirst = overFirst toLower diff --git a/src/Prairie/Update.hs b/src/Prairie/Update.hs new file mode 100644 --- /dev/null +++ b/src/Prairie/Update.hs @@ -0,0 +1,99 @@ +-- | This cl +-- +-- @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 Prairie.Class + +-- | An operation representing an update against the 'rec' in question. +-- +-- This type is partially an example - you may want to have a more +-- sophisticated update type than merely setting fields. +-- +-- @since 0.0.1.0 +data Update rec where + 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 + +-- | +-- +-- @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 + +-- | Renders an 'Update' in the following format: +-- +-- @ +-- { +-- "field": 'toJSON' field, +-- "value": 'toJSON' newValue +-- +-- } +-- @ +-- +-- @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 ] + +-- | Parses an 'Update' with the following format: +-- +-- @ +-- { +-- "field": field, +-- "value": newValue +-- } +-- @ +-- +-- +-- @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" + +-- | Run an 'Update' against the record it is for. +-- +-- @ +-- >>> let user = User { name = "Bob", age = 30 } +-- >>> updateSingleField (SetField UserName "Alice") user +-- User { name = "Alice", age = 30 } +-- @ +-- +-- @since 0.0.1.0 +updateSingleField :: Record rec => Update rec -> rec -> rec +updateSingleField (SetField 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 upds rec = foldr updateSingleField rec upds diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,36 @@ +{-# language TypeApplications, StandaloneDeriving, ConstraintKinds, TemplateHaskell, DataKinds, OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, TypeFamilies, GADTs #-} +module Main where + +import Prairie + +import Data.Aeson +import Control.Monad + +data User = User { name :: String, age :: Int } + deriving Eq + +mkRecord ''User + +deriving instance Eq (Field User a) + +example = User "Alice" 30 + +assert :: String -> Bool -> IO () +assert message success = unless success (error message) + +main :: IO () +main = do + assert "getField" $ getRecordField UserName example == "Alice" + assert "setField" $ setRecordField UserAge 32 example == User "Alice" 32 + assert "label" $ recordFieldLabel UserAge == "age" + assert "label" $ recordFieldLabel UserName == "name" + + assert "update json" $ + encode (diffRecord example (setRecordField UserName "Bob" example)) + == + "[{\"field\":\"name\",\"value\":\"Bob\"}]" + + assert "decode update" $ + decode "[{\"field\":\"name\",\"value\":\"Bob\"}]" + == + Just [SetField UserName "Bob"]