constraints-deriving 1.1.1.0 → 1.1.1.1
raw patch · 8 files changed
+86/−21 lines, 8 filesdep ~ghcsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghc
API changes (from Hackage documentation)
Files
- Setup.hs +10/−2
- constraints-deriving.cabal +3/−3
- src/Data/Constraint/Bare.hs +6/−1
- src/Data/Constraint/Deriving/ClassDict.hs +3/−3
- src/Data/Constraint/Deriving/CorePluginM.hs +42/−3
- src/Data/Constraint/Deriving/DeriveAll.hs +5/−2
- src/Data/Constraint/Deriving/ToInstance.hs +2/−2
- test/Spec.hs +15/−5
Setup.hs view
@@ -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
constraints-deriving.cabal view
@@ -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 <https://github.com/achirkin/constraints-deriving#readme> category: Constraints
src/Data/Constraint/Bare.hs view
@@ -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
src/Data/Constraint/Deriving/ClassDict.hs view
@@ -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
src/Data/Constraint/Deriving/CorePluginM.hs view
@@ -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
src/Data/Constraint/Deriving/DeriveAll.hs view
@@ -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)
src/Data/Constraint/Deriving/ToInstance.hs view
@@ -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
test/Spec.hs view
@@ -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 {..}