deriving-compat 0.6.6 → 0.6.7
raw patch · 26 files changed
+76/−795 lines, 26 filesdep −base-compatdep −semigroupsdep ~basedep ~containersdep ~template-haskellPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies removed: base-compat, semigroups
Dependency ranges changed: base, containers, template-haskell, th-abstraction, transformers
API changes (from Hackage documentation)
- Data.Deriving.Internal: ghc7'8OrLater :: Bool
- Data.Deriving.Internal: predMentionsName :: Pred -> [Name] -> Bool
Files
- CHANGELOG.md +3/−0
- deriving-compat.cabal +15/−61
- src/Data/Deriving/Internal.hs +11/−200
- src/Data/Deriving/Via/Internal.hs +1/−4
- src/Data/Eq/Deriving.hs +0/−5
- src/Data/Eq/Deriving/Internal.hs +2/−55
- src/Data/Functor/Deriving/Internal.hs +4/−31
- src/Data/Ord/Deriving.hs +0/−5
- src/Data/Ord/Deriving/Internal.hs +2/−95
- src/Text/Read/Deriving.hs +3/−7
- src/Text/Read/Deriving/Internal.hs +10/−82
- src/Text/Show/Deriving.hs +0/−5
- src/Text/Show/Deriving/Internal.hs +5/−63
- tests/BoundedEnumIxSpec.hs +5/−27
- tests/DerivingViaSpec.hs +0/−3
- tests/EqSpec.hs +0/−3
- tests/FunctorSpec.hs +4/−22
- tests/GH24Spec.hs +2/−12
- tests/GH27Spec.hs +0/−3
- tests/GH31Spec.hs +0/−3
- tests/GH6Spec.hs +0/−3
- tests/OrdSpec.hs +0/−3
- tests/ReadSpec.hs +0/−14
- tests/ShowSpec.hs +1/−14
- tests/Types/EqOrd.hs +4/−37
- tests/Types/ReadShow.hs +4/−38
CHANGELOG.md view
@@ -1,3 +1,6 @@+### 0.6.7 [2024.12.05]+* Drop support for pre-8.0 versions of GHC.+ ### 0.6.6 [2024.03.19] * Support building with `template-haskell-2.22.*` (GHC 9.10).
deriving-compat.cabal view
@@ -1,5 +1,5 @@ name: deriving-compat-version: 0.6.6+version: 0.6.7 synopsis: Backports of GHC deriving extensions description: @deriving-compat@ provides Template Haskell functions that mimic @deriving@ extensions that were introduced or modified@@ -78,13 +78,7 @@ category: Compatibility build-type: Simple extra-source-files: CHANGELOG.md, README.md-tested-with: GHC == 7.0.4- , GHC == 7.2.2- , GHC == 7.4.2- , GHC == 7.6.3- , GHC == 7.8.4- , GHC == 7.10.3- , GHC == 8.0.2+tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5@@ -93,30 +87,16 @@ , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.8- , GHC == 9.6.4- , GHC == 9.8.2+ , GHC == 9.6.6+ , GHC == 9.8.4 , GHC == 9.10.1+ , GHC == 9.12.1 cabal-version: >=1.10 source-repository head type: git location: https://github.com/haskell-compat/deriving-compat -flag base-4-9- description: Use base-4.9 or later.- default: True--flag template-haskell-2-11- description: Use template-haskell-2.11.0.0 or later.- default: True--flag new-functor-classes- description: Use a version of transformers or transformers-compat with a- modern-style Data.Functor.Classes module. This flag cannot be- used when building with transformers-0.4, since it comes with- a different version of Data.Functor.Classes.- default: True- library exposed-modules: Data.Deriving Data.Deriving.Internal@@ -141,29 +121,14 @@ Text.Read.Deriving.Internal Text.Show.Deriving Text.Show.Deriving.Internal- build-depends: containers >= 0.1 && < 0.8- , ghc-prim- , th-abstraction >= 0.4 && < 0.8-- if flag(base-4-9)- build-depends: base >= 4.9 && < 5- cpp-options: "-DNEW_FUNCTOR_CLASSES"- else- build-depends: base >= 4.3 && < 4.9- , semigroups >= 0.6 && < 0.21-- if flag(template-haskell-2-11)- build-depends: template-haskell >= 2.11 && < 2.23+ build-depends: base >= 4.9 && < 5+ , containers >= 0.1 && < 0.8 , ghc-boot-th- else- build-depends: template-haskell >= 2.5 && < 2.11-- if flag(new-functor-classes)- build-depends: transformers (>= 0.2 && < 0.4) || (>= 0.5 && < 0.7)+ , ghc-prim+ , template-haskell >= 2.11 && < 2.24+ , th-abstraction >= 0.5 && < 0.8+ , transformers >= 0.5 && < 0.7 , transformers-compat >= 0.5- cpp-options: "-DNEW_FUNCTOR_CLASSES"- else- build-depends: transformers == 0.4.* hs-source-dirs: src default-language: Haskell2010@@ -186,28 +151,17 @@ Types.EqOrd Types.ReadShow- build-depends: base-compat >= 0.8.1 && < 1+ build-depends: base >= 4.9 && < 5 , base-orphans >= 0.5 && < 1 , deriving-compat , hspec >= 1.8 , QuickCheck >= 2 && < 3 , tagged >= 0.7 && < 1- , template-haskell >= 2.5 && < 2.23+ , template-haskell >= 2.11 && < 2.24+ , transformers >= 0.5 && < 0.7+ , transformers-compat >= 0.5 , void >= 0.5.10 && < 1 build-tool-depends: hspec-discover:hspec-discover >= 1.8-- if flag(base-4-9)- build-depends: base >= 4.9 && < 5- cpp-options: "-DNEW_FUNCTOR_CLASSES"- else- build-depends: base >= 4.3 && < 4.9-- if flag(new-functor-classes)- build-depends: transformers (>= 0.2 && < 0.4) || (>= 0.5 && < 0.7)- , transformers-compat >= 0.5- cpp-options: "-DNEW_FUNCTOR_CLASSES"- else- build-depends: transformers == 0.4.* hs-source-dirs: tests default-language: Haskell2010
src/Data/Deriving/Internal.hs view
@@ -2,12 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-}--#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TemplateHaskellQuotes #-}-#else-{-# LANGUAGE TemplateHaskell #-}-#endif {-| Module: Data.Deriving.Internal@@ -29,18 +24,11 @@ import qualified Data.Foldable as F import Data.Functor.Classes ( Eq1(..), Ord1(..), Read1(..), Show1(..)-#if MIN_VERSION_base(4,10,0)- , liftReadListPrecDefault-#endif- )-#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0)-import Data.Functor.Classes- ( Eq2(..), Ord2(..), Read2(..), Show2(..)+ , Eq2(..), Ord2(..), Read2(..), Show2(..) #if MIN_VERSION_base(4,10,0)- , liftReadListPrec2Default+ , liftReadListPrecDefault, liftReadListPrec2Default #endif )-#endif import qualified Data.List as List import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map@@ -54,7 +42,8 @@ import GHC.Arr (Ix(..)) import GHC.Base (getTag) import GHC.Exts-import GHC.Read (choose, list, paren)+import GHC.Lexeme (startsConSym, startsVarSym)+import GHC.Read (choose, expectP, list, paren) import GHC.Show (showSpace) #if MIN_VERSION_base(4,19,0) import GHC.Int (Int8(..), Int16(..), Int32(..), Int64(..))@@ -69,21 +58,6 @@ import qualified Text.Read.Lex as L import Text.Show (showListWith) -#if MIN_VERSION_base(4,7,0)-import GHC.Read (expectP)-#else-import GHC.Read (lexP)-import Text.Read.Lex (Lexeme)-#endif--#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative (Applicative(..))-import Data.Foldable (Foldable(..))-import Data.Functor (Functor(..))-import Data.Monoid (Monoid(..))-import Data.Traversable (Traversable(..))-#endif- #if MIN_VERSION_base(4,10,0) import GHC.Show (showCommaSpace) #endif@@ -92,12 +66,6 @@ import GHC.Read (readField, readSymField) #endif -#if defined(MIN_VERSION_ghc_boot_th)-import GHC.Lexeme (startsConSym, startsVarSym)-#else-import Data.Char (isSymbol, ord)-#endif- import Language.Haskell.TH.Datatype as Datatype import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Lib@@ -115,11 +83,7 @@ ------------------------------------------------------------------------------- applySubstitutionKind :: Map Name Kind -> Type -> Type-#if MIN_VERSION_template_haskell(2,8,0) applySubstitutionKind = applySubstitution-#else-applySubstitutionKind _ t = t-#endif substNameWithKind :: Name -> Kind -> Type -> Type substNameWithKind n k = applySubstitutionKind (Map.singleton n k)@@ -285,9 +249,7 @@ canRealizeKindStar t | hasKindStar t = KindStar | otherwise = case t of-#if MIN_VERSION_template_haskell(2,8,0) SigT _ (VarT k) -> IsKindVar k-#endif _ -> NotKindStar -- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.@@ -409,13 +371,11 @@ isDataFamily <- case variant of- Datatype -> return False- Newtype -> return False- DataInstance -> return True- NewtypeInstance -> return True-#if MIN_VERSION_th_abstraction(0,5,0)+ Datatype -> return False+ Newtype -> return False+ DataInstance -> return True+ NewtypeInstance -> return True Datatype.TypeData -> typeDataError tyConName-#endif let remainingTysOrigSubst' :: [Type] -- See Note [Kind signatures in derived instances] for an explanation@@ -434,7 +394,7 @@ -- If the datatype context mentions any of the dropped type variables, -- we can't derive an instance, so throw an error.- when (any (`predMentionsName` droppedTyVarNames) dataCxt) $+ when (any (`mentionsName` droppedTyVarNames) dataCxt) $ datatypeContextError tyConName instanceType -- Also ensure the dropped types can be safely eta-reduced. Otherwise, -- throw an error.@@ -547,7 +507,7 @@ checkExistentialContext :: ClassRep a => a -> TyVarMap b -> Cxt -> Name -> Q c -> Q c checkExistentialContext cRep tvMap ctxt conName q =- if (any (`predMentionsName` Map.keys tvMap) ctxt+ if (any (`mentionsName` Map.keys tvMap) ctxt || Map.size tvMap < arity cRep) && not (allowExQuant cRep) then existentialContextError conName@@ -708,12 +668,6 @@ interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s interleave _ _ = [] -#if !(MIN_VERSION_ghc_prim(0,3,1))-isTrue# :: Bool -> Bool-isTrue# x = x-{-# INLINE isTrue# #-}-#endif- -- filterByList, filterByLists, and partitionByList taken from GHC (BSD3-licensed) -- | 'filterByList' takes a list of Bools and a list of some elements and@@ -761,21 +715,13 @@ -- | Returns True if a Type has kind *. hasKindStar :: Type -> Bool hasKindStar VarT{} = True-#if MIN_VERSION_template_haskell(2,8,0) hasKindStar (SigT _ StarT) = True-#else-hasKindStar (SigT _ StarK) = True-#endif hasKindStar _ = False -- Returns True is a kind is equal to *, or if it is a kind variable. isStarOrVar :: Kind -> Bool-#if MIN_VERSION_template_haskell(2,8,0) isStarOrVar StarT = True isStarOrVar VarT{} = True-#else-isStarOrVar StarK = True-#endif isStarOrVar _ = False -- | @hasKindVarChain n kind@ Checks if @kind@ is of the form@@ -857,22 +803,14 @@ -- | Applies a typeclass constraint to a type. applyClass :: Name -> Name -> Pred-#if MIN_VERSION_template_haskell(2,10,0) applyClass con t = AppT (ConT con) (VarT t)-#else-applyClass con t = ClassP con [VarT t]-#endif createKindChain :: Int -> Kind createKindChain = go starK where go :: Kind -> Int -> Kind go k !0 = k-#if MIN_VERSION_template_haskell(2,8,0) go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1)-#else- go k !n = go (ArrowK StarK k) (n - 1)-#endif -- | Checks to see if the last types in a data family instance can be safely eta- -- reduced (i.e., dropped), given the other types. This checks for three conditions:@@ -940,25 +878,10 @@ go tcName = do info <- reify tcName case info of-#if MIN_VERSION_template_haskell(2,11,0) FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _ -> withinFirstArgs bndrs-#elif MIN_VERSION_template_haskell(2,7,0)- FamilyI (FamilyD TypeFam _ bndrs _) _- -> withinFirstArgs bndrs-#else- TyConI (FamilyD TypeFam _ bndrs _)- -> withinFirstArgs bndrs-#endif--#if MIN_VERSION_template_haskell(2,11,0) FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _ -> withinFirstArgs bndrs-#elif MIN_VERSION_template_haskell(2,9,0)- FamilyI (ClosedTypeFamilyD _ bndrs _ _) _- -> withinFirstArgs bndrs-#endif- _ -> return False where withinFirstArgs :: [a] -> Q Bool@@ -985,22 +908,10 @@ where go :: Type -> [Name] -> Bool go (AppT t1 t2) names = go t1 names || go t2 names- go (SigT t _k) names = go t names-#if MIN_VERSION_template_haskell(2,8,0)- || go _k names-#endif+ go (SigT t k) names = go t names || go k names go (VarT n) names = n `elem` names go _ _ = False --- | Does an instance predicate mention any of the Names in the list?-predMentionsName :: Pred -> [Name] -> Bool-#if MIN_VERSION_template_haskell(2,10,0)-predMentionsName = mentionsName-#else-predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys-predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names-#endif- -- | Construct a type via curried application. applyTy :: Type -> [Type] -> Type applyTy = List.foldl' AppT@@ -1026,10 +937,8 @@ go :: Type -> Type -> [Type] -> (Type, [Type]) go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args) go origTy (SigT ty' _) args = go origTy ty' args-#if MIN_VERSION_template_haskell(2,11,0) go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args go origTy (ParensT ty') args = go origTy ty' args-#endif go origTy _ args = (origTy, args) -- | Split a type signature by the arrows on its spine. For example, this:@@ -1056,12 +965,7 @@ -- | Like uncurryType, except on a kind level. uncurryKind :: Kind -> [Kind]-#if MIN_VERSION_template_haskell(2,8,0) uncurryKind = snd . uncurryTy-#else-uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2-uncurryKind k = [k]-#endif untagExpr :: [(Name, Name)] -> Q Exp -> Q Exp untagExpr [] e = e@@ -1216,22 +1120,6 @@ isSym "" = False isSym (c : _) = startsVarSym c || startsConSym c -#if !defined(MIN_VERSION_ghc_boot_th)-startsVarSym, startsConSym :: Char -> Bool-startsVarSym c = startsVarSymASCII c || (ord c > 0x7f && isSymbol c) -- Infix Ids-startsConSym c = c == ':' -- Infix data constructors--startsVarSymASCII :: Char -> Bool-startsVarSymASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"-#endif--ghc7'8OrLater :: Bool-#if __GLASGOW_HASKELL__ >= 708-ghc7'8OrLater = True-#else-ghc7'8OrLater = False-#endif- ------------------------------------------------------------------------------- -- Quoted names -------------------------------------------------------------------------------@@ -1726,13 +1614,6 @@ wHashDataName :: Name wHashDataName = 'W# -#if !(MIN_VERSION_base(4,7,0))-expectP :: Lexeme -> ReadPrec ()-expectP lexeme = do- thing <- lexP- if thing == lexeme then return () else pfail-#endif- expectPValName :: Name expectPValName = 'expectP @@ -1769,7 +1650,6 @@ show1TypeName :: Name show1TypeName = ''Show1 -#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) eq2TypeName :: Name eq2TypeName = ''Eq2 @@ -1817,78 +1697,9 @@ liftShowsPrec2ValName :: Name liftShowsPrec2ValName = 'liftShowsPrec2-#else-eq1ValName :: Name-eq1ValName = 'eq1 -compare1ValName :: Name-compare1ValName = 'compare1--readsPrec1ValName :: Name-readsPrec1ValName = 'readsPrec1--showsPrec1ValName :: Name-showsPrec1ValName = 'showsPrec1--newtype Apply f a = Apply { unApply :: f a }--instance (Eq1 f, Eq a) => Eq (Apply f a) where- Apply x == Apply y = eq1 x y--instance (Ord1 g, Ord a) => Ord (Apply g a) where- compare (Apply x) (Apply y) = compare1 x y--instance (Read1 f, Read a) => Read (Apply f a) where- readsPrec d s = [(Apply a, t) | (a, t) <- readsPrec1 d s]--instance (Show1 f, Show a) => Show (Apply f a) where- showsPrec p (Apply x) = showsPrec1 p x--makeFmapApplyNeg :: ClassRep a => a -> Name -> Type -> Name -> Q Exp-makeFmapApplyNeg = makeFmapApply False--makeFmapApplyPos :: ClassRep a => a -> Name -> Type -> Name -> Q Exp-makeFmapApplyPos = makeFmapApply True--makeFmapApply :: ClassRep a => Bool -> a -> Name -> Type -> Name -> Q Exp-makeFmapApply pos cRep conName (SigT ty _) name = makeFmapApply pos cRep conName ty name-makeFmapApply pos cRep conName t name = do- let tyCon :: Type- tyArgs :: [Type]- (tyCon, tyArgs) = unapplyTy t-- numLastArgs :: Int- numLastArgs = min (arity cRep) (length tyArgs)-- lhsArgs, rhsArgs :: [Type]- (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs-- inspectTy :: Type -> Q Exp- inspectTy (SigT ty _) = inspectTy ty- inspectTy (VarT a) | a == name = varE idValName- inspectTy beta = varE fmapValName `appE`- infixApp (if pos then makeFmapApply pos cRep conName beta name- else conE applyDataName)- (varE composeValName)- (if pos then varE unApplyValName- else makeFmapApply pos cRep conName beta name)-- itf <- isInTypeFamilyApp [name] tyCon tyArgs- if any (`mentionsName` [name]) lhsArgs || itf- then outOfPlaceTyVarError cRep conName- else inspectTy (head rhsArgs)--applyDataName :: Name-applyDataName = 'Apply--unApplyValName :: Name-unApplyValName = 'unApply-#endif--#if MIN_VERSION_base(4,7,0) coerceValName :: Name coerceValName = 'coerce-#endif #if MIN_VERSION_base(4,10,0) liftReadListPrecDefaultValName :: Name
src/Data/Deriving/Via/Internal.hs view
@@ -1,9 +1,6 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TupleSections #-}--#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TemplateHaskellQuotes #-}-#endif+{-# LANGUAGE TupleSections #-} {-| Module: Data.Deriving.Via.Internal
src/Data/Eq/Deriving.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-| Module: Data.Eq.Deriving Copyright: (C) 2015-2017 Ryan Scott@@ -19,16 +18,12 @@ , makeNotEq -- * 'Eq1' , deriveEq1-#if defined(NEW_FUNCTOR_CLASSES) , makeLiftEq-#endif , makeEq1-#if defined(NEW_FUNCTOR_CLASSES) -- * 'Eq2' , deriveEq2 , makeLiftEq2 , makeEq2-#endif -- * 'deriveEq' limitations -- $constraints ) where
src/Data/Eq/Deriving/Internal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-|@@ -20,16 +19,12 @@ , makeNotEq -- * 'Eq1' , deriveEq1-#if defined(NEW_FUNCTOR_CLASSES) , makeLiftEq-#endif , makeEq1-#if defined(NEW_FUNCTOR_CLASSES) -- * 'Eq2' , deriveEq2 , makeLiftEq2 , makeEq2-#endif ) where import Data.Deriving.Internal@@ -64,7 +59,6 @@ deriveEq1 :: Name -> Q [Dec] deriveEq1 = deriveEqClass Eq1 -#if defined(NEW_FUNCTOR_CLASSES) -- | Generates a lambda expression which behaves like 'liftEq' (without -- requiring an 'Eq1' instance). --@@ -76,14 +70,7 @@ -- requiring an 'Eq1' instance). makeEq1 :: Name -> Q Exp makeEq1 name = makeLiftEq name `appE` varE eqValName-#else--- | Generates a lambda expression which behaves like 'eq1' (without--- requiring an 'Eq1' instance).-makeEq1 :: Name -> Q Exp-makeEq1 = makeEqClass Eq1-#endif -#if defined(NEW_FUNCTOR_CLASSES) -- | Generates an 'Eq2' instance declaration for the given data type or data -- family instance. --@@ -104,7 +91,6 @@ -- This function is not available with @transformers-0.4@. makeEq2 :: Name -> Q Exp makeEq2 name = makeLiftEq name `appE` varE eqValName `appE` varE eqValName-#endif ------------------------------------------------------------------------------- -- Code generation@@ -170,19 +156,12 @@ let lastTyVars = map varTToName $ drop (length instTypes - fromEnum eClass) instTypes tvMap = Map.fromList $ zipWith (\x y -> (x, OneName y)) lastTyVars eqs - lamE (map varP $-#if defined(NEW_FUNCTOR_CLASSES)- eqs ++-#endif- [value1, value2]+ lamE (map varP $ eqs ++ [value1, value2] ) . appsE $ [ varE $ eqConstName eClass , letE [ funD eqDefn [eqClause tvMap] ] $ varE eqDefn `appE` varE value1 `appE` varE value2- ]-#if defined(NEW_FUNCTOR_CLASSES)- ++ map varE eqs-#endif+ ] ++ map varE eqs ++ [varE value1, varE value2] where nonNullaryCons :: [ConstructorInfo]@@ -311,17 +290,12 @@ -> Name -> Type -> Q Exp-#if defined(NEW_FUNCTOR_CLASSES) makeCaseForType _ tvMap _ (VarT tyName) = varE $ case Map.lookup tyName tvMap of Just (OneName eq) -> eq Nothing -> eqValName-#else-makeCaseForType _ _ _ VarT{} = varE eqValName-#endif makeCaseForType eClass tvMap conName (SigT ty _) = makeCaseForType eClass tvMap conName ty makeCaseForType eClass tvMap conName (ForallT _ _ ty) = makeCaseForType eClass tvMap conName ty-#if defined(NEW_FUNCTOR_CLASSES) makeCaseForType eClass tvMap conName ty = do let tyCon :: Type tyArgs :: [Type]@@ -344,22 +318,7 @@ then appsE $ [ varE . eqName $ toEnum numLastArgs] ++ map (makeCaseForType eClass tvMap conName) rhsArgs else varE eqValName-#else-makeCaseForType eClass tvMap conName ty = do- let varNames = Map.keys tvMap - a' <- newName "a'"- b' <- newName "b'"- case varNames of- [] -> varE eqValName- varName:_ ->- if mentionsName ty varNames- then lamE (map varP [a',b']) $ varE eq1ValName- `appE` (makeFmapApplyNeg eClass conName ty varName `appE` varE a')- `appE` (makeFmapApplyNeg eClass conName ty varName `appE` varE b')- else varE eqValName-#endif- ------------------------------------------------------------------------------- -- Class-specific constants -------------------------------------------------------------------------------@@ -367,9 +326,7 @@ -- | A representation of which @Eq@ variant is being derived. data EqClass = Eq | Eq1-#if defined(NEW_FUNCTOR_CLASSES) | Eq2-#endif deriving (Bounded, Enum) instance ClassRep EqClass where@@ -379,9 +336,7 @@ fullClassName Eq = eqTypeName fullClassName Eq1 = eq1TypeName-#if defined(NEW_FUNCTOR_CLASSES) fullClassName Eq2 = eq2TypeName-#endif classConstraint eClass i | eMin <= i && i <= eMax = Just $ fullClassName (toEnum i :: EqClass)@@ -393,18 +348,10 @@ eqConstName :: EqClass -> Name eqConstName Eq = eqConstValName-#if defined(NEW_FUNCTOR_CLASSES) eqConstName Eq1 = liftEqConstValName eqConstName Eq2 = liftEq2ConstValName-#else-eqConstName Eq1 = eq1ConstValName-#endif eqName :: EqClass -> Name eqName Eq = eqValName-#if defined(NEW_FUNCTOR_CLASSES) eqName Eq1 = liftEqValName eqName Eq2 = liftEq2ValName-#else-eqName Eq1 = eq1ValName-#endif
src/Data/Functor/Deriving/Internal.hs view
@@ -311,18 +311,12 @@ where makeFun :: Name -> Name -> TyVarMap1 -> Q Exp makeFun z value tvMap = do-#if MIN_VERSION_template_haskell(2,9,0) roles <- reifyRoles _parentName-#endif case () of- _--#if MIN_VERSION_template_haskell(2,9,0)- | Just (_, PhantomR) <- unsnoc roles+ _ | Just (_, PhantomR) <- unsnoc roles -> functorFunPhantom z value-#endif - | null cons && fftEmptyCaseBehavior opts && ghc7'8OrLater+ | null cons && fftEmptyCaseBehavior opts -> functorFunEmptyCase ff z value | null cons@@ -332,7 +326,6 @@ -> caseE (varE value) (map (makeFunctorFunForCon ff z tvMap) cons) -#if MIN_VERSION_template_haskell(2,9,0) functorFunPhantom :: Name -> Name -> Q Exp functorFunPhantom z value = functorFunTrivial coerce@@ -341,7 +334,6 @@ where coerce :: Q Exp coerce = varE coerceValName `appE` varE value-#endif -- | Generates a match for a single constructor. makeFunctorFunForCon :: FunctorFun -> Name -> TyVarMap1 -> ConstructorInfo -> Q Match@@ -650,11 +642,7 @@ functorClassToFuns :: FunctorClass -> [FunctorFun] functorClassToFuns Functor = [ Fmap, Replace ]-functorClassToFuns Foldable = [ Foldr, FoldMap-#if MIN_VERSION_base(4,8,0)- , Null-#endif- ]+functorClassToFuns Foldable = [ Foldr, FoldMap, Null ] functorClassToFuns Traversable = [ Traverse ] functorFunToClass :: FunctorFun -> FunctorClass@@ -779,10 +767,8 @@ -- and at least one xr is True | TupleT len <- f -> tuple $ Boxed len-#if MIN_VERSION_template_haskell(2,6,0) | UnboxedTupleT len <- f -> tuple $ Unboxed len-#endif | fc || or (init xcs) -> wrongArg -- T (..var..) ty | otherwise -- T (..no var..) ty@@ -792,7 +778,7 @@ then wrongArg else return (caseTyApp (last args) (last xrs), True) go co (SigT t k) = do- (_, kc) <- go_kind co k+ (_, kc) <- go co k if kc then return (caseWrongArg, True) else go co t@@ -809,15 +795,6 @@ else return (caseForAll tvbs tr, True) go _ _ = trivial - go_kind :: Bool- -> Kind- -> Q (a, Bool)-#if MIN_VERSION_template_haskell(2,9,0)- go_kind = go-#else- go_kind _ _ = trivial-#endif- trivial :: Q (a, Bool) trivial = return (caseTrivial, False) @@ -916,9 +893,7 @@ -- corresponds to @Unboxed 3@. data TupleSort = Boxed Int-#if MIN_VERSION_template_haskell(2,6,0) | Unboxed Int-#endif -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" mkSimpleTupleCase :: (Name -> [a] -> Q Match)@@ -926,9 +901,7 @@ mkSimpleTupleCase matchForCon tupSort insides x = do let tupDataName = case tupSort of Boxed len -> tupleDataName len-#if MIN_VERSION_template_haskell(2,6,0) Unboxed len -> unboxedTupleDataName len-#endif m <- matchForCon tupDataName insides return $ CaseE x [m]
src/Data/Ord/Deriving.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-| Module: Data.Ord.Deriving Copyright: (C) 2015-2017 Ryan Scott@@ -24,16 +23,12 @@ , makeMin -- * 'Ord1' , deriveOrd1-#if defined(NEW_FUNCTOR_CLASSES) , makeLiftCompare-#endif , makeCompare1-#if defined(NEW_FUNCTOR_CLASSES) -- * 'Ord2' , deriveOrd2 , makeLiftCompare2 , makeCompare2-#endif -- * 'deriveOrd' limitations -- $constraints ) where
src/Data/Ord/Deriving/Internal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-|@@ -25,16 +24,12 @@ , makeMin -- * 'Ord1' , deriveOrd1-#if defined(NEW_FUNCTOR_CLASSES) , makeLiftCompare-#endif , makeCompare1-#if defined(NEW_FUNCTOR_CLASSES) -- * 'Ord2' , deriveOrd2 , makeLiftCompare2 , makeCompare2-#endif ) where import Data.Deriving.Internal@@ -111,7 +106,6 @@ deriveOrd1 :: Name -> Q [Dec] deriveOrd1 = deriveOrdClass Ord1 -#if defined(NEW_FUNCTOR_CLASSES) -- | Generates a lambda expression which behaves like 'liftCompare' (without -- requiring an 'Ord1' instance). --@@ -123,14 +117,7 @@ -- requiring an 'Ord1' instance). makeCompare1 :: Name -> Q Exp makeCompare1 name = makeLiftCompare name `appE` varE compareValName-#else--- | Generates a lambda expression which behaves like 'compare1' (without--- requiring an 'Ord1' instance).-makeCompare1 :: Name -> Q Exp-makeCompare1 = makeOrdFun Ord1Compare1 (error "This shouldn't happen")-#endif -#if defined(NEW_FUNCTOR_CLASSES) -- | Generates an 'Ord2' instance declaration for the given data type or data -- family instance. --@@ -153,7 +140,6 @@ makeCompare2 name = makeLiftCompare name `appE` varE compareValName `appE` varE compareValName-#endif ------------------------------------------------------------------------------- -- Code generation@@ -205,11 +191,7 @@ dispatchFun oFun | oFun `elem` [ OrdCompare, OrdLT -- OrdLT is included to mirror the fix to -- GHC Trac #10858.-#if defined(NEW_FUNCTOR_CLASSES) , Ord1LiftCompare, Ord2LiftCompare2-#else- , Ord1Compare1-#endif ] = makeOrdFunForCons oFun instTypes cons dispatchFun OrdLE = dispatchLT $ \lt x y -> negateExpr $ lt `appE` y `appE` x@@ -248,12 +230,8 @@ where compareFuns :: [OrdFun] compareFuns = [ OrdCompare-#if defined(NEW_FUNCTOR_CLASSES) , Ord1LiftCompare , Ord2LiftCompare2-#else- , Ord1Compare1-#endif ] -- | Generates a lambda expression for the given constructors.@@ -317,18 +295,11 @@ mkTagCmp = untagExpr [(v1, v1Hash), (v2, v2Hash)] $ unliftedOrdFun intHashTypeName oFun v1Hash v2Hash - lamE (map varP $-#if defined(NEW_FUNCTOR_CLASSES)- ords ++-#endif- [v1, v2])+ lamE (map varP $ ords ++ [v1, v2]) . appsE $ [ varE $ compareConstName oFun , ordFunRhs- ]-#if defined(NEW_FUNCTOR_CLASSES)- ++ map varE ords-#endif+ ] ++ map varE ords ++ [varE v1, varE v2] makeOrdFunForCon :: OrdFun@@ -438,17 +409,12 @@ -> Name -> Type -> Q Exp-#if defined(NEW_FUNCTOR_CLASSES) makeOrdFunForType oFun tvMap _ (VarT tyName) = varE $ case Map.lookup tyName tvMap of Just (OneName ord) -> ord Nothing -> ordFunName oFun 0-#else-makeOrdFunForType oFun _ _ VarT{} = varE $ ordFunName oFun 0-#endif makeOrdFunForType oFun tvMap conName (SigT ty _) = makeOrdFunForType oFun tvMap conName ty makeOrdFunForType oFun tvMap conName (ForallT _ _ ty) = makeOrdFunForType oFun tvMap conName ty-#if defined(NEW_FUNCTOR_CLASSES) makeOrdFunForType oFun tvMap conName ty = do let oClass :: OrdClass oClass = ordFunToClass oFun@@ -474,23 +440,7 @@ then appsE $ [ varE . ordFunName oFun $ toEnum numLastArgs] ++ map (makeOrdFunForType oFun tvMap conName) rhsArgs else varE $ ordFunName oFun 0-#else-makeOrdFunForType oFun tvMap conName ty = do- let varNames = Map.keys tvMap- oClass = ordFunToClass oFun - a' <- newName "a'"- b' <- newName "b'"- case varNames of- [] -> varE $ ordFunName oFun 0- varName:_ ->- if mentionsName ty varNames- then lamE (map varP [a',b']) $ varE (ordFunName oFun 1)- `appE` (makeFmapApplyNeg oClass conName ty varName `appE` varE a')- `appE` (makeFmapApplyNeg oClass conName ty varName `appE` varE b')- else varE $ ordFunName oFun 0-#endif- ------------------------------------------------------------------------------- -- Class-specific constants -------------------------------------------------------------------------------@@ -498,9 +448,7 @@ -- | A representation of which @Ord@ variant is being derived. data OrdClass = Ord | Ord1-#if defined(NEW_FUNCTOR_CLASSES) | Ord2-#endif deriving (Bounded, Enum) instance ClassRep OrdClass where@@ -510,9 +458,7 @@ fullClassName Ord = ordTypeName fullClassName Ord1 = ord1TypeName-#if defined(NEW_FUNCTOR_CLASSES) fullClassName Ord2 = ord2TypeName-#endif classConstraint oClass i | oMin <= i && i <= oMax = Just $ fullClassName (toEnum i :: OrdClass)@@ -528,28 +474,16 @@ compareConstName OrdLE = ltConstValName compareConstName OrdGT = ltConstValName compareConstName OrdGE = ltConstValName-#if defined(NEW_FUNCTOR_CLASSES) compareConstName Ord1LiftCompare = liftCompareConstValName compareConstName Ord2LiftCompare2 = liftCompare2ConstValName-#else-compareConstName Ord1Compare1 = compare1ConstValName-#endif ordClassToCompare :: OrdClass -> OrdFun ordClassToCompare Ord = OrdCompare-#if defined(NEW_FUNCTOR_CLASSES) ordClassToCompare Ord1 = Ord1LiftCompare ordClassToCompare Ord2 = Ord2LiftCompare2-#else-ordClassToCompare Ord1 = Ord1Compare1-#endif data OrdFun = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT-#if defined(NEW_FUNCTOR_CLASSES) | Ord1LiftCompare | Ord2LiftCompare2-#else- | Ord1Compare1-#endif deriving Eq ordFunName :: OrdFun -> Int -> Name@@ -558,16 +492,11 @@ ordFunName OrdLE 0 = leValName ordFunName OrdGE 0 = geValName ordFunName OrdGT 0 = gtValName-#if defined(NEW_FUNCTOR_CLASSES) ordFunName Ord1LiftCompare 0 = ordFunName OrdCompare 0 ordFunName Ord1LiftCompare 1 = liftCompareValName ordFunName Ord2LiftCompare2 0 = ordFunName OrdCompare 0 ordFunName Ord2LiftCompare2 1 = ordFunName Ord1LiftCompare 1 ordFunName Ord2LiftCompare2 2 = liftCompare2ValName-#else-ordFunName Ord1Compare1 0 = ordFunName OrdCompare 0-ordFunName Ord1Compare1 1 = compare1ValName-#endif ordFunName _ _ = error "Data.Ord.Deriving.Internal.ordFunName" ordFunToClass :: OrdFun -> OrdClass@@ -576,12 +505,8 @@ ordFunToClass OrdLE = Ord ordFunToClass OrdGE = Ord ordFunToClass OrdGT = Ord-#if defined(NEW_FUNCTOR_CLASSES) ordFunToClass Ord1LiftCompare = Ord1 ordFunToClass Ord2LiftCompare2 = Ord2-#else-ordFunToClass Ord1Compare1 = Ord1-#endif eqResult :: OrdFun -> Q Exp eqResult OrdCompare = eqTagExpr@@ -589,12 +514,8 @@ eqResult OrdLE = trueExpr eqResult OrdGE = trueExpr eqResult OrdGT = falseExpr-#if defined(NEW_FUNCTOR_CLASSES) eqResult Ord1LiftCompare = eqTagExpr eqResult Ord2LiftCompare2 = eqTagExpr-#else-eqResult Ord1Compare1 = eqTagExpr-#endif gtResult :: OrdFun -> Q Exp gtResult OrdCompare = gtTagExpr@@ -602,12 +523,8 @@ gtResult OrdLE = falseExpr gtResult OrdGE = trueExpr gtResult OrdGT = trueExpr-#if defined(NEW_FUNCTOR_CLASSES) gtResult Ord1LiftCompare = gtTagExpr gtResult Ord2LiftCompare2 = gtTagExpr-#else-gtResult Ord1Compare1 = gtTagExpr-#endif ltResult :: OrdFun -> Q Exp ltResult OrdCompare = ltTagExpr@@ -615,12 +532,8 @@ ltResult OrdLE = trueExpr ltResult OrdGE = falseExpr ltResult OrdGT = falseExpr-#if defined(NEW_FUNCTOR_CLASSES) ltResult Ord1LiftCompare = ltTagExpr ltResult Ord2LiftCompare2 = ltTagExpr-#else-ltResult Ord1Compare1 = ltTagExpr-#endif ------------------------------------------------------------------------------- -- Assorted utilities@@ -638,9 +551,7 @@ otherFuns _ [] = [] -- We only need compare for empty data types. otherFuns oClass cons = case oClass of Ord1 -> []-#if defined(NEW_FUNCTOR_CLASSES) Ord2 -> []-#endif Ord | (lastTag - firstTag) <= 2 || null nonNullaryCons -> [OrdLT, OrdLE, OrdGE, OrdGT] | otherwise@@ -660,12 +571,8 @@ OrdLE -> wrap leFun OrdGE -> wrap geFun OrdGT -> wrap gtFun-#if defined(NEW_FUNCTOR_CLASSES) Ord1LiftCompare -> unliftedCompareExpr Ord2LiftCompare2 -> unliftedCompareExpr-#else- Ord1Compare1 -> unliftedCompareExpr-#endif where unliftedCompareExpr :: Q Exp unliftedCompareExpr = unliftedCompare ltFun eqFun aExpr bExpr
src/Text/Read/Deriving.hs view
@@ -27,23 +27,20 @@ -- * 'Read1' , deriveRead1 , deriveRead1Options-#if defined(NEW_FUNCTOR_CLASSES) , makeLiftReadsPrec -- , makeLiftReadsPrecOptions -- , makeLiftReadList -- , makeLiftReadListOptions-# if __GLASGOW_HASKELL__ >= 801+#if __GLASGOW_HASKELL__ >= 801 , makeLiftReadPrec -- , makeLiftReadPrecOptions -- , makeLiftReadListPrec -- , makeLiftReadListPrecOptions , makeReadPrec1 -- , makeReadPrec1Options-# endif #endif , makeReadsPrec1 -- , makeReadsPrec1Options-#if defined(NEW_FUNCTOR_CLASSES) -- * 'Read2' , deriveRead2 , deriveRead2Options@@ -51,17 +48,16 @@ -- , makeLiftReadsPrec2Options -- , makeLiftReadList2 -- , makeLiftReadList2Options-# if __GLASGOW_HASKELL__ >= 801+#if __GLASGOW_HASKELL__ >= 801 , makeLiftReadPrec2 -- , makeLiftReadPrec2Options -- , makeLiftReadListPrec2 -- , makeLiftReadListPrec2Options , makeReadPrec2 -- , makeReadPrec2Options-# endif+#endif , makeReadsPrec2 -- , makeReadsPrec2Options-#endif -- * 'ReadOptions' , ReadOptions(..) , defaultReadOptions
src/Text/Read/Deriving/Internal.hs view
@@ -27,23 +27,20 @@ -- * 'Read1' , deriveRead1 , deriveRead1Options-#if defined(NEW_FUNCTOR_CLASSES) , makeLiftReadsPrec -- , makeLiftReadsPrecOptions -- , makeLiftReadList -- , makeLiftReadListOptions-# if __GLASGOW_HASKELL__ >= 801+#if __GLASGOW_HASKELL__ >= 801 , makeLiftReadPrec -- , makeLiftReadPrecOptions -- , makeLiftReadListPrec -- , makeLiftReadListPrecOptions , makeReadPrec1 -- , makeReadPrec1Options-# endif #endif , makeReadsPrec1 -- , makeReadsPrec1Options-#if defined(NEW_FUNCTOR_CLASSES) -- * 'Read2' , deriveRead2 , deriveRead2Options@@ -51,17 +48,16 @@ -- , makeLiftReadsPrec2Options -- , makeLiftReadList2 -- , makeLiftReadList2Options-# if __GLASGOW_HASKELL__ >= 801+#if __GLASGOW_HASKELL__ >= 801 , makeLiftReadPrec2 -- , makeLiftReadPrec2Options -- , makeLiftReadListPrec2 -- , makeLiftReadListPrec2Options , makeReadPrec2 -- , makeReadPrec2Options-# endif+#endif , makeReadsPrec2 -- , makeReadsPrec2Options-#endif -- * 'ReadOptions' , ReadOptions(..) , defaultReadOptions@@ -185,7 +181,6 @@ -- makeReadsPrec1 :: Name -> Q Exp -- makeReadsPrec1 = makeReadsPrec1Options defaultReadOptions -#if defined(NEW_FUNCTOR_CLASSES) -- | Generates a lambda expression which behaves like 'liftReadsPrec' (without -- requiring a 'Read1' instance). --@@ -212,7 +207,7 @@ -- makeLiftReadListOptions :: ReadOptions -> Name -> Q Exp -- makeLiftReadListOptions = undefined -# if __GLASGOW_HASKELL__ >= 801+#if __GLASGOW_HASKELL__ >= 801 -- | Generates a lambda expression which behaves like 'liftReadPrec' (without -- requiring a 'Read1' instance). --@@ -255,7 +250,7 @@ -- makeReadPrec1Options opts name = makeLiftReadPrecOptions opts name -- `appE` varE readPrecValName -- `appE` varE readListPrecValName-# endif+#endif -- | Generates a lambda expression which behaves like 'readsPrec1' (without -- requiring a 'Read1' instance). makeReadsPrec1 :: Name -> Q Exp@@ -268,18 +263,7 @@ -- makeReadsPrec1Options opts name = makeLiftReadsPrecOptions opts name -- `appE` varE readsPrecValName -- `appE` varE readListValName-#else--- | Generates a lambda expression which behaves like 'readsPrec1' (without--- requiring a 'Read1' instance).-makeReadsPrec1 :: Name -> Q Exp-makeReadsPrec1 = makeReadPrecClass Read1 False --- -- | Like 'makeReadsPrec1Options', but takes a 'ReadOptions' argument.--- makeReadsPrec1Options :: ReadOptions -> Name -> Q Exp--- makeReadsPrec1Options _ = makeReadPrecClass Read1 False-#endif--#if defined(NEW_FUNCTOR_CLASSES) -- | Generates a 'Read2' instance declaration for the given data type or data -- family instance. --@@ -341,7 +325,7 @@ -- `appE` (rs2pExpr `appE` (constExpr `appE` rl2Expr)))) -- `appE` integerE 0 -# if __GLASGOW_HASKELL__ >= 801+#if __GLASGOW_HASKELL__ >= 801 -- | Generates a lambda expression which behaves like 'liftReadPrec2' (without -- requiring a 'Read2' instance). --@@ -388,7 +372,7 @@ -- `appE` varE readListPrecValName -- `appE` varE readPrecValName -- `appE` varE readListPrecValName-# endif+#endif -- | Generates a lambda expression which behaves like 'readsPrec2' (without -- requiring a 'Read2' instance).@@ -410,7 +394,6 @@ -- `appE` varE readListValName -- `appE` varE readsPrecValName -- `appE` varE readListValName-#endif ------------------------------------------------------------------------------- -- Code generation@@ -483,7 +466,7 @@ rps <- newNameList "rp" $ arity rClass rls <- newNameList "rl" $ arity rClass let rpls = zip rps rls- _rpsAndRls = interleave rps rls+ rpsAndRls = interleave rps rls lastTyVars = map varTToName $ drop (length instTypes - fromEnum rClass) instTypes rplMap = Map.fromList $ zipWith (\x (y, z) -> (x, TwoNames y z)) lastTyVars rpls @@ -527,20 +510,13 @@ | null cons = varE pfailValName | otherwise = varE parensValName `appE` readConsExpr - lamE (map varP $-#if defined(NEW_FUNCTOR_CLASSES)- _rpsAndRls ++-#endif- if urp then [] else [p]+ lamE (map varP $ rpsAndRls ++ if urp then [] else [p] ) . appsE $ [ varE $ (if urp then readPrecConstName else readsPrecConstName) rClass , if urp then mainRhsExpr else varE readPrec_to_SValName `appE` mainRhsExpr `appE` varE p- ]-#if defined(NEW_FUNCTOR_CLASSES)- ++ map varE _rpsAndRls-#endif+ ] ++ map varE rpsAndRls ++ if urp then [] else [varE p] makeReadForCon :: ReadClass@@ -658,21 +634,15 @@ -> Bool -> Type -> Q (Exp, Exp)-#if defined(NEW_FUNCTOR_CLASSES) makeReadForType _ urp tvMap _ tyExpName rl (VarT tyName) = let tyExp = VarE tyExpName in return $ case Map.lookup tyName tvMap of Just (TwoNames rpExp rlExp) -> (VarE $ if rl then rlExp else rpExp, tyExp) Nothing -> (VarE $ readsOrReadName urp rl Read, tyExp)-#else-makeReadForType _ urp _ _ tyExpName _ VarT{} =- return (VarE $ readsOrReadName urp False Read, VarE tyExpName)-#endif makeReadForType rClass urp tvMap conName tyExpName rl (SigT ty _) = makeReadForType rClass urp tvMap conName tyExpName rl ty makeReadForType rClass urp tvMap conName tyExpName rl (ForallT _ _ ty) = makeReadForType rClass urp tvMap conName tyExpName rl ty-#if defined(NEW_FUNCTOR_CLASSES) makeReadForType rClass urp tvMap conName tyExpName rl ty = do let tyCon :: Type tyArgs :: [Type]@@ -700,23 +670,7 @@ (interleave rhsArgs rhsArgs) return (readExp, VarE tyExpName) else return (VarE $ readsOrReadName urp rl Read, VarE tyExpName)-#else-makeReadForType rClass urp tvMap conName tyExpName _ ty = do- let varNames = Map.keys tvMap- rpExpr = VarE $ readsOrReadName urp False Read- rp1Expr = VarE $ readsOrReadName urp False Read1- tyExpr = VarE tyExpName - case varNames of- [] -> return (rpExpr, tyExpr)- varName:_ -> do- if mentionsName ty varNames- then do- applyExp <- makeFmapApplyPos rClass conName ty varName- return (rp1Expr, applyExp `AppE` tyExpr)- else return (rpExpr, tyExpr)-#endif- ------------------------------------------------------------------------------- -- Class-specific constants -------------------------------------------------------------------------------@@ -724,9 +678,7 @@ -- | A representation of which @Read@ variant is being derived. data ReadClass = Read | Read1-#if defined(NEW_FUNCTOR_CLASSES) | Read2-#endif deriving (Bounded, Enum) instance ClassRep ReadClass where@@ -736,9 +688,7 @@ fullClassName Read = readTypeName fullClassName Read1 = read1TypeName-#if defined(NEW_FUNCTOR_CLASSES) fullClassName Read2 = read2TypeName-#endif classConstraint rClass i | rMin <= i && i <= rMax = Just $ fullClassName (toEnum i :: ReadClass)@@ -750,58 +700,38 @@ readsPrecConstName :: ReadClass -> Name readsPrecConstName Read = readsPrecConstValName-#if defined(NEW_FUNCTOR_CLASSES) readsPrecConstName Read1 = liftReadsPrecConstValName readsPrecConstName Read2 = liftReadsPrec2ConstValName-#else-readsPrecConstName Read1 = readsPrec1ConstValName-#endif readPrecConstName :: ReadClass -> Name readPrecConstName Read = readPrecConstValName readPrecConstName Read1 = liftReadPrecConstValName-#if defined(NEW_FUNCTOR_CLASSES) readPrecConstName Read2 = liftReadPrec2ConstValName-#endif readsPrecName :: ReadClass -> Name readsPrecName Read = readsPrecValName-#if defined(NEW_FUNCTOR_CLASSES) readsPrecName Read1 = liftReadsPrecValName readsPrecName Read2 = liftReadsPrec2ValName-#else-readsPrecName Read1 = readsPrec1ValName-#endif readPrecName :: ReadClass -> Name readPrecName Read = readPrecValName readPrecName Read1 = liftReadPrecValName-#if defined(NEW_FUNCTOR_CLASSES) readPrecName Read2 = liftReadPrec2ValName-#endif readListPrecDefaultName :: ReadClass -> Name readListPrecDefaultName Read = readListPrecDefaultValName readListPrecDefaultName Read1 = liftReadListPrecDefaultValName-#if defined(NEW_FUNCTOR_CLASSES) readListPrecDefaultName Read2 = liftReadListPrec2DefaultValName-#endif readListPrecName :: ReadClass -> Name readListPrecName Read = readListPrecValName readListPrecName Read1 = liftReadListPrecValName-#if defined(NEW_FUNCTOR_CLASSES) readListPrecName Read2 = liftReadListPrec2ValName-#endif readListName :: ReadClass -> Name readListName Read = readListValName-#if defined(NEW_FUNCTOR_CLASSES) readListName Read1 = liftReadListValName readListName Read2 = liftReadList2ValName-#else-readListName Read1 = error "Text.Read.Deriving.Internal.readListName"-#endif readsPrecOrListName :: Bool -- ^ readsListName if True, readsPrecName if False -> ReadClass@@ -891,6 +821,4 @@ baseCompatible = case rClass of Read -> True Read1 -> base4'10OrLater-#if defined(NEW_FUNCTOR_CLASSES) Read2 -> base4'10OrLater-#endif
src/Text/Show/Deriving.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-| Module: Text.Show.Deriving Copyright: (C) 2015-2017 Ryan Scott@@ -25,15 +24,12 @@ -- * 'Show1' , deriveShow1 , deriveShow1Options-#if defined(NEW_FUNCTOR_CLASSES) , makeLiftShowsPrec , makeLiftShowsPrecOptions , makeLiftShowList , makeLiftShowListOptions-#endif , makeShowsPrec1 , makeShowsPrec1Options-#if defined(NEW_FUNCTOR_CLASSES) -- * 'Show2' , deriveShow2 , deriveShow2Options@@ -43,7 +39,6 @@ , makeLiftShowList2Options , makeShowsPrec2 , makeShowsPrec2Options-#endif -- * 'ShowOptions' , ShowOptions(..) , defaultShowOptions
src/Text/Show/Deriving/Internal.hs view
@@ -26,15 +26,12 @@ -- * 'Show1' , deriveShow1 , deriveShow1Options-#if defined(NEW_FUNCTOR_CLASSES) , makeLiftShowsPrec , makeLiftShowsPrecOptions , makeLiftShowList , makeLiftShowListOptions-#endif , makeShowsPrec1 , makeShowsPrec1Options-#if defined(NEW_FUNCTOR_CLASSES) -- * 'Show2' , deriveShow2 , deriveShow2Options@@ -44,7 +41,6 @@ , makeLiftShowList2Options , makeShowsPrec2 , makeShowsPrec2Options-#endif -- * 'ShowOptions' , ShowOptions(..) , defaultShowOptions@@ -88,12 +84,7 @@ -- | 'ShowOptions' that match the behavior of the installed version of GHC. legacyShowOptions :: ShowOptions legacyShowOptions = ShowOptions- { ghc8ShowBehavior =-#if __GLASGOW_HASKELL__ >= 711- True-#else- False-#endif+ { ghc8ShowBehavior = True , showEmptyCaseBehavior = False } @@ -153,7 +144,6 @@ makeShowsPrec1 :: Name -> Q Exp makeShowsPrec1 = makeShowsPrec1Options defaultShowOptions -#if defined(NEW_FUNCTOR_CLASSES) -- | Generates a lambda expression which behaves like 'liftShowsPrec' (without -- requiring a 'Show1' instance). --@@ -190,13 +180,7 @@ makeShowsPrec1Options opts name = makeLiftShowsPrecOptions opts name `appE` varE showsPrecValName `appE` varE showListValName-#else--- | Like 'makeShowsPrec1', but takes a 'ShowOptions' argument.-makeShowsPrec1Options :: ShowOptions -> Name -> Q Exp-makeShowsPrec1Options = makeShowsPrecClass Show1-#endif -#if defined(NEW_FUNCTOR_CLASSES) -- | Generates a 'Show2' instance declaration for the given data type or data -- family instance. --@@ -261,7 +245,6 @@ `appE` varE showListValName `appE` varE showsPrecValName `appE` varE showListValName-#endif ------------------------------------------------------------------------------- -- Code generation@@ -324,12 +307,12 @@ sps <- newNameList "sp" $ arity sClass sls <- newNameList "sl" $ arity sClass let spls = zip sps sls- _spsAndSls = interleave sps sls+ spsAndSls = interleave sps sls lastTyVars = map varTToName $ drop (length instTypes - fromEnum sClass) instTypes splMap = Map.fromList $ zipWith (\x (y, z) -> (x, TwoNames y z)) lastTyVars spls makeFun- | null cons && showEmptyCaseBehavior opts && ghc7'8OrLater+ | null cons && showEmptyCaseBehavior opts = caseE (varE value) [] | null cons@@ -341,18 +324,11 @@ = caseE (varE value) (map (makeShowForCon p sClass opts splMap) cons) - lamE (map varP $-#if defined(NEW_FUNCTOR_CLASSES)- _spsAndSls ++-#endif- [p, value])+ lamE (map varP $ spsAndSls ++ [p, value]) . appsE $ [ varE $ showsPrecConstName sClass , makeFun- ]-#if defined(NEW_FUNCTOR_CLASSES)- ++ map varE _spsAndSls-#endif+ ] ++ map varE spsAndSls ++ [varE p, varE value] -- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for a@@ -530,17 +506,12 @@ -- False if we are using the function of type (Int -> a -> ShowS). -> Type -> Q Exp-#if defined(NEW_FUNCTOR_CLASSES) makeShowForType _ _ tvMap sl (VarT tyName) = varE $ case Map.lookup tyName tvMap of Just (TwoNames spExp slExp) -> if sl then slExp else spExp Nothing -> if sl then showListValName else showsPrecValName-#else-makeShowForType _ _ _ _ VarT{} = varE showsPrecValName-#endif makeShowForType sClass conName tvMap sl (SigT ty _) = makeShowForType sClass conName tvMap sl ty makeShowForType sClass conName tvMap sl (ForallT _ _ ty) = makeShowForType sClass conName tvMap sl ty-#if defined(NEW_FUNCTOR_CLASSES) makeShowForType sClass conName tvMap sl ty = do let tyCon :: Type tyArgs :: [Type]@@ -565,22 +536,7 @@ (cycle [False,True]) (interleave rhsArgs rhsArgs) else varE $ if sl then showListValName else showsPrecValName-#else-makeShowForType sClass conName tvMap _ ty = do- let varNames = Map.keys tvMap - p' <- newName "p'"- value' <- newName "value'"- case varNames of- [] -> varE showsPrecValName- varName:_ ->- if mentionsName ty varNames- then lamE [varP p', varP value'] $ varE showsPrec1ValName- `appE` varE p'- `appE` (makeFmapApplyNeg sClass conName ty varName `appE` varE value')- else varE showsPrecValName-#endif- ------------------------------------------------------------------------------- -- Class-specific constants -------------------------------------------------------------------------------@@ -588,9 +544,7 @@ -- | A representation of which @Show@ variant is being derived. data ShowClass = Show | Show1-#if defined(NEW_FUNCTOR_CLASSES) | Show2-#endif deriving (Bounded, Enum) instance ClassRep ShowClass where@@ -600,9 +554,7 @@ fullClassName Show = showTypeName fullClassName Show1 = show1TypeName-#if defined(NEW_FUNCTOR_CLASSES) fullClassName Show2 = show2TypeName-#endif classConstraint sClass i | sMin <= i && i <= sMax = Just $ fullClassName (toEnum i :: ShowClass)@@ -614,23 +566,14 @@ showsPrecConstName :: ShowClass -> Name showsPrecConstName Show = showsPrecConstValName-#if defined(NEW_FUNCTOR_CLASSES) showsPrecConstName Show1 = liftShowsPrecConstValName showsPrecConstName Show2 = liftShowsPrec2ConstValName-#else-showsPrecConstName Show1 = showsPrec1ConstValName-#endif showsPrecName :: ShowClass -> Name showsPrecName Show = showsPrecValName-#if defined(NEW_FUNCTOR_CLASSES) showsPrecName Show1 = liftShowsPrecValName showsPrecName Show2 = liftShowsPrec2ValName-#else-showsPrecName Show1 = showsPrec1ValName-#endif -#if defined(NEW_FUNCTOR_CLASSES) showListName :: ShowClass -> Name showListName Show = showListValName showListName Show1 = liftShowListValName@@ -641,7 +584,6 @@ -> Name showsPrecOrListName False = showsPrecName showsPrecOrListName True = showListName-#endif ------------------------------------------------------------------------------- -- Assorted utilities
tests/BoundedEnumIxSpec.hs view
@@ -2,15 +2,12 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -#if __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE PolyKinds #-}-#endif--#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806+#if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif @@ -26,15 +23,12 @@ module BoundedEnumIxSpec where import Data.Deriving-#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806+#if __GLASGOW_HASKELL__ < 806 import Data.Kind #endif import GHC.Arr (Ix(..)) -import Prelude ()-import Prelude.Compat- import Test.Hspec -------------------------------------------------------------------------------@@ -47,13 +41,7 @@ data TyConProduct a b c = TyConProduct a b c deriving (Eq, Ord, Show) -data TyConUnit-#if __GLASGOW_HASKELL__ >= 706- (f :: k -> *) (a :: k)-#else- (f :: * -> *) (a :: *)-#endif- = TyConUnit+data TyConUnit (f :: k -> *) (a :: k) = TyConUnit deriving (Eq, Ord, Show) data TyConExQuant a = Show a => TyConExQuant@@ -77,13 +65,7 @@ data instance TyFamilyProduct a b c = TyFamilyProduct a b c deriving (Eq, Ord, Show) -data family TyFamilyUnit-#if __GLASGOW_HASKELL__ >= 706- (f :: k -> *) (a :: k)-#else- (f :: * -> *) (a :: *)-#endif- :: *+data family TyFamilyUnit (f :: k -> *) (a :: k) :: * data instance TyFamilyUnit f a = TyFamilyUnit deriving (Eq, Ord, Show) @@ -136,7 +118,6 @@ unsafeIndex = $(makeUnsafeIndex ''TyConGADT) inRange = $(makeInRange ''TyConGADT) -#if MIN_VERSION_template_haskell(2,7,0) -- Data families $(deriveBounded 'TyFamilyEnum1)@@ -170,7 +151,6 @@ range = $(makeRange 'TyFamilyGADT) unsafeIndex = $(makeUnsafeIndex 'TyFamilyGADT) inRange = $(makeInRange 'TyFamilyGADT)-#endif ------------------------------------------------------------------------------- @@ -230,7 +210,6 @@ it "has a sensible Ix instance" $ ixLaws minBound maxBound (TyConGADT False)-#if MIN_VERSION_template_haskell(2,7,0) describe "TyFamilyEnum" $ do it "has a sensible Bounded instance" $ do minBound `shouldBe` TyFamilyEnum1@@ -272,4 +251,3 @@ it "has a sensible Ix instance" $ ixLaws minBound maxBound (TyFamilyGADT False)-#endif
tests/DerivingViaSpec.hs view
@@ -24,9 +24,6 @@ -} module DerivingViaSpec where -import Prelude ()-import Prelude.Compat- import Test.Hspec #if MIN_VERSION_template_haskell(2,12,0)
tests/EqSpec.hs view
@@ -9,9 +9,6 @@ -} module EqSpec where -import Prelude ()-import Prelude.Compat- import Test.Hspec import Types.EqOrd ()
tests/FunctorSpec.hs view
@@ -1,25 +1,20 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyCase #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE RoleAnnotations #-}-#endif -{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# OPTIONS_GHC -fno-warn-unused-matches #-}-#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_GHC -Wno-unused-matches #-} {-# OPTIONS_GHC -Wno-unused-foralls #-}-#endif {-| Module: FunctorSpec@@ -43,9 +38,6 @@ import GHC.Exts (Int#) -import Prelude ()-import Prelude.Compat- import Test.Hspec import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Arbitrary)@@ -109,9 +101,7 @@ data Empty1 a data Empty2 a-#if __GLASGOW_HASKELL__ >= 708 type role Empty2 nominal-#endif data TyCon29 a = TyCon29a (forall b. b -> (forall c. a -> c) -> a)@@ -219,9 +209,7 @@ foldMap = $(makeFoldMap ''ComplexConstraint) fold = $(makeFold ''ComplexConstraint) foldl = $(makeFoldl ''ComplexConstraint)-#if MIN_VERSION_base(4,8,0) null = $(makeNull ''ComplexConstraint)-#endif instance Traversable (f Int Int) => Traversable (ComplexConstraint f g a) where traverse = $(makeTraverse ''ComplexConstraint) sequenceA = $(makeSequenceA ''ComplexConstraint)@@ -255,7 +243,6 @@ $(deriveFoldable ''TyCon30) $(deriveTraversable ''TyCon30) -#if MIN_VERSION_template_haskell(2,7,0) -- Data families $(deriveFunctor 'T1Fam)@@ -281,9 +268,7 @@ foldMap = $(makeFoldMap 'ComplexConstraintFam) fold = $(makeFold 'ComplexConstraintFam) foldl = $(makeFoldl 'ComplexConstraintFam)-# if MIN_VERSION_base(4,8,0) null = $(makeNull 'ComplexConstraintFam)-# endif instance Traversable (f Int Int) => Traversable (ComplexConstraintFam f g a) where traverse = $(makeTraverse 'ComplexConstraintFam) sequenceA = $(makeSequenceA 'ComplexConstraintFam)@@ -307,7 +292,6 @@ $(deriveFunctor 'TyFamily30) $(deriveFoldable 'TyFamily30) $(deriveTraversable 'TyFamily30)-#endif ------------------------------------------------------------------------------- @@ -379,7 +363,6 @@ (prop_FoldableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Expectation) prop "satisfies the Traversable laws" (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] -> Expectation)@@ -387,4 +370,3 @@ (prop_FoldableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Expectation) prop "satisfies the Traversable laws" (prop_TraversableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Expectation)-#endif
tests/GH24Spec.hs view
@@ -1,12 +1,9 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -#if __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE PolyKinds #-}-#endif--#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806+#if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif @@ -22,22 +19,15 @@ -} module GH24Spec (main, spec) where -#if __GLASGOW_HASKELL__ >= 800 import Data.Deriving-#endif -import Prelude ()-import Prelude.Compat- import Test.Hspec -#if __GLASGOW_HASKELL__ >= 800 data family P (a :: j) (b :: k) data instance P (a :: k) k = MkP deriving (Eq, Ord) $(deriveEnum 'MkP) $(deriveIx 'MkP)-#endif main :: IO () main = hspec spec
tests/GH27Spec.hs view
@@ -20,9 +20,6 @@ -} module GH27Spec where -import Prelude ()-import Prelude.Compat- import Test.Hspec #if MIN_VERSION_template_haskell(2,12,0)
tests/GH31Spec.hs view
@@ -19,9 +19,6 @@ import OrdSpec (ordSpec) -import Prelude ()-import Prelude.Compat- import Test.Hspec (Spec, describe, hspec, it, parallel, shouldBe) import Test.QuickCheck (Arbitrary(..), oneof)
tests/GH6Spec.hs view
@@ -17,9 +17,6 @@ import OrdSpec (ordSpec) -import Prelude ()-import Prelude.Compat- import Test.Hspec (Spec, describe, hspec, parallel) import Test.QuickCheck (Arbitrary(..), oneof)
tests/OrdSpec.hs view
@@ -13,9 +13,6 @@ import Data.Functor.Classes -import Prelude ()-import Prelude.Compat- import Test.Hspec import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Arbitrary)
tests/ReadSpec.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -20,9 +19,6 @@ import Data.Functor.Classes (Read1, readsPrec1) import Data.Proxy -import Prelude ()-import Prelude.Compat- import Test.Hspec import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Arbitrary(..))@@ -57,31 +53,23 @@ $(deriveRead ''TyCon#) $(deriveRead1 ''TyCon#)-#if defined(NEW_FUNCTOR_CLASSES) $(deriveRead2 ''TyCon#)-#endif instance (Arbitrary a, Arbitrary b) => Arbitrary (TyCon# a b) where arbitrary = TyCon# <$> arbitrary <*> arbitrary $(deriveRead ''Empty) $(deriveRead1 ''Empty)-#if defined(NEW_FUNCTOR_CLASSES) $(deriveRead2 ''Empty)-#endif -#if MIN_VERSION_template_haskell(2,7,0) -- Data families $(deriveRead 'TyFamily#) $(deriveRead1 'TyFamily#)-# if defined(NEW_FUNCTOR_CLASSES) $(deriveRead2 'TyFamily#)-# endif instance (Arbitrary a, Arbitrary b) => Arbitrary (TyFamily# a b) where arbitrary = TyFamily# <$> arbitrary <*> arbitrary-#endif ------------------------------------------------------------------------------- @@ -118,7 +106,5 @@ spec = parallel $ do describe "TyCon#" $ readSpec (Proxy :: Proxy (TyCon# Char Int))-#if MIN_VERSION_template_haskell(2,7,0) describe "TyFamily#" $ readSpec (Proxy :: Proxy (TyFamily# Char Int))-#endif
tests/ShowSpec.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-}@@ -6,9 +7,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE EmptyCase #-}-#endif {-| Module: ShowSpec@@ -32,9 +30,6 @@ #endif ) -import Prelude ()-import Prelude.Compat- import Test.Hspec import Types.ReadShow ()@@ -140,20 +135,15 @@ $(deriveShow1 ''TyCon2) $(deriveShow1 ''Empty1) -#if defined(NEW_FUNCTOR_CLASSES) $(deriveShow2 ''TyCon#) $(deriveShow2 ''TyCon2) $(deriveShow2 ''Empty1)-#endif -- Use EmptyCase here $(deriveShowOptions defaultShowOptions{ showEmptyCaseBehavior = True } ''Empty2) $(deriveShow1Options defaultShowOptions{ showEmptyCaseBehavior = True } ''Empty2)-#if defined(NEW_FUNCTOR_CLASSES) $(deriveShow2Options defaultShowOptions{ showEmptyCaseBehavior = True } ''Empty2)-#endif -#if MIN_VERSION_template_haskell(2,7,0) -- Data families $(deriveShow 'TyFamily#)@@ -162,11 +152,8 @@ $(deriveShow1 'TyFamily#) $(deriveShow1 'TyFamilyEqualityConstraints) -# if defined(NEW_FUNCTOR_CLASSES) $(deriveShow2 'TyFamily#) $(deriveShow2 'TyFamilyTypeRefinement1)-# endif-#endif -------------------------------------------------------------------------------
tests/Types/EqOrd.hs view
@@ -18,9 +18,6 @@ -} module Types.EqOrd where -#if !defined(NEW_FUNCTOR_CLASSES)-import Data.Functor.Classes (Eq1(..), Ord1(..))-#endif import Data.Deriving import GHC.Exts ( Addr#, Char#, Double#, Float#, Int#, Word#@@ -180,6 +177,7 @@ $(deriveEq1 ''TyCon1) $(deriveEq1 ''TyCon#) $(deriveEq1 ''TyCon2)+$(deriveEq1 ''TyConWrap) $(deriveEq1 ''Empty) $(deriveEq1 ''TyConNullary) @@ -201,24 +199,10 @@ $(deriveOrd1 ''TyCon1) $(deriveOrd1 ''TyCon#) $(deriveOrd1 ''TyCon2)+$(deriveOrd1 ''TyConWrap) $(deriveOrd1 ''Empty) $(deriveOrd1 ''TyConNullary) -#if defined(NEW_FUNCTOR_CLASSES)-$(deriveEq1 ''TyConWrap)--$(deriveOrd1 ''TyConWrap)-#else-instance (Eq1 f, Functor f, Eq1 g, Functor g, Eq1 h)- => Eq1 (TyConWrap f g h) where- eq1 = $(makeEq1 ''TyConWrap)--instance (Ord1 f, Functor f, Ord1 g, Functor g, Ord1 h)- => Ord1 (TyConWrap f g h) where- compare1 = $(makeCompare1 ''TyConWrap)-#endif--#if defined(NEW_FUNCTOR_CLASSES) $(deriveEq2 ''TyCon1) $(deriveEq2 ''TyCon#) $(deriveEq2 ''TyCon2)@@ -230,9 +214,7 @@ $(deriveOrd2 ''TyCon2) $(deriveOrd2 ''Empty) $(deriveOrd2 ''TyConNullary)-#endif -#if MIN_VERSION_template_haskell(2,7,0) -- Data families $(deriveEq 'TyFamily1A)@@ -252,6 +234,7 @@ $(deriveOrd 'TyFamily1A) $(deriveOrd 'TyFamily#) $(deriveOrd 'TyFamilyClassConstraints)+$(deriveEq1 'TyFamilyWrap2) instance (Ord (f a), Ord (f (g a)), Ord (f (g (h a)))) => Ord (TyFamilyWrap f g h a) where compare = $(makeCompare 'TyFamilyWrap1)@@ -266,23 +249,9 @@ $(deriveOrd1 'TyFamily1B) $(deriveOrd1 'TyFamily#) $(deriveOrd1 'TyFamilyEqualityConstraints)-$(deriveOrd1 'TyFamilyNullary1)--#if defined(NEW_FUNCTOR_CLASSES)-$(deriveEq1 'TyFamilyWrap2)- $(deriveOrd1 'TyFamilyWrap2)-#else-instance (Eq1 f, Functor f, Eq1 g, Functor g, Eq1 h)- => Eq1 (TyFamilyWrap f g h) where- eq1 = $(makeEq1 'TyFamilyWrap3)--instance (Ord1 f, Functor f, Ord1 g, Functor g, Ord1 h)- => Ord1 (TyFamilyWrap f g h) where- compare1 = $(makeCompare1 'TyFamilyWrap3)-#endif+$(deriveOrd1 'TyFamilyNullary1) -# if defined(NEW_FUNCTOR_CLASSES) $(deriveEq2 'TyFamily1C) $(deriveEq2 'TyFamily#) $(deriveEq2 'TyFamilyTypeRefinement1)@@ -292,5 +261,3 @@ $(deriveOrd2 'TyFamily#) $(deriveOrd2 'TyFamilyTypeRefinement1) $(deriveOrd2 'TyFamilyNullary1)-# endif-#endif
tests/Types/ReadShow.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-}@@ -17,9 +16,6 @@ -} module Types.ReadShow where -#if !defined(NEW_FUNCTOR_CLASSES)-import Data.Functor.Classes (Read1(..), Show1(..))-#endif import Data.Deriving import Text.Read (Read(..), readListPrecDefault)@@ -112,6 +108,7 @@ $(deriveRead1 ''TyCon1) $(deriveRead1 ''TyConPlain) $(deriveRead1 ''TyConGADT)+$(deriveRead1 ''TyConWrap) $(deriveRead1 ''TC#) $(deriveShow ''TyCon1)@@ -127,23 +124,9 @@ $(deriveShow1 ''TyCon1) $(deriveShow1 ''TyConPlain) $(deriveShow1 ''TyConGADT)-$(deriveShow1 ''TC#)--#if defined(NEW_FUNCTOR_CLASSES)-$(deriveRead1 ''TyConWrap)- $(deriveShow1 ''TyConWrap)-#else-instance (Read1 f, Functor f, Read1 g, Functor g, Read1 h)- => Read1 (TyConWrap f g h) where- readsPrec1 = $(makeReadsPrec1 ''TyConWrap)--instance (Show1 f, Functor f, Show1 g, Functor g, Show1 h)- => Show1 (TyConWrap f g h) where- showsPrec1 = $(makeShowsPrec1 ''TyConWrap)-#endif+$(deriveShow1 ''TC#) -#if defined(NEW_FUNCTOR_CLASSES) $(deriveRead2 ''TyCon1) $(deriveRead2 ''TyConPlain) $(deriveRead2 ''TyConGADT)@@ -153,9 +136,7 @@ $(deriveShow2 ''TyConPlain) $(deriveShow2 ''TyConGADT) $(deriveShow2 ''TC#)-#endif -#if MIN_VERSION_template_haskell(2,7,0) -- Data families $(deriveRead 'TyFamilyPrefix)@@ -169,6 +150,7 @@ $(deriveRead1 '(:!:)) $(deriveRead1 '(:$:)) $(deriveRead1 '(:**))+$(deriveRead1 'TyFamilyWrap2) $(deriveRead1 'MkTF2#) $(deriveShow 'TyFamilyPrefix)@@ -184,23 +166,9 @@ $(deriveShow1 '(:!:)) $(deriveShow1 '(:$:)) $(deriveShow1 '(:**))-$(deriveShow1 'MkTF1#)--# if defined(NEW_FUNCTOR_CLASSES)-$(deriveRead1 'TyFamilyWrap2)- $(deriveShow1 'TyFamilyWrap2)-# else-instance (Read1 f, Functor f, Read1 g, Functor g, Read1 h)- => Read1 (TyFamilyWrap f g h) where- readsPrec1 = $(makeReadsPrec1 'TyFamilyWrap3)--instance (Show1 f, Functor f, Show1 g, Functor g, Show1 h)- => Show1 (TyFamilyWrap f g h) where- showsPrec1 = $(makeShowsPrec1 'TyFamilyWrap3)-# endif+$(deriveShow1 'MkTF1#) -# if defined(NEW_FUNCTOR_CLASSES) $(deriveRead2 'TyFamilyPrefix) $(deriveRead2 'TyFamilyPlain) $(deriveRead2 '(:***))@@ -210,5 +178,3 @@ $(deriveShow2 'TyFamilyPlain) $(deriveShow2 '(:***)) $(deriveShow2 'MkTF3#)-# endif-#endif