{-# LANGUAGE NamedFieldPuns #-} module Calligraphy.Phases.Search ( searchFiles, pSearchConfig, SearchConfig, ) where import qualified Calligraphy.Compat.GHC as GHC import Calligraphy.Compat.Lib (readHieFileCompat) import Control.Applicative import Control.Monad.State import Data.IORef import Data.List (isPrefixOf) 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 -> IO [HieFile] searchFiles SearchConfig {Bool searchDotPaths :: SearchConfig -> Bool searchDotPaths :: Bool searchDotPaths, Maybe (NonEmpty FilePath) searchRoots :: SearchConfig -> Maybe (NonEmpty FilePath) searchRoots :: Maybe (NonEmpty FilePath) searchRoots, Maybe (NonEmpty Pattern) includePatterns :: SearchConfig -> Maybe (NonEmpty Pattern) includePatterns :: Maybe (NonEmpty Pattern) includePatterns, Maybe (NonEmpty Pattern) excludePatterns :: SearchConfig -> Maybe (NonEmpty Pattern) excludePatterns :: Maybe (NonEmpty Pattern) excludePatterns} = do [FilePath] hieFilePaths <- IO [FilePath] searchHieFilePaths [HieFile] hieFiles <- do UniqSupply uniqSupply <- Char -> IO UniqSupply GHC.mkSplitUniqSupply Char 'z' IORef NameCache ref <- NameCache -> IO (IORef NameCache) forall a. a -> IO (IORef a) newIORef (UniqSupply -> [Name] -> NameCache GHC.initNameCache UniqSupply uniqSupply []) [FilePath] -> (FilePath -> IO HieFile) -> IO [HieFile] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) forM [FilePath] hieFilePaths (IORef NameCache -> FilePath -> IO HieFile readHieFileWithWarning IORef NameCache ref) [HieFile] -> IO [HieFile] forall (f :: * -> *) a. Applicative f => a -> f a pure ([HieFile] -> IO [HieFile]) -> [HieFile] -> IO [HieFile] forall a b. (a -> b) -> a -> b $ ((HieFile -> Bool) -> [HieFile] -> [HieFile]) -> [HieFile] -> (HieFile -> Bool) -> [HieFile] forall a b c. (a -> b -> c) -> b -> a -> c flip (HieFile -> Bool) -> [HieFile] -> [HieFile] forall a. (a -> Bool) -> [a] -> [a] filter [HieFile] hieFiles ((HieFile -> Bool) -> [HieFile]) -> (HieFile -> Bool) -> [HieFile] forall a b. (a -> b) -> a -> b $ \HieFile file -> let matches :: Pattern -> Bool matches Pattern pat = Pattern -> FilePath -> Bool matchPattern Pattern pat (ModuleName -> FilePath GHC.moduleNameString (ModuleName -> FilePath) -> (HieFile -> ModuleName) -> HieFile -> FilePath forall b c a. (b -> c) -> (a -> b) -> a -> c . Module -> ModuleName GHC.moduleName (Module -> ModuleName) -> (HieFile -> Module) -> HieFile -> ModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c . HieFile -> Module GHC.hie_module (HieFile -> FilePath) -> HieFile -> FilePath forall a b. (a -> b) -> a -> b $ HieFile file) Bool -> Bool -> Bool || Pattern -> FilePath -> Bool matchPattern Pattern pat (HieFile -> FilePath GHC.hie_hs_file HieFile file) in Bool -> (NonEmpty Pattern -> Bool) -> Maybe (NonEmpty Pattern) -> Bool forall b a. b -> (a -> b) -> Maybe a -> b maybe Bool True ((Pattern -> Bool) -> NonEmpty Pattern -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool any Pattern -> Bool matches) Maybe (NonEmpty Pattern) includePatterns Bool -> Bool -> Bool && Bool -> (NonEmpty Pattern -> Bool) -> Maybe (NonEmpty Pattern) -> Bool forall b a. b -> (a -> b) -> Maybe a -> b maybe Bool True (Bool -> Bool not (Bool -> Bool) -> (NonEmpty Pattern -> Bool) -> NonEmpty Pattern -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . (Pattern -> Bool) -> NonEmpty Pattern -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool any Pattern -> Bool matches) Maybe (NonEmpty Pattern) excludePatterns where searchHieFilePaths :: IO [FilePath] searchHieFilePaths = do [FilePath] roots <- (FilePath -> IO FilePath) -> [FilePath] -> IO [FilePath] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM FilePath -> IO FilePath makeAbsolute ([FilePath] -> (NonEmpty FilePath -> [FilePath]) -> Maybe (NonEmpty FilePath) -> [FilePath] forall b a. b -> (a -> b) -> Maybe a -> b maybe [FilePath "./."] NonEmpty FilePath -> [FilePath] forall a. NonEmpty a -> [a] toList Maybe (NonEmpty FilePath) searchRoots) (FilePath -> IO [FilePath]) -> [FilePath] -> IO [FilePath] forall (t :: * -> *) m a. (Foldable t, Monoid m) => (a -> m) -> t a -> m foldMap FilePath -> IO [FilePath] go [FilePath] roots where go :: FilePath -> IO [FilePath] go :: FilePath -> IO [FilePath] go FilePath path = do Bool isFile <- FilePath -> IO Bool doesFileExist FilePath path if Bool isFile Bool -> Bool -> Bool && FilePath -> FilePath -> Bool isExtensionOf FilePath ".hie" FilePath path then [FilePath] -> IO [FilePath] forall (f :: * -> *) a. Applicative f => a -> f a pure [FilePath path] else do Bool isDir <- FilePath -> IO Bool doesDirectoryExist FilePath path if Bool isDir then do [FilePath] contents <- (if Bool searchDotPaths then [FilePath] -> [FilePath] forall a. a -> a id else (FilePath -> Bool) -> [FilePath] -> [FilePath] forall a. (a -> Bool) -> [a] -> [a] filter (Bool -> Bool not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . FilePath -> FilePath -> Bool forall a. Eq a => [a] -> [a] -> Bool isPrefixOf FilePath ".")) ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> FilePath -> IO [FilePath] listDirectory FilePath path (FilePath -> IO [FilePath]) -> [FilePath] -> IO [FilePath] forall (t :: * -> *) m a. (Foldable t, Monoid m) => (a -> m) -> t a -> m foldMap (FilePath -> IO [FilePath] go (FilePath -> IO [FilePath]) -> (FilePath -> FilePath) -> FilePath -> IO [FilePath] forall b c a. (b -> c) -> (a -> b) -> a -> c . (FilePath path FilePath -> FilePath -> FilePath </>)) [FilePath] contents else [FilePath] -> IO [FilePath] forall (f :: * -> *) a. Applicative f => a -> f a pure [] readHieFileWithWarning :: IORef GHC.NameCache -> FilePath -> IO GHC.HieFile readHieFileWithWarning :: IORef NameCache -> FilePath -> IO HieFile readHieFileWithWarning IORef NameCache ref FilePath path = do GHC.HieFileResult Integer fileHieVersion ByteString fileGHCVersion HieFile hie <- IORef NameCache -> FilePath -> IO HieFileResult readHieFileCompat IORef NameCache ref FilePath path Bool -> IO () -> IO () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Integer GHC.hieVersion Integer -> Integer -> Bool forall a. Eq a => a -> a -> Bool /= Integer fileHieVersion) (IO () -> IO ()) -> IO () -> IO () forall a b. (a -> b) -> a -> b $ do FilePath -> IO () putStrLn (FilePath -> IO ()) -> FilePath -> IO () forall a b. (a -> b) -> a -> b $ FilePath "WARNING: version mismatch in " FilePath -> FilePath -> FilePath forall a. Semigroup a => a -> a -> a <> FilePath path FilePath -> IO () putStrLn (FilePath -> IO ()) -> FilePath -> IO () forall a b. (a -> b) -> a -> b $ FilePath " The hie files in this project were generated with GHC version: " FilePath -> FilePath -> FilePath forall a. Semigroup a => a -> a -> a <> ByteString -> FilePath forall a. Show a => a -> FilePath show ByteString fileGHCVersion FilePath -> IO () putStrLn (FilePath -> IO ()) -> FilePath -> IO () forall a b. (a -> b) -> a -> b $ FilePath " This version of calligraphy was compiled with GHC version: " FilePath -> FilePath -> FilePath forall a. Semigroup a => a -> a -> a <> Integer -> FilePath forall a. Show a => a -> FilePath show Integer GHC.hieVersion FilePath -> IO () putStrLn (FilePath -> IO ()) -> FilePath -> IO () forall a b. (a -> b) -> a -> b $ FilePath " Optimistically continuing anyway..." HieFile -> IO HieFile forall (f :: * -> *) a. Applicative f => a -> f a pure HieFile hie data SearchConfig = SearchConfig { SearchConfig -> Maybe (NonEmpty Pattern) includePatterns :: Maybe (NonEmpty Pattern), SearchConfig -> Maybe (NonEmpty Pattern) excludePatterns :: Maybe (NonEmpty Pattern), SearchConfig -> Bool searchDotPaths :: Bool, SearchConfig -> Maybe (NonEmpty FilePath) searchRoots :: Maybe (NonEmpty FilePath) } newtype Pattern = Pattern String matchPattern :: Pattern -> String -> Bool matchPattern :: Pattern -> FilePath -> Bool matchPattern (Pattern FilePath matcher) = Bool -> FilePath -> FilePath -> Bool go Bool False FilePath matcher where go :: Bool -> FilePath -> FilePath -> Bool go Bool _ (Char '*' : FilePath ms) FilePath cs = Bool -> FilePath -> FilePath -> Bool go Bool True FilePath ms FilePath cs go Bool False (Char m : FilePath ms) (Char c : FilePath cs) = Char m Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char c Bool -> Bool -> Bool && Bool -> FilePath -> FilePath -> Bool go Bool False FilePath ms FilePath cs go Bool True FilePath ms (Char c : FilePath cs) = Bool -> FilePath -> FilePath -> Bool go Bool True FilePath ms FilePath cs Bool -> Bool -> Bool || Bool -> FilePath -> FilePath -> Bool go Bool False FilePath ms (Char c Char -> FilePath -> FilePath forall a. a -> [a] -> [a] : FilePath cs) go Bool _ [] [] = Bool True go Bool _ FilePath _ FilePath _ = Bool False pSearchConfig :: Parser SearchConfig pSearchConfig :: Parser SearchConfig pSearchConfig = Maybe (NonEmpty Pattern) -> Maybe (NonEmpty Pattern) -> Bool -> Maybe (NonEmpty FilePath) -> SearchConfig SearchConfig (Maybe (NonEmpty Pattern) -> Maybe (NonEmpty Pattern) -> Bool -> Maybe (NonEmpty FilePath) -> SearchConfig) -> Parser (Maybe (NonEmpty Pattern)) -> Parser (Maybe (NonEmpty Pattern) -> Bool -> Maybe (NonEmpty FilePath) -> SearchConfig) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (([Pattern] -> Maybe (NonEmpty Pattern)) -> Parser [Pattern] -> Parser (Maybe (NonEmpty Pattern)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap [Pattern] -> Maybe (NonEmpty Pattern) forall a. [a] -> Maybe (NonEmpty a) nonEmpty (Parser [Pattern] -> Parser (Maybe (NonEmpty Pattern))) -> (Parser Pattern -> Parser [Pattern]) -> Parser Pattern -> Parser (Maybe (NonEmpty Pattern)) forall b c a. (b -> c) -> (a -> b) -> a -> c . Parser Pattern -> Parser [Pattern] forall (f :: * -> *) a. Alternative f => f a -> f [a] many) ( FilePath -> Pattern Pattern (FilePath -> Pattern) -> Parser FilePath -> Parser Pattern forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Mod ArgumentFields FilePath -> Parser FilePath forall s. IsString s => Mod ArgumentFields s -> Parser s strArgument ( FilePath -> Mod ArgumentFields FilePath forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a metavar FilePath "MODULE" Mod ArgumentFields FilePath -> Mod ArgumentFields FilePath -> Mod ArgumentFields FilePath forall a. Semigroup a => a -> a -> a <> FilePath -> Mod ArgumentFields FilePath forall (f :: * -> *) a. FilePath -> Mod f a help FilePath "Name or filepath of a module to include in the call graph. Can contain '*' wildcards. Defaults to '*'." ) ) Parser (Maybe (NonEmpty Pattern) -> Bool -> Maybe (NonEmpty FilePath) -> SearchConfig) -> Parser (Maybe (NonEmpty Pattern)) -> Parser (Bool -> Maybe (NonEmpty FilePath) -> SearchConfig) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> (([Pattern] -> Maybe (NonEmpty Pattern)) -> Parser [Pattern] -> Parser (Maybe (NonEmpty Pattern)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap [Pattern] -> Maybe (NonEmpty Pattern) forall a. [a] -> Maybe (NonEmpty a) nonEmpty (Parser [Pattern] -> Parser (Maybe (NonEmpty Pattern))) -> (Parser Pattern -> Parser [Pattern]) -> Parser Pattern -> Parser (Maybe (NonEmpty Pattern)) forall b c a. (b -> c) -> (a -> b) -> a -> c . Parser Pattern -> Parser [Pattern] forall (f :: * -> *) a. Alternative f => f a -> f [a] many) ( FilePath -> Pattern Pattern (FilePath -> Pattern) -> Parser FilePath -> Parser Pattern forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Mod OptionFields FilePath -> Parser FilePath forall s. IsString s => Mod OptionFields s -> Parser s strOption ( FilePath -> Mod OptionFields FilePath forall (f :: * -> *) a. HasName f => FilePath -> Mod f a long FilePath "exclude" Mod OptionFields FilePath -> Mod OptionFields FilePath -> Mod OptionFields FilePath forall a. Semigroup a => a -> a -> a <> Char -> Mod OptionFields FilePath forall (f :: * -> *) a. HasName f => Char -> Mod f a short Char 'e' Mod OptionFields FilePath -> Mod OptionFields FilePath -> Mod OptionFields FilePath forall a. Semigroup a => a -> a -> a <> FilePath -> Mod OptionFields FilePath forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a metavar FilePath "MODULE" Mod OptionFields FilePath -> Mod OptionFields FilePath -> Mod OptionFields FilePath forall a. Semigroup a => a -> a -> a <> FilePath -> Mod OptionFields FilePath forall (f :: * -> *) a. FilePath -> Mod f a help FilePath "Name or filepath of a module to exclude in the call graph. Can contain '*' wildcards." ) ) Parser (Bool -> Maybe (NonEmpty FilePath) -> SearchConfig) -> Parser Bool -> Parser (Maybe (NonEmpty FilePath) -> SearchConfig) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Mod FlagFields Bool -> Parser Bool switch (FilePath -> Mod FlagFields Bool forall (f :: * -> *) a. HasName f => FilePath -> Mod f a long FilePath "hidden" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool forall a. Semigroup a => a -> a -> a <> FilePath -> Mod FlagFields Bool forall (f :: * -> *) a. FilePath -> Mod f a help FilePath "Search paths with a leading period. Disabled by default.") Parser (Maybe (NonEmpty FilePath) -> SearchConfig) -> Parser (Maybe (NonEmpty FilePath)) -> Parser SearchConfig forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> (([FilePath] -> Maybe (NonEmpty FilePath)) -> Parser [FilePath] -> Parser (Maybe (NonEmpty FilePath)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap [FilePath] -> Maybe (NonEmpty FilePath) forall a. [a] -> Maybe (NonEmpty a) nonEmpty (Parser [FilePath] -> Parser (Maybe (NonEmpty FilePath))) -> (Parser FilePath -> Parser [FilePath]) -> Parser FilePath -> Parser (Maybe (NonEmpty FilePath)) forall b c a. (b -> c) -> (a -> b) -> a -> c . Parser FilePath -> Parser [FilePath] forall (f :: * -> *) a. Alternative f => f a -> f [a] many) ( Mod OptionFields FilePath -> Parser FilePath forall s. IsString s => Mod OptionFields s -> Parser s strOption ( FilePath -> Mod OptionFields FilePath forall (f :: * -> *) a. HasName f => FilePath -> Mod f a long FilePath "input" Mod OptionFields FilePath -> Mod OptionFields FilePath -> Mod OptionFields FilePath forall a. Semigroup a => a -> a -> a <> Char -> Mod OptionFields FilePath forall (f :: * -> *) a. HasName f => Char -> Mod f a short Char 'i' Mod OptionFields FilePath -> Mod OptionFields FilePath -> Mod OptionFields FilePath forall a. Semigroup a => a -> a -> a <> FilePath -> Mod OptionFields FilePath forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a metavar FilePath "PATH" Mod OptionFields FilePath -> Mod OptionFields FilePath -> Mod OptionFields FilePath forall a. Semigroup a => a -> a -> a <> FilePath -> Mod OptionFields FilePath forall (f :: * -> *) a. FilePath -> Mod f a help FilePath "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 './.'" ) )