cabal-install-parsers 0.4.3 → 0.4.4
raw patch · 4 files changed
+231/−124 lines, 4 filesdep ~basedep ~bytestringdep ~timePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, bytestring, time
API changes (from Hackage documentation)
+ Cabal.Project: instance (GHC.Show.Show uri, GHC.Show.Show opt, GHC.Show.Show pkg) => GHC.Show.Show (Cabal.Project.Project uri opt pkg)
Files
- Changelog.md +5/−0
- cabal-install-parsers.cabal +6/−6
- src/Cabal/Internal/Glob.hs +155/−86
- src/Cabal/Project.hs +65/−32
Changelog.md view
@@ -1,3 +1,8 @@+## 0.4.4++- Try to fix glob behavior on Windows+- Add `Show (Project ...)` instance+ ## 0.4.3 - Use `Cabal-3.6`
cabal-install-parsers.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: cabal-install-parsers-version: 0.4.3+version: 0.4.4 synopsis: Utilities to work with cabal-install files description: @cabal-install-parsers@ provides parsers for @cabal-install@ files:@@ -21,7 +21,7 @@ category: Development build-type: Simple tested-with:- GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1+ GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.4 || ==8.10.7 || ==9.0.1 || ==9.2.1 extra-source-files: Changelog.md@@ -54,9 +54,9 @@ -- GHC-boot libraries build-depends:- , base >=4.10 && <4.16+ , base >=4.10 && <4.17 , binary ^>=0.8.5- , bytestring ^>=0.10.8.1+ , bytestring ^>=0.10.8.1 || ^>=0.11.1.0 , Cabal ^>=3.6.0.0 , containers ^>=0.5.7.1 || ^>=0.6.0.1 , deepseq ^>=1.4.2.0@@ -65,12 +65,12 @@ , parsec ^>=3.1.13.0 , pretty ^>=1.1.3.3 , text ^>=1.2.3.0- , time ^>=1.8.0.2 || ^>=1.9.3+ , time ^>=1.8.0.2 || ^>=1.9.3 || ^>=1.11.1.1 , transformers ^>=0.5.2.0 -- extra dependencies build-depends:- , aeson ^>=1.4.6.0 || ^>=1.5.0.0+ , aeson ^>=1.4.6.0 || ^>=1.5.0.0 || ^>=2.0.0.0 , base16-bytestring ^>=1.0.0.0 , binary-instances ^>=1 , cryptohash-sha256 ^>=0.11.101.0
src/Cabal/Internal/Glob.hs view
@@ -1,46 +1,28 @@+-- From Distribution.Client.Glob module Cabal.Internal.Glob where -import Control.Monad (filterM, liftM2)-import Control.Monad.IO.Class (MonadIO (..))-import Data.Functor (void)-import Data.List (stripPrefix)-import System.Directory (doesDirectoryExist, getDirectoryContents)-import System.FilePath.Posix ((</>))-import Text.ParserCombinators.ReadP------------------------------------------------------------------------------------ Glob----------------------------------------------------------------------------------{---Globbing code and grammar judiciously stolen from cabal-install:--FilePathGlob ::= FilePathRoot FilePathGlobRel-FilePathRoot ::= {- empty -} # relative to cabal.project- | "/" # Unix root- | [a-zA-Z] ":" [/\\] # Windows root- | "~" # home directory--FilePathGlobRel ::= Glob "/" FilePathGlobRel # Unix directory- | Glob "\\" FilePathGlobRel # Windows directory- | Glob # file- | {- empty -} # trailing slash+import Control.Applicative (some, (<|>))+import Control.Monad (filterM, void)+import Data.Char (isAsciiLower, isAsciiUpper, toUpper)+import Data.Foldable (toList)+import Data.List (stripPrefix)+import Distribution.Parsec (CabalParsing, Parsec (..))+import Distribution.Pretty (Pretty (..))+import System.Directory (doesDirectoryExist, getDirectoryContents, getHomeDirectory)+import System.FilePath.Posix (addTrailingPathSeparator, joinPath, (</>)) -Glob ::= GlobPiece *-GlobPiece ::= "*" # wildcard- | [^*{},/\\] * # literal string- | "\\" [*{},] # escaped reserved character- | "{" Glob "," ... "," Glob "}" # union (match any of these)--}+import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint as Disp +-- | A file path specified by globbing+-- data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel deriving (Eq, Show) data FilePathGlobRel- = GlobDir Glob FilePathGlobRel- | GlobFile Glob- | GlobDirTrailing -- trailing dir, a glob ending in '/'+ = GlobDir !Glob !FilePathGlobRel+ | GlobFile !Glob+ | GlobDirTrailing -- ^ trailing dir, a glob ending in @/@ deriving (Eq, Show) -- | A single directory or file component of a globbed path@@ -54,64 +36,64 @@ data FilePathRoot = FilePathRelative- | FilePathRoot FilePath -- e.g. '/', 'c:\' or result of 'takeDrive'+ | FilePathRoot FilePath -- ^ e.g. @"/"@, @"c:\"@ or result of 'takeDrive' | FilePathHomeDir deriving (Eq, Show) -parseFilePathGlobRel :: ReadP FilePathGlobRel-parseFilePathGlobRel =- parseGlob >>= \globpieces ->- asDir globpieces- <++ asTDir globpieces- <++ asFile globpieces+-- | Check if a 'FilePathGlob' doesn't actually make use of any globbing and+-- is in fact equivalent to a non-glob 'FilePath'.+--+-- If it is trivial in this sense then the result is the equivalent constant+-- 'FilePath'. On the other hand if it is not trivial (so could in principle+-- match more than one file) then the result is @Nothing@.+--+isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath+isTrivialFilePathGlob (FilePathGlob root pathglob) =+ case root of+ FilePathRelative -> go [] pathglob+ FilePathRoot root' -> go [root'] pathglob+ FilePathHomeDir -> Nothing where- asDir glob = do dirSep- GlobDir glob <$> parseFilePathGlobRel- asTDir glob = do dirSep- return (GlobDir glob GlobDirTrailing)- asFile glob = return (GlobFile glob)+ go paths (GlobDir [Literal path] globs) = go (path:paths) globs+ go paths (GlobFile [Literal path]) = Just (joinPath (reverse (path:paths)))+ go paths GlobDirTrailing = Just (addTrailingPathSeparator+ (joinPath (reverse paths)))+ go _ _ = Nothing - dirSep = void (char '/')- +++ (do _ <- char '\\'- -- check this isn't an escape code- following <- look- case following of- (c:_) | isGlobEscapedChar c -> pfail- _ -> return ())+-- | Get the 'FilePath' corresponding to a 'FilePathRoot'.+--+-- The 'FilePath' argument is required to supply the path for the+-- 'FilePathRelative' case.+--+getFilePathRootDirectory :: FilePathRoot+ -> FilePath -- ^ root for relative paths+ -> IO FilePath+getFilePathRootDirectory FilePathRelative root = return root+getFilePathRootDirectory (FilePathRoot root) _ = return root+getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory -parseGlob :: ReadP Glob-parseGlob = many1 parsePiece- where- parsePiece = literal +++ wildcard +++ union' - wildcard = char '*' >> return WildCard-- union' = between (char '{') (char '}') $- fmap Union (sepBy1 parseGlob (char ','))-- literal = Literal `fmap` litchars1-- litchar = normal +++ escape-- normal = satisfy (\c -> not (isGlobEscapedChar c)- && c /= '/' && c /= '\\')- escape = char '\\' >> satisfy isGlobEscapedChar-- litchars1 :: ReadP [Char]- litchars1 = liftM2 (:) litchar litchars-- litchars :: ReadP [Char]- litchars = litchars1 <++ return []+------------------------------------------------------------------------------+-- Matching+-- -isGlobEscapedChar :: Char -> Bool-isGlobEscapedChar '*' = True-isGlobEscapedChar '{' = True-isGlobEscapedChar '}' = True-isGlobEscapedChar ',' = True-isGlobEscapedChar _ = False+-- | Match a 'FilePathGlob' against the file system, starting from a given+-- root directory for relative paths. The results of relative globs are+-- relative to the given root. Matches for absolute globs are absolute.+--+matchFileGlob :: FilePath -> FilePathGlob -> IO [FilePath]+matchFileGlob relroot (FilePathGlob globroot glob) = do+ root <- getFilePathRootDirectory globroot relroot+ matches <- matchFileGlobRel root glob+ case globroot of+ FilePathRelative -> return matches+ _ -> return (map (root </>) matches) -expandRelGlob :: MonadIO m => FilePath -> FilePathGlobRel -> m [FilePath]-expandRelGlob root glob0 = liftIO $ go glob0 ""+-- | Match a 'FilePathGlobRel' against the file system, starting from a+-- given root directory. The results are all relative to the given root.+--+matchFileGlobRel :: FilePath -> FilePathGlobRel -> IO [FilePath]+matchFileGlobRel root glob0 = go glob0 "" where go (GlobFile glob) dir = do entries <- getDirectoryContents (root </> dir)@@ -123,11 +105,14 @@ subdirs <- filterM (\subdir -> doesDirectoryExist (root </> dir </> subdir)) $ filter (matchGlob glob) entries- concat <$> mapM (\subdir -> go globPath (dir </> subdir)) subdirs+ concat <$> traverse (\subdir -> go globPath (dir </> subdir)) subdirs go GlobDirTrailing dir = return [dir] -matchGlob :: Glob -> FilePath -> Bool++-- | Match a globbing pattern against a file path component+--+matchGlob :: Glob -> String -> Bool matchGlob = goStart where -- From the man page, glob(7):@@ -151,3 +136,87 @@ go (Union globs:rest) cs = any (\glob -> go (glob ++ rest) cs) globs go [] (_:_) = False go (_:_) "" = False+++------------------------------------------------------------------------------+-- Parsing & printing+--++instance Pretty FilePathGlob where+ pretty (FilePathGlob root pathglob) = pretty root Disp.<> pretty pathglob++instance Parsec FilePathGlob where+ parsec = do+ root <- parsec+ case root of+ FilePathRelative -> FilePathGlob root <$> parsec+ _ -> FilePathGlob root <$> parsec <|> pure (FilePathGlob root GlobDirTrailing)++instance Pretty FilePathRoot where+ pretty FilePathRelative = Disp.empty+ pretty (FilePathRoot root) = Disp.text root+ pretty FilePathHomeDir = Disp.char '~' Disp.<> Disp.char '/'++instance Parsec FilePathRoot where+ parsec = root <|> P.try home <|> P.try drive <|> pure FilePathRelative where+ root = FilePathRoot "/" <$ P.char '/'+ home = FilePathHomeDir <$ P.string "~/"+ drive = do+ dr <- P.satisfy $ \c -> isAsciiLower c || isAsciiUpper c+ _ <- P.char ':'+ _ <- P.char '/' <|> P.char '\\'+ return (FilePathRoot (toUpper dr : ":\\"))++instance Pretty FilePathGlobRel where+ pretty (GlobDir glob pathglob) = dispGlob glob+ Disp.<> Disp.char '/'+ Disp.<> pretty pathglob+ pretty (GlobFile glob) = dispGlob glob+ pretty GlobDirTrailing = Disp.empty++instance Parsec FilePathGlobRel where+ parsec = parsecPath where+ parsecPath :: CabalParsing m => m FilePathGlobRel+ parsecPath = do+ glob <- parsecGlob+ dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob)++ dirSep :: CabalParsing m => m ()+ dirSep = void (P.char '/') <|> P.try (do+ _ <- P.char '\\'+ -- check this isn't an escape code+ P.notFollowedBy (P.satisfy isGlobEscapedChar))++dispGlob :: Glob -> Disp.Doc+dispGlob = Disp.hcat . map dispPiece+ where+ dispPiece WildCard = Disp.char '*'+ dispPiece (Literal str) = Disp.text (escape str)+ dispPiece (Union globs) = Disp.braces+ (Disp.hcat (Disp.punctuate+ (Disp.char ',')+ (map dispGlob globs)))+ escape [] = []+ escape (c:cs)+ | isGlobEscapedChar c = '\\' : c : escape cs+ | otherwise = c : escape cs++parsecGlob :: CabalParsing m => m Glob+parsecGlob = some parsecPiece where+ parsecPiece = P.choice [ literal, wildcard, union ]++ wildcard = WildCard <$ P.char '*'+ union = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ','))+ literal = Literal <$> some litchar++ litchar = normal <|> escape++ normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\')+ escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar++isGlobEscapedChar :: Char -> Bool+isGlobEscapedChar '*' = True+isGlobEscapedChar '{' = True+isGlobEscapedChar '}' = True+isGlobEscapedChar ',' = True+isGlobEscapedChar _ = False
src/Cabal/Project.hs view
@@ -22,28 +22,27 @@ readPackagesOfProject ) where -import Control.DeepSeq (NFData (..))-import Control.Exception (Exception (..), throwIO)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)-import Data.Bifoldable (Bifoldable (..))-import Data.Bifunctor (Bifunctor (..))-import Data.Bitraversable (Bitraversable (..), bifoldMapDefault, bimapDefault)-import Data.ByteString (ByteString)-import Data.Either (partitionEithers)-import Data.Foldable (toList)-import Data.Function ((&))-import Data.Functor (void)-import Data.List (foldl')-import Data.List.NonEmpty (NonEmpty)-import Data.Traversable (for)-import Data.Void (Void)-import Distribution.Compat.Lens (LensLike', over)-import GHC.Generics (Generic)-import Network.URI (URI, parseURI)-import System.Directory (doesDirectoryExist, doesFileExist)-import System.FilePath (takeDirectory, takeExtension, (</>))-import Text.ParserCombinators.ReadP (readP_to_S)+import Control.DeepSeq (NFData (..))+import Control.Exception (Exception (..), throwIO)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)+import Data.Bifoldable (Bifoldable (..))+import Data.Bifunctor (Bifunctor (..))+import Data.Bitraversable (Bitraversable (..), bifoldMapDefault, bimapDefault)+import Data.ByteString (ByteString)+import Data.Either (partitionEithers)+import Data.Foldable (toList)+import Data.Function ((&))+import Data.Functor (void)+import Data.List (foldl')+import Data.List.NonEmpty (NonEmpty)+import Data.Traversable (for)+import Data.Void (Void)+import Distribution.Compat.Lens (LensLike', over)+import GHC.Generics (Generic)+import Network.URI (URI, parseURI)+import System.Directory (doesDirectoryExist, doesFileExist)+import System.FilePath (isAbsolute, splitDirectories, splitDrive, takeDirectory, takeExtension, (</>)) import qualified Data.ByteString as BS import qualified Data.Map.Strict as M@@ -82,7 +81,7 @@ } deriving (Functor, Foldable, Traversable, Generic) --- | Doesn't compare prjOtherFields+-- | Doesn't compare 'prjOtherFields' instance (Eq uri, Eq opt, Eq pkg) => Eq (Project uri opt pkg) where x == y = and [ eqOn prjPackages@@ -98,6 +97,24 @@ where eqOn f = f x == f y +-- | Doesn't show 'prjOtherFields'+--+-- @since 0.4.4+instance (Show uri, Show opt, Show pkg) => Show (Project uri opt pkg) where+ showsPrec p prj =+ showParen (p > 10)+ ( showString "Project{prjPackages = " . shows (prjPackages prj)+ . showString ", prjOptPackages = " . shows (prjOptPackages prj)+ . showString ", prjUriPackages = " . shows (prjUriPackages prj)+ . showString ", prjConstraints = " . shows (prjConstraints prj)+ . showString ", prjAllowNewer = " . shows (prjAllowNewer prj)+ . showString ", prjReorderGoals = " . shows (prjReorderGoals prj)+ . showString ", prjMaxBackjumps = " . shows (prjMaxBackjumps prj)+ . showString ", prjOptimization = " . shows (prjOptimization prj)+ . showString ", prjSourceRepos = " . shows (prjSourceRepos prj)+ . showChar '}'+ )+ instance Bifunctor (Project c) where bimap = bimapDefault instance Bifoldable (Project c) where bifoldMap = bifoldMapDefault @@ -296,18 +313,34 @@ isFile <- liftIO $ doesFileExist abspath isDir <- liftIO $ doesDirectoryExist abspath if | isFile && takeExtension pkglocstr == ".cabal" -> return (Just [abspath])- | isDir -> checkisFileGlobPackage (pkglocstr </> "*.cabal")+ | isDir -> checkGlob (globStarDotCabal pkglocstr) | otherwise -> return Nothing -- if it looks like glob, glob- checkisFileGlobPackage pkglocstr =- case filter (null . snd) $ readP_to_S parseFilePathGlobRel pkglocstr of- [(g, "")] -> do- files <- liftIO $ expandRelGlob rootdir g- let files' = filter ((== ".cabal") . takeExtension) files- -- if nothing is matched, skip.- if null files' then return Nothing else return (Just files')- _ -> return Nothing+ checkisFileGlobPackage pkglocstr = case C.eitherParsec pkglocstr of+ Right g -> checkGlob g+ Left _ -> return Nothing++ checkGlob :: FilePathGlob -> ExceptT ResolveError IO (Maybe [FilePath])+ checkGlob glob = do+ files <- liftIO $ matchFileGlob rootdir glob+ let files' = filter ((== ".cabal") . takeExtension) files+ -- if nothing is matched, skip.+ if null files' then return Nothing else return (Just files')++ -- A glob to find all the cabal files in a directory.+ --+ -- For a directory @some/dir/@, this is a glob of the form @some/dir/\*.cabal@.+ -- The directory part can be either absolute or relative.+ --+ globStarDotCabal :: FilePath -> FilePathGlob+ globStarDotCabal dir =+ FilePathGlob+ (if isAbsolute dir then FilePathRoot root else FilePathRelative)+ (foldr (\d -> GlobDir [Literal d])+ (GlobFile [WildCard, Literal ".cabal"]) dirComponents)+ where+ (root, dirComponents) = fmap splitDirectories (splitDrive dir) mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) mplusMaybeT ma mb = do