From a3476d1f8672b4a0f176c778c519d7e2e35de229 Mon Sep 17 00:00:00 2001 From: Tristan Seligmann Date: Fri, 5 Feb 2021 15:59:33 +0200 Subject: [PATCH] GHC 9 --- Data/Profunctor/Product/Internal/TH.hs | 15 ++++++++------- Data/Profunctor/Product/Tuples/TH.hs | 11 ++++++----- product-profunctors.cabal | 1 + 3 files changed, 15 insertions(+), 12 deletions(-) diff --git a/Data/Profunctor/Product/Internal/TH.hs b/Data/Profunctor/Product/Internal/TH.hs index c38d3239..fac66997 100644 --- 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 index 3830b09a..8bb40433 100644 --- 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 index e7e21862..938f72d7 100644 --- 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,