diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,17 @@ +## 0.6 [2021.08.29] +* Allow building with `template-haskell-2.18.0.0` (GHC 9.2). +* Using `deriveEnum` and `deriveIx` on poly-kinded data family instances may + now require the use of the `TypeInType` extension if using GHC 8.0, 8.2, or + 8.4. (On later versions of GHC, `TypeInType`'s functionality has been folded + into `PolyKinds`.) +* Support deriving `Eq`, `Ord`, and `Show` instances for data types with fields + of type `Int32#` or `Word32#` on GHC 9.2 or later. +* `deriveVia` now instantiates "floating" `via` type variables (i.e., type + variables mentioned in the `via` type that are not mentioned in the instance + context or the first argument to `Via`) to `Any` in the generated code. As a + result, `deriveVia` no longer generates code that produces `-Wunused-foralls` + warnings. + ### 0.5.10 [2020.09.30] * Allow building with `template-haskell-2.17.0.0` (GHC 9.0). @@ -45,7 +59,7 @@ * Have `deriveGND`/`deriveVia` throw an error if an incorrect number of arguments are supplied to the type class. -### 0.5 [2018.07.01] +## 0.5 [2018.07.01] * Backport the changes to `GeneralizedNewtypeDeriving` and `DerivingVia` code generation from [Trac #15290](https://ghc.haskell.org/trac/ghc/ticket/15290). diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/deriving-compat.svg)](http://packdeps.haskellers.com/reverse/deriving-compat) [![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] [![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] -[![Build](https://img.shields.io/travis/haskell-compat/deriving-compat.svg)](https://travis-ci.org/haskell-compat/deriving-compat) +[![Build Status](https://github.com/haskell-compat/deriving-compat/workflows/Haskell-CI/badge.svg)](https://github.com/haskell-compat/deriving-compat/actions?query=workflow%3AHaskell-CI) [Hackage: deriving-compat]: http://hackage.haskell.org/package/deriving-compat diff --git a/deriving-compat.cabal b/deriving-compat.cabal --- a/deriving-compat.cabal +++ b/deriving-compat.cabal @@ -1,5 +1,5 @@ name: deriving-compat -version: 0.5.10 +version: 0.6 synopsis: Backports of GHC deriving extensions description: Provides Template Haskell functions that mimic deriving extensions that were introduced or modified in recent versions @@ -72,8 +72,10 @@ , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 - , GHC == 8.8.3 - , GHC == 8.10.1 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.1 + , GHC == 9.2.* cabal-version: >=1.10 source-repository head @@ -131,7 +133,7 @@ build-depends: base >= 4.3 && < 4.9 if flag(template-haskell-2-11) - build-depends: template-haskell >= 2.11 && < 2.18 + build-depends: template-haskell >= 2.11 && < 2.19 , ghc-boot-th else build-depends: template-haskell >= 2.5 && < 2.11 @@ -170,7 +172,7 @@ , hspec >= 1.8 , QuickCheck >= 2 && < 3 , tagged >= 0.7 && < 1 - , template-haskell >= 2.5 && < 2.18 + , template-haskell >= 2.5 && < 2.19 , void >= 0.5.10 && < 1 build-tool-depends: hspec-discover:hspec-discover >= 1.8 diff --git a/src/Data/Deriving.hs b/src/Data/Deriving.hs --- a/src/Data/Deriving.hs +++ b/src/Data/Deriving.hs @@ -118,8 +118,10 @@ * In GHC 8.10, @DerivingVia@ permits \"floating\" type variables in @via@ types, such as the @a@ in @'deriveVia' [t| forall a. Show MyInt ``Via`` Const Int a |]@. + @deriving-compat@ does so by instantiating the @a@ to @GHC.Exts.Any@ in the + generated instance. -* In GHC 8.12, @DeriveFunctor@ was changed so that it works on more +* In GHC 9.0, @DeriveFunctor@ was changed so that it works on more constructors with rank-n field types. -} diff --git a/src/Data/Deriving/Internal.hs b/src/Data/Deriving/Internal.hs --- a/src/Data/Deriving/Internal.hs +++ b/src/Data/Deriving/Internal.hs @@ -35,7 +35,7 @@ import Data.Functor.Classes (Eq2(..), Ord2(..), Read2(..), Show2(..)) # endif #endif -import Data.List +import qualified Data.List as List import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe @@ -376,7 +376,7 @@ -- instance C (Fam [Char]) remainingTysOrigSubst :: [Type] remainingTysOrigSubst = - map (substNamesWithKindStar (union droppedKindVarNames kvNames')) + map (substNamesWithKindStar (List.union droppedKindVarNames kvNames')) $ take remainingLength varTysOrig isDataFamily :: Bool @@ -969,7 +969,7 @@ -- | Construct a type via curried application. applyTy :: Type -> [Type] -> Type -applyTy = foldl' AppT +applyTy = List.foldl' AppT -- | Fully applies a type constructor to its type variables. applyTyCon :: Name -> [Type] -> Type @@ -1041,10 +1041,9 @@ tag2ConExpr ty = do iHash <- newName "i#" ty' <- freshenType ty - let tvbs = avoidTypeInType $ freeVariablesWellScoped [ty'] lam1E (conP iHashDataName [varP iHash]) $ varE tagToEnumHashValName `appE` varE iHash - `sigE` return (ForallT (changeTVFlags SpecifiedSpec tvbs) [] ty') + `sigE` return (quantifyType ty') -- tagToEnum# is a hack, and won't typecheck unless it's in the -- immediate presence of a type ascription like so: -- @@ -1057,40 +1056,7 @@ -- (using th-abstraction's quantifyType function). Also make sure -- to freshen the bound type variables to avoid shadowed variable -- warnings on old versions of GHC when -Wall is enabled. - where - -- Somewhat annoyingly, it's possible to generate code that requires - -- TypeInType (on old versions of GHC) for data types which didn't require - -- TypeInType to define. To avoid users having to turn on more language - -- extensions than is necessary, we filter out all kind variable binders. - -- Fortunately, old versions of GHC are quite alright with implicitly - -- quantifying kind variables, even in the type of a SigE. - -- - -- This is rather tiresome, and while writing this function, I debated - -- whether to just forget about this nonsense and require users to - -- enable TypeInType to use the generated code. Alas, that would entail - -- a breaking change, so I decided against it at the time. If we ever make - -- some breaking change in the future, however, this would be at the top - -- of the list of things that I'd rip out. - avoidTypeInType :: [TyVarBndrUnit] -> [TyVarBndrUnit] -#if __GLASGOW_HASKELL__ >= 806 - avoidTypeInType = id -#else - avoidTypeInType = go . map attachFreeKindVars - where - attachFreeKindVars :: TyVarBndrUnit -> (TyVarBndrUnit, [Name]) - attachFreeKindVars tvb = (tvb, freeVariables (tvKind tvb)) - go :: [(TyVarBndrUnit, [Name])] -> [TyVarBndrUnit] - go [] = [] - go ((tvb, _):tvbsAndFVs) - | any (\(_, kindVars) -> tvName tvb `elem` kindVars) tvbsAndFVs - = tvbs' - | otherwise - = tvb:tvbs' - where - tvbs' = go tvbsAndFVs -#endif - primOrdFunTbl :: Map Name (Name, Name, Name, Name, Name) primOrdFunTbl = Map.fromList [ (addrHashTypeName, ( ltAddrHashValName @@ -1155,6 +1121,20 @@ , gtWord16HashValName )) #endif +#if MIN_VERSION_base(4,16,0) + , (int32HashTypeName, ( ltInt32HashValName + , leInt32HashValName + , eqInt32HashValName + , geInt32HashValName + , gtInt32HashValName + )) + , (word32HashTypeName, ( ltWord32HashValName + , leWord32HashValName + , eqWord32HashValName + , geWord32HashValName + , gtWord32HashValName + )) +#endif ] removeClassApp :: Type -> Type @@ -2145,18 +2125,6 @@ eqWord16HashValName :: Name eqWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord16#" -extendInt8HashValName :: Name -extendInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "extendInt8#" - -extendInt16HashValName :: Name -extendInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "extendInt16#" - -extendWord8HashValName :: Name -extendWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "extendWord8#" - -extendWord16HashValName :: Name -extendWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "extendWord16#" - geInt8HashValName :: Name geInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geInt8#" @@ -2184,9 +2152,41 @@ int8HashTypeName :: Name int8HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int8#" +int8ToIntHashValName :: Name +int8ToIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "int8ToInt#" +# else + "extendInt8#" +# endif + int16HashTypeName :: Name int16HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int16#" +int16ToIntHashValName :: Name +int16ToIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "int16ToInt#" +# else + "extendInt16#" +# endif + +intToInt8HashValName :: Name +intToInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "intToInt8#" +# else + "narrowInt8#" +# endif + +intToInt16HashValName :: Name +intToInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "intToInt16#" +# else + "narrowInt16#" +# endif + leInt8HashValName :: Name leInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leInt8#" @@ -2214,6 +2214,88 @@ word8HashTypeName :: Name word8HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word8#" +word8ToWordHashValName :: Name +word8ToWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "word8ToWord#" +# else + "extendWord8#" +# endif + word16HashTypeName :: Name word16HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word16#" + +word16ToWordHashValName :: Name +word16ToWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "word16ToWord#" +# else + "extendWord16#" +# endif + +wordToWord8HashValName :: Name +wordToWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "wordToWord8#" +# else + "narrowWord8#" +# endif + +wordToWord16HashValName :: Name +wordToWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "wordToWord16#" +# else + "narrowWord16#" +# endif +#endif + +#if MIN_VERSION_base(4,16,0) +eqInt32HashValName :: Name +eqInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqInt32#" + +eqWord32HashValName :: Name +eqWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord32#" + +geInt32HashValName :: Name +geInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geInt32#" + +geWord32HashValName :: Name +geWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord32#" + +gtInt32HashValName :: Name +gtInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtInt32#" + +gtWord32HashValName :: Name +gtWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord32#" + +int32HashTypeName :: Name +int32HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int32#" + +int32ToIntHashValName :: Name +int32ToIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "int32ToInt#" + +intToInt32HashValName :: Name +intToInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "intToInt32#" + +leInt32HashValName :: Name +leInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leInt32#" + +leWord32HashValName :: Name +leWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord32#" + +ltInt32HashValName :: Name +ltInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltInt32#" + +ltWord32HashValName :: Name +ltWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord32#" + +word32HashTypeName :: Name +word32HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word32#" + +word32ToWordHashValName :: Name +word32ToWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "word32ToWord#" + +wordToWord32HashValName :: Name +wordToWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "wordToWord32#" #endif diff --git a/src/Data/Deriving/Via/Internal.hs b/src/Data/Deriving/Via/Internal.hs --- a/src/Data/Deriving/Via/Internal.hs +++ b/src/Data/Deriving/Via/Internal.hs @@ -1,5 +1,10 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TupleSections #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TemplateHaskellQuotes #-} +#endif + {-| Module: Data.Deriving.Via.Internal Copyright: (C) 2015-2017 Ryan Scott @@ -23,10 +28,13 @@ import Control.Monad ((<=<), unless) import Data.Deriving.Internal +import qualified Data.List as L import qualified Data.Map as M import Data.Map (Map) import Data.Maybe (catMaybes) +import GHC.Exts (Any) + import Language.Haskell.TH import Language.Haskell.TH.Datatype import Language.Haskell.TH.Datatype.TyVarBndr @@ -46,12 +54,11 @@ deriveGND :: Q Type -> Q [Dec] deriveGND qty = do ty <- qty - let (instanceTvbs, instanceCxt, instanceTy) = decomposeType ty + let (_instanceTvbs, instanceCxt, instanceTy) = decomposeType ty instanceTy' <- (resolveTypeSynonyms <=< resolveInfixT) instanceTy decs <- deriveViaDecs instanceTy' Nothing - let instanceHeader = ForallT instanceTvbs instanceCxt instanceTy - (:[]) `fmap` instanceD (return []) - (return instanceHeader) + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceTy) (map return decs) {- | Generates an instance for a type class by emulating the behavior of the @@ -71,7 +78,7 @@ deriveVia :: Q Type -> Q [Dec] deriveVia qty = do ty <- qty - let (instanceTvbs, instanceCxt, viaApp) = decomposeType ty + let (_instanceTvbs, instanceCxt, viaApp) = decomposeType ty viaApp' <- (resolveTypeSynonyms <=< resolveInfixT) viaApp (instanceTy, viaTy) <- case unapplyTy viaApp' of @@ -83,10 +90,17 @@ , "\tThe ‘Via‘ type must be used, e.g." , "\t[t| forall a. C (T a) `Via` V a |]" ] - decs <- deriveViaDecs instanceTy (Just viaTy) - let instanceHeader = ForallT instanceTvbs instanceCxt instanceTy - (:[]) `fmap` instanceD (return []) - (return instanceHeader) + -- This is a stronger requirement than what GHC's implementation of + -- DerivingVia imposes, but due to Template Haskell restrictions, we + -- currently can't do better. See #27. + let viaTyFVs = freeVariables viaTy + otherFVs = concat [freeVariables instanceCxt, freeVariables instanceTy] + floatingViaTyFVs = viaTyFVs L.\\ otherFVs + floatingViaTySubst = M.fromList $ map (, ConT ''Any) floatingViaTyFVs + viaTy' = applySubstitution floatingViaTySubst viaTy + decs <- deriveViaDecs instanceTy (Just viaTy') + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceTy) (map return decs) deriveViaDecs :: Type -- ^ The instance head (e.g., @Eq (Foo a)@) diff --git a/src/Data/Enum/Deriving.hs b/src/Data/Enum/Deriving.hs --- a/src/Data/Enum/Deriving.hs +++ b/src/Data/Enum/Deriving.hs @@ -28,4 +28,7 @@ * Type variables of kind @*@ are assumed to have 'Enum' constraints. If this is not desirable, use 'makeToEnum' or one of its cousins. + +* Generated 'Enum' instances for poly-kinded data family instances are likely + to require the use of the @TypeInType@ extension on GHC 8.0, 8.2, or 8.4. -} diff --git a/src/Data/Functor/Deriving/Internal.hs b/src/Data/Functor/Deriving/Internal.hs --- a/src/Data/Functor/Deriving/Internal.hs +++ b/src/Data/Functor/Deriving/Internal.hs @@ -56,7 +56,7 @@ import Control.Monad (guard) import Data.Deriving.Internal -import Data.List +import qualified Data.List as List import qualified Data.Map as Map ((!), keys, lookup, member, singleton) import Data.Maybe @@ -590,7 +590,7 @@ mkApCon :: Exp -> [Exp] -> Exp mkApCon conExp [] = VarE pureValName `AppE` conExp mkApCon conExp [e] = VarE fmapValName `AppE` conExp `AppE` e - mkApCon conExp (e1:e2:es) = foldl' appAp + mkApCon conExp (e1:e2:es) = List.foldl' appAp (VarE liftA2ValName `AppE` conExp `AppE` e1 `AppE` e2) es where appAp se1 se2 = InfixE (Just se1) (VarE apValName) (Just se2) @@ -703,7 +703,7 @@ conWildPat :: ConstructorInfo -> Pat conWildPat (ConstructorInfo { constructorName = conName , constructorFields = ts }) = - ConP conName $ replicate (length ts) WildP + conPCompat conName $ replicate (length ts) WildP ------------------------------------------------------------------------------- -- Generic traversal for functor-like deriving @@ -861,7 +861,7 @@ -> Q Match mkSimpleConMatch fold conName insides = do varsNeeded <- newNameList "_arg" $ length insides - let pat = ConP conName (map VarP varsNeeded) + let pat = conPCompat conName (map VarP varsNeeded) rhs <- fold conName (zipWith (\i v -> i $ VarE v) insides varsNeeded) return $ Match pat (NormalB rhs) [] @@ -885,7 +885,7 @@ -> Q Match mkSimpleConMatch2 fold conName insides = do varsNeeded <- newNameList "_arg" lengthInsides - let pat = ConP conName (map VarP varsNeeded) + let pat = conPCompat conName (map VarP varsNeeded) -- Make sure to zip BEFORE invoking catMaybes. We want the variable -- indicies in each expression to match up with the argument indices -- in conExpr (defined below). @@ -933,3 +933,11 @@ #endif m <- matchForCon tupDataName insides return $ CaseE x [m] + +-- Adapt to the type of ConP changing in template-haskell-2.18.0.0. +conPCompat :: Name -> [Pat] -> Pat +conPCompat n pats = ConP n +#if MIN_VERSION_template_haskell(2,18,0) + [] +#endif + pats diff --git a/src/Data/Ix/Deriving.hs b/src/Data/Ix/Deriving.hs --- a/src/Data/Ix/Deriving.hs +++ b/src/Data/Ix/Deriving.hs @@ -25,4 +25,7 @@ * Type variables of kind @*@ are assumed to have 'Ix' constraints. If this is not desirable, use 'makeRange' or one of its cousins. + +* Generated 'Ix' instances for poly-kinded data family instances are likely + to require the use of the @TypeInType@ extension on GHC 8.0, 8.2, or 8.4. -} diff --git a/src/Text/Show/Deriving/Internal.hs b/src/Text/Show/Deriving/Internal.hs --- a/src/Text/Show/Deriving/Internal.hs +++ b/src/Text/Show/Deriving/Internal.hs @@ -52,7 +52,7 @@ ) where import Data.Deriving.Internal -import Data.List +import qualified Data.List as List import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe (fromMaybe) @@ -398,7 +398,7 @@ then do let showArgs = zipWith (makeShowForArg 0 sClass opts conName tvMap) argTys' args parenCommaArgs = (varE showCharValName `appE` charE '(') - : intersperse (varE showCharValName `appE` charE ',') showArgs + : List.intersperse (varE showCharValName `appE` charE ',') showArgs mappendArgs = foldr (`infixApp` varE composeValName) (varE showCharValName `appE` charE ')') parenCommaArgs @@ -692,34 +692,46 @@ }) #if MIN_VERSION_base(4,13,0) , (int8HashTypeName, PrimShow - { primShowBoxer = appE (conE iHashDataName) . appE (varE extendInt8HashValName) + { primShowBoxer = appE (conE iHashDataName) . appE (varE int8ToIntHashValName) , primShowPostfixMod = oneHashE - , primShowConv = mkNarrowE "narrowInt8#" + , primShowConv = mkNarrowE intToInt8HashValName }) , (int16HashTypeName, PrimShow - { primShowBoxer = appE (conE iHashDataName) . appE (varE extendInt16HashValName) + { primShowBoxer = appE (conE iHashDataName) . appE (varE int16ToIntHashValName) , primShowPostfixMod = oneHashE - , primShowConv = mkNarrowE "narrowInt16#" + , primShowConv = mkNarrowE intToInt16HashValName }) , (word8HashTypeName, PrimShow - { primShowBoxer = appE (conE wHashDataName) . appE (varE extendWord8HashValName) + { primShowBoxer = appE (conE wHashDataName) . appE (varE word8ToWordHashValName) , primShowPostfixMod = twoHashE - , primShowConv = mkNarrowE "narrowWord8#" + , primShowConv = mkNarrowE wordToWord8HashValName }) , (word16HashTypeName, PrimShow - { primShowBoxer = appE (conE wHashDataName) . appE (varE extendWord16HashValName) + { primShowBoxer = appE (conE wHashDataName) . appE (varE word16ToWordHashValName) , primShowPostfixMod = twoHashE - , primShowConv = mkNarrowE "narrowWord16#" + , primShowConv = mkNarrowE wordToWord16HashValName }) #endif +#if MIN_VERSION_base(4,16,0) + , (int32HashTypeName, PrimShow + { primShowBoxer = appE (conE iHashDataName) . appE (varE int32ToIntHashValName) + , primShowPostfixMod = oneHashE + , primShowConv = mkNarrowE intToInt32HashValName + }) + , (word32HashTypeName, PrimShow + { primShowBoxer = appE (conE wHashDataName) . appE (varE word32ToWordHashValName) + , primShowPostfixMod = twoHashE + , primShowConv = mkNarrowE wordToWord32HashValName + }) +#endif ] #if MIN_VERSION_base(4,13,0) -mkNarrowE :: String -> Q Exp -> Q Exp -mkNarrowE narrowStr e = +mkNarrowE :: Name -> Q Exp -> Q Exp +mkNarrowE narrowName e = foldr (`infixApp` varE composeValName) (varE showCharValName `appE` charE ')') - [ varE showStringValName `appE` stringE ('(':narrowStr ++ " ") + [ varE showStringValName `appE` stringE ('(':nameBase narrowName ++ " ") , e ] #endif diff --git a/tests/BoundedEnumIxSpec.hs b/tests/BoundedEnumIxSpec.hs --- a/tests/BoundedEnumIxSpec.hs +++ b/tests/BoundedEnumIxSpec.hs @@ -10,6 +10,10 @@ {-# LANGUAGE PolyKinds #-} #endif +#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif + {-| Module: BoundedEnumSpec Copyright: (C) 2015-2017 Ryan Scott @@ -22,6 +26,9 @@ module BoundedEnumIxSpec where import Data.Deriving +#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806 +import Data.Kind +#endif import GHC.Arr (Ix(..)) diff --git a/tests/FunctorSpec.hs b/tests/FunctorSpec.hs --- a/tests/FunctorSpec.hs +++ b/tests/FunctorSpec.hs @@ -34,7 +34,7 @@ import Data.Char (chr) import Data.Foldable (fold) import Data.Deriving -import Data.Functor.Classes (Eq1) +import Data.Functor.Classes (Eq1, Show1) import Data.Functor.Compose (Compose(..)) import Data.Functor.Identity (Identity(..)) import Data.Monoid @@ -310,41 +310,44 @@ ------------------------------------------------------------------------------- -prop_FunctorLaws :: (Functor f, Eq (f a), Eq (f c)) - => (b -> c) -> (a -> b) -> f a -> Bool -prop_FunctorLaws f g x = - fmap id x == x - && fmap (f . g) x == (fmap f . fmap g) x +prop_FunctorLaws :: (Functor f, Eq (f a), Eq (f c), Show (f a), Show (f c)) + => (b -> c) -> (a -> b) -> f a -> Expectation +prop_FunctorLaws f g x = do + fmap id x `shouldBe` x + fmap (f . g) x `shouldBe` (fmap f . fmap g) x -prop_FunctorEx :: (Functor f, Eq (f [Int])) => f [Int] -> Bool +prop_FunctorEx :: (Functor f, Eq (f [Int]), Show (f [Int])) => f [Int] -> Expectation prop_FunctorEx = prop_FunctorLaws reverse (++ [42]) -prop_FoldableLaws :: (Eq a, Eq b, Eq z, Monoid a, Monoid b, Foldable f) - => (a -> b) -> (a -> z -> z) -> z -> f a -> Bool -prop_FoldableLaws f h z x = - fold x == foldMap id x - && foldMap f x == foldr (mappend . f) mempty x - && foldr h z x == appEndo (foldMap (Endo . h) x) z +prop_FoldableLaws :: (Eq a, Eq b, Eq z, Show a, Show b, Show z, + Monoid a, Monoid b, Foldable f) + => (a -> b) -> (a -> z -> z) -> z -> f a -> Expectation +prop_FoldableLaws f h z x = do + fold x `shouldBe` foldMap id x + foldMap f x `shouldBe` foldr (mappend . f) mempty x + foldr h z x `shouldBe` appEndo (foldMap (Endo . h) x) z -prop_FoldableEx :: Foldable f => f [Int] -> Bool +prop_FoldableEx :: Foldable f => f [Int] -> Expectation prop_FoldableEx = prop_FoldableLaws reverse ((+) . length) 0 prop_TraversableLaws :: forall t f g a b c. (Applicative f, Applicative g, Traversable t, - Eq (t (f a)), Eq (g (t a)), Eq (g (t b)), - Eq (t a), Eq (t c), Eq1 f, Eq1 g) + Eq (t (f a)), Eq (g (t a)), Eq (g (t b)), + Eq (t a), Eq (t c), Eq1 f, Eq1 g, + Show (t (f a)), Show (g (t a)), Show (g (t b)), + Show (t a), Show (t c), Show1 f, Show1 g) => (a -> f b) -> (b -> f c) - -> (forall x. f x -> g x) -> t a -> Bool -prop_TraversableLaws f g t x = - (t . traverse f) x == traverse (t . f) x - && traverse Identity x == Identity x - && traverse (Compose . fmap g . f) x - == (Compose . fmap (traverse g) . traverse f) x + -> (forall x. f x -> g x) -> t a -> Expectation +prop_TraversableLaws f g t x = do + (t . traverse f) x `shouldBe` traverse (t . f) x + traverse Identity x `shouldBe` Identity x + traverse (Compose . fmap g . f) x + `shouldBe` (Compose . fmap (traverse g) . traverse f) x - && (t . sequenceA) y == (sequenceA . fmap t) y - && (sequenceA . fmap Identity) y == Identity y - && (sequenceA . fmap Compose) z - == (Compose . fmap sequenceA . sequenceA) z + (t . sequenceA) y `shouldBe` (sequenceA . fmap t) y + (sequenceA . fmap Identity) y `shouldBe` Identity y + (sequenceA . fmap Compose) z + `shouldBe` (Compose . fmap sequenceA . sequenceA) z where y :: t (f a) y = fmap pure x @@ -352,9 +355,10 @@ z :: t (f (g a)) z = fmap (fmap pure) y -prop_TraversableEx :: (Traversable t, Eq (t [[Int]]), - Eq (t [Int]), Eq (t String), Eq (t Char)) - => t [Int] -> Bool +prop_TraversableEx :: (Traversable t, + Eq (t [[Int]]), Eq (t [Int]), Eq (t String), Eq (t Char), + Show (t [[Int]]), Show (t [Int]), Show (t String), Show (t Char)) + => t [Int] -> Expectation prop_TraversableEx = prop_TraversableLaws (replicate 2 . map (chr . abs)) (++ "Hello") @@ -369,17 +373,17 @@ spec = parallel $ do describe "OneTwoCompose Maybe ((,) Bool) [Int] [Int]" $ do prop "satisfies the Functor laws" - (prop_FunctorEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool) + (prop_FunctorEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Expectation) prop "satisfies the Foldable laws" - (prop_FoldableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool) + (prop_FoldableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Expectation) prop "satisfies the Traversable laws" - (prop_TraversableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool) + (prop_TraversableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Expectation) #if MIN_VERSION_template_haskell(2,7,0) describe "OneTwoComposeFam Maybe ((,) Bool) [Int] [Int]" $ do prop "satisfies the Functor laws" - (prop_FunctorEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool) + (prop_FunctorEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Expectation) prop "satisfies the Foldable laws" - (prop_FoldableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool) + (prop_FoldableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Expectation) prop "satisfies the Traversable laws" - (prop_TraversableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool) + (prop_TraversableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Expectation) #endif diff --git a/tests/GH24Spec.hs b/tests/GH24Spec.hs --- a/tests/GH24Spec.hs +++ b/tests/GH24Spec.hs @@ -2,7 +2,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -#if __GLASGOW_HASKELL__ >= 800 +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif + +#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif diff --git a/tests/GH27Spec.hs b/tests/GH27Spec.hs --- a/tests/GH27Spec.hs +++ b/tests/GH27Spec.hs @@ -6,7 +6,6 @@ #if MIN_VERSION_template_haskell(2,12,0) {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-unused-foralls #-} -- Due to GHC #13512. Sigh. #endif {-| @@ -18,10 +17,6 @@ A regression test for https://github.com/haskell-compat/deriving-compat/issues/27. -We isolate this test case from the rest of "DerivingViaSpec" because -we have to disable @-Wunused-foralls@ due to -https://gitlab.haskell.org/ghc/ghc/issues/13512, and we would prefer not to -contaminate the rest of "DerivingViaSpec" with this hack. -} module GH27Spec where diff --git a/tests/OrdSpec.hs b/tests/OrdSpec.hs --- a/tests/OrdSpec.hs +++ b/tests/OrdSpec.hs @@ -24,13 +24,13 @@ ------------------------------------------------------------------------------- -prop_Ord :: (Ord a, Ord (f a), Ord1 f) => f a -> f a -> Bool -prop_Ord x y = compare x y == compare1 x y +prop_Ord :: (Ord a, Ord (f a), Ord1 f) => f a -> f a -> Expectation +prop_Ord x y = compare x y `shouldBe` compare1 x y ordSpec :: forall proxy f a. (Arbitrary (f a), Show (f a), Ord a, Ord (f a), Ord1 f) => proxy (f a) -> Spec -ordSpec _ = prop "has a valid Ord1 instance" (prop_Ord :: f a -> f a -> Bool) +ordSpec _ = prop "has a valid Ord1 instance" (prop_Ord :: f a -> f a -> Expectation) ------------------------------------------------------------------------------- diff --git a/tests/ReadSpec.hs b/tests/ReadSpec.hs --- a/tests/ReadSpec.hs +++ b/tests/ReadSpec.hs @@ -87,8 +87,8 @@ prop_Read :: forall f a. (Read a, Read (f a), Read1 f, Eq (f a), Show (f a)) - => f a -> Bool -prop_Read x = readArb readsPrec == readArb readsPrec1 + => f a -> Expectation +prop_Read x = readArb readsPrec `shouldBe` readArb readsPrec1 where readArb :: (Int -> ReadS (f a)) -> f a readArb = read' (show x) @@ -96,7 +96,7 @@ readSpec :: forall f a. (Arbitrary (f a), Eq (f a), Show (f a), Read a, Read (f a), Read1 f) => Proxy (f a) -> Spec -readSpec _ = prop "has a valid Read1 instance" (prop_Read :: f a -> Bool) +readSpec _ = prop "has a valid Read1 instance" (prop_Read :: f a -> Expectation) -- Adapted from the definition of readEither readEither' :: String -> (Int -> ReadS a) -> Either String a diff --git a/tests/ShowSpec.hs b/tests/ShowSpec.hs --- a/tests/ShowSpec.hs +++ b/tests/ShowSpec.hs @@ -26,6 +26,9 @@ #if MIN_VERSION_base(4,13,0) , Int8#, Int16#, Word8#, Word16# #endif +#if MIN_VERSION_base(4,16,0) + , Int32#, Word32# +#endif ) import Prelude () @@ -53,6 +56,10 @@ , tcWord8# :: Word8# , tcWord16# :: Word16# #endif +#if MIN_VERSION_base(4,16,0) + , tcInt32# :: Int32# + , tcWord32# :: Word32# +#endif } data TyCon2 a b c d where @@ -93,6 +100,10 @@ , tfInt16# :: Int16# , tfWord8# :: Word8# , tfWord16# :: Word16# +#endif +#if MIN_VERSION_base(4,16,0) + , tfInt32# :: Int32# + , tfWord32# :: Word32# #endif } diff --git a/tests/Types/EqOrd.hs b/tests/Types/EqOrd.hs --- a/tests/Types/EqOrd.hs +++ b/tests/Types/EqOrd.hs @@ -26,6 +26,9 @@ #if MIN_VERSION_base(4,13,0) , Int8#, Int16#, Word8#, Word16# #endif +#if MIN_VERSION_base(4,16,0) + , Int32#, Word32# +#endif ) -- Plain data types @@ -60,6 +63,10 @@ , tcWord8# :: Word8# , tcWord16# :: Word16# #endif +#if MIN_VERSION_base(4,16,0) + , tcInt32# :: Int32# + , tcWord32# :: Word32# +#endif } data TyCon2 a b c d where @@ -115,6 +122,10 @@ , tfInt16# :: Int16# , tfWord8# :: Word8# , tfWord16# :: Word16# +#endif +#if MIN_VERSION_base(4,16,0) + , tfInt32# :: Int32# + , tfWord32# :: Word32# #endif }