deriving-compat 0.3.2 → 0.3.3
raw patch · 14 files changed
+1242/−51 lines, 14 filesdep ~deriving-compatPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: deriving-compat
API changes (from Hackage documentation)
+ Data.Bounded.Deriving: deriveBounded :: Name -> Q [Dec]
+ Data.Bounded.Deriving: makeMaxBound :: Name -> Q Exp
+ Data.Bounded.Deriving: makeMinBound :: Name -> Q Exp
+ Data.Enum.Deriving: deriveEnum :: Name -> Q [Dec]
+ Data.Enum.Deriving: makeEnumFrom :: Name -> Q Exp
+ Data.Enum.Deriving: makeEnumFromThen :: Name -> Q Exp
+ Data.Enum.Deriving: makeFromEnum :: Name -> Q Exp
+ Data.Enum.Deriving: makePred :: Name -> Q Exp
+ Data.Enum.Deriving: makeSucc :: Name -> Q Exp
+ Data.Enum.Deriving: makeToEnum :: Name -> Q Exp
+ Data.Ix.Deriving: deriveIx :: Name -> Q [Dec]
+ Data.Ix.Deriving: makeInRange :: Name -> Q Exp
+ Data.Ix.Deriving: makeRange :: Name -> Q Exp
+ Data.Ix.Deriving: makeUnsafeIndex :: Name -> Q Exp
Files
- CHANGELOG.md +6/−0
- README.md +12/−8
- deriving-compat.cabal +39/−28
- src/Data/Bounded/Deriving.hs +27/−0
- src/Data/Bounded/Deriving/Internal.hs +126/−0
- src/Data/Deriving.hs +39/−1
- src/Data/Deriving/Internal.hs +198/−9
- src/Data/Enum/Deriving.hs +31/−0
- src/Data/Enum/Deriving/Internal.hs +238/−0
- src/Data/Ix/Deriving.hs +28/−0
- src/Data/Ix/Deriving/Internal.hs +225/−0
- src/Text/Show/Deriving/Internal.hs +4/−4
- tests/BoundedEnumIxSpec.hs +268/−0
- tests/FunctorSpec.hs +1/−1
CHANGELOG.md view
@@ -1,3 +1,9 @@+### 0.3.3 [2016.09.11]+* Add `Data.Bounded.Deriving`, which allows deriving `Bounded` with TH.+* Add `Data.Enum.Deriving`, which allows deriving `Enum` with TH.+* Add `Data.Ix.Deriving`, which allows deriving `Ix` with TH.+* Fix bug in which derived `Show` instance would parenthesize the output too eagerly+ ### 0.3.2 * Incorporate a fix to GHC Trac #10858, which will be introduced in GHC 8.2 * Fix bug in which derived `Ord` instances accidentally swapped their less-than(-or-equal-to) and greater-than(-or-equal-to) methods
README.md view
@@ -15,20 +15,24 @@ https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 "BSD 3-Clause License (Revised)" -Provides Template Haskell functions that mimic deriving extensions that were introduced or modified in recent versions of GHC. Currently, the following extensions are covered:+Provides Template Haskell functions that mimic deriving extensions that were introduced or modified in recent versions of GHC. Currently, the following typeclasses/extensions are covered: +* Deriving `Bounded`+* Deriving `Enum`+* Deriving `Ix`+* Deriving `Eq`, `Eq1`, and `Eq2`+* Deriving `Ord`, `Ord1`, and `Ord2`+* Deriving `Read`, `Read1`, and `Read2`+* Deriving `Show`, `Show1`, and `Show2` * `DeriveFoldable` * `DeriveFunctor` * `DeriveTraversable` -The following changes have been backported:--* In GHC 8.0, `DeriveFoldable` was changed to allow folding over data types with existential constraints.-* In GHC 8.0, `DeriveFoldable` and `DeriveTraversable` were changed so as not to generate superfluous `mempty` or `pure` expressions in generated code. As a result, this allows deriving `Traversable` instances for datatypes with unlifted argument types.-* In GHC 8.0, deriving `Show` was changed so that constructor fields with unlifted types are no longer shown with parentheses, and the output of showing an unlifted type is suffixed with the same number of hash signs as the corresponding primitive literals.-* In GHC 8.2, deriving `Ord` was changed so that it generates concrete `if`-expressions that are not subject to `RebindableSyntax`. It was also changed so that derived `(<=)`, `(>)`, and `(>=)` methods are expressed through `(<)`, which avoids generating a substantial amount of code.+See the `Data.Deriving` module for a full list of backported changes. -Note that some recent GHC extensions are not covered by this package:+Note that some recent GHC typeclasses/extensions are not covered by this package: +* `DeriveDataTypeable` * `DeriveGeneric`, which was introducted in GHC 7.2 for deriving `Generic` instances, and modified in GHC 7.6 to allow derivation of `Generic1` instances. Use `Generics.Deriving.TH` from [`generic-deriving`](http://hackage.haskell.org/package/generic-deriving) to derive `Generic(1)` using Template Haskell. * `DeriveLift`, which was introduced in GHC 8.0 for deriving `Lift` instances. Use `Language.Haskell.TH.Lift` from [`th-lift`](http://hackage.haskell.org/package/th-lift) to derive `Lift` using Template Haskell.+* The `Bifunctor` typeclass, which was introduced in GHC 7.10, as well as the `Bifoldable` and `Bitraversable` typeclasses, which were introduced in GHC 8.2. Use `Data.Bifunctor.TH` from [`bifunctors`](http://hackage.haskell.org/package/bifunctors) to derive these typeclasses using Template Haskell.
deriving-compat.cabal view
@@ -1,40 +1,36 @@ name: deriving-compat-version: 0.3.2+version: 0.3.3 synopsis: Backports of GHC deriving extensions description: Provides Template Haskell functions that mimic deriving extensions that were introduced or modified in recent versions- of GHC. Currently, the following extensions are covered:+ of GHC. Currently, the following typeclasses/extensions are covered: .- * @DeriveFoldable@+ * Deriving @Bounded@ .- * @DeriveFunctor@+ * Deriving @Enum@ .- * @DeriveTraversable@+ * Deriving @Ix@ .- The following changes have been backported:+ * Deriving @Eq@, @Eq1@, and @Eq2@ .- * In GHC 8.0, @DeriveFoldable@ was changed to allow folding- over data types with existential constraints.+ * Deriving @Ord@, @Ord1@, and @Ord2@ .- * In GHC 8.0, @DeriveFoldable@ and @DeriveTraversable@ were- changed so as not to generate superfluous @mempty@ or @pure@- expressions in generated code. As a result, this allows- deriving @Traversable@ instances for datatypes with unlifted- argument types.+ * Deriving @Read@, @Read1@, and @Read2@ .- * In GHC 8.0, deriving @Show@ was changed so that constructor fields- with unlifted types are no longer shown with parentheses, and- the output of showing an unlifted type is suffixed with the same- number of hash signs as the corresponding primitive literals.+ * Deriving @Show@, @Show1@, and @Show2@ .- * In GHC 8.2, deriving `Ord` was changed so that it generates concrete- @if@-expressions that are not subject to @RebindableSyntax@. It was- also changed so that derived @(<=)@, @(>)@, and @(>=)@ methods are- expressed through @(<)@, which avoids generating a substantial- amount of code.+ * @DeriveFoldable@ .- Note that some recent GHC extensions are not covered by this package:+ * @DeriveFunctor@ .+ * @DeriveTraversable@+ .+ See the "Data.Deriving" module for a full list of backported changes.+ .+ Note that some recent GHC typeclasses/extensions are not covered by this package:+ .+ * @DeriveDataTypeable@+ . * @DeriveGeneric@, which was introducted in GHC 7.2 for deriving @Generic@ instances, and modified in GHC 7.6 to allow derivation of @Generic1@ instances. Use @Generics.Deriving.TH@ from@@ -45,6 +41,12 @@ @Lift@ instances. Use @Language.Haskell.TH.Lift@ from @<http://hackage.haskell.org/package/th-lift th-lift>@ to derive @Lift@ using Template Haskell.+ .+ * The @Bifunctor@ typeclass, which was introduced in GHC 7.10,+ as well as the @Bifoldable@ and @Bitraversable@ typeclasses, which+ were introduced in GHC 8.2. Use @Data.Bifunctor.TH@ from+ @<http://hackage.haskell.org/package/bifunctors bifunctors>@+ to derive these typeclasses using Template Haskell. homepage: https://github.com/haskell-compat/deriving-compat bug-reports: https://github.com/haskell-compat/deriving-compat/issues license: BSD3@@ -87,16 +89,24 @@ library exposed-modules: Data.Deriving + Data.Bounded.Deriving+ Data.Enum.Deriving Data.Eq.Deriving Data.Foldable.Deriving Data.Functor.Deriving+ Data.Ix.Deriving Data.Ord.Deriving Data.Traversable.Deriving Text.Read.Deriving Text.Show.Deriving- other-modules: Data.Eq.Deriving.Internal- Data.Deriving.Internal++ other-modules: Data.Deriving.Internal++ Data.Bounded.Deriving.Internal+ Data.Enum.Deriving.Internal+ Data.Eq.Deriving.Internal Data.Functor.Deriving.Internal+ Data.Ix.Deriving.Internal Data.Ord.Deriving.Internal Text.Read.Deriving.Internal Text.Show.Deriving.Internal@@ -130,7 +140,8 @@ test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs- other-modules: EqSpec+ other-modules: BoundedEnumIxSpec+ EqSpec FunctorSpec OrdSpec ReadSpec@@ -140,7 +151,7 @@ Types.ReadShow build-depends: base-compat >= 0.8.1 && < 1 , base-orphans >= 0.5 && < 1- , deriving-compat == 0.3.2+ , deriving-compat == 0.3.3 , hspec >= 1.8 , QuickCheck >= 2 && < 3 , template-haskell >= 2.5 && < 2.12@@ -160,4 +171,4 @@ hs-source-dirs: tests default-language: Haskell2010- ghc-options: -Wall+ ghc-options: -Wall -threaded -rtsopts
+ src/Data/Bounded/Deriving.hs view
@@ -0,0 +1,27 @@+{-|+Module: Data.Bounded.Deriving+Copyright: (C) 2015-2016 Ryan Scott+License: BSD-style (see the file LICENSE)+Maintainer: Ryan Scott+Portability: Template Haskell++Exports functions to mechanically derive 'Bounded' instances.+-}+module Data.Bounded.Deriving (+ -- * 'Bounded'+ deriveBounded+ , makeMinBound+ , makeMaxBound+ -- * 'deriveBounded' limitations+ -- $constraints+ ) where++import Data.Bounded.Deriving.Internal++{- $constraints++Be aware of the following potential gotchas:++* Type variables of kind @*@ are assumed to have 'Bounded' constraints.+ If this is not desirable, use 'makeMinBound' or one of its cousins.+-}
+ src/Data/Bounded/Deriving/Internal.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE CPP #-}++{-|+Module: Data.Bounded.Deriving.Internal+Copyright: (C) 2015-2016 Ryan Scott+License: BSD-style (see the file LICENSE)+Maintainer: Ryan Scott+Portability: Template Haskell++Exports functions to mechanically derive 'Bounded' instances.+-}+module Data.Bounded.Deriving.Internal (+ -- * 'Bounded'+ deriveBounded+ , makeMinBound+ , makeMaxBound+ ) where++import Data.Deriving.Internal++import Language.Haskell.TH.Lib+import Language.Haskell.TH.Syntax++-------------------------------------------------------------------------------+-- Code generation+-------------------------------------------------------------------------------++-- | Generates a 'Bounded' instance declaration for the given data type or data+-- family instance.+deriveBounded :: Name -> Q [Dec]+deriveBounded name = withType name fromCons+ where+ fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec]+ fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do+ (instanceCxt, instanceType)+ <- buildTypeInstance BoundedClass name' ctxt tvbs mbTys+ instanceD (return instanceCxt)+ (return instanceType)+ (boundedFunDecs name' cons)++-- | Generates a lambda expression which behaves like 'minBound' (without+-- requiring a 'Bounded' instance).+makeMinBound :: Name -> Q Exp+makeMinBound = makeBoundedFun MinBound++-- | Generates a lambda expression which behaves like 'maxBound' (without+-- requiring a 'Bounded' instance).+makeMaxBound :: Name -> Q Exp+makeMaxBound = makeBoundedFun MaxBound++-- | Generates 'minBound' and 'maxBound' method declarations.+boundedFunDecs :: Name -> [Con] -> [Q Dec]+boundedFunDecs tyName cons = [makeFunD MinBound, makeFunD MaxBound]+ where+ makeFunD :: BoundedFun -> Q Dec+ makeFunD bf =+ funD (boundedFunName bf)+ [ clause []+ (normalB $ makeBoundedFunForCons bf tyName cons)+ []+ ]++-- | Generates a lambda expression which behaves like the BoundedFun argument.+makeBoundedFun :: BoundedFun -> Name -> Q Exp+makeBoundedFun bf name = withType name fromCons where+ fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp+ fromCons name' ctxt tvbs cons mbTys =+ -- We force buildTypeInstance here since it performs some checks for whether+ -- or not the provided datatype can actually have minBound/maxBound+ -- implemented for it, and produces errors if it can't.+ buildTypeInstance BoundedClass name' ctxt tvbs mbTys+ `seq` makeBoundedFunForCons bf name' cons++-- | Generates a lambda expression for minBound/maxBound. for the+-- given constructors. All constructors must be from the same type.+makeBoundedFunForCons :: BoundedFun -> Name -> [Con] -> Q Exp+makeBoundedFunForCons _ _ [] = noConstructorsError+makeBoundedFunForCons bf tyName cons+ | not (isProduct || isEnumeration)+ = enumerationOrProductError $ nameBase tyName+ | isEnumeration+ = pickCon+ | otherwise -- It's a product type+ = pickConApp+ where+ isProduct, isEnumeration :: Bool+ isProduct = isProductType cons+ isEnumeration = isEnumerationType cons++ con1, conN :: Q Exp+ con1 = conE $ constructorName $ head cons+ conN = conE $ constructorName $ last cons++ pickCon :: Q Exp+ pickCon = case bf of+ MinBound -> con1+ MaxBound -> conN++ pickConApp :: Q Exp+ pickConApp = appsE+ $ pickCon+ : map varE (replicate (conArity $ head cons) (boundedFunName bf))++-------------------------------------------------------------------------------+-- Class-specific constants+-------------------------------------------------------------------------------++-- There's only one Bounded variant!+data BoundedClass = BoundedClass++instance ClassRep BoundedClass where+ arity _ = 0++ allowExQuant _ = True++ fullClassName _ = boundedTypeName++ classConstraint _ 0 = Just $ boundedTypeName+ classConstraint _ _ = Nothing++-- | A representation of which function is being generated.+data BoundedFun = MinBound | MaxBound++boundedFunName :: BoundedFun -> Name+boundedFunName MinBound = minBoundValName+boundedFunName MaxBound = maxBoundValName
src/Data/Deriving.hs view
@@ -11,6 +11,9 @@ modules. -} module Data.Deriving (+ -- * Backported changes+ -- $changes+ -- * @derive@- functions -- $derive @@ -19,14 +22,49 @@ module Exports ) where +import Data.Bounded.Deriving as Exports+import Data.Enum.Deriving as Exports import Data.Eq.Deriving as Exports import Data.Foldable.Deriving as Exports import Data.Functor.Deriving as Exports+import Data.Ix.Deriving as Exports import Data.Ord.Deriving as Exports import Data.Traversable.Deriving as Exports import Text.Read.Deriving as Exports import Text.Show.Deriving as Exports +{- $changes+The following changes have been backported:++* In GHC 7.8, deriving standalone 'Read' instances was fixed to avoid crashing on+ datatypes with no constructors.++* In GHC 7.10, deriving standalone 'Read' and 'Show' instances were fixed to ensure+ that they use the correct fixity information for a particular datatype.++* In GHC 8.0, @DeriveFoldable@ was changed to allow folding over data types with+ existential constraints.++* In GHC 8.0, @DeriveFoldable@ and @DeriveTraversable@ were changed so as not to+ generate superfluous 'mempty' or 'pure' expressions in generated code. As a result,+ this allows deriving 'Traversable' instances for datatypes with unlifted argument+ types.++* In GHC 8.0, deriving 'Ix' was changed to use @('&&')@ instead of @if@, as the latter+ interacts poorly with @RebindableSyntax@. A bug was also fixed so that+ standalone-derived 'Ix' instances for single-constructor GADTs do not crash GHC.++* In GHC 8.0, deriving 'Show' was changed so that constructor fields with unlifted+ types are no longer shown with parentheses, and the output of showing an unlifted+ type is suffixed with the same number of hash signs as the corresponding primitive+ literals.++* In GHC 8.2, deriving 'Ord' was changed so that it generates concrete @if@-expressions+ that are not subject to @RebindableSyntax@. It was also changed so that derived+ @('<=')@, @('>')@, and @('>=')@ methods are expressed through @('<')@, which avoids+ generating a substantial amount of code.+-}+ {- $derive Functions with the @derive@- prefix can be used to automatically generate an instance@@ -66,7 +104,7 @@ @derive@-functions in @deriving-compat@ fall into one of three categories: * Category 0: Typeclasses with an argument of kind @*@.- ('deriveEq', 'deriveOrd', 'deriveRead', 'deriveShow')+ ('deriveBounded', 'deriveEnum', 'deriveEq', 'deriveIx', 'deriveOrd', 'deriveRead', 'deriveShow') * Category 1: Typeclasses with an argument of kind @* -> *@, That is, a datatype with such an instance must have at least one type variable, and the last type
src/Data/Deriving/Internal.hs view
@@ -22,6 +22,7 @@ -} module Data.Deriving.Internal where +import Control.Applicative (liftA2) import Control.Monad (liftM, when, unless) import Data.Foldable (foldr')@@ -931,6 +932,20 @@ . showString "\n\tuse GHC >= 7.4 instead.)" $ "" +enumerationError :: String -> Q a+enumerationError = fail . enumerationErrorStr++enumerationOrProductError :: String -> Q a+enumerationOrProductError nb = fail $ unlines+ [ enumerationErrorStr nb+ , "\tor a product type (precisely one constructor)"+ ]++enumerationErrorStr :: String -> String+enumerationErrorStr nb =+ '\'':nb ++ "’ must be an enumeration type"+ ++ " (one or more nullary, non-GADT constructors)"+ ------------------------------------------------------------------------------- -- Assorted utilities -------------------------------------------------------------------------------@@ -952,13 +967,13 @@ interleave _ _ = [] #if MIN_VERSION_ghc_prim(0,3,1)-tagToEnum :: Int# -> Bool-tagToEnum x = tagToEnum# x+isTrue# :: Int# -> Bool+isTrue# x = tagToEnum# x #else-tagToEnum :: Bool -> Bool-tagToEnum x = x+isTrue# :: Bool -> Bool+isTrue# x = x #endif-{-# INLINE tagToEnum #-}+{-# INLINE isTrue# #-} -- isRight and fromEither taken from the extra package (BSD3-licensed) @@ -1137,6 +1152,41 @@ #endif isNullaryCon _ = False +-- | Returns the number of fields for the constructor.+conArity :: Con -> Int+conArity (NormalC _ tys) = length tys+conArity (RecC _ tys) = length tys+conArity InfixC{} = 2+conArity (ForallC _ _ con) = conArity con+#if MIN_VERSION_template_haskell(2,11,0)+conArity (GadtC _ tys _) = length tys+conArity (RecGadtC _ tys _) = length tys+#endif++-- | Returns 'True' if it's a datatype with exactly one, non-existential constructor.+isProductType :: [Con] -> Bool+isProductType [con] = case con of+ ForallC tvbs _ _ -> null tvbs+ _ -> True+isProductType _ = False++-- | Returns 'True' if it's a datatype with one or more nullary, non-GADT+-- constructors.+isEnumerationType :: [Con] -> Bool+isEnumerationType cons@(_:_) = all (liftA2 (&&) isNullaryCon isVanillaCon) cons+isEnumerationType _ = False++-- | Returns 'False' if we're dealing with existential quantification or GADTs.+isVanillaCon :: Con -> Bool+isVanillaCon NormalC{} = True+isVanillaCon RecC{} = True+isVanillaCon InfixC{} = True+isVanillaCon ForallC{} = False+#if MIN_VERSION_template_haskell(2,11,0)+isVanillaCon GadtC{} = False+isVanillaCon RecGadtC{} = False+#endif+ -- | Generate a list of fresh names with a common prefix, and numbered suffixes. newNameList :: String -> Int -> Q [Name] newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n]@@ -1335,8 +1385,69 @@ (normalB $ untagExpr more e) []] +tag2ConExpr :: Type -> Q Exp+tag2ConExpr ty = do+ iHash <- newName "i#"+ ty' <- freshenType ty+ lam1E (conP iHashDataName [varP iHash]) $+ varE tagToEnumHashValName `appE` varE iHash+ `sigE` return (ForallT (requiredTyVarsOfType ty') [] ty')+ -- tagToEnum# is a hack, and won't typecheck unless it's in the+ -- immediate presence of a type ascription like so:+ --+ -- tagToEnum# x :: Foo+ --+ -- We have to be careful when dealing with datatypes with type+ -- variables, since Template Haskell might reject the type variables+ -- we use for being out-of-scope. To avoid this, we explicitly+ -- collect the type variable binders with requiredTyVarsOfType+ -- and shove them into a ForallT. Also make sure to freshen the+ -- bound type variables to avoid shadowed variable warnings when+ -- -Wall is enabled.+ --+ -- Note that we do NOT collect the kind variable binders, since+ -- a type signature like `forall k a. Foo (a :: k)` won't typecheck+ -- unless TypeInType is enabled (i.e., if GHC 8.0 or later is being+ -- used). Luckily, GHC seems to just accept kind variables, even if+ -- they aren't actually bound in a ForallT.++removeClassApp :: Type -> Type+removeClassApp (AppT _ t2) = t2+removeClassApp t = t++-- This is an ugly, but unfortunately necessary hack on older versions of GHC which+-- don't have a properly working newName. On those GHCs, even running newName on a+-- variable isn't enought to avoid shadowed variable warnings, so we "fix" the issue by+-- appending an uncommonly used string to the end of the name. This isn't foolproof,+-- since a user could freshen a variable named x and still have another x_' variable in+-- scope, but at least it's unlikely.+freshen :: Name -> Q Name+freshen n = newName (nameBase n ++ "_'")++freshenType :: Type -> Q Type+freshenType (AppT t1 t2) = do t1' <- freshenType t1+ t2' <- freshenType t2+ return $ AppT t1' t2'+freshenType (SigT t k) = do t' <- freshenType t+ return $ SigT t' k+freshenType (VarT n) = fmap VarT $ freshen n+freshenType t = return t++-- | Gets all of the required type variable binders mentioned in a Type.+requiredTyVarsOfType :: Type -> [TyVarBndr]+requiredTyVarsOfType = go+ where+ go :: Type -> [TyVarBndr]+ go (AppT t1 t2) = go t1 ++ go t2+ go (SigT t _) = go t+ go (VarT n) = [PlainTV n]+ go _ = []++enumFromToExpr :: Q Exp -> Q Exp -> Q Exp+enumFromToExpr f t = varE enumFromToValName `appE` f `appE` t+ primOpAppExpr :: Q Exp -> Name -> Q Exp -> Q Exp-primOpAppExpr e1 op e2 = varE tagToEnumValName `appE`+primOpAppExpr e1 op e2 = varE isTrueHashValName `appE` infixApp e1 (varE op) e2 -- | Checks if a 'Name' represents a tuple type constructor (other than '()')@@ -1366,6 +1477,9 @@ mkDerivingCompatName_v :: String -> Name mkDerivingCompatName_v = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" +isTrueHashValName :: Name+isTrueHashValName = mkDerivingCompatName_v "isTrue#"+ fmapConstValName :: Name fmapConstValName = mkDerivingCompatName_v "fmapConst" @@ -1438,9 +1552,6 @@ liftShowsPrec2ConstValName :: Name liftShowsPrec2ConstValName = mkDerivingCompatName_v "liftShowsPrec2Const" -tagToEnumValName :: Name-tagToEnumValName = mkDerivingCompatName_v "tagToEnum"- cHashDataName :: Name cHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "C#" @@ -1474,12 +1585,18 @@ addrHashTypeName :: Name addrHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Addr#" +boundedTypeName :: Name+boundedTypeName = mkNameG_tc "base" "GHC.Enum" "Bounded"+ charHashTypeName :: Name charHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Char#" doubleHashTypeName :: Name doubleHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Double#" +enumTypeName :: Name+enumTypeName = mkNameG_tc "base" "GHC.Enum" "Enum"+ floatHashTypeName :: Name floatHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Float#" @@ -1489,9 +1606,15 @@ functorTypeName :: Name functorTypeName = mkNameG_tc "base" "GHC.Base" "Functor" +intTypeName :: Name+intTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "Int"+ intHashTypeName :: Name intHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int#" +ixTypeName :: Name+ixTypeName = mkNameG_tc "base" "GHC.Arr" "Ix"+ readTypeName :: Name readTypeName = mkNameG_tc "base" "GHC.Read" "Read" @@ -1510,6 +1633,9 @@ appEndoValName :: Name appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo" +appendValName :: Name+appendValName = mkNameG_v "base" "GHC.Base" "++"+ chooseValName :: Name chooseValName = mkNameG_v "base" "GHC.Read" "choose" @@ -1519,6 +1645,18 @@ constValName :: Name constValName = mkNameG_v "base" "GHC.Base" "const" +enumFromValName :: Name+enumFromValName = mkNameG_v "base" "GHC.Enum" "enumFrom"++enumFromThenValName :: Name+enumFromThenValName = mkNameG_v "base" "GHC.Enum" "enumFromThen"++enumFromThenToValName :: Name+enumFromThenToValName = mkNameG_v "base" "GHC.Enum" "enumFromThenTo"++enumFromToValName :: Name+enumFromToValName = mkNameG_v "base" "GHC.Enum" "enumFromTo"+ eqAddrHashValName :: Name eqAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqAddr#" @@ -1552,6 +1690,9 @@ foldMapValName :: Name foldMapValName = mkNameG_v "base" "Data.Foldable" "foldMap" +fromEnumValName :: Name+fromEnumValName = mkNameG_v "base" "GHC.Enum" "fromEnum"+ geAddrHashValName :: Name geAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geAddr#" @@ -1597,6 +1738,12 @@ idValName :: Name idValName = mkNameG_v "base" "GHC.Base" "id" +indexValName :: Name+indexValName = mkNameG_v "base" "GHC.Arr" "index"++inRangeValName :: Name+inRangeValName = mkNameG_v "base" "GHC.Arr" "inRange"+ leAddrHashValName :: Name leAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leAddr#" @@ -1654,6 +1801,18 @@ ltWordHashValName :: Name ltWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord#" +minBoundValName :: Name+minBoundValName = mkNameG_v "base" "GHC.Enum" "minBound"++mapValName :: Name+mapValName = mkNameG_v "base" "GHC.Base" "map"++maxBoundValName :: Name+maxBoundValName = mkNameG_v "base" "GHC.Enum" "maxBound"++minusIntHashValName :: Name+minusIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "-#"+ parenValName :: Name parenValName = mkNameG_v "base" "GHC.Read" "paren" @@ -1663,9 +1822,21 @@ pfailValName :: Name pfailValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "pfail" +plusValName :: Name+plusValName = mkNameG_v "base" "GHC.Num" "+"+ precValName :: Name precValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "prec" +predValName :: Name+predValName = mkNameG_v "base" "GHC.Enum" "pred"++rangeSizeValName :: Name+rangeSizeValName = mkNameG_v "base" "GHC.Arr" "rangeSize"++rangeValName :: Name+rangeValName = mkNameG_v "base" "GHC.Arr" "range"+ readListValName :: Name readListValName = mkNameG_v "base" "GHC.Read" "readList" @@ -1717,8 +1888,26 @@ stepValName :: Name stepValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "step" +succValName :: Name+succValName = mkNameG_v "base" "GHC.Enum" "succ"++tagToEnumHashValName :: Name+tagToEnumHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "tagToEnum#"++timesValName :: Name+timesValName = mkNameG_v "base" "GHC.Num" "*"++toEnumValName :: Name+toEnumValName = mkNameG_v "base" "GHC.Enum" "toEnum"+ traverseValName :: Name traverseValName = mkNameG_v "base" "Data.Traversable" "traverse"++unsafeIndexValName :: Name+unsafeIndexValName = mkNameG_v "base" "GHC.Arr" "unsafeIndex"++unsafeRangeSizeValName :: Name+unsafeRangeSizeValName = mkNameG_v "base" "GHC.Arr" "unsafeRangeSize" unwrapMonadValName :: Name unwrapMonadValName = mkNameG_v "base" "Control.Applicative" "unwrapMonad"
+ src/Data/Enum/Deriving.hs view
@@ -0,0 +1,31 @@+{-|+Module: Data.Enum.Deriving+Copyright: (C) 2015-2016 Ryan Scott+License: BSD-style (see the file LICENSE)+Maintainer: Ryan Scott+Portability: Template Haskell++Exports functions to mechanically derive 'Enum' instances.+-}+module Data.Enum.Deriving (+ -- * 'Enum'+ deriveEnum+ , makeSucc+ , makePred+ , makeToEnum+ , makeFromEnum+ , makeEnumFrom+ , makeEnumFromThen+ -- * 'deriveEnum' limitations+ -- $constraints+ ) where++import Data.Enum.Deriving.Internal++{- $constraints++Be aware of the following potential gotchas:++* Type variables of kind @*@ are assumed to have 'Enum' constraints.+ If this is not desirable, use 'makeToEnum' or one of its cousins.+-}
+ src/Data/Enum/Deriving/Internal.hs view
@@ -0,0 +1,238 @@+{-|+Module: Data.Enum.Deriving.Internal+Copyright: (C) 2015-2016 Ryan Scott+License: BSD-style (see the file LICENSE)+Maintainer: Ryan Scott+Portability: Template Haskell++Exports functions to mechanically derive 'Enum' instances.+-}+module Data.Enum.Deriving.Internal (+ -- * 'Enum'+ deriveEnum+ , makeSucc+ , makePred+ , makeToEnum+ , makeFromEnum+ , makeEnumFrom+ , makeEnumFromThen+ ) where++import Data.Deriving.Internal++import Language.Haskell.TH.Lib+import Language.Haskell.TH.Syntax++-------------------------------------------------------------------------------+-- Code generation+-------------------------------------------------------------------------------++-- | Generates an 'Enum' instance declaration for the given data type or data+-- family instance.+deriveEnum :: Name -> Q [Dec]+deriveEnum name = withType name fromCons+ where+ fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec]+ fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do+ (instanceCxt, instanceType)+ <- buildTypeInstance EnumClass name' ctxt tvbs mbTys+ instanceD (return instanceCxt)+ (return instanceType)+ (enumFunDecs name' instanceType cons)++-- | Generates a lambda expression which behaves like 'succ' (without+-- requiring an 'Enum' instance).+makeSucc :: Name -> Q Exp+makeSucc = makeEnumFun Succ++-- | Generates a lambda expression which behaves like 'pred' (without+-- requiring an 'Enum' instance).+makePred :: Name -> Q Exp+makePred = makeEnumFun Pred++-- | Generates a lambda expression which behaves like 'toEnum' (without+-- requiring an 'Enum' instance).+makeToEnum :: Name -> Q Exp+makeToEnum = makeEnumFun ToEnum++-- | Generates a lambda expression which behaves like 'fromEnum' (without+-- requiring an 'Enum' instance).+makeFromEnum :: Name -> Q Exp+makeFromEnum = makeEnumFun FromEnum++-- | Generates a lambda expression which behaves like 'enumFrom' (without+-- requiring an 'Enum' instance).+makeEnumFrom :: Name -> Q Exp+makeEnumFrom = makeEnumFun EnumFrom++-- | Generates a lambda expression which behaves like 'enumFromThen' (without+-- requiring an 'Enum' instance).+makeEnumFromThen :: Name -> Q Exp+makeEnumFromThen = makeEnumFun EnumFromThen++-- | Generates method declarations for an 'Enum' instance.+enumFunDecs :: Name -> Type -> [Con] -> [Q Dec]+enumFunDecs tyName ty cons =+ map makeFunD [ Succ+ , Pred+ , ToEnum+ , EnumFrom+ , EnumFromThen+ , FromEnum+ ]+ where+ makeFunD :: EnumFun -> Q Dec+ makeFunD ef =+ funD (enumFunName ef)+ [ clause []+ (normalB $ makeEnumFunForCons ef tyName ty cons)+ []+ ]++-- | Generates a lambda expression which behaves like the EnumFun argument.+makeEnumFun :: EnumFun -> Name -> Q Exp+makeEnumFun ef name = withType name fromCons where+ fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp+ fromCons name' ctxt tvbs cons mbTys = do+ (_, instanceType) <- buildTypeInstance EnumClass name' ctxt tvbs mbTys+ makeEnumFunForCons ef name' instanceType cons++-- | Generates a lambda expression for fromEnum/toEnum/etc. for the+-- given constructors. All constructors must be from the same type.+makeEnumFunForCons :: EnumFun -> Name -> Type -> [Con] -> Q Exp+makeEnumFunForCons _ _ _ [] = noConstructorsError+makeEnumFunForCons ef tyName ty cons+ | not $ isEnumerationType cons+ = enumerationError tyNameBase+ | otherwise = case ef of+ Succ -> lamOneHash $ \aHash ->+ condE (varE eqValName `appE` maxTagExpr `appE`+ (conE iHashDataName `appE` varE aHash))+ (illegalExpr "succ" tyNameBase+ "tried to take `succ' of last tag in enumeration")+ (tag2Con `appE` (varE plusValName `appE`+ (conE iHashDataName `appE` varE aHash) `appE` integerE 1))++ Pred -> lamOneHash $ \aHash ->+ condE (varE eqValName `appE` integerE 0 `appE`+ (conE iHashDataName `appE` varE aHash))+ (illegalExpr "pred" tyNameBase+ "tried to take `pred' of first tag in enumeration")+ (tag2Con `appE` (varE plusValName `appE`+ (conE iHashDataName `appE` varE aHash) `appE` integerE (-1)))++ ToEnum -> lamOne $ \a ->+ condE (appsE [ varE andValName+ , varE geValName `appE` varE a `appE` integerE 0+ , varE leValName `appE` varE a `appE` maxTagExpr+ ])+ (tag2Con `appE` varE a)+ (illegalToEnumTag tyNameBase maxTagExpr a)++ EnumFrom -> lamOneHash $ \aHash ->+ appsE [ varE mapValName+ , tag2Con+ , enumFromToExpr (conE iHashDataName `appE` varE aHash) maxTagExpr+ ]++ EnumFromThen -> do+ a <- newName "a"+ aHash <- newName "a#"+ b <- newName "b"+ bHash <- newName "b#"+ lamE [varP a, varP b] $ untagExpr [(a, aHash), (b, bHash)] $+ appE (varE mapValName `appE` tag2Con) $+ enumFromThenToExpr+ (conE iHashDataName `appE` varE aHash)+ (conE iHashDataName `appE` varE bHash)+ (condE (appsE [ varE gtValName+ , conE iHashDataName `appE` varE aHash+ , conE iHashDataName `appE` varE bHash+ ])+ (integerE 0) maxTagExpr)++ FromEnum -> lamOneHash $ \aHash ->+ conE iHashDataName `appE` varE aHash++ where+ tyNameBase :: String+ tyNameBase = nameBase tyName++ maxTagExpr :: Q Exp+ maxTagExpr = integerE (length cons - 1) `sigE` conT intTypeName++ lamOne :: (Name -> Q Exp) -> Q Exp+ lamOne f = do+ a <- newName "a"+ lam1E (varP a) $ f a++ lamOneHash :: (Name -> Q Exp) -> Q Exp+ lamOneHash f = lamOne $ \a -> do+ aHash <- newName "a#"+ untagExpr [(a, aHash)] $ f aHash++ tag2Con :: Q Exp+ tag2Con = tag2ConExpr $ removeClassApp ty++-------------------------------------------------------------------------------+-- Class-specific constants+-------------------------------------------------------------------------------++-- There's only one Enum variant!+data EnumClass = EnumClass++instance ClassRep EnumClass where+ arity _ = 0++ allowExQuant _ = True++ fullClassName _ = enumTypeName++ classConstraint _ 0 = Just $ enumTypeName+ classConstraint _ _ = Nothing++-- | A representation of which function is being generated.+data EnumFun = Succ+ | Pred+ | ToEnum+ | FromEnum+ | EnumFrom+ | EnumFromThen+ deriving Show++enumFunName :: EnumFun -> Name+enumFunName Succ = succValName+enumFunName Pred = predValName+enumFunName ToEnum = toEnumValName+enumFunName FromEnum = fromEnumValName+enumFunName EnumFrom = enumFromValName+enumFunName EnumFromThen = enumFromThenValName++-------------------------------------------------------------------------------+-- Assorted utilities+-------------------------------------------------------------------------------++enumFromThenToExpr :: Q Exp -> Q Exp -> Q Exp -> Q Exp+enumFromThenToExpr f t1 t2 = varE enumFromThenToValName `appE` f `appE` t1 `appE` t2++illegalExpr :: String -> String -> String -> Q Exp+illegalExpr meth tp msg =+ varE errorValName `appE` stringE (meth ++ '{':tp ++ "}: " ++ msg)++illegalToEnumTag :: String -> Q Exp -> Name -> Q Exp+illegalToEnumTag tp maxtag a =+ appE (varE errorValName)+ (appE (appE (varE appendValName)+ (stringE ("toEnum{" ++ tp ++ "}: tag(")))+ (appE (appE (appE+ (varE showsPrecValName)+ (integerE 0))+ (varE a))+ (appE (appE+ (varE appendValName)+ (stringE ") is outside of enumeration's range (0,"))+ (appE (appE (appE+ (varE showsPrecValName)+ (integerE 0))+ maxtag)+ (stringE ")")))))
+ src/Data/Ix/Deriving.hs view
@@ -0,0 +1,28 @@+{-|+Module: Data.Ix.Deriving+Copyright: (C) 2015-2016 Ryan Scott+License: BSD-style (see the file LICENSE)+Maintainer: Ryan Scott+Portability: Template Haskell++Exports functions to mechanically derive 'Ix' instances.+-}+module Data.Ix.Deriving (+ -- * 'Ix'+ deriveIx+ , makeRange+ , makeUnsafeIndex+ , makeInRange+ -- * 'deriveIx' limitations+ -- $constraints+ ) where++import Data.Ix.Deriving.Internal++{- $constraints++Be aware of the following potential gotchas:++* Type variables of kind @*@ are assumed to have 'Ix' constraints.+ If this is not desirable, use 'makeRange' or one of its cousins.+-}
+ src/Data/Ix/Deriving/Internal.hs view
@@ -0,0 +1,225 @@+{-|+Module: Data.Ix.Deriving.Internal+Copyright: (C) 2015-2016 Ryan Scott+License: BSD-style (see the file LICENSE)+Maintainer: Ryan Scott+Portability: Template Haskell++Exports functions to mechanically derive 'Ix' instances.+-}+module Data.Ix.Deriving.Internal (+ -- * 'Ix'+ deriveIx+ , makeRange+ , makeUnsafeIndex+ , makeInRange+ ) where++import Data.Deriving.Internal++import Language.Haskell.TH.Lib+import Language.Haskell.TH.Syntax++-------------------------------------------------------------------------------+-- Code generation+-------------------------------------------------------------------------------++-- | Generates a 'Ix' instance declaration for the given data type or data+-- family instance.+deriveIx :: Name -> Q [Dec]+deriveIx name = withType name fromCons+ where+ fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec]+ fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do+ (instanceCxt, instanceType)+ <- buildTypeInstance IxClass name' ctxt tvbs mbTys+ instanceD (return instanceCxt)+ (return instanceType)+ (ixFunDecs name' instanceType cons)++-- | Generates a lambda expression which behaves like 'range' (without+-- requiring an 'Ix' instance).+makeRange :: Name -> Q Exp+makeRange = makeIxFun Range++-- | Generates a lambda expression which behaves like 'unsafeIndex' (without+-- requiring an 'Ix' instance).+makeUnsafeIndex :: Name -> Q Exp+makeUnsafeIndex = makeIxFun UnsafeIndex++-- | Generates a lambda expression which behaves like 'inRange' (without+-- requiring an 'Ix' instance).+makeInRange :: Name -> Q Exp+makeInRange = makeIxFun InRange++-- | Generates method declarations for an 'Ix' instance.+ixFunDecs :: Name -> Type -> [Con] -> [Q Dec]+ixFunDecs tyName ty cons =+ [ makeFunD Range+ , makeFunD UnsafeIndex+ , makeFunD InRange+ ]+ where+ makeFunD :: IxFun -> Q Dec+ makeFunD ixf =+ funD (ixFunName ixf)+ [ clause []+ (normalB $ makeIxFunForCons ixf tyName ty cons)+ []+ ]++-- | Generates a lambda expression which behaves like the IxFun argument.+makeIxFun :: IxFun -> Name -> Q Exp+makeIxFun ixf name = withType name fromCons where+ fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp+ fromCons name' ctxt tvbs cons mbTys = do+ (_, instanceType) <- buildTypeInstance IxClass name' ctxt tvbs mbTys+ makeIxFunForCons ixf name' instanceType cons++-- | Generates a lambda expression for an 'Ix' method for the+-- given constructors. All constructors must be from the same type.+makeIxFunForCons :: IxFun -> Name -> Type -> [Con] -> Q Exp+makeIxFunForCons _ _ _ [] = noConstructorsError+makeIxFunForCons ixf tyName ty cons+ | not (isProduct || isEnumeration)+ = enumerationOrProductError $ nameBase tyName+ | isEnumeration+ = case ixf of+ Range -> do+ a <- newName "a"+ aHash <- newName "a#"+ b <- newName "b"+ bHash <- newName "b#"+ lamE [tupP [varP a, varP b]] $+ untagExpr [(a, aHash)] $+ untagExpr [(b, bHash)] $+ appE (varE mapValName `appE` tag2Con) $+ enumFromToExpr (conE iHashDataName `appE` varE aHash)+ (conE iHashDataName `appE` varE bHash)++ UnsafeIndex -> do+ a <- newName "a"+ aHash <- newName "a#"+ c <- newName "c"+ cHash <- newName "c#"+ dHash <- newName "d#"+ lamE [tupP [varP a, wildP], varP c] $+ untagExpr [(a, aHash)] $+ untagExpr [(c, cHash)] $+ caseE (infixApp (varE cHash) (varE minusIntHashValName) (varE aHash))+ [ match (varP dHash)+ (normalB $ conE iHashDataName `appE` varE dHash)+ []+ ]++ InRange -> do+ a <- newName "a"+ aHash <- newName "a#"+ b <- newName "b"+ bHash <- newName "b#"+ c <- newName "c"+ cHash <- newName "c#"+ lamE [tupP [varP a, varP b], varP c] $+ untagExpr [(a, aHash)] $+ untagExpr [(b, bHash)] $+ untagExpr [(c, cHash)] $+ appsE [ varE andValName+ , primOpAppExpr (varE cHash) geIntHashValName (varE aHash)+ , primOpAppExpr (varE cHash) leIntHashValName (varE bHash)+ ]++ | otherwise -- It's a product type+ = do let con :: Con+ [con] = cons++ conName :: Name+ conName = constructorName con++ conFields :: Int+ conFields = conArity con++ as <- newNameList "a" conFields+ bs <- newNameList "b" conFields+ cs <- newNameList "c" conFields++ let conPat :: [Name] -> Q Pat+ conPat = conP conName . map varP++ conExpr :: Q Exp+ conExpr = appsE $ conE conName : map varE cs++ case ixf of+ Range -> lamE [tupP [conPat as, conPat bs]] $+ compE $ stmts ++ [noBindS conExpr]+ where+ stmts :: [Q Stmt]+ stmts = zipWith3 mkQual as bs cs++ mkQual :: Name -> Name -> Name -> Q Stmt+ mkQual a b c = bindS (varP c) $+ varE rangeValName `appE` tupE [varE a, varE b]++ UnsafeIndex -> lamE [tupP [conPat as, conPat bs], conPat cs] $+ mkUnsafeIndex $ reverse $ zip3 as bs cs+ where+ mkUnsafeIndex :: [(Name, Name, Name)] -> Q Exp+ mkUnsafeIndex [] = integerE 0+ mkUnsafeIndex [(l, u, i)] = mkOne l u i+ mkUnsafeIndex ((l, u, i):rest) =+ infixApp (mkOne l u i)+ (varE plusValName)+ (infixApp (varE unsafeRangeSizeValName+ `appE` tupE [varE l, varE u])+ (varE timesValName)+ (mkUnsafeIndex rest))++ mkOne :: Name -> Name -> Name -> Q Exp+ mkOne l u i = varE unsafeIndexValName `appE` tupE [varE l, varE u]+ `appE` varE i++ InRange -> lamE [tupP [conPat as, conPat bs], conPat cs] $+ if conFields == 0+ then conE trueDataName+ else foldl1 andExpr $ zipWith3 mkInRange as bs cs+ where+ andExpr :: Q Exp -> Q Exp -> Q Exp+ andExpr a b = infixApp a (varE andValName) b++ mkInRange :: Name -> Name -> Name -> Q Exp+ mkInRange a b c = varE inRangeValName `appE` tupE [varE a, varE b]+ `appE` varE c+ where+ isProduct, isEnumeration :: Bool+ isProduct = isProductType cons+ isEnumeration = isEnumerationType cons++ tag2Con :: Q Exp+ tag2Con = tag2ConExpr $ removeClassApp ty++-------------------------------------------------------------------------------+-- Class-specific constants+-------------------------------------------------------------------------------++-- There's only one Ix variant!+data IxClass = IxClass++instance ClassRep IxClass where+ arity _ = 0++ allowExQuant _ = True++ fullClassName _ = ixTypeName++ classConstraint _ 0 = Just ixTypeName+ classConstraint _ _ = Nothing++-- | A representation of which function is being generated.+data IxFun = Range+ | UnsafeIndex+ | InRange+ deriving Show++ixFunName :: IxFun -> Name+ixFunName Range = rangeValName+ixFunName UnsafeIndex = unsafeIndexValName+ixFunName InRange = inRangeValName
src/Text/Show/Deriving/Internal.hs view
@@ -349,7 +349,7 @@ m <- match (conP conName [varP arg]) (normalB $ varE showParenValName- `appE` infixApp (varE p) (varE ltValName) (integerE appPrec)+ `appE` infixApp (varE p) (varE gtValName) (integerE appPrec) `appE` namedArg) [] return [m]@@ -381,7 +381,7 @@ match (conP conName $ map varP args) (normalB $ varE showParenValName- `appE` infixApp (varE p) (varE ltValName) (integerE appPrec)+ `appE` infixApp (varE p) (varE gtValName) (integerE appPrec) `appE` namedArgs) [] return [m]@@ -409,7 +409,7 @@ m <- match (conP conName $ map varP args) (normalB $ varE showParenValName- `appE` infixApp (varE p) (varE ltValName) (integerE appPrec)+ `appE` infixApp (varE p) (varE gtValName) (integerE appPrec) `appE` namedArgs) [] return [m]@@ -439,7 +439,7 @@ m <- match (infixP (varP al) conName (varP ar))- (normalB $ (varE showParenValName `appE` infixApp (varE p) (varE ltValName) (integerE conPrec))+ (normalB $ (varE showParenValName `appE` infixApp (varE p) (varE gtValName) (integerE conPrec)) `appE` (infixApp (makeShowForArg (conPrec + 1) sClass opts conName tvMap alTy al) (varE composeValName) (infixApp infixOpE
+ tests/BoundedEnumIxSpec.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif++{-|+Module: BoundedEnumSpec+Copyright: (C) 2015-2016 Ryan Scott+License: BSD-style (see the file LICENSE)+Maintainer: Ryan Scott+Portability: Template Haskell++@hspec@ tests for derived 'Bounded', 'Enum', and 'Ix' instances.+-}+module BoundedEnumIxSpec where++import Data.Deriving++import GHC.Arr (Ix(..))++import Prelude ()+import Prelude.Compat++import Test.Hspec++-------------------------------------------------------------------------------++-- Plain data types++data TyConEnum = TyConEnum1 | TyConEnum2 | TyConEnum3+ deriving (Eq, Ord, Show)++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+ deriving (Eq, Ord, Show)++data TyConExQuant a = Show a => TyConExQuant+deriving instance Eq (TyConExQuant a)+deriving instance Ord (TyConExQuant a)+deriving instance Show (TyConExQuant a)++data TyConGADT a where+ TyConGADT :: Show a => a -> TyConGADT a+deriving instance Eq a => Eq (TyConGADT a)+deriving instance Ord a => Ord (TyConGADT a)+deriving instance Show a => Show (TyConGADT a)++-- Data families++data family TyFamilyEnum :: *+data instance TyFamilyEnum = TyFamilyEnum1 | TyFamilyEnum2 | TyFamilyEnum3+ deriving (Eq, Ord, Show)++data family TyFamilyProduct x y z :: *+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 instance TyFamilyUnit f a = TyFamilyUnit+ deriving (Eq, Ord, Show)++data family TyFamilyExQuant x :: *+data instance TyFamilyExQuant a = Show a => TyFamilyExQuant+deriving instance Eq (TyFamilyExQuant a)+deriving instance Ord (TyFamilyExQuant a)+deriving instance Show (TyFamilyExQuant a)++data family TyFamilyGADT x :: *+data instance TyFamilyGADT a where+ TyFamilyGADT :: Show a => a -> TyFamilyGADT a+deriving instance Eq a => Eq (TyFamilyGADT a)+deriving instance Ord a => Ord (TyFamilyGADT a)+deriving instance Show a => Show (TyFamilyGADT a)++-------------------------------------------------------------------------------++-- Plain data types++$(deriveBounded ''TyConEnum)+$(deriveBounded ''TyConProduct)+instance Bounded (TyConUnit f a) where+ minBound = $(makeMinBound ''TyConUnit)+ maxBound = $(makeMaxBound ''TyConUnit)+instance Show a => Bounded (TyConExQuant a) where+ minBound = $(makeMinBound ''TyConExQuant)+ maxBound = $(makeMaxBound ''TyConExQuant)+instance (Bounded a, Show a) => Bounded (TyConGADT a) where+ minBound = $(makeMinBound ''TyConGADT)+ maxBound = $(makeMaxBound ''TyConGADT)++$(deriveEnum ''TyConEnum)+instance Enum (TyConUnit f a) where+ toEnum = $(makeToEnum ''TyConUnit)+ fromEnum = $(makeFromEnum ''TyConUnit)++$(deriveIx ''TyConEnum)+$(deriveIx ''TyConProduct)+instance Ix (TyConUnit f a) where+ range = $(makeRange ''TyConUnit)+ unsafeIndex = $(makeUnsafeIndex ''TyConUnit)+ inRange = $(makeInRange ''TyConUnit)+instance Ix (TyConExQuant a) where+ range = $(makeRange ''TyConExQuant)+ unsafeIndex = $(makeUnsafeIndex ''TyConExQuant)+ inRange = $(makeInRange ''TyConExQuant)+instance Ix a => Ix (TyConGADT a) where+ range = $(makeRange ''TyConGADT)+ unsafeIndex = $(makeUnsafeIndex ''TyConGADT)+ inRange = $(makeInRange ''TyConGADT)++#if MIN_VERSION_template_haskell(2,7,0)+-- Data families++$(deriveBounded 'TyFamilyEnum1)+$(deriveBounded 'TyFamilyProduct)+instance Bounded (TyFamilyUnit f a) where+ minBound = $(makeMinBound 'TyFamilyUnit)+ maxBound = $(makeMaxBound 'TyFamilyUnit)+instance Show a => Bounded (TyFamilyExQuant a) where+ minBound = $(makeMinBound 'TyFamilyExQuant)+ maxBound = $(makeMaxBound 'TyFamilyExQuant)+instance (Bounded a, Show a) => Bounded (TyFamilyGADT a) where+ minBound = $(makeMinBound 'TyFamilyGADT)+ maxBound = $(makeMaxBound 'TyFamilyGADT)++$(deriveEnum 'TyFamilyEnum1)+instance Enum (TyFamilyUnit f a) where+ toEnum = $(makeToEnum 'TyFamilyUnit)+ fromEnum = $(makeFromEnum 'TyFamilyUnit)++$(deriveIx 'TyFamilyEnum1)+$(deriveIx 'TyFamilyProduct)+instance Ix (TyFamilyUnit f a) where+ range = $(makeRange 'TyFamilyUnit)+ unsafeIndex = $(makeUnsafeIndex 'TyFamilyUnit)+ inRange = $(makeInRange 'TyFamilyUnit)+instance Ix (TyFamilyExQuant a) where+ range = $(makeRange 'TyFamilyExQuant)+ unsafeIndex = $(makeUnsafeIndex 'TyFamilyExQuant)+ inRange = $(makeInRange 'TyFamilyExQuant)+instance Ix a => Ix (TyFamilyGADT a) where+ range = $(makeRange 'TyFamilyGADT)+ unsafeIndex = $(makeUnsafeIndex 'TyFamilyGADT)+ inRange = $(makeInRange 'TyFamilyGADT)+#endif++-------------------------------------------------------------------------------++-- | Verifies an 'Ix' instance satisfies the laws.+ixLaws :: (Ix a, Show a) => a -> a -> a -> Expectation+ixLaws l u i = do+ inRange (l,u) i `shouldBe` elem i (range (l,u))+ range (l,u) !! index (l,u) i `shouldBe` i+ map (index (l,u)) (range (l,u)) `shouldBe` [0..rangeSize (l,u)-1]+ rangeSize (l,u) `shouldBe` length (range (l,u))++-------------------------------------------------------------------------------++main :: IO ()+main = hspec spec++spec :: Spec+spec = parallel $ do+ describe "TyConEnum" $ do+ it "has a sensible Bounded instance" $ do+ minBound `shouldBe` TyConEnum1+ maxBound `shouldBe` TyConEnum3++ it "has a sensible Enum instance" $+ [minBound .. maxBound] `shouldBe` [TyConEnum1, TyConEnum2, TyConEnum3]++ it "has a sensible Ix instance" $+ ixLaws minBound maxBound TyConEnum2+ describe "TyConProduct Bool Bool Bool" $ do+ it "has a sensible Bounded instance" $ do+ minBound `shouldBe` TyConProduct False False False+ maxBound `shouldBe` TyConProduct True True True++ it "has a sensible Ix instance" $+ ixLaws minBound maxBound (TyConProduct False False False)+ describe "TyConUnit Maybe Bool" $ do+ it "has a sensible Bounded instance" $ do+ minBound `shouldBe` TyConUnit+ maxBound `shouldBe` TyConUnit++ it "has a sensible Enum instance" $+ [minBound .. maxBound] `shouldBe` [TyConUnit]++ it "has a sensible Ix instance" $+ ixLaws minBound maxBound TyConUnit+ describe "TyConExQuant Bool" $ do+ it "has a sensible Bounded instance" $ do+ minBound `shouldBe` (TyConExQuant :: TyConExQuant Bool)+ maxBound `shouldBe` (TyConExQuant :: TyConExQuant Bool)++ it "has a sensible Ix instance" $+ ixLaws minBound maxBound (TyConExQuant :: TyConExQuant Bool)+ describe "TyConGADT Bool" $ do+ it "has a sensible Bounded instance" $ do+ minBound `shouldBe` TyConGADT False+ maxBound `shouldBe` TyConGADT True++ 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+ maxBound `shouldBe` TyFamilyEnum3++ it "has a sensible Enum instance" $+ [minBound .. maxBound] `shouldBe` [TyFamilyEnum1, TyFamilyEnum2, TyFamilyEnum3]++ it "has a sensible Ix instance" $+ ixLaws minBound maxBound TyFamilyEnum2+ describe "TyFamilyProduct Bool Bool Bool" $ do+ it "has a sensible Bounded instance" $ do+ minBound `shouldBe` TyFamilyProduct False False False+ maxBound `shouldBe` TyFamilyProduct True True True++ it "has a sensible Ix instance" $+ ixLaws minBound maxBound (TyFamilyProduct False False False)+ describe "TyFamilyUnit Maybe Bool" $ do+ it "has a sensible Bounded instance" $ do+ minBound `shouldBe` TyFamilyUnit+ maxBound `shouldBe` TyFamilyUnit++ it "has a sensible Enum instance" $+ [minBound .. maxBound] `shouldBe` [TyFamilyUnit]++ it "has a sensible Ix instance" $+ ixLaws minBound maxBound TyFamilyUnit+ describe "TyFamilyExQuant Bool" $ do+ it "has a sensible Bounded instance" $ do+ minBound `shouldBe` (TyFamilyExQuant :: TyFamilyExQuant Bool)+ maxBound `shouldBe` (TyFamilyExQuant :: TyFamilyExQuant Bool)++ it "has a sensible Ix instance" $+ ixLaws minBound maxBound (TyFamilyExQuant :: TyFamilyExQuant Bool)+ describe "TyFamilyGADT Bool" $ do+ it "has a sensible Bounded instance" $ do+ minBound `shouldBe` TyFamilyGADT False+ maxBound `shouldBe` TyFamilyGADT True++ it "has a sensible Ix instance" $+ ixLaws minBound maxBound (TyFamilyGADT False)+#endif
tests/FunctorSpec.hs view
@@ -309,7 +309,7 @@ main = hspec spec spec :: Spec-spec = do+spec = parallel $ do describe "OneTwoCompose Maybe ((,) Bool) [Int] [Int]" $ do prop "satisfies the Functor laws" (prop_FunctorEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool)