-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE CPP #-} -- To get precise GHC version
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

module Ide.Main(defaultMain, runLspMode) where

import Control.Concurrent.Extra
import Control.Monad.Extra
import Data.Default
import Data.List.Extra
import qualified Data.Map.Strict as Map
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Development.IDE.Core.Debouncer
import Development.IDE.Core.FileStore
import Development.IDE.Core.OfInterest
import Development.IDE.Core.RuleTypes
import Development.IDE.Core.Rules
import Development.IDE.Core.Service
import Development.IDE.Core.Shake
import Development.IDE.LSP.LanguageServer
import Development.IDE.LSP.Protocol
import Development.IDE.Plugin
import Development.IDE.Plugin.HLS
import Development.IDE.Session (loadSession, findCradle, defaultLoadingOptions)
import Development.IDE.Types.Diagnostics
import Development.IDE.Types.Location
import Development.IDE.Types.Logger as G
import Development.IDE.Types.Options
import qualified Language.Haskell.LSP.Core as LSP
import Ide.Arguments
import Ide.Logger
import Ide.Version
import Ide.Plugin.Config
import Ide.PluginUtils
import Ide.Types (IdePlugins, ipMap)
import Language.Haskell.LSP.Messages
import Language.Haskell.LSP.Types
import qualified System.Directory.Extra as IO
import System.Exit
import System.FilePath
import System.IO
import qualified System.Log.Logger as L
import System.Time.Extra
import Development.Shake (action)

ghcIdePlugins :: T.Text -> IdePlugins IdeState -> (Plugin Config, [T.Text])
ghcIdePlugins :: Text -> IdePlugins IdeState -> (Plugin Config, [Text])
ghcIdePlugins Text
pid IdePlugins IdeState
ps = (IdePlugins IdeState -> Plugin Config
asGhcIdePlugin IdePlugins IdeState
ps, Text -> IdePlugins IdeState -> [Text]
forall ideState. Text -> IdePlugins ideState -> [Text]
allLspCmdIds' Text
pid IdePlugins IdeState
ps)

defaultMain :: Arguments -> IdePlugins IdeState -> IO ()
defaultMain :: Arguments -> IdePlugins IdeState -> IO ()
defaultMain Arguments
args IdePlugins IdeState
idePlugins = do
    -- WARNING: If you write to stdout before runLanguageServer
    --          then the language server will not work

    String
hlsVer <- IO String
haskellLanguageServerVersion
    case Arguments
args of
        Arguments
ProbeToolsMode -> do
            ProgramsOfInterest
programsOfInterest <- IO ProgramsOfInterest
findProgramVersions
            String -> IO ()
putStrLn String
hlsVer
            String -> IO ()
putStrLn String
"Tool versions found on the $PATH"
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ProgramsOfInterest -> String
showProgramVersionOfInterest ProgramsOfInterest
programsOfInterest

        VersionMode PrintVersion
PrintVersion ->
            String -> IO ()
putStrLn String
hlsVer

        VersionMode PrintVersion
PrintNumericVersion ->
            String -> IO ()
putStrLn String
haskellLanguageServerNumericVersion

        LspMode LspArguments
lspArgs -> do
            {- see WARNING above -}
            Handle -> String -> IO ()
hPutStrLn Handle
stderr String
hlsVer
            LspArguments -> IdePlugins IdeState -> IO ()
runLspMode LspArguments
lspArgs IdePlugins IdeState
idePlugins

-- ---------------------------------------------------------------------

hlsLogger :: G.Logger
hlsLogger :: Logger
hlsLogger = (Priority -> Text -> IO ()) -> Logger
G.Logger ((Priority -> Text -> IO ()) -> Logger)
-> (Priority -> Text -> IO ()) -> Logger
forall a b. (a -> b) -> a -> b
$ \Priority
pri Text
txt ->
    case Priority
pri of
      Priority
G.Telemetry -> String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm     (Text -> String
T.unpack Text
txt)
      Priority
G.Debug     -> String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugm   (Text -> String
T.unpack Text
txt)
      Priority
G.Info      -> String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm     (Text -> String
T.unpack Text
txt)
      Priority
G.Warning   -> String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
warningm (Text -> String
T.unpack Text
txt)
      Priority
G.Error     -> String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
errorm   (Text -> String
T.unpack Text
txt)

-- ---------------------------------------------------------------------

runLspMode :: LspArguments -> IdePlugins IdeState -> IO ()
runLspMode :: LspArguments -> IdePlugins IdeState -> IO ()
runLspMode lspArgs :: LspArguments
lspArgs@LspArguments{Bool
Int
[String]
Maybe String
argsProjectGhcVersion :: LspArguments -> Bool
argsThreads :: LspArguments -> Int
argsLogFile :: LspArguments -> Maybe String
argsDebugOn :: LspArguments -> Bool
argsExamplePlugin :: LspArguments -> Bool
argsTesting :: LspArguments -> Bool
argsShakeProfiling :: LspArguments -> Maybe String
argFiles :: LspArguments -> [String]
argsCwd :: LspArguments -> Maybe String
argLSP :: LspArguments -> Bool
argsProjectGhcVersion :: Bool
argsThreads :: Int
argsLogFile :: Maybe String
argsDebugOn :: Bool
argsExamplePlugin :: Bool
argsTesting :: Bool
argsShakeProfiling :: Maybe String
argFiles :: [String]
argsCwd :: Maybe String
argLSP :: Bool
..} IdePlugins IdeState
idePlugins = do
    Maybe String -> [String] -> Priority -> IO ()
LSP.setupLogger Maybe String
argsLogFile [String
"hls", String
"hie-bios"]
      (Priority -> IO ()) -> Priority -> IO ()
forall a b. (a -> b) -> a -> b
$ if Bool
argsDebugOn then Priority
L.DEBUG else Priority
L.INFO

    -- lock to avoid overlapping output on stdout
    Lock
lock <- IO Lock
newLock
    let logger :: Priority -> Logger
logger Priority
p = (Priority -> Text -> IO ()) -> Logger
Logger ((Priority -> Text -> IO ()) -> Logger)
-> (Priority -> Text -> IO ()) -> Logger
forall a b. (a -> b) -> a -> b
$ \Priority
pri Text
msg -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Priority
pri Priority -> Priority -> Bool
forall a. Ord a => a -> a -> Bool
>= Priority
p) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
withLock Lock
lock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
upper (Priority -> String
forall a. Show a => a -> String
show Priority
pri) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] ") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg

    Maybe String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe String
argsCwd String -> IO ()
IO.setCurrentDirectory

    String
dir <- IO String
IO.getCurrentDirectory

    Text
pid <- String -> Text
T.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> IO Int -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int
getProcessID
    let
        (Plugin Config
plugins, [Text]
commandIds) = Text -> IdePlugins IdeState -> (Plugin Config, [Text])
ghcIdePlugins Text
pid IdePlugins IdeState
idePlugins
        options :: Options
options = Options
forall a. Default a => a
def { executeCommandCommands :: Maybe [Text]
LSP.executeCommandCommands = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text]
commandIds
                      , completionTriggerCharacters :: Maybe String
LSP.completionTriggerCharacters = String -> Maybe String
forall a. a -> Maybe a
Just String
"."
                      }

    if Bool
argLSP then do
        IO Seconds
t <- IO (IO Seconds)
offsetTime
        Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Starting (haskell-language-server)LSP server..."
        Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  with arguments: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> LspArguments -> String
forall a. Show a => a -> String
show LspArguments
lspArgs
        Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  with plugins: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [PluginId] -> String
forall a. Show a => a -> String
show (Map PluginId (PluginDescriptor IdeState) -> [PluginId]
forall k a. Map k a -> [k]
Map.keys (Map PluginId (PluginDescriptor IdeState) -> [PluginId])
-> Map PluginId (PluginDescriptor IdeState) -> [PluginId]
forall a b. (a -> b) -> a -> b
$ IdePlugins IdeState -> Map PluginId (PluginDescriptor IdeState)
forall ideState.
IdePlugins ideState -> Map PluginId (PluginDescriptor ideState)
ipMap IdePlugins IdeState
idePlugins)
        Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  in directory: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dir
        Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"

        Options
-> PartialHandlers Config
-> (InitializeRequest -> Either Text Config)
-> (DidChangeConfigurationNotification -> Either Text Config)
-> (IO LspId
    -> (FromServerMessage -> IO ())
    -> VFSHandle
    -> ClientCapabilities
    -> WithProgressFunc
    -> WithIndefiniteProgressFunc
    -> IO (Maybe Config)
    -> Maybe String
    -> IO IdeState)
-> IO ()
forall config.
Show config =>
Options
-> PartialHandlers config
-> (InitializeRequest -> Either Text config)
-> (DidChangeConfigurationNotification -> Either Text config)
-> (IO LspId
    -> (FromServerMessage -> IO ())
    -> VFSHandle
    -> ClientCapabilities
    -> WithProgressFunc
    -> WithIndefiniteProgressFunc
    -> IO (Maybe config)
    -> Maybe String
    -> IO IdeState)
-> IO ()
runLanguageServer Options
options (Plugin Config -> PartialHandlers Config
forall c. Plugin c -> PartialHandlers c
pluginHandler Plugin Config
plugins) InitializeRequest -> Either Text Config
getInitialConfig DidChangeConfigurationNotification -> Either Text Config
getConfigFromNotification ((IO LspId
  -> (FromServerMessage -> IO ())
  -> VFSHandle
  -> ClientCapabilities
  -> WithProgressFunc
  -> WithIndefiniteProgressFunc
  -> IO (Maybe Config)
  -> Maybe String
  -> IO IdeState)
 -> IO ())
-> (IO LspId
    -> (FromServerMessage -> IO ())
    -> VFSHandle
    -> ClientCapabilities
    -> WithProgressFunc
    -> WithIndefiniteProgressFunc
    -> IO (Maybe Config)
    -> Maybe String
    -> IO IdeState)
-> IO ()
forall a b. (a -> b) -> a -> b
$ \IO LspId
getLspId FromServerMessage -> IO ()
event VFSHandle
vfs ClientCapabilities
caps WithProgressFunc
wProg WithIndefiniteProgressFunc
wIndefProg IO (Maybe Config)
_getConfig Maybe String
_rootPath -> do
            Seconds
t <- IO Seconds
t
            Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Started LSP server in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Seconds -> String
showDuration Seconds
t
            Action IdeGhcSession
sessionLoader <- String -> IO (Action IdeGhcSession)
loadSession String
dir
            -- config <- fromMaybe defaultLspConfig <$> getConfig
            let options :: IdeOptions
options = (Action IdeGhcSession -> IdeOptions
defaultIdeOptions Action IdeGhcSession
sessionLoader)
                    { optReportProgress :: IdeReportProgress
optReportProgress = ClientCapabilities -> IdeReportProgress
clientSupportsProgress ClientCapabilities
caps
                    , optShakeProfiling :: Maybe String
optShakeProfiling = Maybe String
argsShakeProfiling
                    , optTesting :: IdeTesting
optTesting        = Bool -> IdeTesting
IdeTesting Bool
argsTesting
                    , optThreads :: Int
optThreads        = Int
argsThreads
                    -- , optCheckParents   = checkParents config
                    -- , optCheckProject   = checkProject config
                    }
            Debouncer NormalizedUri
debouncer <- IO (Debouncer NormalizedUri)
forall k. (Eq k, Hashable k) => IO (Debouncer k)
newAsyncDebouncer
            ClientCapabilities
-> Rules ()
-> IO LspId
-> (FromServerMessage -> IO ())
-> WithProgressFunc
-> WithIndefiniteProgressFunc
-> Logger
-> Debouncer NormalizedUri
-> IdeOptions
-> VFSHandle
-> IO IdeState
initialise ClientCapabilities
caps (Rules ()
mainRule 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 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)
                IO LspId
getLspId FromServerMessage -> IO ()
event WithProgressFunc
wProg WithIndefiniteProgressFunc
wIndefProg Logger
hlsLogger Debouncer NormalizedUri
debouncer IdeOptions
options VFSHandle
vfs
    else 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

        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"(haskell-language-server)Ghcide setup tester in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
        String -> IO ()
putStrLn String
"Report bugs at https://github.com/haskell/haskell-language-server/issues"
        ProgramsOfInterest
programsOfInterest <- IO ProgramsOfInterest
findProgramVersions
        String -> IO ()
putStrLn String
""
        String -> IO ()
putStrLn String
"Tool versions found on the $PATH"
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ProgramsOfInterest -> String
showProgramVersionOfInterest ProgramsOfInterest
programsOfInterest

        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\nStep 1/4: Finding files to test in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dir
        [String]
files <- [String] -> IO [String]
expandFiles ([String]
argFiles [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"." | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
argFiles])
        -- LSP works with absolute file paths, so try and behave similarly
        [String]
files <- [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO String) -> [String] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO String
IO.canonicalizePath [String]
files
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
files) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" files"

        String -> IO ()
putStrLn String
"\nStep 2/4: Looking for hie.yaml files that control setup"
        [Maybe String]
cradles <- (String -> IO (Maybe String)) -> [String] -> IO [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SessionLoadingOptions -> String -> IO (Maybe String)
findCradle SessionLoadingOptions
defaultLoadingOptions) [String]
files
        let ucradles :: [Maybe String]
ucradles = [Maybe String] -> [Maybe String]
forall a. Ord a => [a] -> [a]
nubOrd [Maybe String]
cradles
        let n :: Int
n = [Maybe String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe String]
ucradles
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" cradle" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
's' | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1]
        String -> IO ()
putStrLn String
"\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
        let dummyWithProg :: p -> p -> ((b -> f ()) -> t) -> t
dummyWithProg p
_ p
_ (b -> f ()) -> t
f = (b -> f ()) -> t
f (f () -> b -> f ()
forall a b. a -> b -> a
const (() -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
        Action IdeGhcSession
sessionLoader <- String -> IO (Action IdeGhcSession)
loadSession String
dir
        IdeState
ide <- ClientCapabilities
-> Rules ()
-> IO LspId
-> (FromServerMessage -> IO ())
-> WithProgressFunc
-> WithIndefiniteProgressFunc
-> Logger
-> Debouncer NormalizedUri
-> IdeOptions
-> VFSHandle
-> IO IdeState
initialise ClientCapabilities
forall a. Default a => a
def Rules ()
mainRule (LspId -> IO LspId
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LspId -> IO LspId) -> LspId -> IO LspId
forall a b. (a -> b) -> a -> b
$ Int -> LspId
IdInt Int
0) (Lock -> FromServerMessage -> IO ()
showEvent Lock
lock) WithProgressFunc
forall (f :: * -> *) p p b t.
Applicative f =>
p -> p -> ((b -> f ()) -> t) -> t
dummyWithProg ((ProgressCancellable -> IO a -> IO a)
-> Text -> ProgressCancellable -> IO a -> IO a
forall a b. a -> b -> a
const ((IO a -> IO a) -> ProgressCancellable -> IO a -> IO a
forall a b. a -> b -> a
const IO a -> IO a
forall a. a -> a
id)) (Priority -> Logger
logger Priority
Info)     Debouncer NormalizedUri
debouncer (Action IdeGhcSession -> IdeOptions
defaultIdeOptions Action IdeGhcSession
sessionLoader) VFSHandle
vfs

        String -> IO ()
putStrLn String
"\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
$ (String -> (NormalizedFilePath, FileOfInterestStatus))
-> [String] -> [(NormalizedFilePath, FileOfInterestStatus)]
forall a b. (a -> b) -> [a] -> [b]
map ((, FileOfInterestStatus
OnDisk) (NormalizedFilePath -> (NormalizedFilePath, FileOfInterestStatus))
-> (String -> NormalizedFilePath)
-> String
-> (NormalizedFilePath, FileOfInterestStatus)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NormalizedFilePath
toNormalizedFilePath') [String]
files
        [Maybe TcModuleResult]
results <- String
-> IdeState
-> Action [Maybe TcModuleResult]
-> IO [Maybe TcModuleResult]
forall a. String -> IdeState -> Action a -> IO a
runAction String
"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 ((String -> NormalizedFilePath) -> [String] -> [NormalizedFilePath]
forall a b. (a -> b) -> [a] -> [b]
map String -> NormalizedFilePath
toNormalizedFilePath' [String]
files)
        let ([(Bool, String)]
worked, [(Bool, String)]
failed) = ((Bool, String) -> Bool)
-> [(Bool, String)] -> ([(Bool, String)], [(Bool, String)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Bool, String) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, String)] -> ([(Bool, String)], [(Bool, String)]))
-> [(Bool, String)] -> ([(Bool, String)], [(Bool, String)])
forall a b. (a -> b) -> a -> b
$ [Bool] -> [String] -> [(Bool, String)]
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) [String]
files
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(Bool, String)]
failed [(Bool, String)] -> [(Bool, String)] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"Files that failed:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((Bool, String) -> String) -> [(Bool, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
forall a. [a] -> [a] -> [a]
(++) String
" * " (String -> String)
-> ((Bool, String) -> String) -> (Bool, String) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, String) -> String
forall a b. (a, b) -> b
snd) [(Bool, String)]
failed

        let files :: t a -> String
files 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 String
"1 file" else Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" files"
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\nCompleted (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(Bool, String)] -> String
forall (t :: * -> *) a. Foldable t => t a -> String
files [(Bool, String)]
worked String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" worked, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(Bool, String)] -> String
forall (t :: * -> *) a. Foldable t => t a -> String
files [(Bool, String)]
failed String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" failed)"
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Bool, String)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Bool, String)]
failed) (ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure ([(Bool, String)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, String)]
failed))

expandFiles :: [FilePath] -> IO [FilePath]
expandFiles :: [String] -> IO [String]
expandFiles = (String -> IO [String]) -> [String] -> IO [String]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ((String -> IO [String]) -> [String] -> IO [String])
-> (String -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ \String
x -> do
    Bool
b <- String -> IO Bool
IO.doesFileExist String
x
    if Bool
b then [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
x] else do
        let recurse :: String -> Bool
recurse String
"." = Bool
True
            recurse String
x | String
"." String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String -> String
takeFileName String
x = Bool
False -- skip .git etc
            recurse String
x = String -> String
takeFileName String
x String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
"dist",String
"dist-newstyle"] -- cabal directories
        [String]
files <- (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\String
x -> String -> String
takeExtension String
x String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".hs",String
".lhs"]) ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO Bool) -> String -> IO [String]
IO.listFilesInside (Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> (String -> Bool) -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
recurse) String
x
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
files) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Couldn't find any .hs/.lhs files inside directory: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x
        [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
files

-- | Print an LSP event.
showEvent :: Lock -> FromServerMessage -> IO ()
showEvent :: Lock -> FromServerMessage -> IO ()
showEvent Lock
_ (EventFileDiagnostics String
_ []) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
showEvent Lock
lock (EventFileDiagnostics (String -> NormalizedFilePath
toNormalizedFilePath' -> NormalizedFilePath
file) [Diagnostic]
diags) =
    Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
withLock Lock
lock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [FileDiagnostic] -> Text
showDiagnosticsColored ([FileDiagnostic] -> Text) -> [FileDiagnostic] -> Text
forall a b. (a -> b) -> a -> b
$ (Diagnostic -> FileDiagnostic) -> [Diagnostic] -> [FileDiagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (NormalizedFilePath
file,ShowDiagnostic
ShowDiag,) [Diagnostic]
diags
showEvent Lock
lock FromServerMessage
e = Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
withLock Lock
lock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FromServerMessage -> IO ()
forall a. Show a => a -> IO ()
print FromServerMessage
e