Commit eb5e6f32 authored by Oleg Grenrus's avatar Oleg Grenrus

runParseResult reutrns NonEmpty PError

parent 0d2d9ca7
......@@ -282,7 +282,8 @@ library
if impl(ghc >= 8.0)
ghc-options: -Wcompat -Wnoncanonical-monad-instances
-Wnoncanonical-monadfail-instances
else
if !impl(ghc >= 8.0)
-- at least one of lib:Cabal's dependency (i.e. `parsec`)
-- already depends on `fail` and `semigroups` transitively
build-depends: fail == 4.9.*, semigroups >= 0.18.3 && < 0.20
......@@ -636,6 +637,9 @@ test-suite parser-tests
ghc-options: -Wall
default-language: Haskell2010
if !impl(ghc >= 8.0)
build-depends: semigroups
if impl(ghc >= 7.8)
build-depends:
tree-diff >= 0.0.2 && <0.1
......@@ -660,6 +664,8 @@ test-suite check-tests
Cabal
ghc-options: -Wall
default-language: Haskell2010
if !impl(ghc >= 8.0)
build-depends: semigroups
test-suite custom-setup-tests
type: exitcode-stdio-1.0
......
......@@ -50,13 +50,14 @@ emptyPRState = PRState [] [] Nothing
-- | Destruct a 'ParseResult' into the emitted warnings and either
-- a successful value or
-- list of errors and possibly recovered a spec-version declaration.
runParseResult :: ParseResult a -> ([PWarning], Either (Maybe Version, [PError]) a)
runParseResult :: ParseResult a -> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
runParseResult pr = unPR pr emptyPRState failure success
where
failure (PRState warns errs v) = (warns, Left (v, errs))
success (PRState warns [] _) x = (warns, Right x)
failure (PRState warns [] v) = (warns, Left (v, PError zeroPos "panic" :| []))
failure (PRState warns (err:errs) v) = (warns, Left (v, err :| errs)) where
success (PRState warns [] _) x = (warns, Right x)
-- If there are any errors, don't return the result
success (PRState warns errs v) _ = (warns, Left (v, errs))
success (PRState warns (err:errs) v) _ = (warns, Left (v, err :| errs))
instance Functor ParseResult where
fmap f (PR pr) = PR $ \ !s failure success ->
......
......@@ -96,15 +96,15 @@ sourceComponentName = CLibName . sourceLibName
-- /Note:/ errors array /may/ be empty, but the parse is still failed (it's a bug though)
parseInstalledPackageInfo
:: String
-> Either [String] ([String], InstalledPackageInfo)
-> Either (NonEmpty String) ([String], InstalledPackageInfo)
parseInstalledPackageInfo s = case P.readFields (toUTF8BS s) of
Left err -> Left [show err]
Left err -> Left (show err :| [])
Right fs -> case partitionFields fs of
(fs', _) -> case P.runParseResult $ parseFieldGrammar cabalSpecLatest fs' ipiFieldGrammar of
(ws, Right x) -> Right (ws', x) where
ws' = map (P.showPWarning "") ws
(_, Left (_, errs)) -> Left errs' where
errs' = map (P.showPError "") errs
errs' = fmap (P.showPError "") errs
-- -----------------------------------------------------------------------------
-- Pretty-printing
......
......@@ -9,6 +9,7 @@ import Distribution.Compat.Prelude
import Data.Either (partitionEithers)
import qualified Data.Map as Map (empty)
import qualified Data.List.NonEmpty as NE
import Distribution.Simple.Program
import Distribution.Simple.Compiler as Compiler
......@@ -139,7 +140,7 @@ getInstalledPackages verbosity packagedbs progdb =
parsePackages str =
case partitionEithers $ map parseInstalledPackageInfo (splitPkgs str) of
([], ok) -> Right [ pkg | (_, pkg) <- ok ]
(msgss, _) -> Left (concat msgss)
(msgss, _) -> Left (foldMap NE.toList msgss)
splitPkgs :: String -> [String]
splitPkgs = map unlines . splitWith ("---" ==) . lines
......
......@@ -46,6 +46,7 @@ import Prelude ()
import Distribution.Compat.Prelude hiding (init)
import Data.Either (partitionEithers)
import qualified Data.List.NonEmpty as NE
import Distribution.InstalledPackageInfo
import Distribution.Simple.Compiler
......@@ -263,7 +264,7 @@ parsePackages :: String -> Either [InstalledPackageInfo] [String]
parsePackages str =
case partitionEithers $ map parseInstalledPackageInfo (splitPkgs str) of
([], ok) -> Left [ setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok ]
(msgss, _) -> Right (concat msgss)
(msgss, _) -> Right (foldMap NE.toList msgss)
--TODO: this could be a lot faster. We're doing normaliseLineEndings twice
-- and converting back and forth with lines/unlines.
......
......@@ -17,6 +17,7 @@ import System.FilePath (replaceExtension, (</>))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.List.NonEmpty as NE
tests :: TestTree
tests = checkTests
......@@ -52,7 +53,7 @@ checkTest fp = cabalGoldenTest fp correct $ do
-- D.PD.Check functionality.
unlines (map (showPWarning fp) ws) ++
unlines (map show (checkPackage gpd Nothing))
Left (_, errs) -> unlines $ map (("ERROR: " ++) . showPError fp) errs
Left (_, errs) -> unlines $ map (("ERROR: " ++) . showPError fp) $ NE.toList errs
where
input = "tests" </> "ParserTests" </> "regressions" </> fp
correct = replaceExtension input "check"
......
......@@ -26,6 +26,7 @@ import System.FilePath (replaceExtension, (</>))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.List.NonEmpty as NE
import qualified Distribution.InstalledPackageInfo as IPI
......@@ -136,7 +137,7 @@ errorTest fp = cabalGoldenTest fp correct $ do
"UNXPECTED SUCCESS\n" ++
showGenericPackageDescription gpd
Left (v, errs) ->
unlines $ ("VERSION: " ++ show v) : map (showPError fp) errs
unlines $ ("VERSION: " ++ show v) : map (showPError fp) (NE.toList errs)
where
input = "tests" </> "ParserTests" </> "errors" </> fp
correct = replaceExtension input "errors"
......@@ -202,7 +203,7 @@ formatGoldenTest fp = cabalGoldenTest "format" correct $ do
unlines (map (showPWarning fp) warns)
++ showGenericPackageDescription gpd
Left (_, errs) ->
unlines $ "ERROR" : map (showPError fp) errs
unlines $ "ERROR" : map (showPError fp) (NE.toList errs)
where
input = "tests" </> "ParserTests" </> "regressions" </> fp
correct = replaceExtension input "format"
......@@ -215,7 +216,7 @@ treeDiffGoldenTest fp = ediffGolden goldenTest "expr" exprFile $ do
let (_, x) = runParseResult res
case x of
Right gpd -> pure (toExpr gpd)
Left (_, errs) -> fail $ unlines $ "ERROR" : map (showPError fp) errs
Left (_, errs) -> fail $ unlines $ "ERROR" : map (showPError fp) (NE.toList errs)
where
input = "tests" </> "ParserTests" </> "regressions" </> fp
exprFile = replaceExtension input "expr"
......@@ -251,7 +252,7 @@ formatRoundTripTest fp = testCase "roundtrip" $ do
case x' of
Right gpd -> pure gpd
Left (_, errs) -> do
void $ assertFailure $ unlines (map (showPError fp) errs)
void $ assertFailure $ unlines (map (showPError fp) $ NE.toList errs)
fail "failure"
input = "tests" </> "ParserTests" </> "regressions" </> fp
......
......@@ -32,6 +32,7 @@ module Distribution.Client.Install (
import Prelude ()
import Distribution.Client.Compat.Prelude
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Set as S
import Control.Exception as Exception
......@@ -1549,7 +1550,7 @@ installUnpackedPackage verbosity installLock numJobs
readPkgConf pkgConfDir pkgConfFile =
(withUTF8FileContents (pkgConfDir </> pkgConfFile) $ \pkgConfText ->
case Installed.parseInstalledPackageInfo pkgConfText of
Left perrors -> pkgConfParseFailed $ unlines perrors
Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors
Right (warns, pkgConf) -> do
unless (null warns) $
warn verbosity $ unlines warns
......
......@@ -95,6 +95,7 @@ import Distribution.Verbosity
import Distribution.Pretty
import Distribution.Compat.Graph (IsNode(..))
import qualified Data.List.NonEmpty as NE
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
......@@ -1444,7 +1445,7 @@ withTempInstalledPackageInfoFile verbosity tempdir action =
(warns, ipkg) <-
withUTF8FileContents (pkgConfDir </> pkgConfFile) $ \pkgConfStr ->
case Installed.parseInstalledPackageInfo pkgConfStr of
Left perrors -> pkgConfParseFailed $ unlines perrors
Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors
Right (warns, ipkg) -> return (warns, ipkg)
unless (null warns) $
......
......@@ -1229,11 +1229,11 @@ mkSpecificSourcePackage location pkg =
-- | Errors reported upon failing to parse a @.cabal@ file.
--
data CabalFileParseError = CabalFileParseError
FilePath -- ^ @.cabal@ file path
BS.ByteString -- ^ @.cabal@ file contents
[PError] -- ^ errors
(Maybe Version) -- ^ We might discover the spec version the package needs
[PWarning] -- ^ warnings
FilePath -- ^ @.cabal@ file path
BS.ByteString -- ^ @.cabal@ file contents
(NonEmpty PError) -- ^ errors
(Maybe Version) -- ^ We might discover the spec version the package needs
[PWarning] -- ^ warnings
deriving (Typeable)
-- | Manual instance which skips file contentes
......
......@@ -16,7 +16,7 @@ import Distribution.Simple.Utils (fromUTF8BS)
renderParseError
:: FilePath
-> BS.ByteString
-> [PError]
-> NonEmpty PError
-> [PWarning]
-> String
renderParseError filepath contents errors warnings = unlines $
......
......@@ -338,6 +338,7 @@ executable cabal
if !impl(ghc >= 8.0)
build-depends: fail == 4.9.*
build-depends: semigroups >= 0.18.3 && <0.20
if flag(native-dns)
if os(windows)
......
......@@ -48,6 +48,7 @@ Version: 3.1.0.0
if !impl(ghc >= 8.0)
build-depends: fail == 4.9.*
build-depends: semigroups >= 0.18.3 && <0.20
if flag(native-dns)
if os(windows)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment