diff --git a/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs b/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs index 46299b8edac..4ebc5188ffc 100644 --- a/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs +++ b/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 diff --git a/Cabal/src/Distribution/Fields/Field.hs b/Cabal/src/Distribution/Fields/Field.hs index 42108eef549..f0f260c6d98 100644 --- a/Cabal/src/Distribution/Fields/Field.hs +++ b/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 diff --git a/Cabal/src/Distribution/Pretty.hs b/Cabal/src/Distribution/Pretty.hs index f7e7893f9e6..1dfed5c8337 100644 --- a/Cabal/src/Distribution/Pretty.hs +++ b/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 == ',' diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs index 139eed29425..ed3c058f46d 100644 --- a/cabal-install/src/Distribution/Client/Config.hs +++ b/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 $ diff --git a/cabal-install/src/Distribution/Client/GlobalFlags.hs b/cabal-install/src/Distribution/Client/GlobalFlags.hs index 4c050690f47..d44e3eb9733 100644 --- a/cabal-install/src/Distribution/Client/GlobalFlags.hs +++ b/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 diff --git a/cabal-install/src/Distribution/Client/ParseUtils.hs b/cabal-install/src/Distribution/Client/ParseUtils.hs index 2e94cd4bc34..ef94a167712 100644 --- a/cabal-install/src/Distribution/Client/ParseUtils.hs +++ b/cabal-install/src/Distribution/Client/ParseUtils.hs @@ -47,7 +47,7 @@ import Prelude () import Distribution.Deprecated.ParseUtils ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo - , Field(..), liftField, readFieldsFlat ) + , Field(..), liftField, readFields ) import Distribution.Deprecated.ViewAsFieldDescr ( viewAsFieldDescr ) @@ -55,6 +55,7 @@ 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. diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index 5a42729a841..736b07d7e80 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/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 diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index c7622c092e0..f0ce83db1ab 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/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 diff --git a/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs b/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs index 7ecab15ce10..f199455262a 100644 --- a/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs +++ b/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,7 +181,7 @@ 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 @@ -188,7 +189,7 @@ readPackageEnvironmentFile src initial file = 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 diff --git a/cabal-install/src/Distribution/Deprecated/ParseUtils.hs b/cabal-install/src/Distribution/Deprecated/ParseUtils.hs index 67de8dfd2ca..5ddcc778e8e 100644 --- a/cabal-install/src/Distribution/Deprecated/ParseUtils.hs +++ b/cabal-install/src/Distribution/Deprecated/ParseUtils.hs @@ -25,7 +25,7 @@ module Distribution.Deprecated.ParseUtils ( LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning, runP, runE, ParseResult(..), parseFail, showPWarning, Field(..), lineNo, - FieldDescr(..), readFields, readFieldsFlat, + FieldDescr(..), readFields, parseHaskellString, parseFilePathQ, parseTokenQ, parseOptCommaList, showFilePath, showToken, showFreeText, @@ -51,7 +51,6 @@ import Distribution.Pretty import Distribution.ReadE import Distribution.Utils.Generic -import Data.Tree as Tree (Tree (..), flatten) import System.FilePath (normalise) import Text.PrettyPrint (Doc, punctuate, comma, fsep, sep) import qualified Text.Read as Read @@ -59,6 +58,14 @@ import qualified Text.Read as Read import qualified Control.Monad.Fail as Fail import Distribution.Parsec (ParsecParser, parsecLeadingCommaList, parsecLeadingOptCommaList) +import qualified Data.ByteString as BS +import qualified Distribution.Fields as Fields +import qualified Distribution.Fields.Field as Fields +import qualified Distribution.Parsec as Parsec +import qualified Distribution.Fields.LexerMonad as Fields +import qualified Text.Parsec.Error as PE +import qualified Text.Parsec.Pos as PP + -- ----------------------------------------------------------------------------- type LineNo = Int @@ -151,8 +158,6 @@ locatedErrorMsg (FromString s n) = (n, s) syntaxError :: LineNo -> String -> ParseResult a syntaxError n s = ParseFailed $ FromString s (Just n) -tabsError :: LineNo -> ParseResult a -tabsError ln = ParseFailed $ TabsError ln warning :: String -> ParseResult () warning s = ParseOk [PWarning s] () @@ -283,244 +288,37 @@ data Field -- * -- } -- @ - | IfBlock LineNo String [Field] [Field] - -- ^ A conditional block with an optional else branch: - -- - -- @ - -- if { - -- * - -- } else { - -- * - -- } - -- @ deriving (Show ,Eq) -- for testing lineNo :: Field -> LineNo lineNo (F n _ _) = n lineNo (Section n _ _ _) = n -lineNo (IfBlock n _ _ _) = n - -readFields :: String -> ParseResult [Field] -readFields input = ifelse - =<< traverse (mkField 0) - =<< mkTree tokens - - where ls = (lines . normaliseLineEndings) input - tokens = (concatMap tokeniseLine . trimLines) ls - -readFieldsFlat :: String -> ParseResult [Field] -readFieldsFlat input = traverse (mkField 0) - =<< mkTree tokens - where ls = (lines . normaliseLineEndings) input - tokens = (concatMap tokeniseLineFlat . trimLines) ls - --- attach line number and determine indentation -trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)] -trimLines ls = [ (lineno, indent, hastabs, trimTrailing l') - | (lineno, l) <- zip [1..] ls - , let (sps, l') = span isSpace l - indent = length sps - hastabs = '\t' `elem` sps - , validLine l' ] - where validLine ('-':'-':_) = False -- Comment - validLine [] = False -- blank line - validLine _ = True - --- | We parse generically based on indent level and braces '{' '}'. To do that --- we split into lines and then '{' '}' tokens and other spans within a line. -data Token = - -- | The 'Line' token is for bits that /start/ a line, eg: - -- - -- > "\n blah blah { blah" - -- - -- tokenises to: - -- - -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"] - -- - -- so lines are the only ones that can have nested layout, since they - -- have a known indentation level. - -- - -- eg: we can't have this: - -- - -- > if ... { - -- > } else - -- > other - -- - -- because other cannot nest under else, since else doesn't start a line - -- so cannot have nested layout. It'd have to be: - -- - -- > if ... { - -- > } - -- > else - -- > other - -- - -- but that's not so common, people would normally use layout or - -- brackets not both in a single @if else@ construct. - -- - -- > if ... { foo : bar } - -- > else - -- > other - -- - -- this is OK - Line LineNo Indent HasTabs String - | Span LineNo String -- ^ span in a line, following brackets - | OpenBracket LineNo | CloseBracket LineNo - -type Indent = Int -type HasTabs = Bool - --- | Tokenise a single line, splitting on '{' '}' and the spans in between. --- Also trims leading & trailing space on those spans within the line. -tokeniseLine :: (LineNo, Indent, HasTabs, String) -> [Token] -tokeniseLine (n0, i, t, l) = case split n0 l of - (Span _ l':ss) -> Line n0 i t l' :ss - cs -> cs - where split _ "" = [] - split n s = case span (\c -> c /='}' && c /= '{') s of - ("", '{' : s') -> OpenBracket n : split n s' - (w , '{' : s') -> mkspan n w (OpenBracket n : split n s') - ("", '}' : s') -> CloseBracket n : split n s' - (w , '}' : s') -> mkspan n w (CloseBracket n : split n s') - (w , _) -> mkspan n w [] - - mkspan n s ss | null s' = ss - | otherwise = Span n s' : ss - where s' = trimTrailing (trimLeading s) - -tokeniseLineFlat :: (LineNo, Indent, HasTabs, String) -> [Token] -tokeniseLineFlat (n0, i, t, l) - | null l' = [] - | otherwise = [Line n0 i t l'] - where - l' = trimTrailing (trimLeading l) - -trimLeading, trimTrailing :: String -> String -trimLeading = dropWhile isSpace -trimTrailing = dropWhileEndLE isSpace - - -type SyntaxTree = Tree (LineNo, HasTabs, String) - --- | Parse the stream of tokens into a tree of them, based on indent \/ layout -mkTree :: [Token] -> ParseResult [SyntaxTree] -mkTree toks = - layout 0 [] toks >>= \(trees, trailing) -> case trailing of - [] -> return trees - OpenBracket n:_ -> syntaxError n "mismatched brackets, unexpected {" - CloseBracket n:_ -> syntaxError n "mismatched brackets, unexpected }" - -- the following two should never happen: - Span n l :_ -> syntaxError n $ "unexpected span: " ++ show l - Line n _ _ l :_ -> syntaxError n $ "unexpected line: " ++ show l - - --- | Parse the stream of tokens into a tree of them, based on indent --- This parse state expect to be in a layout context, though possibly --- nested within a braces context so we may still encounter closing braces. -layout :: Indent -- ^ indent level of the parent\/previous line - -> [SyntaxTree] -- ^ accumulating param, trees in this level - -> [Token] -- ^ remaining tokens - -> ParseResult ([SyntaxTree], [Token]) - -- ^ collected trees on this level and trailing tokens -layout _ a [] = return (reverse a, []) -layout i a (s@(Line _ i' _ _):ss) | i' < i = return (reverse a, s:ss) -layout i a (Line n _ t l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - layout i (Node (n,t,l) sub:a) ss' - -layout i a (Span n l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - layout i (Node (n,False,l) sub:a) ss' - --- look ahead to see if following lines are more indented, giving a sub-tree -layout i a (Line n i' t l:ss) = do - lookahead <- layout (i'+1) [] ss - case lookahead of - ([], _) -> layout i (Node (n,t,l) [] :a) ss - (ts, ss') -> layout i (Node (n,t,l) ts :a) ss' - -layout _ _ ( OpenBracket n :_) = syntaxError n "unexpected '{'" -layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss) -layout _ _ ( Span n l : _) = syntaxError n $ "unexpected span: " - ++ show l - --- | Parse the stream of tokens into a tree of them, based on explicit braces --- This parse state expects to find a closing bracket. -braces :: LineNo -- ^ line of the '{', used for error messages - -> [SyntaxTree] -- ^ accumulating param, trees in this level - -> [Token] -- ^ remaining tokens - -> ParseResult ([SyntaxTree],[Token]) - -- ^ collected trees on this level and trailing tokens -braces m a (Line n _ t l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - braces m (Node (n,t,l) sub:a) ss' - -braces m a (Span n l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - braces m (Node (n,False,l) sub:a) ss' - -braces m a (Line n i t l:ss) = do - lookahead <- layout (i+1) [] ss - case lookahead of - ([], _) -> braces m (Node (n,t,l) [] :a) ss - (ts, ss') -> braces m (Node (n,t,l) ts :a) ss' - -braces m a (Span n l:ss) = braces m (Node (n,False,l) []:a) ss -braces _ a (CloseBracket _:ss) = return (reverse a, ss) -braces n _ [] = syntaxError n $ "opening brace '{'" - ++ "has no matching closing brace '}'" -braces _ _ (OpenBracket n:_) = syntaxError n "unexpected '{'" - --- | Convert the parse tree into the Field AST --- Also check for dodgy uses of tabs in indentation. -mkField :: Int -> SyntaxTree -> ParseResult Field -mkField d (Node (n,t,_) _) | d >= 1 && t = tabsError n -mkField d (Node (n,_,l) ts) = case span (\c -> isAlphaNum c || c == '-') l of - ([], _) -> syntaxError n $ "unrecognised field or section: " ++ show l - (name, rest) -> case trimLeading rest of - (':':rest') -> do let followingLines = concatMap Tree.flatten ts - tabs = not (null [()| (_,True,_) <- followingLines ]) - if tabs && d >= 1 - then tabsError n - else return $ F n (map toLower name) - (fieldValue rest' followingLines) - rest' -> do ts' <- traverse (mkField (d+1)) ts - return (Section n (map toLower name) rest' ts') - where fieldValue firstLine followingLines = - let firstLine' = trimLeading firstLine - followingLines' = map (\(_,_,s) -> stripDot s) followingLines - allLines | null firstLine' = followingLines' - | otherwise = firstLine' : followingLines' - in intercalate "\n" allLines - stripDot "." = "" - stripDot s = s - --- | Convert if/then/else 'Section's to 'IfBlock's -ifelse :: [Field] -> ParseResult [Field] -ifelse [] = return [] -ifelse (Section n "if" cond thenpart - :Section _ "else" as elsepart:fs) - | null cond = syntaxError n "'if' with missing condition" - | null thenpart = syntaxError n "'then' branch of 'if' is empty" - | not (null as) = syntaxError n "'else' takes no arguments" - | null elsepart = syntaxError n "'else' branch of 'if' is empty" - | otherwise = do tp <- ifelse thenpart - ep <- ifelse elsepart - fs' <- ifelse fs - return (IfBlock n cond tp ep:fs') -ifelse (Section n "if" cond thenpart:fs) - | null cond = syntaxError n "'if' with missing condition" - | null thenpart = syntaxError n "'then' branch of 'if' is empty" - | otherwise = do tp <- ifelse thenpart - fs' <- ifelse fs - return (IfBlock n cond tp []:fs') -ifelse (Section n "else" _ _:_) = syntaxError n - "stray 'else' with no preceding 'if'" -ifelse (Section n s a fs':fs) = do fs'' <- ifelse fs' - fs''' <- ifelse fs - return (Section n s a fs'' : fs''') -ifelse (f:fs) = do fs' <- ifelse fs - return (f : fs') + +readFields :: BS.ByteString -> ParseResult [Field] +readFields input = case Fields.readFields' input of + Right (fs, ws) -> ParseOk + [ PWarning msg | Fields.PWarning _ _ msg <- Fields.toPWarnings ws ] + (legacyFields fs) + Left perr -> ParseFailed $ NoParse + (PE.showErrorMessages + "or" "unknown parse error" "expecting" "unexpected" "end of file" + (PE.errorMessages perr)) + (PP.sourceLine pos) + where + pos = PE.errorPos perr + +legacyFields :: [Fields.Field Parsec.Position] -> [Field] +legacyFields = map legacyField + +legacyField :: Fields.Field Parsec.Position -> Field +legacyField (Fields.Field (Fields.Name pos name) fls) = + F (posToLineNo pos) (fromUTF8BS name) (Fields.fieldLinesToString fls) +legacyField (Fields.Section (Fields.Name pos name) args fs) = + Section (posToLineNo pos) (fromUTF8BS name) (Fields.sectionArgsToString args) (legacyFields fs) + +posToLineNo :: Parsec.Position -> LineNo +posToLineNo (Parsec.Position row _) = row ------------------------------------------------------------------------------ diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs index e4a34d35a4a..ee286d0554f 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -135,6 +135,7 @@ instance Arbitrary ShortToken where arbitrary = ShortToken <$> (shortListOf1 5 (choose ('#', '~')) + `suchThat` (all (`notElem` "{}")) `suchThat` (not . ("[]" `isPrefixOf`))) --TODO: [code cleanup] need to replace parseHaskellString impl to stop -- accepting Haskell list syntax [], ['a'] etc, just allow String syntax. @@ -183,7 +184,8 @@ arbitraryFlag :: Gen a -> Gen (Flag a) arbitraryFlag = liftArbitrary instance Arbitrary RepoName where - arbitrary = RepoName <$> mk where + -- TODO: rename refinement? + arbitrary = RepoName <$> (mk `suchThat` \x -> not $ "--" `isPrefixOf` x) where mk = (:) <$> lead <*> rest lead = elements [ c | c <- [ '\NUL' .. '\255' ], isAlpha c || c `elem` "_-."] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 132aa4090d8..51fef6ca95b 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -28,6 +28,7 @@ import Distribution.Compiler import Distribution.Version import Distribution.Simple.Program.Types import Distribution.Simple.Program.Db +import Distribution.Simple.Utils (toUTF8BS) import Distribution.Types.PackageVersionConstraint import Distribution.Parsec @@ -99,10 +100,12 @@ tests = -- Round trip: conversion to/from legacy types -- -roundtrip :: (Eq a, ToExpr a) => (a -> b) -> (b -> a) -> a -> Property +roundtrip :: (Eq a, ToExpr a, Show b) => (a -> b) -> (b -> a) -> a -> Property roundtrip f f_inv x = - let y = f x - in x `ediffEq` f_inv y -- no counterexample with y, as they not have ToExpr + counterexample (show y) $ + x `ediffEq` f_inv y -- no counterexample with y, as they not have ToExpr + where + y = f x roundtrip_legacytypes :: ProjectConfig -> Property roundtrip_legacytypes = @@ -155,10 +158,10 @@ prop_roundtrip_legacytypes_specific config = roundtrip_printparse :: ProjectConfig -> Property roundtrip_printparse config = - case fmap convertLegacyProjectConfig (parseLegacyProjectConfig str) of - ParseOk _ x -> counterexample ("shown: " ++ str) $ + case fmap convertLegacyProjectConfig (parseLegacyProjectConfig (toUTF8BS str)) of + ParseOk _ x -> counterexample ("shown:\n" ++ str) $ x `ediffEq` config { projectConfigProvenance = mempty } - ParseFailed err -> counterexample (show err) False + ParseFailed err -> counterexample ("shown:\n" ++ str ++ "\nERROR: " ++ show err) False where str :: String str = showLegacyProjectConfig (convertToLegacyProjectConfig config) @@ -344,6 +347,7 @@ instance Arbitrary PackageLocationString where , arbitraryGlobLikeStr , show <$> (arbitrary :: Gen URI) ] + `suchThat` (\xs -> not ("{" `isPrefixOf` xs)) arbitraryGlobLikeStr :: Gen String arbitraryGlobLikeStr = outerTerm