diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for prairie +## 0.0.2.0 + +- [#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/prairie.cabal b/prairie.cabal --- a/prairie.cabal +++ b/prairie.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: prairie -version: 0.0.1.1 +version: 0.0.2.0 description: Please see the README on GitHub at homepage: https://github.com/parsonsmatt/prairie#readme bug-reports: https://github.com/parsonsmatt/prairie/issues @@ -86,4 +86,5 @@ base >=4.7 && <5 , prairie , aeson + , lens default-language: Haskell2010 diff --git a/src/Prairie/Class.hs b/src/Prairie/Class.hs --- a/src/Prairie/Class.hs +++ b/src/Prairie/Class.hs @@ -16,13 +16,14 @@ -- @since 0.0.1.0 module Prairie.Class where -import Control.Lens (Lens', set, view) +import Control.Lens (Lens', set, view, Identity(..), Const(..)) 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 qualified Data.Text as Text import Data.Typeable ((:~:)(..), Typeable, eqT) import GHC.OverloadedLabels (IsLabel(..)) import GHC.TypeLits (Symbol) @@ -33,90 +34,109 @@ -- -- @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 + -- | 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 + -- | 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] + -- | Construct a 'Record' by providing an 'Applicative' action + -- returning a value for each 'Field' on the 'Record'. + -- + -- Example: + -- + -- @ + -- tabulateRecordA $ \\field -> case field of + -- UserName -> Just "Matt" + -- UserAge -> Nothing + -- + -- tabulateRecordA $ \\field -> case field of + -- UserName -> getLine + -- UserAge -> do + -- ageStr <- getLine + -- case readMaybe ageStr of + -- Nothing -> fail $ "Expected Int, got: " <> ageStr + -- Just a -> pure a + -- @ + -- + -- @since 0.0.2.0 + tabulateRecordA :: Applicative m => (forall ty. Field rec ty -> m ty) -> m 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)@. + -- + -- Record field labels can be given a @stock@ derived 'Show' instance, + -- which works for the default implementation of the class. + -- + -- @since 0.0.1.0 + recordFieldLabel :: Field rec ty -> Text + default recordFieldLabel :: Show (Field rec ty) => Field rec ty -> Text + recordFieldLabel = Text.pack . show - -- | 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 +-- | An enumeration of fields on the record. +-- +-- 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 +-- member. +-- +-- @since 0.0.1.0 +allFields :: Record rec => [SomeField rec] +allFields = getConst $ tabulateRecordA $ \field -> + Const [SomeField field] + +-- | 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 k = runIdentity (tabulateRecordA (Identity . k)) -- | A mapping from 'Text' record field labels to the corresponding -- 'SomeField' for that record. diff --git a/src/Prairie/TH.hs b/src/Prairie/TH.hs --- a/src/Prairie/TH.hs +++ b/src/Prairie/TH.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# language CPP #-} -- | Helpers for generating instances of the 'Record' type class. -- @@ -134,22 +134,20 @@ 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 + let body = + List.foldl' + (\acc (n, _) -> + VarE '(<*>) + `AppE` acc + `AppE` (VarE fromFieldName `AppE` ConE (mkConstrFieldName n)) + ) + (VarE 'pure `AppE` ConE recordCon) + names'types pure $ - FunD 'tabulateRecord + FunD 'tabulateRecordA [ Clause [VarP fromFieldName] (NormalB body) [] ] @@ -197,7 +195,6 @@ fieldConstrs [] , recordFieldLensDec - , mkAllFields , mkTabulateRecord , mkRecordFieldLabel ] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,10 +1,12 @@ -{-# language TypeApplications, StandaloneDeriving, ConstraintKinds, TemplateHaskell, DataKinds, OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, TypeFamilies, GADTs #-} +{-# language PolyKinds, LambdaCase, TypeApplications, RankNTypes, StandaloneDeriving, ConstraintKinds, TemplateHaskell, DataKinds, OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, TypeFamilies, GADTs #-} +{-# options_ghc -Wall #-} module Main where import Prairie import Data.Aeson import Control.Monad +import Control.Lens data User = User { name :: String, age :: Int } deriving Eq @@ -15,22 +17,73 @@ example = User "Alice" 30 +data T a = T { x :: a, y :: Int } + +instance Record (T a) where + data Field (T a) t 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 }) + + tabulateRecordA 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 :: *) (p :: *) (f :: * -> *) 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 + 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 "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\"}]" + let t :: T Int + t = T 3 2 - assert "decode update" $ - decode "[{\"field\":\"name\",\"value\":\"Bob\"}]" - == - Just [SetField UserName "Bob"] + t' :: T Char + t' = t & polyLens TX .~ 'a' + + 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"] + + user' <- + tabulateRecordA $ \case + UserName -> + print 10 >> pure "Matt" + UserAge -> + print 20 >> pure 33 + assert "tabulateRecordA" $ + user' + == + User + { name = "Matt" + , age = 33 + } + +