Use new code to read old Fields

Author: phadej

Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs

@@ -6,7 +6,7 @@ module Test.QuickCheck.Instances.Cabal () where
 import Control.Applicative        (liftA2)
 import Data.Bits                  (shiftR)
 import Data.Char                  (isAlphaNum, isDigit)
-import Data.List                  (intercalate, isPrefixOf)
+import Data.List                  (intercalate)
 import Data.List.NonEmpty         (NonEmpty (..))
 import Distribution.Utils.Generic (lowercase)
 import Test.QuickCheck
@@ -525,7 +525,7 @@ shortListOf1 bound gen = sized $ \n -> do
 
 arbitraryShortToken :: Gen String
 arbitraryShortToken =
-    shortListOf1 5 (choose ('#', '~')) `suchThat` (not . ("[]" `isPrefixOf`))
+    shortListOf1 5 $ elements [c | c <- ['#' ..  '~' ], c `notElem` "{}[]" ]
 
 -- |
 intSqrt :: Int -> Int

Cabal/src/Distribution/Fields/Field.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFoldable    #-}
+{-# LANGUAGE DeriveFunctor     #-}
 {-# LANGUAGE DeriveTraversable #-}
 -- | Cabal-like file AST types: 'Field', 'Section' etc
 --
@@ -21,13 +21,19 @@ module Distribution.Fields.Field (
     mkName,
     getName,
     nameAnn,
+    -- * Conversions to String
+    sectionArgsToString,
+    fieldLinesToString,
     ) where
 
-import           Prelude ()
-import           Distribution.Compat.Prelude
 import           Data.ByteString             (ByteString)
 import qualified Data.ByteString.Char8       as B
 import qualified Data.Char                   as Char
+import           Distribution.Compat.Prelude
+import           Distribution.Pretty         (showTokenStr)
+import           Distribution.Simple.Utils   (fromUTF8BS)
+import           Prelude ()
+
 
 -------------------------------------------------------------------------------
 -- Cabal file
@@ -106,3 +112,30 @@ getName (Name _ bs) = bs
 
 nameAnn :: Name ann -> ann
 nameAnn (Name ann _) = ann
+
+-------------------------------------------------------------------------------
+-- To Strings
+-------------------------------------------------------------------------------
+
+-- |
+--
+-- @since 3.6.0.0
+sectionArgsToString :: [SectionArg ann] -> String
+sectionArgsToString = unwords . map toStr where
+    toStr :: SectionArg ann -> String
+    toStr (SecArgName _ bs)  = showTokenStr (fromUTF8BS bs)
+    toStr (SecArgStr _ bs)   = showTokenStr (fromUTF8BS bs)
+    toStr (SecArgOther _ bs) = fromUTF8BS bs
+
+-- | Convert @['FieldLine']@ into String.
+--
+-- /Note:/ this doesn't preserve indentation or empty lines,
+-- as the annotations (e.g. positions) are ignored.
+--
+-- @since 3.6.0.0
+fieldLinesToString :: [FieldLine ann] -> String
+fieldLinesToString =
+    -- intercalate to avoid trailing newline.
+    intercalate "\n" . map toStr
+  where
+    toStr (FieldLine _ bs) = fromUTF8BS bs

Cabal/src/Distribution/Pretty.hs

@@ -6,6 +6,7 @@ module Distribution.Pretty (
     -- * Utilities
     showFilePath,
     showToken,
+    showTokenStr,
     showFreeText,
     showFreeTextV3,
     -- * Deprecated
@@ -70,13 +71,16 @@ showFilePath :: FilePath -> PP.Doc
 showFilePath = showToken
 
 showToken :: String -> PP.Doc
-showToken str
+showToken = PP.text . showTokenStr
+
+showTokenStr :: String -> String
+showTokenStr str
     -- if token looks like a comment (starts with --), print it in quotes
-    | "--" `isPrefixOf` str                 = PP.text (show str)
+    | "--" `isPrefixOf` str                 = show str
     -- also if token ends with a colon (e.g. executable name), print it in quotes
-    | ":" `isSuffixOf` str                  = PP.text (show str)
-    | not (any dodgy str) && not (null str) = PP.text str
-    | otherwise                             = PP.text (show str)
+    | ":" `isSuffixOf` str                  = show str
+    | not (any dodgy str) && not (null str) = str
+    | otherwise                             = show str
   where
     dodgy c = isSpace c || c == ','
 

cabal-install/src/Distribution/Client/Config.hs

@@ -111,7 +111,7 @@ import Distribution.Simple.Command
 import Distribution.Simple.Program
          ( defaultProgramDb )
 import Distribution.Simple.Utils
-         ( die', notice, warn, lowercase, cabalVersion )
+         ( die', notice, warn, lowercase, cabalVersion, toUTF8BS )
 import Distribution.Client.Utils
          ( cabalInstallVersion )
 import Distribution.Compiler
@@ -142,6 +142,7 @@ import System.IO.Error
 import Distribution.Compat.Environment
          ( getEnvironment, lookupEnv )
 import qualified Data.Map as M
+import qualified Data.ByteString as BS
 
 --
 -- * Configuration saved in the config file
@@ -781,7 +782,7 @@ readConfigFile
   :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig))
 readConfigFile initial file = handleNotExists $
   fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial)
-       (readFile file)
+       (BS.readFile file)
 
   where
     handleNotExists action = catchIO action $ \ioe ->
@@ -1101,7 +1102,7 @@ liftReportFlag = liftField
 
 parseConfig :: ConstraintSource
             -> SavedConfig
-            -> String
+            -> BS.ByteString
             -> ParseResult SavedConfig
 parseConfig src initial = \str -> do
   fields <- readFields str
@@ -1402,7 +1403,7 @@ withProgramOptionsFields =
 parseExtraLines :: Verbosity -> [String] -> IO SavedConfig
 parseExtraLines verbosity extraLines =
   case parseConfig (ConstraintSourceMainConfig "additional lines")
-       mempty (unlines extraLines) of
+       mempty (toUTF8BS (unlines extraLines)) of
     ParseFailed err ->
       let (line, msg) = locatedErrorMsg err
       in die' verbosity $

cabal-install/src/Distribution/Client/GlobalFlags.hs

@@ -71,7 +71,7 @@ data GlobalFlags = GlobalFlags
     , globalNix               :: Flag Bool  -- ^ Integrate with Nix
     , globalStoreDir          :: Flag FilePath
     , globalProgPathExtra     :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports)
-    } deriving Generic
+    } deriving (Show, Generic)
 
 defaultGlobalFlags :: GlobalFlags
 defaultGlobalFlags  = GlobalFlags

cabal-install/src/Distribution/Client/ParseUtils.hs

@@ -47,14 +47,15 @@ import Prelude ()
 
 import Distribution.Deprecated.ParseUtils
          ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo
-         , Field(..), liftField, readFieldsFlat )
+         , Field(..), liftField, readFields )
 import Distribution.Deprecated.ViewAsFieldDescr
          ( viewAsFieldDescr )
 
 import Distribution.Simple.Command
          ( OptionField  )
 
 import Text.PrettyPrint ( ($+$) )
+import qualified Data.ByteString as BS
 import qualified Data.Map as Map
 import qualified Text.PrettyPrint as Disp
          ( (<>), Doc, text, colon, vcat, empty, isEmpty, nest )
@@ -243,7 +244,7 @@ parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs =
           b <- parseFieldsAndSections fieldDescrs' sectionDescrs' [] sectionEmpty fields
           set line param b a
         Just (Right (FGSectionDescr _ grammar _getter setter)) -> do
-          let fields1 = mapMaybe convertField fields
+          let fields1 = map convertField fields
               (fields2, sections) = partitionFields fields1
           -- TODO: recurse into sections
           for_ (concat sections) $ \(FG.MkSection (F.Name (Position line' _) name') _ _) ->
@@ -262,23 +263,16 @@ parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs =
                  ++ "' on line " ++ show line
           return a
 
-    setField accum (block@IfBlock {}) = do
-      warning $ "Unrecognized stanza on line " ++ show (lineNo block)
-      return accum
-
-convertField :: Field -> Maybe (F.Field Position)
-convertField (F line name str) = Just $
+convertField :: Field -> F.Field Position
+convertField (F line name str) =
     F.Field (F.Name pos (toUTF8BS name)) [ F.FieldLine pos $ toUTF8BS str ]
   where
     pos = Position line 0
 -- arguments omitted
-convertField (Section line name _arg fields) = Just $
-    F.Section (F.Name pos (toUTF8BS name)) [] (mapMaybe convertField fields)
+convertField (Section line name _arg fields) =
+    F.Section (F.Name pos (toUTF8BS name)) [] (map convertField fields)
   where
     pos = Position line 0
--- silently omitted.
-convertField IfBlock {} = Nothing
-
 
 -- | Much like 'ppFields' but also pretty prints any subsections. Subsection
 -- are only shown if they are non-empty.
@@ -361,10 +355,10 @@ ppFgSection secName arg grammar x
 -- It accumulates the result on top of a given initial (typically empty) value.
 --
 parseConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.ParsecFieldGrammar a] -> a
-            -> String -> ParseResult a
+            -> BS.ByteString -> ParseResult a
 parseConfig fieldDescrs sectionDescrs fgSectionDescrs empty str =
       parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs empty
-  =<< readFieldsFlat str
+  =<< readFields str
 
 -- | Render a value in the config file syntax, based on a description of the
 -- configuration file in terms of its fields and sections.

cabal-install/src/Distribution/Client/ProjectConfig.hs

@@ -573,7 +573,7 @@ readProjectFile verbosity DistDirLayout{distProjectFile}
     readExtensionFile =
           reportParseResult verbosity extensionDescription extensionFile
         . parseProjectConfig
-      =<< readFile extensionFile
+      =<< BS.readFile extensionFile
 
     addProjectFileProvenance config =
       config {
@@ -587,7 +587,7 @@ readProjectFile verbosity DistDirLayout{distProjectFile}
 -- For the moment this is implemented in terms of parsers for legacy
 -- configuration types, plus a conversion.
 --
-parseProjectConfig :: String -> OldParser.ParseResult ProjectConfig
+parseProjectConfig :: BS.ByteString -> OldParser.ParseResult ProjectConfig
 parseProjectConfig content =
     convertLegacyProjectConfig <$>
       parseLegacyProjectConfig content

cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs

@@ -95,6 +95,7 @@ import Distribution.Types.PackageVersionConstraint
 import Distribution.Parsec (ParsecParser)
 
 import qualified Data.Map as Map
+import qualified Data.ByteString as BS
 
 import Network.URI (URI (..))
 
@@ -121,7 +122,7 @@ data LegacyProjectConfig = LegacyProjectConfig {
        legacyAllConfig         :: LegacyPackageConfig,
        legacyLocalConfig       :: LegacyPackageConfig,
        legacySpecificConfig    :: MapMappend PackageName LegacyPackageConfig
-     } deriving Generic
+     } deriving (Show, Generic)
 
 instance Monoid LegacyProjectConfig where
   mempty  = gmempty
@@ -136,7 +137,7 @@ data LegacyPackageConfig = LegacyPackageConfig {
        legacyHaddockFlags      :: HaddockFlags,
        legacyTestFlags         :: TestFlags,
        legacyBenchmarkFlags    :: BenchmarkFlags
-     } deriving Generic
+     } deriving (Show, Generic)
 
 instance Monoid LegacyPackageConfig where
   mempty  = gmempty
@@ -152,7 +153,7 @@ data LegacySharedConfig = LegacySharedConfig {
        legacyInstallFlags      :: InstallFlags,
        legacyClientInstallFlags:: ClientInstallFlags,
        legacyProjectFlags      :: ProjectFlags
-     } deriving Generic
+     } deriving (Show, Generic)
 
 instance Monoid LegacySharedConfig where
   mempty  = gmempty
@@ -843,7 +844,7 @@ convertToLegacyPerPackageConfig PackageConfig {..} =
 -- Parsing and showing the project config file
 --
 
-parseLegacyProjectConfig :: String -> ParseResult LegacyProjectConfig
+parseLegacyProjectConfig :: BS.ByteString -> ParseResult LegacyProjectConfig
 parseLegacyProjectConfig =
     parseConfig legacyProjectConfigFieldDescrs
                 legacyPackageConfigSectionDescrs

cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs

@@ -52,6 +52,7 @@ import System.FilePath                 ( (</>) )
 import System.IO.Error                 ( isDoesNotExistError )
 import Text.PrettyPrint                ( ($+$) )
 
+import qualified Data.ByteString as BS
 import qualified Text.PrettyPrint          as Disp
 import qualified Distribution.Deprecated.ParseUtils   as ParseUtils ( Field(..) )
 
@@ -180,15 +181,15 @@ readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath
                               -> IO (Maybe (ParseResult PackageEnvironment))
 readPackageEnvironmentFile src initial file =
   handleNotExists $
-  fmap (Just . parsePackageEnvironment src initial) (readFile file)
+  fmap (Just . parsePackageEnvironment src initial) (BS.readFile file)
   where
     handleNotExists action = catchIO action $ \ioe ->
       if isDoesNotExistError ioe
         then return Nothing
         else ioError ioe
 
 -- | Parse the package environment file.
-parsePackageEnvironment :: ConstraintSource -> PackageEnvironment -> String
+parsePackageEnvironment :: ConstraintSource -> PackageEnvironment -> BS.ByteString
                            -> ParseResult PackageEnvironment
 parsePackageEnvironment src initial str = do
   fields <- readFields str