packages feed

lens 5.1.1 → 5.2

raw patch · 9 files changed

+198/−128 lines, 9 filesdep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

+ Control.Lens.Internal.TH: dropSigsIfNonDataFam :: DatatypeInfo -> [Type] -> [Type]
- Control.Lens.Combinators: universeOf :: Getting [a] a a -> a -> [a]
+ Control.Lens.Combinators: universeOf :: Getting (Endo [a]) a a -> a -> [a]
- Control.Lens.Combinators: universeOn :: Plated a => Getting [a] s a -> s -> [a]
+ Control.Lens.Combinators: universeOn :: Plated a => Getting (Endo [a]) s a -> s -> [a]
- Control.Lens.Combinators: universeOnOf :: Getting [a] s a -> Getting [a] a a -> s -> [a]
+ Control.Lens.Combinators: universeOnOf :: Getting (Endo [a]) s a -> Getting (Endo [a]) a a -> s -> [a]
- Control.Lens.Plated: universeOf :: Getting [a] a a -> a -> [a]
+ Control.Lens.Plated: universeOf :: Getting (Endo [a]) a a -> a -> [a]
- Control.Lens.Plated: universeOn :: Plated a => Getting [a] s a -> s -> [a]
+ Control.Lens.Plated: universeOn :: Plated a => Getting (Endo [a]) s a -> s -> [a]
- Control.Lens.Plated: universeOnOf :: Getting [a] s a -> Getting [a] a a -> s -> [a]
+ Control.Lens.Plated: universeOnOf :: Getting (Endo [a]) s a -> Getting (Endo [a]) a a -> s -> [a]

Files

CHANGELOG.markdown view
@@ -1,3 +1,24 @@+5.2 [2022.08.11]+----------------+* Allow building with GHC 9.4.+* The type of `universeOf` has changed:++  ```diff+  -universeOf :: Getting       [a]  a a -> a -> [a]+  +universeOf :: Getting (Endo [a]) a a -> a -> [a]+  ```++  In many cases, using `Endo [a]` over `[a]` improves performance. Most call+  sites to `universeOf` will not be affected by this change, although you may+  need to update your code if you define your own combinators in terms of+  `universeOf`.+* Allow `makeWrapped` to accept the names of data constructors. This way,+  `makeWrapped` can be used with data family instances, much like other+  functions in `Control.Lens.TH`.+* Define `_OpaqueP`, `_DefaultD`, `_LamCasesE`, `_PromotedInfixT`, and+  `_PromotedUInfixT` in `Language.Haskell.TH.Lens` when building with+  `template-haskell-2.19.0.0` (GHC 9.4) or later.+ 5.1.1 [2022.05.17] ------------------ * Add `Data.HashSet.Lens.hashMap`, an `Iso` between a `HashSet a` and a
benchmarks/plated.hs view
@@ -70,6 +70,8 @@   , bench "universeOf Data.template"           $ nf (map (universeOf Data.template)) testsExpr   , bench "universeOf Data.uniplate"           $ nf (map (universeOf Data.uniplate)) testsExpr   , bench "universeOf (cloneTraversal plate)"  $ nf (map (universeOf (cloneTraversal plate))) testsExpr+  , bench "universeOf plate fibExpr"           $ nf (universeOf plate) fibExpr+  , bench "universeOf Data.uniplate fibExpr"   $ nf (universeOf Data.uniplate) fibExpr #ifdef BENCHMARK_UNIPLATE   , bench "Direct.universe"                    $ nf (map Uni.universe) testsExpr   , bench "DataOnly.universe"                  $ nf (map UniDataOnly.universe) testsExpr@@ -78,3 +80,8 @@  testsExpr :: [Expr] testsExpr = [Val 3,Val 2,Val 6,Neg (Neg (Var "dus")),Mul (Div (Add (Val 4) (Var "kxm")) (Sub (Mul (Div (Var "") (Var "")) (Var "w")) (Var "ed"))) (Var "whpd"),Val 6,Val 4,Val 2,Var "a",Val 1,Div (Var "") (Val 0),Var "",Var "",Val (-3),Val 3,Sub (Var "") (Val 2),Neg (Var "dlp"),Div (Val 0) (Var "sd"),Val (-2),Val (-3),Var "g",Mul (Val 3) (Var "i"),Val 1,Var "ul",Div (Add (Var "") (Var "")) (Mul (Div (Val 0) (Neg (Val 0))) (Neg (Neg (Mul (Var "") (Val 0))))),Var "z",Sub (Neg (Add (Var "") (Val 0))) (Var ""),Neg (Sub (Mul (Val 0) (Val 2)) (Val 5)),Val 0,Val 0,Mul (Val (-4)) (Sub (Val 5) (Neg (Div (Div (Val 0) (Sub (Neg (Sub (Val (-3)) (Mul (Mul (Var "ap") (Val 3)) (Add (Add (Add (Var "owre") (Add (Add (Var "avj") (Val 3)) (Var "vhi"))) (Mul (Val 2) (Var "hak"))) (Val 2))))) (Var "nf"))) (Add (Sub (Val 5) (Sub (Var "pkjyh") (Val 2))) (Var "lsiu"))))),Var "u",Val 1,Neg (Add (Add (Var "") (Val 1)) (Sub (Add (Add (Val (-3)) (Mul (Val 1) (Var "pfe"))) (Var "yv")) (Mul (Var "") (Var "jfq")))),Val 2,Div (Div (Div (Div (Var "xrgykq") (Mul (Var "kyfu") (Val 2))) (Sub (Var "v") (Val 0))) (Sub (Val 6) (Val 2))) (Val 3),Var "",Var "",Add (Var "ob") (Sub (Mul (Neg (Val 2)) (Val 6)) (Add (Mul (Val 6) (Sub (Add (Var "wue") (Mul (Var "hgsuj") (Neg (Div (Var "hr") (Var "ozvsb"))))) (Sub (Var "j") (Div (Var "yeyhvq") (Val (-6)))))) (Var "b"))),Div (Add (Div (Div (Neg (Val 4)) (Var "")) (Var "yfx")) (Div (Sub (Var "") (Sub (Var "np") (Mul (Val 3) (Var "mxr")))) (Mul (Var "m") (Var "kkhbf")))) (Neg (Sub (Var "yie") (Val 1))),Neg (Var ""),Var "liuh",Var "pbqg",Var "",Neg (Div (Sub (Add (Val (-1)) (Var "onynvr")) (Neg (Var "tqjsay"))) (Add (Val 4) (Var "yorkb"))),Val 1,Add (Mul (Neg (Div (Val (-1)) (Var "u"))) (Sub (Var "") (Neg (Val 1)))) (Var "h"),Var "",Add (Mul (Sub (Var "em") (Val 0)) (Add (Val (-2)) (Val 1))) (Var ""),Add (Mul (Add (Div (Add (Val 0) (Mul (Mul (Var "e") (Add (Val 1) (Var ""))) (Neg (Neg (Div (Add (Div (Neg (Val 1)) (Div (Val (-1)) (Mul (Add (Div (Val (-1)) (Mul (Mul (Val 1) (Val 1)) (Mul (Var "t") (Val (-1))))) (Val 1)) (Val 1)))) (Add (Neg (Add (Val 0) (Var "k"))) (Mul (Neg (Div (Sub (Sub (Var "u") (Val 1)) (Val 1)) (Sub (Neg (Var "")) (Sub (Var "b") (Val (-1)))))) (Neg (Var ""))))) (Val 0)))))) (Val 0)) (Var "a")) (Var "")) (Val (-1)),Var "xijsnp",Div (Var "h") (Neg (Val 5)),Div (Var "dmzlh") (Add (Val 6) (Val (-2))),Neg (Add (Val 0) (Var "")),Add (Add (Add (Sub (Val 4) (Var "nfse")) (Var "o")) (Add (Val 2) (Div (Var "mtqdx") (Val (-3))))) (Val 3),Neg (Var "c"),Var "sr",Mul (Add (Sub (Neg (Val 1)) (Sub (Div (Add (Sub (Add (Sub (Sub (Var "gd") (Mul (Var "v") (Var "d"))) (Var "")) (Val 1)) (Add (Val 2) (Var ""))) (Var "kk")) (Div (Var "fw") (Add (Val 1) (Var "f")))) (Var ""))) (Val 2)) (Add (Neg (Div (Var "") (Val 0))) (Add (Var "") (Add (Var "s") (Add (Mul (Var "") (Val (-1))) (Val 1))))),Val 1,Var "",Sub (Var "vbnzahx") (Val (-5)),Var "nl",Val 0,Add (Mul (Neg (Mul (Var "") (Var "mvil"))) (Var "")) (Neg (Var "zxl")),Val (-3),Var "",Var "e",Add (Div (Sub (Val 0) (Add (Val 5) (Val 7))) (Mul (Var "") (Var "qz"))) (Val 4),Add (Val (-1)) (Neg (Var "lk")),Add (Add (Var "u") (Mul (Val 1) (Var "h"))) (Sub (Mul (Div (Val 1) (Div (Var "t") (Neg (Var "")))) (Var "")) (Mul (Val 1) (Neg (Div (Neg (Var "")) (Var ""))))),Val 0,Val 0,Val (-7),Mul (Var "") (Val 0),Mul (Add (Val (-6)) (Add (Val 2) (Sub (Div (Var "z") (Var "gbb")) (Var "vddnpsl")))) (Add (Add (Add (Var "") (Sub (Div (Val 3) (Neg (Div (Add (Var "cfvgz") (Add (Sub (Var "htd") (Sub (Var "mhbl") (Var "un"))) (Val 3))) (Val (-3))))) (Var ""))) (Val 5)) (Neg (Mul (Val 0) (Var "sufvvj")))),Sub (Div (Neg (Add (Add (Neg (Add (Var "") (Val 0))) (Var "")) (Sub (Val 0) (Val 0)))) (Val 0)) (Add (Neg (Div (Div (Add (Sub (Add (Add (Neg (Var "")) (Val 0)) (Val 0)) (Add (Neg (Add (Neg (Var "")) (Neg (Val 0)))) (Val 0))) (Div (Val 0) (Val 0))) (Val 0)) (Val 0))) (Var "")),Var "",Sub (Div (Val 0) (Div (Add (Val 1) (Neg (Div (Neg (Var "y")) (Val 0)))) (Var ""))) (Sub (Div (Var "t") (Var "")) (Neg (Var "s"))),Mul (Div (Sub (Var "") (Var "")) (Add (Val 0) (Sub (Div (Var "yr") (Neg (Var "o"))) (Val 1)))) (Var "u"),Var "odmn",Div (Var "uddqy") (Val 3),Var "",Sub (Val 2) (Neg (Val (-1))),Div (Mul (Var "sox") (Val (-3))) (Val (-3)),Var "qv",Var "xmbnts",Var "j",Mul (Val 6) (Mul (Var "fryndq") (Neg (Val 6))),Var "",Var "",Val (-1),Val 7,Add (Var "dg") (Val 1),Neg (Val 1),Val 0,Var "xnm",Sub (Div (Div (Var "miwi") (Var "mbh")) (Val 3)) (Val 3),Neg (Val (-4)),Var "ndubxoa",Var ""]++fibExpr :: Expr+fibExpr = go 11 where+    go :: Int -> Expr+    go n = if n <= 1 then Val 1 else Add (go (n - 1)) (go (n - 2))
examples/lens-examples.cabal view
@@ -57,7 +57,7 @@     gloss      >= 1.12  && < 1.14,     lens,     mtl        >= 2.0.1 && < 2.4,-    random     >= 1.0   && < 1.2,+    random     >= 1.0   && < 1.3,     streams    >= 3.3   && < 4   main-is: Pong.hs   default-language: Haskell2010
lens.cabal view
@@ -1,6 +1,6 @@ name:          lens category:      Data, Lenses, Generics-version:       5.1.1+version:       5.2 license:       BSD2 cabal-version: 1.18 license-file:  LICENSE@@ -196,14 +196,14 @@     semigroupoids                 >= 5.0.1    && < 6,     strict                        >= 0.4      && < 0.5,     tagged                        >= 0.8.6    && < 1,-    template-haskell              >= 2.11.1.0 && < 2.19,+    template-haskell              >= 2.11.1.0 && < 2.20,     text                          >= 1.2.3.0  && < 2.1,     th-abstraction                >= 0.4.1    && < 0.5,     these                         >= 1.1.1.1  && < 1.2,     transformers                  >= 0.5.0.0  && < 0.7,     transformers-compat           >= 0.5.0.4  && < 1,     unordered-containers          >= 0.2.10   && < 0.3,-    vector                        >= 0.12.1.2 && < 0.13+    vector                        >= 0.12.1.2 && < 0.14    -- Control.Lens as the first module, so cabal repl loads it.   exposed-modules:
src/Control/Lens/Internal/TH.hs view
@@ -98,32 +98,30 @@ datatypeTypeKinded :: D.DatatypeInfo -> Type datatypeTypeKinded di   = foldl AppT (ConT (D.datatypeName di))-  $ dropSigsIfNonDataFam+  $ dropSigsIfNonDataFam di   $ D.datatypeInstTypes di-  where-    {--    In an effort to prevent users from having to enable KindSignatures every-    time that they use lens' TH functionality, we strip off reified kind-    annotations from when: -    1. The kind of a type does not contain any kind variables. If it *does*-       contain kind variables, we want to preserve them so that we can generate-       type signatures that preserve the dependency order of kind and type-       variables. (The data types in test/T917.hs contain examples where this-       is important.) This will require enabling `PolyKinds`, but since-       `PolyKinds` implies `KindSignatures`, we can at least accomplish two-       things at once.-    2. The data type is not an instance of a data family. We make an exception-       for data family instances, since the presence or absence of a kind-       annotation can be the difference between typechecking or not.-       (See T917DataFam in tests/T917.hs for an example.) Moreover, the-       `TypeFamilies` extension implies `KindSignatures`.-    -}-    dropSigsIfNonDataFam :: [Type] -> [Type]-    dropSigsIfNonDataFam-      | isDataFamily (D.datatypeVariant di) = id-      | otherwise                           = map dropSig-+-- | In an effort to prevent users from having to enable KindSignatures every+-- time that they use lens' TH functionality, we strip off reified kind+-- annotations from when:+--+-- 1. The kind of a type does not contain any kind variables. If it *does*+--    contain kind variables, we want to preserve them so that we can generate+--    type signatures that preserve the dependency order of kind and type+--    variables. (The data types in test/T917.hs contain examples where this+--    is important.) This will require enabling `PolyKinds`, but since+--    `PolyKinds` implies `KindSignatures`, we can at least accomplish two+--    things at once.+-- 2. The data type is not an instance of a data family. We make an exception+--    for data family instances, since the presence or absence of a kind+--    annotation can be the difference between typechecking or not.+--    (See T917DataFam in tests/T917.hs for an example.) Moreover, the+--    `TypeFamilies` extension implies `KindSignatures`.+dropSigsIfNonDataFam :: D.DatatypeInfo -> [Type] -> [Type]+dropSigsIfNonDataFam di+  | isDataFamily (D.datatypeVariant di) = id+  | otherwise                           = map dropSig+  where     dropSig :: Type -> Type     dropSig (SigT t k) | null (D.freeVariables k) = t     dropSig t                                     = t
src/Control/Lens/Plated.hs view
@@ -385,13 +385,18 @@ -- @ -- 'universeOf' :: 'Fold' a a -> a -> [a] -- @-universeOf :: Getting [a] a a -> a -> [a]-universeOf l = go where-  go a = a : foldMapOf l go a+universeOf :: Getting (Endo [a]) a a -> a -> [a]+universeOf l = \x -> appEndo (universeOf' l x) [] {-# INLINE universeOf #-} +universeOf' :: Getting (Endo [a]) a a -> a -> Endo [a]+universeOf' l = go where+  go a = Endo (a :) <> foldMapOf l go a+{-# INLINE universeOf' #-}++ -- | Given a 'Fold' that knows how to find 'Plated' parts of a container retrieve them and all of their descendants, recursively.-universeOn ::  Plated a => Getting [a] s a -> s -> [a]+universeOn ::  Plated a => Getting (Endo [a]) s a -> s -> [a] universeOn b = universeOnOf b plate {-# INLINE universeOn #-} @@ -401,8 +406,8 @@ -- @ -- 'toListOf' l ≡ 'universeOnOf' l 'ignored' -- @-universeOnOf :: Getting [a] s a -> Getting [a] a a -> s -> [a]-universeOnOf b = foldMapOf b . universeOf+universeOnOf :: Getting (Endo [a]) s a -> Getting (Endo [a]) a a -> s -> [a]+universeOnOf b = \p x -> appEndo (foldMapOf b (universeOf' p) x) [] {-# INLINE universeOnOf #-}  -- | Fold over all transitive descendants of a 'Plated' container, including itself.
src/Control/Lens/TH.hs view
@@ -88,7 +88,6 @@ import Control.Lens.Getter import Control.Lens.Lens import Control.Lens.Setter-import Control.Lens.Tuple import Control.Lens.Traversal import Control.Lens.Internal.Prelude as Prelude import Control.Lens.Internal.TH@@ -104,15 +103,10 @@ import Data.Maybe (maybeToList) import qualified Data.Set as Set import Data.Set (Set)-import Data.Set.Lens import Data.Traversable hiding (mapM) import Language.Haskell.TH.Datatype-import Language.Haskell.TH.Datatype.TyVarBndr as D import Language.Haskell.TH.Lens import Language.Haskell.TH.Lib-#if MIN_VERSION_template_haskell(2,15,0)-import Language.Haskell.TH.Ppr (pprint)-#endif import Language.Haskell.TH.Syntax hiding (lift)  -- | Generate "simple" optics even when type-changing optics are possible.@@ -446,7 +440,9 @@ -- | Build 'Control.Lens.Wrapped.Wrapped' instance for each newtype. declareWrapped :: DecsQ -> DecsQ declareWrapped = declareWith $ \dec -> do-  maybeDecs <- liftDeclare (makeWrappedForDec dec)+  maybeDecs <- liftDeclare $ do+    inf <- normalizeDec dec+    makeWrappedForDatatypeInfo inf   forM_ maybeDecs emit   return dec @@ -466,14 +462,6 @@ -- Internal TH Implementation ----------------------------------------------------------------------------- --- | Transform @NewtypeD@s declarations to @DataD@s and @NewtypeInstD@s to--- @DataInstD@s.-deNewtype :: Dec -> Dec-deNewtype (NewtypeD ctx tyName args kind c d) = DataD ctx tyName args kind [c] d-deNewtype (NewtypeInstD ctx tyName args kind c d) = DataInstD ctx tyName args kind [c] d-deNewtype d = d-- -- | Given a set of names, build a map from those names to a set of fresh names -- based on them. freshMap :: Set Name -> Q (Map Name Name)@@ -484,96 +472,39 @@ apps = Prelude.foldl AppT  -makeDataDecl :: Dec -> Maybe DataDecl-makeDataDecl dec = case deNewtype dec of-  DataD ctx tyName args _ cons _ -> Just DataDecl-    { dataContext = ctx-    , tyConName = Just tyName-    , dataParameters = args-    , fullType = apps $ ConT tyName-    , constructors = cons-    }-#if MIN_VERSION_template_haskell(2,15,0)-  DataInstD ctx _ fnArgs _ cons _-#else-  DataInstD ctx familyName args _ cons _-#endif-                    -> Just DataDecl-    { dataContext = ctx-    , tyConName = Nothing-    , dataParameters = map D.plainTV vars-    , fullType = \tys -> apps (ConT familyName) $-        substType (Map.fromList $ zip vars tys) args-    , constructors = cons-    }-    where-      -- The list of "type parameters" to a data family instance is not-      -- explicitly specified in the source. Here we define it to be-      -- the set of distinct type variables that appear in the LHS. e.g.-      ---      -- data instance F a Int (Maybe (a, b)) = G-      ---      -- has 2 type parameters: a and b.-      vars = toList $ setOf typeVars args--#if MIN_VERSION_template_haskell(2,15,0)-      (familyName, args) =-        case unfoldType fnArgs of-          (ConT familyName', args') -> (familyName', args')-          (_, _) -> error $ "Illegal data instance LHS: " ++ pprint fnArgs-#endif-  _ -> Nothing---- | A data, newtype, data instance or newtype instance declaration.-data DataDecl = DataDecl-  { dataContext :: Cxt -- ^ Datatype context.-  , tyConName :: Maybe Name-    -- ^ Type constructor name, or Nothing for a data family instance.-  , dataParameters :: [TyVarBndrUnit] -- ^ List of type parameters-  , fullType :: [Type] -> Type-    -- ^ Create a concrete record type given a substitution to-    -- 'detaParameters'.-  , constructors :: [Con] -- ^ Constructors-  -- , derivings :: [Name] -- currently not needed-  }--- -- | Build 'Wrapped' instance for a given newtype makeWrapped :: Name -> DecsQ makeWrapped nm = do-  inf <- reify nm-  case inf of-    TyConI decl -> do-      maybeDecs <- makeWrappedForDec decl-      maybe (fail "makeWrapped: Unsupported data type") return maybeDecs-    _ -> fail "makeWrapped: Expected the name of a newtype or datatype"+  inf <- reifyDatatype nm+  maybeDecs <- makeWrappedForDatatypeInfo inf+  maybe (fail "makeWrapped: Unsupported data type") return maybeDecs -makeWrappedForDec :: Dec -> Q (Maybe [Dec])-makeWrappedForDec decl = case makeDataDecl decl of-  Just dataDecl | [con]   <- constructors dataDecl-                , [field] <- toListOf (conFields._2) con-    -> do wrapped   <- makeWrappedInstance dataDecl con field-          rewrapped <- makeRewrappedInstance dataDecl-          return (Just [rewrapped, wrapped])-  _ -> return Nothing+makeWrappedForDatatypeInfo :: DatatypeInfo -> Q (Maybe [Dec])+makeWrappedForDatatypeInfo dataInfo@(DatatypeInfo{datatypeCons = cons})+  | [conInfo@(ConstructorInfo{constructorFields = fields})] <- cons+  , [field] <- fields+  = do wrapped   <- makeWrappedInstance dataInfo conInfo field+       rewrapped <- makeRewrappedInstance dataInfo+       return (Just [rewrapped, wrapped]) -makeRewrappedInstance :: DataDecl -> DecQ-makeRewrappedInstance dataDecl = do+  | otherwise = return Nothing +makeRewrappedInstance :: DatatypeInfo -> DecQ+makeRewrappedInstance dataInfo = do+    t <- varT <$> newName "t" -   let typeArgs = map (view name) (dataParameters dataDecl)+   let typeArgs = map (view name) (datatypeVars dataInfo)     typeArgs' <- do      m <- freshMap (Set.fromList typeArgs)      return (substTypeVars m typeArgs)         -- Con a b c...-   let appliedType  = return (fullType dataDecl (map VarT typeArgs))+   let appliedType  = return (applyDatatypeToArgs dataInfo (map VarT typeArgs))         -- Con a' b' c'...-       appliedType' = return (fullType dataDecl (map VarT typeArgs'))+       appliedType' = return (applyDatatypeToArgs dataInfo (map VarT typeArgs'))         -- Con a' b' c'... ~ t        eq = AppT. AppT EqualityT <$> appliedType' <*> t@@ -584,14 +515,14 @@    -- instance (Con a' b' c'... ~ t) => Rewrapped (Con a b c...) t    instanceD (cxt [eq]) klass [] -makeWrappedInstance :: DataDecl-> Con -> Type -> DecQ-makeWrappedInstance dataDecl con fieldType = do+makeWrappedInstance :: DatatypeInfo -> ConstructorInfo -> Type -> DecQ+makeWrappedInstance dataInfo conInfo fieldType = do -  let conName = view name con-  let typeArgs = toListOf typeVars (dataParameters dataDecl)+  let conName = constructorName conInfo+  let typeArgs = toListOf typeVars (datatypeVars dataInfo)    -- Con a b c...-  let appliedType  = fullType dataDecl (map VarT typeArgs)+  let appliedType  = applyDatatypeToArgs dataInfo (map VarT typeArgs)    -- type Unwrapped (Con a b c...) = $fieldType   let unwrappedATF = tySynInstDCompat unwrappedTypeName Nothing@@ -610,6 +541,23 @@   --   type Unwrapped (Con a b c...) = fieldType   --   _Wrapped' = iso (\(Con x) -> x) Con   instanceD (cxt []) klass [unwrappedATF, isoMethod]++-- | Apply the 'datatypeName' of a 'DatatypeInfo' to some argument 'Type's,+-- which are used to instantiate its 'datatypeVars'.+applyDatatypeToArgs :: DatatypeInfo -> [Type] -> Type+applyDatatypeToArgs di@(DatatypeInfo { datatypeName = nm+                                     , datatypeVars = vars+                                     , datatypeInstTypes = instTypes+                                     }) args =+  apps (ConT nm) $+  -- Drop kind signatures if possible to reduce the likelihood of needing to+  -- enable KindSignatures. The likelihood is already quite small, however.+  -- This function is only used for the benefit of {make,declare}Wrapped, and+  -- one needs to enable TypeFamilies in order for the generated code to+  -- typecheck. Since TypeFamilies implies KindSignatures, dropping kind+  -- signatures is probably not required, but better to be safe then sorry.+  dropSigsIfNonDataFam di $+  applySubstitution (Map.fromList (zip (map tvName vars) args)) instTypes  overHead :: (a -> a) -> [a] -> [a] overHead _ []     = []
src/Language/Haskell/TH/Lens.hs view
@@ -125,6 +125,9 @@ #if MIN_VERSION_template_haskell(2,15,0)   , _ImplicitParamBindD #endif+#if MIN_VERSION_template_haskell(2,19,0)+  , _DefaultD+#endif #if MIN_VERSION_template_haskell(2,12,0)   -- ** PatSynDir Prisms   , _Unidir@@ -182,6 +185,9 @@ #if MIN_VERSION_template_haskell(2,12,0)   , _CompleteP #endif+#if MIN_VERSION_template_haskell(2,19,0)+  , _OpaqueP+#endif   -- ** Inline Prisms   , _NoInline   , _Inline@@ -249,6 +255,9 @@   , _MDoE   , _ImplicitParamVarE #endif+#if MIN_VERSION_template_haskell(2,19,0)+  , _LamCasesE+#endif   -- ** Body Prisms   , _GuardedB   , _NormalB@@ -337,6 +346,10 @@ #if MIN_VERSION_template_haskell(2,17,0)   , _MulArrowT #endif+#if MIN_VERSION_template_haskell(2,19,0)+  , _PromotedInfixT+  , _PromotedUInfixT+#endif #if MIN_VERSION_template_haskell(2,17,0)   -- ** Specificity Prisms   , _SpecifiedSpec@@ -533,6 +546,14 @@ #if MIN_VERSION_template_haskell(2,17,0)   typeVarsEx _ _ t@MulArrowT{}        = pure t #endif+#if MIN_VERSION_template_haskell(2,19,0)+  typeVarsEx s f (PromotedInfixT  t1 n t2) = PromotedInfixT  <$> typeVarsEx s f t1+                                                             <*> pure n+                                                             <*> typeVarsEx s f t2+  typeVarsEx s f (PromotedUInfixT t1 n t2) = PromotedUInfixT <$> typeVarsEx s f t1+                                                             <*> pure n+                                                             <*> typeVarsEx s f t2+#endif  instance HasTypeVars Con where   typeVarsEx s f (NormalC n ts) = NormalC n <$> traverseOf (traverse . _2) (typeVarsEx s f) ts@@ -605,6 +626,10 @@ #if MIN_VERSION_template_haskell(2,17,0)   substType _ t@MulArrowT{}        = t #endif+#if MIN_VERSION_template_haskell(2,19,0)+  substType m (PromotedInfixT  t1 n t2) = PromotedInfixT  (substType m t1) n (substType m t2)+  substType m (PromotedUInfixT t1 n t2) = PromotedUInfixT (substType m t1) n (substType m t2)+#endif  instance SubstType t => SubstType [t] where   substType = map . substType@@ -1137,6 +1162,16 @@       remitter _ = Nothing #endif +#if MIN_VERSION_template_haskell(2,19,0)+_DefaultD :: Prism' Dec [Type]+_DefaultD+  = prism' reviewer remitter+  where+      reviewer = DefaultD+      remitter (DefaultD x) = Just x+      remitter _ = Nothing+#endif+ #if MIN_VERSION_template_haskell(2,12,0) _Unidir :: Prism' PatSynDir () _Unidir@@ -1462,6 +1497,16 @@       remitter _ = Nothing #endif +#if MIN_VERSION_template_haskell(2,19,0)+_OpaqueP :: Prism' Pragma Name+_OpaqueP+  = prism' reviewer remitter+  where+      reviewer = OpaqueP+      remitter (OpaqueP x) = Just x+      remitter _ = Nothing+#endif+ _NoInline :: Prism' Inline () _NoInline   = prism' reviewer remitter@@ -1932,6 +1977,16 @@       remitter _ = Nothing #endif +#if MIN_VERSION_template_haskell(2,19,0)+_LamCasesE :: Prism' Exp [Clause]+_LamCasesE+  = prism' reviewer remitter+  where+      reviewer = LamCasesE+      remitter (LamCasesE x) = Just x+      remitter _ = Nothing+#endif+ _GuardedB :: Prism' Body [(Guard, Exp)] _GuardedB   = prism' reviewer remitter@@ -2494,6 +2549,24 @@   where       reviewer () = MulArrowT       remitter MulArrowT = Just ()+      remitter _ = Nothing+#endif++#if MIN_VERSION_template_haskell(2,19,0)+_PromotedInfixT :: Prism' Type (Type, Name, Type)+_PromotedInfixT+  = prism' reviewer remitter+  where+      reviewer (x, y, z) = PromotedInfixT x y z+      remitter (PromotedInfixT x y z) = Just (x, y, z)+      remitter _ = Nothing++_PromotedUInfixT :: Prism' Type (Type, Name, Type)+_PromotedUInfixT+  = prism' reviewer remitter+  where+      reviewer (x, y, z) = PromotedUInfixT x y z+      remitter (PromotedUInfixT x y z) = Just (x, y, z)       remitter _ = Nothing #endif 
tests/templates.hs view
@@ -450,5 +450,23 @@ instance AsT866 T865 where   _T866 = __T865 . _T866 +-- {make,declare}Wrapped test cases for ordinary data types+newtype T997A a = MkT997A a+$(makeWrapped ''T997A)++$(declareWrapped [d|+  newtype T997B b = MkT997B b+  |])++-- {make,declare}Wrapped test cases for data family instances (#997)+data family T997FamA a+newtype instance T997FamA a = MkT997FamA a+$(makeWrapped 'MkT997FamA)++$(declareWrapped [d|+  data family T997FamB b+  newtype instance T997FamB b = MkT997FamB b+  |])+ main :: IO () main = putStrLn "test/templates.hs: ok"