diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +# 0.4.3.10 + +* Port lens commit [fae336e1](https://github.com/ekmett/lens/commit/fae336e191748782cff023540bd25e3582ca93fb), "Close over kind variables when computing fixed type variables", fixing lens issue [#972](https://github.com/ekmett/lens/issues/972). + +* Allow building with template-haskell-2.18. + # 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". 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.9 +version: 0.4.3.10 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). @@ -16,8 +16,7 @@ extra-source-files: CHANGELOG.md cabal-version: >=1.10 -tested-with: GHC==7.4.2 - GHC==7.6.3 +tested-with: GHC==7.6.3 GHC==7.8.4 GHC==7.10.3 GHC==8.0.2 @@ -26,6 +25,7 @@ GHC==8.6.5 GHC==8.8.4 GHC==8.10.3 + GHC==9.0.1 source-repository head type: git @@ -38,10 +38,9 @@ -- other-extensions: build-depends: base >=4.5 && <5 , microlens >=0.4.0 && <0.5 - , containers >=0.4.0 && <0.7 + , containers >=0.5 && <0.7 , transformers - -- lens has >=2.4, but GHC 7.4 shipped with 2.7 - , template-haskell >=2.7 && <2.18 + , template-haskell >=2.8 && <2.19 , th-abstraction >=0.4.1 && <0.5 ghc-options: @@ -55,7 +54,7 @@ test-suite templates type: exitcode-stdio-1.0 main-is: templates.hs - other-modules: T799 T917 + other-modules: T799 T917 T972 ghc-options: -Wall -threaded hs-source-dirs: test 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 @@ -157,15 +157,6 @@ -- Utilities --- @fromSet@ wasn't always there, and we need compatibility with --- containers-0.4 to compile on GHC 7.4. -fromSet :: (k -> v) -> Set.Set k -> Map.Map k v -#if MIN_VERSION_containers(0,5,0) -fromSet = Map.fromSet -#else -fromSet f x = Map.fromDistinctAscList [ (k,f k) | k <- Set.toAscList x ] -#endif - -- like 'rewrite' from uniplate rewrite :: (Data a, Data b) => (a -> Maybe a) -> b -> b rewrite f mbA = case cast mbA of @@ -734,7 +725,7 @@ let allFields = toListOf (folded . _2 . folded . _1 . folded) fieldCons let defCons = over normFieldLabels (expandName allFields) fieldCons allDefs = setOf (normFieldLabels . folded) defCons - sequenceA (fromSet (buildScaffold rules s defCons) allDefs) + sequenceA (Map.fromSet (buildScaffold rules s defCons) allDefs) let defs = Map.toList perDef case _classyLenses rules tyName of @@ -956,15 +947,59 @@ let s' = applyTypeSubst subA s -- compute possible type changes - sub <- sequenceA (fromSet (newName . nameBase) unfixedTypeVars) + sub <- sequenceA (Map.fromSet (newName . nameBase) unfixedTypeVars) let (t,b) = over both (substTypeVars sub) (s',a) return (s',t,a,b) where (fixedFields, targetFields) = partitionEithers categorizedFields - fixedTypeVars = setOf typeVars fixedFields - unfixedTypeVars = setOf typeVars s Set.\\ fixedTypeVars + + fixedTypeVars, unfixedTypeVars :: Set Name + fixedTypeVars = closeOverKinds $ setOf typeVars fixedFields + unfixedTypeVars = setOf typeVars s Set.\\ fixedTypeVars + + -- Compute the kind variables that appear in the kind of a type variable + -- binder. For example, @kindVarsOfTvb (x :: (a, b)) = (x, {a, b})@. If a + -- type variable binder lacks an explicit kind annotation, this + -- conservatively assumes that there are no kind variables. For example, + -- @kindVarsOfTvb (y) = (y, {})@. + kindVarsOfTvb :: D.TyVarBndr_ flag -> (Name, Set Name) + kindVarsOfTvb = D.elimTV (\n -> (n, Set.empty)) + (\n k -> (n, setOf typeVars k)) + + -- For each type variable name that appears in @s@, map to the kind variables + -- that appear in that type variable's kind. + sKindVarMap :: Map Name (Set Name) + sKindVarMap = Map.fromList $ map kindVarsOfTvb $ D.freeVariablesWellScoped [s] + + lookupSKindVars :: Name -> Set Name + lookupSKindVars n = fromMaybe Set.empty $ Map.lookup n sKindVarMap + + -- Consider this example (adapted from #972): + -- + -- data Dart (s :: k) = Dart { _arc :: Proxy s, _direction :: Int } + -- $(makeLenses ''Dart) + -- + -- When generating a Lens for `direction`, the type variable `s` should be + -- fixed. But note that (s :: k), and as a result, the kind variable `k` + -- needs to be fixed as well. This is because a type like this would be + -- ill kinded: + -- + -- direction :: Lens (Dart (s :: k1)) (Dart (s :: k2)) Direction Direction + -- + -- However, only `s` is mentioned syntactically in the type of `_arc`, so we + -- have to infer that `k` is mentioned in the kind of `s`. We accomplish this + -- with `closeOverKinds`, which does the following: + -- + -- 1. Use freeVariablesWellScoped to compute the free type variables of + -- `Dart (s :: k)`, which gives us `(s :: k)`. + -- 2. For each type variable name in `Proxy s`, the type of `_arc`, look up + -- the kind variables in the type variable's kind. In the case of `s`, + -- the only kind variable is `k`. + -- 3. Add these kind variables to the set of fixed type variables. + closeOverKinds :: Set Name -> Set Name + closeOverKinds st = Set.foldl' Set.union Set.empty (Set.map lookupSKindVars st) `Set.union` st -- Build the signature and definition for a single field optic. -- In the case of a singleton constructor irrefutable matches are diff --git a/test/T917.hs b/test/T917.hs --- a/test/T917.hs +++ b/test/T917.hs @@ -18,17 +18,13 @@ 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 +-- Like Data.Functor.Const, but redefined 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 diff --git a/test/T972.hs b/test/T972.hs new file mode 100644 --- /dev/null +++ b/test/T972.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} + +#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif +module T972 where + +import Lens.Micro.TH +#if __GLASGOW_HASKELL__ >= 800 +import Data.Proxy +#endif + +newtype Arc s = Arc { _unArc :: Int } + +data Direction = Negative | Positive +data Dart s = Dart { _arc :: Arc s, _direction :: Direction } +$(makeLenses ''Dart) + +#if __GLASGOW_HASKELL__ >= 800 +data Fancy k (a :: k) = MkFancy { _unFancy1 :: k, _unFancy2 :: Proxy a } +$(makeLenses ''Fancy) +#endif diff --git a/test/templates.hs b/test/templates.hs --- a/test/templates.hs +++ b/test/templates.hs @@ -28,6 +28,7 @@ import Lens.Micro.TH import T799 () import T917 () +import T972 () data Bar a b c = Bar { _baz :: (a, b) } makeLenses ''Bar