deriving-compat 0.2.2 → 0.3

raw patch · 21 files changed

+3505/−252 lines, 21 filesdep ~deriving-compatPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: deriving-compat

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−1
• README.md +1/−0
• deriving-compat.cabal +19/−4
• src/Data/Deriving.hs +3/−0
• src/Data/Deriving/Internal.hs +658/−6
• src/Data/Eq/Deriving.hs +51/−0
• src/Data/Eq/Deriving/Internal.hs +352/−0
• src/Data/Functor/Deriving/Internal.hs +4/−0
• src/Data/Ord/Deriving.hs +56/−0
• src/Data/Ord/Deriving/Internal.hs +690/−0
• src/Text/Read/Deriving.hs +94/−0
• src/Text/Read/Deriving/Internal.hs +911/−0
• src/Text/Show/Deriving.hs +4/−4
• src/Text/Show/Deriving/Internal.hs +85/−131
• tests/EqSpec.hs +25/−0
• tests/FunctorSpec.hs +18/−8
• tests/OrdSpec.hs +26/−0
• tests/ReadSpec.hs +72/−0
• tests/ShowSpec.hs +2/−98
• tests/Types/EqOrd.hs +236/−0
• tests/Types/ReadShow.hs +191/−0

@@ -1,4 +1,10 @@-## 0.2.2+## 0.3+* Added `Data.Eq.Deriving`, which allows deriving `Eq`, `Eq1`, and `Eq2` with TH.+* Added `Data.Ord.Deriving`, which allows deriving `Ord`, `Ord1`, and `Ord2` with TH.+* Added `Data.Read.Deriving`, which allows deriving `Read`, `Read1`, and `Eq2` with TH.+* Renamed `Text.Show.Deriving.Options` to `ShowOptions` so as to disambiguate it from the options datatypes in other `deriving-compat` modules.++### 0.2.2 * Fixed a bug in `Text.Show.Deriving`'s treatment of unlifted types  ### 0.2.1

@@ -26,6 +26,7 @@ * 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`.  Note that some recent GHC extensions are not covered by this package: 

@@ -1,5 +1,5 @@ name:                deriving-compat-version:             0.2.2+version:             0.3 synopsis:            Backports of GHC deriving extensions description:         Provides Template Haskell functions that mimic deriving                      extensions that were introduced or modified in recent versions@@ -27,6 +27,9 @@                        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@.+                     .                      Note that some recent GHC extensions are not covered by this package:                      .                      * @DeriveGeneric@, which was introducted in GHC 7.2 for deriving@@ -81,12 +84,18 @@ library   exposed-modules:     Data.Deriving +                       Data.Eq.Deriving                        Data.Foldable.Deriving                        Data.Functor.Deriving+                       Data.Ord.Deriving                        Data.Traversable.Deriving+                       Text.Read.Deriving                        Text.Show.Deriving-  other-modules:       Data.Deriving.Internal+  other-modules:       Data.Eq.Deriving.Internal+                       Data.Deriving.Internal                        Data.Functor.Deriving.Internal+                       Data.Ord.Deriving.Internal+                       Text.Read.Deriving.Internal                        Text.Show.Deriving.Internal                        Paths_deriving_compat   build-depends:       containers          >= 0.1 && < 0.6@@ -118,11 +127,17 @@ test-suite spec   type:                exitcode-stdio-1.0   main-is:             Spec.hs-  other-modules:       FunctorSpec+  other-modules:       EqSpec+                       FunctorSpec+                       OrdSpec+                       ReadSpec                        ShowSpec++                       Types.EqOrd+                       Types.ReadShow   build-depends:       base-compat         >= 0.8.1 && < 1                      , base-orphans        >= 0.5   && < 1-                     , deriving-compat     == 0.2.2+                     , deriving-compat     == 0.3                      , hspec               >= 1.8                      , QuickCheck          >= 2     && < 3 

@@ -19,9 +19,12 @@       module Exports     ) where +import Data.Eq.Deriving          as Exports import Data.Foldable.Deriving    as Exports import Data.Functor.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  {- $derive

@@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE MagicHash #-}  #if !(MIN_VERSION_base(4,9,0)) # if __GLASGOW_HASKELL__ >= 800@@ -25,10 +26,9 @@  import           Data.Foldable (foldr') #if !(MIN_VERSION_base(4,9,0))+import           Data.Functor.Classes (Eq1(..), Ord1(..), Read1(..), Show1(..)) # if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0)-import           Data.Functor.Classes (Show1(..), Show2(..))-# else-import           Data.Functor.Classes (Show1(..))+import           Data.Functor.Classes (Eq2(..), Ord2(..), Read2(..), Show2(..)) # endif #endif import           Data.List@@ -38,6 +38,19 @@ import qualified Data.Set as Set import           Data.Set (Set) +import           Text.ParserCombinators.ReadPrec (ReadPrec)++#if !(MIN_VERSION_base(4,7,0))+import           GHC.Read (lexP)++import           Text.Read (pfail)+import           Text.Read.Lex (Lexeme)+#endif++#if MIN_VERSION_ghc_prim(0,3,1)+import           GHC.Prim (Int#, tagToEnum#)+#endif+ import           Language.Haskell.TH.Lib import           Language.Haskell.TH.Ppr (pprint) import           Language.Haskell.TH.Syntax@@ -142,6 +155,89 @@ traverseConst x _ _ = x {-# INLINE traverseConst #-} +eqConst :: Bool+        -> a -> a -> Bool+eqConst x _ _ = x+{-# INLINE eqConst #-}++eq1Const :: Bool+         -> f a -> f a-> Bool+eq1Const x _ _ = x+{-# INLINE eq1Const #-}++liftEqConst :: Bool+            -> (a -> b -> Bool) -> f a -> f b -> Bool+liftEqConst x _ _ _ = x+{-# INLINE liftEqConst #-}++liftEq2Const :: Bool+             -> (a -> b -> Bool) -> (c -> d -> Bool)+             -> f a c -> f b d -> Bool+liftEq2Const x _ _ _ _ = x+{-# INLINE liftEq2Const #-}++compareConst :: Ordering -> a -> a -> Ordering+compareConst x _ _ = x+{-# INLINE compareConst #-}++ltConst :: Bool -> a -> a -> Bool+ltConst x _ _ = x+{-# INLINE ltConst #-}++compare1Const :: Ordering -> f a -> f a -> Ordering+compare1Const x _ _ = x+{-# INLINE compare1Const #-}++liftCompareConst :: Ordering+                 -> (a -> b -> Ordering) -> f a -> f b -> Ordering+liftCompareConst x _ _ _ = x+{-# INLINE liftCompareConst #-}++liftCompare2Const :: Ordering+                  -> (a -> b -> Ordering) -> (c -> d -> Ordering)+                  -> f a c -> f b d -> Ordering+liftCompare2Const x _ _ _ _ = x+{-# INLINE liftCompare2Const #-}++readsPrecConst :: ReadS a -> Int -> ReadS a+readsPrecConst x _ = x+{-# INLINE readsPrecConst #-}++-- This isn't really necessary, but it makes for an easier implementation+readPrecConst :: ReadPrec a -> ReadPrec a+readPrecConst x = x+{-# INLINE readPrecConst #-}++readsPrec1Const :: ReadS (f a) -> Int -> ReadS (f a)+readsPrec1Const x _ = x+{-# INLINE readsPrec1Const #-}++liftReadsPrecConst :: ReadS (f a)+                   -> (Int -> ReadS a) -> ReadS [a]+                   -> Int -> ReadS (f a)+liftReadsPrecConst x _ _ _ = x+{-# INLINE liftReadsPrecConst #-}++liftReadPrecConst :: ReadPrec (f a)+                  -> ReadPrec a -> ReadPrec [a]+                  -> ReadPrec (f a)+liftReadPrecConst x _ _ = x+{-# INLINE liftReadPrecConst #-}++liftReadsPrec2Const :: ReadS (f a b)+                    -> (Int -> ReadS a) -> ReadS [a]+                    -> (Int -> ReadS b) -> ReadS [b]+                    -> Int -> ReadS (f a b)+liftReadsPrec2Const x _ _ _ _ _ = x+{-# INLINE liftReadsPrec2Const #-}++liftReadPrec2Const :: ReadPrec (f a b)+                   -> ReadPrec a -> ReadPrec [a]+                   -> ReadPrec b -> ReadPrec [b]+                   -> ReadPrec (f a b)+liftReadPrec2Const x _ _ _ _ = x+{-# INLINE liftReadPrec2Const #-}+ showsPrecConst :: ShowS                -> Int -> a -> ShowS showsPrecConst x _ _ = x@@ -735,6 +831,10 @@ -- Error messages ------------------------------------------------------------------------------- +-- | The given datatype has no constructors, and we don't know what to do with it.+noConstructorsError :: Q a+noConstructorsError = fail "Must have at least one data constructor"+ -- | Either the given data type doesn't have enough type variables, or one of -- the type variables to be eta-reduced cannot realize kind *. derivingKindError :: ClassRep a => a ->  Name -> Q b@@ -845,6 +945,15 @@ interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s interleave _        _        = [] +#if MIN_VERSION_ghc_prim(0,3,1)+tagToEnum :: Int# -> Bool+tagToEnum x = tagToEnum# x+#else+tagToEnum :: Bool -> Bool+tagToEnum x = x+#endif+{-# INLINE tagToEnum #-}+ -- isRight and fromEither taken from the extra package (BSD3-licensed)  -- | Test if an 'Either' value is the 'Right' constructor.@@ -910,6 +1019,9 @@         e2' = (`AppE` e2)     either (Left . e2') (Right . e2') `fmap` e1Q +integerE :: Int -> Q Exp+integerE = litE . integerL . fromIntegral+ -- | Returns True if a Type has kind *. hasKindStar :: Type -> Bool hasKindStar VarT{}         = True@@ -973,8 +1085,27 @@  -- | Monadic version of concatMap concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]-concatMapM f xs = liftM concat (mapM f xs)+concatMapM f xs = concat `liftM` mapM f xs +zipWithAndUnzipM :: Monad m+                 => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d])+zipWithAndUnzipM f (x:xs) (y:ys) = do+    (c, d) <- f x y+    (cs, ds) <- zipWithAndUnzipM f xs ys+    return (c:cs, d:ds)+zipWithAndUnzipM _ _ _ = return ([], [])+{-# INLINE zipWithAndUnzipM #-}++zipWith3AndUnzipM :: Monad m+                 => (a -> b -> c -> m (d, e)) -> [a] -> [b] -> [c]+                 -> m ([d], [e])+zipWith3AndUnzipM f (x:xs) (y:ys) (z:zs) = do+    (d, e) <- f x y z+    (ds, es) <- zipWith3AndUnzipM f xs ys zs+    return (d:ds, e:es)+zipWith3AndUnzipM _ _ _ _ = return ([], [])+{-# INLINE zipWith3AndUnzipM #-}+ thd3 :: (a, b, c) -> c thd3 (_, _, c) = c @@ -989,6 +1120,17 @@ constructorName (RecGadtC names _ _)    = head names #endif +isNullaryCon :: Con -> Bool+isNullaryCon (NormalC _ [])    = True+isNullaryCon (RecC    _ [])    = True+isNullaryCon InfixC{}          = False+isNullaryCon (ForallC _ _ con) = isNullaryCon con+#if MIN_VERSION_template_haskell(2,11,0)+isNullaryCon (GadtC    _ [] _) = True+isNullaryCon (RecGadtC _ [] _) = True+#endif+isNullaryCon _                 = False+ -- | 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]@@ -1038,6 +1180,13 @@     droppedNames :: [Name]     droppedNames = map varTToName dropped +-- | Extract the Name from a type constructor. If the argument Type is not a+-- type variable, throw an error.+conTToName :: Type -> Name+conTToName (ConT n)   = n+conTToName (SigT t _) = conTToName t+conTToName _          = error "Not a type constructor!"+ -- | Extract Just the Name from a type variable. If the argument Type is not a -- type variable, return Nothing. varTToName_maybe :: Type -> Maybe Name@@ -1172,6 +1321,27 @@ uncurryKind k              = [k] #endif +untagExpr :: [(Name, Name)] -> Q Exp -> Q Exp+untagExpr [] e = e+untagExpr ((untagThis, putTagHere) : more) e =+    caseE (varE getTagValName `appE` varE untagThis)+          [match (varP putTagHere)+                 (normalB $ untagExpr more e)+                 []]++primOpAppExpr :: Q Exp -> Name -> Q Exp -> Q Exp+primOpAppExpr e1 op e2 = varE tagToEnumValName `appE`+                           infixApp e1 (varE op) e2++-- | Checks if a 'Name' represents a tuple type constructor (other than '()')+isNonUnitTuple :: Name -> Bool+isNonUnitTuple = isNonUnitTupleString . nameBase++-- | Checks if a 'String' represents a tuple (other than '()')+isNonUnitTupleString :: String -> Bool+isNonUnitTupleString ('(':',':_) = True+isNonUnitTupleString _           = False+ ------------------------------------------------------------------------------- -- Manually quoted names -------------------------------------------------------------------------------@@ -1202,6 +1372,54 @@ traverseConstValName :: Name traverseConstValName = mkDerivingCompatName_v "traverseConst" +eqConstValName :: Name+eqConstValName = mkDerivingCompatName_v "eqConst"++eq1ConstValName :: Name+eq1ConstValName = mkDerivingCompatName_v "eq1Const"++liftEqConstValName :: Name+liftEqConstValName = mkDerivingCompatName_v "liftEqConst"++liftEq2ConstValName :: Name+liftEq2ConstValName = mkDerivingCompatName_v "liftEq2Const"++compareConstValName :: Name+compareConstValName = mkDerivingCompatName_v "compareConst"++ltConstValName :: Name+ltConstValName = mkDerivingCompatName_v "ltConst"++compare1ConstValName :: Name+compare1ConstValName = mkDerivingCompatName_v "compare1Const"++liftCompareConstValName :: Name+liftCompareConstValName = mkDerivingCompatName_v "liftCompareConst"++liftCompare2ConstValName :: Name+liftCompare2ConstValName = mkDerivingCompatName_v "liftCompare2Const"++readsPrecConstValName :: Name+readsPrecConstValName = mkDerivingCompatName_v "readsPrecConst"++readPrecConstValName :: Name+readPrecConstValName = mkDerivingCompatName_v "readPrecConst"++readsPrec1ConstValName :: Name+readsPrec1ConstValName = mkDerivingCompatName_v "readsPrec1Const"++liftReadsPrecConstValName :: Name+liftReadsPrecConstValName = mkDerivingCompatName_v "liftReadsPrecConst"++liftReadPrecConstValName :: Name+liftReadPrecConstValName = mkDerivingCompatName_v "liftReadPrecConst"++liftReadsPrec2ConstValName :: Name+liftReadsPrec2ConstValName = mkDerivingCompatName_v "liftReadsPrec2Const"++liftReadPrec2ConstValName :: Name+liftReadPrec2ConstValName = mkDerivingCompatName_v "liftReadPrec2Const"+ showsPrecConstValName :: Name showsPrecConstValName = mkDerivingCompatName_v "showsPrecConst" @@ -1214,6 +1432,9 @@ liftShowsPrec2ConstValName :: Name liftShowsPrec2ConstValName = mkDerivingCompatName_v "liftShowsPrec2Const" +tagToEnumValName :: Name+tagToEnumValName = mkDerivingCompatName_v "tagToEnum"+ cHashDataName :: Name cHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "C#" @@ -1229,14 +1450,23 @@ fHashDataName :: Name fHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "F#" +identDataName :: Name+identDataName = mkNameG_d "base" "Text.Read.Lex" "Ident"+ iHashDataName :: Name iHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "I#" +puncDataName :: Name+puncDataName = mkNameG_d "base" "Text.Read.Lex" "Punc"++symbolDataName :: Name+symbolDataName = mkNameG_d "base" "Text.Read.Lex" "Symbol"+ wrapMonadDataName :: Name wrapMonadDataName = mkNameG_d "base" "Control.Applicative" "WrapMonad" --- addrHashTypeName :: Name--- addrHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Addr#"+addrHashTypeName :: Name+addrHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Addr#"  charHashTypeName :: Name charHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Char#"@@ -1256,6 +1486,9 @@ intHashTypeName :: Name intHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int#" +readTypeName :: Name+readTypeName = mkNameG_tc "base" "GHC.Read" "Read"+ showTypeName :: Name showTypeName = mkNameG_tc "base" "GHC.Show" "Show" @@ -1265,12 +1498,39 @@ wordHashTypeName :: Name wordHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word#" +altValName :: Name+altValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "+++"+ appEndoValName :: Name appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo" +chooseValName :: Name+chooseValName = mkNameG_v "base" "GHC.Read" "choose"+ composeValName :: Name composeValName = mkNameG_v "base" "GHC.Base" "." +constValName :: Name+constValName = mkNameG_v "base" "GHC.Base" "const"++eqAddrHashValName :: Name+eqAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqAddr#"++eqCharHashValName :: Name+eqCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqChar#"++eqDoubleHashValName :: Name+eqDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "==##"++eqFloatHashValName :: Name+eqFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqFloat#"++eqIntHashValName :: Name+eqIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "==#"++eqWordHashValName :: Name+eqWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord#"+ errorValName :: Name errorValName = mkNameG_v "base" "GHC.Err" "error" @@ -1286,12 +1546,147 @@ foldMapValName :: Name foldMapValName = mkNameG_v "base" "Data.Foldable" "foldMap" +geAddrHashValName :: Name+geAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geAddr#"++geCharHashValName :: Name+geCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geChar#"++geDoubleHashValName :: Name+geDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">=##"++geFloatHashValName :: Name+geFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geFloat#"++geIntHashValName :: Name+geIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">=#"+ getDualValName :: Name getDualValName = mkNameG_v "base" "Data.Monoid" "getDual" +getTagValName :: Name+getTagValName = mkNameG_v "base" "GHC.Base" "getTag"++geWordHashValName :: Name+geWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord#"++gtAddrHashValName :: Name+gtAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtAddr#"++gtCharHashValName :: Name+gtCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtChar#"++gtDoubleHashValName :: Name+gtDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">##"++gtFloatHashValName :: Name+gtFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtFloat#"++gtIntHashValName :: Name+gtIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">#"++gtWordHashValName :: Name+gtWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord#"+ idValName :: Name idValName = mkNameG_v "base" "GHC.Base" "id" +leAddrHashValName :: Name+leAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leAddr#"++leCharHashValName :: Name+leCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leChar#"++leDoubleHashValName :: Name+leDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<=##"++leFloatHashValName :: Name+leFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leFloat#"++leIntHashValName :: Name+leIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<=#"++leWordHashValName :: Name+leWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord#"++liftReadListPrecDefaultValName :: Name+liftReadListPrecDefaultValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrecDefault"++liftReadListPrec2DefaultValName :: Name+liftReadListPrec2DefaultValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec2Default"++liftReadListPrecValName :: Name+liftReadListPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec"++liftReadListPrec2ValName :: Name+liftReadListPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec2"++liftReadPrecValName :: Name+liftReadPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadPrec"++liftReadPrec2ValName :: Name+liftReadPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadPrec2"++listValName :: Name+listValName = mkNameG_v "base" "GHC.Read" "list"++ltAddrHashValName :: Name+ltAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltAddr#"++ltCharHashValName :: Name+ltCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltChar#"++ltDoubleHashValName :: Name+ltDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<##"++ltFloatHashValName :: Name+ltFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltFloat#"++ltIntHashValName :: Name+ltIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<#"++ltWordHashValName :: Name+ltWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord#"++parenValName :: Name+parenValName = mkNameG_v "base" "GHC.Read" "paren"++parensValName :: Name+parensValName = mkNameG_v "base" "GHC.Read" "parens"++pfailValName :: Name+pfailValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "pfail"++precValName :: Name+precValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "prec"++readListValName :: Name+readListValName = mkNameG_v "base" "GHC.Read" "readList"++readListPrecDefaultValName :: Name+readListPrecDefaultValName = mkNameG_v "base" "GHC.Read" "readListPrecDefault"++readListPrecValName :: Name+readListPrecValName = mkNameG_v "base" "GHC.Read" "readListPrec"++readPrec_to_SValName :: Name+readPrec_to_SValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "readPrec_to_S"++readPrecValName :: Name+readPrecValName = mkNameG_v "base" "GHC.Read" "readPrec"++readS_to_PrecValName :: Name+readS_to_PrecValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "readS_to_Prec"++readsPrecValName :: Name+readsPrecValName = mkNameG_v "base" "GHC.Read" "readsPrec"++resetValName :: Name+resetValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "reset"++returnValName :: Name+returnValName = mkNameG_v "base" "GHC.Base" "return"+ showCharValName :: Name showCharValName = mkNameG_v "base" "GHC.Show" "showChar" @@ -1313,18 +1708,113 @@ showStringValName :: Name showStringValName = mkNameG_v "base" "GHC.Show" "showString" +stepValName :: Name+stepValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "step"+ traverseValName :: Name traverseValName = mkNameG_v "base" "Data.Traversable" "traverse"  unwrapMonadValName :: Name unwrapMonadValName = mkNameG_v "base" "Control.Applicative" "unwrapMonad" +#if MIN_VERSION_base(4,4,0)+boolTypeName :: Name+boolTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "Bool"++falseDataName :: Name+falseDataName = mkNameG_v "ghc-prim" "GHC.Types" "False"++trueDataName :: Name+trueDataName = mkNameG_v "ghc-prim" "GHC.Types" "True"+#else+boolTypeName :: Name+boolTypeName = mkNameG_tc "ghc-prim" "GHC.Bool" "Bool"++falseDataName :: Name+falseDataName = mkNameG_v "ghc-prim" "GHC.Bool" "False"++trueDataName :: Name+trueDataName = mkNameG_v "ghc-prim" "GHC.Bool" "True"+#endif+ #if MIN_VERSION_base(4,5,0)+eqDataName :: Name+eqDataName = mkNameG_d "ghc-prim" "GHC.Types" "EQ"++gtDataName :: Name+gtDataName = mkNameG_d "ghc-prim" "GHC.Types" "GT"++ltDataName :: Name+ltDataName = mkNameG_d "ghc-prim" "GHC.Types" "LT"++eqTypeName :: Name+eqTypeName = mkNameG_tc "ghc-prim" "GHC.Classes" "Eq"++ordTypeName :: Name+ordTypeName = mkNameG_tc "ghc-prim" "GHC.Classes" "Ord"++andValName :: Name+andValName = mkNameG_v "ghc-prim" "GHC.Classes" "&&"++compareValName :: Name+compareValName = mkNameG_v "ghc-prim" "GHC.Classes" "compare"++eqValName :: Name+eqValName = mkNameG_v "ghc-prim" "GHC.Classes" "=="++geValName :: Name+geValName = mkNameG_v "ghc-prim" "GHC.Classes" "<="++gtValName :: Name+gtValName = mkNameG_v "ghc-prim" "GHC.Classes" "<"++leValName :: Name+leValName = mkNameG_v "ghc-prim" "GHC.Classes" ">="+ ltValName :: Name ltValName = mkNameG_v "ghc-prim" "GHC.Classes" ">"++notValName :: Name+notValName = mkNameG_v "ghc-prim" "GHC.Classes" "not" #else+eqDataName :: Name+eqDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "EQ"++gtDataName :: Name+gtDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "GT"++ltDataName :: Name+ltDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "LT"++eqTypeName :: Name+eqTypeName = mkNameG_tc "base" "GHC.Classes" "Eq"++ordTypeName :: Name+ordTypeName = mkNameG_tc "base" "GHC.Classes" "Ord"++andValName :: Name+andValName = mkNameG_v "base" "GHC.Classes" "&&"++compareValName :: Name+compareValName = mkNameG_v "base" "GHC.Classes" "compare"++eqValName :: Name+eqValName = mkNameG_v "base" "GHC.Classes" "=="++geValName :: Name+geValName = mkNameG_v "base" "GHC.Classes" "<="++gtValName :: Name+gtValName = mkNameG_v "base" "GHC.Classes" "<"++leValName :: Name+leValName = mkNameG_v "base" "GHC.Classes" ">="+ ltValName :: Name ltValName = mkNameG_v "base" "GHC.Classes" ">"++notValName :: Name+notValName = mkNameG_v "base" "GHC.Classes" "not" #endif  #if MIN_VERSION_base(4,6,0)@@ -1340,6 +1830,19 @@ starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*" #endif +#if MIN_VERSION_base(4,7,0)+expectPValName :: Name+expectPValName = mkNameG_v "base" "GHC.Read" "expectP"+#else+expectP :: Lexeme -> ReadPrec ()+expectP lexeme = do+  thing <- lexP+  if thing == lexeme then return () else pfail++expectPValName :: Name+expectPValName = mkDerivingCompatName_v "expectP"+#endif+ #if MIN_VERSION_base(4,8,0) pureValName :: Name pureValName = mkNameG_v "base" "GHC.Base" "pure"@@ -1367,6 +1870,48 @@ #endif  #if MIN_VERSION_base(4,9,0)+eq1TypeName :: Name+eq1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Eq1"++eq2TypeName :: Name+eq2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Eq2"++liftEqValName :: Name+liftEqValName = mkNameG_v "base" "Data.Functor.Classes" "liftEq"++liftEq2ValName :: Name+liftEq2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftEq2"++ord1TypeName :: Name+ord1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Ord1"++ord2TypeName :: Name+ord2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Ord2"++liftCompareValName :: Name+liftCompareValName = mkNameG_v "base" "Data.Functor.Classes" "liftCompare"++liftCompare2ValName :: Name+liftCompare2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftCompare2"++read1TypeName :: Name+read1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Read1"++read2TypeName :: Name+read2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Read2"++liftReadsPrecValName :: Name+liftReadsPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadsPrec"++liftReadListValName :: Name+liftReadListValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadList"++liftReadsPrec2ValName :: Name+liftReadsPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadsPrec2"++liftReadList2ValName :: Name+liftReadList2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadList2"+ show1TypeName :: Name show1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Show1" @@ -1388,6 +1933,48 @@ -- If Data.Functor.Classes isn't located in base, then sadly we can't refer to -- Names from that module without using -XTemplateHaskell. # if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0)+eq1TypeName :: Name+eq1TypeName = ''Eq1++eq2TypeName :: Name+eq2TypeName = ''Eq2++liftEqValName :: Name+liftEqValName = 'liftEq++liftEq2ValName :: Name+liftEq2ValName = 'liftEq2++ord1TypeName :: Name+ord1TypeName = ''Ord1++ord2TypeName :: Name+ord2TypeName = ''Ord2++liftCompareValName :: Name+liftCompareValName = 'liftCompare++liftCompare2ValName :: Name+liftCompare2ValName = 'liftCompare2++read1TypeName :: Name+read1TypeName = ''Read1++read2TypeName :: Name+read2TypeName = ''Read2++liftReadsPrecValName :: Name+liftReadsPrecValName = 'liftReadsPrec++liftReadListValName :: Name+liftReadListValName = 'liftReadList++liftReadsPrec2ValName :: Name+liftReadsPrec2ValName = 'liftReadsPrec2++liftReadList2ValName :: Name+liftReadList2ValName = 'liftReadList2+ show1TypeName :: Name show1TypeName = ''Show1 @@ -1406,6 +1993,24 @@ liftShowsPrec2ValName :: Name liftShowsPrec2ValName = 'liftShowsPrec2 # else+eq1TypeName :: Name+eq1TypeName = ''Eq1++eq1ValName :: Name+eq1ValName = 'eq1++ord1TypeName :: Name+ord1TypeName = ''Ord1++compare1ValName :: Name+compare1ValName = 'compare1++read1TypeName :: Name+read1TypeName = ''Read1++readsPrec1ValName :: Name+readsPrec1ValName = 'readsPrec1+ show1TypeName :: Name show1TypeName = ''Show1 @@ -1414,10 +2019,57 @@  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 <- isTyFamily tyCon+    if any (`mentionsName` [name]) lhsArgs+          || itf && any (`mentionsName` [name]) tyArgs+       then outOfPlaceTyVarError cRep conName+       else inspectTy (head rhsArgs)+ applyDataName :: Name applyDataName = mkNameG_d derivingCompatPackageKey "Data.Deriving.Internal" "Apply"++unApplyValName :: Name+unApplyValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "unApply" # endif #endif

@@ -0,0 +1,51 @@+{-# LANGUAGE CPP #-}+{-|+Module:      Data.Eq.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 'Eq', 'Eq1', and 'Eq2' instances.+-}+module Data.Eq.Deriving (+      -- * 'Eq'+      deriveEq+    , makeEq+    , 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++import Data.Eq.Deriving.Internal++{- $constraints++Be aware of the following potential gotchas:++* Type variables of kind @*@ are assumed to have 'Eq' constraints.+  Type variables of kind @* -> *@ are assumed to have 'Eq1' constraints.+  Type variables of kind @* -> * -> *@ are assumed to have 'Eq2' constraints.+  If this is not desirable, use 'makeEq' or one of its cousins.++* The 'Eq1' class had a different definition in @transformers-0.4@, and as a result,+  'deriveEq1' implements different instances for the @transformers-0.4@ 'Eq1' than+  it otherwise does. Also, 'makeLiftEq' is not available+  when this library is built against @transformers-0.4@, only 'makeEq1.++* The 'Eq2' class is not available in @transformers-0.4@, and as a+  result, neither are Template Haskell functions that deal with 'Eq2' when this+  library is built against @transformers-0.4@.+-}

@@ -0,0 +1,352 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}++{-|+Module:      Data.Eq.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 'Eq', 'Eq1', and 'Eq2' instances.+-}+module Data.Eq.Deriving.Internal (+      -- * 'Eq'+      deriveEq+    , makeEq+    , 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+import           Data.List (foldl1', partition)+import qualified Data.Map as Map++import           Language.Haskell.TH.Lib+import           Language.Haskell.TH.Syntax++-- | Generates an 'Eq' instance declaration for the given data type or data+-- family instance.+deriveEq :: Name -> Q [Dec]+deriveEq = deriveEqClass Eq++-- | Generates a lambda expression which behaves like '(==)' (without+-- requiring an 'Eq' instance).+makeEq :: Name -> Q Exp+makeEq = makeEqClass Eq++-- | Generates a lambda expression which behaves like '(/=)' (without+-- requiring an 'Eq' instance).+makeNotEq :: Name -> Q Exp+makeNotEq name = do+    x1 <- newName "x1"+    x2 <- newName "x2"+    lamE [varP x1, varP x2] $ varE notValName `appE`+        (makeEq name `appE` varE x1 `appE` varE x2)++-- | Generates an 'Eq1' instance declaration for the given data type or data+-- family instance.+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).+--+-- This function is not available with @transformers-0.4@.+makeLiftEq :: Name -> Q Exp+makeLiftEq = makeEqClass Eq1++-- | Generates a lambda expression which behaves like 'eq1' (without+-- 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.+--+-- This function is not available with @transformers-0.4@.+deriveEq2 :: Name -> Q [Dec]+deriveEq2 = deriveEqClass Eq2++-- | Generates a lambda expression which behaves like 'liftEq2' (without+-- requiring an 'Eq2' instance).+--+-- This function is not available with @transformers-0.4@.+makeLiftEq2 :: Name -> Q Exp+makeLiftEq2 = makeEqClass Eq2++-- | Generates a lambda expression which behaves like 'eq2' (without+-- requiring an 'Eq2' instance).+--+-- 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+-------------------------------------------------------------------------------++-- | Derive an Eq(1)(2) instance declaration (depending on the EqClass+-- argument's value).+deriveEqClass :: EqClass -> Name -> Q [Dec]+deriveEqClass eClass 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 eClass name' ctxt tvbs mbTys+        instanceD (return instanceCxt)+                  (return instanceType)+                  (eqDecs eClass cons)++-- | Generates a declaration defining the primary function corresponding to a+-- particular class ((==) for Eq, liftEq for Eq1, and+-- liftEq2 for Eq2).+eqDecs :: EqClass -> [Con] -> [Q Dec]+eqDecs eClass cons =+    [ funD (eqName eClass)+           [ clause []+                    (normalB $ makeEqForCons eClass cons)+                    []+           ]+    ]++-- | Generates a lambda expression which behaves like (==) (for Eq),+-- liftEq (for Eq1), or liftEq2 (for Eq2).+makeEqClass :: EqClass -> Name -> Q Exp+makeEqClass eClass 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 (==)/liftEq/etc.+        -- implemented for it, and produces errors if it can't.+        buildTypeInstance eClass name' ctxt tvbs mbTys+          `seq` makeEqForCons eClass cons++-- | Generates a lambda expression for (==)/liftEq/etc. for the+-- given constructors. All constructors must be from the same type.+makeEqForCons :: EqClass -> [Con] -> Q Exp+makeEqForCons _ [] = noConstructorsError+makeEqForCons eClass cons = do+    value1 <- newName "value1"+    value2 <- newName "value2"+    eqDefn <- newName "eqDefn"+    eqs    <- newNameList "eq" $ arity eClass++    lamE (map varP $+#if defined(NEW_FUNCTOR_CLASSES)+                     eqs +++#endif+                     [value1, value2]+         ) . appsE+         $ [ varE $ eqConstName eClass+           , letE [ funD eqDefn $ map (makeCaseForCon eClass eqs) patMatchCons+                               ++ fallThroughCase+                  ] $ varE eqDefn `appE` varE value1 `appE` varE value2+           ]+#if defined(NEW_FUNCTOR_CLASSES)+             ++ map varE eqs+#endif+             ++ [varE value1, varE value2]+  where+    nullaryCons, nonNullaryCons :: [Con]+    (nullaryCons, nonNullaryCons) = partition isNullaryCon cons++    tagMatchCons, patMatchCons :: [Con]+    (tagMatchCons, patMatchCons)+      | length nullaryCons > 10 = (nullaryCons, nonNullaryCons)+      | otherwise               = ([],          cons)++    fallThroughCase :: [Q Clause]+    fallThroughCase+      | null tagMatchCons = case patMatchCons of+          []  -> []+          [_] -> []+          _   -> [makeFallThroughCase]+      | otherwise = [makeTagCase]++makeTagCase :: Q Clause+makeTagCase = do+    a     <- newName "a"+    aHash <- newName "a#"+    b     <- newName "b"+    bHash <- newName "b#"+    clause (map varP [a,b])+           (normalB $ untagExpr [(a, aHash), (b, bHash)] $+               primOpAppExpr (varE aHash) eqIntHashValName (varE bHash)) []++makeFallThroughCase :: Q Clause+makeFallThroughCase = clause [wildP, wildP] (normalB $ conE falseDataName) []++makeCaseForCon :: EqClass -> [Name] -> Con -> Q Clause+makeCaseForCon eClass eqs con = do+  let conName = constructorName con+  (ts, tvMap) <- reifyConTys1 eClass eqs conName+  let tsLen = length ts+  as <- newNameList "a" tsLen+  bs <- newNameList "b" tsLen+  clause [conP conName (map varP as), conP conName (map varP bs)]+         (normalB $ makeCaseForArgs eClass tvMap conName ts as bs)+         []++makeCaseForArgs :: EqClass+                -> TyVarMap1+                -> Name+                -> [Type]+                -> [Name]+                -> [Name]+                -> Q Exp+makeCaseForArgs _ _ _ [] [] [] = conE trueDataName+makeCaseForArgs eClass tvMap conName tys as bs =+    foldl1' (\q e -> infixApp q (varE andValName) e)+            (zipWith3 (makeCaseForArg eClass tvMap conName) tys as bs)++makeCaseForArg :: EqClass+               -> TyVarMap1+               -> Name+               -> Type+               -> Name+               -> Name+               -> Q Exp+makeCaseForArg _ _ _ (ConT tyName) a b = primEqExpr+  where+    aExpr, bExpr :: Q Exp+    aExpr = varE a+    bExpr = varE b++    makePrimEqExpr :: Name -> Q Exp+    makePrimEqExpr n = primOpAppExpr aExpr n bExpr++    primEqExpr :: Q Exp+    primEqExpr+      | tyName == addrHashTypeName   = makePrimEqExpr eqAddrHashValName+      | tyName == charHashTypeName   = makePrimEqExpr eqCharHashValName+      | tyName == doubleHashTypeName = makePrimEqExpr eqDoubleHashValName+      | tyName == floatHashTypeName  = makePrimEqExpr eqFloatHashValName+      | tyName == intHashTypeName    = makePrimEqExpr eqIntHashValName+      | tyName == wordHashTypeName   = makePrimEqExpr eqWordHashValName+      | otherwise = infixApp aExpr (varE eqValName) bExpr+makeCaseForArg eClass tvMap conName ty a b =+    makeCaseForType eClass tvMap conName ty `appE` varE a `appE` varE b++makeCaseForType :: EqClass+                -> TyVarMap1+                -> 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]+        tyCon:tyArgs = unapplyTy ty++        numLastArgs :: Int+        numLastArgs = min (arity eClass) (length tyArgs)++        lhsArgs, rhsArgs :: [Type]+        (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs++        tyVarNames :: [Name]+        tyVarNames = Map.keys tvMap++    itf <- isTyFamily tyCon+    if any (`mentionsName` tyVarNames) lhsArgs+          || itf && any (`mentionsName` tyVarNames) tyArgs+       then outOfPlaceTyVarError eClass conName+       else appsE $ [ varE . eqName $ toEnum numLastArgs]+                    ++ map (makeCaseForType eClass tvMap conName) rhsArgs+#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+-------------------------------------------------------------------------------++-- | 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+    arity = fromEnum++    allowExQuant _ = True++    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)+      | otherwise              = Nothing+      where+        eMin, eMax :: Int+        eMin = fromEnum (minBound :: EqClass)+        eMax = fromEnum eClass++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

@@ -369,6 +369,10 @@ allowFunTys Functor = True allowFunTys _       = False +-------------------------------------------------------------------------------+-- Assorted utilities+-------------------------------------------------------------------------------+ -- See Trac #7436 for why explicit lambdas are used functorFunTriv :: FunctorFun -> Q Exp functorFunTriv Fmap = do

@@ -0,0 +1,56 @@+{-# LANGUAGE CPP #-}+{-|+Module:      Data.Ord.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 'Ord', 'Ord1', and 'Ord2' instances.+-}+module Data.Ord.Deriving (+      -- * 'Ord'+      deriveOrd+    , makeCompare+    , makeLT+    , makeLE+    , makeGT+    , makeGE+    , makeMax+    , 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++import Data.Ord.Deriving.Internal++{- $constraints++Be aware of the following potential gotchas:++* Type variables of kind @*@ are assumed to have 'Ord' constraints.+  Type variables of kind @* -> *@ are assumed to have 'Ord1' constraints.+  Type variables of kind @* -> * -> *@ are assumed to have 'Ord2' constraints.+  If this is not desirable, use 'makeCompare' or one of its cousins.++* The 'Ord1' class had a different definition in @transformers-0.4@, and as a result,+  'deriveOrd1' implements different instances for the @transformers-0.4@ 'Ord1' than+  it otherwise does. Also, 'makeLiftCompare' is not available+  when this library is built against @transformers-0.4@, only 'makeCompare1.++* The 'Ord2' class is not available in @transformers-0.4@, and as a+  result, neither are Template Haskell functions that deal with 'Ord2' when this+  library is built against @transformers-0.4@.+-}

@@ -0,0 +1,690 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}++{-|+Module:      Data.Ord.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 'Ord', 'Ord1', and 'Ord2' instances.+-}+module Data.Ord.Deriving.Internal (+      -- * 'Ord'+      deriveOrd+    , makeCompare+    , makeLE+    , makeLT+    , makeGT+    , makeGE+    , makeMax+    , 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+import           Data.List (partition)+import qualified Data.Map as Map+import           Data.Maybe (isJust)++import           Language.Haskell.TH.Lib+import           Language.Haskell.TH.Syntax++-- | Generates an 'Ord' instance declaration for the given data type or data+-- family instance.+deriveOrd :: Name -> Q [Dec]+deriveOrd = deriveOrdClass Ord++-- | Generates a lambda expression which behaves like 'compare' (without+-- requiring an 'Ord' instance).+makeCompare :: Name -> Q Exp+makeCompare = makeOrdFun OrdCompare (error "This shouldn't happen")++-- | Generates a lambda expression which behaves like '(<)' (without+-- requiring an 'Ord' instance).+makeLT :: Name -> Q Exp+makeLT = makeOrdFun OrdLT [ match (conP ltDataName []) (normalB $ conE trueDataName)  []+                          , match wildP                (normalB $ conE falseDataName) []+                          ]++-- | Generates a lambda expression which behaves like '(<=)' (without+-- requiring an 'Ord' instance).+makeLE :: Name -> Q Exp+makeLE = makeOrdFun OrdLE [ match (conP gtDataName []) (normalB $ conE falseDataName) []+                          , match wildP                (normalB $ conE trueDataName)  []+                          ]++-- | Generates a lambda expression which behaves like '(>)' (without+-- requiring an 'Ord' instance).+makeGT :: Name -> Q Exp+makeGT = makeOrdFun OrdGT [ match (conP gtDataName []) (normalB $ conE trueDataName)  []+                          , match wildP                (normalB $ conE falseDataName) []+                          ]++-- | Generates a lambda expression which behaves like '(>=)' (without+-- requiring an 'Ord' instance).+makeGE :: Name -> Q Exp+makeGE = makeOrdFun OrdGE [ match (conP ltDataName []) (normalB $ conE falseDataName) []+                          , match wildP                (normalB $ conE trueDataName)  []+                          ]++-- | Generates a lambda expression which behaves like 'max' (without+-- requiring an 'Ord' instance).+makeMax :: Name -> Q Exp+makeMax = makeMinMax flip++-- | Generates a lambda expression which behaves like 'min' (without+-- requiring an 'Ord' instance).+makeMin :: Name -> Q Exp+makeMin = makeMinMax id++makeMinMax :: ((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp)+           -> Name -> Q Exp+makeMinMax f name = do+    x <- newName "x"+    y <- newName "y"+    let xExpr = varE x+        yExpr = varE y+    lamE [varP x, varP y] $+        f (condE $ makeLE name `appE` xExpr `appE` yExpr) xExpr yExpr++-- | Generates an 'Ord1' instance declaration for the given data type or data+-- family instance.+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).+--+-- This function is not available with @transformers-0.4@.+makeLiftCompare :: Name -> Q Exp+makeLiftCompare = makeOrdFun Ord1LiftCompare (error "This shouldn't happen")++-- | Generates a lambda expression which behaves like 'compare1' (without+-- 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.+--+-- This function is not available with @transformers-0.4@.+deriveOrd2 :: Name -> Q [Dec]+deriveOrd2 = deriveOrdClass Ord2++-- | Generates a lambda expression which behaves like 'liftCompare2' (without+-- requiring an 'Ord2' instance).+--+-- This function is not available with @transformers-0.4@.+makeLiftCompare2 :: Name -> Q Exp+makeLiftCompare2 = makeOrdFun Ord2LiftCompare2 (error "This shouldn't happen")++-- | Generates a lambda expression which behaves like 'compare2' (without+-- requiring an 'Ord2' instance).+--+-- This function is not available with @transformers-0.4@.+makeCompare2 :: Name -> Q Exp+makeCompare2 name = makeLiftCompare name+             `appE` varE compareValName+             `appE` varE compareValName+#endif++-------------------------------------------------------------------------------+-- Code generation+-------------------------------------------------------------------------------++-- | Derive an Ord(1)(2) instance declaration (depending on the OrdClass+-- argument's value).+deriveOrdClass :: OrdClass -> Name -> Q [Dec]+deriveOrdClass oClass 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 oClass name' ctxt tvbs mbTys+        instanceD (return instanceCxt)+                  (return instanceType)+                  (ordFunDecs oClass cons)++-- | Generates a declaration defining the primary function(s) corresponding to a+-- particular class (compare for Ord, liftCompare for Ord1, and+-- liftCompare2 for Ord2).+ordFunDecs :: OrdClass -> [Con] -> [Q Dec]+ordFunDecs oClass cons =+    map makeFunD $ ordClassToCompare oClass : otherFuns oClass cons+  where+    makeFunD :: OrdFun -> Q Dec+    makeFunD oFun =+      funD (ordFunName oFun $ arity oClass)+           [ clause []+                    (normalB $ makeOrdFunForCons oFun cons)+                    []+           ]++-- | Generates a lambda expression which behaves like the OrdFun value. This+-- function uses heuristics to determine whether to implement the OrdFun from+-- scratch or define it in terms of compare.+makeOrdFun :: OrdFun -> [Q Match] -> Name -> Q Exp+makeOrdFun oFun matches name = withType name fromCons+  where+    fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp+    fromCons name' ctxt tvbs cons mbTys = do+        let oClass = ordFunToClass oFun+            others = otherFuns oClass cons+        -- We force buildTypeInstance here since it performs some checks for whether+        -- or not the provided datatype can actually have compare/liftCompare/etc.+        -- implemented for it, and produces errors if it can't.+        buildTypeInstance oClass name' ctxt tvbs mbTys `seq`+          if oFun `elem` compareFuns || oFun `elem` others+             then makeOrdFunForCons oFun cons+             else do+               x <- newName "x"+               y <- newName "y"+               lamE [varP x, varP y] $+                    caseE (makeOrdFunForCons (ordClassToCompare oClass) cons+                               `appE` varE x `appE` varE y)+                          matches++    compareFuns :: [OrdFun]+    compareFuns = [ OrdCompare+#if defined(NEW_FUNCTOR_CLASSES)+                  , Ord1LiftCompare+                  , Ord2LiftCompare2+#else+                  , Ord1Compare1+#endif+                  ]++-- | Generates a lambda expression for the given constructors.+-- All constructors must be from the same type.+makeOrdFunForCons :: OrdFun -> [Con] -> Q Exp+makeOrdFunForCons _    []   = noConstructorsError+makeOrdFunForCons oFun cons = do+    let oClass = ordFunToClass oFun+    v1   <- newName "v1"+    v2   <- newName "v2"+    v1Hash <- newName "v1#"+    v2Hash <- newName "v2#"+    ords <- newNameList "ord" $ arity oClass++    let nullaryCons, nonNullaryCons :: [Con]+        (nullaryCons, nonNullaryCons) = partition isNullaryCon cons++        singleConType :: Bool+        singleConType = isSingleton cons++        firstConName, lastConName :: Name+        firstConName = constructorName $ head cons+        lastConName  = constructorName $ last cons++        -- I think these should always be the case...+        firstTag, lastTag :: Int+        firstTag = 0+        lastTag  = length cons - 1++        ordMatches :: Int -> Con -> Q Match+        ordMatches = makeOrdFunForCon oFun v2 v2Hash ords singleConType+                                      firstTag firstConName lastTag lastConName++        ordFunRhs :: Q Exp+        ordFunRhs+          | length nullaryCons <= 2+          = caseE (varE v1) $ zipWith ordMatches [0..] cons+          | null nonNullaryCons+          = mkTagCmp+          | otherwise+          = caseE (varE v1) $ zipWith ordMatches [0..] nonNullaryCons+                ++ [match wildP (normalB mkTagCmp) []]++        mkTagCmp :: Q Exp+        mkTagCmp = untagExpr [(v1, v1Hash), (v2, v2Hash)] $+                       unliftedOrdFun intHashTypeName oFun v1Hash v2Hash++    lamE (map varP $+#if defined(NEW_FUNCTOR_CLASSES)+                     ords +++#endif+                     [v1, v2])+        . appsE+        $ [ varE $ compareConstName oFun+          , ordFunRhs+          ]+#if defined(NEW_FUNCTOR_CLASSES)+            ++ map varE ords+#endif+            ++ [varE v1, varE v2]++makeOrdFunForCon :: OrdFun+                 -> Name+                 -> Name+                 -> [Name]+                 -> Bool+                 -> Int -> Name+                 -> Int -> Name+                 -> Int -> Con+                 -> Q Match+makeOrdFunForCon oFun v2 v2Hash ords singleConType+                 firstTag firstConName lastTag lastConName tag con = do+  let conName = constructorName con+  (ts, tvMap) <- reifyConTys1 (ordFunToClass oFun) ords conName+  let tsLen = length ts+  as <- newNameList "a" tsLen+  bs <- newNameList "b" tsLen++  let innerRhs :: Q Exp+      innerRhs+        | singleConType+        = caseE (varE v2) [innerEqAlt]++        | tag == firstTag+        = caseE (varE v2) [innerEqAlt, match wildP (normalB $ ltResult oFun) []]++        | tag == lastTag+        = caseE (varE v2) [innerEqAlt, match wildP (normalB $ gtResult oFun) []]++        | tag == firstTag + 1+        = caseE (varE v2) [ match (recP firstConName []) (normalB $ gtResult oFun) []+                          , innerEqAlt+                          , match wildP (normalB $ ltResult oFun) []+                          ]++        | tag == lastTag - 1+        = caseE (varE v2) [ match (recP lastConName []) (normalB $ ltResult oFun) []+                          , innerEqAlt+                          , match wildP (normalB $ gtResult oFun) []+                          ]++        | tag > lastTag `div` 2+        = untagExpr [(v2, v2Hash)] $+          condE (primOpAppExpr (varE v2Hash) ltIntHashValName tagLit)+                (gtResult oFun) $+          caseE (varE v2) [innerEqAlt, match wildP (normalB $ ltResult oFun) []]++        | otherwise+        = untagExpr [(v2, v2Hash)] $+          condE (primOpAppExpr (varE v2Hash) gtIntHashValName tagLit)+                (ltResult oFun) $+          caseE (varE v2) [innerEqAlt, match wildP (normalB $ gtResult oFun) []]++      innerEqAlt :: Q Match+      innerEqAlt = match (conP conName $ map varP bs)+                         (normalB $ makeOrdFunForFields oFun tvMap conName ts as bs)+                         []++      tagLit :: Q Exp+      tagLit = litE . integerL $ fromIntegral tag++  match (conP conName $ map varP as)+        (normalB innerRhs)+        []++makeOrdFunForFields :: OrdFun+                    -> TyVarMap1+                    -> Name+                    -> [Type]+                    -> [Name]+                    -> [Name]+                    -> Q Exp+makeOrdFunForFields oFun tvMap conName = go+  where+    go :: [Type] -> [Name] -> [Name] -> Q Exp+    go [] _ _ = eqResult oFun+    go [ty] [a] [b]+      | isSupportedUnliftedType ty = unliftedOrdFun (conTToName ty) oFun a b+      | otherwise = makeOrdFunForType oFun tvMap conName ty+                        `appE` varE a `appE` varE b+    go (ty:tys) (a:as) (b:bs) =+        mkCompare ty a b (ltResult oFun) (go tys as bs) (gtResult oFun)+    go _ _ _ = fail "Data.Ord.Deriving.Internal.makeOrdFunForFields"++    mkCompare :: Type -> Name -> Name -> Q Exp -> Q Exp -> Q Exp -> Q Exp+    mkCompare ty a b lt eq gt+      | isSupportedUnliftedType ty =+          let (ltFun, _, eqFun, _, _) = primOrdFuns $ conTToName ty+          in unliftedCompare ltFun eqFun aExpr bExpr lt eq gt+      | otherwise+      = caseE (makeOrdFunForType (ordClassToCompare $ ordFunToClass oFun)+                   tvMap conName ty `appE` aExpr `appE` bExpr)+              [ match (conP ltDataName []) (normalB lt) []+              , match (conP eqDataName []) (normalB eq) []+              , match (conP gtDataName []) (normalB gt) []+              ]+      where+        aExpr, bExpr :: Q Exp+        aExpr = varE a+        bExpr = varE b++makeOrdFunForType :: OrdFun+                  -> TyVarMap1+                  -> 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++        tyCon :: Type+        tyArgs :: [Type]+        tyCon:tyArgs = unapplyTy ty++        numLastArgs :: Int+        numLastArgs = min (arity oClass) (length tyArgs)++        lhsArgs, rhsArgs :: [Type]+        (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs++        tyVarNames :: [Name]+        tyVarNames = Map.keys tvMap++    itf <- isTyFamily tyCon+    if any (`mentionsName` tyVarNames) lhsArgs+          || itf && any (`mentionsName` tyVarNames) tyArgs+       then outOfPlaceTyVarError oClass conName+       else appsE $ [ varE . ordFunName oFun $ toEnum numLastArgs]+                    ++ map (makeOrdFunForType oFun tvMap conName) rhsArgs+#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+-------------------------------------------------------------------------------++-- | 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+    arity = fromEnum++    allowExQuant _ = True++    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)+      | otherwise              = Nothing+      where+        oMin, oMax :: Int+        oMin = fromEnum (minBound :: OrdClass)+        oMax = fromEnum oClass++compareConstName :: OrdFun -> Name+compareConstName OrdCompare       = compareConstValName+compareConstName OrdLT            = ltConstValName+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+ordFunName OrdCompare       0 = compareValName+ordFunName OrdLT            0 = ltValName+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+ordFunToClass OrdCompare       = Ord+ordFunToClass OrdLT            = Ord+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+eqResult OrdLT            = falseExpr+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+gtResult OrdLT            = falseExpr+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+ltResult OrdLT            = trueExpr+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+-------------------------------------------------------------------------------++ltTagExpr, eqTagExpr, gtTagExpr, falseExpr, trueExpr :: Q Exp+ltTagExpr = conE ltDataName+eqTagExpr = conE eqDataName+gtTagExpr = conE gtDataName+falseExpr = conE falseDataName+trueExpr  = conE trueDataName++-- Besides compare, that is+otherFuns :: OrdClass -> [Con] -> [OrdFun]+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+       -> []+  where+    firstTag, lastTag :: Int+    firstTag = 0+    lastTag  = length cons - 1++    nonNullaryCons :: [Con]+    nonNullaryCons = filterOut isNullaryCon cons++unliftedOrdFun :: Name -> OrdFun -> Name -> Name -> Q Exp+unliftedOrdFun tyName oFun a b = case oFun of+    OrdCompare       -> unliftedCompareExpr+    OrdLT            -> wrap ltFun+    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+                                          ltTagExpr eqTagExpr gtTagExpr++    ltFun, leFun, eqFun, geFun, gtFun :: Name+    (ltFun, leFun, eqFun, geFun, gtFun) = primOrdFuns tyName++    wrap :: Name -> Q Exp+    wrap primFun = primOpAppExpr aExpr primFun bExpr++    aExpr, bExpr :: Q Exp+    aExpr = varE a+    bExpr = varE b++unliftedCompare :: Name -> Name+                -> Q Exp -> Q Exp          -- What to compare+                -> Q Exp -> Q Exp -> Q Exp -- Three results+                -> Q Exp+unliftedCompare ltFun eqFun aExpr bExpr lt eq gt =+    condE (ascribeBool $ primOpAppExpr aExpr ltFun bExpr) lt $+        condE (ascribeBool $ primOpAppExpr aExpr eqFun bExpr) eq gt+  where+    ascribeBool :: Q Exp -> Q Exp+    ascribeBool e = sigE e $ conT boolTypeName++primOrdFuns :: Name -> (Name, Name, Name, Name, Name)+primOrdFuns tyName = case lookup tyName primOrdFunTbl of+    Just names -> names+    Nothing    -> error $ nameBase tyName ++ " is not supported."++primOrdFunTbl :: [(Name, (Name, Name, Name, Name, Name))]+primOrdFunTbl =+    [ (addrHashTypeName,   ( ltAddrHashValName+                           , leAddrHashValName+                           , eqAddrHashValName+                           , geAddrHashValName+                           , gtAddrHashValName+                           ))+    , (charHashTypeName,   ( ltCharHashValName+                           , leCharHashValName+                           , eqCharHashValName+                           , geCharHashValName+                           , gtCharHashValName+                           ))+    , (doubleHashTypeName, ( ltDoubleHashValName+                           , leDoubleHashValName+                           , eqDoubleHashValName+                           , geDoubleHashValName+                           , gtDoubleHashValName+                           ))+    , (floatHashTypeName,  ( ltFloatHashValName+                           , leFloatHashValName+                           , eqFloatHashValName+                           , geFloatHashValName+                           , gtFloatHashValName+                           ))+    , (intHashTypeName,    ( ltIntHashValName+                           , leIntHashValName+                           , eqIntHashValName+                           , geIntHashValName+                           , gtIntHashValName+                           ))+    , (wordHashTypeName,   ( ltWordHashValName+                           , leWordHashValName+                           , eqWordHashValName+                           , geWordHashValName+                           , gtWordHashValName+                           ))+    ]++isSupportedUnliftedType :: Type -> Bool+isSupportedUnliftedType (ConT tyName) = isJust $ lookup tyName primOrdFunTbl+isSupportedUnliftedType _             = False++isSingleton :: [a] -> Bool+isSingleton [_] = True+isSingleton _   = False++-- | Like 'filter', only it reverses the sense of the test+filterOut :: (a -> Bool) -> [a] -> [a]+filterOut _ [] = []+filterOut p (x:xs) | p x       = filterOut p xs+                   | otherwise = x : filterOut p xs

@@ -0,0 +1,94 @@+{-# LANGUAGE CPP #-}+{-|+Module:      Text.Read.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 'Read', 'Read1', and 'Read2' instances.+-}+module Text.Read.Deriving (+      -- * 'Read'+      deriveRead+    , deriveReadOptions+    , makeReadsPrec+--     , makeReadsPrecOptions+--     , makeReadList+--     , makeReadListOptions+    , makeReadPrec+--     , makeReadPrecOptions+--     , makeReadListPrec+--     , makeReadListPrecOptions+      -- * 'Read1'+    , deriveRead1+    , deriveRead1Options+#if defined(NEW_FUNCTOR_CLASSES)+    , makeLiftReadsPrec+--     , makeLiftReadsPrecOptions+--     , makeLiftReadList+--     , makeLiftReadListOptions+# if __GLASGOW_HASKELL__ >= 801+    , makeLiftReadPrec+--     , makeLiftReadPrecOptions+--     , makeLiftReadListPrec+--     , makeLiftReadListPrecOptions+    , makeReadPrec1+--     , makeReadPrec1Options+# endif+#endif+    , makeReadsPrec1+--     , makeReadsPrec1Options+#if defined(NEW_FUNCTOR_CLASSES)+      -- * 'Read2'+    , deriveRead2+    , deriveRead2Options+    , makeLiftReadsPrec2+--     , makeLiftReadsPrec2Options+--     , makeLiftReadList2+--     , makeLiftReadList2Options+# if __GLASGOW_HASKELL__ >= 801+    , makeLiftReadPrec2+--     , makeLiftReadPrec2Options+--     , makeLiftReadListPrec2+--     , makeLiftReadListPrec2Options+    , makeReadPrec2+--     , makeReadPrec2Options+# endif+    , makeReadsPrec2+--     , makeReadsPrec2Options+#endif+      -- * 'ReadOptions'+    , ReadOptions(..)+    , defaultReadOptions+      -- * 'deriveRead' limitations+      -- $constraints+    ) where++import Text.Read.Deriving.Internal++{- $constraints++Be aware of the following potential gotchas:++* Type variables of kind @*@ are assumed to have 'Read' constraints.+  Type variables of kind @* -> *@ are assumed to have 'Read1' constraints.+  Type variables of kind @* -> * -> *@ are assumed to have 'Read2' constraints.+  If this is not desirable, use 'makeReadsPrec' or one of its cousins.++* The 'Read1' class had a different definition in @transformers-0.4@, and as a result,+  'deriveRead1' implements different instances for the @transformers-0.4@ 'Read1' than+  it otherwise does. Also, 'makeLiftReadsPrec' and 'makeLiftReadList' are not available+  when this library is built against @transformers-0.4@, only 'makeReadsPrec1.++* The 'Read2' class is not available in @transformers-0.4@, and as a+  result, neither are Template Haskell functions that deal with 'Read2' when this+  library is built against @transformers-0.4@.++* The 'Read1' and 'Read2' classes have new methods ('liftReadPrec'/'liftReadListPrec'+  and 'liftReadPrec2'/'liftReadListPrec2', respectively) that were introduced in+  @base-4.10@. For now, these methods are only defined when deriving 'Read1'/'Read2'+  if built against @base-4.10@ (until @transformers-compat@ catches up), and+  the corresponding @make-@ functions are also only available when built against+  @base-4.10@.+-}

@@ -0,0 +1,911 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-|+Module:      Text.Read.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 'Read', 'Read1', and 'Read2' instances.+-}+module Text.Read.Deriving.Internal (+      -- * 'Read'+      deriveRead+    , deriveReadOptions+    , makeReadsPrec+--     , makeReadsPrecOptions+--     , makeReadList+--     , makeReadListOptions+    , makeReadPrec+--     , makeReadPrecOptions+--     , makeReadListPrec+--     , makeReadListPrecOptions+      -- * 'Read1'+    , deriveRead1+    , deriveRead1Options+#if defined(NEW_FUNCTOR_CLASSES)+    , makeLiftReadsPrec+--     , makeLiftReadsPrecOptions+--     , makeLiftReadList+--     , makeLiftReadListOptions+# if __GLASGOW_HASKELL__ >= 801+    , makeLiftReadPrec+--     , makeLiftReadPrecOptions+--     , makeLiftReadListPrec+--     , makeLiftReadListPrecOptions+    , makeReadPrec1+--     , makeReadPrec1Options+# endif+#endif+    , makeReadsPrec1+--     , makeReadsPrec1Options+#if defined(NEW_FUNCTOR_CLASSES)+      -- * 'Read2'+    , deriveRead2+    , deriveRead2Options+    , makeLiftReadsPrec2+--     , makeLiftReadsPrec2Options+--     , makeLiftReadList2+--     , makeLiftReadList2Options+# if __GLASGOW_HASKELL__ >= 801+    , makeLiftReadPrec2+--     , makeLiftReadPrec2Options+--     , makeLiftReadListPrec2+--     , makeLiftReadListPrec2Options+    , makeReadPrec2+--     , makeReadPrec2Options+# endif+    , makeReadsPrec2+--     , makeReadsPrec2Options+#endif+      -- * 'ReadOptions'+    , ReadOptions(..)+    , defaultReadOptions+    ) where++#if MIN_VERSION_template_haskell(2,11,0)+import           Control.Monad ((<=<))+import           Data.Maybe (fromMaybe, isJust)+#endif++import           Data.Deriving.Internal+import           Data.List (intersperse, partition)+import qualified Data.Map as Map++import           GHC.Show (appPrec, appPrec1)++import           Language.Haskell.TH.Lib+import           Language.Haskell.TH.Syntax++#if defined(MIN_VERSION_ghc_boot)+import           GHC.Lexeme (startsConSym, startsVarSym)+#else+import           Data.Char (isSymbol, ord)+#endif++-- | Options that further configure how the functions in "Text.Read.Deriving"+-- should behave.+newtype ReadOptions = ReadOptions+  { useReadPrec :: Bool+    -- ^ If 'True':+    --+    -- * Derived 'Read' instances will implement 'readPrec', not 'readsPrec', and+    --   will provide a default implementation of 'readListPrec' in terms of+    --   'readPrec'.+    --+    -- * If built against @base-4.10@ or later, derived 'Read1'/'Read2'+    --   instances will implement 'liftReadPrec'/'liftReadPrec2', not+    --   'liftReadsPrec'/'liftReadsPrec2', and will provide default implementations+    --   of 'liftReadListPrec'/'liftReadListPrec2' in terms of+    --   'liftReadPrec'/'liftReadPrec2'. If built against an earlier version of+    --   @base@, derived 'Read1'/'Read2' instances are not affected, so they will+    --   act as if this flag were 'False'.+    --+    -- If 'False':+    --+    -- * Derived 'Read' instances will implement 'readsPrec'.+    --+    -- * Derived 'Read1' instances will implement 'readsPrec1' (if built against+    --   @transformers-0.4@) or 'liftReadsPrec' (otherwise). If not built against+    --   @transformers-0.4@, derived 'Read2' instances will implement+    --   'liftReadsPrec2'.+    --+    -- It's generally a good idea to enable this option, since 'readPrec' and+    -- friends are more efficient than 'readsPrec' and friends, since the former+    -- use the efficient 'ReadPrec' parser datatype while the latter use the+    -- slower, list-based 'ReadS' type.+  } deriving (Eq, Ord, Read, Show)++-- | 'ReadOptions' that favor 'readPrec' over 'readsPrec'.+defaultReadOptions :: ReadOptions+defaultReadOptions = ReadOptions { useReadPrec = True }++-- | Generates a 'Read' instance declaration for the given data type or data+-- family instance.+deriveRead :: Name -> Q [Dec]+deriveRead = deriveReadOptions defaultReadOptions++-- | Like 'deriveRead', but takes a 'ReadOptions' argument.+deriveReadOptions :: ReadOptions -> Name -> Q [Dec]+deriveReadOptions = deriveReadClass Read++-- | Generates a lambda expression which behaves like 'readsPrec' (without+-- requiring a 'Read' instance).+makeReadsPrec :: Name -> Q Exp+makeReadsPrec = makeReadPrecClass Read False++-- -- | Like 'readsPrec', but takes a 'ReadOptions' argument.+-- makeReadsPrecOptions :: ReadOptions -> Name -> Q Exp+-- makeReadsPrecOptions _ = makeReadPrecClass Read False+--+-- -- | Generates a lambda expression which behaves like 'readList' (without+-- -- requiring a 'Read' instance).+-- makeReadList :: Name -> Q Exp+-- makeReadList = makeReadListOptions defaultReadOptions+--+-- -- | Like 'readList', but takes a 'ReadOptions' argument.+-- makeReadListOptions :: ReadOptions -> Name -> Q Exp+-- makeReadListOptions opts name =+--     if shouldDefineReadPrec Read opts+--        then varE readPrec_to_SValName+--             `appE` makeReadListPrecOptions opts name+--             `appE` integerE 0+--        else varE readPrec_to_SValName+--             `appE` (varE listValName `appE` makeReadPrecOptions opts name)+--             `appE` integerE 0++-- | Generates a lambda expression which behaves like 'readPrec' (without+-- requiring a 'Read' instance).+makeReadPrec :: Name -> Q Exp+makeReadPrec = makeReadPrecClass Read True++-- -- | Like 'readPrec', but takes a 'ReadOptions' argument.+-- makeReadPrecOptions :: ReadOptions -> Name -> Q Exp+-- makeReadPrecOptions _ = makeReadPrecClass Read True+--+-- -- | Generates a lambda expression which behaves like 'readListPrec' (without+-- -- requiring a 'Read' instance).+-- makeReadListPrec :: Name -> Q Exp+-- makeReadListPrec = makeReadListPrecOptions defaultReadOptions+--+-- -- | Like 'readListPrec', but takes a 'ReadOptions' argument.+-- makeReadListPrecOptions :: ReadOptions -> Name -> Q Exp+-- makeReadListPrecOptions opts name =+--     if shouldDefineReadPrec Read opts+--        then varE listValName `appE` makeReadPrecOptions opts name+--        else varE readS_to_PrecValName+--             `appE` (varE constValName `appE` makeReadListOptions opts name)++-- | Generates a 'Read1' instance declaration for the given data type or data+-- family instance.+deriveRead1 :: Name -> Q [Dec]+deriveRead1 = deriveRead1Options defaultReadOptions++-- | Like 'deriveRead1', but takes a 'ReadOptions' argument.+deriveRead1Options :: ReadOptions -> Name -> Q [Dec]+deriveRead1Options = deriveReadClass Read1++-- -- | Generates a lambda expression which behaves like 'readsPrec1' (without+-- -- requiring a 'Read1' instance).+-- 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).+--+-- This function is not available with @transformers-0.4@.+makeLiftReadsPrec :: Name -> Q Exp+makeLiftReadsPrec = makeReadPrecClass Read1 False++-- -- | Like 'makeLiftReadsPrec', but takes a 'ReadOptions' argument.+-- --+-- -- This function is not available with @transformers-0.4@.+-- makeLiftReadsPrecOptions :: ReadOptions -> Name -> Q Exp+-- makeLiftReadsPrecOptions _ = makeReadPrecClass Read1 False+--+-- -- | Generates a lambda expression which behaves like 'liftReadList' (without+-- -- requiring a 'Read1' instance).+-- --+-- -- This function is not available with @transformers-0.4@.+-- makeLiftReadList :: Name -> Q Exp+-- makeLiftReadList = makeLiftReadListOptions defaultReadOptions+--+-- -- | Like 'makeLiftReadList', but takes a 'ReadOptions' argument.+-- --+-- -- This function is not available with @transformers-0.4@.+-- makeLiftReadListOptions :: ReadOptions -> Name -> Q Exp+-- makeLiftReadListOptions = undefined++# if __GLASGOW_HASKELL__ >= 801+-- | Generates a lambda expression which behaves like 'liftReadPrec' (without+-- requiring a 'Read1' instance).+--+-- This function is only available with @base-4.10@ or later.+makeLiftReadPrec :: Name -> Q Exp+makeLiftReadPrec = makeReadPrecClass Read1 True++-- -- | Like 'makeLiftReadPrec', but takes a 'ReadOptions' argument.+-- --+-- -- This function is only available with @base-4.10@ or later.+-- makeLiftReadPrecOptions :: ReadOptions -> Name -> Q Exp+-- makeLiftReadPrecOptions _ = makeReadPrecClass Read1 True+--+-- -- | Generates a lambda expression which behaves like 'liftReadListPrec' (without+-- -- requiring a 'Read1' instance).+-- --+-- -- This function is only available with @base-4.10@ or later.+-- makeLiftReadListPrec :: Name -> Q Exp+-- makeLiftReadListPrec = makeLiftReadListPrecOptions defaultReadOptions+--+-- -- | Like 'makeLiftReadListPrec', but takes a 'ReadOptions' argument.+-- --+-- -- This function is only available with @base-4.10@ or later.+-- makeLiftReadListPrecOptions :: ReadOptions -> Name -> Q Exp+-- makeLiftReadListPrecOptions = undefined++-- | Generates a lambda expression which behaves like 'readPrec1' (without+-- requiring a 'Read1' instance).+--+-- This function is only available with @base-4.10@ or later.+makeReadPrec1 :: Name -> Q Exp+makeReadPrec1 name = makeLiftReadPrec name+                     `appE` varE readPrecValName+                     `appE` varE readListPrecValName++-- -- | Like 'makeReadPrec1', but takes a 'ReadOptions' argument.+-- --+-- -- This function is only available with @base-4.10@ or later.+-- makeReadPrec1Options :: ReadOptions -> Name -> Q Exp+-- makeReadPrec1Options opts name = makeLiftReadPrecOptions opts name+--                           `appE` varE readPrecValName+--                           `appE` varE readListPrecValName+# endif+-- | Generates a lambda expression which behaves like 'readsPrec1' (without+-- requiring a 'Read1' instance).+makeReadsPrec1 :: Name -> Q Exp+makeReadsPrec1 name = makeLiftReadsPrec name+                      `appE` varE readsPrecValName+                      `appE` varE readListValName++-- -- | Like 'makeReadsPrec1Options', but takes a 'ReadOptions' argument.+-- makeReadsPrec1Options :: ReadOptions -> Name -> Q Exp+-- 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.+--+-- This function is not available with @transformers-0.4@.+deriveRead2 :: Name -> Q [Dec]+deriveRead2 = deriveRead2Options defaultReadOptions++-- | Like 'deriveRead2', but takes a 'ReadOptions' argument.+--+-- This function is not available with @transformers-0.4@.+deriveRead2Options :: ReadOptions -> Name -> Q [Dec]+deriveRead2Options = deriveReadClass Read2++-- | Generates a lambda expression which behaves like 'liftReadsPrec2' (without+-- requiring a 'Read2' instance).+--+-- This function is not available with @transformers-0.4@.+makeLiftReadsPrec2 :: Name -> Q Exp+makeLiftReadsPrec2 = makeReadPrecClass Read2 False++-- -- | Like 'makeLiftReadsPrec2', but takes a 'ReadOptions' argument.+-- --+-- -- This function is not available with @transformers-0.4@.+-- makeLiftReadsPrec2Options :: ReadOptions -> Name -> Q Exp+-- makeLiftReadsPrec2Options _ = makeReadPrecClass Read2 False+--+-- -- | Generates a lambda expression which behaves like 'liftReadList2' (without+-- -- requiring a 'Read2' instance).+-- --+-- -- This function is not available with @transformers-0.4@.+-- makeLiftReadList2 :: Name -> Q Exp+-- makeLiftReadList2 = makeLiftReadList2Options defaultReadOptions+--+-- -- | Like 'makeLiftReadList2', but takes a 'ReadOptions' argument.+-- --+-- -- This function is not available with @transformers-0.4@.+-- makeLiftReadList2Options :: ReadOptions -> Name -> Q Exp+-- makeLiftReadList2Options opts name = do+--     let rp1Expr   = VarE `fmap` newName "rp1'"+--         rl1Expr   = VarE `fmap` newName "rl1'"+--         rp2Expr   = VarE `fmap` newName "rp2'"+--         rl2Expr   = VarE `fmap` newName "rl2'"+--     let rp2sExpr  = varE readPrec_to_SValName+--         rs2pExpr  = varE readS_to_PrecValName+--         constExpr = varE constValName+--     if shouldDefineReadPrec Read2 opts+--        then rp2sExpr+--             `appE` (makeLiftReadListPrec2Options opts name+--                     `appE` (rs2pExpr `appE` rp1Expr)+--                     `appE` (rs2pExpr `appE` (constExpr `appE` rl1Expr))+--                     `appE` (rs2pExpr `appE` rp2Expr)+--                     `appE` (rs2pExpr `appE` (constExpr `appE` rl2Expr)))+--             `appE` integerE 0+--        else rp2sExpr `appE` (varE listValName+--             `appE` (makeLiftReadPrec2Options opts name+--                     `appE` (rs2pExpr `appE` rp1Expr)+--                     `appE` (rs2pExpr `appE` (constExpr `appE` rl1Expr))+--                     `appE` (rs2pExpr `appE` rp2Expr)+--                     `appE` (rs2pExpr `appE` (constExpr `appE` rl2Expr))))+--             `appE` integerE 0++# if __GLASGOW_HASKELL__ >= 801+-- | Generates a lambda expression which behaves like 'liftReadPrec2' (without+-- requiring a 'Read2' instance).+--+-- This function is only available with @base-4.10@ or later.+makeLiftReadPrec2 :: Name -> Q Exp+makeLiftReadPrec2 = makeReadPrecClass Read2 True++-- -- | Like 'makeLiftReadPrec2', but takes a 'ReadOptions' argument.+-- --+-- -- This function is only available with @base-4.10@ or later.+-- makeLiftReadPrec2Options :: ReadOptions -> Name -> Q Exp+-- makeLiftReadPrec2Options _ = makeReadPrecClass Read2 True+--+-- -- | Generates a lambda expression which behaves like 'liftReadListPrec2' (without+-- -- requiring a 'Read2' instance).+-- --+-- -- This function is only available with @base-4.10@ or later.+-- makeLiftReadListPrec2 :: Name -> Q Exp+-- makeLiftReadListPrec2 = makeLiftReadListPrec2Options defaultReadOptions+--+-- -- | Like 'makeLiftReadListPrec2', but takes a 'ReadOptions' argument.+-- --+-- -- This function is only available with @base-4.10@ or later.+-- makeLiftReadListPrec2Options :: ReadOptions -> Name -> Q Exp+-- makeLiftReadListPrec2Options = undefined++-- | Generates a lambda expression which behaves like 'readPrec2' (without+-- requiring a 'Read2' instance).+--+-- This function is only available with @base-4.10@ or later.+makeReadPrec2 :: Name -> Q Exp+makeReadPrec2 name = makeLiftReadPrec2 name+                     `appE` varE readPrecValName+                     `appE` varE readListPrecValName+                     `appE` varE readPrecValName+                     `appE` varE readListPrecValName++-- -- | Like 'makeReadPrec2', but takes a 'ReadOptions' argument.+-- --+-- -- This function is only available with @base-4.10@ or later.+-- makeReadPrec2Options :: ReadOptions -> Name -> Q Exp+-- makeReadPrec2Options opts name = makeLiftReadPrec2Options opts name+--                           `appE` varE readPrecValName+--                           `appE` varE readListPrecValName+--                           `appE` varE readPrecValName+--                           `appE` varE readListPrecValName+# endif++-- | Generates a lambda expression which behaves like 'readsPrec2' (without+-- requiring a 'Read2' instance).+--+-- This function is not available with @transformers-0.4@.+makeReadsPrec2 :: Name -> Q Exp+makeReadsPrec2 name = makeLiftReadsPrec2 name+                      `appE` varE readsPrecValName+                      `appE` varE readListValName+                      `appE` varE readsPrecValName+                      `appE` varE readListValName++-- -- | Like 'makeReadsPrec2', but takes a 'ReadOptions' argument.+-- --+-- -- This function is not available with @transformers-0.4@.+-- makeReadsPrec2Options :: ReadOptions -> Name -> Q Exp+-- makeReadsPrec2Options opts name = makeLiftReadsPrec2Options opts name+--                           `appE` varE readsPrecValName+--                           `appE` varE readListValName+--                           `appE` varE readsPrecValName+--                           `appE` varE readListValName+#endif++-------------------------------------------------------------------------------+-- Code generation+-------------------------------------------------------------------------------++-- | Derive a Read(1)(2) instance declaration (depending on the ReadClass+-- argument's value).+deriveReadClass :: ReadClass -> ReadOptions -> Name -> Q [Dec]+deriveReadClass rClass opts 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 rClass name' ctxt tvbs mbTys+        instanceD (return instanceCxt)+                  (return instanceType)+                  (readPrecDecs rClass opts cons)++-- | Generates a declaration defining the primary function corresponding to a+-- particular class (read(s)Prec for Read, liftRead(s)Prec for Read1, and+-- liftRead(s)Prec2 for Read2).+readPrecDecs :: ReadClass -> ReadOptions -> [Con] -> [Q Dec]+readPrecDecs rClass opts cons =+    [ funD ((if defineReadPrec then readPrecName else readsPrecName) rClass)+           [ clause []+                    (normalB $ makeReadForCons rClass defineReadPrec cons)+                    []+           ]+    ] ++ if defineReadPrec+            then [ funD (readListPrecName rClass)+                        [ clause []+                                 (normalB . varE $ readListPrecDefaultName rClass)+                                 []+                        ]+                 ]+            else []+  where+    defineReadPrec :: Bool+    defineReadPrec = shouldDefineReadPrec rClass opts++-- | Generates a lambda expression which behaves like read(s)Prec (for Read),+-- liftRead(s)Prec (for Read1), or liftRead(s)Prec2 (for Read2).+makeReadPrecClass :: ReadClass -> Bool -> Name -> Q Exp+makeReadPrecClass rClass urp 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+        -- read(s)Prec/liftRead(s)Prec/etc. implemented for it, and produces errors+        -- if it can't.+        buildTypeInstance rClass name' ctxt tvbs mbTys+          `seq` makeReadForCons rClass urp cons++-- | Generates a lambda expression for read(s)Prec/liftRead(s)Prec/etc. for the+-- given constructors. All constructors must be from the same type.+makeReadForCons :: ReadClass -> Bool -> [Con] -> Q Exp+makeReadForCons rClass urp cons = do+    p   <- newName "p"+    rps <- newNameList "rp" $ arity rClass+    rls <- newNameList "rl" $ arity rClass+    let rpls       = zip rps rls+        _rpsAndRls = interleave rps rls++    let nullaryCons, nonNullaryCons :: [Con]+        (nullaryCons, nonNullaryCons) = partition isNullaryCon cons++        readConsExpr :: Q Exp+        readConsExpr+          | null cons = varE pfailValName+          | otherwise = do+                readNonNullaryCons <- concatMapM (makeReadForCon rClass urp rpls)+                                                 nonNullaryCons+                foldr1 mkAlt (readNullaryCons ++ map return readNonNullaryCons)++        readNullaryCons :: [Q Exp]+        readNullaryCons = case nullaryCons of+          []    -> []+          [con]+            | nameBase (constructorName con) == "()"+           -> [varE parenValName `appE`+                    mkDoStmts [] (varE returnValName `appE` tupE [])]+            | otherwise -> [mkDoStmts (matchCon con)+                                      (resultExpr (constructorName con) [])]+          _     -> [varE chooseValName `appE` listE (map mkPair nullaryCons)]++        mkAlt :: Q Exp -> Q Exp -> Q Exp+        mkAlt e1 e2 = infixApp e1 (varE altValName) e2++        mkPair :: Con -> Q Exp+        mkPair con = tupE [ stringE $ dataConStr con+                          , resultExpr (constructorName con) []+                          ]++        matchCon :: Con -> [Q Stmt]+        matchCon con+          | isSym conStr = [symbolPat conStr]+          | otherwise    = identHPat conStr+          where+            conStr = dataConStr con++        mainRhsExpr :: Q Exp+        mainRhsExpr = varE parensValName `appE` readConsExpr++    lamE (map varP $+#if defined(NEW_FUNCTOR_CLASSES)+                     _rpsAndRls +++#endif+                     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+             ++ if urp then [] else [varE p]++makeReadForCon :: ReadClass+               -> Bool+               -> [(Name, Name)]+               -> Con+               -> Q [Exp]+makeReadForCon rClass urp rpls (NormalC conName _)  = do+    (argTys, tvMap) <- reifyConTys2 rClass rpls conName+    args <- newNameList "arg" $ length argTys+    let conStr = nameBase conName+        isTup  = isNonUnitTupleString conStr+    (readStmts, varExps) <-+        zipWithAndUnzipM (makeReadForArg rClass isTup urp tvMap conName) argTys args+    let body = resultExpr conName varExps++    e <- if isTup+            then let tupleStmts = intersperse (readPunc ",") readStmts+                 in varE parenValName `appE` mkDoStmts tupleStmts body+            else let prefixStmts = readPrefixCon conStr ++ readStmts+                 in mkParser appPrec prefixStmts body+    return [e]+makeReadForCon rClass urp rpls (RecC conName ts) = do+    (argTys, tvMap) <- reifyConTys2 rClass rpls conName+    args <- newNameList "arg" $ length argTys+    (readStmts, varExps) <- zipWith3AndUnzipM+        (\(argName, _, _) argTy arg -> makeReadForField rClass urp tvMap conName+                                           (nameBase argName) argTy arg)+        ts argTys args+    let body        = resultExpr conName varExps+        conStr      = nameBase conName+        recordStmts = readPrefixCon conStr ++ [readPunc "{"]+                      ++ concat (intersperse [readPunc ","] readStmts)+                      ++ [readPunc "}"]++    e <- mkParser appPrec1 recordStmts body+    return [e]+makeReadForCon rClass urp rpls (InfixC _ conName _) = do+    ([alTy, arTy], tvMap) <- reifyConTys2 rClass rpls conName+    al   <- newName "argL"+    ar   <- newName "argR"+    ([readStmt1, readStmt2], varExps) <-+        zipWithAndUnzipM (makeReadForArg rClass False urp tvMap conName)+                         [alTy, arTy] [al, ar]+    info <- reify conName++#if MIN_VERSION_template_haskell(2,11,0)+    conPrec <- case info of+                        DataConI{} -> do+                            fi <- fromMaybe defaultFixity <$> reifyFixity conName+                            case fi of+                                 Fixity prec _ -> return prec+#else+    let conPrec  = case info of+                        DataConI _ _ _ (Fixity prec _) -> prec+#endif+                        _ -> error $ "Text.Read.Deriving.Internal.makeReadForCon: Unsupported type: " ++ show info++    let body   = resultExpr conName varExps+        conStr = nameBase conName+        readInfixCon+          | isSym conStr = [symbolPat conStr]+          | otherwise    = [readPunc "`"] ++ identHPat conStr ++ [readPunc "`"]+        infixStmts = [readStmt1] ++ readInfixCon ++ [readStmt2]++    e <- mkParser conPrec infixStmts body+    return [e]+makeReadForCon rClass urp rpls (ForallC _ _ con) =+    makeReadForCon rClass urp rpls con+#if MIN_VERSION_template_haskell(2,11,0)+makeReadForCon rClass urp rpls (GadtC conNames ts _) =+    let con :: Name -> Q Con+        con conName = do+            mbFi <- reifyFixity conName+            return $ if startsConSym (head $ nameBase conName)+                        && length ts == 2+                        && isJust mbFi+                      then let [t1, t2] = ts in InfixC t1 conName t2+                      else NormalC conName ts++    in concatMapM (makeReadForCon rClass urp rpls <=< con) conNames+makeReadForCon rClass urp rpls (RecGadtC conNames ts _) =+    concatMapM (makeReadForCon rClass urp rpls . flip RecC ts) conNames+#endif++makeReadForArg :: ReadClass+               -> Bool+               -> Bool+               -> TyVarMap2+               -> Name+               -> Type+               -> Name+               -> Q (Q Stmt, Exp)+makeReadForArg rClass isTup urp tvMap conName ty tyExpName = do+    (rExp, varExp) <- makeReadForType rClass urp tvMap conName tyExpName False ty+    let readStmt = bindS (varP tyExpName) $+                         (if (not isTup) then appE (varE stepValName) else id) $+                            wrapReadS urp (return rExp)+    return (readStmt, varExp)++makeReadForField :: ReadClass+                 -> Bool+                 -> TyVarMap2+                 -> Name+                 -> String+                 -> Type+                 -> Name+                 -> Q ([Q Stmt], Exp)+makeReadForField rClass urp tvMap conName lblStr ty tyExpName = do+    (rExp, varExp) <- makeReadForType rClass urp tvMap conName tyExpName False ty+    let readStmt = bindS (varP tyExpName) $+                         varE resetValName `appE` wrapReadS urp (return rExp)+    return (readLbl ++ [readStmt], varExp)+  where+    readLbl | isSym lblStr+            = [readPunc "(", symbolPat lblStr, readPunc ")"]+            | otherwise+            = identHPat lblStr++makeReadForType :: ReadClass+                -> Bool+                -> TyVarMap2+                -> Name+                -> Name+                -> 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]+        tyCon:tyArgs = unapplyTy ty++        numLastArgs :: Int+        numLastArgs = min (arity rClass) (length tyArgs)++        lhsArgs, rhsArgs :: [Type]+        (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs++        tyVarNames :: [Name]+        tyVarNames = Map.keys tvMap++    itf <- isTyFamily tyCon+    if any (`mentionsName` tyVarNames) lhsArgs+          || itf && any (`mentionsName` tyVarNames) tyArgs+       then outOfPlaceTyVarError rClass conName+       else do+        readExp <- appsE $ [ varE . readsOrReadName urp rl $ toEnum numLastArgs]+                   ++ zipWith (\b -> fmap fst+                                   . makeReadForType rClass urp tvMap conName tyExpName b)+                              (cycle [False,True])+                              (interleave rhsArgs rhsArgs)+        return (readExp, 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+-------------------------------------------------------------------------------++-- | 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+    arity = fromEnum++    allowExQuant _ = False++    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)+      | otherwise              = Nothing+      where+        rMin, rMax :: Int+        rMin = fromEnum (minBound :: ReadClass)+        rMax = fromEnum rClass++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+                    -> Name+readsPrecOrListName False = readsPrecName+readsPrecOrListName True  = readListName++readPrecOrListName :: Bool -- ^ readListPrecName if True, readPrecName if False+                   -> ReadClass+                   -> Name+readPrecOrListName False = readPrecName+readPrecOrListName True  = readListPrecName++readsOrReadName :: Bool -- ^ readPrecOrListName if True, readsPrecOrListName if False+                -> Bool -- ^ read(s)List(Prec)Name if True, read(s)PrecName if False+                -> ReadClass+                -> Name+readsOrReadName False = readsPrecOrListName+readsOrReadName True  = readPrecOrListName++-------------------------------------------------------------------------------+-- Assorted utilities+-------------------------------------------------------------------------------++mkParser :: Int -> [Q Stmt] -> Q Exp -> Q Exp+mkParser p ss b = varE precValName `appE` integerE p `appE` mkDoStmts ss b++mkDoStmts :: [Q Stmt] -> Q Exp -> Q Exp+mkDoStmts ss b = doE (ss ++ [noBindS b])++resultExpr :: Name -> [Exp] -> Q Exp+resultExpr conName as = varE returnValName `appE` conApp+  where+    conApp :: Q Exp+    conApp = appsE $ conE conName : map return as++isSym :: String -> Bool+isSym ""      = False+isSym (c : _) = startsVarSym c || startsConSym c++#if !defined(MIN_VERSION_ghc_boot)+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++identHPat :: String -> [Q Stmt]+identHPat s+    | Just (ss, '#') <- snocView s = [identPat ss, symbolPat "#"]+    | otherwise                    = [identPat s]++bindLex :: Q Exp -> Q Stmt+bindLex pat = noBindS $ varE expectPValName `appE` pat++identPat :: String -> Q Stmt+identPat s = bindLex $ conE identDataName `appE` stringE s++symbolPat :: String -> Q Stmt+symbolPat s = bindLex $ conE symbolDataName `appE` stringE s++readPunc :: String -> Q Stmt+readPunc c = bindLex $ conE puncDataName `appE` stringE c++snocView :: [a] -> Maybe ([a],a)+        -- Split off the last element+snocView [] = Nothing+snocView xs = go [] xs+  where+      -- Invariant: second arg is non-empty+    go acc [a]    = Just (reverse acc, a)+    go acc (a:as) = go (a:acc) as+    go _   []     = error "Util: snocView"++dataConStr :: Con -> String+dataConStr = nameBase . constructorName++readPrefixCon :: String -> [Q Stmt]+readPrefixCon conStr+  | isSym conStr = [readPunc "(", symbolPat conStr, readPunc ")"]+  | otherwise    = identHPat conStr++wrapReadS :: Bool -> Q Exp -> Q Exp+wrapReadS urp e = if urp then e+                         else varE readS_to_PrecValName `appE` e++shouldDefineReadPrec :: ReadClass -> ReadOptions -> Bool+shouldDefineReadPrec rClass opts = useReadPrec opts && baseCompatible+  where+    base4'10OrLater :: Bool+#if __GLASGOW_HASKELL__ >= 801+    base4'10OrLater = True+#else+    base4'10OrLater = False+#endif++    baseCompatible :: Bool+    baseCompatible = case rClass of+        Read  -> True+        Read1 -> base4'10OrLater+#if defined(NEW_FUNCTOR_CLASSES)+        Read2 -> base4'10OrLater+#endif

@@ -40,10 +40,10 @@     , makeShowsPrec2     , makeShowsPrec2Options #endif-      -- * 'Options'-    , Options(..)-    , defaultOptions-    , legacyOptions+      -- * 'ShowOptions'+    , ShowOptions(..)+    , defaultShowOptions+    , legacyShowOptions       -- * 'deriveShow' limitations       -- $constraints     ) where

@@ -41,10 +41,10 @@     , makeShowsPrec2     , makeShowsPrec2Options #endif-      -- * 'Options'-    , Options(..)-    , defaultOptions-    , legacyOptions+      -- * 'ShowOptions'+    , ShowOptions(..)+    , defaultShowOptions+    , legacyShowOptions     ) where  #if MIN_VERSION_template_haskell(2,11,0)@@ -66,20 +66,20 @@  -- | Options that further configure how the functions in "Text.Show.Deriving" -- should behave.-newtype Options = Options+newtype ShowOptions = ShowOptions   { ghc8ShowBehavior :: Bool     -- ^ If 'True', the derived 'Show', 'Show1', or 'Show2' instance will not     --   surround the output of showing fields of unlifted types with parentheses,     --   and the output will be suffixed with hash signs (@#@).   } deriving (Eq, Ord, Read, Show) --- | Options that match the behavior of the most recent GHC release.-defaultOptions :: Options-defaultOptions = Options { ghc8ShowBehavior = True }+-- | 'ShowOptions' that match the behavior of the most recent GHC release.+defaultShowOptions :: ShowOptions+defaultShowOptions = ShowOptions { ghc8ShowBehavior = True } --- | Options that match the behavior of the installed version of GHC.-legacyOptions :: Options-legacyOptions = Options+-- | 'ShowOptions' that match the behavior of the installed version of GHC.+legacyShowOptions :: ShowOptions+legacyShowOptions = ShowOptions   { ghc8ShowBehavior = #if __GLASGOW_HASKELL__ >= 711                        True@@ -91,58 +91,58 @@ -- | Generates a 'Show' instance declaration for the given data type or data -- family instance. deriveShow :: Name -> Q [Dec]-deriveShow = deriveShowOptions defaultOptions+deriveShow = deriveShowOptions defaultShowOptions --- | Like 'deriveShow', but takes an 'Options' argument.-deriveShowOptions :: Options -> Name -> Q [Dec]+-- | Like 'deriveShow', but takes a 'ShowOptions' argument.+deriveShowOptions :: ShowOptions -> Name -> Q [Dec] deriveShowOptions = deriveShowClass Show  -- | Generates a lambda expression which behaves like 'show' (without -- requiring a 'Show' instance). makeShow :: Name -> Q Exp-makeShow = makeShowOptions defaultOptions+makeShow = makeShowOptions defaultShowOptions --- | Like 'makeShow', but takes an 'Options' argument.-makeShowOptions :: Options -> Name -> Q Exp+-- | Like 'makeShow', but takes a 'ShowOptions' argument.+makeShowOptions :: ShowOptions -> Name -> Q Exp makeShowOptions opts name = do     x <- newName "x"     lam1E (varP x) $ makeShowsPrecOptions opts name-              `appE` litE (integerL 0)-              `appE` varE x-              `appE` stringE ""+                     `appE` integerE 0+                     `appE` varE x+                     `appE` stringE ""  -- | Generates a lambda expression which behaves like 'showsPrec' (without -- requiring a 'Show' instance). makeShowsPrec :: Name -> Q Exp-makeShowsPrec = makeShowsPrecOptions defaultOptions+makeShowsPrec = makeShowsPrecOptions defaultShowOptions --- | Like 'makeShowsPrec', but takes an 'Options' argument.-makeShowsPrecOptions :: Options -> Name -> Q Exp+-- | Like 'makeShowsPrec', but takes a 'ShowOptions' argument.+makeShowsPrecOptions :: ShowOptions -> Name -> Q Exp makeShowsPrecOptions = makeShowsPrecClass Show  -- | Generates a lambda expression which behaves like 'showList' (without -- requiring a 'Show' instance). makeShowList :: Name -> Q Exp-makeShowList = makeShowListOptions defaultOptions+makeShowList = makeShowListOptions defaultShowOptions --- | Like 'makeShowList', but takes an 'Options' argument.-makeShowListOptions :: Options -> Name -> Q Exp+-- | Like 'makeShowList', but takes a 'ShowOptions' argument.+makeShowListOptions :: ShowOptions -> Name -> Q Exp makeShowListOptions opts name =-    varE showListWithValName `appE` (makeShowsPrecOptions opts name `appE` litE (integerL 0))+    varE showListWithValName `appE` (makeShowsPrecOptions opts name `appE` integerE 0)  -- | Generates a 'Show1' instance declaration for the given data type or data -- family instance. deriveShow1 :: Name -> Q [Dec]-deriveShow1 = deriveShow1Options defaultOptions+deriveShow1 = deriveShow1Options defaultShowOptions --- | Like 'deriveShow1', but takes an 'Options' argument.-deriveShow1Options :: Options -> Name -> Q [Dec]+-- | Like 'deriveShow1', but takes a 'ShowOptions' argument.+deriveShow1Options :: ShowOptions -> Name -> Q [Dec] deriveShow1Options = deriveShowClass Show1  -- | Generates a lambda expression which behaves like 'showsPrec1' (without -- requiring a 'Show1' instance). makeShowsPrec1 :: Name -> Q Exp-makeShowsPrec1 = makeShowsPrec1Options defaultOptions+makeShowsPrec1 = makeShowsPrec1Options defaultShowOptions  #if defined(NEW_FUNCTOR_CLASSES) -- | Generates a lambda expression which behaves like 'liftShowsPrec' (without@@ -150,12 +150,12 @@ -- -- This function is not available with @transformers-0.4@. makeLiftShowsPrec :: Name -> Q Exp-makeLiftShowsPrec = makeLiftShowsPrecOptions defaultOptions+makeLiftShowsPrec = makeLiftShowsPrecOptions defaultShowOptions --- | Like 'makeLiftShowsPrec', but takes an 'Options' argument.+-- | Like 'makeLiftShowsPrec', but takes a 'ShowOptions' argument. -- -- This function is not available with @transformers-0.4@.-makeLiftShowsPrecOptions :: Options -> Name -> Q Exp+makeLiftShowsPrecOptions :: ShowOptions -> Name -> Q Exp makeLiftShowsPrecOptions = makeShowsPrecClass Show1  -- | Generates a lambda expression which behaves like 'liftShowList' (without@@ -163,27 +163,27 @@ -- -- This function is not available with @transformers-0.4@. makeLiftShowList :: Name -> Q Exp-makeLiftShowList = makeLiftShowListOptions defaultOptions+makeLiftShowList = makeLiftShowListOptions defaultShowOptions --- | Like 'makeLiftShowList', but takes an 'Options' argument.+-- | Like 'makeLiftShowList', but takes a 'ShowOptions' argument. -- -- This function is not available with @transformers-0.4@.-makeLiftShowListOptions :: Options -> Name -> Q Exp+makeLiftShowListOptions :: ShowOptions -> Name -> Q Exp makeLiftShowListOptions opts name = do     sp' <- newName "sp'"     sl' <- newName "sl'"     lamE [varP sp', varP sl'] $ varE showListWithValName `appE`         (makeLiftShowsPrecOptions opts name `appE` varE sp' `appE` varE sl'-                                            `appE` litE (integerL 0))+                                            `appE` integerE 0) --- | Like 'makeShowsPrec1', but takes an 'Options' argument.-makeShowsPrec1Options :: Options -> Name -> Q Exp+-- | Like 'makeShowsPrec1', but takes a 'ShowOptions' argument.+makeShowsPrec1Options :: ShowOptions -> Name -> Q Exp makeShowsPrec1Options opts name = makeLiftShowsPrecOptions opts name                            `appE` varE showsPrecValName                            `appE` varE showListValName #else--- | Like 'makeShowsPrec1', but takes an 'Options' argument.-makeShowsPrec1Options :: Options -> Name -> Q Exp+-- | Like 'makeShowsPrec1', but takes a 'ShowOptions' argument.+makeShowsPrec1Options :: ShowOptions -> Name -> Q Exp makeShowsPrec1Options = makeShowsPrecClass Show1 #endif @@ -193,12 +193,12 @@ -- -- This function is not available with @transformers-0.4@. deriveShow2 :: Name -> Q [Dec]-deriveShow2 = deriveShow2Options defaultOptions+deriveShow2 = deriveShow2Options defaultShowOptions --- | Like 'deriveShow2', but takes an 'Options' argument.+-- | Like 'deriveShow2', but takes a 'ShowOptions' argument. -- -- This function is not available with @transformers-0.4@.-deriveShow2Options :: Options -> Name -> Q [Dec]+deriveShow2Options :: ShowOptions -> Name -> Q [Dec] deriveShow2Options = deriveShowClass Show2  -- | Generates a lambda expression which behaves like 'liftShowsPrec2' (without@@ -206,12 +206,12 @@ -- -- This function is not available with @transformers-0.4@. makeLiftShowsPrec2 :: Name -> Q Exp-makeLiftShowsPrec2 = makeLiftShowsPrec2Options defaultOptions+makeLiftShowsPrec2 = makeLiftShowsPrec2Options defaultShowOptions --- | Like 'makeLiftShowsPrec2', but takes an 'Options' argument.+-- | Like 'makeLiftShowsPrec2', but takes a 'ShowOptions' argument. -- -- This function is not available with @transformers-0.4@.-makeLiftShowsPrec2Options :: Options -> Name -> Q Exp+makeLiftShowsPrec2Options :: ShowOptions -> Name -> Q Exp makeLiftShowsPrec2Options = makeShowsPrecClass Show2  -- | Generates a lambda expression which behaves like 'liftShowList2' (without@@ -219,12 +219,12 @@ -- -- This function is not available with @transformers-0.4@. makeLiftShowList2 :: Name -> Q Exp-makeLiftShowList2 = makeLiftShowList2Options defaultOptions+makeLiftShowList2 = makeLiftShowList2Options defaultShowOptions --- | Like 'makeLiftShowList2', but takes an 'Options' argument.+-- | Like 'makeLiftShowList2', but takes a 'ShowOptions' argument. -- -- This function is not available with @transformers-0.4@.-makeLiftShowList2Options :: Options -> Name -> Q Exp+makeLiftShowList2Options :: ShowOptions -> Name -> Q Exp makeLiftShowList2Options opts name = do     sp1' <- newName "sp1'"     sl1' <- newName "sl1'"@@ -234,19 +234,19 @@         varE showListWithValName `appE`             (makeLiftShowsPrec2Options opts name `appE` varE sp1' `appE` varE sl1'                                                  `appE` varE sp2' `appE` varE sl2'-                                                 `appE` litE (integerL 0))+                                                 `appE` integerE 0)  -- | Generates a lambda expression which behaves like 'showsPrec2' (without -- requiring a 'Show2' instance). -- -- This function is not available with @transformers-0.4@. makeShowsPrec2 :: Name -> Q Exp-makeShowsPrec2 = makeShowsPrec2Options defaultOptions+makeShowsPrec2 = makeShowsPrec2Options defaultShowOptions --- | Like 'makeShowsPrec2', but takes an 'Options' argument.+-- | Like 'makeShowsPrec2', but takes a 'ShowOptions' argument. -- -- This function is not available with @transformers-0.4@.-makeShowsPrec2Options :: Options -> Name -> Q Exp+makeShowsPrec2Options :: ShowOptions -> Name -> Q Exp makeShowsPrec2Options opts name = makeLiftShowsPrec2Options opts name                            `appE` varE showsPrecValName                            `appE` varE showListValName@@ -260,7 +260,7 @@  -- | Derive a Show(1)(2) instance declaration (depending on the ShowClass -- argument's value).-deriveShowClass :: ShowClass -> Options -> Name -> Q [Dec]+deriveShowClass :: ShowClass -> ShowOptions -> Name -> Q [Dec] deriveShowClass sClass opts name = withType name fromCons   where     fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec]@@ -274,7 +274,7 @@ -- | Generates a declaration defining the primary function corresponding to a -- particular class (showsPrec for Show, liftShowsPrec for Show1, and -- liftShowsPrec2 for Show2).-showsPrecDecs :: ShowClass -> Options -> [Con] -> [Q Dec]+showsPrecDecs :: ShowClass -> ShowOptions -> [Con] -> [Q Dec] showsPrecDecs sClass opts cons =     [ funD (showsPrecName sClass)            [ clause []@@ -285,7 +285,7 @@  -- | Generates a lambda expression which behaves like showsPrec (for Show), -- liftShowsPrec (for Show1), or liftShowsPrec2 (for Show2).-makeShowsPrecClass :: ShowClass -> Options -> Name -> Q Exp+makeShowsPrecClass :: ShowClass -> ShowOptions -> Name -> Q Exp makeShowsPrecClass sClass opts name = withType name fromCons   where     fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp@@ -298,8 +298,8 @@  -- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for the -- given constructors. All constructors must be from the same type.-makeShowForCons :: ShowClass -> Options -> [Con] -> Q Exp-makeShowForCons _ _ [] = error "Must have at least one data constructor"+makeShowForCons :: ShowClass -> ShowOptions -> [Con] -> Q Exp+makeShowForCons _ _ [] = noConstructorsError makeShowForCons sClass opts cons = do     p     <- newName "p"     value <- newName "value"@@ -324,7 +324,12 @@  -- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for a -- single constructor.-makeShowForCon :: Name -> ShowClass -> Options -> [(Name, Name)] -> Con -> Q [Match]+makeShowForCon :: Name+               -> ShowClass+               -> ShowOptions+               -> [(Name, Name)]+               -> Con+               -> Q [Match] makeShowForCon _ sClass _ spls (NormalC conName []) = do     ([], _) <- reifyConTys2 sClass spls conName     m <- match@@ -344,9 +349,7 @@     m <- match            (conP conName [varP arg])            (normalB $ varE showParenValName-                       `appE` infixApp (varE p)-                                       (varE ltValName)-                                       (litE . integerL $ fromIntegral appPrec)+                       `appE` infixApp (varE p) (varE ltValName) (integerE appPrec)                        `appE` namedArg)            []     return [m]@@ -357,10 +360,10 @@     m <- if isNonUnitTuple conName          then do            let showArgs       = zipWith (makeShowForArg 0 sClass opts conName tvMap) argTys args-               parenCommaArgs = (varE showCharValName `appE` litE (charL '('))-                                : intersperse (varE showCharValName `appE` litE (charL ',')) showArgs+               parenCommaArgs = (varE showCharValName `appE` charE '(')+                                : intersperse (varE showCharValName `appE` charE ',') showArgs                mappendArgs    = foldr (`infixApp` varE composeValName)-                                      (varE showCharValName `appE` litE (charL ')'))+                                      (varE showCharValName `appE` charE ')')                                       parenCommaArgs             match (conP conName $ map varP args)@@ -378,9 +381,7 @@             match (conP conName $ map varP args)                  (normalB $ varE showParenValName-                              `appE` infixApp (varE p)-                                              (varE ltValName)-                                              (litE . integerL $ fromIntegral appPrec)+                              `appE` infixApp (varE p) (varE ltValName) (integerE appPrec)                               `appE` namedArgs)                  []     return [m]@@ -397,9 +398,9 @@                                          ]                                    )                                    (zip3 ts argTys args)-        braceCommaArgs = (varE showCharValName `appE` litE (charL '{')) : take (length showArgs - 1) showArgs+        braceCommaArgs = (varE showCharValName `appE` charE '{') : take (length showArgs - 1) showArgs         mappendArgs    = foldr (`infixApp` varE composeValName)-                               (varE showCharValName `appE` litE (charL '}'))+                               (varE showCharValName `appE` charE '}')                                braceCommaArgs         namedArgs      = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " "))                                   (varE composeValName)@@ -408,9 +409,7 @@     m <- match            (conP conName $ map varP args)            (normalB $ varE showParenValName-                        `appE` infixApp (varE p)-                                        (varE ltValName)-                                        (litE . integerL $ fromIntegral appPrec)+                        `appE` infixApp (varE p) (varE ltValName) (integerE appPrec)                         `appE` namedArgs)            []     return [m]@@ -420,7 +419,7 @@     ar   <- newName "argR"     info <- reify conName -#if __GLASGOW_HASKELL__ >= 711+#if MIN_VERSION_template_haskell(2,11,0)     conPrec <- case info of                         DataConI{} -> do                             fi <- fromMaybe defaultFixity <$> reifyFixity conName@@ -440,9 +439,7 @@      m <- match            (infixP (varP al) conName (varP ar))-           (normalB $ (varE showParenValName `appE` infixApp (varE p)-                                                             (varE ltValName)-                                                             (litE . integerL $ fromIntegral conPrec))+           (normalB $ (varE showParenValName `appE` infixApp (varE p) (varE ltValName) (integerE conPrec))                         `appE` (infixApp (makeShowForArg (conPrec + 1) sClass opts conName tvMap alTy al)                                          (varE composeValName)                                          (infixApp infixOpE@@ -473,7 +470,7 @@ -- argument of a constructor. makeShowForArg :: Int                -> ShowClass-               -> Options+               -> ShowOptions                -> Name                -> TyVarMap2                -> Type@@ -491,9 +488,7 @@           | tyName == floatHashTypeName  = showPrimE fHashDataName oneHashE           | tyName == intHashTypeName    = showPrimE iHashDataName oneHashE           | tyName == wordHashTypeName   = showPrimE wHashDataName twoHashE-          | otherwise = varE showsPrecValName-                          `appE` litE (integerL $ fromIntegral p)-                          `appE` tyVarE+          | otherwise = varE showsPrecValName `appE` integerE p `appE` tyVarE      -- Starting with GHC 7.10, data types containing unlifted types with derived Show     -- instances show hashed literals with actual hash signs, and negative hashed@@ -501,22 +496,16 @@     showPrimE :: Name -> Q Exp -> Q Exp     showPrimE con hashE       | ghc8ShowBehavior opts-      = infixApp (varE showsPrecValName-                   `appE` litE (integerL 0)-                   `appE` (conE con `appE` tyVarE))+      = infixApp (varE showsPrecValName `appE` integerE 0 `appE` (conE con `appE` tyVarE))                  (varE composeValName)                  hashE-      | otherwise = varE showsPrecValName-                      `appE` litE (integerL $ fromIntegral p)-                      `appE` (conE con `appE` tyVarE)+      | otherwise = varE showsPrecValName `appE` integerE p `appE` (conE con `appE` tyVarE)      oneHashE, twoHashE :: Q Exp-    oneHashE = varE showCharValName `appE` litE (charL '#')+    oneHashE = varE showCharValName `appE` charE '#'     twoHashE = varE showStringValName `appE` stringE "##" makeShowForArg p sClass _ conName tvMap ty tyExpName =-    makeShowForType sClass conName tvMap False ty-      `appE` litE (integerL $ fromIntegral p)-      `appE` varE tyExpName+    makeShowForType sClass conName tvMap False ty `appE` integerE p `appE` varE tyExpName  -- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for a -- specific type. The generated expression depends on the number of type variables.@@ -577,39 +566,10 @@       if mentionsName ty varNames          then lamE [varP p', varP value'] $ varE showsPrec1ValName                 `appE` varE p'-                `appE` (makeFmapApply sClass conName ty varName `appE` varE value')+                `appE` (makeFmapApplyNeg sClass conName ty varName `appE` varE value')          else varE showsPrecValName #endif -#if !defined(NEW_FUNCTOR_CLASSES)-makeFmapApply :: ShowClass -> Name -> Type -> Name -> Q Exp-makeFmapApply sClass conName (SigT ty _) name = makeFmapApply sClass conName ty name-makeFmapApply sClass conName t name = do-    let tyCon :: Type-        tyArgs :: [Type]-        tyCon:tyArgs = unapplyTy t--        numLastArgs :: Int-        numLastArgs = min (arity sClass) (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 (conE applyDataName)-                                    (varE composeValName)-                                    (makeFmapApply sClass conName beta name)--    itf <- isTyFamily tyCon-    if any (`mentionsName` [name]) lhsArgs-          || itf && any (`mentionsName` [name]) tyArgs-       then outOfPlaceTyVarError sClass conName-       else inspectTy (head rhsArgs)-#endif- ------------------------------------------------------------------------------- -- Class-specific constants -------------------------------------------------------------------------------@@ -676,10 +636,6 @@ -- Assorted utilities ------------------------------------------------------------------------------- --- | Checks if a 'Name' represents a tuple type constructor (other than '()')-isNonUnitTuple :: Name -> Bool-isNonUnitTuple = isTupleString . nameBase- -- | Parenthesize an infix constructor name if it is being applied as a prefix -- function (e.g., data Amp a = (:&) a a) parenInfixConName :: Name -> ShowS@@ -693,7 +649,5 @@ isInfixTypeCon (':':_) = True isInfixTypeCon _       = False --- | Checks if a 'String' represents a tuple (other than '()')-isTupleString :: String -> Bool-isTupleString ('(':',':_) = True-isTupleString _           = False+charE :: Char -> Q Exp+charE = litE . charL

@@ -0,0 +1,25 @@+{-|+Module:      EqSpec+Copyright:   (C) 2015-2016 Ryan Scott+License:     BSD-style (see the file LICENSE)+Maintainer:  Ryan Scott+Portability: Template Haskell++@hspec@ tests for derived 'Eq', 'Eq1', and 'Eq2' instances.+-}+module EqSpec where++import Prelude ()+import Prelude.Compat++import Test.Hspec++import Types.EqOrd ()++-------------------------------------------------------------------------------++main :: IO ()+main = hspec spec++spec :: Spec+spec = pure ()

@@ -183,12 +183,17 @@ $(deriveTraversable ''OneTwoCompose)  instance Functor (f Int Int) => Functor (ComplexConstraint f g a) where-    fmap    = $(makeFmap      ''ComplexConstraint)+    fmap      = $(makeFmap      ''ComplexConstraint) instance Foldable (f Int Int) => Foldable (ComplexConstraint f g a) where-    foldr   = $(makeFoldr     ''ComplexConstraint)-    foldMap = $(makeFoldMap   ''ComplexConstraint)+    foldr     = $(makeFoldr     ''ComplexConstraint)+    foldMap   = $(makeFoldMap   ''ComplexConstraint)+    fold      = $(makeFold      ''ComplexConstraint)+    foldl     = $(makeFoldl     ''ComplexConstraint) instance Traversable (f Int Int) => Traversable (ComplexConstraint f g a) where-    traverse = $(makeTraverse ''ComplexConstraint)+    traverse  = $(makeTraverse  ''ComplexConstraint)+    sequenceA = $(makeSequenceA ''ComplexConstraint)+    mapM      = $(makeMapM      ''ComplexConstraint)+    sequence  = $(makeSequence  ''ComplexConstraint)  $(deriveFunctor     ''Universal) @@ -221,12 +226,17 @@ $(deriveTraversable 'OneTwoComposeFam)  instance Functor (f Int Int) => Functor (ComplexConstraintFam f g a) where-    fmap    = $(makeFmap      'ComplexConstraintFam)+    fmap      = $(makeFmap      'ComplexConstraintFam) instance Foldable (f Int Int) => Foldable (ComplexConstraintFam f g a) where-    foldr   = $(makeFoldr     'ComplexConstraintFam)-    foldMap = $(makeFoldMap   'ComplexConstraintFam)+    foldr     = $(makeFoldr     'ComplexConstraintFam)+    foldMap   = $(makeFoldMap   'ComplexConstraintFam)+    fold      = $(makeFold      'ComplexConstraintFam)+    foldl     = $(makeFoldl     'ComplexConstraintFam) instance Traversable (f Int Int) => Traversable (ComplexConstraintFam f g a) where-    traverse = $(makeTraverse 'ComplexConstraintFam)+    traverse  = $(makeTraverse  'ComplexConstraintFam)+    sequenceA = $(makeSequenceA 'ComplexConstraintFam)+    mapM      = $(makeMapM      'ComplexConstraintFam)+    sequence  = $(makeSequence  'ComplexConstraintFam)  $(deriveFunctor     'UniversalFam) 

@@ -0,0 +1,26 @@+{-|+Module:      OrdSpec+Copyright:   (C) 2015-2016 Ryan Scott+License:     BSD-style (see the file LICENSE)+Maintainer:  Ryan Scott+Portability: Template Haskell++@hspec@ tests for derived 'Ord', 'Ord1', and 'Ord2' instances.+-}+module OrdSpec where++import Prelude ()+import Prelude.Compat++import Test.Hspec++import Types.EqOrd ()++-------------------------------------------------------------------------------++main :: IO ()+main = hspec spec++spec :: Spec+spec = pure ()+

@@ -0,0 +1,72 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++{-|+Module:      ReadSpec+Copyright:   (C) 2015-2016 Ryan Scott+License:     BSD-style (see the file LICENSE)+Maintainer:  Ryan Scott+Portability: Template Haskell++@hspec@ tests for derived 'Read', 'Read1', and 'Read2' instances.+-}+module ReadSpec where++import Data.Deriving++import Prelude ()+import Prelude.Compat++import Test.Hspec++import Types.ReadShow ()++-------------------------------------------------------------------------------++-- Plain data types++data TyCon# a b = TyCon# {+    tcA# :: a+  , tcB# :: b+}++-- Data families++data family TyFamily# y z :: *++data instance TyFamily# a b = TyFamily# {+    tfA# :: a+  , tfB# :: b+}++-------------------------------------------------------------------------------++-- Plain data types++$(deriveRead  ''TyCon#)+$(deriveRead1 ''TyCon#)+#if defined(NEW_FUNCTOR_CLASSES)+$(deriveRead2 ''TyCon#)+#endif++#if MIN_VERSION_template_haskell(2,7,0)+-- Data families++$(deriveRead  'TyFamily#)+$(deriveRead1 'TyFamily#)+# if defined(NEW_FUNCTOR_CLASSES)+$(deriveRead2 'TyFamily#)+# endif+#endif++-------------------------------------------------------------------------------++main :: IO ()+main = hspec spec++spec :: Spec+spec = pure ()+

@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-}@@ -18,9 +17,6 @@ -} module ShowSpec where -#if !defined(NEW_FUNCTOR_CLASSES)-import Data.Functor.Classes (Show1(..))-#endif import Data.Deriving  import GHC.Exts (Char#, Double#, Float#, Int#, Word#)@@ -30,29 +26,12 @@  import Test.Hspec +import Types.ReadShow ()+ -------------------------------------------------------------------------------  -- Plain data types -infixl 4 :@:-data TyCon1 a b = TyConPrefix { tc1 :: a, tc2 :: b }-                | (:@:) { tc3 :: b, tc4 :: a }--infixl 3 :!!:-infix  4 :@@:-infixr 5 `TyConPlain`-infixr 6 `TyConFakeInfix`-data TyConPlain a b = (:!!:) a b-                    | a :@@: b-                    | a `TyConPlain` b-                    | TyConFakeInfix a b--data TyConGADT a b where-    (:.)    ::           c ->       d        -> TyConGADT c d-    (:..)   ::           e ->       f        -> TyConGADT e f-    (:...)  ::           g ->       h -> Int -> TyConGADT g h-    (:....) :: { tcg1 :: i, tcg2 :: j }      -> TyConGADT i j- data TyCon# a b = TyCon# {     tcA       :: a   , tcB       :: b@@ -81,39 +60,8 @@                              => p -> q -> u -> t                              -> TyCon2 r s t u -data TyConWrap f g h a = TyConWrap1 (f a)-                       | TyConWrap2 (f (g a))-                       | TyConWrap3 (f (g (h a)))- -- Data families -data family TyFamily1 y z :: *--infixl 4 :!:-data instance TyFamily1 a b = TyFamilyPrefix { tf1 :: a, tf2 :: b }-                            | (:!:)          { tf3 :: b, tf4 :: a }--data family TyFamilyPlain y z :: *--infixl 3 :#:-infix  4 :$:-infixr 5 `TyFamilyPlain`-infixr 6 `TyFamilyFakeInfix`-data instance TyFamilyPlain a b = (:#:) a b-                                 | a :$: b-                                 | a `TyFamilyPlain` b-                                 | TyFamilyFakeInfix a b---data family TyFamilyGADT y z :: *--infixr 1 :*, :***, :****-data instance TyFamilyGADT a b where-    (:*)    ::           c ->       d        -> TyFamilyGADT c d-    (:**)   ::           e ->       f        -> TyFamilyGADT e f-    (:***)  ::           g ->       h -> Int -> TyFamilyGADT g h-    (:****) :: { tfg1 :: i, tfg2 :: j }      -> TyFamilyGADT i j- data family TyFamily# y z :: *  data instance TyFamily# a b = TyFamily# {@@ -146,42 +94,17 @@                                 => p -> q -> u -> t                                 -> TyFamily2 r s t u -data family TyFamilyWrap (w :: * -> *) (x :: * -> *) (y :: * -> *) z :: *--data instance TyFamilyWrap f g h a = TyFamilyWrap1 (f a)-                                   | TyFamilyWrap2 (f (g a))-                                   | TyFamilyWrap3 (f (g (h a)))- -------------------------------------------------------------------------------  -- Plain data types -$(deriveShow  ''TyCon1)-$(deriveShow  ''TyConPlain)-$(deriveShow  ''TyConGADT) $(deriveShow  ''TyCon#) $(deriveShow  ''TyCon2)-instance (Show (f a), Show (f (g a)), Show (f (g (h a))))-  => Show (TyConWrap f g h a) where-    showsPrec = $(makeShowsPrec ''TyConWrap) -$(deriveShow1 ''TyCon1)-$(deriveShow1 ''TyConPlain)-$(deriveShow1 ''TyConGADT) $(deriveShow1 ''TyCon#) $(deriveShow1 ''TyCon2)-#if defined(NEW_FUNCTOR_CLASSES)-$(deriveShow1 ''TyConWrap)-#else-instance (Show1 f, Functor f, Show1 g, Functor g, Show1 h)-  => Show1 (TyConWrap f g h) where-    showsPrec1 = $(makeShowsPrec1 ''TyConWrap)-#endif  #if defined(NEW_FUNCTOR_CLASSES)-$(deriveShow2 ''TyCon1)-$(deriveShow2 ''TyConPlain)-$(deriveShow2 ''TyConGADT) $(deriveShow2 ''TyCon#) $(deriveShow2 ''TyCon2) #endif@@ -189,32 +112,13 @@ #if MIN_VERSION_template_haskell(2,7,0) -- Data families -$(deriveShow  'TyFamilyPrefix)-$(deriveShow  '(:#:))-$(deriveShow  '(:*)) $(deriveShow  'TyFamily#) $(deriveShow  'TyFamilyClassConstraints)-instance (Show (f a), Show (f (g a)), Show (f (g (h a))))-  => Show (TyFamilyWrap f g h a) where-    showsPrec = $(makeShowsPrec 'TyFamilyWrap1) -$(deriveShow1 '(:!:))-$(deriveShow1 '(:$:))-$(deriveShow1 '(:**)) $(deriveShow1 'TyFamily#) $(deriveShow1 'TyFamilyEqualityConstraints)-# if defined(NEW_FUNCTOR_CLASSES)-$(deriveShow1 'TyFamilyWrap2)-# else-instance (Show1 f, Functor f, Show1 g, Functor g, Show1 h)-  => Show1 (TyFamilyWrap f g h) where-    showsPrec1 = $(makeShowsPrec1 'TyFamilyWrap3)-# endif  # if defined(NEW_FUNCTOR_CLASSES)-$(deriveShow2 'TyFamilyPrefix)-$(deriveShow2 'TyFamilyPlain)-$(deriveShow2 '(:***)) $(deriveShow2 'TyFamily#) $(deriveShow2 'TyFamilyTypeRefinement1) # endif

@@ -0,0 +1,236 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++{-|+Module:      Types.EqOrd+Copyright:   (C) 2015-2016 Ryan Scott+License:     BSD-style (see the file LICENSE)+Maintainer:  Ryan Scott+Portability: Template Haskell++Shared datatypes between "EqSpec" and "OrdSpec".+-}+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#)++-- Plain data types++data TyCon1 a m =+    TyCon1A a+  | TyCon1B+  | TyCon1C+  | TyCon1D+  | TyCon1E+  | TyCon1F+  | TyCon1G+  | TyCon1H+  | TyCon1I+  | TyCon1J+  | TyCon1K+  | TyCon1L+  | TyCon1M m++data TyCon# a b = TyCon# {+    tcA       :: a+  , tcB       :: b+  , tcAddr#   :: Addr#+  , tcInt#    :: Int#+  , tcFloat#  :: Float#+  , tcDouble# :: Double#+  , tcChar#   :: Char#+  , tcWord#   :: Word#+}++data TyCon2 a b c d where+    TyConClassConstraints    :: (Show m, Show n, Show o, Show p)+                             => m -> n -> o -> p+                             -> TyCon2 m n o p++    TyConEqualityConstraints :: (e ~ g, f ~ h, e ~ f)+                                => e -> f -> g -> h+                             -> TyCon2 e f g h++    TyConTypeRefinement1,+      TyConTypeRefinement2   :: Int -> z+                             -> TyCon2 Int Int z z++data TyConWrap f g h a = TyConWrap1 (f a)+                       | TyConWrap2 (f (g a))+                       | TyConWrap3 (f (g (h a)))++-- Data families++data family TyFamily1 y z :: *++data instance TyFamily1 a m =+    TyFamily1A a+  | TyFamily1B+  | TyFamily1C+  | TyFamily1D+  | TyFamily1E+  | TyFamily1F+  | TyFamily1G+  | TyFamily1H+  | TyFamily1I+  | TyFamily1J+  | TyFamily1K+  | TyFamily1L+  | TyFamily1M m++data family TyFamily# y z :: *++data instance TyFamily# a b = TyFamily# {+    tfA       :: a+  , tfB       :: b+  , tfInt#    :: Int#+  , tfFloat#  :: Float#+  , tfDouble# :: Double#+  , tfChar#   :: Char#+  , tfWord#   :: Word#+}++data family TyFamily2 w x y z :: *++data instance TyFamily2 a b c d where+    TyFamilyClassConstraints    :: (Show m, Show n, Show o, Show p)+                                => m -> n -> o -> p+                                -> TyFamily2 m n o p++    TyFamilyEqualityConstraints :: (e ~ g, f ~ h, e ~ f)+                                => e -> f -> g -> h+                                -> TyFamily2 e f g h++    TyFamilyTypeRefinement1,+      TyFamilyTypeRefinement2   :: Int -> z+                                -> TyFamily2 Int Int z z++data family TyFamilyWrap (w :: * -> *) (x :: * -> *) (y :: * -> *) z :: *++data instance TyFamilyWrap f g h a = TyFamilyWrap1 (f a)+                                   | TyFamilyWrap2 (f (g a))+                                   | TyFamilyWrap3 (f (g (h a)))++-------------------------------------------------------------------------------++-- Plain data types++$(deriveEq  ''TyCon1)+$(deriveEq  ''TyCon#)+$(deriveEq  ''TyCon2)+instance (Eq (f a), Eq (f (g a)), Eq (f (g (h a))))+  => Eq (TyConWrap f g h a) where+    (==) = $(makeEq    ''TyConWrap)+    (/=) = $(makeNotEq ''TyConWrap)++$(deriveEq1 ''TyCon1)+$(deriveEq1 ''TyCon#)+$(deriveEq1 ''TyCon2)++$(deriveOrd  ''TyCon1)+$(deriveOrd  ''TyCon#)+$(deriveOrd  ''TyCon2)+instance (Ord (f a), Ord (f (g a)), Ord (f (g (h a))))+  => Ord (TyConWrap f g h a) where+    compare = $(makeCompare ''TyConWrap)+    (>)     = $(makeLT      ''TyConWrap)+    (>=)    = $(makeLE      ''TyConWrap)+    (<)     = $(makeGT      ''TyConWrap)+    (<=)    = $(makeGE      ''TyConWrap)+    max     = $(makeMax     ''TyConWrap)+    min     = $(makeMin     ''TyConWrap)++$(deriveOrd1 ''TyCon1)+$(deriveOrd1 ''TyCon#)+$(deriveOrd1 ''TyCon2)++#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)++$(deriveOrd2 ''TyCon1)+$(deriveOrd2 ''TyCon#)+$(deriveOrd2 ''TyCon2)+#endif++#if MIN_VERSION_template_haskell(2,7,0)+-- Data families++$(deriveEq  'TyFamily1A)+$(deriveEq  'TyFamily#)+$(deriveEq  'TyFamilyClassConstraints)+instance (Eq (f a), Eq (f (g a)), Eq (f (g (h a))))+  => Eq (TyFamilyWrap f g h a) where+    (==) = $(makeEq    'TyFamilyWrap1)+    (/=) = $(makeNotEq 'TyFamilyWrap1)++$(deriveEq1 'TyFamily1B)+$(deriveEq1 'TyFamily#)+$(deriveEq1 'TyFamilyEqualityConstraints)++$(deriveOrd  'TyFamily1A)+$(deriveOrd  'TyFamily#)+$(deriveOrd  'TyFamilyClassConstraints)+instance (Ord (f a), Ord (f (g a)), Ord (f (g (h a))))+  => Ord (TyFamilyWrap f g h a) where+    compare = $(makeCompare 'TyFamilyWrap1)+    (>)     = $(makeLT      'TyFamilyWrap1)+    (>=)    = $(makeLE      'TyFamilyWrap1)+    (<)     = $(makeGT      'TyFamilyWrap1)+    (<=)    = $(makeGE      'TyFamilyWrap1)+    max     = $(makeMax     'TyFamilyWrap1)+    min     = $(makeMin     'TyFamilyWrap1)++$(deriveOrd1 'TyFamily1B)+$(deriveOrd1 'TyFamily#)+$(deriveOrd1 'TyFamilyEqualityConstraints)++#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++# if defined(NEW_FUNCTOR_CLASSES)+$(deriveEq2 'TyFamily1C)+$(deriveEq2 'TyFamily#)+$(deriveEq2 'TyFamilyTypeRefinement1)++$(deriveOrd2 'TyFamily1C)+$(deriveOrd2 'TyFamily#)+$(deriveOrd2 'TyFamilyTypeRefinement1)+# endif+#endif

@@ -0,0 +1,191 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++{-|+Module:      Types.ReadShow+Copyright:   (C) 2015-2016 Ryan Scott+License:     BSD-style (see the file LICENSE)+Maintainer:  Ryan Scott+Portability: Template Haskell++Shared datatypes between "ReadSpec" and "ShowSpec".+-}+module Types.ReadShow where++#if !defined(NEW_FUNCTOR_CLASSES)+import Data.Functor.Classes (Read1(..), Show1(..))+#endif+import Data.Deriving++import Text.Read (Read(..), readListPrecDefault)++-------------------------------------------------------------------------------++-- Plain data types++infixl 4 :@:+data TyCon1 a b = TyConPrefix { tc1 :: a, tc2 :: b }+                | (:@:) { tc3 :: b, tc4 :: a }++infixl 3 :!!:+infix  4 :@@:+infixr 5 `TyConPlain`+infixr 6 `TyConFakeInfix`+data TyConPlain a b = (:!!:) a b+                    | a :@@: b+                    | a `TyConPlain` b+                    | TyConFakeInfix a b++data TyConGADT a b where+    (:.)    ::           c ->       d        -> TyConGADT c d+    (:..)   ::           e ->       f        -> TyConGADT e f+    (:...)  ::           g ->       h -> Int -> TyConGADT g h+    (:....) :: { tcg1 :: i, tcg2 :: j }      -> TyConGADT i j++data TyConWrap f g h a = TyConWrap1 (f a)+                       | TyConWrap2 (f (g a))+                       | TyConWrap3 (f (g (h a)))++-- Data families++data family TyFamily1 y z :: *++infixl 4 :!:+data instance TyFamily1 a b = TyFamilyPrefix { tf1 :: a, tf2 :: b }+                            | (:!:)          { tf3 :: b, tf4 :: a }++data family TyFamilyPlain y z :: *++infixl 3 :#:+infix  4 :$:+infixr 5 `TyFamilyPlain`+infixr 6 `TyFamilyFakeInfix`+data instance TyFamilyPlain a b = (:#:) a b+                                 | a :$: b+                                 | a `TyFamilyPlain` b+                                 | TyFamilyFakeInfix a b+++data family TyFamilyGADT y z :: *++infixr 1 :*, :***, :****+data instance TyFamilyGADT a b where+    (:*)    ::           c ->       d        -> TyFamilyGADT c d+    (:**)   ::           e ->       f        -> TyFamilyGADT e f+    (:***)  ::           g ->       h -> Int -> TyFamilyGADT g h+    (:****) :: { tfg1 :: i, tfg2 :: j }      -> TyFamilyGADT i j++data family TyFamilyWrap (w :: * -> *) (x :: * -> *) (y :: * -> *) z :: *++data instance TyFamilyWrap f g h a = TyFamilyWrap1 (f a)+                                   | TyFamilyWrap2 (f (g a))+                                   | TyFamilyWrap3 (f (g (h a)))++-------------------------------------------------------------------------------++-- Plain data types++$(deriveRead  ''TyCon1)+$(deriveRead  ''TyConPlain)+$(deriveRead  ''TyConGADT)+instance (Read (f a), Read (f (g a)), Read (f (g (h a))))+  => Read (TyConWrap f g h a) where+    readPrec     = $(makeReadPrec ''TyConWrap)+    readListPrec = readListPrecDefault++$(deriveRead1 ''TyCon1)+$(deriveRead1 ''TyConPlain)+$(deriveRead1 ''TyConGADT)++$(deriveShow  ''TyCon1)+$(deriveShow  ''TyConPlain)+$(deriveShow  ''TyConGADT)+instance (Show (f a), Show (f (g a)), Show (f (g (h a))))+  => Show (TyConWrap f g h a) where+    showsPrec = $(makeShowsPrec ''TyConWrap)+    show      = $(makeShow      ''TyConWrap)+    showList  = $(makeShowList  ''TyConWrap)++$(deriveShow1 ''TyCon1)+$(deriveShow1 ''TyConPlain)+$(deriveShow1 ''TyConGADT)++#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++#if defined(NEW_FUNCTOR_CLASSES)+$(deriveRead2 ''TyCon1)+$(deriveRead2 ''TyConPlain)+$(deriveRead2 ''TyConGADT)++$(deriveShow2 ''TyCon1)+$(deriveShow2 ''TyConPlain)+$(deriveShow2 ''TyConGADT)+#endif++#if MIN_VERSION_template_haskell(2,7,0)+-- Data families++$(deriveRead  'TyFamilyPrefix)+$(deriveRead  '(:#:))+$(deriveRead  '(:*))+instance (Read (f a), Read (f (g a)), Read (f (g (h a))))+  => Read (TyFamilyWrap f g h a) where+    readsPrec = $(makeReadsPrec 'TyFamilyWrap1)++$(deriveRead1 '(:!:))+$(deriveRead1 '(:$:))+$(deriveRead1 '(:**))++$(deriveShow  'TyFamilyPrefix)+$(deriveShow  '(:#:))+$(deriveShow  '(:*))+instance (Show (f a), Show (f (g a)), Show (f (g (h a))))+  => Show (TyFamilyWrap f g h a) where+    showsPrec = $(makeShowsPrec 'TyFamilyWrap1)+    show      = $(makeShow      'TyFamilyWrap1)+    showList  = $(makeShowList  'TyFamilyWrap1)++$(deriveShow1 '(:!:))+$(deriveShow1 '(:$:))+$(deriveShow1 '(:**))++# 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++# if defined(NEW_FUNCTOR_CLASSES)+$(deriveRead2 'TyFamilyPrefix)+$(deriveRead2 'TyFamilyPlain)+$(deriveRead2 '(:***))++$(deriveShow2 'TyFamilyPrefix)+$(deriveShow2 'TyFamilyPlain)+$(deriveShow2 '(:***))+# endif+#endif