Search.hs

{-# LANGUAGE NamedFieldPuns #-}

module Calligraphy.Phases.Search
  ( searchFiles,
    pSearchConfig,
    SearchConfig,
  )
where

import qualified Calligraphy.Compat.GHC as GHC
import Calligraphy.Compat.Lib
import Control.Applicative
import Data.List.NonEmpty (NonEmpty (..), nonEmpty, toList)
import Options.Applicative hiding (str)
import System.Directory (doesDirectoryExist, doesFileExist, listDirectory, makeAbsolute)
import System.FilePath (isExtensionOf, (</>))

searchFiles :: SearchConfig -> IO [GHC.HieFile]
searchFiles SearchConfig {searchDotPaths, searchRoots, includePatterns, excludePatterns} = do
  hieFiles <- getHieFiles =<< searchHieFilePaths

  pure $
    flip filter hieFiles $ \file ->
      let matches pat =
            matchPattern pat (GHC.moduleNameString . GHC.moduleName . GHC.hie_module $ file)
              || matchPattern pat (GHC.hie_hs_file file)
       in maybe True (any matches) includePatterns && maybe True (not . any matches) excludePatterns
  where
    searchHieFilePaths = do
      roots <- mapM makeAbsolute (maybe ["./."] toList searchRoots)
      foldMap go roots
      where
        go :: FilePath -> IO [FilePath]
        go path = do
          isFile <- doesFileExist path
          if isFile && isExtensionOf ".hie" path
            then pure [path]
            else do
              isDir <- doesDirectoryExist path
              if isDir
                then do
                  contents <- (if searchDotPaths then id else filter (not . isPrefixOf ".")) <$> listDirectory path
                  foldMap (go . (path </>)) contents
                else pure []

data SearchConfig = SearchConfig
  { includePatterns :: Maybe (NonEmpty Pattern),
    excludePatterns :: Maybe (NonEmpty Pattern),
    searchDotPaths :: Bool,
    searchRoots :: Maybe (NonEmpty FilePath)
  }

newtype Pattern = Pattern String

matchPattern :: Pattern -> String -> Bool
matchPattern (Pattern matcher) = go False matcher
  where
    go _ ('*' : ms) cs = go True ms cs
    go False (m : ms) (c : cs) = m == c && go False ms cs
    go True ms (c : cs) = go True ms cs || go False ms (c : cs)
    go _ [] [] = True
    go _ _ _ = False

pSearchConfig :: Parser SearchConfig
pSearchConfig =
  SearchConfig
    <$> (fmap nonEmpty . many)
      ( Pattern
          <$> strArgument
            ( metavar "MODULE"
                <> help "Name or filepath of a module to include in the call graph. Can contain '*' wildcards. Defaults to '*'."
            )
      )
    <*> (fmap nonEmpty . many)
      ( Pattern
          <$> strOption
            ( long "exclude"
                <> short 'e'
                <> metavar "MODULE"
                <> help "Name or filepath of a module to exclude in the call graph. Can contain '*' wildcards."
            )
      )
    <*> switch (long "hidden" <> help "Search paths with a leading period. Disabled by default.")
    <*> (fmap nonEmpty . many)
      ( strOption
          ( long "input"
              <> short 'i'
              <> metavar "PATH"
              <> help "Filepaths to search for HIE files. If passed a file, it will be processed as is. If passed a directory, the directory will be searched recursively. Can be repeated. Defaults to './.'"
          )
      )