diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +### 0.3.1 +* Allow deriving `Functor` and `Foldable` instances for datatypes containing unboxed tuples +* Microoptimization in derived instances of higher-order versions of `Eq`, `Ord`, `Read`, and `Show` + ## 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. diff --git a/deriving-compat.cabal b/deriving-compat.cabal --- a/deriving-compat.cabal +++ b/deriving-compat.cabal @@ -1,5 +1,5 @@ name: deriving-compat -version: 0.3 +version: 0.3.1 synopsis: Backports of GHC deriving extensions description: Provides Template Haskell functions that mimic deriving extensions that were introduced or modified in recent versions @@ -137,7 +137,7 @@ Types.ReadShow build-depends: base-compat >= 0.8.1 && < 1 , base-orphans >= 0.5 && < 1 - , deriving-compat == 0.3 + , deriving-compat == 0.3.1 , hspec >= 1.8 , QuickCheck >= 2 && < 3 diff --git a/src/Data/Deriving/Internal.hs b/src/Data/Deriving/Internal.hs --- a/src/Data/Deriving/Internal.hs +++ b/src/Data/Deriving/Internal.hs @@ -55,6 +55,12 @@ import Language.Haskell.TH.Ppr (pprint) import Language.Haskell.TH.Syntax +-- Ensure, beyond a shadow of a doubt, that the instances are in-scope +import Data.Functor () +import Data.Functor.Classes () +import Data.Foldable () +import Data.Traversable () + #ifndef CURRENT_PACKAGE_KEY import Data.Version (showVersion) import Paths_deriving_compat (version) diff --git a/src/Data/Eq/Deriving/Internal.hs b/src/Data/Eq/Deriving/Internal.hs --- a/src/Data/Eq/Deriving/Internal.hs +++ b/src/Data/Eq/Deriving/Internal.hs @@ -284,8 +284,10 @@ 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 if any (`mentionsName` tyVarNames) rhsArgs + then appsE $ [ varE . eqName $ toEnum numLastArgs] + ++ map (makeCaseForType eClass tvMap conName) rhsArgs + else varE eqValName #else makeCaseForType eClass tvMap conName ty = do let varNames = Map.keys tvMap diff --git a/src/Data/Functor/Deriving/Internal.hs b/src/Data/Functor/Deriving/Internal.hs --- a/src/Data/Functor/Deriving/Internal.hs +++ b/src/Data/Functor/Deriving/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-| Module: Data.Functor.Deriving.Internal @@ -261,8 +262,29 @@ mentionsTyArgs :: Bool mentionsTyArgs = any (`mentionsName` tyVarNames) tyArgs - makeFunctorFunTuple :: Type -> Name -> Q (Either Exp Exp) - makeFunctorFunTuple fieldTy fieldName = + makeFunctorFunTuple :: ([Q Pat] -> Q Pat) -> (Int -> Name) -> Int + -> Q (Either Exp Exp) + makeFunctorFunTuple mkTupP mkTupleDataName n = do + args <- mapM newName $ catMaybes [ Just "x" + , guard (ff == Foldr) >> Just "z" + ] + xs <- newNameList "_tup" n + + let x = head args + z = last args + fmap Right $ lamE (map varP args) $ caseE (varE x) + [ match (mkTupP $ map varP xs) + (normalB $ functorFunCombine ff + (mkTupleDataName n) + z + xs + (zipWithM makeFunctorFunTupleField tyArgs xs) + ) + [] + ] + + makeFunctorFunTupleField :: Type -> Name -> Q (Either Exp Exp) + makeFunctorFunTupleField fieldTy fieldName = makeFunctorFunForType ff tvMap conName covariant fieldTy `appEitherE` varE fieldName @@ -281,25 +303,12 @@ where covFunctorFun :: Bool -> Type -> Q Exp covFunctorFun cov = fmap fromEither . makeFunctorFunForType ff tvMap conName cov +#if MIN_VERSION_template_haskell(2,6,0) + UnboxedTupleT n + | n > 0 && mentionsTyArgs -> makeFunctorFunTuple unboxedTupP unboxedTupleDataName n +#endif TupleT n - | n > 0 && mentionsTyArgs -> do - args <- mapM newName $ catMaybes [ Just "x" - , guard (ff == Foldr) >> Just "z" - ] - xs <- newNameList "_tup" n - - let x = head args - z = last args - fmap Right $ lamE (map varP args) $ caseE (varE x) - [ match (tupP $ map varP xs) - (normalB $ functorFunCombine ff - (tupleDataName n) - z - xs - (zipWithM makeFunctorFunTuple tyArgs xs) - ) - [] - ] + | n > 0 && mentionsTyArgs -> makeFunctorFunTuple tupP tupleDataName n _ -> do itf <- isTyFamily tyCon if any (`mentionsName` tyVarNames) lhsArgs || (itf && mentionsTyArgs) diff --git a/src/Data/Ord/Deriving/Internal.hs b/src/Data/Ord/Deriving/Internal.hs --- a/src/Data/Ord/Deriving/Internal.hs +++ b/src/Data/Ord/Deriving/Internal.hs @@ -411,8 +411,10 @@ 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 if any (`mentionsName` tyVarNames) rhsArgs + then appsE $ [ varE . ordFunName oFun $ toEnum numLastArgs] + ++ map (makeOrdFunForType oFun tvMap conName) rhsArgs + else varE $ ordFunName oFun 0 #else makeOrdFunForType oFun tvMap conName ty = do let varNames = Map.keys tvMap diff --git a/src/Text/Read/Deriving/Internal.hs b/src/Text/Read/Deriving/Internal.hs --- a/src/Text/Read/Deriving/Internal.hs +++ b/src/Text/Read/Deriving/Internal.hs @@ -695,13 +695,15 @@ 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 if any (`mentionsName` tyVarNames) rhsArgs + then 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 return (VarE $ readsOrReadName urp rl Read, VarE tyExpName) #else makeReadForType rClass urp tvMap conName tyExpName _ ty = do let varNames = Map.keys tvMap diff --git a/src/Text/Show/Deriving/Internal.hs b/src/Text/Show/Deriving/Internal.hs --- a/src/Text/Show/Deriving/Internal.hs +++ b/src/Text/Show/Deriving/Internal.hs @@ -550,10 +550,12 @@ if any (`mentionsName` tyVarNames) lhsArgs || itf && any (`mentionsName` tyVarNames) tyArgs then outOfPlaceTyVarError sClass conName - else appsE $ [ varE . showsPrecOrListName sl $ toEnum numLastArgs] - ++ zipWith (makeShowForType sClass conName tvMap) - (cycle [False,True]) - (interleave rhsArgs rhsArgs) + else if any (`mentionsName` tyVarNames) rhsArgs + then appsE $ [ varE . showsPrecOrListName sl $ toEnum numLastArgs] + ++ zipWith (makeShowForType sClass conName tvMap) + (cycle [False,True]) + (interleave rhsArgs rhsArgs) + else varE $ if sl then showListValName else showsPrecValName #else makeShowForType sClass conName tvMap _ ty = do let varNames = Map.keys tvMap