mirror of
https://github.com/haskell/ghcide.git
synced 2024-12-18 07:31:33 +03:00
e2e158a85d
* Move getFilesOfInterest into the IDE, and OfInterest out into DAML * Have the IDE mode kick all active files each time * Add a missing .cabal dependency * Add a missing dependencies * Use the right thing, if any files have parse errors, then don't worry * Print messages to stderr rather than stdout * Add a big warning that writing to stdout is a bad plan
127 lines
4.4 KiB
Haskell
127 lines
4.4 KiB
Haskell
-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
|
-- SPDX-License-Identifier: Apache-2.0
|
|
|
|
module Demo(main) where
|
|
|
|
import Control.Concurrent.Extra
|
|
import Control.Monad
|
|
import System.Time.Extra
|
|
import Development.IDE.State.FileStore
|
|
import Development.IDE.State.Service
|
|
import Development.IDE.State.Rules
|
|
import Development.IDE.State.Shake
|
|
import Development.IDE.State.RuleTypes
|
|
import Data.String
|
|
import Development.IDE.Types.Diagnostics
|
|
import Development.IDE.Types.Options
|
|
import Development.IDE.Logger
|
|
import qualified Data.Text.IO as T
|
|
import Language.Haskell.LSP.Messages
|
|
import Development.IDE.LSP.LanguageServer
|
|
import System.Environment
|
|
import Data.List
|
|
import Data.Maybe
|
|
import System.FilePath
|
|
import Data.Tuple.Extra
|
|
import System.IO.Extra
|
|
import Development.IDE.Types.LSP
|
|
import Development.Shake hiding (Env)
|
|
import qualified Data.Set as Set
|
|
|
|
import CmdLineParser
|
|
import DynFlags
|
|
import Panic
|
|
import GHC
|
|
import qualified GHC.Paths
|
|
|
|
-- Set the GHC libdir to the nix libdir if it's present.
|
|
getLibdir :: IO FilePath
|
|
getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"
|
|
|
|
main :: IO ()
|
|
main = do
|
|
-- WARNING: If you write to stdout before runLanguageServer
|
|
-- then the language server will not work
|
|
hPutStrLn stderr "Starting haskell-ide-core Demo"
|
|
(ghcOptions, map toNormalizedFilePath -> files, isIde) <- getCmdLine
|
|
|
|
-- lock to avoid overlapping output on stdout
|
|
lock <- newLock
|
|
let logger = makeOneHandle $ withLock lock . T.putStrLn
|
|
|
|
let options = IdeOptions
|
|
{optPreprocessor = (,) []
|
|
,optWriteIface = False
|
|
,optGhcSession = liftIO $ newSession ghcOptions
|
|
,optExtensions = ["hs"]
|
|
,optPkgLocationOpts = error "optPkgLocationOpts not implemented yet"
|
|
,optThreads = 0
|
|
,optShakeProfiling = Nothing -- Just "output.html"
|
|
}
|
|
|
|
if isIde then do
|
|
hPutStrLn stderr "Starting running the IDE server"
|
|
runLanguageServer logger $ \event vfs -> do
|
|
hPutStrLn stderr "Server started"
|
|
initialise (mainRule >> action kick) event logger options vfs
|
|
else do
|
|
vfs <- makeVFSHandle
|
|
ide <- initialise mainRule (showEvent lock) logger options vfs
|
|
setFilesOfInterest ide $ Set.fromList files
|
|
runAction ide kick
|
|
-- shake now writes an async message that it is completed with timing info,
|
|
-- so we sleep briefly to wait for it to have been written
|
|
sleep 0.01
|
|
putStrLn "Done"
|
|
|
|
|
|
kick :: Action ()
|
|
kick = do
|
|
files <- use_ GetFilesOfInterest $ fromString ""
|
|
void $ uses TypeCheck $ Set.toList files
|
|
|
|
-- | Print an LSP event.
|
|
showEvent :: Lock -> FromServerMessage -> IO ()
|
|
showEvent _ (EventFileDiagnostics _ []) = return ()
|
|
showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
|
|
withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,) diags
|
|
showEvent lock e = withLock lock $ print e
|
|
|
|
|
|
-- | Create a GHC session that will be subsequently reused.
|
|
newSession :: [String] -> IO HscEnv
|
|
newSession flags = getLibdir >>= \libdir -> runGhc (Just libdir) $ do
|
|
damlDFlags <- getSessionDynFlags
|
|
(dflags', leftover, warns) <- parseDynamicFlagsCmdLine damlDFlags $ map noLoc flags
|
|
|
|
let leftoverError = CmdLineError $
|
|
(unlines . ("Unable to parse custom flags:":) . map unLoc) leftover
|
|
unless (null leftover) $ liftIO $ throwGhcExceptionIO leftoverError
|
|
|
|
unless (null warns) $
|
|
liftIO $ putStrLn $ unlines $ "Warnings:" : map (unLoc . warnMsg) warns
|
|
|
|
_ <- setSessionDynFlags dflags'
|
|
getSession
|
|
|
|
|
|
-- | Convert the command line into GHC options and files to load.
|
|
getCmdLine :: IO ([String], [FilePath], Bool)
|
|
getCmdLine = do
|
|
args <- getArgs
|
|
let isIde = "--ide" `elem` args
|
|
args <- return $ delete "--ide" $ if null args then [".ghci"] else args
|
|
let (flags, files) = partition ("-" `isPrefixOf`) args
|
|
let (ghci, hs) = partition ((==) ".ghci" . takeExtension) files
|
|
(flags, files) <- both concat . unzip . ((flags,hs):) <$> mapM readGhci ghci
|
|
when (null files) $
|
|
fail "Expected some files to load, but didn't find any"
|
|
return (flags, files, isIde)
|
|
|
|
readGhci :: FilePath -> IO ([String], [FilePath])
|
|
readGhci file = do
|
|
xs <- lines <$> readFileUTF8' file
|
|
let flags = concatMap words $ mapMaybe (stripPrefix ":set ") xs
|
|
let files = concatMap words $ mapMaybe (stripPrefix ":load ") xs
|
|
return (flags, files)
|