GHC 9

tomjaguarpaw · Feb 5, 2021 · a3476d1 · a3476d1
1 parent f72663e
commit a3476d1
Show file tree

Hide file tree

Showing 3 changed files with 15 additions and 12 deletions.
diff --git a/Data/Profunctor/Product/Internal/TH.hs b/Data/Profunctor/Product/Internal/TH.hs
@@ -9,7 +9,7 @@ import Data.Profunctor.Product hiding (constructor, field)
 import Data.Profunctor.Product.Default (Default, def)
 import qualified Data.Profunctor.Product.Newtype as N
 import Language.Haskell.TH (Dec(DataD, SigD, FunD, InstanceD, NewtypeD),
-                            mkName, newName, nameBase, TyVarBndr(PlainTV, KindedTV),
+                            mkName, newName, nameBase,
                             Con(RecC, NormalC),
                             Clause(Clause),
                             Type(VarT, ForallT, AppT, ConT),
@@ -18,6 +18,8 @@ import Language.Haskell.TH (Dec(DataD, SigD, FunD, InstanceD, NewtypeD),
                             Pat(TupP, VarP, ConP), Name,
                             Info(TyConI), reify, conE, appT, conT, varE, varP,
                             instanceD, Overlap(Incoherent), Pred)
+import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndr_, TyVarBndrSpec,
+                                               plainTVSpecified, tvName)
 import Control.Monad ((<=<))
 import Control.Applicative (pure, liftA2, (<$>), (<*>))
 
@@ -119,9 +121,8 @@ dataDecStuffOfInfo (TyConI (NewtypeD _cxt tyName tyVars _kind constructor _deriv
                         }
 dataDecStuffOfInfo _ = Left "That doesn't look like a data or newtype declaration to me"
 
-varNameOfBinder :: TyVarBndr -> Name
-varNameOfBinder (PlainTV n) = n
-varNameOfBinder (KindedTV n _) = n
+varNameOfBinder :: TyVarBndr_ flag -> Name
+varNameOfBinder = tvName
 
 conStuffOfConstructor :: Con -> Either Error (Name, ConTysFields)
 conStuffOfConstructor = \case
@@ -205,7 +206,7 @@ adaptorSig tyName' numTyVars n = fmap (SigD n) adaptorType
 
         after = [t| $pType $(pArg "0") $(pArg "1") |]
 
-        scope = concat [ [PlainTV p]
+        scope = concat [ [plainTVSpecified p]
                        , map (mkTyVarsuffix "0") tyVars
                        , map (mkTyVarsuffix "1") tyVars ]
 
@@ -372,8 +373,8 @@ varS = VarE . mkName
 varPS :: String -> Pat
 varPS = VarP . mkName
 
-mkTyVarsuffix :: String -> String -> TyVarBndr
-mkTyVarsuffix s = PlainTV . mkName . (++s)
+mkTyVarsuffix :: String -> String -> TyVarBndrSpec
+mkTyVarsuffix s = plainTVSpecified . mkName . (++s)
 
 mkTySuffix :: String -> String -> Type
 mkTySuffix s = varTS . (++s)

diff --git a/Data/Profunctor/Product/Tuples/TH.hs b/Data/Profunctor/Product/Tuples/TH.hs
@@ -10,6 +10,7 @@ module Data.Profunctor.Product.Tuples.TH
   ) where
 
 import Language.Haskell.TH
+import Language.Haskell.TH.Datatype.TyVarBndr
 
 import Data.Profunctor (Profunctor (dimap))
 import Data.Profunctor.Product.Class (ProductProfunctor, (***!), empty)
@@ -23,7 +24,7 @@ mkT :: Int -> Q Dec
 mkT n = tySynD (tyName n) tyVars tyDef
   where
     tyName n' = mkName ('T':show n')
-    tyVars = map PlainTV . take n $ allNames
+    tyVars = map plainTV . take n $ allNames
     tyDef = case n of
       0 -> tupleT 0
       1 -> varT (head allNames)
@@ -48,7 +49,7 @@ pTn :: Int -> Q [Dec]
 pTn n = sequence [sig, fun]
   where
     p = mkName "p"
-    sig = sigD (pT n) (forallT (map PlainTV $ p : take n as ++ take n bs)
+    sig = sigD (pT n) (forallT (map plainTVSpecified $ p : take n as ++ take n bs)
                                (sequence [productProfunctor p])
                                (arrowT `appT` mkLeftTy `appT` mkRightTy)
                       )
@@ -73,7 +74,7 @@ mkFlattenNs = fmap concat . mapM mkFlattenN
 mkFlattenN :: Int -> Q [Dec]
 mkFlattenN n = sequence [sig, fun]
   where
-    sig = sigD nm (forallT (map PlainTV names) (pure []) $ arrowT `appT` unflatT names `appT` flatT names)
+    sig = sigD nm (forallT (map plainTVSpecified names) (pure []) $ arrowT `appT` unflatT names `appT` flatT names)
     fun = funD nm [ clause [mkTupPat names] (normalB bdy) [] ]
     bdy = mkFlatExp names
     unflatT [] = tupleT 0
@@ -97,7 +98,7 @@ mkUnflattenNs = fmap concat . mapM mkUnflattenN
 mkUnflattenN :: Int -> Q [Dec]
 mkUnflattenN n = sequence [sig, fun]
   where
-    sig = sigD nm (forallT (map PlainTV names) (pure []) $ arrowT `appT` flatT names `appT` unflatT names)
+    sig = sigD nm (forallT (map plainTVSpecified names) (pure []) $ arrowT `appT` flatT names `appT` unflatT names)
     fun = funD nm [ clause [mkTupPat names] (normalB bdy) [] ]
     bdy = mkUnflatExp names
     unflatT [] = tupleT 0
@@ -121,7 +122,7 @@ pNs = fmap concat . mapM pN
 pN :: Int -> Q [Dec]
 pN n = sequence [sig, fun]
   where
-    sig = sigD nm (forallT (map PlainTV $ p : as ++ bs)
+    sig = sigD nm (forallT (map plainTVSpecified $ p : as ++ bs)
                            (sequence [productProfunctor p])
                            (arrowT `appT` mkLeftTy `appT` mkRightTy)
                    )

diff --git a/product-profunctors.cabal b/product-profunctors.cabal
@@ -29,6 +29,7 @@ library
                  , contravariant >= 0.4 && < 1.6
                  , tagged >= 0.0 && < 1
                  , template-haskell
+                 , th-abstraction >= 0.4
   exposed-modules: Data.Profunctor.Product,
                    Data.Profunctor.Product.Adaptor
                    Data.Profunctor.Product.Default,