diff --git a/.travis.yml b/.travis.yml index 7ee418812..f04506e0f 100644 --- a/.travis.yml +++ b/.travis.yml @@ -8,7 +8,7 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.10.2 +# version: 0.10.3 # version: ~> 1.0 language: c @@ -101,6 +101,7 @@ before_install: install: - ${CABAL} --version - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" + - "echo 'jobs: 2' >> $CABALHOME/config" - | echo "program-default-options" >> $CABALHOME/config echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config @@ -125,6 +126,10 @@ install: - if [ $HCNUMVER -ge 80200 ] ; then echo 'package lens-properties' >> cabal.project ; fi - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" - | + echo "source-repository-package" >> cabal.project + echo " type: git" >> cabal.project + echo " location: https://github.com/glguy/th-abstraction" >> cabal.project + echo " tag: 873002c6f502d35c1533c6c0e07009b0f40a4995" >> cabal.project - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(lens|lens-examples|lens-properties)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true @@ -134,7 +139,6 @@ install: - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - rm cabal.project.freeze - - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all script: - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) # Packaging... @@ -161,6 +165,10 @@ script: - if [ $HCNUMVER -ge 80200 ] ; then echo 'package lens-properties' >> cabal.project ; fi - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" - | + echo "source-repository-package" >> cabal.project + echo " type: git" >> cabal.project + echo " location: https://github.com/glguy/th-abstraction" >> cabal.project + echo " tag: 873002c6f502d35c1533c6c0e07009b0f40a4995" >> cabal.project - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(lens|lens-examples|lens-properties)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true @@ -180,5 +188,5 @@ script: # haddock... - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all -# REGENDATA ("0.10.2",["--output=.travis.yml","--config=cabal.haskell-ci","cabal.project"]) +# REGENDATA ("0.10.3",["--output=.travis.yml","--config=cabal.haskell-ci","cabal.project"]) # EOF diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown index cbfed9d8f..dcdd2e0d8 100644 --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,9 +1,6 @@ 4.20 [2020.xx.yy] ----------------- * Support building with GHC 9.0. -* Add `Control.Lens.Profunctor` with conversion functions to and from - profunctor optic representation -* Mark `Control.Lens.Equality` as Trustworthy * The `Swapped` type class is removed in favor of `Swap` from the `assoc` package * The `Strict` type class is removed in favor of `Strict` from the `strict` package @@ -24,6 +21,16 @@ swapped = iso Swap.swap Swap.swap #endif ``` +* Make the functions in `Control.Lens.TH` work more robustly with poly-kinded + data types. This can cause a breaking change under certain situations: + * TH-generated optics for poly-kinded data types are now much more likely to + mention kind variables in their definitions, which will require enabling + the `PolyKinds` extension at use sites in order to typecheck. + * Because TH-generated optics now quantify more kind variables than they did + previously, this can affect the order of visible type applications. +* Add `Control.Lens.Profunctor` with conversion functions to and from + profunctor optic representation +* Mark `Control.Lens.Equality` as Trustworthy 4.19.2 [2020.04.15] ------------------- diff --git a/cabal.haskell-ci b/cabal.haskell-ci index 1e2a54ee7..321044da9 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -3,3 +3,8 @@ unconstrained: False hlint: True apt: freeglut3-dev irc-channels: irc.freenode.org#haskell-lens + +-- TODO: Temporary until https://github.com/glguy/th-abstraction/issues/84 is fixed +jobs: 2 +jobs-selection: any +install-dependencies: False diff --git a/cabal.project b/cabal.project index b91f16f28..cc5b23935 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,9 @@ packages: . ./examples ./lens-properties + +-- TODO: Temporary until https://github.com/glguy/th-abstraction/issues/84 is fixed +source-repository-package + type: git + location: https://github.com/glguy/th-abstraction + tag: 873002c6f502d35c1533c6c0e07009b0f40a4995 diff --git a/lens.cabal b/lens.cabal index 36423bb4a..b5f47e43d 100644 --- a/lens.cabal +++ b/lens.cabal @@ -353,11 +353,16 @@ library test-suite templates type: exitcode-stdio-1.0 main-is: templates.hs - other-modules: T799 + other-modules: + T799 + T917 ghc-options: -Wall -threaded hs-source-dirs: tests default-language: Haskell2010 + if impl(ghc >= 8.6) + ghc-options: -Wno-star-is-type + if flag(dump-splices) ghc-options: -ddump-splices diff --git a/src/Control/Lens/Internal/FieldTH.hs b/src/Control/Lens/Internal/FieldTH.hs index d8cf16ec9..aa6ec0ae8 100644 --- a/src/Control/Lens/Internal/FieldTH.hs +++ b/src/Control/Lens/Internal/FieldTH.hs @@ -95,9 +95,9 @@ makeFieldOpticsForDatatype rules info = return (concat decss) where - tyName = D.datatypeName info - s = D.datatypeType info - cons = D.datatypeCons info + tyName = D.datatypeName info + s = datatypeTypeKinded info + cons = D.datatypeCons info -- Traverse the field labels of a normalized constructor normFieldLabels :: Traversal [(Name,[(a,Type)])] [(Name,[(b,Type)])] a b @@ -320,12 +320,13 @@ makeClassyClass className methodName s defs = do let ss = map (stabToS . view (_2 . _2)) defs (sub,s') <- unifyTypes (s : ss) c <- newName "c" - let vars = toListOf typeVars s' + let vars = D.freeVariablesWellScoped [s'] + varNames = map D.tvName vars fd | null vars = [] - | otherwise = [FunDep [c] vars] + | otherwise = [FunDep [c] varNames] - classD (cxt[]) className (map D.plainTV (c:vars)) fd + classD (cxt[]) className (D.plainTV c:vars) fd $ sigD methodName (return (lens'TypeName `conAppsT` [VarT c, s'])) : concat [ [sigD defName (return ty) @@ -334,7 +335,7 @@ makeClassyClass className methodName s defs = do inlinePragma defName | (TopName defName, (_, stab, _)) <- defs , let body = appsE [varE composeValName, varE methodName, varE defName] - , let ty = quantifyType' (Set.fromList (c:vars)) + , let ty = quantifyType' (Set.fromList (c:varNames)) (stabToContext stab) $ stabToOptic stab `conAppsT` [VarT c, applyTypeSubst sub (stabToA stab)] @@ -356,8 +357,8 @@ makeClassyInstance rules className methodName s defs = do : map return (concat methodss) where - instanceHead = className `conAppsT` (s : map VarT vars) - vars = toListOf typeVars s + instanceHead = className `conAppsT` (s : map tvbToType vars) + vars = D.freeVariablesWellScoped [s] rules' = rules { _generateSigs = False , _generateClasses = False } @@ -620,23 +621,3 @@ type HasFieldClasses = StateT (Set Name) Q addFieldClassName :: Name -> HasFieldClasses () addFieldClassName n = modify $ Set.insert n - ------------------------------------------------------------------------- --- Miscellaneous utility functions ------------------------------------------------------------------------- - - --- | Template Haskell wants type variables declared in a forall, so --- we find all free type variables in a given type and declare them. -quantifyType :: Cxt -> Type -> Type -quantifyType = quantifyType' Set.empty - --- | This function works like 'quantifyType' except that it takes --- a list of variables to exclude from quantification. -quantifyType' :: Set Name -> Cxt -> Type -> Type -quantifyType' exclude c t = ForallT vs c t - where - vs = map D.plainTVSpecified - $ filter (`Set.notMember` exclude) - $ nub -- stable order - $ toListOf typeVars t diff --git a/src/Control/Lens/Internal/PrismTH.hs b/src/Control/Lens/Internal/PrismTH.hs index 27517224c..8f32280e7 100644 --- a/src/Control/Lens/Internal/PrismTH.hs +++ b/src/Control/Lens/Internal/PrismTH.hs @@ -23,7 +23,6 @@ module Control.Lens.Internal.PrismTH ) where import Control.Applicative -import Control.Lens.Fold import Control.Lens.Getter import Control.Lens.Internal.TH import Control.Lens.Lens @@ -39,6 +38,7 @@ import qualified Language.Haskell.TH.Datatype.TyVarBndr as D import Language.Haskell.TH.Lens import qualified Data.Map as Map import qualified Data.Set as Set +import Data.Set (Set) import Prelude -- | Generate a 'Prism' for each constructor of a data type. @@ -137,7 +137,7 @@ makePrisms' normal typeName = let cls | normal = Nothing | otherwise = Just (D.datatypeName info) cons = D.datatypeCons info - makeConsPrisms (D.datatypeType info) (map normalizeCon cons) cls + makeConsPrisms (datatypeTypeKinded info) (map normalizeCon cons) cls -- | Generate prisms for the given 'Dec' @@ -147,7 +147,7 @@ makeDecPrisms normal dec = let cls | normal = Nothing | otherwise = Just (D.datatypeName info) cons = D.datatypeCons info - makeConsPrisms (D.datatypeType info) (map normalizeCon cons) cls + makeConsPrisms (datatypeTypeKinded info) (map normalizeCon cons) cls -- | Generate prisms for the given type, normalized constructors, and @@ -166,7 +166,7 @@ makeConsPrisms t cons Nothing = stab <- computeOpticType t cons con let n = prismName conName sequenceA - ( [ sigD n (close (stabToType stab)) + ( [ sigD n (return (quantifyType [] (stabToType Set.empty stab))) , valD (varP n) (normalB (makeConOpticExp stab cons con)) [] ] ++ inlinePragma n @@ -197,17 +197,15 @@ simplifyStab (Stab cx ty _ t _ b) = Stab cx ty t t b b stabSimple :: Stab -> Bool 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 $ - case ty of - PrismType | stabSimple stab -> prism'TypeName `conAppsT` [t,b] - | otherwise -> prismTypeName `conAppsT` [s,t,a,b] - ReviewType -> reviewTypeName `conAppsT` [t,b] - +stabToType :: Set Name -> Stab -> Type +stabToType clsTVBNames stab@(Stab cx ty s t a b) = + quantifyType' clsTVBNames cx stabTy where - vs = map D.plainTVSpecified - $ nub -- stable order - $ toListOf typeVars cx + stabTy = + case ty of + PrismType | stabSimple stab -> prism'TypeName `conAppsT` [t,b] + | otherwise -> prismTypeName `conAppsT` [s,t,a,b] + ReviewType -> reviewTypeName `conAppsT` [t,b] stabType :: Stab -> OpticType stabType (Stab _ o _ _ _ _) = o @@ -256,7 +254,7 @@ computeIsoType t' fields = | otherwise = appsT (conT isoTypeName) [s,t,a,b] #endif - close =<< ty + quantifyType [] <$> ty @@ -420,8 +418,8 @@ makeClassyPrismClass t className methodName cons = #ifndef HLINT let methodType = appsT (conT prism'TypeName) [varT r,return t] #endif - methodss <- traverse (mkMethod (VarT r)) cons' - classD (cxt[]) className (map D.plainTV (r : vs)) (fds r) + methodss <- traverse (mkMethod r) cons' + classD (cxt[]) className (D.plainTV r : vs) (fds r) ( sigD methodName methodType : map return (concat methodss) ) @@ -429,19 +427,21 @@ makeClassyPrismClass t className methodName cons = where mkMethod r con = do Stab cx o _ _ _ b <- computeOpticType t cons con - let stab' = Stab cx o r r b b + let rTy = VarT r + stab' = Stab cx o rTy rTy b b defName = view nconName con body = appsE [varE composeValName, varE methodName, varE defName] sequenceA - [ sigD defName (return (stabToType stab')) + [ sigD defName (return (stabToType (Set.fromList (r:vNames)) stab')) , valD (varP defName) (normalB body) [] ] cons' = map (over nconName prismName) cons - vs = Set.toList (setOf typeVars t) + vs = D.freeVariablesWellScoped [t] + vNames = map D.tvName vs fds r | null vs = [] - | otherwise = [FunDep [r] vs] + | otherwise = [FunDep [r] vNames] @@ -457,8 +457,8 @@ makeClassyPrismInstance :: [NCon] {- Constructors -} -> DecQ makeClassyPrismInstance s className methodName cons = - do let vs = Set.toList (setOf typeVars s) - cls = className `conAppsT` (s : map VarT vs) + do let vs = D.freeVariablesWellScoped [s] + cls = className `conAppsT` (s : map tvbToType vs) instanceD (cxt[]) (return cls) ( valD (varP methodName) @@ -541,9 +541,3 @@ prismName' sameNameAsCon n = prefix :: Char -> String -> String prefix char str | sameNameAsCon = char:char:str | otherwise = char:str - --- | Quantify all the free variables in a type. -close :: Type -> TypeQ -close t = forallT (map D.plainTVSpecified (Set.toList vs)) (cxt[]) (return t) - where - vs = setOf typeVars t diff --git a/src/Control/Lens/Internal/TH.hs b/src/Control/Lens/Internal/TH.hs index 0f902b695..266fa753d 100644 --- a/src/Control/Lens/Internal/TH.hs +++ b/src/Control/Lens/Internal/TH.hs @@ -22,7 +22,11 @@ module Control.Lens.Internal.TH where import Data.Functor.Contravariant +import qualified Data.Set as Set +import Data.Set (Set) import Language.Haskell.TH +import qualified Language.Haskell.TH.Datatype as D +import qualified Language.Haskell.TH.Datatype.TyVarBndr as D import Language.Haskell.TH.Syntax #ifndef CURRENT_PACKAGE_KEY import Data.Version (showVersion) @@ -88,6 +92,80 @@ unfoldType = go [] #endif go acc ty = (ty, acc) +-- Construct a 'Type' using the datatype's type constructor and type +-- parameters. Unlike 'D.datatypeType', kind signatures are preserved to +-- some extent. (See the comments for 'dropSigsIfNonDataFam' below for more +-- details on this.) +datatypeTypeKinded :: D.DatatypeInfo -> Type +datatypeTypeKinded di + = foldl AppT (ConT (D.datatypeName di)) + $ dropSigsIfNonDataFam + $ 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 + + dropSig :: Type -> Type + dropSig (SigT t k) | null (D.freeVariables k) = t + dropSig t = t + +-- | Template Haskell wants type variables declared in a forall, so +-- we find all free type variables in a given type and declare them. +quantifyType :: Cxt -> Type -> Type +quantifyType = quantifyType' Set.empty + +-- | This function works like 'quantifyType' except that it takes +-- a list of variables to exclude from quantification. +quantifyType' :: Set Name -> Cxt -> Type -> Type +quantifyType' exclude c t = ForallT vs c t + where + vs = filter (\tvb -> D.tvName tvb `Set.notMember` exclude) + $ D.changeTVFlags D.SpecifiedSpec + $ D.freeVariablesWellScoped (t:concatMap predTypes c) -- stable order + + predTypes :: Pred -> [Type] +#if MIN_VERSION_template_haskell(2,10,0) + predTypes p = [p] +#else + predTypes (ClassP _ ts) = ts + predTypes (EqualP t1 t2) = [t1, t2] +#endif + +-- | Convert a 'TyVarBndr' into its corresponding 'Type'. +tvbToType :: D.TyVarBndr_ flag -> Type +tvbToType = D.elimTV VarT (SigT . VarT) + +-- | Peel off a kind signature from a Type (if it has one). +unSigT :: Type -> Type +unSigT (SigT t _) = t +unSigT t = t + +isDataFamily :: D.DatatypeVariant -> Bool +isDataFamily D.Datatype = False +isDataFamily D.Newtype = False +isDataFamily D.DataInstance = True +isDataFamily D.NewtypeInstance = True + ------------------------------------------------------------------------ -- Manually quoted names ------------------------------------------------------------------------ diff --git a/tests/T917.hs b/tests/T917.hs new file mode 100644 index 000000000..ef522b947 --- /dev/null +++ b/tests/T917.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif +module T917 where + +import Control.Lens +import Data.Proxy + +#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806 +import Data.Kind +#endif + +-- Like Data.Functor.Const, but redfined to ensure that it is poly-kinded +-- across all versions of GHC, not just 8.0+ +newtype Constant a (b :: k) = Constant a + +data T917OneA (a :: k -> *) (b :: k -> *) = MkT917OneA +data T917OneB a b = MkT917OneB (T917OneA a (Const b)) +$(makePrisms ''T917OneB) + +data T917TwoA (a :: k -> *) (b :: k -> *) = MkT917TwoA +data T917TwoB a b = MkT917TwoB (T917TwoA a (Const b)) +$(makeClassyPrisms ''T917TwoB) + +data family T917DataFam (a :: k) +data instance T917DataFam (a :: *) = MkT917DataFam { _unT917DataFam :: Proxy a } +$(makeLenses 'MkT917DataFam) + +#if __GLASGOW_HASKELL__ >= 800 +data T917GadtOne (a :: k) where + MkT917GadtOne :: T917GadtOne (a :: *) +$(makePrisms ''T917GadtOne) + +data T917GadtTwo (a :: k) where + MkT917GadtTwo :: T917GadtTwo (a :: *) +$(makePrisms ''T917GadtTwo) +#endif diff --git a/tests/templates.hs b/tests/templates.hs index e24c4c1af..1fa0ad9c2 100644 --- a/tests/templates.hs +++ b/tests/templates.hs @@ -27,6 +27,7 @@ module Main where import Control.Lens -- import Test.QuickCheck (quickCheck) import T799 () +import T917 () data Bar a b c = Bar { _baz :: (a, b) } makeLenses ''Bar