diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,4 +1,16 @@ -## Changes in next +## Changes in 0.3.0 + - `Show` instance for `Fingerprint` + - `Data.Orphans` is now `Trustworthy` + - Backported the `Generic` and `Generic1` instances available in `base-4.7.0.0` + to GHC 7.2, 7.4, and 7.6, namely + * `Const`, `WrappedMonad`, and `ZipList` from `Control.Applicative` + * `WrappedArrow` from `Control.Category` + * `All`, `Any`, `Dual`, `Endo`, `First`, `Last`, `Product`, and `Sum` from + `Data.Monoid` + * `U1`, `Par1`, `Rec1`, `K1`, `M1`, `(:+:)`, `(:*:)`, `(:.:)`, `Arity`, + `Associativity`, and `Fixity` from `GHC.Generics` + +## Changes in 0.2.0 - Drop GHC 6.12 (and `base-4.2.0.0`) compatibility - Fix Windows, GHCJS build - `Read` instance for `Fixed` diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -30,6 +30,7 @@ * `Functor` instance for `ArgOrder`, `OptDescr`, and `ArgDescr` * `Num` instance for `Sum` and `Product` * `Read` instance for `Fixed` + * `Show` instance for `Fingerprint` * `Storable` instance for `Complex` and `Ratio` * `Traversable` instance for `Either`, `(,)` and `Const` * `Typeable` instance for most data types and typeclasses (when possible) diff --git a/base-orphans.cabal b/base-orphans.cabal --- a/base-orphans.cabal +++ b/base-orphans.cabal @@ -1,7 +1,12 @@ +-- This file has been generated from package.yaml by hpack version 0.1.2. +-- +-- see: https://github.com/sol/hpack + name: base-orphans -version: 0.2.0 +version: 0.3.0 synopsis: Backwards-compatible orphan instances for base -homepage: https://github.com/haskell-compat/base-orphans +homepage: https://github.com/haskell-compat/base-orphans#readme +bug-reports: https://github.com/haskell-compat/base-orphans/issues license: MIT license-file: LICENSE author: Simon Hengel , @@ -16,44 +21,47 @@ category: Compatibility build-type: Simple cabal-version: >= 1.10 -extra-source-files: CHANGES.markdown, README.markdown -description: @base-orphans@ defines orphan instances that mimic instances - available in later versions of @base@ to a wider (older) - range of compilers. @base-orphans@ does not export - anything except the orphan instances themselves and - complements - @@. +description: @base-orphans@ defines orphan instances that mimic instances available in later versions of @base@ to a wider (older) range of compilers. @base-orphans@ does not export anything except the orphan instances themselves and complements @@. . - See the README for what instances are covered: - + See the README for what instances are covered: +extra-source-files: + CHANGES.markdown + README.markdown + source-repository head - type: git - location: https://github.com/haskell-compat/base-orphans + type: git + location: https://github.com/haskell-compat/base-orphans library - ghc-options: - -Wall + hs-source-dirs: src + exposed-modules: + Data.Orphans build-depends: base >= 4.3 && < 5 + , ghc-prim - hs-source-dirs: - src - exposed-modules: - Data.Orphans + ghc-options: -Wall default-language: Haskell2010 test-suite spec - type: - exitcode-stdio-1.0 - ghc-options: - -Wall - hs-source-dirs: - test - main-is: - Spec.hs + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + Control.Applicative.OrphansSpec + Control.Exception.OrphansSpec + Data.Bits.OrphansSpec + Data.Foldable.OrphansSpec + Data.Monoid.OrphansSpec + Data.Traversable.OrphansSpec + Data.Version.OrphansSpec + Foreign.Storable.OrphansSpec + GHC.Fingerprint.OrphansSpec build-depends: base >= 4.3 && < 5 + , base-orphans , hspec == 2.* + ghc-options: -Wall default-language: Haskell2010 diff --git a/src/Data/Orphans.hs b/src/Data/Orphans.hs --- a/src/Data/Orphans.hs +++ b/src/Data/Orphans.hs @@ -1,14 +1,16 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE DeriveGeneric #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 706 @@ -23,6 +25,11 @@ -} module Data.Orphans () where +#if MIN_VERSION_base(4,4,0) && !(MIN_VERSION_base(4,7,0)) +import Data.Word (Word64) +import Numeric (showHex) +#endif + #if !(MIN_VERSION_base(4,4,0)) import Control.Concurrent.SampleVar import Control.Monad.ST as Strict @@ -42,7 +49,7 @@ # endif #endif -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 +#if __GLASGOW_HASKELL__ >= 701 && __GLASGOW_HASKELL__ < 710 import GHC.Generics as Generics # endif @@ -126,6 +133,16 @@ ------------------------------------------------------------------------------- +#if MIN_VERSION_base(4,4,0) && !(MIN_VERSION_base(4,7,0)) +instance Show Fingerprint where + show (Fingerprint w1 w2) = hex16 w1 ++ hex16 w2 + where + -- Formats a 64 bit number as 16 digits hex. + hex16 :: Word64 -> String + hex16 i = let hex = showHex i "" + in replicate (16 - length hex) '0' ++ hex +#endif + #if !(MIN_VERSION_base(4,4,0)) instance HasResolution a => Read (Fixed a) where readsPrec _ = readsFixed @@ -213,6 +230,11 @@ #endif #if !(MIN_VERSION_base(4,7,0)) +deriving instance Foldable (Const m) +deriving instance Foldable (Either a) +deriving instance Traversable (Const m) +deriving instance Traversable (Either a) + instance Foldable ((,) a) where foldMap f (_, y) = f y @@ -221,27 +243,10 @@ instance Traversable ((,) a) where traverse f (x, y) = (,) x <$> f y -instance Foldable (Const m) where - foldMap _ _ = mempty - instance Monoid a => Monoid (Const a b) where mempty = Const mempty mappend (Const a) (Const b) = Const (mappend a b) -instance Traversable (Const m) where - traverse _ (Const m) = pure $ Const m - -instance Foldable (Either a) where - foldMap _ (Left _) = mempty - foldMap f (Right y) = f y - - foldr _ z (Left _) = z - foldr f z (Right y) = f y z - -instance Traversable (Either a) where - traverse _ (Left x) = pure (Left x) - traverse f (Right y) = Right <$> f y - deriving instance Eq ErrorCall deriving instance Ord ErrorCall deriving instance Num a => Num (Sum a) @@ -263,72 +268,818 @@ deriving instance Functor ArgDescr #endif -#if __GLASGOW_HASKELL__ >= 702 && !(MIN_VERSION_base(4,7,0)) +#if __GLASGOW_HASKELL__ >= 701 && !(MIN_VERSION_base(4,7,0)) +----- -- Although DeriveGeneric has been around since GHC 7.2, various bugs cause --- the standalone-derived code below to fail to compile unless a fairly --- recent version of GHC is used. -# if __GLASGOW_HASKELL__ >= 704 -deriving instance Generic All -deriving instance Generic Any -deriving instance Generic Arity -deriving instance Generic Associativity -deriving instance Generic Generics.Fixity +-- standalone Generic instances to fail to compile unless a fairly recent +-- version of GHC is used. For this reason, we manually implement all Generic +-- and Generic1 instances to maintain GHC 7.2 and 7.4 support. +----- -deriving instance Generic (U1 p) -# endif +instance Generic All where + type Rep All = D1 D1All (C1 C1_0All (S1 S1_0_0All (Rec0 Bool))) + from (All a) = M1 (M1 (M1 (K1 a))) + to (M1 (M1 (M1 (K1 a)))) = All a -# if __GLASGOW_HASKELL__ >= 706 -deriving instance Generic (Const a b) -deriving instance Generic (Dual a) -deriving instance Generic (Endo a) -deriving instance Generic (First a) -deriving instance Generic (Last a) -deriving instance Generic (Product a) -deriving instance Generic (Sum a) -deriving instance Generic (WrappedArrow a b c) -deriving instance Generic (WrappedMonad m a) -deriving instance Generic (ZipList a) +data D1All +data C1_0All +data S1_0_0All -deriving instance Generic1 (Const a) -deriving instance Generic1 Dual -deriving instance Generic1 First -deriving instance Generic1 Last -deriving instance Generic1 Product -deriving instance Generic1 Sum -deriving instance Generic1 (WrappedArrow a b) -deriving instance Generic1 (WrappedMonad m) -deriving instance Generic1 ZipList +instance Datatype D1All where + datatypeName _ = "All" + moduleName _ = "Data.Monoid" -deriving instance Generic (Par1 p) -deriving instance Generic (Rec1 f p) -deriving instance Generic (K1 i c p) -deriving instance Generic (M1 i c f p) -deriving instance Generic ((f :+: g) p) -deriving instance Generic ((f :.: g) p) +instance Constructor C1_0All where + conName _ = "All" + conIsRecord _ = True --- Due to a GHC bug (https://ghc.haskell.org/trac/ghc/ticket/9830), the derived --- Generic instances for infix data constructors will use the wrong --- precedence (prior to GHC 7.10). --- We'll manually derive a Generic :*: instance to avoid this. +instance Selector S1_0_0All where + selName _ = "getAll" + +----- + +instance Generic Any where + type Rep Any = D1 D1Any (C1 C1_0Any (S1 S1_0_0Any (Rec0 Bool))) + from (Any a) = M1 (M1 (M1 (K1 a))) + to (M1 (M1 (M1 (K1 a)))) = Any a + +data D1Any +data C1_0Any +data S1_0_0Any + +instance Datatype D1Any where + datatypeName _ = "Any" + moduleName _ = "Data.Monoid" + +instance Constructor C1_0Any where + conName _ = "Any" + conIsRecord _ = True + +instance Selector S1_0_0Any where + selName _ = "getAny" + +----- + +instance Generic Arity where + type Rep Arity = D1 D1Arity (C1 C1_0Arity U1 + :+: C1 C1_1Arity (S1 NoSelector (Rec0 Int))) + + from NoArity = M1 (L1 (M1 U1)) + from (Arity a) = M1 (R1 (M1 (M1 (K1 a)))) + + to (M1 (L1 (M1 U1))) = NoArity + to (M1 (R1 (M1 (M1 (K1 a))))) = Arity a + +data D1Arity +data C1_0Arity +data C1_1Arity + +instance Datatype D1Arity where + datatypeName _ = "Arity" + moduleName _ = "GHC.Generics" + +instance Constructor C1_0Arity where + conName _ = "NoArity" + +instance Constructor C1_1Arity where + conName _ = "Arity" + +----- + +instance Generic Associativity where + type Rep Associativity = D1 D1Associativity (C1 C1_0Associativity U1 + :+: (C1 C1_1Associativity U1 + :+: C1 C1_2Associativity U1)) + + from LeftAssociative = M1 (L1 (M1 U1)) + from RightAssociative = M1 (R1 (L1 (M1 U1))) + from NotAssociative = M1 (R1 (R1 (M1 U1))) + + to (M1 (L1 (M1 U1))) = LeftAssociative + to (M1 (R1 (L1 (M1 U1)))) = RightAssociative + to (M1 (R1 (R1 (M1 U1)))) = NotAssociative + +data D1Associativity +data C1_0Associativity +data C1_1Associativity +data C1_2Associativity + +instance Datatype D1Associativity where + datatypeName _ = "Associativity" + moduleName _ = "GHC.Generics" + +instance Constructor C1_0Associativity where + conName _ = "LeftAssociative" + +instance Constructor C1_1Associativity where + conName _ = "RightAssociative" + +instance Constructor C1_2Associativity where + conName _ = "NotAssociative" + +----- + +instance Generic (Const a b) where + type Rep (Const a b) = D1 D1Const (C1 C1_0Const (S1 S1_0_0Const (Rec0 a))) + from (Const a) = M1 (M1 (M1 (K1 a))) + to (M1 (M1 (M1 (K1 a)))) = Const a + +instance Generic1 (Const a) where + type Rep1 (Const a) = D1 D1Const (C1 C1_0Const (S1 S1_0_0Const (Rec0 a))) + from1 (Const a) = M1 (M1 (M1 (K1 a))) + to1 (M1 (M1 (M1 (K1 a)))) = Const a + +data D1Const +data C1_0Const +data S1_0_0Const + +instance Datatype D1Const where + datatypeName _ = "Const" + moduleName _ = "Control.Applicative" + +instance Constructor C1_0Const where + conName _ = "Const" + conIsRecord _ = True + +instance Selector S1_0_0Const where + selName _ = "getConst" + +----- + +instance Generic (Dual a) where + type Rep (Dual a) = D1 D1Dual (C1 C1_0Dual (S1 S1_0_0Dual (Rec0 a))) + from (Dual d) = M1 (M1 (M1 (K1 d))) + to (M1 (M1 (M1 (K1 d)))) = Dual d + +instance Generic1 Dual where + type Rep1 Dual = D1 D1Dual (C1 C1_0Dual (S1 S1_0_0Dual Par1)) + from1 (Dual d) = M1 (M1 (M1 (Par1 d))) + to1 (M1 (M1 (M1 (Par1 d)))) = Dual d + +data D1Dual +data C1_0Dual +data S1_0_0Dual + +instance Datatype D1Dual where + datatypeName _ = "Dual" + moduleName _ = "Data.Monoid" + +instance Constructor C1_0Dual where + conName _ = "Dual" + conIsRecord _ = True + +instance Selector S1_0_0Dual where + selName _ = "getDual" + +----- + +instance Generic (Endo a) where + type Rep (Endo a) = D1 D1Endo (C1 C1_0Endo (S1 S1_0_0Endo (Rec0 (a -> a)))) + from (Endo e) = M1 (M1 (M1 (K1 e))) + to (M1 (M1 (M1 (K1 e)))) = Endo e + +data D1Endo +data C1_0Endo +data S1_0_0Endo + +instance Datatype D1Endo where + datatypeName _ = "Endo" + moduleName _ = "Data.Monoid" + +instance Constructor C1_0Endo where + conName _ = "Endo" + conIsRecord _ = True + +instance Selector S1_0_0Endo where + selName _ = "appEndo" + +----- + +instance Generic (First a) where + type Rep (First a) = D1 D1First (C1 C1_0First (S1 S1_0_0First (Rec0 (Maybe a)))) + from (First f) = M1 (M1 (M1 (K1 f))) + to (M1 (M1 (M1 (K1 f)))) = First f + +instance Generic1 First where + type Rep1 First = D1 D1First (C1 C1_0First (S1 S1_0_0First (Rec1 Maybe))) + from1 (First f) = M1 (M1 (M1 (Rec1 f))) + to1 (M1 (M1 (M1 (Rec1 f)))) = First f + +data D1First +data C1_0First +data S1_0_0First + +instance Datatype D1First where + datatypeName _ = "First" + moduleName _ = "Data.Monoid" + +instance Constructor C1_0First where + conName _ = "First" + conIsRecord _ = True + +instance Selector S1_0_0First where + selName _ = "getFirst" + +----- + +instance Generic Generics.Fixity where + type Rep Generics.Fixity = D1 D1Fixity (C1 C1_0Fixity U1 + :+: C1 C1_1Fixity (S1 NoSelector (Rec0 Associativity) + :*: S1 NoSelector (Rec0 Int))) + + from Generics.Prefix = M1 (L1 (M1 U1)) + from (Generics.Infix a i) = M1 (R1 (M1 (M1 (K1 a) :*: M1 (K1 i)))) + + to (M1 (L1 (M1 U1))) = Generics.Prefix + to (M1 (R1 (M1 (M1 (K1 a) :*: M1 (K1 i))))) = Generics.Infix a i + +data D1Fixity +data C1_0Fixity +data C1_1Fixity + +instance Datatype D1Fixity where + datatypeName _ = "Fixity" + moduleName _ = "GHC.Generics" + +instance Constructor C1_0Fixity where + conName _ = "Prefix" + +instance Constructor C1_1Fixity where + conName _ = "Infix" + +----- + +instance Generic (Last a) where + type Rep (Last a) = D1 D1Last (C1 C1_0Last (S1 S1_0_0Last (Rec0 (Maybe a)))) + from (Last l) = M1 (M1 (M1 (K1 l))) + to (M1 (M1 (M1 (K1 l)))) = Last l + +instance Generic1 Last where + type Rep1 Last = D1 D1Last (C1 C1_0Last (S1 S1_0_0Last (Rec1 Maybe))) + from1 (Last l) = M1 (M1 (M1 (Rec1 l))) + to1 (M1 (M1 (M1 (Rec1 l)))) = Last l + +data D1Last +data C1_0Last +data S1_0_0Last + +instance Datatype D1Last where + datatypeName _ = "Last" + moduleName _ = "Data.Monoid" + +instance Constructor C1_0Last where + conName _ = "Last" + conIsRecord _ = True + +instance Selector S1_0_0Last where + selName _ = "getLast" + +----- + +instance Generic (Product a) where + type Rep (Product a) = D1 D1Product (C1 C1_0Product (S1 S1_0_0Product (Rec0 a))) + from (Product p) = M1 (M1 (M1 (K1 p))) + to (M1 (M1 (M1 (K1 p)))) = Product p + +instance Generic1 Product where + type Rep1 Product = D1 D1Product (C1 C1_0Product (S1 S1_0_0Product Par1)) + from1 (Product p) = M1 (M1 (M1 (Par1 p))) + to1 (M1 (M1 (M1 (Par1 p)))) = Product p + +data D1Product +data C1_0Product +data S1_0_0Product + +instance Datatype D1Product where + datatypeName _ = "Product" + moduleName _ = "Data.Monoid" + +instance Constructor C1_0Product where + conName _ = "Product" + conIsRecord _ = True + +instance Selector S1_0_0Product where + selName _ = "getProduct" + +----- + +instance Generic (Sum a) where + type Rep (Sum a) = D1 D1Sum (C1 C1_0Sum (S1 S1_0_0Sum (Rec0 a))) + from (Sum s) = M1 (M1 (M1 (K1 s))) + to (M1 (M1 (M1 (K1 s)))) = Sum s + +instance Generic1 Sum where + type Rep1 Sum = D1 D1Sum (C1 C1_0Sum (S1 S1_0_0Sum Par1)) + from1 (Sum s) = M1 (M1 (M1 (Par1 s))) + to1 (M1 (M1 (M1 (Par1 s)))) = Sum s + +data D1Sum +data C1_0Sum +data S1_0_0Sum + +instance Datatype D1Sum where + datatypeName _ = "Sum" + moduleName _ = "Data.Monoid" + +instance Constructor C1_0Sum where + conName _ = "Sum" + conIsRecord _ = True + +instance Selector S1_0_0Sum where + selName _ = "getSum" + +----- + +instance Generic (WrappedArrow a b c) where + type Rep (WrappedArrow a b c) + = D1 D1WrappedArrow (C1 C1_0WrappedArrow (S1 S1_0_0WrappedArrow (Rec0 (a b c)))) + from (WrapArrow a) = M1 (M1 (M1 (K1 a))) + to (M1 (M1 (M1 (K1 a)))) = WrapArrow a + +instance Generic1 (WrappedArrow a b) where + type Rep1 (WrappedArrow a b) + = D1 D1WrappedArrow (C1 C1_0WrappedArrow (S1 S1_0_0WrappedArrow (Rec1 (a b)))) + from1 (WrapArrow a) = M1 (M1 (M1 (Rec1 a))) + to1 (M1 (M1 (M1 (Rec1 a)))) = WrapArrow a + +data D1WrappedArrow +data C1_0WrappedArrow +data S1_0_0WrappedArrow + +instance Datatype D1WrappedArrow where + datatypeName _ = "WrappedArrow" + moduleName _ = "Control.Applicative" + +instance Constructor C1_0WrappedArrow where + conName _ = "WrapArrow" + conIsRecord _ = True + +instance Selector S1_0_0WrappedArrow where + selName _ = "unwrapArrow" + +----- + +instance Generic (WrappedMonad m a) where + type Rep (WrappedMonad m a) + = D1 D1WrappedMonad (C1 C1_0WrappedMonad (S1 S1_0_0WrappedMonad (Rec0 (m a)))) + from (WrapMonad m) = M1 (M1 (M1 (K1 m))) + to (M1 (M1 (M1 (K1 m)))) = WrapMonad m + +instance Generic1 (WrappedMonad m) where + type Rep1 (WrappedMonad m) + = D1 D1WrappedMonad (C1 C1_0WrappedMonad (S1 S1_0_0WrappedMonad (Rec1 m))) + from1 (WrapMonad m) = M1 (M1 (M1 (Rec1 m))) + to1 (M1 (M1 (M1 (Rec1 m)))) = WrapMonad m + +data D1WrappedMonad +data C1_0WrappedMonad +data S1_0_0WrappedMonad + +instance Datatype D1WrappedMonad where + datatypeName _ = "WrappedMonad" + moduleName _ = "Control.Applicative" + +instance Constructor C1_0WrappedMonad where + conName _ = "WrapMonad" + conIsRecord _ = True + +instance Selector S1_0_0WrappedMonad where + selName _ = "unwrapMonad" + +----- + +instance Generic (ZipList a) where + type Rep (ZipList a) = D1 D1ZipList (C1 C1_0ZipList (S1 S1_0_0ZipList (Rec0 [a]))) + from (ZipList z) = M1 (M1 (M1 (K1 z))) + to (M1 (M1 (M1 (K1 z)))) = ZipList z + +instance Generic1 ZipList where + type Rep1 ZipList = D1 D1ZipList (C1 C1_0ZipList (S1 S1_0_0ZipList (Rec1 []))) + from1 (ZipList z) = M1 (M1 (M1 (Rec1 z))) + to1 (M1 (M1 (M1 (Rec1 z)))) = ZipList z + +data D1ZipList +data C1_0ZipList +data S1_0_0ZipList + +instance Datatype D1ZipList where + datatypeName _ = "ZipList" + moduleName _ = "Control.Applicative" + +instance Constructor C1_0ZipList where + conName _ = "ZipList" + conIsRecord _ = True + +instance Selector S1_0_0ZipList where + selName _ = "getZipList" + +----- + +instance Generic (U1 p) where + type Rep (U1 p) = D1 D1U1 (C1 C1_0U1 U1) + from U1 = M1 (M1 U1) + to (M1 (M1 U1)) = U1 + +data D1U1 +data C1_0U1 + +instance Datatype D1U1 where + datatypeName _ = "U1" + moduleName _ = "GHC.Generics" + +instance Constructor C1_0U1 where + conName _ = "U1" + +----- + +instance Generic (Par1 p) where + type Rep (Par1 p) = D1 D1Par1 (C1 C1_0Par1 (S1 S1_0_0Par1 (Rec0 p))) + from (Par1 p) = M1 (M1 (M1 (K1 p))) + to (M1 (M1 (M1 (K1 p)))) = Par1 p + +data D1Par1 +data C1_0Par1 +data S1_0_0Par1 + +instance Datatype D1Par1 where + datatypeName _ = "Par1" + moduleName _ = "GHC.Generics" + +instance Constructor C1_0Par1 where + conName _ = "Par1" + conIsRecord _ = True + +instance Selector S1_0_0Par1 where + selName _ = "unPar1" + +----- + +instance Generic (Rec1 f p) where + type Rep (Rec1 f p) + = D1 D1Rec1 (C1 C1_0Rec1 (S1 S1_0_0Rec1 (Rec0 (f p)))) + from (Rec1 r) = M1 (M1 (M1 (K1 r))) + to (M1 (M1 (M1 (K1 r)))) = Rec1 r + +data D1Rec1 +data C1_0Rec1 +data S1_0_0Rec1 + +instance Datatype D1Rec1 where + datatypeName _ = "Rec1" + moduleName _ = "GHC.Generics" + +instance Constructor C1_0Rec1 where + conName _ = "Rec1" + conIsRecord _ = True + +instance Selector S1_0_0Rec1 where + selName _ = "unRec1" + +----- + +instance Generic (K1 i c p) where + type Rep (K1 i c p) = D1 D1K1 (C1 C1_0K1 (S1 S1_0_0K1 (Rec0 c))) + from (K1 c) = M1 (M1 (M1 (K1 c))) + to (M1 (M1 (M1 (K1 c)))) = K1 c + +data D1K1 +data C1_0K1 +data S1_0_0K1 + +instance Datatype D1K1 where + datatypeName _ = "K1" + moduleName _ = "GHC.Generics" + +instance Constructor C1_0K1 where + conName _ = "K1" + conIsRecord _ = True + +instance Selector S1_0_0K1 where + selName _ = "unK1" + +----- + +instance Generic (M1 i c f p) where + type Rep (M1 i c f p) = D1 D1M1 (C1 C1_0M1 (S1 S1_0_0M1 (Rec0 (f p)))) + from (M1 m) = M1 (M1 (M1 (K1 m))) + to (M1 (M1 (M1 (K1 m)))) = M1 m + +data D1M1 +data C1_0M1 +data S1_0_0M1 + +instance Datatype D1M1 where + datatypeName _ = "M1" + moduleName _ = "GHC.Generics" + +instance Constructor C1_0M1 where + conName _ = "M1" + conIsRecord _ = True + +instance Selector S1_0_0M1 where + selName _ = "unM1" + +----- + +instance Generic ((f :+: g) p) where + type Rep ((f :+: g) p) = D1 D1ConSum (C1 C1_0ConSum (S1 NoSelector (Rec0 (f p))) + :+: C1 C1_1ConSum (S1 NoSelector (Rec0 (g p)))) + + from (L1 l) = M1 (L1 (M1 (M1 (K1 l)))) + from (R1 r) = M1 (R1 (M1 (M1 (K1 r)))) + + to (M1 (L1 (M1 (M1 (K1 l))))) = L1 l + to (M1 (R1 (M1 (M1 (K1 r))))) = R1 r + +data D1ConSum +data C1_0ConSum +data C1_1ConSum + +instance Datatype D1ConSum where + datatypeName _ = ":+:" + moduleName _ = "GHC.Generics" + +instance Constructor C1_0ConSum where + conName _ = "L1" + +instance Constructor C1_1ConSum where + conName _ = "R1" + +----- + instance Generic ((f :*: g) p) where type Rep ((f :*: g) p) = - D1 D_Product (C1 C_Product (S1 NoSelector (Rec0 (f p)) - :*: S1 NoSelector (Rec0 (g p)))) + D1 D1ConProduct (C1 C1_ConProduct (S1 NoSelector (Rec0 (f p)) + :*: S1 NoSelector (Rec0 (g p)))) from (f :*: g) = M1 (M1 (M1 (K1 f) :*: M1 (K1 g))) to (M1 (M1 (M1 (K1 f) :*: M1 (K1 g)))) = f :*: g -data D_Product -data C_Product +data D1ConProduct +data C1_ConProduct -instance Datatype D_Product where +instance Datatype D1ConProduct where datatypeName _ = ":*:" moduleName _ = "GHC.Generics" -instance Constructor C_Product where - conName _ = ":*:" +instance Constructor C1_ConProduct where + conName _ = ":*:" conFixity _ = Generics.Infix RightAssociative 6 + +----- + +instance Generic ((f :.: g) p) where + type Rep ((f :.: g) p) + = D1 D1ConCompose (C1 C1_0ConCompose (S1 S1_0_0ConCompose (Rec0 (f (g p))))) + from (Comp1 c) = M1 (M1 (M1 (K1 c))) + to (M1 (M1 (M1 (K1 c)))) = Comp1 c + +data D1ConCompose +data C1_0ConCompose +data S1_0_0ConCompose + +instance Datatype D1ConCompose where + datatypeName _ = ":.:" + moduleName _ = "GHC.Generics" + +instance Constructor C1_0ConCompose where + conName _ = "Comp1" + conIsRecord _ = True + +instance Selector S1_0_0ConCompose where + selName _ = "unComp1" + +----- + +# if !(MIN_VERSION_base(4,6,0)) +instance Generic1 [] where + type Rep1 [] = D1 D1List (C1 C1_0List U1 :+: + C1 C1_1List (S1 NoSelector Par1 + :*: S1 NoSelector (Rec1 []))) + + from1 [] = M1 (L1 (M1 U1)) + from1 (h:t) = M1 (R1 (M1 (M1 (Par1 h) :*: M1 (Rec1 t)))) + + to1 (M1 (L1 (M1 U1))) = [] + to1 (M1 (R1 (M1 (M1 (Par1 h) :*: M1 (Rec1 t))))) = h : t + +data D1List +data C1_0List +data C1_1List + +instance Datatype D1List where + datatypeName _ = "[]" + moduleName _ = "GHC.Types" + +instance Constructor C1_0List where + conName _ = "[]" + +instance Constructor C1_1List where + conName _ = ":" + conFixity _ = Generics.Infix RightAssociative 5 + +----- + +instance Generic1 (Either a) where + type Rep1 (Either a) = D1 D1Either (C1 C1_0Either (S1 NoSelector (Rec0 a)) + :+: C1 C1_1Either (S1 NoSelector Par1)) + + from1 (Left l) = M1 (L1 (M1 (M1 (K1 l)))) + from1 (Right r) = M1 (R1 (M1 (M1 (Par1 r)))) + + to1 (M1 (L1 (M1 (M1 (K1 l))))) = Left l + to1 (M1 (R1 (M1 (M1 (Par1 r))))) = Right r + +data D1Either +data C1_0Either +data C1_1Either + +instance Datatype D1Either where + datatypeName _ = "Either" + moduleName _ = "Data.Either" + +instance Constructor C1_0Either where + conName _ = "Left" + +instance Constructor C1_1Either where + conName _ = "Right" + +----- + +instance Generic1 Maybe where + type Rep1 Maybe = D1 D1Maybe (C1 C1_0Maybe U1 + :+: C1 C1_1Maybe (S1 NoSelector Par1)) + + from1 Nothing = M1 (L1 (M1 U1)) + from1 (Just j) = M1 (R1 (M1 (M1 (Par1 j)))) + + to1 (M1 (L1 (M1 U1))) = Nothing + to1 (M1 (R1 (M1 (M1 (Par1 j))))) = Just j + +data D1Maybe +data C1_0Maybe +data C1_1Maybe + +instance Datatype D1Maybe where + datatypeName _ = "Maybe" + -- As of base-4.7.0.0, Maybe is actually located in GHC.Base. + -- We don't need to worry about this for the versions of base + -- that this instance is defined for, however. + moduleName _ = "Data.Maybe" + +instance Constructor C1_0Maybe where + conName _ = "Nothing" + +instance Constructor C1_1Maybe where + conName _ = "Just" + +----- + +instance Generic1 ((,) a) where + type Rep1 ((,) a) = D1 D1Tuple2 (C1 C1_0Tuple2 (S1 NoSelector (Rec0 a) + :*: S1 NoSelector Par1)) + from1 (a, b) = M1 (M1 (M1 (K1 a) :*: M1 (Par1 b))) + to1 (M1 (M1 (M1 (K1 a) :*: M1 (Par1 b)))) = (a, b) + +data D1Tuple2 +data C1_0Tuple2 + +instance Datatype D1Tuple2 where + datatypeName _ = "(,)" + moduleName _ = "GHC.Tuple" + +instance Constructor C1_0Tuple2 where + conName _ = "(,)" + +----- + +instance Generic1 ((,,) a b) where + type Rep1 ((,,) a b) = D1 D1Tuple3 (C1 C1_0Tuple3 (S1 NoSelector (Rec0 a) + :*: (S1 NoSelector (Rec0 b) + :*: S1 NoSelector Par1))) + from1 (a, b, c) = M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (Par1 c)))) + to1 (M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (Par1 c))))) = (a, b, c) + +data D1Tuple3 +data C1_0Tuple3 + +instance Datatype D1Tuple3 where + datatypeName _ = "(,,)" + moduleName _ = "GHC.Tuple" + +instance Constructor C1_0Tuple3 where + conName _ = "(,,)" + +----- + +instance Generic1 ((,,,) a b c) where + type Rep1 ((,,,) a b c) = D1 D1Tuple4 (C1 C1_0Tuple4 ((S1 NoSelector (Rec0 a) + :*: S1 NoSelector (Rec0 b)) + :*: (S1 NoSelector (Rec0 c) + :*: S1 NoSelector Par1))) + + from1 (a, b, c, d) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) + :*: (M1 (K1 c) :*: M1 (Par1 d)))) + + to1 (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) + :*: (M1 (K1 c) :*: M1 (Par1 d))))) + = (a, b, c, d) + +data D1Tuple4 +data C1_0Tuple4 + +instance Datatype D1Tuple4 where + datatypeName _ = "(,,,)" + moduleName _ = "GHC.Tuple" + +instance Constructor C1_0Tuple4 where + conName _ = "(,,,)" + +----- + +instance Generic1 ((,,,,) a b c d) where + type Rep1 ((,,,,) a b c d) = D1 D1Tuple5 (C1 C1_0Tuple5 ((S1 NoSelector (Rec0 a) + :*: S1 NoSelector (Rec0 b)) + :*: (S1 NoSelector (Rec0 c) + :*: (S1 NoSelector (Rec0 d) + :*: S1 NoSelector Par1)))) + + from1 (a, b, c, d, e) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) + :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (Par1 e))))) + + to1 (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) + :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (Par1 e)))))) + = (a, b, c, d, e) + +data D1Tuple5 +data C1_0Tuple5 + +instance Datatype D1Tuple5 where + datatypeName _ = "(,,,,)" + moduleName _ = "GHC.Tuple" + +instance Constructor C1_0Tuple5 where + conName _ = "(,,,,)" + +----- + +instance Generic1 ((,,,,,) a b c d e) where + type Rep1 ((,,,,,) a b c d e) + = D1 D1Tuple6 (C1 C1_0Tuple6 ((S1 NoSelector (Rec0 a) + :*: (S1 NoSelector (Rec0 b) + :*: S1 NoSelector (Rec0 c))) + :*: (S1 NoSelector (Rec0 d) + :*: (S1 NoSelector (Rec0 e) + :*: S1 NoSelector Par1)))) + + from1 (a, b, c, d, e, f) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) + :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (Par1 f))))) + + to1 (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) + :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (Par1 f)))))) + = (a, b, c, d, e, f) + +data D1Tuple6 +data C1_0Tuple6 + +instance Datatype D1Tuple6 where + datatypeName _ = "(,,,,,)" + moduleName _ = "GHC.Tuple" + +instance Constructor C1_0Tuple6 where + conName _ = "(,,,,,)" + +----- + +instance Generic1 ((,,,,,,) a b c d e f) where + type Rep1 ((,,,,,,) a b c d e f) + = D1 D1Tuple7 (C1 C1_0Tuple7 ((S1 NoSelector (Rec0 a) + :*: (S1 NoSelector (Rec0 b) + :*: S1 NoSelector (Rec0 c))) + :*: ((S1 NoSelector (Rec0 d) + :*: S1 NoSelector (Rec0 e)) + :*: (S1 NoSelector (Rec0 f) + :*: S1 NoSelector Par1)))) + + from1 (a, b, c, d, e, f, g) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) + :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (Par1 g))))) + + to1 (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) + :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (Par1 g)))))) + = (a, b, c, d, e, f, g) + +data D1Tuple7 +data C1_0Tuple7 + +instance Datatype D1Tuple7 where + datatypeName _ = "(,,,,,,)" + moduleName _ = "GHC.Tuple" + +instance Constructor C1_0Tuple7 where + conName _ = "(,,,,,,)" # endif +----- + deriving instance Eq (U1 p) deriving instance Ord (U1 p) deriving instance Read (U1 p) @@ -513,7 +1264,7 @@ # endif # endif -# if __GLASGOW_HASKELL__ >= 702 +# if __GLASGOW_HASKELL__ >= 701 deriving instance Typeable Arity deriving instance Typeable Associativity deriving instance Typeable C diff --git a/test/Control/Applicative/OrphansSpec.hs b/test/Control/Applicative/OrphansSpec.hs new file mode 100644 --- /dev/null +++ b/test/Control/Applicative/OrphansSpec.hs @@ -0,0 +1,40 @@ +module Control.Applicative.OrphansSpec (main, spec) where + +import Test.Hspec +import Control.Applicative +import Data.Orphans () +import Data.Monoid +import Prelude + +-- simplest one to use +newtype Identity a = Identity { runIdentity :: a } + +instance Functor Identity where + fmap f = Identity . f . runIdentity + +instance Applicative Identity where + pure = Identity + Identity f <*> x = f <$> x + +instance Monad Identity where + return = Identity + m >>= k = k (runIdentity m) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Monoid (Const a b)" $ do + it "mempty returns an empty const" $ + getConst (mempty :: (Const String Int)) `shouldBe` "" + it "mappends const part" $ + getConst ((Const "aaa" :: Const String Int) `mappend` (Const "bbb" :: Const String Int)) + `shouldBe` "aaabbb" + + describe "Monad (WrappedMonad m)" $ + it "allows to use a Monad interface in a WrappedMonad" $ + (runIdentity . unwrapMonad + $ (WrapMonad (return 1 :: Identity Int)) + >> (WrapMonad (return 2 :: Identity Int))) + `shouldBe` (2::Int) diff --git a/test/Control/Exception/OrphansSpec.hs b/test/Control/Exception/OrphansSpec.hs new file mode 100644 --- /dev/null +++ b/test/Control/Exception/OrphansSpec.hs @@ -0,0 +1,17 @@ +module Control.Exception.OrphansSpec (main, spec) where + +import Test.Hspec +import Control.Exception +import Data.Orphans () + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "ErrorCall" $ do + it "has an Eq instance" $ do + ErrorCall "foo" `shouldBe` ErrorCall "foo" + + it "has an Ord instance" $ do + ErrorCall "foo" `shouldSatisfy` (> ErrorCall "bar") diff --git a/test/Data/Bits/OrphansSpec.hs b/test/Data/Bits/OrphansSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Bits/OrphansSpec.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} +module Data.Bits.OrphansSpec (main, spec) where + +import Test.Hspec + +#if MIN_VERSION_base(4,6,0) +import Data.Bits +import Data.Orphans () +#endif + +main :: IO () +main = hspec spec + +spec :: Spec +spec = +#if MIN_VERSION_base(4,6,0) + describe "Bits Bool instance" $ + it "allows bitwise operations on Bools" $ do + True .&. True `shouldBe` True + True .&. False `shouldBe` False + False .&. True `shouldBe` False + False .&. False `shouldBe` False +#else + return () +#endif diff --git a/test/Data/Foldable/OrphansSpec.hs b/test/Data/Foldable/OrphansSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Foldable/OrphansSpec.hs @@ -0,0 +1,38 @@ +module Data.Foldable.OrphansSpec (main, spec) where + +import Test.Hspec + +import Control.Applicative +import Data.Foldable as F +import Data.Monoid +import Data.Orphans () +import Prelude + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Either Foldable Instance" $ do + it "foldMap returns mempty for a Left value" $ + foldMap (`mappend` "+") (Left "abc" :: Either String String) `shouldBe` mempty + it "foldMap returns the result of the function on the Right value" $ + foldMap (`mappend` "+") (Right "abc" :: Either String String) `shouldBe` "abc+" + + it "foldr returns the accumulator for a Left value" $ + F.foldr mappend "+" (Left "abc" :: Either String String) `shouldBe` "+" + it "foldr returns the result of the function on the Right value and accumulator" $ + F.foldr mappend "+" (Right "abc" :: Either String String) `shouldBe` "abc+" + + describe "(,) Foldable Instance" $ do + it "foldMap returns the result of the function applied to the second element" $ + foldMap (`mappend` "+") ("xyz","abc") `shouldBe` "abc+" + + it "foldr returns the result of the function on the second element of the tuple and accumulator" $ + F.foldr mappend "+" ("xyz","abc") `shouldBe` "abc+" + + describe "Const m Foldable Instance" $ do + it "foldMap always returns mempty" $ + foldMap (`mappend` "+") (Const "abc") `shouldBe` "" + it "foldr applies the function to the accumulator and mempty" $ do + F.foldr mappend "+" (Const "abc") `shouldBe` "+" diff --git a/test/Data/Monoid/OrphansSpec.hs b/test/Data/Monoid/OrphansSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Monoid/OrphansSpec.hs @@ -0,0 +1,17 @@ +module Data.Monoid.OrphansSpec (main, spec) where + +import Test.Hspec +import Data.Monoid +import Data.Orphans () + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Num (Sum a) instance" $ + it "allows a Sum value to be created from a number" $ + 1 `shouldBe` Sum (1 :: Int) + describe "Num (Product a) instance" $ + it "allows a Product value to be created from a number" $ + 1 `shouldBe` Product (1 :: Int) diff --git a/test/Data/Traversable/OrphansSpec.hs b/test/Data/Traversable/OrphansSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Traversable/OrphansSpec.hs @@ -0,0 +1,27 @@ +module Data.Traversable.OrphansSpec (main, spec) where + +import Test.Hspec + +import Control.Applicative +import Data.Orphans () +import Data.Traversable +import Prelude + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Either Traversable Instance" $ do + it "traverses a Left value" $ + traverse (:[]) (Left 5 :: Either Int String) `shouldBe` [Left 5] + it "traverses a Right Value" $ + traverse (:[]) (Right "aaa" :: Either Int String) `shouldBe` [Right "aaa"] + + describe "(,) a Traversable Instance" $ do + it "traverses a (,) a value" $ + traverse (:[]) (5::Int,"aaa") `shouldBe` [(5,"aaa")] + + describe "Const m Traversable Instance" $ do + it "traverses a Const a value" $ do + fmap getConst (traverse (:[]) (Const 5 :: Const Int String)) `shouldBe` [5] diff --git a/test/Data/Version/OrphansSpec.hs b/test/Data/Version/OrphansSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Version/OrphansSpec.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP #-} +#if MIN_VERSION_base(4,7,0) +{-# LANGUAGE OverloadedLists #-} +#endif +module Data.Version.OrphansSpec (main, spec) where + +import Test.Hspec + +import Data.Data +import Data.Orphans () +import Data.Version + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Data Version instance" $ + it "allows obtaining a Version constructor" $ + dataTypeName (dataTypeOf (Version [1,2,3] [])) `shouldBe` "Data.Version.Version" + +#if MIN_VERSION_base(4,7,0) + describe "IsList Version instance" $ + it "creates a Version from an Int list" $ + [1,2,3] `shouldBe` Version [1,2,3] [] +#endif diff --git a/test/Foreign/Storable/OrphansSpec.hs b/test/Foreign/Storable/OrphansSpec.hs new file mode 100644 --- /dev/null +++ b/test/Foreign/Storable/OrphansSpec.hs @@ -0,0 +1,24 @@ +module Foreign.Storable.OrphansSpec (main, spec) where + +import Test.Hspec +import Data.Complex +import Data.Orphans () +import Data.Ratio +import Foreign.Storable + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Storable Complex instance" $ do + it "has twice the sizeOf its realPart" $ do + sizeOf ((1 :: Double) :+ 2) `shouldBe` 2*sizeOf (1 :: Double) + it "has the alignment of its realPart" $ do + alignment ((1 :: Double) :+ 2) `shouldBe` alignment (1 :: Double) + + describe "Storable Ratio instance" $ do + it "has twice the sizeOf its parameterized type" $ do + sizeOf ((1 :: Int) % 2) `shouldBe` 2*sizeOf (1 :: Int) + it "has the alignment of its parameterized type" $ do + alignment ((1 :: Int) % 2) `shouldBe` alignment (1 :: Int) diff --git a/test/GHC/Fingerprint/OrphansSpec.hs b/test/GHC/Fingerprint/OrphansSpec.hs new file mode 100644 --- /dev/null +++ b/test/GHC/Fingerprint/OrphansSpec.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE CPP #-} +module GHC.Fingerprint.OrphansSpec (main, spec) where + +import Test.Hspec + +#if MIN_VERSION_base(4,4,0) +import Data.Orphans () +import Data.Word (Word64) +import GHC.Fingerprint.Type +#endif + +main :: IO () +main = hspec spec + +spec :: Spec +spec = +#if MIN_VERSION_base(4,4,0) + describe "Fingerprint" $ + it "has a Show instance" $ do + let w1, w2 :: Word64 + w1 = 0x0123456789abcdef + w2 = 0x42 + + f :: Fingerprint + f = Fingerprint w1 w2 + show f `shouldBe` "0123456789abcdef0000000000000042" +#else + return () +#endif