diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# 0.4.3.9 + +* Port lens commit [66e199ee](https://github.com/ekmett/lens/commit/66e199ee07f1aaf589faa2a8c661f6a722679959), fixing lens issue [#945](https://github.com/ekmett/lens/pull/945) — "Make the TH machinery handle PolyKinds more robustly". + # 0.4.3.8 * Fixup. diff --git a/microlens-th.cabal b/microlens-th.cabal --- a/microlens-th.cabal +++ b/microlens-th.cabal @@ -1,5 +1,5 @@ name: microlens-th -version: 0.4.3.8 +version: 0.4.3.9 synopsis: Automatic generation of record lenses for microlens description: This package lets you automatically generate lenses for data types; code was extracted from the lens package, and therefore generated lenses are fully compatible with ones generated by lens (and can be used both from lens and microlens). @@ -24,8 +24,8 @@ GHC==8.2.2 GHC==8.4.4 GHC==8.6.5 - GHC==8.8.1 - GHC==8.10.1 + GHC==8.8.4 + GHC==8.10.3 source-repository head type: git @@ -42,7 +42,7 @@ , transformers -- lens has >=2.4, but GHC 7.4 shipped with 2.7 , template-haskell >=2.7 && <2.18 - , th-abstraction >=0.4 && <0.5 + , th-abstraction >=0.4.1 && <0.5 ghc-options: -Wall -fwarn-tabs @@ -55,10 +55,10 @@ 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: test - build-depends: base, microlens, microlens-th + build-depends: base, microlens, microlens-th, tagged default-language: Haskell2010 diff --git a/src/Lens/Micro/TH.hs b/src/Lens/Micro/TH.hs --- a/src/Lens/Micro/TH.hs +++ b/src/Lens/Micro/TH.hs @@ -744,9 +744,9 @@ 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 @@ -805,12 +805,13 @@ let ss = map (stabToS . (^. _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' `conAppsT` [VarT c, s'])) : concat [ [sigD defName (return ty) @@ -819,7 +820,7 @@ inlinePragma defName | (TopName defName, (_, stab, _)) <- defs , let body = appsE [varE '(.), 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)] @@ -840,8 +841,8 @@ : 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 } diff --git a/src/Lens/Micro/TH/Internal.hs b/src/Lens/Micro/TH/Internal.hs --- a/src/Lens/Micro/TH/Internal.hs +++ b/src/Lens/Micro/TH/Internal.hs @@ -33,9 +33,12 @@ substTypeVars, -- * Miscellaneous utilities + datatypeTypeKinded, inlinePragma, conAppsT, quantifyType, quantifyType', + tvbToType, + unSigT, -- * Lens functions elemOf, @@ -50,11 +53,12 @@ import Data.Map (Map) import qualified Data.Set as Set import Data.Set (Set) -import Data.List (nub) import Data.Maybe import Lens.Micro import Language.Haskell.TH import Language.Haskell.TH.Datatype.TyVarBndr +import qualified Language.Haskell.TH.Datatype as D +import qualified Language.Haskell.TH.Datatype.TyVarBndr as D #if __GLASGOW_HASKELL__ < 710 import Control.Applicative @@ -209,20 +213,79 @@ conAppsT :: Name -> [Type] -> Type conAppsT conName = foldl AppT (ConT conName) --- | Template Haskell wants type variables declared in a forall, so we find --- all free type variables in a given type and declare them. +-- 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. +-- | 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 plainTVSpecified - $ filter (`Set.notMember` exclude) - $ nub -- stable order - $ toListOf typeVars t + 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 ---------------------------------------------------------------------------- -- Lens functions which would've been in Lens.Micro if it wasn't “micro” diff --git a/test/T917.hs b/test/T917.hs new file mode 100644 --- /dev/null +++ b/test/T917.hs @@ -0,0 +1,53 @@ +{-# 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 Lens.Micro.TH +import Data.Proxy + +#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806 +import Data.Kind +#endif + +-- Doesn't compile on GHC 7.4 at all +#if __GLASGOW_HASKELL__ >= 706 + +-- 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 family T917DataFam (a :: k) +data instance T917DataFam (a :: *) = MkT917DataFam { _unT917DataFam :: Proxy a } +$(makeLenses 'MkT917DataFam) +#endif + +{- +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 T917GadtOne (a :: k) where + MkT917GadtOne :: T917GadtOne (a :: *) +$(makePrisms ''T917GadtOne) + +data T917GadtTwo (a :: k) where + MkT917GadtTwo :: T917GadtTwo (a :: *) +$(makePrisms ''T917GadtTwo) +-} +#endif diff --git a/test/templates.hs b/test/templates.hs --- a/test/templates.hs +++ b/test/templates.hs @@ -27,6 +27,7 @@ import Lens.Micro import Lens.Micro.TH import T799 () +import T917 () data Bar a b c = Bar { _baz :: (a, b) } makeLenses ''Bar