RFC: patchLegacy

Author: phadej

Cabal/Cabal.cabal

@@ -271,6 +271,7 @@ library
     Distribution.Compat.Parsec
     Distribution.PackageDescription.Parsec
     Distribution.PackageDescription.Parsec.FieldDescr
+    Distribution.PackageDescription.Parsec.Legacy
     Distribution.Parsec.Class
     Distribution.Parsec.ConfVar
     Distribution.Parsec.Lexer
@@ -411,7 +412,7 @@ test-suite parser-hackage-tests
 
   if flag(parsec-struct-diff)
     build-depends:
-      generics-sop ==0.2.*,
+      generics-sop >= 0.2.5 && <0.3,
       these >=0.7.1 && <0.8,
       singleton-bool >=0.1.1.0 && <0.2,
       keys

Cabal/Distribution/PackageDescription/Parsec.hs

@@ -38,6 +38,7 @@ import qualified Data.Map                                          as Map
 import qualified Distribution.Compat.SnocList                      as SnocList
 import           Distribution.PackageDescription
 import           Distribution.PackageDescription.Parsec.FieldDescr
+import           Distribution.PackageDescription.Parsec.Legacy     (patchLegacy)
 import           Distribution.Parsec.Class                         (parsec)
 import           Distribution.Parsec.ConfVar
                  (parseConditionConfVar)
@@ -103,10 +104,15 @@ readGenericPackageDescription = readAndParseFile parseGenericPackageDescription
 --
 -- TODO: add lex warnings
 parseGenericPackageDescription :: BS.ByteString -> ParseResult GenericPackageDescription
-parseGenericPackageDescription bs = case readFields' bs of
-    Right (fs, lexWarnings) -> parseGenericPackageDescription' lexWarnings fs
+parseGenericPackageDescription bs = case readFields' bs' of
+    Right (fs, lexWarnings) -> do
+        when patched $
+            parseWarning zeroPos PWTLegacyCabalFile "Legacy cabal file"
+        parseGenericPackageDescription' lexWarnings fs
     -- TODO: better marshalling of errors
-    Left perr -> parseFatalFailure (Position 0 0) (show perr)
+    Left perr -> parseFatalFailure zeroPos (show perr)
+  where
+    (patched, bs') = patchLegacy bs
 
 -- | 'Maybe' variant of 'parseGenericPackageDescription'
 parseGenericPackageDescriptionMaybe :: BS.ByteString -> Maybe GenericPackageDescription

Cabal/Distribution/Parsec/Types/Common.hs

@@ -13,6 +13,7 @@ module Distribution.Parsec.Types.Common (
     incPos,
     retPos,
     showPos,
+    zeroPos,
     ) where
 
 import           Prelude ()
@@ -45,6 +46,7 @@ data PWarnType
     | PWTExtraBenchmarkModule  -- ^ extra benchmark-module field
     | PWTLexNBSP
     | PWTLexBOM
+    | PWTLegacyCabalFile       -- ^ legacy cabal file that we know how to patch
     deriving (Eq, Ord, Show, Enum, Bounded)
 
 -- | Parser warning.
@@ -87,3 +89,6 @@ retPos (Position row _col) = Position (row + 1) 1
 
 showPos :: Position -> String
 showPos (Position row col) = show row ++ ":" ++ show col
+
+zeroPos :: Position
+zeroPos = Position 0 0

Cabal/tests/DiffInstances.hs

@@ -17,14 +17,15 @@ import           Distribution.Package
 import           Distribution.Types.ForeignLib
 import           Distribution.Types.ForeignLibOption
 import           Distribution.Types.ForeignLibType
+import           Distribution.Types.IncludeRenaming (IncludeRenaming)
 import           Distribution.PackageDescription
-                 (Benchmark, BenchmarkInterface, BenchmarkType, BuildInfo,
-                 BuildType, CondTree, Condition, Executable, Flag, FlagName,
-                 GenericPackageDescription, Library, ModuleReexport,
-                 ModuleRenaming, PackageDescription, RepoKind, RepoType,
-                 SetupBuildInfo, SourceRepo, TestSuite, TestSuiteInterface,
-                 TestType)
-import Distribution.Types.IncludeRenaming (IncludeRenaming)
+import           Distribution.Types.CondTree
+import           Distribution.Types.ExeDependency
+import           Distribution.Types.ExecutableScope
+import           Distribution.Types.LegacyExeDependency
+import           Distribution.Types.Mixin
+import           Distribution.Types.PkgconfigDependency
+import           Distribution.Types.UnqualComponentName
 import           Distribution.Version            (Version, VersionRange)
 import           Language.Haskell.Extension
                  (Extension, KnownExtension, Language)
@@ -39,6 +40,7 @@ deriveGeneric ''BenchmarkType
 deriveGeneric ''BuildInfo
 deriveGeneric ''BuildType
 deriveGeneric ''CompilerFlavor
+deriveGeneric ''CondBranch
 deriveGeneric ''CondTree
 deriveGeneric ''Dependency
 deriveGeneric ''Executable
@@ -48,6 +50,7 @@ deriveGeneric ''ForeignLib
 deriveGeneric ''ForeignLibOption
 deriveGeneric ''ForeignLibType
 deriveGeneric ''GenericPackageDescription
+deriveGeneric ''IncludeRenaming
 deriveGeneric ''KnownExtension
 deriveGeneric ''Language
 deriveGeneric ''Library
@@ -65,10 +68,10 @@ deriveGeneric ''TestSuite
 deriveGeneric ''TestSuiteInterface
 deriveGeneric ''TestType
 deriveGeneric ''VersionRange
-deriveGeneric ''IncludeRenaming
 
 instance (Eq a, Show a) => Diff (Condition a) where diff = eqDiff
 instance (Show a, Diff b, Diff c, Show b, Show c, Eq a, Eq c, Eq b) => Diff (CondTree a b c)
+instance (Show a, Diff b, Diff c, Show b, Show c, Eq a, Eq c, Eq b) => Diff (CondBranch a b c)
 
 instance Diff Benchmark
 instance Diff BenchmarkInterface
@@ -77,31 +80,38 @@ instance Diff BuildInfo
 instance Diff BuildType
 instance Diff CompilerFlavor
 instance Diff Dependency
+instance Diff ExeDependency where diff = eqDiff
 instance Diff Executable
+instance Diff ExecutableScope where diff = eqDiff
 instance Diff Extension
 instance Diff Flag
 instance Diff FlagName where diff = eqDiff
 instance Diff ForeignLib
-instance Diff ForeignLibType
 instance Diff ForeignLibOption
+instance Diff ForeignLibType
 instance Diff GenericPackageDescription
+instance Diff IncludeRenaming 
 instance Diff KnownExtension
 instance Diff Language
+instance Diff LegacyExeDependency where diff = eqDiff
+instance Diff LibVersionInfo where diff = eqDiff
 instance Diff Library
 instance Diff License
+instance Diff Mixin where diff = eqDiff
 instance Diff ModuleName where diff = eqDiff
 instance Diff ModuleReexport
 instance Diff ModuleRenaming
 instance Diff PackageDescription
 instance Diff PackageIdentifier
 instance Diff PackageName where diff = eqDiff
+instance Diff PkgconfigDependency where diff = eqDiff
 instance Diff RepoKind
 instance Diff RepoType
 instance Diff SetupBuildInfo
 instance Diff SourceRepo
 instance Diff TestSuite
 instance Diff TestSuiteInterface
 instance Diff TestType
+instance Diff UnqualComponentName where diff = eqDiff
 instance Diff Version where diff = eqDiff
 instance Diff VersionRange
-instance Diff IncludeRenaming 

Cabal/tests/ParserHackageTests.hs

@@ -197,8 +197,6 @@ problematicFiles =
     , eq "ixset/1.0.4/ixset.cabal"
     -- comments in braces
     , isPrefixOf "hint/"
-    -- other-modules:\n  .
-    , eq "unicode-transforms/0.3.3/unicode-transforms.cabal"
     ]
   where
     eq = (==)

Cabal/tests/StructDiff.hs

@@ -85,7 +85,7 @@ class Diff a where
 
 -- | And generic implementation!
 gdiff :: forall a. (Generic a, HasDatatypeInfo a, All2 Diff (Code a)) => a -> a -> DiffResult
-gdiff x y  = gdiffS (constructorInfo (P :: P a)) (unSOP $ from x) (unSOP $ from y)
+gdiff x y  = gdiffS (constructorInfo (datatypeInfo (P :: P a))) (unSOP $ from x) (unSOP $ from y)
 
 gdiffS :: All2 Diff xss => NP ConstructorInfo xss -> NS (NP I) xss -> NS (NP I) xss -> DiffResult
 gdiffS (c :* _) (Z xs) (Z ys) = mconcat $ hcollapse $ hczipWith3 (P :: P Diff) f (fieldNames c) xs ys
@@ -138,23 +138,13 @@ instance (Ord k, Show k, Diff v, Show v) => Diff (Map k v) where diff = alignDif
 -- SOP helpers
 -------------------------------------------------------------------------------
 
-constructorInfo :: (HasDatatypeInfo a, xss ~ Code a) => proxy a -> NP ConstructorInfo xss
-constructorInfo p = case datatypeInfo p of
-    ADT _ _ cs    -> cs
-    Newtype _ _ c -> c :* Nil
-
 constructorNameOf :: NP ConstructorInfo xss -> NS f xss -> ConstructorName
 constructorNameOf (c :* _)  (Z _)  = constructorName c
 constructorNameOf (_ :* cs) (S xs) = constructorNameOf cs xs
 #if __GLASGOW_HASKELL__ < 800
 constructorNameOf _ _ = error "Should never happen"
 #endif
 
-constructorName :: ConstructorInfo xs -> ConstructorName
-constructorName (Constructor name) = name
-constructorName (Infix name _ _)   = "(" ++ name ++ ")"
-constructorName (Record name _)    = name
-
 -- | This is a little lie.
 fieldNames :: ConstructorInfo xs -> NP (K FieldName) xs
 fieldNames (Constructor name) = hpure (K name) -- TODO: add .1 .2 etc.