mirror of
https://github.com/haskell/ghcide.git
synced 2024-12-18 07:31:33 +03:00
7c3213c3c5
* Use haskell-lsp’s builtin VFS in "damlc ide" haskell-lsp has a builtin VFS that it updates automatically on the corresponding requests. This PR removes our own VFS implementation and uses that builtin VFS in "damlc ide". To allow the use of functions like setBufferModified (we use that heavily in daml-ghc-shake-test-ci) without having to spawn an LSP server, we also add a fallback where we spin up our own LSP implementation.
108 lines
3.5 KiB
Haskell
108 lines
3.5 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 Development.IDE.Types.Diagnostics
|
|
import Development.IDE.Types.Options
|
|
import Development.IDE.Logger
|
|
import qualified Data.Text.IO as T
|
|
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 GHC.Paths
|
|
|
|
|
|
main :: IO ()
|
|
main = do
|
|
(ghcOptions, files) <- getCmdLine
|
|
|
|
-- lock to avoid overlapping output on stdout
|
|
lock <- newLock
|
|
|
|
vfs <- makeVFSHandle
|
|
ide <- initialise
|
|
mainRule
|
|
(Just $ showEvent lock)
|
|
(makeOneHandle $ withLock lock . T.putStrLn)
|
|
IdeOptions
|
|
{optPreprocessor = (,) []
|
|
,optWriteIface = False
|
|
,optGhcSession = liftIO $ newSession ghcOptions
|
|
,optExtensions = ["hs"]
|
|
,optPkgLocationOpts = error "optPkgLocationOpts not implemented yet"
|
|
,optThreads = 0
|
|
,optShakeProfiling = Nothing -- Just "output.html"
|
|
}
|
|
vfs
|
|
setFilesOfInterest ide $ Set.fromList files
|
|
_ <- runAction ide $ uses_ TypeCheck files
|
|
-- 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"
|
|
|
|
|
|
-- | Print an LSP event.
|
|
showEvent :: Lock -> Event -> IO ()
|
|
showEvent _ (EventFileDiagnostics (_, [])) = return ()
|
|
showEvent lock (EventFileDiagnostics (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 = 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])
|
|
getCmdLine = do
|
|
args <- getArgs
|
|
args <- return $ 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)
|
|
|
|
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)
|