{-# language ApplicativeDo #-}
{-# 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 Control.Monad ( unless, when )
import Data.Foldable
import Data.List ( isSuffixOf )
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 ( canonicalizePath, doesDirectoryExist, doesFileExist, doesPathExist, listDirectory, withCurrentDirectory )

-- filepath
import System.FilePath ( isExtensionOf )

-- 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 -> FilePath
(Int -> WeederException -> ShowS)
-> (WeederException -> FilePath)
-> ([WeederException] -> ShowS)
-> Show WeederException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WeederException -> ShowS
showsPrec :: Int -> WeederException -> ShowS
$cshow :: WeederException -> FilePath
show :: WeederException -> FilePath
$cshowList :: [WeederException] -> ShowS
showList :: [WeederException] -> ShowS
Show


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


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

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

      hieVersionMismatchMessage :: FilePath -> a -> FilePath
hieVersionMismatchMessage FilePath
path a
v = [FilePath] -> FilePath
unlines
        [ FilePath
"incompatible hie file: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
path
        , FilePath
"    this version of weeder was compiled with GHC version "
          FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
hieVersion
        , FilePath
"    the hie files in this project were generated with GHC version "
          FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> FilePath
forall a. Show a => a -> FilePath
show a
v
        , FilePath
"    weeder must be built with the same GHC version"
          FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" 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 -> FilePath -> IO ()
hPutStrLn Handle
stderr (WeederException -> FilePath
forall e. Exception e => e -> FilePath
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 -> FilePath
configPath :: FilePath
  , CLIArguments -> FilePath
hieExt :: String
  , CLIArguments -> [FilePath]
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
    FilePath
configPath <- 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
"config"
            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
"A file path for Weeder's configuration."
            Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value FilePath
"./weeder.toml"
            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
"<weeder.toml>"
        )
    FilePath
hieExt <- 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
"hie-extension"
            Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value FilePath
".hie"
            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
"Extension of HIE files"
            Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields FilePath
forall a (f :: * -> *). Show a => Mod f a
showDefault
        )
    [FilePath]
hieDirectories <- Parser FilePath -> Parser [FilePath]
forall a. Parser a -> Parser [a]
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
"hie-directory"
                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
"A directory to look for .hie files in. Maybe specified multiple times. Default ./."
            )
        )
    Bool
requireHsFiles <- Mod FlagFields Bool -> Parser Bool
switch
          ( FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"require-hs-files"
              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
"Skip stale .hie files with no matching .hs modules"
          )
    Bool
writeDefaultConfig <- Mod FlagFields Bool -> Parser Bool
switch
          ( FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"write-default-config"
              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
"Write a default configuration file if the one specified by --config does not exist"
          )
    Bool
noDefaultFields <- Mod FlagFields Bool -> Parser Bool
switch
          ( FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"no-default-fields"
              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
"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
FilePath
[FilePath]
Maybe Int
configPath :: FilePath
hieExt :: FilePath
hieDirectories :: [FilePath]
requireHsFiles :: Bool
writeDefaultConfig :: Bool
noDefaultFields :: Bool
capabilities :: Maybe Int
configPath :: FilePath
hieExt :: FilePath
hieDirectories :: [FilePath]
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
<> FilePath -> Mod OptionFields Int
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"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
<> FilePath -> Mod FlagFields (Maybe a)
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"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
FilePath
[FilePath]
Maybe Int
configPath :: CLIArguments -> FilePath
hieExt :: CLIArguments -> FilePath
hieDirectories :: CLIArguments -> [FilePath]
requireHsFiles :: CLIArguments -> Bool
writeDefaultConfig :: CLIArguments -> Bool
noDefaultFields :: CLIArguments -> Bool
capabilities :: CLIArguments -> Maybe Int
configPath :: FilePath
hieExt :: FilePath
hieDirectories :: [FilePath]
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 <-
    FilePath -> IO Bool
doesFileExist FilePath
configPath

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

  Bool -> FilePath -> IO (Either TOMLError Config)
decodeConfig Bool
noDefaultFields FilePath
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 {a} {a}. Show a => a -> 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
>>= FilePath -> [FilePath] -> Bool -> Config -> IO ()
mainWithConfig FilePath
hieExt [FilePath]
hieDirectories Bool
requireHsFiles
  where
    throwConfigError :: a -> IO a
throwConfigError a
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
$ FilePath -> WeederException
ExitConfigFailure (a -> FilePath
forall a. Show a => a -> FilePath
show a
e)

    decodeConfig :: Bool -> FilePath -> 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))
-> (FilePath -> IO Text)
-> FilePath
-> IO (Either TOMLError Config)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO Text
T.readFile
        else FilePath -> IO (Either TOMLError Config)
forall a. DecodeTOML a => FilePath -> IO (Either TOMLError a)
TOML.decodeFile

    versionP :: Parser (a -> a)
versionP = FilePath -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a. FilePath -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption ( FilePath
"weeder version "
                            FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Version -> FilePath
showVersion Version
version
                            FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"\nhie version "
                            FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
hieVersion )
        ( FilePath -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"version" Mod OptionFields (a -> a)
-> Mod OptionFields (a -> a) -> Mod OptionFields (a -> a)
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"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 :: FilePath -> [FilePath] -> Bool -> Config -> IO ()
mainWithConfig FilePath
hieExt [FilePath]
hieDirectories Bool
requireHsFiles Config
weederConfig = IO () -> IO ()
forall a. IO a -> IO a
handleWeederException do
  [HieFile]
hieFiles <-
    FilePath -> [FilePath] -> Bool -> IO [HieFile]
getHieFiles FilePath
hieExt [FilePath]
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_ (FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> (Weed -> FilePath) -> Weed -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Weed -> FilePath
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 :: FilePath -> [FilePath] -> Bool -> IO [HieFile]
getHieFiles FilePath
hieExt [FilePath]
hieDirectories Bool
requireHsFiles = do
  [FilePath]
hieFilePaths <-
    [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      (FilePath -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
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 ( FilePath -> FilePath -> IO [FilePath]
getFilesIn FilePath
hieExt )
        ( if [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
hieDirectories
          then [FilePath
"./."]
          else [FilePath]
hieDirectories
        )

  [FilePath]
hsFilePaths <-
    if Bool
requireHsFiles
      then FilePath -> FilePath -> IO [FilePath]
getFilesIn FilePath
".hs" FilePath
"./."
      else [FilePath] -> IO [FilePath]
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
-> [FilePath] -> Chan (Maybe HieFile) -> [FilePath] -> IO ()
forall {t :: * -> *} {t :: * -> *}.
(Foldable t, Foldable t) =>
NameCache
-> t FilePath -> Chan (Maybe HieFile) -> t FilePath -> IO ()
readHieFiles NameCache
nameCache [FilePath]
hieFilePaths Chan (Maybe HieFile)
hieFileResultsChan [FilePath]
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 FilePath -> Chan (Maybe HieFile) -> t FilePath -> IO ()
readHieFiles NameCache
nameCache t FilePath
hieFilePaths Chan (Maybe HieFile)
hieFileResultsChan t FilePath
hsFilePaths =
      t FilePath -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ t FilePath
hieFilePaths \FilePath
hieFilePath -> do
        HieFile
hieFileResult <-
          NameCache -> FilePath -> IO HieFile
readCompatibleHieFileOrExit NameCache
nameCache FilePath
hieFilePath
        let hsFileExists :: Bool
hsFileExists = (FilePath -> Bool) -> t FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ( HieFile -> FilePath
hie_hs_file HieFile
hieFileResult FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` ) t FilePath
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 with this extension are considered
  -> FilePath
  -- ^ Directory to look in
  -> IO [FilePath]
getFilesIn :: FilePath -> FilePath -> IO [FilePath]
getFilesIn FilePath
ext FilePath
path = do
  Bool
exists <-
    FilePath -> IO Bool
doesPathExist FilePath
path

  if Bool
exists
    then do
      Bool
isFile <-
        FilePath -> IO Bool
doesFileExist FilePath
path

      if Bool
isFile Bool -> Bool -> Bool
&& FilePath
ext FilePath -> FilePath -> Bool
`isExtensionOf` FilePath
path
        then do
          FilePath
path' <-
            FilePath -> IO FilePath
canonicalizePath FilePath
path

          return [ FilePath
path' ]

        else do
          Bool
isDir <-
            FilePath -> IO Bool
doesDirectoryExist FilePath
path

          if Bool
isDir
            then do
              [FilePath]
cnts <-
                FilePath -> IO [FilePath]
listDirectory FilePath
path

              FilePath -> IO [FilePath] -> IO [FilePath]
forall a. FilePath -> IO a -> IO a
withCurrentDirectory FilePath
path ( (FilePath -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ( FilePath -> FilePath -> IO [FilePath]
getFilesIn FilePath
ext ) [FilePath]
cnts )

            else
              [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

    else
      [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []


-- | Read a .hie file, exiting if it's an incompatible version.
readCompatibleHieFileOrExit :: NameCache -> FilePath -> IO HieFile
readCompatibleHieFileOrExit :: NameCache -> FilePath -> IO HieFile
readCompatibleHieFileOrExit NameCache
nameCache FilePath
path = do
  Either HieHeader HieFileResult
res <- (HieHeader -> Bool)
-> NameCache -> FilePath -> IO (Either HieHeader HieFileResult)
readHieFileWithVersion (\(Integer
v, ByteString
_) -> Integer
v Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
hieVersion) NameCache
nameCache FilePath
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
$ FilePath -> Integer -> WeederException
ExitHieVersionFailure FilePath
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