prairie 0.1.1.0 → 0.1.2.0

raw patch · 6 files changed

+285/−33 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• prairie.cabal +3/−1
• src/Prairie/TH.hs +205/−17
• test/Prairie/TypeFamilySpec.hs +28/−0
• test/Prairie/TypeVariablesSpec.hs +22/−0
• test/Spec.hs +19/−15

@@ -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)

@@ -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 <https://github.com/parsonsmatt/prairie#readme> 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

@@ -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

@@ -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

@@ -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

@@ -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"