diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -26,7 +26,9 @@ import Distribution.PackageDescription import Distribution.Simple import qualified Distribution.ModuleName as ModuleName -#if MIN_VERSION_Cabal(2,0,0) +#if MIN_VERSION_Cabal(3,5,0) +import Distribution.Types.ModuleReexport +#elif MIN_VERSION_Cabal(2,0,0) import Distribution.Types.CondTree (CondBranch(CondBranch)) #endif @@ -43,7 +45,13 @@ addReexportsCT ct = ct { condTreeComponents = reexportBranch : condTreeComponents ct } where - constraintsCondition = Var (Flag (mkFlagName "constraints")) + constraintsCondition = Var ( +#if MIN_VERSION_Cabal(3,5,0) + PackageFlag +#else + Flag +#endif + (mkFlagName "constraints")) reexportContent = mempty { reexportedModules = [ ModuleReexport diff --git a/constraints-deriving.cabal b/constraints-deriving.cabal --- a/constraints-deriving.cabal +++ b/constraints-deriving.cabal @@ -1,13 +1,13 @@ cabal-version: 1.24 --- This file has been generated from package.yaml by hpack version 0.31.1. +-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack -- --- hash: c2db64ad19f7bc5dcefbf65b4cc6f18f31e222344bce693f390c652fe11cc053 +-- hash: 1f381c6f9903b2c370468e91d9aac18c3c22484c77c40d714597171d0403c0da name: constraints-deriving -version: 1.1.1.0 +version: 1.1.1.1 synopsis: Manipulating constraints and deriving class instances programmatically. description: The library provides a plugin to derive class instances programmatically. Please see the README on GitHub at category: Constraints diff --git a/src/Data/Constraint/Bare.hs b/src/Data/Constraint/Bare.hs --- a/src/Data/Constraint/Bare.hs +++ b/src/Data/Constraint/Bare.hs @@ -28,7 +28,12 @@ import Data.Constraint (Dict (..)) -import GHC.Base (Constraint, Type, unsafeCoerce#) +import GHC.Base (Constraint, Type) +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Exts (unsafeCoerce#) +#else +import GHC.Base (unsafeCoerce#) +#endif -- | An unsafeCoerced pointer to a Constraint, such as a class function dictionary. data BareConstraint :: Constraint -> Type diff --git a/src/Data/Constraint/Deriving/ClassDict.hs b/src/Data/Constraint/Deriving/ClassDict.hs --- a/src/Data/Constraint/Deriving/ClassDict.hs +++ b/src/Data/Constraint/Deriving/ClassDict.hs @@ -10,7 +10,7 @@ import Control.Monad (join, unless, when) import Data.Data (Data) import Data.Maybe (fromMaybe, isJust) -import GhcPlugins hiding (OverlapMode (..), overlapMode) +import GhcPlugins hiding (OverlapMode (..), overlapMode, mkFunTy) import qualified Unify import Data.Constraint.Deriving.CorePluginM @@ -207,7 +207,7 @@ mapResultType f t | (bndrs@(_:_), t') <- splitForAllTys t = mkSpecForAllTys bndrs $ mapResultType f t' - | Just (at, rt) <- splitFunTy_maybe t - = mkFunTy at (mapResultType f rt) + | Just (vis, at, rt) <- splitFunTyArg_maybe t + = mkFunTy vis at (mapResultType f rt) | otherwise = f t diff --git a/src/Data/Constraint/Deriving/CorePluginM.hs b/src/Data/Constraint/Deriving/CorePluginM.hs --- a/src/Data/Constraint/Deriving/CorePluginM.hs +++ b/src/Data/Constraint/Deriving/CorePluginM.hs @@ -30,6 +30,11 @@ -- * Debugging , pluginDebug, pluginTrace , HasCallStack + , splitFunTyArg_maybe + , mkFunTy +#if __GLASGOW_HASKELL__ < 810 + , mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys +#endif ) where import qualified Avail @@ -45,7 +50,7 @@ import qualified ErrUtils import qualified Finder import GhcPlugins hiding (OverlapMode (..), empty, - overlapMode, (<>)) + overlapMode, (<>), mkFunTy) import qualified GhcPlugins import qualified IfaceEnv import InstEnv (InstEnv, InstEnvs) @@ -56,6 +61,9 @@ import TcRnMonad (getEps, initTc) import TcRnTypes (TcM) import qualified Unify +#if __GLASGOW_HASKELL__ >= 810 +import qualified TyCoRep +#endif #if __GLASGOW_HASKELL__ >= 808 import qualified TysWiredIn #endif @@ -587,8 +595,8 @@ | (bndrs@(_:_), t') <- splitForAllTys t = mkSpecForAllTys bndrs $ replace t' -- split arrow types - | Just (at, rt) <- splitFunTy_maybe t - = mkFunTy (replace at) (replace rt) + | Just (vis, at, rt) <- splitFunTyArg_maybe t + = mkFunTy vis (replace at) (replace rt) -- could not find anything | otherwise = t @@ -746,4 +754,35 @@ #if __GLASGOW_HASKELL__ < 808 cnTypeEq :: OccName cnTypeEq = mkTcOcc "~" +#endif + +#if __GLASGOW_HASKELL__ < 810 +type AnonArgFlag = () + +mkVisFunTy, mkInvisFunTy :: Type -> Type -> Type +mkVisFunTy = GhcPlugins.mkFunTy +mkInvisFunTy = GhcPlugins.mkFunTy + +mkVisFunTys, mkInvisFunTys :: [Type] -> Type -> Type +mkVisFunTys = GhcPlugins.mkFunTys +mkInvisFunTys = GhcPlugins.mkFunTys +#endif + +mkFunTy :: AnonArgFlag -> Type -> Type -> Type +#if __GLASGOW_HASKELL__ < 810 +mkFunTy _ = GhcPlugins.mkFunTy +#else +mkFunTy = TyCoRep.mkFunTy +#endif + +splitFunTyArg_maybe :: Type -> Maybe (AnonArgFlag, Type, Type) +#if __GLASGOW_HASKELL__ < 810 +splitFunTyArg_maybe ty = + case splitFunTy_maybe ty of + Just (arg, res) -> Just ((), arg, res) + _ -> Nothing +#else +splitFunTyArg_maybe ty | Just ty' <- coreView ty = splitFunTyArg_maybe ty' +splitFunTyArg_maybe (TyCoRep.FunTy vis arg res) = Just (vis, arg, res) +splitFunTyArg_maybe _ = Nothing #endif diff --git a/src/Data/Constraint/Deriving/DeriveAll.hs b/src/Data/Constraint/Deriving/DeriveAll.hs --- a/src/Data/Constraint/Deriving/DeriveAll.hs +++ b/src/Data/Constraint/Deriving/DeriveAll.hs @@ -37,6 +37,9 @@ import Panic (panicDoc) import TcType (tcSplitDFunTy) import qualified Unify +#if __GLASGOW_HASKELL__ >= 810 +import Predicate +#endif import Data.Constraint.Deriving.CorePluginM @@ -754,8 +757,8 @@ let extraTheta = filter (\t -> not $ any (eqType t . fst) bndrs) mtTheta tRepl = replaceTypeOccurrences mtBaseType mtNewType tOrig - tFun = mkFunTys (extraTheta ++ map fst bndrs) tRepl - tvs = tyCoVarsOfTypeWellScoped tFun + tFun = mkInvisFunTys (extraTheta ++ map fst bndrs) tRepl + tvs = tyCoVarsOfTypeWellScoped tFun return ( mkSpecForAllTys tvs tFun , mkCoreLams (tvs ++ map mkWildValBinder extraTheta ++ map snd bndrs) diff --git a/src/Data/Constraint/Deriving/ToInstance.hs b/src/Data/Constraint/Deriving/ToInstance.hs --- a/src/Data/Constraint/Deriving/ToInstance.hs +++ b/src/Data/Constraint/Deriving/ToInstance.hs @@ -152,8 +152,8 @@ Nothing -> pluginLocatedError loc notGoodMsg Just ma -> pure ma let matchedTy = substTyVar match varCls - instSig = mkSpecForAllTys bndrs $ mkFunTys theta matchedTy - bindBareTy = mkSpecForAllTys bndrs $ mkFunTys theta $ mkTyConApp tcBareConstraint [matchedTy] + instSig = mkSpecForAllTys bndrs $ mkInvisFunTys theta matchedTy + bindBareTy = mkSpecForAllTys bndrs $ mkInvisFunTys theta $ mkTyConApp tcBareConstraint [matchedTy] -- check if constraint is indeed a class and get it matchedClass <- case tyConAppTyCon_maybe matchedTy >>= tyConClass_maybe of diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,7 +4,7 @@ {-# LANGUAGE RecordWildCards #-} module Main (main) where -import Control.Monad (when) +import Control.Monad (when, guard) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.Char (isSpace) @@ -27,6 +27,11 @@ import System.FilePath (isPathSeparator) import System.IO +#if !MIN_VERSION_path(0,7,0) +replaceExtension :: String -> Path b File -> Maybe (Path b File) +replaceExtension = setFileExtension +#endif + -- | Folder with test modules to be compiled specDir :: Path Rel Dir specDir = [reldir|test/Spec/|] @@ -36,10 +41,10 @@ outDir = [reldir|test/out/|] correspondingStdOut :: Path a File -> Maybe (Path Rel File) -correspondingStdOut f = setFileExtension "stdout" $ outDir filename f +correspondingStdOut f = replaceExtension "stdout" $ outDir filename f correspondingStdErr :: Path a File -> Maybe (Path Rel File) -correspondingStdErr f = setFileExtension "stderr" $ outDir filename f +correspondingStdErr f = replaceExtension "stderr" $ outDir filename f data TargetPaths = TargetPaths { targetName :: String @@ -50,9 +55,14 @@ lookupTargetPaths :: Path a File -> Maybe TargetPaths lookupTargetPaths p = do - if fileExtension p == ".hs" then Just () else Nothing +#if MIN_VERSION_path(0,7,0) + ext <- fileExtension p +#else + let ext = fileExtension p +#endif + guard $ ext == ".hs" targetPath <- Just $ toFilePath p - targetName <- toFilePath <$> setFileExtension "" (filename p) + targetName <- toFilePath <$> replaceExtension "" (filename p) stdoutPath <- toFilePath <$> correspondingStdOut p stderrPath <- toFilePath <$> correspondingStdErr p return TargetPaths {..}