module Development.IDE.Main (Arguments(..), defaultMain) where
import Control.Concurrent.Extra (readVar)
import Control.Exception.Safe (
    Exception (displayException),
    catchAny,
 )
import Control.Monad.Extra (concatMapM, unless, when)
import Data.Default (Default (def))
import qualified Data.HashMap.Strict as HashMap
import Data.List.Extra (
    intercalate,
    isPrefixOf,
    nub,
    nubOrd,
    partition,
 )
import Data.Maybe (catMaybes, fromMaybe, isJust)
import qualified Data.Text as T
import Development.IDE (Action, Rules, noLogging)
import Development.IDE.Core.Debouncer (newAsyncDebouncer)
import Development.IDE.Core.FileStore (makeVFSHandle)
import Development.IDE.Core.OfInterest (
    FileOfInterestStatus (OnDisk),
    kick,
    setFilesOfInterest,
 )
import Development.IDE.Core.RuleTypes (
    GenerateCore (GenerateCore),
    GetHieAst (GetHieAst),
    GhcSession (GhcSession),
    GhcSessionDeps (GhcSessionDeps),
    TypeCheck (TypeCheck),
 )
import Development.IDE.Core.Rules (
    GhcSessionIO (GhcSessionIO),
    mainRule,
 )
import Development.IDE.Core.Service (initialise, runAction)
import Development.IDE.Core.Shake (
    IdeState (shakeExtras),
    ShakeExtras (state),
    uses,
 )
import Development.IDE.Core.Tracing (measureMemory)
import Development.IDE.LSP.LanguageServer (runLanguageServer)
import Development.IDE.Plugin (
    Plugin (pluginHandlers, pluginRules),
 )
import Development.IDE.Plugin.HLS (asGhcIdePlugin)
import Development.IDE.Session (SessionLoadingOptions, loadSessionWithOptions, setInitialDynFlags, getHieDbLoc, runWithDb)
import Development.IDE.Types.Location (toNormalizedFilePath')
import Development.IDE.Types.Logger (Logger)
import Development.IDE.Types.Options (
    IdeGhcSession,
    IdeOptions (optCheckParents, optCheckProject, optReportProgress),
    clientSupportsProgress,
    defaultIdeOptions,
 )
import Development.IDE.Types.Shake (Key (Key))
import Development.Shake (action)
import HIE.Bios.Cradle (findCradle)
import Ide.Plugin.Config (CheckParents (NeverCheck), Config, getConfigFromNotification)
import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins)
import Ide.Types (IdePlugins)
import qualified Language.LSP.Server as LSP
import qualified System.Directory.Extra as IO
import System.Exit (ExitCode (ExitFailure), exitWith)
import System.FilePath (takeExtension, takeFileName)
import System.IO (hPutStrLn, hSetEncoding, stderr, stdout, utf8)
import System.Time.Extra (offsetTime, showDuration)
import Text.Printf (printf)
import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide

data Arguments = Arguments
    { Arguments -> Bool
argsOTMemoryProfiling :: Bool
    , Arguments -> Maybe [FilePath]
argFiles :: Maybe [FilePath]   -- ^ Nothing: lsp server ;  Just: typecheck and exit

    , Arguments -> Logger
argsLogger :: Logger
    , Arguments -> Rules ()
argsRules :: Rules ()
    , Arguments -> IdePlugins IdeState
argsHlsPlugins :: IdePlugins IdeState
    , Arguments -> Plugin Config
argsGhcidePlugin :: Plugin Config  -- ^ Deprecated

    , Arguments -> SessionLoadingOptions
argsSessionLoadingOptions :: SessionLoadingOptions
    , Arguments -> Maybe Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions :: Maybe Config -> Action IdeGhcSession -> IdeOptions
    , Arguments -> Options
argsLspOptions :: LSP.Options
    , Arguments -> Config
argsDefaultHlsConfig :: Config
    , Arguments -> FilePath -> IO FilePath
argsGetHieDbLoc :: FilePath -> IO FilePath -- ^ Map project roots to the location of the hiedb for the project

    }

instance Default Arguments where
    def :: Arguments
def = Arguments :: Bool
-> Maybe [FilePath]
-> Logger
-> Rules ()
-> IdePlugins IdeState
-> Plugin Config
-> SessionLoadingOptions
-> (Maybe Config -> Action IdeGhcSession -> IdeOptions)
-> Options
-> Config
-> (FilePath -> IO FilePath)
-> Arguments
Arguments
        { argsOTMemoryProfiling :: Bool
argsOTMemoryProfiling = Bool
False
        , argFiles :: Maybe [FilePath]
argFiles = Maybe [FilePath]
forall a. Maybe a
Nothing
        , argsLogger :: Logger
argsLogger = Logger
noLogging
        , argsRules :: Rules ()
argsRules = Rules ()
mainRule Rules () -> Rules () -> Rules ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Action () -> Rules ()
forall a. Partial => Action a -> Rules ()
action Action ()
kick
        , argsGhcidePlugin :: Plugin Config
argsGhcidePlugin = Plugin Config
forall a. Monoid a => a
mempty
        , argsHlsPlugins :: IdePlugins IdeState
argsHlsPlugins = [PluginDescriptor IdeState] -> IdePlugins IdeState
forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
pluginDescToIdePlugins [PluginDescriptor IdeState]
Ghcide.descriptors
        , argsSessionLoadingOptions :: SessionLoadingOptions
argsSessionLoadingOptions = SessionLoadingOptions
forall a. Default a => a
def
        , argsIdeOptions :: Maybe Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions = (Action IdeGhcSession -> IdeOptions)
-> Maybe Config -> Action IdeGhcSession -> IdeOptions
forall a b. a -> b -> a
const Action IdeGhcSession -> IdeOptions
defaultIdeOptions
        , argsLspOptions :: Options
argsLspOptions = Options
forall a. Default a => a
def {completionTriggerCharacters :: Maybe FilePath
LSP.completionTriggerCharacters = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"."}
        , argsDefaultHlsConfig :: Config
argsDefaultHlsConfig = Config
forall a. Default a => a
def
        , argsGetHieDbLoc :: FilePath -> IO FilePath
argsGetHieDbLoc = FilePath -> IO FilePath
getHieDbLoc
        }

defaultMain :: Arguments -> IO ()
defaultMain :: Arguments -> IO ()
defaultMain Arguments{Bool
Maybe [FilePath]
IdePlugins IdeState
Config
Options
Rules ()
Logger
SessionLoadingOptions
Plugin Config
FilePath -> IO FilePath
Maybe Config -> Action IdeGhcSession -> IdeOptions
argsGetHieDbLoc :: FilePath -> IO FilePath
argsDefaultHlsConfig :: Config
argsLspOptions :: Options
argsIdeOptions :: Maybe Config -> Action IdeGhcSession -> IdeOptions
argsSessionLoadingOptions :: SessionLoadingOptions
argsGhcidePlugin :: Plugin Config
argsHlsPlugins :: IdePlugins IdeState
argsRules :: Rules ()
argsLogger :: Logger
argFiles :: Maybe [FilePath]
argsOTMemoryProfiling :: Bool
argsGetHieDbLoc :: Arguments -> FilePath -> IO FilePath
argsDefaultHlsConfig :: Arguments -> Config
argsLspOptions :: Arguments -> Options
argsIdeOptions :: Arguments -> Maybe Config -> Action IdeGhcSession -> IdeOptions
argsSessionLoadingOptions :: Arguments -> SessionLoadingOptions
argsGhcidePlugin :: Arguments -> Plugin Config
argsHlsPlugins :: Arguments -> IdePlugins IdeState
argsRules :: Arguments -> Rules ()
argsLogger :: Arguments -> Logger
argFiles :: Arguments -> Maybe [FilePath]
argsOTMemoryProfiling :: Arguments -> Bool
..} = do
    Text
pid <- FilePath -> Text
T.pack (FilePath -> Text) -> (Int -> FilePath) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> Text) -> IO Int -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int
getProcessID

    let hlsPlugin :: Plugin Config
hlsPlugin = Config -> IdePlugins IdeState -> Plugin Config
asGhcIdePlugin Config
argsDefaultHlsConfig IdePlugins IdeState
argsHlsPlugins
        hlsCommands :: [Text]
hlsCommands = Text -> IdePlugins IdeState -> [Text]
forall ideState. Text -> IdePlugins ideState -> [Text]
allLspCmdIds' Text
pid IdePlugins IdeState
argsHlsPlugins
        plugins :: Plugin Config
plugins = Plugin Config
hlsPlugin Plugin Config -> Plugin Config -> Plugin Config
forall a. Semigroup a => a -> a -> a
<> Plugin Config
argsGhcidePlugin
        options :: Options
options = Options
argsLspOptions { executeCommandCommands :: Maybe [Text]
LSP.executeCommandCommands = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text]
hlsCommands }
        argsOnConfigChange :: p -> Value -> f (Either Text Config)
argsOnConfigChange p
_ide = Either Text Config -> f (Either Text Config)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Config -> f (Either Text Config))
-> (Value -> Either Text Config) -> Value -> f (Either Text Config)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Value -> Either Text Config
getConfigFromNotification Config
argsDefaultHlsConfig
        rules :: Rules ()
rules = Rules ()
argsRules Rules () -> Rules () -> Rules ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Plugin Config -> Rules ()
forall c. Plugin c -> Rules ()
pluginRules Plugin Config
plugins

    case Maybe [FilePath]
argFiles of
        Maybe [FilePath]
Nothing -> do
            IO Seconds
t <- IO (IO Seconds)
offsetTime
            Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
"Starting LSP server..."
            Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
"If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
            Options
-> (FilePath -> IO FilePath)
-> (IdeState -> Value -> IO (Either Text Config))
-> Handlers (ServerM Config)
-> (LanguageContextEnv Config
    -> VFSHandle
    -> Maybe FilePath
    -> HieDb
    -> IndexQueue
    -> IO IdeState)
-> IO ()
forall config.
Show config =>
Options
-> (FilePath -> IO FilePath)
-> (IdeState -> Value -> IO (Either Text config))
-> Handlers (ServerM config)
-> (LanguageContextEnv config
    -> VFSHandle
    -> Maybe FilePath
    -> HieDb
    -> IndexQueue
    -> IO IdeState)
-> IO ()
runLanguageServer Options
options FilePath -> IO FilePath
argsGetHieDbLoc IdeState -> Value -> IO (Either Text Config)
forall (f :: * -> *) p.
Applicative f =>
p -> Value -> f (Either Text Config)
argsOnConfigChange (Plugin Config -> Handlers (ServerM Config)
forall c. Plugin c -> Handlers (ServerM c)
pluginHandlers Plugin Config
plugins) ((LanguageContextEnv Config
  -> VFSHandle
  -> Maybe FilePath
  -> HieDb
  -> IndexQueue
  -> IO IdeState)
 -> IO ())
-> (LanguageContextEnv Config
    -> VFSHandle
    -> Maybe FilePath
    -> HieDb
    -> IndexQueue
    -> IO IdeState)
-> IO ()
forall a b. (a -> b) -> a -> b
$ \LanguageContextEnv Config
env VFSHandle
vfs Maybe FilePath
rootPath HieDb
hiedb IndexQueue
hieChan -> do
                Seconds
t <- IO Seconds
t
                Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Started LSP server in " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Seconds -> FilePath
showDuration Seconds
t

                FilePath
dir <- IO FilePath
IO.getCurrentDirectory

                -- We want to set the global DynFlags right now, so that we can use

                -- `unsafeGlobalDynFlags` even before the project is configured

                -- We do it here since haskell-lsp changes our working directory to the correct place ('rootPath')

                -- before calling this function

                Maybe LibDir
_mlibdir <-
                    SessionLoadingOptions -> IO (Maybe LibDir)
setInitialDynFlags SessionLoadingOptions
argsSessionLoadingOptions
                        IO (Maybe LibDir)
-> (SomeException -> IO (Maybe LibDir)) -> IO (Maybe LibDir)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
`catchAny` (\SomeException
e -> (Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"setInitialDynFlags: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall e. Exception e => e -> FilePath
displayException SomeException
e) IO () -> IO (Maybe LibDir) -> IO (Maybe LibDir)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe LibDir -> IO (Maybe LibDir)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LibDir
forall a. Maybe a
Nothing)

                Action IdeGhcSession
sessionLoader <- SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession)
loadSessionWithOptions SessionLoadingOptions
argsSessionLoadingOptions (FilePath -> IO (Action IdeGhcSession))
-> FilePath -> IO (Action IdeGhcSession)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
dir Maybe FilePath
rootPath
                Maybe Config
config <- LanguageContextEnv Config
-> LspT Config IO (Maybe Config) -> IO (Maybe Config)
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env LspT Config IO (Maybe Config)
forall config (m :: * -> *). MonadLsp config m => m (Maybe config)
LSP.getConfig
                let options :: IdeOptions
options = (Maybe Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions Maybe Config
config Action IdeGhcSession
sessionLoader)
                            { optReportProgress :: IdeReportProgress
optReportProgress = ClientCapabilities -> IdeReportProgress
clientSupportsProgress ClientCapabilities
caps
                            }
                    caps :: ClientCapabilities
caps = LanguageContextEnv Config -> ClientCapabilities
forall config. LanguageContextEnv config -> ClientCapabilities
LSP.resClientCapabilities LanguageContextEnv Config
env
                Debouncer NormalizedUri
debouncer <- IO (Debouncer NormalizedUri)
forall k. (Eq k, Hashable k) => IO (Debouncer k)
newAsyncDebouncer
                Config
-> Rules ()
-> Maybe (LanguageContextEnv Config)
-> Logger
-> Debouncer NormalizedUri
-> IdeOptions
-> VFSHandle
-> HieDb
-> IndexQueue
-> IO IdeState
initialise
                    Config
argsDefaultHlsConfig
                    Rules ()
rules
                    (LanguageContextEnv Config -> Maybe (LanguageContextEnv Config)
forall a. a -> Maybe a
Just LanguageContextEnv Config
env)
                    Logger
argsLogger
                    Debouncer NormalizedUri
debouncer
                    IdeOptions
options
                    VFSHandle
vfs
                    HieDb
hiedb
                    IndexQueue
hieChan
        Just [FilePath]
argFiles -> do
          FilePath
dir <- IO FilePath
IO.getCurrentDirectory
          FilePath
dbLoc <- FilePath -> IO FilePath
getHieDbLoc FilePath
dir
          FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO ()
runWithDb FilePath
dbLoc ((HieDb -> IndexQueue -> IO ()) -> IO ())
-> (HieDb -> IndexQueue -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HieDb
hiedb IndexQueue
hieChan -> do
            -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error

            Handle -> TextEncoding -> IO ()
hSetEncoding Handle
stdout TextEncoding
utf8
            Handle -> TextEncoding -> IO ()
hSetEncoding Handle
stderr TextEncoding
utf8

            FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"ghcide setup tester in " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
dir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"."
            FilePath -> IO ()
putStrLn FilePath
"Report bugs at https://github.com/haskell/haskell-language-server/issues"

            FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"\nStep 1/4: Finding files to test in " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
dir
            [FilePath]
files <- [FilePath] -> IO [FilePath]
expandFiles ([FilePath]
argFiles [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"." | [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
argFiles])
            -- LSP works with absolute file paths, so try and behave similarly

            [FilePath]
files <- [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
nubOrd ([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 :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO FilePath
IO.canonicalizePath [FilePath]
files
            FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Found " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show ([FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
files) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" files"

            FilePath -> IO ()
putStrLn FilePath
"\nStep 2/4: Looking for hie.yaml files that control setup"
            [Maybe FilePath]
cradles <- (FilePath -> IO (Maybe FilePath))
-> [FilePath] -> IO [Maybe FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO (Maybe FilePath)
findCradle [FilePath]
files
            let ucradles :: [Maybe FilePath]
ucradles = [Maybe FilePath] -> [Maybe FilePath]
forall a. Ord a => [a] -> [a]
nubOrd [Maybe FilePath]
cradles
            let n :: Int
n = [Maybe FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe FilePath]
ucradles
            FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Found " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" cradle" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [Char
's' | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1]
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"  (" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " ([Maybe FilePath] -> [FilePath]
forall a. [Maybe a] -> [a]
catMaybes [Maybe FilePath]
ucradles) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")"
            FilePath -> IO ()
putStrLn FilePath
"\nStep 3/4: Initializing the IDE"
            VFSHandle
vfs <- IO VFSHandle
makeVFSHandle
            Debouncer NormalizedUri
debouncer <- IO (Debouncer NormalizedUri)
forall k. (Eq k, Hashable k) => IO (Debouncer k)
newAsyncDebouncer
            Action IdeGhcSession
sessionLoader <- SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession)
loadSessionWithOptions SessionLoadingOptions
argsSessionLoadingOptions FilePath
dir
            let options :: IdeOptions
options = (Maybe Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions Maybe Config
forall a. Maybe a
Nothing Action IdeGhcSession
sessionLoader)
                        { optCheckParents :: IO CheckParents
optCheckParents = CheckParents -> IO CheckParents
forall (f :: * -> *) a. Applicative f => a -> f a
pure CheckParents
NeverCheck
                        , optCheckProject :: IO Bool
optCheckProject = Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                        }
            IdeState
ide <- Config
-> Rules ()
-> Maybe (LanguageContextEnv Config)
-> Logger
-> Debouncer NormalizedUri
-> IdeOptions
-> VFSHandle
-> HieDb
-> IndexQueue
-> IO IdeState
initialise Config
argsDefaultHlsConfig Rules ()
rules Maybe (LanguageContextEnv Config)
forall a. Maybe a
Nothing Logger
argsLogger Debouncer NormalizedUri
debouncer IdeOptions
options VFSHandle
vfs HieDb
hiedb IndexQueue
hieChan

            FilePath -> IO ()
putStrLn FilePath
"\nStep 4/4: Type checking the files"
            IdeState
-> HashMap NormalizedFilePath FileOfInterestStatus -> IO ()
setFilesOfInterest IdeState
ide (HashMap NormalizedFilePath FileOfInterestStatus -> IO ())
-> HashMap NormalizedFilePath FileOfInterestStatus -> IO ()
forall a b. (a -> b) -> a -> b
$ [(NormalizedFilePath, FileOfInterestStatus)]
-> HashMap NormalizedFilePath FileOfInterestStatus
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(NormalizedFilePath, FileOfInterestStatus)]
 -> HashMap NormalizedFilePath FileOfInterestStatus)
-> [(NormalizedFilePath, FileOfInterestStatus)]
-> HashMap NormalizedFilePath FileOfInterestStatus
forall a b. (a -> b) -> a -> b
$ (FilePath -> (NormalizedFilePath, FileOfInterestStatus))
-> [FilePath] -> [(NormalizedFilePath, FileOfInterestStatus)]
forall a b. (a -> b) -> [a] -> [b]
map ((,FileOfInterestStatus
OnDisk) (NormalizedFilePath -> (NormalizedFilePath, FileOfInterestStatus))
-> (FilePath -> NormalizedFilePath)
-> FilePath
-> (NormalizedFilePath, FileOfInterestStatus)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> NormalizedFilePath
toNormalizedFilePath') [FilePath]
files
            [Maybe TcModuleResult]
results <- FilePath
-> IdeState
-> Action [Maybe TcModuleResult]
-> IO [Maybe TcModuleResult]
forall a. FilePath -> IdeState -> Action a -> IO a
runAction FilePath
"User TypeCheck" IdeState
ide (Action [Maybe TcModuleResult] -> IO [Maybe TcModuleResult])
-> Action [Maybe TcModuleResult] -> IO [Maybe TcModuleResult]
forall a b. (a -> b) -> a -> b
$ TypeCheck -> [NormalizedFilePath] -> Action [Maybe TcModuleResult]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe v]
uses TypeCheck
TypeCheck ((FilePath -> NormalizedFilePath)
-> [FilePath] -> [NormalizedFilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> NormalizedFilePath
toNormalizedFilePath' [FilePath]
files)
            [Maybe HieAstResult]
_results <- FilePath
-> IdeState
-> Action [Maybe HieAstResult]
-> IO [Maybe HieAstResult]
forall a. FilePath -> IdeState -> Action a -> IO a
runAction FilePath
"GetHie" IdeState
ide (Action [Maybe HieAstResult] -> IO [Maybe HieAstResult])
-> Action [Maybe HieAstResult] -> IO [Maybe HieAstResult]
forall a b. (a -> b) -> a -> b
$ GetHieAst -> [NormalizedFilePath] -> Action [Maybe HieAstResult]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe v]
uses GetHieAst
GetHieAst ((FilePath -> NormalizedFilePath)
-> [FilePath] -> [NormalizedFilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> NormalizedFilePath
toNormalizedFilePath' [FilePath]
files)
            [Maybe ModGuts]
_results <- FilePath
-> IdeState -> Action [Maybe ModGuts] -> IO [Maybe ModGuts]
forall a. FilePath -> IdeState -> Action a -> IO a
runAction FilePath
"GenerateCore" IdeState
ide (Action [Maybe ModGuts] -> IO [Maybe ModGuts])
-> Action [Maybe ModGuts] -> IO [Maybe ModGuts]
forall a b. (a -> b) -> a -> b
$ GenerateCore -> [NormalizedFilePath] -> Action [Maybe ModGuts]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe v]
uses GenerateCore
GenerateCore ((FilePath -> NormalizedFilePath)
-> [FilePath] -> [NormalizedFilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> NormalizedFilePath
toNormalizedFilePath' [FilePath]
files)
            let ([(Bool, FilePath)]
worked, [(Bool, FilePath)]
failed) = ((Bool, FilePath) -> Bool)
-> [(Bool, FilePath)] -> ([(Bool, FilePath)], [(Bool, FilePath)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Bool, FilePath) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, FilePath)] -> ([(Bool, FilePath)], [(Bool, FilePath)]))
-> [(Bool, FilePath)] -> ([(Bool, FilePath)], [(Bool, FilePath)])
forall a b. (a -> b) -> a -> b
$ [Bool] -> [FilePath] -> [(Bool, FilePath)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Maybe TcModuleResult -> Bool) -> [Maybe TcModuleResult] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map Maybe TcModuleResult -> Bool
forall a. Maybe a -> Bool
isJust [Maybe TcModuleResult]
results) [FilePath]
files
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(Bool, FilePath)]
failed [(Bool, FilePath)] -> [(Bool, FilePath)] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                FilePath -> IO ()
putStr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"Files that failed:" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: ((Bool, FilePath) -> FilePath) -> [(Bool, FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
(++) FilePath
" * " (FilePath -> FilePath)
-> ((Bool, FilePath) -> FilePath) -> (Bool, FilePath) -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, FilePath) -> FilePath
forall a b. (a, b) -> b
snd) [(Bool, FilePath)]
failed

            let nfiles :: t a -> FilePath
nfiles t a
xs = let n :: Int
n = t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
xs in if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then FilePath
"1 file" else Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" files"
            FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"\nCompleted (" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [(Bool, FilePath)] -> FilePath
forall (t :: * -> *) a. Foldable t => t a -> FilePath
nfiles [(Bool, FilePath)]
worked FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" worked, " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [(Bool, FilePath)] -> FilePath
forall (t :: * -> *) a. Foldable t => t a -> FilePath
nfiles [(Bool, FilePath)]
failed FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" failed)"

            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
argsOTMemoryProfiling (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                let valuesRef :: Var Values
valuesRef = ShakeExtras -> Var Values
state (ShakeExtras -> Var Values) -> ShakeExtras -> Var Values
forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeExtras
shakeExtras IdeState
ide
                Values
values <- Var Values -> IO Values
forall a. Var a -> IO a
readVar Var Values
valuesRef
                let consoleObserver :: Maybe a -> m (Int -> t)
consoleObserver Maybe a
Nothing = (Int -> t) -> m (Int -> t)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int -> t) -> m (Int -> t)) -> (Int -> t) -> m (Int -> t)
forall a b. (a -> b) -> a -> b
$ \Int
size -> FilePath -> Seconds -> t
forall r. PrintfType r => FilePath -> r
printf FilePath
"Total: %.2fMB\n" (Int -> Seconds
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Double Int
size Seconds -> Seconds -> Seconds
forall a. Fractional a => a -> a -> a
/ Seconds
1e6)
                    consoleObserver (Just a
k) = (Int -> t) -> m (Int -> t)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int -> t) -> m (Int -> t)) -> (Int -> t) -> m (Int -> t)
forall a b. (a -> b) -> a -> b
$ \Int
size -> FilePath -> FilePath -> Seconds -> t
forall r. PrintfType r => FilePath -> r
printf FilePath
"  - %s: %.2fKB\n" (a -> FilePath
forall a. Show a => a -> FilePath
show a
k) (Int -> Seconds
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Double Int
size Seconds -> Seconds -> Seconds
forall a. Fractional a => a -> a -> a
/ Seconds
1e3)

                FilePath -> Int -> IO ()
forall r. PrintfType r => FilePath -> r
printf FilePath
"# Shake value store contents(%d):\n" (Values -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Values
values)
                let keys :: [Key]
keys =
                        [Key] -> [Key]
forall a. Eq a => [a] -> [a]
nub ([Key] -> [Key]) -> [Key] -> [Key]
forall a b. (a -> b) -> a -> b
$
                            GhcSession -> Key
forall k. (Typeable k, Hashable k, Eq k, Show k) => k -> Key
Key GhcSession
GhcSession Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
:
                            GhcSessionDeps -> Key
forall k. (Typeable k, Hashable k, Eq k, Show k) => k -> Key
Key GhcSessionDeps
GhcSessionDeps Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
:
                            [Key
k | (NormalizedFilePath
_, Key
k) <- Values -> [(NormalizedFilePath, Key)]
forall k v. HashMap k v -> [k]
HashMap.keys Values
values, Key
k Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
/= GhcSessionIO -> Key
forall k. (Typeable k, Hashable k, Eq k, Show k) => k -> Key
Key GhcSessionIO
GhcSessionIO]
                            [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
++ [GhcSessionIO -> Key
forall k. (Typeable k, Hashable k, Eq k, Show k) => k -> Key
Key GhcSessionIO
GhcSessionIO]
                Logger
-> [[Key]]
-> (Maybe Key -> IO (Int -> IO ()))
-> Var Values
-> IO ()
measureMemory Logger
argsLogger [[Key]
keys] Maybe Key -> IO (Int -> IO ())
forall (m :: * -> *) t a.
(Monad m, PrintfType t, Show a) =>
Maybe a -> m (Int -> t)
consoleObserver Var Values
valuesRef

            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Bool, FilePath)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Bool, FilePath)]
failed) (ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure ([(Bool, FilePath)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, FilePath)]
failed))
{-# ANN defaultMain ("HLint: ignore Use nubOrd" :: String) #-}

expandFiles :: [FilePath] -> IO [FilePath]
expandFiles :: [FilePath] -> IO [FilePath]
expandFiles = (FilePath -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ((FilePath -> IO [FilePath]) -> [FilePath] -> IO [FilePath])
-> (FilePath -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ \FilePath
x -> do
    Bool
b <- FilePath -> IO Bool
IO.doesFileExist FilePath
x
    if Bool
b
        then [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
x]
        else do
            let recurse :: FilePath -> Bool
recurse FilePath
"." = Bool
True
                recurse FilePath
x | FilePath
"." FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath -> FilePath
takeFileName FilePath
x = Bool
False -- skip .git etc

                recurse FilePath
x = FilePath -> FilePath
takeFileName FilePath
x FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FilePath
"dist", FilePath
"dist-newstyle"] -- cabal directories

            [FilePath]
files <- (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (\FilePath
x -> FilePath -> FilePath
takeExtension FilePath
x FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
".hs", FilePath
".lhs"]) ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO Bool) -> FilePath -> IO [FilePath]
IO.listFilesInside (Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> (FilePath -> Bool) -> FilePath -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
recurse) FilePath
x
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
files) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                FilePath -> IO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Couldn't find any .hs/.lhs files inside directory: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x
            [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath]
files