diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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` 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.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 diff --git a/src/Cabal/Internal/Glob.hs b/src/Cabal/Internal/Glob.hs --- a/src/Cabal/Internal/Glob.hs +++ b/src/Cabal/Internal/Glob.hs @@ -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 diff --git a/src/Cabal/Project.hs b/src/Cabal/Project.hs --- a/src/Cabal/Project.hs +++ b/src/Cabal/Project.hs @@ -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