{-# language ApplicativeDo #-}
{-# language ScopedTypeVariables #-}
{-# language BlockArguments #-}
{-# language FlexibleContexts #-}
{-# language NamedFieldPuns #-}
{-# language OverloadedStrings #-}
{-# language LambdaCase #-}
{-# language RecordWildCards #-}

-- | This module provides an entry point to the Weeder executable.

module Weeder.Main ( main, mainWithConfig, getHieFiles ) where

-- async
import Control.Concurrent.Async ( async, link, ExceptionInLinkedThread ( ExceptionInLinkedThread ) )

-- base
import Control.Exception ( Exception, throwIO, displayException, catches, Handler ( Handler ), SomeException ( SomeException ))
import Control.Concurrent ( getChanContents, newChan, writeChan, setNumCapabilities )
import Data.List
import Control.Monad ( unless, when )
import Data.Foldable
import Data.Maybe ( isJust, catMaybes )
import Data.Version ( showVersion )
import System.Exit ( ExitCode(..), exitWith )
import System.IO ( stderr, hPutStrLn )

-- toml-reader
import qualified TOML

-- directory
import System.Directory ( doesFileExist )

-- filepath
import System.FilePath ( isExtSeparator )

-- glob
import qualified System.FilePath.Glob as Glob

-- ghc
import GHC.Iface.Ext.Binary ( HieFileResult( HieFileResult, hie_file_result ), readHieFileWithVersion )
import GHC.Iface.Ext.Types ( HieFile( hie_hs_file ), hieVersion )
import GHC.Types.Name.Cache ( initNameCache, NameCache )

-- optparse-applicative
import Options.Applicative

-- text
import qualified Data.Text.IO as T

-- weeder
import Weeder.Run
import Weeder.Config
import Paths_weeder (version)


-- | Each exception corresponds to an exit code.
data WeederException 
  = ExitNoHieFilesFailure
  | ExitHieVersionFailure 
      FilePath -- ^ Path to HIE file
      Integer -- ^ HIE file's header version
  | ExitConfigFailure
      String -- ^ Error message
  | ExitWeedsFound
  deriving Int -> WeederException -> ShowS
[WeederException] -> ShowS
WeederException -> [Char]
(Int -> WeederException -> ShowS)
-> (WeederException -> [Char])
-> ([WeederException] -> ShowS)
-> Show WeederException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WeederException -> ShowS
showsPrec :: Int -> WeederException -> ShowS
$cshow :: WeederException -> [Char]
show :: WeederException -> [Char]
$cshowList :: [WeederException] -> ShowS
showList :: [WeederException] -> ShowS
Show


weederExitCode :: WeederException -> ExitCode
weederExitCode :: WeederException -> ExitCode
weederExitCode = \case
  WeederException
ExitWeedsFound -> Int -> ExitCode
ExitFailure Int
228
  ExitHieVersionFailure [Char]
_ Integer
_ -> Int -> ExitCode
ExitFailure Int
2
  ExitConfigFailure [Char]
_ -> Int -> ExitCode
ExitFailure Int
3
  WeederException
ExitNoHieFilesFailure -> Int -> ExitCode
ExitFailure Int
4


instance Exception WeederException where
  displayException :: WeederException -> [Char]
displayException = \case
    WeederException
ExitNoHieFilesFailure -> [Char]
noHieFilesFoundMessage
    ExitHieVersionFailure [Char]
path Integer
v -> [Char] -> Integer -> [Char]
forall {a}. Show a => [Char] -> a -> [Char]
hieVersionMismatchMessage [Char]
path Integer
v
    ExitConfigFailure [Char]
s -> [Char]
s
    WeederException
ExitWeedsFound -> [Char]
forall a. Monoid a => a
mempty
    where

      noHieFilesFoundMessage :: [Char]
noHieFilesFoundMessage =  
        [Char]
"No HIE files found: check that the directory is correct "
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"and that the -fwrite-ide-info compilation flag is set."

      hieVersionMismatchMessage :: [Char] -> a -> [Char]
hieVersionMismatchMessage [Char]
path a
v = [[Char]] -> [Char]
unlines
        [ [Char]
"incompatible hie file: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
path
        , [Char]
"    this version of weeder was compiled with GHC version "
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
hieVersion
        , [Char]
"    the hie files in this project were generated with GHC version "
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> [Char]
forall a. Show a => a -> [Char]
show a
v
        , [Char]
"    weeder must be built with the same GHC version"
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" as the project it is used on"
        ]


-- | Convert 'WeederException' to the corresponding 'ExitCode' and emit an error 
-- message to stderr.
--
-- Additionally, unwrap 'ExceptionInLinkedThread' exceptions: this is for
-- 'getHieFiles'.
handleWeederException :: IO a -> IO a
handleWeederException :: forall a. IO a -> IO a
handleWeederException IO a
a = IO a -> [Handler a] -> IO a
forall a. IO a -> [Handler a] -> IO a
catches IO a
a [Handler a]
forall {a}. [Handler a]
handlers 
  where
    handlers :: [Handler a]
handlers = [ (WeederException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler WeederException -> IO a
forall {b}. WeederException -> IO b
rethrowExits
               , (ExceptionInLinkedThread -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ExceptionInLinkedThread -> IO a
forall {a}. ExceptionInLinkedThread -> IO a
unwrapLinks
               ]
    rethrowExits :: WeederException -> IO b
rethrowExits WeederException
w = do
      Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr (WeederException -> [Char]
forall e. Exception e => e -> [Char]
displayException WeederException
w)
      ExitCode -> IO b
forall a. ExitCode -> IO a
exitWith (WeederException -> ExitCode
weederExitCode WeederException
w)
    unwrapLinks :: ExceptionInLinkedThread -> IO a
unwrapLinks (ExceptionInLinkedThread Async a
_ (SomeException e
w)) =
      e -> IO a
forall e a. Exception e => e -> IO a
throwIO e
w


data CLIArguments = CLIArguments
  { CLIArguments -> [Char]
configPath :: FilePath
  , CLIArguments -> [Char]
hieExt :: String
  , CLIArguments -> [[Char]]
hieDirectories :: [FilePath]
  , CLIArguments -> Bool
requireHsFiles :: Bool
  , CLIArguments -> Bool
writeDefaultConfig :: Bool
  , CLIArguments -> Bool
noDefaultFields :: Bool
  , CLIArguments -> Maybe Int
capabilities :: Maybe Int
  }


parseCLIArguments :: Parser CLIArguments
parseCLIArguments :: Parser CLIArguments
parseCLIArguments = do
    [Char]
configPath <- Mod OptionFields [Char] -> Parser [Char]
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
        ( [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"config"
            Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"A file path for Weeder's configuration."
            Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value [Char]
"./weeder.toml"
            Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"<weeder.toml>"
        )
    [Char]
hieExt <- Mod OptionFields [Char] -> Parser [Char]
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
        ( [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"hie-extension"
            Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value [Char]
".hie"
            Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Extension of HIE files"
            Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields [Char]
forall a (f :: * -> *). Show a => Mod f a
showDefault
        )
    [[Char]]
hieDirectories <- Parser [Char] -> Parser [[Char]]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (
        Mod OptionFields [Char] -> Parser [Char]
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
            ( [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"hie-directory"
                Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"A directory to look for .hie files in. Maybe specified multiple times. Default ./."
            )
        )
    Bool
requireHsFiles <- Mod FlagFields Bool -> Parser Bool
switch
          ( [Char] -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"require-hs-files"
              Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod FlagFields Bool
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Skip stale .hie files with no matching .hs modules"
          )
    Bool
writeDefaultConfig <- Mod FlagFields Bool -> Parser Bool
switch
          ( [Char] -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"write-default-config"
              Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod FlagFields Bool
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Write a default configuration file if the one specified by --config does not exist"
          )
    Bool
noDefaultFields <- Mod FlagFields Bool -> Parser Bool
switch
          ( [Char] -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"no-default-fields"
              Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod FlagFields Bool
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Do not use default field values for missing fields in the configuration."
          )
    Maybe Int
capabilities <- Parser (Maybe Int)
forall {a}. Parser (Maybe a)
nParser Parser (Maybe Int) -> Parser (Maybe Int) -> Parser (Maybe Int)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Maybe Int)
jParser
    pure CLIArguments{Bool
[Char]
[[Char]]
Maybe Int
configPath :: [Char]
hieExt :: [Char]
hieDirectories :: [[Char]]
requireHsFiles :: Bool
writeDefaultConfig :: Bool
noDefaultFields :: Bool
capabilities :: Maybe Int
configPath :: [Char]
hieExt :: [Char]
hieDirectories :: [[Char]]
requireHsFiles :: Bool
writeDefaultConfig :: Bool
noDefaultFields :: Bool
capabilities :: Maybe Int
..}
    where
      jParser :: Parser (Maybe Int)
jParser = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Parser Int -> Parser (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Int
forall a. Read a => ReadM a
auto
          ( Char -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'j'
              Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Int -> Mod OptionFields Int
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Int
1
              Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod OptionFields Int
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Number of cores to use."
              Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields Int
forall a (f :: * -> *). Show a => Mod f a
showDefault)
      nParser :: Parser (Maybe a)
nParser = Maybe a -> Mod FlagFields (Maybe a) -> Parser (Maybe a)
forall a. a -> Mod FlagFields a -> Parser a
flag' Maybe a
forall a. Maybe a
Nothing
          ( Char -> Mod FlagFields (Maybe a)
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'N'
              Mod FlagFields (Maybe a)
-> Mod FlagFields (Maybe a) -> Mod FlagFields (Maybe a)
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod FlagFields (Maybe a)
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Use all available cores."
          )


-- | Parse command line arguments and into a 'Config' and run 'mainWithConfig'.
--
-- Exits with one of the listed Weeder exit codes on failure.
main :: IO ()
main :: IO ()
main = IO () -> IO ()
forall a. IO a -> IO a
handleWeederException do
  CLIArguments{Bool
[Char]
[[Char]]
Maybe Int
configPath :: CLIArguments -> [Char]
hieExt :: CLIArguments -> [Char]
hieDirectories :: CLIArguments -> [[Char]]
requireHsFiles :: CLIArguments -> Bool
writeDefaultConfig :: CLIArguments -> Bool
noDefaultFields :: CLIArguments -> Bool
capabilities :: CLIArguments -> Maybe Int
configPath :: [Char]
hieExt :: [Char]
hieDirectories :: [[Char]]
requireHsFiles :: Bool
writeDefaultConfig :: Bool
noDefaultFields :: Bool
capabilities :: Maybe Int
..} <-
    ParserInfo CLIArguments -> IO CLIArguments
forall a. ParserInfo a -> IO a
execParser (ParserInfo CLIArguments -> IO CLIArguments)
-> ParserInfo CLIArguments -> IO CLIArguments
forall a b. (a -> b) -> a -> b
$
      Parser CLIArguments
-> InfoMod CLIArguments -> ParserInfo CLIArguments
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser CLIArguments
parseCLIArguments Parser CLIArguments
-> Parser (CLIArguments -> CLIArguments) -> Parser CLIArguments
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (CLIArguments -> CLIArguments)
forall a. Parser (a -> a)
helper Parser CLIArguments
-> Parser (CLIArguments -> CLIArguments) -> Parser CLIArguments
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (CLIArguments -> CLIArguments)
forall a. Parser (a -> a)
versionP) InfoMod CLIArguments
forall a. Monoid a => a
mempty

  (Int -> IO ()) -> Maybe Int -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Int -> IO ()
setNumCapabilities Maybe Int
capabilities

  Bool
configExists <-
    [Char] -> IO Bool
doesFileExist [Char]
configPath

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
writeDefaultConfig Bool -> Bool -> Bool
==> Bool
configExists) do
    Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Did not find config: wrote default config to " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
configPath
    [Char] -> [Char] -> IO ()
writeFile [Char]
configPath (ConfigParsed -> [Char]
configToToml ConfigParsed
defaultConfig)

  Bool -> [Char] -> IO (Either TOMLError Config)
decodeConfig Bool
noDefaultFields [Char]
configPath
    IO (Either TOMLError Config)
-> (Either TOMLError Config -> IO Config) -> IO Config
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (TOMLError -> IO Config)
-> (Config -> IO Config) -> Either TOMLError Config -> IO Config
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either TOMLError -> IO Config
forall e a. Exception e => e -> IO a
throwConfigError Config -> IO Config
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    IO Config -> (Config -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> [[Char]] -> Bool -> Config -> IO ()
mainWithConfig [Char]
hieExt [[Char]]
hieDirectories Bool
requireHsFiles
  where
    throwConfigError :: e -> IO a
throwConfigError e
e =
      WeederException -> IO a
forall e a. Exception e => e -> IO a
throwIO (WeederException -> IO a) -> WeederException -> IO a
forall a b. (a -> b) -> a -> b
$ [Char] -> WeederException
ExitConfigFailure (e -> [Char]
forall e. Exception e => e -> [Char]
displayException e
e)

    decodeConfig :: Bool -> [Char] -> IO (Either TOMLError Config)
decodeConfig Bool
noDefaultFields =
      if Bool
noDefaultFields
        then (Text -> Either TOMLError Config)
-> IO Text -> IO (Either TOMLError Config)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Decoder Config -> Text -> Either TOMLError Config
forall a. Decoder a -> Text -> Either TOMLError a
TOML.decodeWith Decoder Config
decodeNoDefaults) (IO Text -> IO (Either TOMLError Config))
-> ([Char] -> IO Text) -> [Char] -> IO (Either TOMLError Config)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO Text
T.readFile
        else [Char] -> IO (Either TOMLError Config)
forall a. DecodeTOML a => [Char] -> IO (Either TOMLError a)
TOML.decodeFile

    versionP :: Parser (a -> a)
versionP = [Char] -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a. [Char] -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption ( [Char]
"weeder version "
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Version -> [Char]
showVersion Version
version
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"\nhie version "
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
hieVersion )
        ( [Char] -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"version" Mod OptionFields (a -> a)
-> Mod OptionFields (a -> a) -> Mod OptionFields (a -> a)
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Show version" )


-- | Run Weeder in the current working directory with a given 'Config'.
--
-- This will recursively find all files with the given extension in the given directories, perform
-- analysis, and report all unused definitions according to the 'Config'.
--
-- Exits with one of the listed Weeder exit codes on failure.
mainWithConfig :: String -> [FilePath] -> Bool -> Config -> IO ()
mainWithConfig :: [Char] -> [[Char]] -> Bool -> Config -> IO ()
mainWithConfig [Char]
hieExt [[Char]]
hieDirectories Bool
requireHsFiles Config
weederConfig = IO () -> IO ()
forall a. IO a -> IO a
handleWeederException do
  [HieFile]
hieFiles <-
    [Char] -> [[Char]] -> Bool -> IO [HieFile]
getHieFiles [Char]
hieExt [[Char]]
hieDirectories Bool
requireHsFiles

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([HieFile] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HieFile]
hieFiles) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ WeederException -> IO ()
forall e a. Exception e => e -> IO a
throwIO WeederException
ExitNoHieFilesFailure

  let
    ([Weed]
weeds, Analysis
_) =
      Config -> [HieFile] -> ([Weed], Analysis)
runWeeder Config
weederConfig [HieFile]
hieFiles

  (Weed -> IO ()) -> [Weed] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> IO ()
putStrLn ([Char] -> IO ()) -> (Weed -> [Char]) -> Weed -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Weed -> [Char]
formatWeed) [Weed]
weeds

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Weed] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Weed]
weeds) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ WeederException -> IO ()
forall e a. Exception e => e -> IO a
throwIO WeederException
ExitWeedsFound


-- | Find and read all .hie files in the given directories according to the given parameters,
-- exiting if any are incompatible with the current version of GHC.
-- The .hie files are returned as a lazy stream in the form of a list.
--
-- Will rethrow exceptions as 'ExceptionInLinkedThread' to the calling thread.
getHieFiles :: String -> [FilePath] -> Bool -> IO [HieFile]
getHieFiles :: [Char] -> [[Char]] -> Bool -> IO [HieFile]
getHieFiles [Char]
hieExt [[Char]]
hieDirectories Bool
requireHsFiles = do
  let hiePat :: [Char]
hiePat = [Char]
"**/*." [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
hieExtNoSep
      hieExtNoSep :: [Char]
hieExtNoSep = if Char -> Bool
isExtSeparator ([Char] -> Char
forall a. HasCallStack => [a] -> a
head [Char]
hieExt) then ShowS
forall a. HasCallStack => [a] -> [a]
tail [Char]
hieExt else [Char]
hieExt

  [[Char]]
hieFilePaths :: [FilePath] <-
    [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Char]]] -> [[Char]]) -> IO [[[Char]]] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      ([Char] -> IO [[Char]]) -> [[Char]] -> IO [[[Char]]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ( [Char] -> [Char] -> IO [[Char]]
getFilesIn [Char]
hiePat )
        ( if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
hieDirectories
          then [[Char]
"./."]
          else [[Char]]
hieDirectories
        )

  [[Char]]
hsFilePaths :: [FilePath] <-
    if Bool
requireHsFiles
      then [Char] -> [Char] -> IO [[Char]]
getFilesIn [Char]
"**/*.hs" [Char]
"./."
      else [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

  Chan (Maybe HieFile)
hieFileResultsChan <- IO (Chan (Maybe HieFile))
forall a. IO (Chan a)
newChan

  NameCache
nameCache <-
    Char -> [Name] -> IO NameCache
initNameCache Char
'z' []

  Async ()
a <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
handleWeederException do
    NameCache -> [[Char]] -> Chan (Maybe HieFile) -> [[Char]] -> IO ()
forall {t :: * -> *} {t :: * -> *}.
(Foldable t, Foldable t) =>
NameCache -> t [Char] -> Chan (Maybe HieFile) -> t [Char] -> IO ()
readHieFiles NameCache
nameCache [[Char]]
hieFilePaths Chan (Maybe HieFile)
hieFileResultsChan [[Char]]
hsFilePaths
    Chan (Maybe HieFile) -> Maybe HieFile -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Maybe HieFile)
hieFileResultsChan Maybe HieFile
forall a. Maybe a
Nothing
 
  Async () -> IO ()
forall a. Async a -> IO ()
link Async ()
a

  [Maybe HieFile] -> [HieFile]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe HieFile] -> [HieFile])
-> ([Maybe HieFile] -> [Maybe HieFile])
-> [Maybe HieFile]
-> [HieFile]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe HieFile -> Bool) -> [Maybe HieFile] -> [Maybe HieFile]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Maybe HieFile -> Bool
forall a. Maybe a -> Bool
isJust ([Maybe HieFile] -> [HieFile])
-> IO [Maybe HieFile] -> IO [HieFile]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Chan (Maybe HieFile) -> IO [Maybe HieFile]
forall a. Chan a -> IO [a]
getChanContents Chan (Maybe HieFile)
hieFileResultsChan

  where

    readHieFiles :: NameCache -> t [Char] -> Chan (Maybe HieFile) -> t [Char] -> IO ()
readHieFiles NameCache
nameCache t [Char]
hieFilePaths Chan (Maybe HieFile)
hieFileResultsChan t [Char]
hsFilePaths =
      t [Char] -> ([Char] -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ t [Char]
hieFilePaths \[Char]
hieFilePath -> do
        HieFile
hieFileResult <-
          NameCache -> [Char] -> IO HieFile
readCompatibleHieFileOrExit NameCache
nameCache [Char]
hieFilePath
        let hsFileExists :: Bool
hsFileExists = ([Char] -> Bool) -> t [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ( HieFile -> [Char]
hie_hs_file HieFile
hieFileResult [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` ) t [Char]
hsFilePaths
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
requireHsFiles Bool -> Bool -> Bool
==> Bool
hsFileExists) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Chan (Maybe HieFile) -> Maybe HieFile -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Maybe HieFile)
hieFileResultsChan (HieFile -> Maybe HieFile
forall a. a -> Maybe a
Just HieFile
hieFileResult)


-- | Recursively search for files with the given extension in given directory
getFilesIn
  :: String
  -- ^ Only files matching this pattern are considered.
  -> FilePath
  -- ^ Directory to look in
  -> IO [FilePath]
getFilesIn :: [Char] -> [Char] -> IO [[Char]]
getFilesIn [Char]
pat [Char]
root = do
  [[[Char]]
result] <- [Pattern] -> [Char] -> IO [[[Char]]]
Glob.globDir [[Char] -> Pattern
Glob.compile [Char]
pat] [Char]
root
  [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]]
result
  

-- | Read a .hie file, exiting if it's an incompatible version.
readCompatibleHieFileOrExit :: NameCache -> FilePath -> IO HieFile
readCompatibleHieFileOrExit :: NameCache -> [Char] -> IO HieFile
readCompatibleHieFileOrExit NameCache
nameCache [Char]
path = do
  Either HieHeader HieFileResult
res <- (HieHeader -> Bool)
-> NameCache -> [Char] -> IO (Either HieHeader HieFileResult)
readHieFileWithVersion (\(Integer
v, ByteString
_) -> Integer
v Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
hieVersion) NameCache
nameCache [Char]
path
  case Either HieHeader HieFileResult
res of
    Right HieFileResult{ HieFile
hie_file_result :: HieFileResult -> HieFile
hie_file_result :: HieFile
hie_file_result } ->
      HieFile -> IO HieFile
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HieFile
hie_file_result
    Left ( Integer
v, ByteString
_ghcVersion ) ->
      WeederException -> IO HieFile
forall e a. Exception e => e -> IO a
throwIO (WeederException -> IO HieFile) -> WeederException -> IO HieFile
forall a b. (a -> b) -> a -> b
$ [Char] -> Integer -> WeederException
ExitHieVersionFailure [Char]
path Integer
v


infixr 5 ==>


-- | An infix operator for logical implication
(==>) :: Bool -> Bool -> Bool
Bool
True  ==> :: Bool -> Bool -> Bool
==> Bool
x = Bool
x
Bool
False ==> Bool
_ = Bool
True