diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,13 @@ +## 0.7 + +- Use `Cabal-syntax-3.18`. + The breaking changes from `Cabal-syntax` unfortunately leak into public interface of `cabal-install-parsers` in this update, therefore the major update to `cabal-install-parsers. +- Drop support for GHC prior 9.4.8 + +## 0.6.4 + +- Add support for reading project files with conditionals. + ## 0.6.3 - Drop support for GHC prior 8.8.4 diff --git a/cabal-install-parsers.cabal b/cabal-install-parsers.cabal --- a/cabal-install-parsers.cabal +++ b/cabal-install-parsers.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: cabal-install-parsers -version: 0.6.3 +version: 0.7 synopsis: Utilities to work with cabal-install files description: @cabal-install-parsers@ provides parsers for @cabal-install@ files: @@ -25,15 +25,12 @@ category: Development build-type: Simple tested-with: - GHC ==8.8.4 - || ==8.10.7 - || ==9.0.2 - || ==9.2.8 - || ==9.4.8 + GHC ==9.4.8 || ==9.6.7 || ==9.8.4 - || ==9.10.2 - || ==9.12.2 + || ==9.10.3 + || ==9.12.4 + || ==9.14.1 extra-source-files: Changelog.md @@ -66,29 +63,29 @@ -- GHC-boot libraries build-depends: - , base >=4.13.0.0 && <4.22 - , binary ^>=0.8.7.0 - , bytestring ^>=0.10.10.1 || ^>=0.11.1.0 || ^>=0.12.0.2 - , Cabal-syntax ^>=3.14.2.0 - , containers ^>=0.6.2.1 || ^>=0.7 - , deepseq ^>=1.4.4.0 || ^>=1.5.0.0 + , base >=4.17.2.1 && <4.23 + , binary ^>=0.8.9.1 + , bytestring ^>=0.11.5.3 || ^>=0.12.0.2 + , Cabal-syntax ^>=3.18.1.0 + , containers ^>=0.6.7 || ^>=0.7 || ^>=0.8 + , deepseq ^>=1.4.8.0 || ^>=1.5.0.0 , directory ^>=1.3.6.0 - , filepath ^>=1.4.2.1 || ^>=1.5.2.0 + , filepath ^>=1.4.2.1 || ^>=1.5.2.0 , parsec ^>=3.1.14.0 , pretty ^>=1.1.3.6 - , text ^>=1.2.4.0 || ^>=2.0.1 || ^>=2.1 - , time ^>=1.9.3 || ^>=1.11.1.1 || ^>=1.12.2 || ^>=1.14 - , transformers ^>=0.5.6.2 || ^>=0.6.1.0 + , text ^>=2.0.2 || ^>=2.1 + , time ^>=1.12.2 || ^>=1.14 || ^>=1.15 + , transformers ^>=0.5.6.2 || ^>=0.6.1.0 -- extra dependencies build-depends: - , aeson ^>=2.1.0.0 || ^>=2.2.0.0 + , aeson ^>=2.1.0.0 || ^>=2.2.0.0 || ^>=2.3.0.0 , base16-bytestring ^>=1.0.0.0 , binary-instances ^>=1 , cryptohash-sha256 ^>=0.11.101.0 , lukko ^>=0.1.1 , network-uri ^>=2.6.1.0 - , tar ^>=0.5.1.1 || ^>=0.6.0.0 + , tar ^>=0.5.1.1 || ^>=0.6.0.0 || ^>=0.7.2.0 test-suite cabal-parsers-index default-language: Haskell2010 @@ -123,17 +120,14 @@ , bytestring , cabal-install-parsers , Cabal-syntax - , containers - , directory , filepath , pretty -- dependencies needing explicit constraints build-depends: - , ansi-terminal >=1.0 && <1.2 - , tasty ^>=1.4 || ^>=1.5 - , tasty-golden ^>=2.3.1.1 - , tree-diff >=0.2 && <0.4 + , tasty ^>=1.4 || ^>=1.5 + , tasty-golden ^>=2.3.1.1 + , tree-diff ^>=0.4.1 benchmark cabal-parsers-bench default-language: Haskell2010 @@ -146,10 +140,6 @@ , base , bytestring , cabal-install-parsers - , Cabal-syntax - , containers - , directory - , filepath -- dependencies needing explicit constraints build-depends: criterion ^>=1.6.0.0 diff --git a/src/Cabal/Config.hs b/src/Cabal/Config.hs --- a/src/Cabal/Config.hs +++ b/src/Cabal/Config.hs @@ -156,7 +156,7 @@ cfg <- C.parseFieldGrammar C.cabalSpecLatest fields grammar foldl' (&) cfg <$> traverse parseSec (concat sections) - parseSec :: C.Section C.Position -> C.ParseResult (Config f -> Config f) + parseSec :: C.Section C.Position -> C.ParseResult src (Config f -> Config f) parseSec (C.MkSection (C.Name _pos name) [C.SecArgName _pos' secName] fields) | name == "repository" = do let repoName = C.fromUTF8BS secName let fields' = fst $ C.partitionFields fields diff --git a/src/Cabal/Index.hs b/src/Cabal/Index.hs --- a/src/Cabal/Index.hs +++ b/src/Cabal/Index.hs @@ -399,7 +399,7 @@ f :: Maybe TmpPackageInfo -> Maybe TmpPackageInfo f Nothing = Just TmpPackageInfo - { tmpPiVersions = Map.singleton ver TmpReleaseInfo + { tmpPiVersions = Map.singleton ver TmpReleaseInfo { tmpRiRevision = 0 , tmpRiTarOffset = offset , tmpRiCabalHash = Just digest diff --git a/src/Cabal/Package.hs b/src/Cabal/Package.hs --- a/src/Cabal/Package.hs +++ b/src/Cabal/Package.hs @@ -26,5 +26,5 @@ -- | Parse @.cabal@ file. parsePackage :: FilePath -> ByteString -> Either (ParseError NonEmpty) C.GenericPackageDescription parsePackage fp contents = case C.runParseResult $ C.parseGenericPackageDescription contents of - (ws, Left (_mv, errs)) -> Left $ ParseError fp contents errs ws + (ws, Left (_mv, errs)) -> Left $ ParseError fp contents (fmap C.perror errs) (fmap C.pwarning ws) (_, Right gpd) -> Right gpd diff --git a/src/Cabal/Parse.hs b/src/Cabal/Parse.hs --- a/src/Cabal/Parse.hs +++ b/src/Cabal/Parse.hs @@ -32,13 +32,13 @@ -- This variant doesn't return any warnings in the successful case. -- parseWith - :: ([C.Field C.Position] -> C.ParseResult a) -- ^ parse - -> FilePath -- ^ filename - -> ByteString -- ^ contents + :: ([C.Field C.Position] -> C.ParseResult src a) -- ^ parse + -> FilePath -- ^ filename + -> ByteString -- ^ contents -> Either (ParseError NonEmpty) a parseWith parser fp bs = case C.runParseResult result of (_, Right x) -> return x - (ws, Left (_, es)) -> Left $ ParseError fp bs es ws + (ws, Left (_, es)) -> Left $ ParseError fp bs (fmap C.perror es) (fmap C.pwarning ws) where result = case C.readFields' bs of Left perr -> C.parseFatalFailure pos (show perr) where diff --git a/src/Cabal/Project.hs b/src/Cabal/Project.hs --- a/src/Cabal/Project.hs +++ b/src/Cabal/Project.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | License: GPL-3.0-or-later AND BSD-3-Clause -- module Cabal.Project ( @@ -15,6 +16,8 @@ -- * Parse project readProject, parseProject, + readProjectWithConditionals, + parseProjectWithConditionals, -- * Resolve project resolveProject, ResolveError (..), @@ -25,6 +28,7 @@ import Control.DeepSeq (NFData (..)) import Control.Exception (Exception (..), throwIO) +import Control.Monad (unless) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Data.Bifoldable (Bifoldable (..)) @@ -55,6 +59,7 @@ import qualified Distribution.CabalSpecVersion as C import qualified Distribution.FieldGrammar as C import qualified Distribution.Fields as C +import qualified Distribution.Fields.ConfVar as C import qualified Distribution.PackageDescription as C import qualified Distribution.Parsec as C @@ -71,6 +76,12 @@ -- $setup -- >>> :set -XOverloadedStrings +-- >>> import Data.String (fromString) +-- >>> import qualified Distribution.PackageDescription as C +-- >>> import Text.Show (showListWith) +-- >>> import Data.Functor.Classes (liftShowsPrec) +-- >>> let sB (C.CondBranch c t f) = showString "CondBranch _ " . showParen True (sT t) . showChar ' ' . liftShowsPrec (\_ -> sT) undefined 11 f; sT (C.CondNode x xs) = showString "CondTree " . showsPrec 11 x . showChar ' ' . showListWith sB xs +-- >>> pp x = putStrLn (either show (flip sT "") x) -- | @cabal.project@ file data Project uri opt pkg = Project @@ -152,7 +163,7 @@ rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnfList rnfPrettyField x10 where - rnfList :: (a -> ()) -> [a] -> () + rnfList :: (x -> ()) -> [x] -> () rnfList _ [] = () rnfList f (x:xs) = f x `seq` rnfList f xs @@ -179,6 +190,13 @@ prj1 <- resolveProject fp prj0 >>= either throwIO return readPackagesOfProject prj1 >>= either throwIO return +readProjectWithConditionals :: FilePath -> IO (C.CondTree C.ConfVar (Project URI Void (FilePath, C.GenericPackageDescription))) +readProjectWithConditionals fp = do + contents <- BS.readFile fp + prj0 <- either throwIO return (parseProjectWithConditionals fp contents) + prj1 <- traverse (\p -> resolveProject fp p >>= either throwIO return) prj0 + traverse (\p -> readPackagesOfProject p >>= either throwIO return) prj1 + -- | Parse project file. Extracts only few fields. -- -- >>> fmap prjPackages $ parseProject "cabal.project" "packages: foo bar/*.cabal" @@ -199,7 +217,7 @@ -- Special case for source-repository-package. If you add another such -- special case, make sure to update otherFieldName appropriately. - parseSec :: C.Section C.Position -> C.ParseResult (Project Void String String -> Project Void String String) + parseSec :: C.Section C.Position -> C.ParseResult src (Project Void String String -> Project Void String String) parseSec (C.MkSection (C.Name _pos name) [] fields) | name == sourceRepoSectionName = do let fields' = fst $ C.partitionFields fields repos <- C.parseFieldGrammar C.cabalSpecLatest fields' sourceRepositoryPackageGrammar @@ -207,6 +225,46 @@ parseSec _ = return id +-- | Parse project files with conditionals. +-- +-- >>> pp $ fmap (fmap prjPackages) $ parseProjectWithConditionals "cabal.project" "packages: foo bar/*.cabal" +-- CondTree ["foo","bar/*.cabal"] [] +-- +-- >>> pp $ fmap (fmap prjPackages) $ parseProjectWithConditionals "cabal.project" $ fromString $ unlines [ "packages: foo bar/*.cabal", "if impl(ghc >=9)", " packages: quu" ] +-- CondTree ["foo","bar/*.cabal"] [CondBranch _ (CondTree ["quu"] []) Nothing] +-- +-- >>> pp $ fmap (fmap prjPackages) $ parseProjectWithConditionals "cabal.project" $ fromString $ unlines [ "packages: foo bar/*.cabal", "if impl(ghc >=9)", " packages: quu", "if impl(ghc >=10)", " packages: zoo" ] +-- CondTree ["foo","bar/*.cabal"] [CondBranch _ (CondTree ["quu"] []) Nothing,CondBranch _ (CondTree ["zoo"] []) Nothing] +-- +-- >>> pp $ fmap (fmap prjPackages) $ parseProjectWithConditionals "cabal.project" $ fromString $ unlines [ "packages: foo bar/*.cabal", "if impl(ghc >=9)", " packages: quu", "else", " packages: zoo" ] +-- CondTree ["foo","bar/*.cabal"] [CondBranch _ (CondTree ["quu"] []) (Just CondTree ["zoo"] [])] +-- +-- >>> pp $ fmap (fmap prjPackages) $ parseProjectWithConditionals "cabal.project" $ fromString $ unlines [ "packages: foo bar/*.cabal", "if impl(ghc >=9)", " packages: quu", "elif impl(ghc >=10)", " packages: zoo", "else", " packages: yyz" ] +-- CondTree ["foo","bar/*.cabal"] [CondBranch _ (CondTree ["quu"] []) (Just CondTree [] [CondBranch _ (CondTree ["zoo"] []) (Just CondTree ["yyz"] [])])] +-- +parseProjectWithConditionals :: FilePath -> ByteString -> Either (ParseError NonEmpty) (C.CondTree C.ConfVar (Project Void String String)) +parseProjectWithConditionals = parseWith $ \fields0 -> flip parseCondTree fields0 $ \fields1 sections -> do + let fields2 = M.filterWithKey (\k _ -> k `elem` knownFields) fields1 + parse fields0 fields2 sections + where + knownFields = C.fieldGrammarKnownFieldList $ grammar [] + + parse :: [C.Field a] -> C.Fields C.Position -> [[C.Section C.Position]] -> C.ParseResult src (Project Void String String) + parse otherFields fields sections = do + let prettyOtherFields = map void $ C.fromParsecFields $ filter otherFieldName otherFields + prj <- C.parseFieldGrammar C.cabalSpecLatest fields $ grammar prettyOtherFields + foldl' (&) prj <$> traverse parseSec (concat sections) + + -- Special case for source-repository-package. If you add another such + -- special case, make sure to update otherFieldName appropriately. + parseSec :: C.Section C.Position -> C.ParseResult src (Project Void String String -> Project Void String String) + parseSec (C.MkSection (C.Name _pos name) [] fields) | name == sourceRepoSectionName = do + let fields' = fst $ C.partitionFields fields + repos <- C.parseFieldGrammar C.cabalSpecLatest fields' sourceRepositoryPackageGrammar + return $ over prjSourceReposL (++ toList (srpFanOut repos)) + + parseSec _ = return id + -- | Returns 'True' if a field should be a part of 'prjOtherFields'. This -- excludes any field that is a part of 'grammar' as well as -- @source-repository-package@ (see 'parseProject', which has a special case @@ -377,3 +435,65 @@ readPackagesOfProject prj = runExceptT $ for prj $ \fp -> do contents <- liftIO $ BS.readFile fp either throwE (\gpd -> return (fp, gpd)) (parsePackage fp contents) + +------------------------------------------------------------------------------- +-- Read package files +------------------------------------------------------------------------------- + +parseCondTree + :: forall a src. (C.Fields C.Position -> [[C.Section C.Position]] -> C.ParseResult src a) -- ^ parse + -> [C.Field C.Position] + -> C.ParseResult src (C.CondTree C.ConfVar a) +parseCondTree subparse = go + where + go fields = do + let (fs, ss) = C.partitionFields fields + (ss', branches) <- second concat . unzip <$> traverse (goIfs id id) ss + x <- subparse fs ss' + return $ C.CondNode x branches + + goIfs + :: ([C.Section C.Position] -> [C.Section C.Position]) + -> ([C.CondBranch C.ConfVar a] -> [C.CondBranch C.ConfVar a]) + -> [C.Section C.Position] + -> C.ParseResult src ([C.Section C.Position], [C.CondBranch C.ConfVar a]) + goIfs accS accB [] = do + return (accS [], accB []) + goIfs accS accB (C.MkSection (C.Name pos name) args fields : sections) + | name == "if" = do + test' <- C.parseConditionConfVar (wrong pos) args + fields' <- go fields + goElse (C.CondBranch test' fields') accS accB sections + | name == "else" = do + C.parseFailure pos "standalone else" + return ([], []) + | name == "elif" = do + C.parseFailure pos "standalone elif" + goIfs accS accB sections + goIfs accS accB (section : sections) = do + goIfs (accS . (section :)) accB sections + + goElse + :: (Maybe (C.CondTree C.ConfVar a) -> C.CondBranch C.ConfVar a) + -> ([C.Section C.Position] -> [C.Section C.Position]) + -> ([C.CondBranch C.ConfVar a] -> [C.CondBranch C.ConfVar a]) + -> [C.Section C.Position] + -> C.ParseResult src ([C.Section C.Position], [C.CondBranch C.ConfVar a]) + goElse make accS accB (C.MkSection (C.Name pos name) args fields : sections) + | name == "else" = do + unless (null args) $ C.parseFailure pos "arguments passed to else" + fields' <- go fields + let condTree = make (Just fields') + goIfs accS (accB . (condTree :)) sections + | name == "elif" = do + test' <- C.parseConditionConfVar (wrong pos) args + fields' <- go fields + emptyA <- subparse mempty [] + goElse (make . Just . C.CondNode emptyA . pure . C.CondBranch test' fields') accS accB sections + goElse make accS accB sections = do + let condTree = make Nothing + goIfs accS (accB . (condTree :)) sections + +-- | I don't know which location to pass to parseConditionConfVar, so I just pass some. +wrong :: C.Position -> C.Position +wrong = id diff --git a/test/Golden.hs b/test/Golden.hs --- a/test/Golden.hs +++ b/test/Golden.hs @@ -65,3 +65,4 @@ instance ToExpr (PrettyField ann) where toExpr (PrettyField _ fn d) = App "PrettyField" [toExpr fn, toExpr d] toExpr (PrettySection _ fn ds ps) = App "PrettySection" [toExpr fn, toExpr ds, toExpr ps] + toExpr PrettyEmpty = App "PrettyEmpty" []