Make the TH machinery handle PolyKinds more robustly

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.
ekmett · Oct 8, 2020 · de857e0 · de857e0
1 parent bc839cc
commit de857e0
Show file tree

Hide file tree

Showing 10 changed files with 140 additions and 65 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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,28 +418,30 @@ 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)
        )
 
   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
@@ -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
 ------------------------------------------------------------------------