Microframework for file search

FindFiles.hs

{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
module Main where

import Data.Monoid
import System.Directory
import System.FilePath
import Control.Monad (filterM)
import System.Process (callProcess)

type Match = FilePath -> IO Bool
type Criteria = (Match, Match)

-- | By exact file name
name :: String -> Match
name exact = pure . (== exact) . takeFileName

isDir :: Match
isDir = doesDirectoryExist

-- | Match second predicate after the first one, if needed
infix 6 ?>>
(?>>) :: Match -> Match -> Match
(?>>) a b path = a path >>= \case
  True -> b path -- Passed to the next check
  False -> return False

instance {-# OVERLAPS #-} Monoid Match where
  mempty = pure . const False
-- | Match one of the two alternatives
  mappend a b path = a path >>= \case
    True -> return True
    False -> b path

-- Add a match rule
match :: Match -> Criteria
match predicate = (predicate, mempty)

-- Add an ignore rule
ignore :: Match -> Criteria
ignore predicate = (mempty, predicate)

-- Find files in `root`
find :: Criteria -> FilePath -> IO [FilePath]
find criteria@(match, ignore) root = do
  entries <- map (root </>) <$> listDirectory root >>= filterM (\p -> ignore p >>= pure . not)
  subdirs <- filterM doesDirectoryExist entries
  results <- filterM match entries
  concat . (results:) <$> mapM (find criteria) subdirs

devIgnores :: Criteria
devIgnores = ignore $ name ".stack-work" <> name "node_modules"

gitRepositories :: Criteria
gitRepositories = devIgnores <> match (name ".git" ?>> isDir)

main :: IO ()
main = getHomeDirectory >>= find gitRepositories . (</> "software") >>= mapM_ putStrLn