diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Changelog for prairie +## 0.1.2.0 + +- [#26](https://github.com/parsonsmatt/prairie/pull/26) + - `mkRecord` now supports record types with type variables (e.g. `data Box a = Box { contents :: a }`). +- [#27](https://github.com/parsonsmatt/prairie/pull/27) + - Added `mkRecordWith`, the abstract `PrairieOptions` type, and `defaultPrairieOptions`. `mkRecord` is now `mkRecordWith defaultPrairieOptions` and its generated code is unchanged. The `PrairieOptions` constructor is intentionally not exported, so adding options later is not a breaking change. + - `mkRecordWith defaultPrairieOptions { useTypeEquality = True }` generates the `SymbolToField` instances with a `~` equality constraint binding the field type, instead of placing it directly in the instance head. This admits field types that an instance head rejects — most notably type-family applications (e.g. `data Test m = Test { field :: Family m Int }`). It is opt-in because the `~` constraint requires the `TypeOperators` extension at the use site; default `mkRecord` behaviour is unaffected. Using a type-family field without enabling `useTypeEquality` now produces a descriptive error. + ## 0.1.1.0 - [#24](https://github.com/parsonsmatt/prairie/pull/24) 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.1.1.0 +version: 0.1.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 @@ -91,6 +91,8 @@ Paths_prairie Prairie.DuplicateFieldSpec Prairie.NoFieldSelectorSpec + Prairie.TypeVariablesSpec + Prairie.TypeFamilySpec hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/src/Prairie/TH.hs b/src/Prairie/TH.hs --- a/src/Prairie/TH.hs +++ b/src/Prairie/TH.hs @@ -3,8 +3,18 @@ -- | Helpers for generating instances of the 'Record' type class. -- -- @since 0.0.1.0 -module Prairie.TH where +module Prairie.TH + ( -- * Generating @Record@ instances + mkRecord + , mkRecordWith + -- * Configuration + -- $options + , PrairieOptions + , defaultPrairieOptions + , useTypeEquality + ) where + import Data.Char (toLower, toUpper) import Data.Constraint (Dict (..)) import Data.Functor.Apply (Apply (..)) @@ -75,22 +85,102 @@ -- -- @since 0.0.1.0 mkRecord :: Name -> DecsQ -mkRecord u = do +mkRecord = mkRecordWith defaultPrairieOptions + +-- $options +-- +-- 'PrairieOptions' is an opaque type. Configure it by record-updating +-- 'defaultPrairieOptions' using the exported field accessors, e.g. +-- +-- @ +-- 'defaultPrairieOptions' { 'useTypeEquality' = True } +-- @ +-- +-- The constructor is intentionally not exported so that future options can +-- be added without it being a breaking change. + +-- | Options controlling how 'mkRecordWith' generates instances. +-- +-- This type is abstract; see 'defaultPrairieOptions' and the individual field +-- accessors ('useTypeEquality'). +-- +-- @since 0.1.2.0 +data PrairieOptions = PrairieOptions + { useTypeEquality :: Bool + -- ^ Generate the 'SymbolToField' instances using a @~@ equality + -- constraint to bind the field type, rather than placing the field type + -- directly in the instance head: + -- + -- @ + -- -- with useTypeEquality = False (default): + -- instance SymbolToField \"foo\" Rec Ty where ... + -- + -- -- with useTypeEquality = True: + -- instance (field ~ Ty) => SymbolToField \"foo\" Rec field where ... + -- @ + -- + -- This admits field types that are not permitted directly in an instance + -- head — most notably type-family applications (e.g. @field :: Family m + -- Int@), but anything else that an instance head rejects too. The cost is + -- that the calling module must enable the @TypeOperators@ extension, so it + -- is off by default: the generated code is then identical to previous + -- versions of @prairie@. When it is off and a field is found to use a type + -- family, 'mkRecordWith' fails with a descriptive error pointing here. + -- + -- @since 0.1.2.0 + } + +-- | The default 'PrairieOptions'. 'mkRecord' is @'mkRecordWith' 'defaultPrairieOptions'@, +-- and the generated code is identical to previous versions of @prairie@. +-- +-- @since 0.1.2.0 +defaultPrairieOptions :: PrairieOptions +defaultPrairieOptions = + PrairieOptions + { useTypeEquality = False + } + +-- | Like 'mkRecord', but with control over code generation via 'PrairieOptions'. +-- +-- For example, to allow fields whose type is a type-family application: +-- +-- @ +-- {-\# LANGUAGE TypeOperators \#-} +-- +-- mkRecordWith defaultPrairieOptions { useTypeEquality = True } ''MyRecord +-- @ +-- +-- @since 0.1.2.0 +mkRecordWith :: PrairieOptions -> Name -> DecsQ +mkRecordWith opts u = do ty <- reify u - (typeName, con) <- + (typeName, con, tyvars) <- 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) + DataD _cxt name tyvars _mkind [con] _derivs -> + pure (name, con, tyvars) + NewtypeD _cxt name tyvars _mkind con _derivs -> + pure (name, con, tyvars) _ -> fail "unsupported data structure" _ -> fail "unsupported type" let + instanceHead = List.foldl' AppT (ConT typeName) $ fmap getTyVarType tyvars + -- Annotate a record update with the record's type so that + -- @DuplicateRecordFields@ can figure out which field is being set. We + -- only do this for monomorphic records: applying the type constructor + -- to its variables (e.g. @One a@) in an expression signature would + -- introduce fresh, rigid type variables that cannot unify with the + -- ones bound by the instance head. For polymorphic records the type of + -- the surrounding 'lens' already fixes the record type, so no + -- annotation is needed. + annotateRecordUpdate e = + case tyvars of + [] -> SigE e instanceHead + _ -> e stripTypeName n = let typeNamePrefix = @@ -131,9 +221,8 @@ `AppE` (VarE 'getField `AppTypeE` LitT (StrTyLit (nameBase fieldName))) `AppE` LamE [VarP recVar, VarP newVal] - ( SigE + ( annotateRecordUpdate (RecUpdE (VarE recVar) [(fieldName, VarE newVal)]) - (ConT typeName) ) ) [] @@ -245,17 +334,17 @@ [ fieldName ] [] - (ConT ''Field `AppT` ConT typeName `AppT` typ) + (ConT ''Field `AppT` instanceHead `AppT` typ) recordInstance = InstanceD Nothing [] - (ConT ''Record `AppT` ConT typeName) + (ConT ''Record `AppT` instanceHead) ( [ DataInstD [] Nothing - (ConT ''Field `AppT` ConT typeName `AppT` VarT (mkName "_")) + (ConT ''Field `AppT` instanceHead `AppT` VarT (mkName "_")) Nothing fieldConstrs [] @@ -285,27 +374,114 @@ InstanceD Nothing -- maybe overlap allFieldsC - (ConT ''FieldDict `AppT` VarT constraintVar `AppT` ConT typeName) + (ConT ''FieldDict `AppT` VarT constraintVar `AppT` instanceHead) fieldDictDecl - symbolToFieldInstances <- - fmap concat $ for names'types $ \(fieldName, typ) -> do + let + -- Bind the field type through a @~@ equality constraint. Needed for + -- field types that cannot appear directly in an instance head (e.g. + -- type-family applications); requires @TypeOperators@ at the use site. + equalitySymbolToField fieldName typ = do + retType <- newName "field" [d| instance + ($(varT retType) ~ $(pure typ)) + => SymbolToField + $(litT (strTyLit (nameBase fieldName))) + $(pure instanceHead) + $(varT retType) + where + symbolToField = $(conE (mkConstrFieldName fieldName)) + |] + -- Place the field type directly in the instance head, exactly as + -- @prairie@ always has (no @TypeOperators@ required). + directSymbolToField fieldName typ = + [d| + instance SymbolToField $(litT (strTyLit (nameBase fieldName))) - $(conT typeName) + $(pure instanceHead) $(pure typ) where symbolToField = $(conE (mkConstrFieldName fieldName)) |] + symbolToFieldInstances <- + fmap concat $ for names'types $ \(fieldName, typ) -> + if useTypeEquality opts + then equalitySymbolToField fieldName typ + else do + -- The direct form can't express a type-family field. Detect + -- that and fail with guidance rather than letting GHC emit a + -- confusing instance-head error. + mentionsFamily <- typeMentionsFamily typ + if mentionsFamily + then fail (typeFamilyFieldError typeName fieldName typ) + else directSymbolToField fieldName typ + pure $ [ recordInstance , fieldDictInstance ] ++ symbolToFieldInstances +-- | Does this type mention a type or data family anywhere within it? Such +-- types are not permitted in instance heads, so the generated +-- 'SymbolToField' instance has to bind them through an equality constraint +-- instead (see 'allowTypeFamilies'). The walk short-circuits as soon as a +-- family is found, and expands type synonyms so that a synonym hiding a +-- family (e.g. @type Foo m = Family m Int@) is still detected. +typeMentionsFamily :: Type -> Q Bool +typeMentionsFamily = go + where + go ty = + case ty of + ConT n -> isFamily n + InfixT a n b -> anyM [isFamily n, go a, go b] + UInfixT a n b -> anyM [isFamily n, go a, go b] + AppT a b -> anyM [go a, go b] + AppKindT a _ -> go a + SigT a _ -> go a + ParensT a -> go a + _ -> pure False + + isFamily n = do + info <- reify n + case info of + FamilyI{} -> pure True + -- Type synonyms are not recursive, so this terminates. + TyConI (TySynD _ _ rhs) -> go rhs + _ -> pure False + + anyM = + foldr + (\m acc -> m >>= \found -> if found then pure True else acc) + (pure False) + +-- | The error reported when a field uses a type family but +-- 'useTypeEquality' has not been enabled. +typeFamilyFieldError :: Name -> Name -> Type -> String +typeFamilyFieldError tyName fieldName typ = + unlines + [ "prairie: the field `" + <> nameBase fieldName + <> "` of `" + <> nameBase tyName + <> "` has a type that mentions a type family:" + , "" + , " " <> pprint typ + , "" + , "Generating instances for such a field requires binding the field type" + , "with a `~` equality constraint, which means the calling module must" + , "enable the TypeOperators extension. Because that is a new requirement," + , "it is opt-in. Enable it like so:" + , "" + , " {-# LANGUAGE TypeOperators #-}" + , "" + , " mkRecordWith defaultPrairieOptions { useTypeEquality = True } ''" + <> nameBase tyName + ] + overFirst :: (Char -> Char) -> String -> String overFirst f str = case str of @@ -316,6 +492,18 @@ upperFirst = overFirst toUpper lowerFirst = overFirst toLower +-- | @template-haskell-2.17@ (GHC 9.0) added a @flag@ parameter to +-- 'TyVarBndr'; on older versions the constructors have one fewer field. +#if MIN_VERSION_template_haskell(2,17,0) +getTyVarType :: TyVarBndr a -> Type +getTyVarType (PlainTV n _) = VarT n +getTyVarType (KindedTV n _ _) = VarT n +#else +getTyVarType :: TyVarBndr -> Type +getTyVarType (PlainTV n) = VarT n +getTyVarType (KindedTV n _) = VarT n +#endif + compatConP :: Name -> Pat #if MIN_VERSION_template_haskell(2,18,0) compatConP constrFieldName = @@ -331,5 +519,5 @@ ConP constrFieldName [] ps #else compatConP' constrFieldName ps = - ConP constrFieldName ps + ConP constrFieldName ps #endif diff --git a/test/Prairie/TypeFamilySpec.hs b/test/Prairie/TypeFamilySpec.hs new file mode 100644 --- /dev/null +++ b/test/Prairie/TypeFamilySpec.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Prairie.TypeFamilySpec where + +import Prairie + +data Mode = Foo | Bar + +type family Family (m :: Mode) a where + Family 'Foo a = a + Family 'Bar a = () + +data Test (m :: Mode) = Test + { test_field1 :: Family m Int + , test_field2 :: Family m Bool + } + +mkRecordWith defaultPrairieOptions{useTypeEquality = True} ''Test diff --git a/test/Prairie/TypeVariablesSpec.hs b/test/Prairie/TypeVariablesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Prairie/TypeVariablesSpec.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.TypeVariablesSpec where + +import Prairie + +data One a = One {the_one :: a} + +mkRecord ''One + +data Two a b = Two {first :: a, second :: b, pair :: (a, b)} + +mkRecord ''Two diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -24,10 +24,8 @@ import Prairie -import Control.Lens hiding ((<.>)) import Control.Monad import Data.Aeson -import Data.Functor.Apply (Apply (..)) import Data.Functor.Compose import Data.List.NonEmpty (NonEmpty (..)) import Data.Monoid @@ -58,22 +56,15 @@ data T a = T {x :: a, y :: Int} -instance Record (T a) 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}) +mkRecord ''T - tabulateRecordA f = T <$> f TX <*> f TY +data Box a b = Box {boxContents :: a, boxLabel :: b, boxPair :: (a, b)} + deriving (Show, Eq) - tabulateRecordApply f = (T <$> f TX) <.> f TY +mkRecord ''Box - recordFieldLabel = \case - TX -> "TX" - TY -> "TY" +exampleBox :: Box Int String +exampleBox = Box 1 "hello" (1, "hello") main :: IO () main = hspec $ do @@ -249,3 +240,16 @@ u0 u1 `shouldBe` User "MattttaM" (35 + 53) + + describe "type variables" do + it "can get a field" do + getRecordField BoxContents exampleBox `shouldBe` 1 + getRecordField BoxLabel exampleBox `shouldBe` "hello" + it "can set a field" do + setRecordField BoxContents 2 exampleBox + `shouldBe` Box 2 "hello" (1, "hello") + setRecordField BoxLabel "world" exampleBox + `shouldBe` Box 1 "world" (1, "hello") + it "produces field labels" do + recordFieldLabel BoxContents `shouldBe` "contents" + recordFieldLabel BoxPair `shouldBe` "pair"