Glob.hs

module CabalGild.Glob where

import CabalGild.Prelude
import Data.List (isInfixOf)
import Data.List.NonEmpty (NonEmpty (..))
import qualified System.FilePath as Native (splitDirectories)
import qualified System.FilePath.Posix as Posix (splitDirectories)

data Glob = Glob FilePath [GlobPiece]
  deriving (Show)

data GlobPiece
  = GlobStarStar
  | GlobPiece (NonEmpty GlobChar)
  deriving (Show)

data GlobChar
  = GlobStar
  | GlobChar Char
  deriving (Show)

-- | Match glob
--
-- >>> let Right g = parseGlob "cbits/**/*.c"
--
-- >>> map (match g) ["foo", "cbits/header.h", "cbits/source.c", "cbits/dir/source.c"]
-- [False,False,True,True]
match :: Glob -> FilePath -> Bool
match (Glob g1 gs0) fp = go0 (Native.splitDirectories fp)
  where
    go0 [] = False
    go0 (p : ps) = p == g1 && go ps gs0

    go :: [FilePath] -> [GlobPiece] -> Bool
    go [] [] = True
    go [] (_ : _) = False
    go (_ : _) [] = False
    go (s : ss) (GlobStarStar : gs) = go (s : ss) gs || go ss (GlobStarStar : gs)
    go (s : ss) (GlobPiece cs : gs) = matches s (toList cs) && go ss gs

    matches :: FilePath -> [GlobChar] -> Bool
    matches [] [] = True
    matches (_ : _) [] = False
    matches [] (_ : _) = False
    matches (x : xs) (GlobStar : cs) = matches (x : xs) cs || matches xs (GlobStar : cs)
    matches (x : xs) (GlobChar c : cs) = x == c && matches xs cs

parseGlob :: String -> Either String Glob
parseGlob input = case Posix.splitDirectories input of
  [] -> Left "empty path"
  (x : xs) -> do
    p <- parseFirstPiece x
    ps <- traverse parsePiece xs
    return (Glob p ps)
  where
    parseFirstPiece :: String -> Either String FilePath
    parseFirstPiece "" = Left "empty path segment"
    parseFirstPiece s | "*" `isInfixOf` s = Left "wild card in first path segment"
    parseFirstPiece s = Right s

    parsePiece :: String -> Either String GlobPiece
    parsePiece "" = Left "empty path segment"
    parsePiece "**" = Right GlobStarStar
    parsePiece s | "**" `isInfixOf` s = Left $ "** inside path segment: " ++ s
    parsePiece (c : cs) = Right (GlobPiece (parseChar c :| map parseChar cs))

    parseChar :: Char -> GlobChar
    parseChar '*' = GlobStar
    parseChar c = GlobChar c