{-# LANGUAGE LambdaCase #-}

{- | Minimal shell-style globbing, enough for the @packages:@ field of a
@cabal.project@ file.

The reference implementation (@scripts/list-test-suites/list-test-suites.sh@)
resolves package entries by letting @bash@ expand them, so tokens such as
@*\/*.cabal@ or @pkgs\/*@ work. This module reproduces that behaviour
without a shell and without pulling in a dependency: patterns are matched
segment by segment against the real filesystem, @*@ and @?@ never cross a
directory separator, and — as in @bash@ — a wildcard does not match a
leading dot.
-}
module PbtCli.Glob (
  isGlob,
  matchSegment,
  expandGlob,
) where

import Control.Monad (filterM, foldM)
import Data.List (sort)
import System.Directory (doesDirectoryExist, doesPathExist, listDirectory)
import System.FilePath (splitDirectories, (</>))

-- | Does this token contain any wildcard metacharacter?
isGlob :: String -> Bool
isGlob :: FilePath -> Bool
isGlob FilePath
s = (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> FilePath -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (FilePath
"*?" :: String)) FilePath
s

{- | Match a single path segment against a single pattern segment.

@*@ matches any run of characters, @?@ exactly one, and everything else is
literal. A pattern that does not itself start with @.@ never matches a name
that does, which is how shell globs hide dotfiles.
-}
matchSegment :: String -> String -> Bool
matchSegment :: FilePath -> FilePath -> Bool
matchSegment FilePath
pat FilePath
name
  | Bool -> Bool
not (FilePath -> Bool
startsWithDot FilePath
pat) Bool -> Bool -> Bool
&& FilePath -> Bool
startsWithDot FilePath
name = Bool
False
  | Bool
otherwise = FilePath -> FilePath -> Bool
go FilePath
pat FilePath
name
 where
  startsWithDot :: FilePath -> Bool
startsWithDot = \case
    (Char
'.' : FilePath
_) -> Bool
True
    FilePath
_ -> Bool
False

  go :: FilePath -> FilePath -> Bool
go [] [] = Bool
True
  go [] FilePath
_ = Bool
False
  -- A trailing run of '*' matches the rest of the segment, including nothing.
  go (Char
'*' : FilePath
ps) FilePath
cs = FilePath -> FilePath -> Bool
go FilePath
ps FilePath
cs Bool -> Bool -> Bool
|| (Bool -> Bool
not (FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
cs) Bool -> Bool -> Bool
&& FilePath -> FilePath -> Bool
go (Char
'*' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
ps) (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
1 FilePath
cs))
  go (Char
'?' : FilePath
ps) (Char
_ : FilePath
cs) = FilePath -> FilePath -> Bool
go FilePath
ps FilePath
cs
  go (Char
'?' : FilePath
_) [] = Bool
False
  go (Char
p : FilePath
ps) (Char
c : FilePath
cs) = Char
p Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c Bool -> Bool -> Bool
&& FilePath -> FilePath -> Bool
go FilePath
ps FilePath
cs
  go (Char
_ : FilePath
_) [] = Bool
False

{- | Expand @pattern@, interpreted relative to @base@, into the paths that
actually exist. The returned paths keep the @base \</\> …@ prefix and are
sorted, so callers get a deterministic order.

A pattern with no wildcard is simply checked for existence, which makes this
function usable for every @packages:@ token, glob or not.
-}
expandGlob :: FilePath -> String -> IO [FilePath]
expandGlob :: FilePath -> FilePath -> IO [FilePath]
expandGlob FilePath
base FilePath
pattern
  | Bool -> Bool
not (FilePath -> Bool
isGlob FilePath
pattern) = do
      let p :: FilePath
p = FilePath
base FilePath -> FilePath -> FilePath
</> FilePath
pattern
      Bool
exists <- FilePath -> IO Bool
doesPathExist FilePath
p
      [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath
p | Bool
exists]
  | Bool
otherwise = do
      -- Anchor on the pattern's own directory structure. Absolute patterns are
      -- not something cabal.project produces, and `splitDirectories` on a
      -- relative pattern gives exactly the segments we want to walk.
      let segments :: [FilePath]
segments = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
".") (FilePath -> [FilePath]
splitDirectories FilePath
pattern)
      [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([FilePath] -> FilePath -> IO [FilePath])
-> [FilePath] -> [FilePath] -> IO [FilePath]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [FilePath] -> FilePath -> IO [FilePath]
step [FilePath
base] [FilePath]
segments
 where
  step :: [FilePath] -> String -> IO [FilePath]
  step :: [FilePath] -> FilePath -> IO [FilePath]
step [FilePath]
dirs FilePath
seg
    | Bool -> Bool
not (FilePath -> Bool
isGlob FilePath
seg) =
        (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesPathExist ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> FilePath
</> FilePath
seg) [FilePath]
dirs)
    | Bool
otherwise =
        [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FilePath -> FilePath -> IO [FilePath]
matchesIn FilePath
seg) [FilePath]
dirs

  -- Wildcard segment: list the directory and keep the entries that match.
  matchesIn :: String -> FilePath -> IO [FilePath]
  matchesIn :: FilePath -> FilePath -> IO [FilePath]
matchesIn FilePath
seg FilePath
dir = do
    Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
dir
    if Bool -> Bool
not Bool
isDir
      then [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      else do
        [FilePath]
entries <- FilePath -> IO [FilePath]
listDirectory FilePath
dir
        [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
e | FilePath
e <- [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort [FilePath]
entries, FilePath -> FilePath -> Bool
matchSegment FilePath
seg FilePath
e]