Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package ghc-optics-th for openSUSE:Factory checked in at 2021-03-10 08:55:17 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-optics-th (Old) and /work/SRC/openSUSE:Factory/.ghc-optics-th.new.2378 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-optics-th" Wed Mar 10 08:55:17 2021 rev:4 rq:877660 version:0.4 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-optics-th/ghc-optics-th.changes 2020-12-22 11:43:47.089733253 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-optics-th.new.2378/ghc-optics-th.changes 2021-03-10 08:57:22.822896729 +0100 @@ -1,0 +2,21 @@ +Tue Feb 23 18:11:41 UTC 2021 - psim...@suse.com + +- Update optics-th to version 0.4. + # optics-th-0.4 (2021-02-22) + * Add support for GHC-9.0 + * Print missing language extensions during TH generation of labels if there are + any ([#352](https://github.com/well-typed/optics/pull/352)) + * Add support for getters of rank1 polymorphic fields to optics generated with + the `makeFieldLabels` family of functions + ([#365](https://github.com/well-typed/optics/pull/365)) + * Extend support of type-changing optics generated with the `makeFieldLabels` + family to type parameters that are phantom and applied to non-injective type + families + ([#365](https://github.com/well-typed/optics/pull/365)) + * Fix TH generation of optics for poly-kinded data families + ([#378](https://github.com/well-typed/optics/pull/378)) + * Fix `declareFieldLabels` when a field type refers to a type defined in the + same quote + ([#380](https://github.com/well-typed/optics/pull/380)) + +------------------------------------------------------------------- Old: ---- optics-th-0.3.0.2.tar.gz optics-th.cabal New: ---- optics-th-0.4.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-optics-th.spec ++++++ --- /var/tmp/diff_new_pack.Nq50Ne/_old 2021-03-10 08:57:23.426897353 +0100 +++ /var/tmp/diff_new_pack.Nq50Ne/_new 2021-03-10 08:57:23.426897353 +0100 @@ -1,7 +1,7 @@ # # spec file for package ghc-optics-th # -# Copyright (c) 2020 SUSE LLC +# Copyright (c) 2021 SUSE LLC # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,13 +19,12 @@ %global pkg_name optics-th %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.3.0.2 +Version: 0.4 Release: 0 Summary: Optics construction using TemplateHaskell License: BSD-3-Clause URL: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz -Source1: https://hackage.haskell.org/package/%{pkg_name}-%{version}/revision/1.cabal#/%{pkg_name}.cabal BuildRequires: ghc-Cabal-devel BuildRequires: ghc-containers-devel BuildRequires: ghc-mtl-devel @@ -59,7 +58,6 @@ %prep %autosetup -n %{pkg_name}-%{version} -cp -p %{SOURCE1} %{pkg_name}.cabal %build %ghc_lib_build ++++++ optics-th-0.3.0.2.tar.gz -> optics-th-0.4.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-th-0.3.0.2/CHANGELOG.md new/optics-th-0.4/CHANGELOG.md --- old/optics-th-0.3.0.2/CHANGELOG.md 2001-09-09 03:46:40.000000000 +0200 +++ new/optics-th-0.4/CHANGELOG.md 2001-09-09 03:46:40.000000000 +0200 @@ -1,3 +1,20 @@ +# optics-th-0.4 (2021-02-22) +* Add support for GHC-9.0 +* Print missing language extensions during TH generation of labels if there are + any ([#352](https://github.com/well-typed/optics/pull/352)) +* Add support for getters of rank1 polymorphic fields to optics generated with + the `makeFieldLabels` family of functions + ([#365](https://github.com/well-typed/optics/pull/365)) +* Extend support of type-changing optics generated with the `makeFieldLabels` + family to type parameters that are phantom and applied to non-injective type + families + ([#365](https://github.com/well-typed/optics/pull/365)) +* Fix TH generation of optics for poly-kinded data families + ([#378](https://github.com/well-typed/optics/pull/378)) +* Fix `declareFieldLabels` when a field type refers to a type defined in the + same quote + ([#380](https://github.com/well-typed/optics/pull/380)) + # optics-th-0.3.0.2 (2020-08-20) * Fix tests on GHC 8.10.2 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-th-0.3.0.2/optics-th.cabal new/optics-th-0.4/optics-th.cabal --- old/optics-th-0.3.0.2/optics-th.cabal 2001-09-09 03:46:40.000000000 +0200 +++ new/optics-th-0.4/optics-th.cabal 2001-09-09 03:46:40.000000000 +0200 @@ -1,12 +1,12 @@ name: optics-th -version: 0.3.0.2 +version: 0.4 license: BSD3 license-file: LICENSE build-type: Simple maintainer: opt...@well-typed.com author: Andrzej Rybczak cabal-version: 1.24 -tested-with: ghc ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2, GHCJS ==8.4 +tested-with: ghc ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.3, GHCJS ==8.4 synopsis: Optics construction using TemplateHaskell category: Data, Optics, Lenses description: @@ -29,12 +29,12 @@ hs-source-dirs: src ghc-options: -Wall - build-depends: base >= 4.9 && <5 - , containers >= 0.5.7.1 && <0.7 + build-depends: base >= 4.10 && <5 + , containers >= 0.5.10.2 && <0.7 , mtl >= 2.2.2 && <2.3 - , optics-core >= 0.3 && <0.4 - , template-haskell >= 2.11 && <2.17 - , th-abstraction >= 0.2.1 && <0.4 + , optics-core >= 0.4 && <0.5 + , template-haskell >= 2.12 && <2.18 + , th-abstraction >= 0.4 && <0.5 , transformers >= 0.5 && <0.6 exposed-modules: Optics.TH diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-th-0.3.0.2/src/Language/Haskell/TH/Optics/Internal.hs new/optics-th-0.4/src/Language/Haskell/TH/Optics/Internal.hs --- old/optics-th-0.3.0.2/src/Language/Haskell/TH/Optics/Internal.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/optics-th-0.4/src/Language/Haskell/TH/Optics/Internal.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeSynonymInstances #-} module Language.Haskell.TH.Optics.Internal ( -- * Traversals @@ -14,6 +15,9 @@ , _ClosedTypeFamilyD , _OpenTypeFamilyD , _ForallT + + -- * TyVarBndr compatiblity + , TyVarBndrSpec ) where import Data.Map as Map hiding (map, toList) @@ -21,6 +25,7 @@ import Data.Foldable (traverse_) import Data.Set as Set hiding (map, toList) import Language.Haskell.TH +import Language.Haskell.TH.Datatype.TyVarBndr import Data.Set.Optics import Optics.Core @@ -30,10 +35,15 @@ -- | Extract (or modify) the 'Name' of something name :: Lens' t Name -instance HasName TyVarBndr where +instance HasName (TyVarBndr_ flag) where name = lensVL $ \f -> \case +#if MIN_VERSION_template_haskell(2,17,0) + PlainTV n flag -> (\n' -> PlainTV n' flag) <$> f n + KindedTV n flag k -> (\n' -> KindedTV n' flag k ) <$> f n +#else PlainTV n -> PlainTV <$> f n KindedTV n k -> (`KindedTV` k) <$> f n +#endif -- | Provides for the extraction of free type variables, and alpha renaming. class HasTypeVars t where @@ -42,7 +52,7 @@ -- 'Traversal' laws, when in doubt generate your names with 'newName'. typeVarsEx :: Set Name -> Traversal' t Name -instance HasTypeVars TyVarBndr where +instance HasTypeVars (TyVarBndr_ flag) where typeVarsEx s = traversalVL $ \f b -> if view name b `Set.member` s then pure b @@ -159,7 +169,7 @@ remitter (OpenTypeFamilyD x) = Just x remitter _ = Nothing -_ForallT :: Prism' Type ([TyVarBndr], Cxt, Type) +_ForallT :: Prism' Type ([TyVarBndrSpec], Cxt, Type) _ForallT = prism' reviewer remitter where diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-th-0.3.0.2/src/Optics/TH/Internal/Product.hs new/optics-th-0.4/src/Optics/TH/Internal/Product.hs --- old/optics-th-0.3.0.2/src/Optics/TH/Internal/Product.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/optics-th-0.4/src/Optics/TH/Internal/Product.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -35,6 +36,7 @@ import Data.Set.Optics import Language.Haskell.TH.Optics.Internal import Optics.Core hiding (cons) +import Optics.Internal.Magic import Optics.TH.Internal.Utils ------------------------------------------------------------------------ @@ -44,8 +46,13 @@ typeSelf :: Traversal' Type Type typeSelf = traversalVL $ \f -> \case ForallT tyVarBndrs ctx ty -> +#if MIN_VERSION_template_haskell(2,17,0) + let go (KindedTV nam flag kind) = KindedTV <$> pure nam <*> pure flag <*> f kind + go (PlainTV nam flag) = pure (PlainTV nam flag) +#else let go (KindedTV nam kind) = KindedTV <$> pure nam <*> f kind go (PlainTV nam) = pure (PlainTV nam) +#endif in ForallT <$> traverse go tyVarBndrs <*> traverse f ctx <*> f ty AppT ty1 ty2 -> AppT <$> f ty1 <*> f ty2 SigT ty kind -> SigT <$> f ty <*> f kind @@ -84,12 +91,15 @@ case _classyLenses rules tyName of Just (className, methodName) -> makeClassyDriver rules className methodName s defs - Nothing -> do decss <- traverse (makeFieldOptic rules) defs - return (concat decss) + Nothing -> do + when (has (traversed % _1 % _MethodName) defs) $ do + lift requireExtensionsForFields + decss <- traverse (makeFieldOptic rules) defs + return (concat decss) where tyName = D.datatypeName info - s = addKindVars info $ D.datatypeType info + s = addKindInfo info $ D.datatypeType info cons = D.datatypeCons info -- Traverse the field labels of a normalized constructor @@ -135,26 +145,19 @@ -- | Compute the field optics for a deconstructed datatype Dec -- When possible build an Iso otherwise build one optic per field. makeFieldLabelsForDatatype :: LensRules -> D.DatatypeInfo -> Q [Dec] -makeFieldLabelsForDatatype rules info = - do perDef <- do - fieldCons <- traverse (normalizeConstructor info) cons - let allFields = toListOf (folded % _2 % folded % _1 % folded) fieldCons - let defCons = over normFieldLabels (expandName rules tyName cons allFields) fieldCons - allDefs = setOf (normFieldLabels % folded) defCons - T.sequenceA (M.fromSet (buildScaffold True rules s defCons) allDefs) - - let defs = filter isRank1 $ M.toList perDef - traverse (makeFieldLabel rules) defs - +makeFieldLabelsForDatatype rules info = do + requireExtensionsForLabels + perDef <- do + fieldCons <- traverse (normalizeConstructor info) cons + let allFields = toListOf (folded % _2 % folded % _1 % folded) fieldCons + let defCons = over normFieldLabels (expandName rules tyName cons allFields) fieldCons + allDefs = setOf (normFieldLabels % folded) defCons + T.sequenceA (M.fromSet (buildScaffold True rules s defCons) allDefs) + let defs = M.toList perDef + traverse (makeFieldLabel info rules) defs where - -- LabelOptic doesn't support higher rank fields because of functional - -- dependencies (s -> a, t -> b), so just skip them. - isRank1 = \case - (_, (OpticSa vs _ _ _ _, _)) -> null vs - _ -> True - tyName = D.datatypeName info - s = addKindVars info $ D.datatypeType info + s = addKindInfo info $ D.datatypeType info cons = D.datatypeCons info -- Traverse the field labels of a normalized constructor @@ -162,23 +165,38 @@ normFieldLabels = traversed % _2 % traversed % _1 makeFieldLabel - :: LensRules + :: D.DatatypeInfo + -> LensRules -> (DefName, (OpticStab, [(Name, Int, [Int])])) -> Q Dec -makeFieldLabel rules (defName, (defType, cons)) = do +makeFieldLabel info rules (defName, (defType, cons)) = do (context, instHead) <- case defType of - OpticSa _ _ otype s a -> do + OpticSa vs cx otype s a0 -> do + -- 'tv' might have info about type variables of 'a' that need filling in. + let a = addKindInfo' (map tyVarBndrToType vs) info a0 (k, cxtK) <- eqSubst (ConT $ opticTypeToTag otype) "k" (a', cxtA) <- eqSubst a "a" (b', cxtB) <- eqSubst a "b" - pure (pure [cxtK, cxtA, cxtB], pure $ conAppsT ''LabelOptic - [LitT (StrTyLit fieldName), k, s, s, a', b']) - OpticStab otype s t a b -> do + let tyArgs = [LitT (StrTyLit fieldName), k, s, s, a', b'] + context = concat + [ -- If the field is polymorphic, the instance is dysfunctional. + if null vs then [] else [conAppsT ''Dysfunctional tyArgs] + , [cxtK, cxtA, cxtB] + , cx + ] + pure (pure context, pure $ conAppsT ''LabelOptic tyArgs) + OpticStab tvsCovered otype s t a b -> do (k, cxtK) <- eqSubst (ConT $ opticTypeToTag otype) "k" (a', cxtA) <- eqSubst a "a" (b', cxtB) <- eqSubst b "b" - pure (pure [cxtK, cxtA, cxtB], pure $ conAppsT ''LabelOptic - [LitT (StrTyLit fieldName), k, s, t, a', b']) + let tyArgs = [LitT (StrTyLit fieldName), k, s, t, a', b'] + context = concat + [ -- If some of the type variables are not covered, the instance is + -- dysfunctional. + if tvsCovered then [] else [conAppsT ''Dysfunctional tyArgs] + , [cxtK, cxtA, cxtB] + ] + pure (pure context, pure $ conAppsT ''LabelOptic tyArgs) instanceD context instHead (fun 'labelOptic) where opticTypeToTag AffineFoldType = ''An_AffineFold @@ -221,11 +239,11 @@ -- elligible for TH generated optics. checkForExistentials _ fieldtype | any (\tv -> D.tvName tv `S.member` used) unallowable - = (Nothing, addKindVars info fieldtype) + = (Nothing, addKindInfo info fieldtype) where used = setOf typeVars fieldtype unallowable = D.constructorVars con - checkForExistentials fieldname fieldtype = (fieldname, addKindVars info fieldtype) + checkForExistentials fieldname fieldtype = (fieldname, addKindInfo info fieldtype) -- | Compute the positional location of the fields involved in -- each constructor for a given optic definition as well as the @@ -241,29 +259,30 @@ {- ^ optic type, definition type, field count, target fields -} buildScaffold forClassInstance rules s cons defName = - do (s',t,a,b) <- buildStab forClassInstance s (concatMap snd consForDef) + do (t,a,b, tvsCovered) <- buildTab forClassInstance s $ + concatMap snd consForDef let defType | Just (tyvars, cx, a') <- preview _ForallT a = let optic | lensCase = GetterType | affineCase = AffineFoldType | otherwise = FoldType - in OpticSa tyvars cx optic s' a' + in OpticSa tyvars cx optic s a' -- Getter and Fold are always simple | not (_allowUpdates rules) = let optic | lensCase = GetterType | affineCase = AffineFoldType | otherwise = FoldType - in OpticSa [] [] optic s' a + in OpticSa [] [] optic s a -- Generate simple Lens and Traversal where possible - | _simpleLenses rules || s' == t && a == b = + | _simpleLenses rules || s == t && a == b = let optic | isoCase && _allowIsos rules = IsoType | lensCase = LensType | affineCase = AffineTraversalType | otherwise = TraversalType - in OpticSa [] [] optic s' a + in OpticSa [] [] optic s a -- Generate type-changing Lens and Traversal otherwise | otherwise = @@ -271,7 +290,7 @@ | lensCase = LensType | affineCase = AffineTraversalType | otherwise = TraversalType - in OpticStab optic s' t a b + in OpticStab tvsCovered optic s t a b return (defType, scaffolds) where @@ -333,12 +352,12 @@ else ''Traversal' data OpticStab - = OpticStab OpticType Type Type Type Type - | OpticSa [TyVarBndr] Cxt OpticType Type Type + = OpticStab Bool OpticType Type Type Type Type + | OpticSa [TyVarBndrSpec] Cxt OpticType Type Type deriving Show stabToType :: OpticStab -> Type -stabToType (OpticStab c s t a b) = +stabToType (OpticStab _ c s t a b) = quantifyType [] [] (opticTypeName True c `conAppsT` [s,t,a,b]) stabToType (OpticSa vs cx c s a) = quantifyType vs cx (opticTypeName False c `conAppsT` [s,a]) @@ -348,31 +367,33 @@ stabToContext (OpticSa _ cx _ _ _) = cx stabToOpticType :: OpticStab -> OpticType -stabToOpticType (OpticStab c _ _ _ _) = c +stabToOpticType (OpticStab _ c _ _ _ _) = c stabToOpticType (OpticSa _ _ c _ _) = c stabToOptic :: OpticStab -> Name -stabToOptic (OpticStab c _ _ _ _) = opticTypeName True c +stabToOptic (OpticStab _ c _ _ _ _) = opticTypeName True c stabToOptic (OpticSa _ _ c _ _) = opticTypeName False c stabToS :: OpticStab -> Type -stabToS (OpticStab _ s _ _ _) = s +stabToS (OpticStab _ _ s _ _ _) = s stabToS (OpticSa _ _ _ s _) = s stabToA :: OpticStab -> Type -stabToA (OpticStab _ _ _ a _) = a +stabToA (OpticStab _ _ _ _ a _) = a stabToA (OpticSa _ _ _ _ a) = a --- | Compute the s t a b types given the outer type 's' and the +-- | Compute the t a b types given the outer type 's' and the -- categorized field types. Left for fixed and Right for visited. -- These types are "raw" and will be packaged into an 'OpticStab' -- shortly after creation. -buildStab :: Bool -> Type -> [Either Type Type] -> Q (Type,Type,Type,Type) -buildStab forClassInstance s categorizedFields = do - -- compute possible type changes - sub <- T.sequenceA . M.fromSet (newName . nameBase) =<< unfixedTypeVars +buildTab :: Bool -> Type -> [Either Type Type] -> Q (Type,Type,Type,Bool) +buildTab forClassInstance s categorizedFields = do + -- Compute possible type changes and check whether we have to lift the + -- coverage condition in case we're generating a class instance. + (unfixedTypeVars, tvsCovered) <- mkUnfixedTypeVars + sub <- T.sequenceA $ M.fromSet (newName . nameBase) unfixedTypeVars let (t, b) = over each (substTypeVars sub) (s, a) - pure (s, t, a, b) + pure (t, a, b, tvsCovered) where -- Just take the type of the first field and let GHC do the unification. a = fromMaybe @@ -385,7 +406,11 @@ (fixedFields, targetFields) = partitionEithers categorizedFields - unfixedTypeVars + mkUnfixedTypeVars + | S.null freeTypeVars = + -- If there are no free type vars, don't bother searching for ambiguous + -- type family applications because there are none. + pure (S.empty, True) | forClassInstance = do ambiguousTypeVars <- getAmbiguousTypeFamilyTypeVars --runIO $ do @@ -395,10 +420,10 @@ -- putStrLn $ "FIXED: " ++ show fixedTypeVars -- putStrLn $ "PHANTOM: " ++ show phantomTypeVars -- putStrLn $ "AMBIGUOUS: " ++ show ambiguousTypeVars - pure $ freeTypeVars S.\\ fixedTypeVars - S.\\ phantomTypeVars - S.\\ ambiguousTypeVars - | otherwise = pure $ freeTypeVars S.\\ fixedTypeVars + pure ( freeTypeVars S.\\ fixedTypeVars + , S.null phantomTypeVars && S.null ambiguousTypeVars + ) + | otherwise = pure (freeTypeVars S.\\ fixedTypeVars, True) where freeTypeVars = setOf typeVars s fixedTypeVars = setOf typeVars fixedFields @@ -421,7 +446,7 @@ go (ConT nm) = do let getVarLen = afolding $ \tf@(TypeFamilyHead _ varBndrs _ _) -> if null varBndrs then Nothing else Just (length varBndrs, tf, []) - preview (_FamilyI % _1 % typeFamilyHead % getVarLen) <$> lift (reify nm) + tryReify (preview $ _FamilyI % _1 % typeFamilyHead % getVarLen) nm go (AppT ty1 ty2) = go ty1 >>= \case Just (n, tf, !args) @@ -433,18 +458,23 @@ go _ = pure Nothing procInfix ty1 nm ty2 = do - mtf <- preview (_FamilyI % _1 % typeFamilyHead) <$> lift (reify nm) + mtf <- tryReify (preview $ _FamilyI % _1 % typeFamilyHead) nm case mtf of Just tf -> procTF tf [ty1, ty2] Nothing -> go ty1 *> go ty2 *> pure () + -- If reification fails (e.g. because the type contains local names), + -- assume there are no type families (the best we can do really). + tryReify :: (Info -> Maybe a) -> Name -> StateT (S.Set Name) Q (Maybe a) + tryReify f nm = lift $ recover (pure Nothing) (f <$> reify nm) + -- Once fully applied type family is collected, the only arguments that -- should be traversed further are these with injectivity annotation. procTF :: TypeFamilyHead -> [Type] -> StateT (S.Set Name) Q () procTF tf args = case tf of TypeFamilyHead _ varBndrs _ (Just (InjectivityAnn _ ins)) -> do let insSet = S.fromList ins - vars = map bndrName varBndrs + vars = map D.tvName varBndrs --lift . runIO $ do -- putStrLn $ "INS: " ++ show ins -- putStrLn $ "VARS: " ++ show vars @@ -528,7 +558,7 @@ | otherwise = [FunDep [c] vars] - classD (cxt[]) className (map PlainTV (c:vars)) fd + classD (cxt[]) className (map plainTV (c:vars)) fd $ sigD methodName (return (''Lens' `conAppsT` [VarT c, s])) : concat [ [sigD defName (return ty) @@ -572,7 +602,7 @@ makeFieldClass :: OpticStab -> Name -> Name -> DecQ makeFieldClass defType className methodName = - classD (cxt []) className [PlainTV s, PlainTV a] [FunDep [s] [a]] + classD (cxt []) className [plainTV s, plainTV a] [FunDep [s] [a]] [sigD methodName (return methodType)] where methodType = quantifyType' (S.fromList [s,a]) @@ -879,6 +909,11 @@ | MethodName Name Name -- ^ makeFields-style class name and method name deriving (Show, Eq, Ord) +_MethodName :: Prism' DefName (Name, Name) +_MethodName = prism' (uncurry MethodName) $ \case + TopName{} -> Nothing + MethodName c n -> Just (c, n) + -- | The optional rule to create a class and method around a -- monomorphic data type. If this naming convention is provided, it -- generates a "classy" lens. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-th-0.3.0.2/src/Optics/TH/Internal/Sum.hs new/optics-th-0.4/src/Optics/TH/Internal/Sum.hs --- old/optics-th-0.3.0.2/src/Optics/TH/Internal/Sum.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/optics-th-0.4/src/Optics/TH/Internal/Sum.hs 2001-09-09 03:46:40.000000000 +0200 @@ -11,6 +11,7 @@ import Data.Maybe import Data.Traversable import Language.Haskell.TH +import Language.Haskell.TH.Datatype.TyVarBndr import qualified Data.Map as M import qualified Data.Set as S import qualified Language.Haskell.TH.Datatype as D @@ -18,6 +19,7 @@ import Data.Set.Optics import Language.Haskell.TH.Optics.Internal import Optics.Core hiding (cons) +import Optics.Internal.Magic import Optics.TH.Internal.Utils -- | Generate a 'Prism' for each constructor of a data type. Isos generated when @@ -82,29 +84,31 @@ makePrismLabels :: Name -> DecsQ makePrismLabels typeName = do + requireExtensionsForLabels info <- D.reifyDatatype typeName let cons = map (normalizeCon info) $ D.datatypeCons info catMaybes <$> traverse (makeLabel info cons) cons where makeLabel :: D.DatatypeInfo -> [NCon] -> NCon -> Q (Maybe Dec) makeLabel info cons con = do - stab@(Stab cx otype s t a b) <- computeOpticType labelConfig ty cons con - case otype of - -- Reviews are for existentially quantified types and these don't fit - -- into OpticLabel because of functional dependencies, just skip them. - ReviewType -> pure Nothing - _ -> do - (k, cxtK) <- eqSubst (ConT $ opticTypeToTag otype) "k" - (a', cxtA) <- eqSubst a "a" - (b', cxtB) <- eqSubst b "b" - let label = nameBase . prismName $ view nconName con - instHead = pure $ conAppsT ''LabelOptic - [LitT (StrTyLit label), k, s, t, a', b'] - Just <$> instanceD (pure $ cx ++ [cxtK, cxtA, cxtB]) - instHead - (fun stab 'labelOptic) + stab@(Stab tvsCovered cx otype s t a b) <- computeOpticType labelConfig ty cons con + (k, cxtK) <- eqSubst (ConT $ opticTypeToTag otype) "k" + (a', cxtA) <- eqSubst a "a" + (b', cxtB) <- eqSubst b "b" + let label = nameBase . prismName $ view nconName con + tyArgs = [LitT (StrTyLit label), k, s, t, a', b'] + context = concat + [ -- If some of the type variables are not covered, instance is + -- dysfunctional. + if tvsCovered then [] else [conAppsT ''Dysfunctional tyArgs] + , [cxtK, cxtA, cxtB] + , cx + ] + Just <$> instanceD (pure context) + (pure $ conAppsT ''LabelOptic tyArgs) + (fun stab 'labelOptic) where - ty = addKindVars info $ D.datatypeType info + ty = addKindInfo info $ D.datatypeType info isNewtype = D.datatypeVariant info == D.Newtype opticTypeToTag IsoType = ''An_Iso @@ -156,7 +160,7 @@ , valD (varP n) (normalB body) [] ] ++ inlinePragma n where - ty = addKindVars info $ D.datatypeType info + ty = addKindInfo info $ D.datatypeType info isNewtype = D.datatypeVariant info == D.Newtype -- classy prism class and instance @@ -173,41 +177,42 @@ ---------------------------------------- data StabConfig = StabConfig - { scAllowPhantomsChange :: Bool - , scAllowIsos :: Bool + { scForLabelInstance :: Bool + , scAllowIsos :: Bool } defaultConfig :: StabConfig defaultConfig = StabConfig - { scAllowPhantomsChange = True - , scAllowIsos = True + { scForLabelInstance = False + , scAllowIsos = True } classyConfig :: StabConfig classyConfig = StabConfig - { scAllowPhantomsChange = True - , scAllowIsos = False + { scForLabelInstance = False + , scAllowIsos = False } labelConfig :: StabConfig labelConfig = StabConfig - { scAllowPhantomsChange = False - , scAllowIsos = True + { scForLabelInstance = True + , scAllowIsos = True } data OpticType = IsoType | PrismType | ReviewType -data Stab = Stab Cxt OpticType Type Type Type Type + deriving Eq +data Stab = Stab Bool Cxt OpticType Type Type Type Type simplifyStab :: Stab -> Stab -simplifyStab (Stab cx ty _ t _ b) = Stab cx ty t t b b +simplifyStab (Stab tvsCovered cx ty _ t _ b) = Stab tvsCovered cx ty t t b b -- simplification uses t and b because those types -- are interesting in the Review case stabSimple :: Stab -> Bool -stabSimple (Stab _ _ s t a b) = s == t && a == b +stabSimple (Stab _ _ _ s t a b) = s == t && a == b stabToType :: Stab -> Type -stabToType stab@(Stab cx ty s t a b) = ForallT vs cx $ +stabToType stab@(Stab _ cx ty s t a b) = ForallT vs cx $ case ty of IsoType | stabSimple stab -> ''Iso' `conAppsT` [s,a] | otherwise -> ''Iso `conAppsT` [s,t,a,b] @@ -216,12 +221,13 @@ ReviewType -> ''Review `conAppsT` [t,b] where - vs = D.freeVariablesWellScoped + vs = changeTVFlags SpecifiedSpec + . D.freeVariablesWellScoped . S.toList $ setOf (folded % typeVarsKinded) cx stabType :: Stab -> OpticType -stabType (Stab _ o _ _ _ _) = o +stabType (Stab _ _ o _ _ _ _) = o computeOpticType :: StabConfig -> Type -> [NCon] -> NCon -> Q Stab computeOpticType conf t cons con = @@ -230,11 +236,10 @@ then computePrismType conf t (view nconCxt con) cons' con else computeReviewType t (view nconCxt con) (view nconTypes con) - computeReviewType :: Type -> Cxt -> [Type] -> Q Stab computeReviewType t cx tys = do b <- toTupleT (map return tys) - return (Stab cx ReviewType t t b b) + return (Stab False cx ReviewType t t b b) -- | Compute the full type-changing Prism type given an outer type, list of -- constructors, and target constructor name. @@ -244,9 +249,11 @@ free = setOf typeVars s fixed = setOf typeVars cons phantoms = free S.\\ setOf (folded % nconTypes % typeVars) (con : cons) - unbound = if scAllowPhantomsChange conf - then free S.\\ fixed - else free S.\\ fixed S.\\ phantoms + + unbound = free S.\\ fixed + tvsCovered = if scForLabelInstance conf + then S.null phantoms + else True sub <- sequenceA (M.fromSet (newName . nameBase) unbound) a <- toTupleT (map return ts) b <- toTupleT (map return (substTypeVars sub ts)) @@ -262,7 +269,7 @@ otype = if null cons && scAllowIsos conf then IsoType else PrismType - return (Stab cx' otype s t a b) + return (Stab tvsCovered cx' otype s t a b) -- | Construct either a Review or Prism as appropriate makeConOpticExp :: Stab -> [NCon] -> NCon -> ExpQ @@ -403,15 +410,15 @@ do r <- newName "r" let methodType = appsT (conT ''Prism') [varT r,return t] methodss <- traverse (mkMethod (VarT r)) cons' - classD (cxt[]) className (map PlainTV (r : vs)) (fds r) + classD (cxt[]) className (map plainTV (r : vs)) (fds r) ( sigD methodName methodType : map return (concat methodss) ) where mkMethod r con = - do Stab cx o _ _ _ b <- computeOpticType classyConfig t cons con - let stab' = Stab cx o r r b b + do Stab tvsCovered cx o _ _ _ b <- computeOpticType classyConfig t cons con + let stab' = Stab tvsCovered cx o r r b b defName = view nconName con body = appsE [varE '(%), varE methodName, varE defName] sequenceA @@ -467,7 +474,7 @@ , _nconCxt :: Cxt , _nconTypes :: [Type] } - deriving (Eq) + deriving (Eq, Show) instance HasTypeVars NCon where typeVarsEx s = traversalVL $ \f (NCon x vars y z) -> @@ -487,10 +494,13 @@ -- | Normalize a single 'Con' to its constructor name and field types. normalizeCon :: D.DatatypeInfo -> D.ConstructorInfo -> NCon -normalizeCon di info = NCon (D.constructorName info) - (D.tvName <$> D.constructorVars info) - (D.constructorContext info) - (map (addKindVars di) $ D.constructorFields info) +normalizeCon di info = NCon + { _nconName = D.constructorName info + , _nconVars = D.tvName <$> D.constructorVars info + , _nconCxt = D.constructorContext info + , _nconTypes = let tyVars = map tyVarBndrToType (D.constructorVars info) + in addKindInfo' tyVars di <$> D.constructorFields info + } -- | Compute a prism's name by prefixing an underscore for normal diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-th-0.3.0.2/src/Optics/TH/Internal/Utils.hs new/optics-th-0.4/src/Optics/TH/Internal/Utils.hs --- old/optics-th-0.3.0.2/src/Optics/TH/Internal/Utils.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/optics-th-0.4/src/Optics/TH/Internal/Utils.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,7 +1,10 @@ module Optics.TH.Internal.Utils where +import Control.Monad import Data.Maybe +import Data.List import Language.Haskell.TH +import Language.Haskell.TH.Datatype.TyVarBndr import qualified Data.Map as M import qualified Data.Set as S import qualified Language.Haskell.TH.Datatype as D @@ -37,11 +40,6 @@ conAppsT :: Name -> [Type] -> Type conAppsT conName = foldl AppT (ConT conName) --- | Return 'Name' contained in a 'TyVarBndr'. -bndrName :: TyVarBndr -> Name -bndrName (PlainTV n ) = n -bndrName (KindedTV n _) = n - -- | Generate many new names from a given base name. newNames :: String {- ^ base name -} -> Int {- ^ count -} -> Q [Name] newNames base n = sequence [ newName (base++show i) | i <- [1..n] ] @@ -55,31 +53,101 @@ placeholder <- VarT <$> newName n pure (placeholder, D.equalPred placeholder ty) +addKindInfo :: D.DatatypeInfo -> Type -> Type +addKindInfo = addKindInfo' [] + -- | Fill in kind variables using info from datatype type parameters. -addKindVars :: D.DatatypeInfo -> Type -> Type -addKindVars = substType . M.fromList . mapMaybe var . D.datatypeInstTypes +addKindInfo' :: [Type] -> D.DatatypeInfo -> Type -> Type +addKindInfo' additionalInfo di = + substType . M.fromList . mapMaybe var $ additionalInfo ++ D.datatypeInstTypes di where + -- If the type is a data/newtype family instance, we need to fill in all of + -- the kinds for weird cases such as: + -- + -- data family KDF (a :: k) + -- data instance KDF (a :: Type) = Kinded3 { _kdf :: Proxy a } + -- + -- Otherwise we only need info about kind variables. + -- + -- More info at https://github.com/ekmett/lens/pull/945. + isDataFamily = D.datatypeVariant di == D.DataInstance + || D.datatypeVariant di == D.NewtypeInstance + var t@(SigT (VarT n) k) + | isDataFamily = Just (n, t) | has typeVars k = Just (n, t) | otherwise = Nothing var _ = Nothing -- | Template Haskell wants type variables declared in a forall, so -- we find all free type variables in a given type and declare them. -quantifyType :: [TyVarBndr] -> Cxt -> Type -> Type +quantifyType :: [TyVarBndrSpec] -> Cxt -> Type -> Type quantifyType = quantifyType' S.empty -- | This function works like 'quantifyType' except that it takes -- a list of variables to exclude from quantification. -quantifyType' :: S.Set Name -> [TyVarBndr] -> Cxt -> Type -> Type +quantifyType' :: S.Set Name -> [TyVarBndrSpec] -> Cxt -> Type -> Type quantifyType' exclude vars cx t = ForallT vs cx t where - vs = filter (\v -> bndrName v `S.notMember` exclude) + vs = filter (\v -> D.tvName v `S.notMember` exclude) + . changeTVFlags SpecifiedSpec . D.freeVariablesWellScoped - $ map bndrToType vars ++ S.toList (setOf typeVarsKinded t) + $ map tyVarBndrToType vars ++ S.toList (setOf typeVarsKinded t) + +-- | Transform 'TyVarBndr' into a 'Type' so it's suitable e.g. for +-- freeVariablesWellScoped or type substitution. +tyVarBndrToType :: TyVarBndr_ flag -> Type +tyVarBndrToType = elimTV VarT (\n k -> SigT (VarT n) k) + +-- | Pass in a list of lists of extensions, where any of the given extensions +-- will satisfy it. For example, you might need either GADTs or +-- ExistentialQuantification, so you'd write: +-- +-- > requireExtensions [[GADTs, ExistentialQuantification]] +-- +-- But if you need TypeFamilies and MultiParamTypeClasses, then you'd write: +-- +-- > requireExtensions [[TypeFamilies], [MultiParamTypeClasses]] +-- +requireExtensions :: String -> [[Extension]] -> Q () +requireExtensions what extLists = do + -- Taken from the persistent library + required <- filterM (fmap (not . or) . traverse isExtEnabled) extLists + case mapMaybe listToMaybe required of + [] -> pure () + [extension] -> fail $ mconcat + [ "Generating " ++ what ++ " requires the " + , show extension + , " language extension. Please enable it by copy/pasting this line to the top of your file:\n\n" + , extensionToPragma extension + , "\n\nTo enable it in a GHCi session, use the following command:\n\n" + , ":seti -X" ++ show extension + ] + extensions -> fail $ mconcat + [ "Generating " ++ what ++ " requires the following language extensions:\n\n" + , intercalate "\n" (map (("- " ++) . show) extensions) + , "\n\nPlease enable the extensions by copy/pasting these lines into the top of your file:\n\n" + , intercalate "\n" (map extensionToPragma extensions) + , "\n\nTo enable them in a GHCi session, use the following command:\n\n" + , ":seti " ++ unwords (map (("-X" ++) . show) extensions) + ] + where + extensionToPragma ext = "{-# LANGUAGE " ++ show ext ++ " #-}" - bndrToType (PlainTV n) = VarT n - bndrToType (KindedTV n k) = SigT (VarT n) k +requireExtensionsForLabels :: Q () +requireExtensionsForLabels = requireExtensions "LabelOptic instances" + [ [DataKinds] + , [FlexibleInstances] + , [MultiParamTypeClasses] + , [TypeFamilies, GADTs] + , [UndecidableInstances] + ] + +requireExtensionsForFields :: Q () +requireExtensionsForFields = requireExtensions "field optics" + [ [FlexibleInstances] + , [FunctionalDependencies] + ] ------------------------------------------------------------------------ -- Support for generating inline pragmas diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-th-0.3.0.2/src/Optics/TH.hs new/optics-th-0.4/src/Optics/TH.hs --- old/optics-th-0.3.0.2/src/Optics/TH.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/optics-th-0.4/src/Optics/TH.hs 2001-09-09 03:46:40.000000000 +0200 @@ -3,6 +3,7 @@ -- * Generation of field optics -- ** Labels makeFieldLabels + , makeFieldLabelsNoPrefix , makeFieldLabelsFor , makeFieldLabelsWith , declareFieldLabels @@ -124,13 +125,21 @@ -- labelOptic = atraversalVL $ \\point f s -> case s of -- Cat x1 x2 -> fmap (\\y -> Cat x1 y) (f x2) -- Dog x1 x2 -> point (Dog x1 x2) +-- +-- instance +-- ( Dysfunctional "absurd" k Animal Animal a b +-- , k ~ An_AffineFold, a ~ (x -> y), b ~ (x -> y) +-- ) => LabelOptic "absurd" k Animal Animal a b where +-- labelOptic = afolding $ \\s -> case s of +-- Cat _ _ -> Nothing +-- Dog _ f -> Just f -- @ -- --- which can be used as @#age@ and @#name@ with the @OverloadedLabels@ language --- extension. +-- which can be used as @#age@, @#name@ and @#absurd@ with the +-- @OverloadedLabels@ language extension. -- --- /Note:/ if you wonder about the form of instances or why there is no label for --- @animalAbsurd@, see "Optics.Label#limitations". +-- /Note:/ if you wonder about the structure of instances, see +-- "Optics.Label#structure". -- -- @ -- 'makeFieldOptics' = 'makeFieldLabelsWith' 'fieldLabelsRules' @@ -138,6 +147,10 @@ makeFieldLabels :: Name -> DecsQ makeFieldLabels = makeFieldLabelsWith fieldLabelsRules +-- | An alias for @makeFieldLabels noPrefixFieldLabels@. +makeFieldLabelsNoPrefix :: Name -> DecsQ +makeFieldLabelsNoPrefix = makeFieldLabelsWith noPrefixFieldLabels + -- | Derive field optics as labels, specifying explicit pairings of @(fieldName, -- labelName)@. -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-th-0.3.0.2/tests/Optics/TH/Tests.hs new/optics-th-0.4/tests/Optics/TH/Tests.hs --- old/optics-th-0.3.0.2/tests/Optics/TH/Tests.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/optics-th-0.4/tests/Optics/TH/Tests.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} @@ -67,7 +68,7 @@ checkPairEq_ :: (Eq a', Eq b') - => Iso (PairEq a b c) (PairEq a' b' c) (a, b) (a', b') + => Iso (PairEq a b c) (PairEq a' b' c') (a, b) (a', b') checkPairEq_ = #_PairEq data Brr a where @@ -97,15 +98,13 @@ checkBzztShow :: Show a => Prism (Bzzt a b c) (Bzzt a b c') a a checkBzztShow = _BzztShow --- We can't change b because of LabelOptic fundeps. -checkBzztShow_ :: Show a => Prism' (Bzzt a b c) a +checkBzztShow_ :: Show a => Prism (Bzzt a b c) (Bzzt a b c') a a checkBzztShow_ = #_BzztShow checkBzztRead :: Read b => Prism (Bzzt a b c) (Bzzt a b c') b b checkBzztRead = _BzztRead --- We can't change b because of LabelOptic fundeps. -checkBzztRead_ :: Read b => Prism' (Bzzt a b c) b +checkBzztRead_ :: Read b => Prism (Bzzt a b c) (Bzzt a b c') b b checkBzztRead_ = #_BzztRead data FooX a where @@ -116,15 +115,13 @@ checkFooX1 :: Prism (FooX a) (FooX b) (Int, Int) (Int, Int) checkFooX1 = _FooX1 --- We can't change a because of LabelOptic fundeps. -checkFooX1_ :: Prism' (FooX a) (Int, Int) +checkFooX1_ :: Prism (FooX a) (FooX b) (Int, Int) (Int, Int) checkFooX1_ = #_FooX1 checkFooX2 :: Prism (FooX a) (FooX b) (Int, Int) (Int, Int) checkFooX2 = _FooX2 --- We can't change a because of LabelOptic fundeps. -checkFooX2_ :: Prism' (FooX a) (Int, Int) +checkFooX2_ :: Prism (FooX a) (FooX b) (Int, Int) (Int, Int) checkFooX2_ = #_FooX2 data ClassyTest = ClassyT1 Int | ClassyT2 String | ClassyT3 Char @@ -173,9 +170,11 @@ checkWeird2 = _Weird2 checkWeird2_ - :: forall (a :: Type -> Type) - (b :: Type -> Type) - . Iso (Weird2 a b) (Weird2 a b) () () + :: forall k (a :: k -> Type) + (b :: k -> Type) + (a' :: Type -> Type) + (b' :: Type -> Type) + . Iso (Weird2 a b) (Weird2 a' b') () () checkWeird2_ = #_Weird2 data Weird3 (a :: k) where @@ -186,7 +185,7 @@ checkWeird3 :: forall k (a :: k) (b :: Type). Iso (Weird3 a) (Weird3 b) () () checkWeird3 = _Weird3 -checkWeird3_ :: forall (a :: Type). Iso (Weird3 a) (Weird3 a) () () +checkWeird3_ :: forall k (a :: k) (b :: Type). Iso (Weird3 a) (Weird3 b) () () checkWeird3_ = #_Weird3 ---------------------------------------- @@ -198,8 +197,7 @@ checkBaz :: Iso (Bar a b c) (Bar a' b' c') (a, b) (a', b') checkBaz = baz --- We can't change c because of LabelOptic fundeps. -checkBaz_ :: Iso (Bar a b c) (Bar a' b' c) (a, b) (a', b') +checkBaz_ :: Iso (Bar a b c) (Bar a' b' c') (a, b) (a', b') checkBaz_ = #baz data Quux a b = Quux { _quaffle :: Int, _quartz :: Double } @@ -209,15 +207,13 @@ checkQuaffle :: Lens (Quux a b) (Quux a' b') Int Int checkQuaffle = quaffle --- We can't change a and b because of LabelOptic fundeps. -checkQuaffle_ :: Lens (Quux a b) (Quux a b) Int Int +checkQuaffle_ :: Lens (Quux a b) (Quux a' b') Int Int checkQuaffle_ = #quaffle checkQuartz :: Lens (Quux a b) (Quux a' b') Double Double checkQuartz = quartz --- We can't change a and b because of LabelOptic fundeps. -checkQuartz_ :: Lens (Quux a b) (Quux a b) Double Double +checkQuartz_ :: Lens (Quux a b) (Quux a' b') Double Double checkQuartz_ = #quartz data Quark a = Qualified { _gaffer :: a } @@ -289,9 +285,15 @@ checkAbsurdity1 :: Eq x => Getter (Perambulation a b) (x -> y) checkAbsurdity1 = absurdity1 +checkAbsurdity1_ :: Eq x => Getter (Perambulation a b) (x -> y) +checkAbsurdity1_ = #absurdity1 + checkAbsurdity2 :: Eq x => AffineFold (Perambulation a b) (x -> y) checkAbsurdity2 = absurdity2 +checkAbsurdity2_ :: Eq x => AffineFold (Perambulation a b) (x -> y) +checkAbsurdity2_ = #absurdity2 + checkDunes :: AffineTraversal' (Perambulation a b) a checkDunes = dunes @@ -507,10 +509,14 @@ { _kinded0Thing :: forall a. Proxy (a :: k) } makeLenses ''Kinded0 +makeFieldLabelsWith lensRules ''Kinded0 checkKinded0Thing :: Getter (Kinded0 k) (Proxy (a :: k)) checkKinded0Thing = kinded0Thing +checkKinded0Thing_ :: Getter (Kinded0 k) (Proxy (a :: k)) +checkKinded0Thing_ = #kinded0Thing + data Kinded1 (a :: k1) (b :: k2) = Kinded { _kinded1Thing :: Tagged '(a, b) Int } @@ -533,6 +539,17 @@ (Proxy (a' :: k')) checkKinded2Thing = #thing +data family KDF (a :: k) +data instance KDF (a :: Type) = Kinded3 { _kdf :: Proxy a } +makeLenses 'Kinded3 +makeFieldLabelsWith lensRules 'Kinded3 + +checkKdf :: forall (a :: Type) (b :: Type). Iso (KDF a) (KDF b) (Proxy a) (Proxy b) +checkKdf = kdf + +checkKdf_ :: forall (a :: Type) (b :: Type). Iso (KDF a) (KDF b) (Proxy a) (Proxy b) +checkKdf_ = #kdf + type family Fam0 type family Fam (a :: k) @@ -554,7 +571,7 @@ data FamRec2 a b = FamRec2 { _famRec2Thing :: FamInj1 a b } makeFieldLabels ''FamRec2 -checkFamRec2Thing :: Iso (FamRec2 a b) (FamRec2 a' b) (FamInj1 a b) (FamInj1 a' b) +checkFamRec2Thing :: Iso (FamRec2 a b) (FamRec2 a' b') (FamInj1 a b) (FamInj1 a' b') checkFamRec2Thing = #thing type family a :#: b = r | r -> b @@ -563,15 +580,14 @@ data FamRec3 a b = FamRec3 { _famRec3Thing :: a :#: b } makeFieldLabels ''FamRec3 -checkFamRec3Thing :: Iso (FamRec3 a b) (FamRec3 a b') (a :#: b) (a :#: b') +checkFamRec3Thing :: Iso (FamRec3 a b) (FamRec3 a' b') (a :#: b) (a' :#: b') checkFamRec3Thing = #thing -- ambiguous type family application, type-preserving optic data FamRec4 a = FamRec4 { _famRec4Thing :: FamInj1 (Fam a) a } makeFieldLabels ''FamRec4 -- no error --- no type changing optic here -checkFamRec4Thing :: Iso' (FamRec4 a) (FamInj1 (Fam a) a) +checkFamRec4Thing :: Iso (FamRec4 a) (FamRec4 b) (FamInj1 (Fam a) a) (FamInj1 (Fam b) b) checkFamRec4Thing = #thing type family FamInj2 a b (c :: k) = r | r -> a b c @@ -601,10 +617,10 @@ } makeFieldLabels ''FamRec7 -checkFamRec7Thing :: Iso (FamRec7 a b (c :: [k ])) - (FamRec7 a' b (c' :: [k'])) +checkFamRec7Thing :: Iso (FamRec7 a b (c :: [k ])) + (FamRec7 a' b' (c' :: [k'])) (FamInj1 (b :#: (a -> FamInj1 c b)) b) - (FamInj1 (b :#: (a' -> FamInj1 c' b)) b) + (FamInj1 (b' :#: (a' -> FamInj1 c' b')) b') checkFamRec7Thing = #thing data FamRec a = FamRec @@ -687,6 +703,13 @@ data Quark2 a = Qualified2 { gaffer2 :: a } | Unqualified2 { gaffer2 :: a, tape2 :: a } |] +makePrismLabels ''Quark2 -- after declareFieldLabels + +checkQualified2 :: Prism' (Quark2 a) a +checkQualified2 = #_Qualified2 + +checkUnqualified2 :: Prism' (Quark2 a) (a, a) +checkUnqualified2 = #_Unqualified2 checkGaffer2 :: Lens' (Quark2 a) a checkGaffer2 = #gaffer2 @@ -781,6 +804,24 @@ checkCoffee :: Iso' (Associated Double) Double checkCoffee = #coffee +declareFieldLabels + [d| data User a = User + { user_name :: Name -- local type + , user_age :: a + } + + newtype Name = Name { name_unwrap :: String } + |] + +checkUserName :: Lens' (User a) Name +checkUserName = #user_name + +checkUserAge :: Lens (User a) (User b) a b +checkUserAge = #user_age + +checkNameUnwrap :: Iso' Name String +checkNameUnwrap = #name_unwrap + declareFields [d| data DeclaredFields f a = DeclaredField1 { declaredFieldsA0 :: f a , declaredFieldsB0 :: Int } @@ -824,26 +865,35 @@ | C2 { _r2length :: forall a. [a] -> Int } makeLenses ''Rank2Tests -makeFieldLabelsWith lensRules ''Rank2Tests -- doesn't generate anything +makeFieldLabelsWith lensRules ''Rank2Tests checkR2length :: Getter Rank2Tests ([a] -> Int) checkR2length = r2length +checkR2length_ :: Getter Rank2Tests ([a] -> Int) +checkR2length_ = #r2length + checkR2nub :: Eq a => AffineFold Rank2Tests ([a] -> [a]) checkR2nub = r2nub +checkR2nub_ :: Eq a => AffineFold Rank2Tests ([a] -> [a]) +checkR2nub_ = #r2nub + data PureNoFields = PureNoFieldsA | PureNoFieldsB { _pureNoFields :: Int } makeLenses ''PureNoFields makeFieldLabels ''PureNoFields -data ReviewTest where - ReviewTest :: (Typeable a, Typeable b) => a -> b -> ReviewTest +data ReviewTest k where + ReviewTest :: Typeable t => t -> Proxy (a :: k) -> ReviewTest k makePrisms ''ReviewTest -makePrismLabels ''ReviewTest -- doesn't generate anything +makePrismLabels ''ReviewTest -checkReviewTest :: (Typeable a, Typeable b) => Review ReviewTest (a, b) +checkReviewTest :: Typeable t => Review (ReviewTest k) (t, Proxy (a :: k)) checkReviewTest = _ReviewTest +checkReviewTest_ :: Typeable t => Review (ReviewTest k) (t, Proxy (a :: k)) +checkReviewTest_ = #_ReviewTest + -- test FieldNamers data CheckUnderscoreNoPrefixNamer = CheckUnderscoreNoPrefixNamer
