deriving-compat 0.3.3 → 0.3.4
raw patch · 7 files changed
+75/−44 lines, 7 filesdep ~deriving-compatPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: deriving-compat
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−0
- deriving-compat.cabal +2/−2
- src/Data/Deriving.hs +5/−1
- src/Data/Deriving/Internal.hs +25/−0
- src/Text/Read/Deriving/Internal.hs +2/−21
- src/Text/Show/Deriving/Internal.hs +10/−16
- tests/Types/ReadShow.hs +27/−4
CHANGELOG.md view
@@ -1,3 +1,7 @@+### 0.3.4 [2016.10.20]+* Fix bug in which infix record selectors weren't shown with parentheses in derived `Show` instances+* Fix bug in which record selectors weren't parsed correctly in derived `Read` instances+ ### 0.3.3 [2016.09.11] * Add `Data.Bounded.Deriving`, which allows deriving `Bounded` with TH. * Add `Data.Enum.Deriving`, which allows deriving `Enum` with TH.
deriving-compat.cabal view
@@ -1,5 +1,5 @@ name: deriving-compat-version: 0.3.3+version: 0.3.4 synopsis: Backports of GHC deriving extensions description: Provides Template Haskell functions that mimic deriving extensions that were introduced or modified in recent versions@@ -151,7 +151,7 @@ Types.ReadShow build-depends: base-compat >= 0.8.1 && < 1 , base-orphans >= 0.5 && < 1- , deriving-compat == 0.3.3+ , deriving-compat == 0.3.4 , hspec >= 1.8 , QuickCheck >= 2 && < 3 , template-haskell >= 2.5 && < 2.12
src/Data/Deriving.hs view
@@ -36,8 +36,12 @@ {- $changes The following changes have been backported: +* In GHC 7.2, deriving 'Read' was changed so that constructors that use+ @MagicHash@ now parse correctly.+ * In GHC 7.8, deriving standalone 'Read' instances was fixed to avoid crashing on- datatypes with no constructors.+ datatypes with no constructors. Derived 'Read' instances were also changed so+ as to compile more quickly. * In GHC 7.10, deriving standalone 'Read' and 'Show' instances were fixed to ensure that they use the correct fixity information for a particular datatype.
src/Data/Deriving/Internal.hs view
@@ -52,6 +52,12 @@ import GHC.Prim (Int#, tagToEnum#) #endif +#if defined(MIN_VERSION_ghc_boot_th)+import GHC.Lexeme (startsConSym, startsVarSym)+#else+import Data.Char (isSymbol, ord)+#endif+ import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr (pprint) import Language.Haskell.TH.Syntax@@ -1458,6 +1464,25 @@ isNonUnitTupleString :: String -> Bool isNonUnitTupleString ('(':',':_) = True isNonUnitTupleString _ = False++-- | Checks if a 'String' names a valid Haskell infix data constructor (i.e., does+-- it begin with a colon?).+isInfixDataCon :: String -> Bool+isInfixDataCon (':':_) = True+isInfixDataCon _ = False++isSym :: String -> Bool+isSym "" = False+isSym (c : _) = startsVarSym c || startsConSym c++#if !defined(MIN_VERSION_ghc_boot_th)+startsVarSym, startsConSym :: Char -> Bool+startsVarSym c = startsVarSymASCII c || (ord c > 0x7f && isSymbol c) -- Infix Ids+startsConSym c = c == ':' -- Infix data constructors++startsVarSymASCII :: Char -> Bool+startsVarSymASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"+#endif ------------------------------------------------------------------------------- -- Manually quoted names
src/Text/Read/Deriving/Internal.hs view
@@ -78,12 +78,6 @@ 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@@ -609,7 +603,7 @@ let con :: Name -> Q Con con conName = do mbFi <- reifyFixity conName- return $ if startsConSym (head $ nameBase conName)+ return $ if isInfixDataCon (nameBase conName) && length ts == 2 && isJust mbFi then let [t1, t2] = ts in InfixC t1 conName t2@@ -647,7 +641,7 @@ (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)+ return (readLbl ++ [readPunc "=", readStmt], varExp) where readLbl | isSym lblStr = [readPunc "(", symbolPat lblStr, readPunc ")"]@@ -841,19 +835,6 @@ 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
src/Text/Show/Deriving/Internal.hs view
@@ -56,9 +56,6 @@ import Data.List import qualified Data.Map as Map -#if __GLASGOW_HASKELL__ >= 800-import GHC.Lexeme (startsConSym)-#endif import GHC.Show (appPrec, appPrec1) import Language.Haskell.TH.Lib@@ -392,10 +389,13 @@ args <- newNameList "arg" $ length argTys let showArgs = concatMap (\((argName, _, _), argTy, arg)- -> [ varE showStringValName `appE` stringE (nameBase argName ++ " = ")- , makeShowForArg 0 sClass opts conName tvMap argTy arg- , varE showStringValName `appE` stringE ", "- ]+ -> let argNameBase = nameBase argName+ infixRec = showParen (isSym argNameBase)+ (showString argNameBase) ""+ in [ varE showStringValName `appE` stringE (infixRec ++ " = ")+ , makeShowForArg 0 sClass opts conName tvMap argTy arg+ , varE showStringValName `appE` stringE ", "+ ] ) (zip3 ts argTys args) braceCommaArgs = (varE showCharValName `appE` charE '{') : take (length showArgs - 1) showArgs@@ -433,7 +433,7 @@ let opName = nameBase conName infixOpE = appE (varE showStringValName) . stringE $- if isInfixTypeCon opName+ if isInfixDataCon opName then " " ++ opName ++ " " else " `" ++ opName ++ "` " @@ -455,7 +455,7 @@ let con :: Name -> Q Con con conName = do mbFi <- reifyFixity conName- return $ if startsConSym (head $ nameBase conName)+ return $ if isInfixDataCon (nameBase conName) && length ts == 2 && isJust mbFi then let [t1, t2] = ts in InfixC t1 conName t2@@ -643,13 +643,7 @@ parenInfixConName :: Name -> ShowS parenInfixConName conName = let conNameBase = nameBase conName- in showParen (isInfixTypeCon conNameBase) $ showString conNameBase---- | Checks if a 'String' names a valid Haskell infix type constructor (i.e., does--- it begin with a colon?).-isInfixTypeCon :: String -> Bool-isInfixTypeCon (':':_) = True-isInfixTypeCon _ = False+ in showParen (isInfixDataCon conNameBase) $ showString conNameBase charE :: Char -> Q Exp charE = litE . charL
tests/Types/ReadShow.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -28,8 +29,8 @@ -- Plain data types infixl 4 :@:-data TyCon1 a b = TyConPrefix { tc1 :: a, tc2 :: b }- | (:@:) { tc3 :: b, tc4 :: a }+data TyCon1 a b = TyConPrefix { tc1 :: a, tc2 :: b }+ | (:@:) { tc3 :: b, (##) :: a } infixl 3 :!!: infix 4 :@@:@@ -50,13 +51,17 @@ | TyConWrap2 (f (g a)) | TyConWrap3 (f (g (h a))) +data TC# a b = MkTC1# a b+ | MkTC2# { getTC2# :: b, (#~#) :: a }+ | a `MkTC3#` b+ -- Data families data family TyFamily1 y z :: * infixl 4 :!:-data instance TyFamily1 a b = TyFamilyPrefix { tf1 :: a, tf2 :: b }- | (:!:) { tf3 :: b, tf4 :: a }+data instance TyFamily1 a b = TyFamilyPrefix { tf1 :: a, tf2 :: b }+ | (:!:) { tf3 :: b, (###) :: a } data family TyFamilyPlain y z :: * @@ -85,6 +90,12 @@ | TyFamilyWrap2 (f (g a)) | TyFamilyWrap3 (f (g (h a))) +data family TF# y z :: *++data instance TF# a b = MkTF1# a b+ | MkTF2# { getTF2# :: b, (#~~#) :: a }+ | a `MkTF3#` b+ ------------------------------------------------------------------------------- -- Plain data types@@ -96,10 +107,12 @@ => Read (TyConWrap f g h a) where readPrec = $(makeReadPrec ''TyConWrap) readListPrec = readListPrecDefault+$(deriveRead ''TC#) $(deriveRead1 ''TyCon1) $(deriveRead1 ''TyConPlain) $(deriveRead1 ''TyConGADT)+$(deriveRead1 ''TC#) $(deriveShow ''TyCon1) $(deriveShow ''TyConPlain)@@ -109,10 +122,12 @@ showsPrec = $(makeShowsPrec ''TyConWrap) show = $(makeShow ''TyConWrap) showList = $(makeShowList ''TyConWrap)+$(deriveShow ''TC#) $(deriveShow1 ''TyCon1) $(deriveShow1 ''TyConPlain) $(deriveShow1 ''TyConGADT)+$(deriveShow1 ''TC#) #if defined(NEW_FUNCTOR_CLASSES) $(deriveRead1 ''TyConWrap)@@ -132,10 +147,12 @@ $(deriveRead2 ''TyCon1) $(deriveRead2 ''TyConPlain) $(deriveRead2 ''TyConGADT)+$(deriveRead2 ''TC#) $(deriveShow2 ''TyCon1) $(deriveShow2 ''TyConPlain) $(deriveShow2 ''TyConGADT)+$(deriveShow2 ''TC#) #endif #if MIN_VERSION_template_haskell(2,7,0)@@ -147,10 +164,12 @@ instance (Read (f a), Read (f (g a)), Read (f (g (h a)))) => Read (TyFamilyWrap f g h a) where readsPrec = $(makeReadsPrec 'TyFamilyWrap1)+$(deriveRead 'MkTF1#) $(deriveRead1 '(:!:)) $(deriveRead1 '(:$:)) $(deriveRead1 '(:**))+$(deriveRead1 'MkTF2#) $(deriveShow 'TyFamilyPrefix) $(deriveShow '(:#:))@@ -160,10 +179,12 @@ showsPrec = $(makeShowsPrec 'TyFamilyWrap1) show = $(makeShow 'TyFamilyWrap1) showList = $(makeShowList 'TyFamilyWrap1)+$(deriveShow 'MkTF3#) $(deriveShow1 '(:!:)) $(deriveShow1 '(:$:)) $(deriveShow1 '(:**))+$(deriveShow1 'MkTF1#) # if defined(NEW_FUNCTOR_CLASSES) $(deriveRead1 'TyFamilyWrap2)@@ -183,9 +204,11 @@ $(deriveRead2 'TyFamilyPrefix) $(deriveRead2 'TyFamilyPlain) $(deriveRead2 '(:***))+$(deriveRead2 'MkTF2#) $(deriveShow2 'TyFamilyPrefix) $(deriveShow2 'TyFamilyPlain) $(deriveShow2 '(:***))+$(deriveShow2 'MkTF3#) # endif #endif