Skip to content

Commit fe82a92

Browse files
phadejphadej
committed
Use new code to read old Fields
1 parent 6118fd9 commit fe82a92

File tree

12 files changed

+120
-282
lines changed

12 files changed

+120
-282
lines changed

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,7 @@ module Test.QuickCheck.Instances.Cabal () where
66
import Control.Applicative (liftA2)
77
import Data.Bits (shiftR)
88
import Data.Char (isAlphaNum, isDigit)
9-
import Data.List (intercalate, isPrefixOf)
9+
import Data.List (intercalate)
1010
import Data.List.NonEmpty (NonEmpty (..))
1111
import Distribution.Utils.Generic (lowercase)
1212
import Test.QuickCheck
@@ -525,7 +525,7 @@ shortListOf1 bound gen = sized $ \n -> do
525525

526526
arbitraryShortToken :: Gen String
527527
arbitraryShortToken =
528-
shortListOf1 5 (choose ('#', '~')) `suchThat` (not . ("[]" `isPrefixOf`))
528+
shortListOf1 5 $ elements [c | c <- ['#' .. '~' ], c `notElem` "{}[]" ]
529529

530530
-- |
531531
intSqrt :: Int -> Int

‎Cabal/src/Distribution/Fields/Field.hs

Lines changed: 37 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
1-
{-# LANGUAGE DeriveFunctor #-}
2-
{-# LANGUAGE DeriveFoldable #-}
1+
{-# LANGUAGE DeriveFoldable #-}
2+
{-# LANGUAGE DeriveFunctor #-}
33
{-# LANGUAGE DeriveTraversable #-}
44
-- | Cabal-like file AST types: 'Field', 'Section' etc
55
--
@@ -21,13 +21,19 @@ module Distribution.Fields.Field (
2121
mkName,
2222
getName,
2323
nameAnn,
24+
-- * Conversions to String
25+
sectionArgsToString,
26+
fieldLinesToString,
2427
) where
2528

26-
import Prelude ()
27-
import Distribution.Compat.Prelude
2829
import Data.ByteString (ByteString)
2930
import qualified Data.ByteString.Char8 as B
3031
import qualified Data.Char as Char
32+
import Distribution.Compat.Prelude
33+
import Distribution.Pretty (showTokenStr)
34+
import Distribution.Simple.Utils (fromUTF8BS)
35+
import Prelude ()
36+
3137

3238
-------------------------------------------------------------------------------
3339
-- Cabal file
@@ -106,3 +112,30 @@ getName (Name _ bs) = bs
106112

107113
nameAnn :: Name ann -> ann
108114
nameAnn (Name ann _) = ann
115+
116+
-------------------------------------------------------------------------------
117+
-- To Strings
118+
-------------------------------------------------------------------------------
119+
120+
-- |
121+
--
122+
-- @since 3.6.0.0
123+
sectionArgsToString :: [SectionArg ann] -> String
124+
sectionArgsToString = unwords . map toStr where
125+
toStr :: SectionArg ann -> String
126+
toStr (SecArgName _ bs) = showTokenStr (fromUTF8BS bs)
127+
toStr (SecArgStr _ bs) = showTokenStr (fromUTF8BS bs)
128+
toStr (SecArgOther _ bs) = fromUTF8BS bs
129+
130+
-- | Convert @['FieldLine']@ into String.
131+
--
132+
-- /Note:/ this doesn't preserve indentation or empty lines,
133+
-- as the annotations (e.g. positions) are ignored.
134+
--
135+
-- @since 3.6.0.0
136+
fieldLinesToString :: [FieldLine ann] -> String
137+
fieldLinesToString =
138+
-- intercalate to avoid trailing newline.
139+
intercalate "\n" . map toStr
140+
where
141+
toStr (FieldLine _ bs) = fromUTF8BS bs

‎Cabal/src/Distribution/Pretty.hs

Lines changed: 9 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@ module Distribution.Pretty (
66
-- * Utilities
77
showFilePath,
88
showToken,
9+
showTokenStr,
910
showFreeText,
1011
showFreeTextV3,
1112
-- * Deprecated
@@ -70,13 +71,16 @@ showFilePath :: FilePath -> PP.Doc
7071
showFilePath = showToken
7172

7273
showToken :: String -> PP.Doc
73-
showToken str
74+
showToken = PP.text . showTokenStr
75+
76+
showTokenStr :: String -> String
77+
showTokenStr str
7478
-- if token looks like a comment (starts with --), print it in quotes
75-
| "--" `isPrefixOf` str = PP.text (show str)
79+
| "--" `isPrefixOf` str = show str
7680
-- also if token ends with a colon (e.g. executable name), print it in quotes
77-
| ":" `isSuffixOf` str = PP.text (show str)
78-
| not (any dodgy str) && not (null str) = PP.text str
79-
| otherwise = PP.text (show str)
81+
| ":" `isSuffixOf` str = show str
82+
| not (any dodgy str) && not (null str) = str
83+
| otherwise = show str
8084
where
8185
dodgy c = isSpace c || c == ','
8286

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

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -111,7 +111,7 @@ import Distribution.Simple.Command
111111
import Distribution.Simple.Program
112112
( defaultProgramDb )
113113
import Distribution.Simple.Utils
114-
( die', notice, warn, lowercase, cabalVersion )
114+
( die', notice, warn, lowercase, cabalVersion, toUTF8BS )
115115
import Distribution.Client.Utils
116116
( cabalInstallVersion )
117117
import Distribution.Compiler
@@ -142,6 +142,7 @@ import System.IO.Error
142142
import Distribution.Compat.Environment
143143
( getEnvironment, lookupEnv )
144144
import qualified Data.Map as M
145+
import qualified Data.ByteString as BS
145146

146147
--
147148
-- * Configuration saved in the config file
@@ -781,7 +782,7 @@ readConfigFile
781782
:: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig))
782783
readConfigFile initial file = handleNotExists $
783784
fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial)
784-
(readFile file)
785+
(BS.readFile file)
785786

786787
where
787788
handleNotExists action = catchIO action $ \ioe ->
@@ -1101,7 +1102,7 @@ liftReportFlag = liftField
11011102

11021103
parseConfig :: ConstraintSource
11031104
-> SavedConfig
1104-
-> String
1105+
-> BS.ByteString
11051106
-> ParseResult SavedConfig
11061107
parseConfig src initial = \str -> do
11071108
fields <- readFields str
@@ -1402,7 +1403,7 @@ withProgramOptionsFields =
14021403
parseExtraLines :: Verbosity -> [String] -> IO SavedConfig
14031404
parseExtraLines verbosity extraLines =
14041405
case parseConfig (ConstraintSourceMainConfig "additional lines")
1405-
mempty (unlines extraLines) of
1406+
mempty (toUTF8BS (unlines extraLines)) of
14061407
ParseFailed err ->
14071408
let (line, msg) = locatedErrorMsg err
14081409
in die' verbosity $

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -71,7 +71,7 @@ data GlobalFlags = GlobalFlags
7171
, globalNix :: Flag Bool -- ^ Integrate with Nix
7272
, globalStoreDir :: Flag FilePath
7373
, globalProgPathExtra :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports)
74-
} deriving Generic
74+
} deriving (Show, Generic)
7575

7676
defaultGlobalFlags :: GlobalFlags
7777
defaultGlobalFlags = GlobalFlags

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

Lines changed: 9 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -47,14 +47,15 @@ import Prelude ()
4747

4848
import Distribution.Deprecated.ParseUtils
4949
( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo
50-
, Field(..), liftField, readFieldsFlat )
50+
, Field(..), liftField, readFields )
5151
import Distribution.Deprecated.ViewAsFieldDescr
5252
( viewAsFieldDescr )
5353

5454
import Distribution.Simple.Command
5555
( OptionField )
5656

5757
import Text.PrettyPrint ( ($+$) )
58+
import qualified Data.ByteString as BS
5859
import qualified Data.Map as Map
5960
import qualified Text.PrettyPrint as Disp
6061
( (<>), Doc, text, colon, vcat, empty, isEmpty, nest )
@@ -243,7 +244,7 @@ parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs =
243244
b <- parseFieldsAndSections fieldDescrs' sectionDescrs' [] sectionEmpty fields
244245
set line param b a
245246
Just (Right (FGSectionDescr _ grammar _getter setter)) -> do
246-
let fields1 = mapMaybe convertField fields
247+
let fields1 = map convertField fields
247248
(fields2, sections) = partitionFields fields1
248249
-- TODO: recurse into sections
249250
for_ (concat sections) $ \(FG.MkSection (F.Name (Position line' _) name') _ _) ->
@@ -262,23 +263,16 @@ parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs =
262263
++ "' on line " ++ show line
263264
return a
264265

265-
setField accum (block@IfBlock {}) = do
266-
warning $ "Unrecognized stanza on line " ++ show (lineNo block)
267-
return accum
268-
269-
convertField :: Field -> Maybe (F.Field Position)
270-
convertField (F line name str) = Just $
266+
convertField :: Field -> F.Field Position
267+
convertField (F line name str) =
271268
F.Field (F.Name pos (toUTF8BS name)) [ F.FieldLine pos $ toUTF8BS str ]
272269
where
273270
pos = Position line 0
274271
-- arguments omitted
275-
convertField (Section line name _arg fields) = Just $
276-
F.Section (F.Name pos (toUTF8BS name)) [] (mapMaybe convertField fields)
272+
convertField (Section line name _arg fields) =
273+
F.Section (F.Name pos (toUTF8BS name)) [] (map convertField fields)
277274
where
278275
pos = Position line 0
279-
-- silently omitted.
280-
convertField IfBlock {} = Nothing
281-
282276

283277
-- | Much like 'ppFields' but also pretty prints any subsections. Subsection
284278
-- are only shown if they are non-empty.
@@ -361,10 +355,10 @@ ppFgSection secName arg grammar x
361355
-- It accumulates the result on top of a given initial (typically empty) value.
362356
--
363357
parseConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.ParsecFieldGrammar a] -> a
364-
-> String -> ParseResult a
358+
-> BS.ByteString -> ParseResult a
365359
parseConfig fieldDescrs sectionDescrs fgSectionDescrs empty str =
366360
parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs empty
367-
=<< readFieldsFlat str
361+
=<< readFields str
368362

369363
-- | Render a value in the config file syntax, based on a description of the
370364
-- configuration file in terms of its fields and sections.

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -573,7 +573,7 @@ readProjectFile verbosity DistDirLayout{distProjectFile}
573573
readExtensionFile =
574574
reportParseResult verbosity extensionDescription extensionFile
575575
. parseProjectConfig
576-
=<< readFile extensionFile
576+
=<< BS.readFile extensionFile
577577

578578
addProjectFileProvenance config =
579579
config {
@@ -587,7 +587,7 @@ readProjectFile verbosity DistDirLayout{distProjectFile}
587587
-- For the moment this is implemented in terms of parsers for legacy
588588
-- configuration types, plus a conversion.
589589
--
590-
parseProjectConfig :: String -> OldParser.ParseResult ProjectConfig
590+
parseProjectConfig :: BS.ByteString -> OldParser.ParseResult ProjectConfig
591591
parseProjectConfig content =
592592
convertLegacyProjectConfig <$>
593593
parseLegacyProjectConfig content

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

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -95,6 +95,7 @@ import Distribution.Types.PackageVersionConstraint
9595
import Distribution.Parsec (ParsecParser)
9696

9797
import qualified Data.Map as Map
98+
import qualified Data.ByteString as BS
9899

99100
import Network.URI (URI (..))
100101

@@ -121,7 +122,7 @@ data LegacyProjectConfig = LegacyProjectConfig {
121122
legacyAllConfig :: LegacyPackageConfig,
122123
legacyLocalConfig :: LegacyPackageConfig,
123124
legacySpecificConfig :: MapMappend PackageName LegacyPackageConfig
124-
} deriving Generic
125+
} deriving (Show, Generic)
125126

126127
instance Monoid LegacyProjectConfig where
127128
mempty = gmempty
@@ -136,7 +137,7 @@ data LegacyPackageConfig = LegacyPackageConfig {
136137
legacyHaddockFlags :: HaddockFlags,
137138
legacyTestFlags :: TestFlags,
138139
legacyBenchmarkFlags :: BenchmarkFlags
139-
} deriving Generic
140+
} deriving (Show, Generic)
140141

141142
instance Monoid LegacyPackageConfig where
142143
mempty = gmempty
@@ -152,7 +153,7 @@ data LegacySharedConfig = LegacySharedConfig {
152153
legacyInstallFlags :: InstallFlags,
153154
legacyClientInstallFlags:: ClientInstallFlags,
154155
legacyProjectFlags :: ProjectFlags
155-
} deriving Generic
156+
} deriving (Show, Generic)
156157

157158
instance Monoid LegacySharedConfig where
158159
mempty = gmempty
@@ -843,7 +844,7 @@ convertToLegacyPerPackageConfig PackageConfig {..} =
843844
-- Parsing and showing the project config file
844845
--
845846

846-
parseLegacyProjectConfig :: String -> ParseResult LegacyProjectConfig
847+
parseLegacyProjectConfig :: BS.ByteString -> ParseResult LegacyProjectConfig
847848
parseLegacyProjectConfig =
848849
parseConfig legacyProjectConfigFieldDescrs
849850
legacyPackageConfigSectionDescrs

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

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -52,6 +52,7 @@ import System.FilePath ( (</>) )
5252
import System.IO.Error ( isDoesNotExistError )
5353
import Text.PrettyPrint ( ($+$) )
5454

55+
import qualified Data.ByteString as BS
5556
import qualified Text.PrettyPrint as Disp
5657
import qualified Distribution.Deprecated.ParseUtils as ParseUtils ( Field(..) )
5758

@@ -180,15 +181,15 @@ readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath
180181
-> IO (Maybe (ParseResult PackageEnvironment))
181182
readPackageEnvironmentFile src initial file =
182183
handleNotExists $
183-
fmap (Just . parsePackageEnvironment src initial) (readFile file)
184+
fmap (Just . parsePackageEnvironment src initial) (BS.readFile file)
184185
where
185186
handleNotExists action = catchIO action $ \ioe ->
186187
if isDoesNotExistError ioe
187188
then return Nothing
188189
else ioError ioe
189190

190191
-- | Parse the package environment file.
191-
parsePackageEnvironment :: ConstraintSource -> PackageEnvironment -> String
192+
parsePackageEnvironment :: ConstraintSource -> PackageEnvironment -> BS.ByteString
192193
-> ParseResult PackageEnvironment
193194
parsePackageEnvironment src initial str = do
194195
fields <- readFields str

0 commit comments

Comments
 (0)