{-# 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 './.'"
          )
      )