Remove Text WorldPkgInfo

Author: phadej

cabal-install/Distribution/Client/World.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Distribution.Client.World
@@ -33,22 +34,20 @@ import Prelude (sequence)
 import Distribution.Client.Compat.Prelude hiding (getContents)
 
 import Distribution.Types.Dependency
-import Distribution.PackageDescription
-         ( FlagAssignment, mkFlagAssignment, unFlagAssignment
-         , mkFlagName, unFlagName )
+import Distribution.Types.Flag
+         ( FlagAssignment, unFlagAssignment
+         , unFlagName, parsecFlagAssignmentNonEmpty, describeFlagAssignmentNonEmpty )
 import Distribution.Verbosity
          ( Verbosity )
 import Distribution.Simple.Utils
          ( die', info, chattyTry, writeFileAtomic )
-import Distribution.Deprecated.Text
-         ( Text(..), display, simpleParse )
-import qualified Distribution.Deprecated.ReadP as Parse
+import Distribution.Parsec (Parsec (..), CabalParsing, simpleParsec)
+import Distribution.Pretty (Pretty (..), prettyShow)
+import Distribution.FieldGrammar.Described (Described (..), GrammarRegex (..))
+import qualified Distribution.Compat.CharParsing as P
 import Distribution.Compat.Exception ( catchIO )
 import qualified Text.PrettyPrint as Disp
 
-
-import Data.Char as Char
-
 import Data.List
          ( unionBy, deleteFirstsBy )
 import System.IO.Error
@@ -57,7 +56,7 @@ import qualified Data.ByteString.Lazy.Char8 as B
 
 
 data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment
-  deriving (Show,Eq)
+  deriving (Show,Eq, Generic)
 
 -- | Adds packages to the world file; creates the file if it doesn't
 -- exist yet. Version constraints and flag assignments for a package are
@@ -102,7 +101,7 @@ modifyWorld f verbosity world pkgs =
       then do
         info verbosity "Updating world file..."
         writeFileAtomic world . B.pack $ unlines
-            [ (display pkg) | pkg <- pkgsNewWorld]
+            [ (prettyShow pkg) | pkg <- pkgsNewWorld]
       else
         info verbosity "World file is already up to date."
 
@@ -111,7 +110,7 @@ modifyWorld f verbosity world pkgs =
 getContents :: Verbosity -> FilePath -> IO [WorldPkgInfo]
 getContents verbosity world = do
   content <- safelyReadFile world
-  let result = map simpleParse (lines $ B.unpack content)
+  let result = map simpleParsec (lines $ B.unpack content)
   case sequence result of
     Nothing -> die' verbosity "Could not parse world file."
     Just xs -> return xs
@@ -123,51 +122,34 @@ getContents verbosity world = do
                 | otherwise             = ioError e
 
 
-instance Text WorldPkgInfo where
-  disp (WorldPkgInfo dep flags) = disp dep Disp.<+> dispFlags (unFlagAssignment flags)
+instance Pretty WorldPkgInfo where
+  pretty (WorldPkgInfo dep flags) = pretty dep Disp.<+> dispFlags (unFlagAssignment flags)
     where
       dispFlags [] = Disp.empty
       dispFlags fs = Disp.text "--flags="
                   <<>> Disp.doubleQuotes (flagAssToDoc fs)
       flagAssToDoc = foldr (\(fname,val) flagAssDoc ->
                              (if not val then Disp.char '-'
-                                         else Disp.empty)
+                                         else Disp.char '+')
                              <<>> Disp.text (unFlagName fname)
                              Disp.<+> flagAssDoc)
                            Disp.empty
-  parse = do
-      dep <- parse
-      Parse.skipSpaces
-      flagAss <- Parse.option mempty parseFlagAssignment
+
+instance Parsec WorldPkgInfo where
+  parsec = do
+      dep <- parsec
+      P.spaces
+      flagAss <- P.option mempty parseFlagAssignment
       return $ WorldPkgInfo dep flagAss
     where
-      parseFlagAssignment :: Parse.ReadP r FlagAssignment
+      parseFlagAssignment :: CabalParsing m => m FlagAssignment
       parseFlagAssignment = do
-          _ <- Parse.string "--flags"
-          Parse.skipSpaces
-          _ <- Parse.char '='
-          Parse.skipSpaces
-          mkFlagAssignment <$> (inDoubleQuotes $ Parse.many1 flag)
+          _ <- P.string "--flags="
+          inDoubleQuotes parsecFlagAssignmentNonEmpty
         where
-          inDoubleQuotes :: Parse.ReadP r a -> Parse.ReadP r a
-          inDoubleQuotes = Parse.between (Parse.char '"') (Parse.char '"')
-
-          flag = do
-            Parse.skipSpaces
-            val <- negative Parse.+++ positive
-            name <- ident
-            Parse.skipSpaces
-            return (mkFlagName name,val)
-          negative = do
-            _ <- Parse.char '-'
-            return False
-          positive = return True
+          inDoubleQuotes = P.between (P.char '"') (P.char '"')
 
-          ident :: Parse.ReadP r String
-          ident = do
-            -- First character must be a letter/digit to avoid flags
-            -- like "+-debug":
-            c  <- Parse.satisfy Char.isAlphaNum
-            cs <- Parse.munch (\ch -> Char.isAlphaNum ch || ch == '_'
-                                                         || ch == '-')
-            return (c:cs)
+instance Described WorldPkgInfo where
+  describe _ = 
+    describe (Proxy :: Proxy Dependency)
+    <> REOpt (RESpaces1 <> fromString "--flags=\"" <> describeFlagAssignmentNonEmpty <> fromString "\"")

cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs

@@ -37,6 +37,7 @@ import Distribution.Client.InstallSymlink                (OverwritePolicy)
 import Distribution.Client.Targets
 import Distribution.Client.Types                         (RepoName (..), WriteGhcEnvironmentFilesPolicy)
 import Distribution.Client.Types.AllowNewer
+import Distribution.Client.World                         (WorldPkgInfo (..))
 import Distribution.Solver.Types.OptionalStanza          (OptionalStanza (..))
 import Distribution.Solver.Types.PackageConstraint       (PackageProperty (..))
 
@@ -260,6 +261,14 @@ instance Arbitrary RelaxDepSubject where
 instance Arbitrary RelaxedDep where
     arbitrary = RelaxedDep <$> arbitrary <*> arbitrary <*> arbitrary
 
+-------------------------------------------------------------------------------
+-- WorldPkgInfo
+-------------------------------------------------------------------------------
+
+instance Arbitrary WorldPkgInfo where
+    arbitrary = WorldPkgInfo <$> arbitrary <*> arbitrary
+    shrink    = genericShrink
+
 -------------------------------------------------------------------------------
 -- UserConstraint
 -------------------------------------------------------------------------------

cabal-install/tests/UnitTests/Distribution/Client/Described.hs

@@ -23,6 +23,7 @@ import Distribution.Client.IndexUtils.Timestamp   (Timestamp)
 import Distribution.Client.Targets                (UserConstraint)
 import Distribution.Client.Types                  (RepoName)
 import Distribution.Client.Types.AllowNewer       (RelaxDepSubject, RelaxDeps, RelaxedDep)
+import Distribution.Client.World                  (WorldPkgInfo)
 
 import qualified RERE         as RE
 import qualified RERE.CharSet as RE
@@ -41,6 +42,7 @@ tests = testGroup "Described"
     , testDescribed (Proxy :: Proxy RelaxedDep)
     , testDescribed (Proxy :: Proxy RelaxDeps)
     , testDescribed (Proxy :: Proxy UserConstraint)
+    , testDescribed (Proxy :: Proxy WorldPkgInfo)
     ]
 
 -------------------------------------------------------------------------------