diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index f7961d02ef78511fae49b6a70d9aac22514a155c..5a100e75223f1ea2898b800bec181e0acd17d214 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -593,6 +593,7 @@ test-suite unit-tests build-depends: array, base, + binary, bytestring, containers, directory, diff --git a/Cabal/ChangeLog.md b/Cabal/ChangeLog.md index ab89a2899e57e05009d324273d72659bbb321e67..8af130e4cecfbdf6db0b0da150c84bac1dc8750f 100644 --- a/Cabal/ChangeLog.md +++ b/Cabal/ChangeLog.md @@ -21,6 +21,8 @@ * Fix corrupted config file header for non-ASCII package names ([2557](https://github.com/haskell/cabal/issues/2557)). * Extend `Distribution.Simple.Utils.rewriteFileEx` from ASCII to UTF-8 encoding. + * Change the arguments of `Newtype` class to better suit @DeriveAnyClass@ usage, + add default implementation in terms of `coerce` / `unsafeCoerce`. ---- diff --git a/Cabal/Distribution/Compat/Newtype.hs b/Cabal/Distribution/Compat/Newtype.hs index e45e97cf9271f45182c0911c2542e81d07320ccb..3e6d1c3aa3adb099fe9509927a8fbbb72881ee55 100644 --- a/Cabal/Distribution/Compat/Newtype.hs +++ b/Cabal/Distribution/Compat/Newtype.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -- | Per Conor McBride, the 'Newtype' typeclass represents the packing and @@ -14,31 +16,50 @@ module Distribution.Compat.Newtype ( import Data.Functor.Identity (Identity (..)) import Data.Monoid (Sum (..), Product (..), Endo (..)) +#if MIN_VERSION_base(4,7,0) +import Data.Coerce (coerce, Coercible) +#else +import Unsafe.Coerce (unsafeCoerce) +#endif + -- | The @FunctionalDependencies@ version of 'Newtype' type-class. -- --- /Note:/ for actual newtypes the implementation can be --- @pack = coerce; unpack = coerce@. We don't have default implementation, --- because @Cabal@ have to support older than @base >= 4.7@ compilers. --- Also, 'Newtype' could witness a non-structural isomorphism. -class Newtype n o | n -> o where +-- Since Cabal-3.0 class arguments are in a different order than in @newtype@ package. +-- This change is to allow usage with @DeriveAnyClass@ (and @DerivingStrategies@, in GHC-8.2). +-- Unfortunately one have to repeat inner type. +-- +-- @ +-- newtype New = New Old +-- deriving anyclass (Newtype Old) +-- @ +-- +-- Another approach would be to use @TypeFamilies@ (and possibly +-- compute inner type using "GHC.Generics"), but we think @FunctionalDependencies@ +-- version gives cleaner type signatures. +-- +class Newtype o n | n -> o where pack :: o -> n - unpack :: n -> o - -instance Newtype (Identity a) a where - pack = Identity - unpack = runIdentity +#if MIN_VERSION_base(4,7,0) + default pack :: Coercible o n => o -> n + pack = coerce +#else + default pack :: o -> n + pack = unsafeCoerce +#endif -instance Newtype (Sum a) a where - pack = Sum - unpack = getSum - -instance Newtype (Product a) a where - pack = Product - unpack = getProduct + unpack :: n -> o +#if MIN_VERSION_base(4,7,0) + default unpack :: Coercible n o => n -> o + unpack = coerce +#else + default unpack :: n -> o + unpack = unsafeCoerce +#endif -instance Newtype (Endo a) (a -> a) where - pack = Endo - unpack = appEndo +instance Newtype a (Identity a) +instance Newtype a (Sum a) +instance Newtype a (Product a) +instance Newtype (a -> a) (Endo a) -- | -- @@ -49,7 +70,7 @@ instance Newtype (Endo a) (a -> a) where -- -- >>> ala (Sum . (+1)) foldMap [1, 2, 3, 4 :: Int] -- 10 -ala :: (Newtype n o, Newtype n' o') => (o -> n) -> ((o -> n) -> b -> n') -> (b -> o') +ala :: (Newtype o n, Newtype o' n') => (o -> n) -> ((o -> n) -> b -> n') -> (b -> o') ala pa hof = alaf pa hof id -- | @@ -58,13 +79,13 @@ ala pa hof = alaf pa hof id -- 12 -- -- /Note:/ as with 'ala', the user supplied function for the newtype is /ignored/. -alaf :: (Newtype n o, Newtype n' o') => (o -> n) -> ((a -> n) -> b -> n') -> (a -> o) -> (b -> o') +alaf :: (Newtype o n, Newtype o' n') => (o -> n) -> ((a -> n) -> b -> n') -> (a -> o) -> (b -> o') alaf _ hof f = unpack . hof (pack . f) -- | Variant of 'pack', which takes a phantom type. -pack' :: Newtype n o => (o -> n) -> o -> n +pack' :: Newtype o n => (o -> n) -> o -> n pack' _ = pack -- | Variant of 'pack', which takes a phantom type. -unpack' :: Newtype n o => (o -> n) -> n -> o +unpack' :: Newtype o n => (o -> n) -> n -> o unpack' _ = unpack diff --git a/Cabal/Distribution/FieldGrammar/Class.hs b/Cabal/Distribution/FieldGrammar/Class.hs index e1939fad666d2af0c689f678aa3dec271f4ec682..872b402bb4fa6373703cbe2e24b44569ccf3e673 100644 --- a/Cabal/Distribution/FieldGrammar/Class.hs +++ b/Cabal/Distribution/FieldGrammar/Class.hs @@ -33,7 +33,7 @@ class FieldGrammar g where -- | Field which should be defined, exactly once. uniqueFieldAla - :: (Parsec b, Pretty b, Newtype b a) + :: (Parsec b, Pretty b, Newtype a b) => FieldName -- ^ field name -> (a -> b) -- ^ 'Newtype' pack -> ALens' s a -- ^ lens into the field @@ -48,7 +48,7 @@ class FieldGrammar g where -- | Optional field. optionalFieldAla - :: (Parsec b, Pretty b, Newtype b a) + :: (Parsec b, Pretty b, Newtype a b) => FieldName -- ^ field name -> (a -> b) -- ^ 'pack' -> ALens' s (Maybe a) -- ^ lens into the field @@ -56,7 +56,7 @@ class FieldGrammar g where -- | Optional field with default value. optionalFieldDefAla - :: (Parsec b, Pretty b, Newtype b a, Eq a) + :: (Parsec b, Pretty b, Newtype a b, Eq a) => FieldName -- ^ field name -> (a -> b) -- ^ 'Newtype' pack -> ALens' s a -- ^ @'Lens'' s a@: lens into the field @@ -88,7 +88,7 @@ class FieldGrammar g where -- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid. -- monoidalFieldAla - :: (Parsec b, Pretty b, Monoid a, Newtype b a) + :: (Parsec b, Pretty b, Monoid a, Newtype a b) => FieldName -- ^ field name -> (a -> b) -- ^ 'pack' -> ALens' s a -- ^ lens into the field diff --git a/Cabal/Distribution/Parsec/Newtypes.hs b/Cabal/Distribution/Parsec/Newtypes.hs index b9e5687648ee12f9847c9b0c65365813c2c3141d..f48ef8d2d4ca7f6cd11039e3bfdc8afb4bb787cc 100644 --- a/Cabal/Distribution/Parsec/Newtypes.hs +++ b/Cabal/Distribution/Parsec/Newtypes.hs @@ -95,7 +95,7 @@ instance Sep NoCommaFSep where -- | List separated with optional commas. Displayed with @sep@, arguments of -- type @a@ are parsed and pretty-printed as @b@. -newtype List sep b a = List { getList :: [a] } +newtype List sep b a = List { _getList :: [a] } -- | 'alaList' and 'alaList'' are simply 'List', with additional phantom -- arguments to constraint the resulting type @@ -113,22 +113,18 @@ alaList _ = List alaList' :: sep -> (a -> b) -> [a] -> List sep b a alaList' _ _ = List -instance Newtype (List sep wrapper a) [a] where - pack = List - unpack = getList +instance Newtype [a] (List sep wrapper a) -instance (Newtype b a, Sep sep, Parsec b) => Parsec (List sep b a) where +instance (Newtype a b, Sep sep, Parsec b) => Parsec (List sep b a) where parsec = pack . map (unpack :: b -> a) <$> parseSep (P :: P sep) parsec -instance (Newtype b a, Sep sep, Pretty b) => Pretty (List sep b a) where +instance (Newtype a b, Sep sep, Pretty b) => Pretty (List sep b a) where pretty = prettySep (P :: P sep) . map (pretty . (pack :: a -> b)) . unpack -- | Haskell string or @[^ ,]+@ newtype Token = Token { getToken :: String } -instance Newtype Token String where - pack = Token - unpack = getToken +instance Newtype String Token instance Parsec Token where parsec = pack <$> parsecToken @@ -139,9 +135,7 @@ instance Pretty Token where -- | Haskell string or @[^ ]+@ newtype Token' = Token' { getToken' :: String } -instance Newtype Token' String where - pack = Token' - unpack = getToken' +instance Newtype String Token' instance Parsec Token' where parsec = pack <$> parsecToken' @@ -152,9 +146,7 @@ instance Pretty Token' where -- | Either @"quoted"@ or @un-quoted@. newtype MQuoted a = MQuoted { getMQuoted :: a } -instance Newtype (MQuoted a) a where - pack = MQuoted - unpack = getMQuoted +instance Newtype a (MQuoted a) instance Parsec a => Parsec (MQuoted a) where parsec = pack <$> parsecMaybeQuoted parsec @@ -173,9 +165,7 @@ instance Pretty a => Pretty (MQuoted a) where -- newtype SpecVersion = SpecVersion { getSpecVersion :: Either Version VersionRange } -instance Newtype SpecVersion (Either Version VersionRange) where - pack = SpecVersion - unpack = getSpecVersion +instance Newtype (Either Version VersionRange) SpecVersion instance Parsec SpecVersion where parsec = pack <$> parsecSpecVersion @@ -198,9 +188,7 @@ specVersionFromRange versionRange = case asVersionIntervals versionRange of -- | SPDX License expression or legacy license newtype SpecLicense = SpecLicense { getSpecLicense :: Either SPDX.License License } -instance Newtype SpecLicense (Either SPDX.License License) where - pack = SpecLicense - unpack = getSpecLicense +instance Newtype (Either SPDX.License License) SpecLicense instance Parsec SpecLicense where parsec = do @@ -215,9 +203,7 @@ instance Pretty SpecLicense where -- | Version range or just version newtype TestedWith = TestedWith { getTestedWith :: (CompilerFlavor, VersionRange) } -instance Newtype TestedWith (CompilerFlavor, VersionRange) where - pack = TestedWith - unpack = getTestedWith +instance Newtype (CompilerFlavor, VersionRange) TestedWith instance Parsec TestedWith where parsec = pack <$> parsecTestedWith @@ -229,9 +215,7 @@ instance Pretty TestedWith where -- | Filepath are parsed as 'Token'. newtype FilePathNT = FilePathNT { getFilePathNT :: String } -instance Newtype FilePathNT String where - pack = FilePathNT - unpack = getFilePathNT +instance Newtype String FilePathNT instance Parsec FilePathNT where parsec = pack <$> parsecToken diff --git a/Cabal/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs b/Cabal/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs index e629f97308504325ee3aa819db2d48f5c35cdf76..7ae6957edef32d8230786c0622be39c8dd718b63 100644 --- a/Cabal/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs +++ b/Cabal/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs @@ -172,9 +172,7 @@ maybePackageName ipi = case sourceLibName ipi of newtype ExposedModules = ExposedModules { getExposedModules :: [ExposedModule] } -instance Newtype ExposedModules [ExposedModule] where - pack = ExposedModules - unpack = getExposedModules +instance Newtype [ExposedModule] ExposedModules instance Parsec ExposedModules where parsec = ExposedModules <$> parsecOptCommaList parsec @@ -185,9 +183,7 @@ instance Pretty ExposedModules where newtype CompatPackageKey = CompatPackageKey { getCompatPackageKey :: String } -instance Newtype CompatPackageKey String where - pack = CompatPackageKey - unpack = getCompatPackageKey +instance Newtype String CompatPackageKey instance Pretty CompatPackageKey where pretty = Disp.text . getCompatPackageKey @@ -199,9 +195,7 @@ instance Parsec CompatPackageKey where newtype InstWith = InstWith { getInstWith :: [(ModuleName,OpenModule)] } -instance Newtype InstWith [(ModuleName, OpenModule)] where - pack = InstWith - unpack = getInstWith +instance Newtype [(ModuleName, OpenModule)] InstWith instance Pretty InstWith where pretty = dispOpenModuleSubst . Map.fromList . getInstWith @@ -213,15 +207,13 @@ instance Parsec InstWith where -- | SPDX License expression or legacy license. Lenient parser, accepts either. newtype SpecLicenseLenient = SpecLicenseLenient { getSpecLicenseLenient :: Either SPDX.License License } -instance Newtype SpecLicenseLenient (Either SPDX.License License) where - pack = SpecLicenseLenient - unpack = getSpecLicenseLenient +instance Newtype (Either SPDX.License License) SpecLicenseLenient instance Parsec SpecLicenseLenient where parsec = fmap SpecLicenseLenient $ Left <$> P.try parsec <|> Right <$> parsec instance Pretty SpecLicenseLenient where - pretty = either pretty pretty . unpack + pretty = either pretty pretty . getSpecLicenseLenient ------------------------------------------------------------------------------- -- Basic fields