From de857e08547bd9eb0337bcc97754b5be19f16ee3 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Thu, 8 Oct 2020 11:20:06 -0400 Subject: [PATCH] Make the TH machinery handle PolyKinds more robustly MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is a collection of various Template Haskell–related fixes that, when all put together, fixes #917. This does the following: * Rather than use `th-abstraction`'s `datatypeType` function, which strips off important kind information from type arguments, I defined a similar `datatypeTypeKinded` function that preserves kinds. * `Control.Lens.Internal.{FieldTH,PrismTH}` is now more careful to use `freeVariablesWellScoped` (from `th-abstraction`) instead of `typeVars` to ensure that the resulting types are well scoped. This is particularly important for poly-kinded types, as the kind variables must always appear before the type variables. * I deleted the `close` function from `Control.Lens.Internal.PrismTH` in favor of `quantifyType` and `quantifyType'`, which I have moved to `Control.Lens.Internal.TH` so that they may be used by `FieldTH` and `PrismTH` alike. Moreover, I now use `quantifyType'` in the definition of `PrismTH.makeClassyPrismClass` so that any type variables bound by the class itself do not get requantified in any class methods. The previous code was not doing this at all, which was just plain wrong. --- .travis.yml | 14 ++++++-- CHANGELOG.markdown | 13 +++++-- cabal.haskell-ci | 5 +++ cabal.project | 6 ++++ lens.cabal | 4 ++- src/Control/Lens/Internal/FieldTH.hs | 39 ++++++--------------- src/Control/Lens/Internal/PrismTH.hs | 52 ++++++++++++---------------- src/Control/Lens/Internal/TH.hs | 37 ++++++++++++++++++++ tests/T917.hs | 34 ++++++++++++++++++ tests/templates.hs | 1 + 10 files changed, 140 insertions(+), 65 deletions(-) create mode 100644 tests/T917.hs diff --git a/.travis.yml b/.travis.yml index 7ee418812..340c8e8a4 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: 1707806d4c27ebb88d1c15b12509aeaad8652b5a" >> 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: 1707806d4c27ebb88d1c15b12509aeaad8652b5a" >> 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..b9a3de679 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 are now much more likely to generate kind signatures, + so you may have to enable `KindSignatures` (or `PolyKinds`, for poly-kinded + data types) in places where you did not have to previously. + * 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..b4daf93a3 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: 1707806d4c27ebb88d1c15b12509aeaad8652b5a diff --git a/lens.cabal b/lens.cabal index 36423bb4a..34ba3a8a2 100644 --- a/lens.cabal +++ b/lens.cabal @@ -353,7 +353,9 @@ 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 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..ddcfa18ad 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,39 @@ 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. +datatypeTypeKinded :: D.DatatypeInfo -> Type +datatypeTypeKinded di + = foldl AppT (ConT (D.datatypeName di)) + $ D.datatypeInstTypes di + +-- | 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) + ------------------------------------------------------------------------ -- Manually quoted names ------------------------------------------------------------------------ diff --git a/tests/T917.hs b/tests/T917.hs new file mode 100644 index 000000000..98910596c --- /dev/null +++ b/tests/T917.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif +module T917 where + +import Control.Lens + +-- 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) + +#if __GLASGOW_HASKELL__ >= 800 +data T917Three (a :: k) where + MkT917Three :: T917Three (a :: *) +$(makePrisms ''T917Three) + +data T917Four (a :: k) where + MkT917Four :: T917Four (a :: *) +$(makePrisms ''T917Four) +#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