mirror of
https://github.com/haskell/ghcide.git
synced 2024-10-26 14:08:12 +03:00
Initial stab at integrating hie-bios (#1685)
This commit is contained in:
parent
e823c5d431
commit
1be84f1a23
@ -75,11 +75,13 @@ da_haskell_binary(
|
||||
hazel_deps = [
|
||||
"base",
|
||||
"containers",
|
||||
"directory",
|
||||
"extra",
|
||||
"filepath",
|
||||
"ghc-paths",
|
||||
"ghc",
|
||||
"haskell-lsp",
|
||||
"hie-bios",
|
||||
"shake",
|
||||
"text",
|
||||
],
|
||||
|
@ -115,6 +115,8 @@ executable ide-demo
|
||||
base == 4.*,
|
||||
filepath,
|
||||
containers,
|
||||
directory,
|
||||
hie-bios,
|
||||
shake,
|
||||
ghc-paths,
|
||||
ghc,
|
||||
|
@ -8,3 +8,7 @@ extra-deps:
|
||||
subdirs:
|
||||
- .
|
||||
- haskell-lsp-types
|
||||
- git: https://github.com/mpickering/hie-bios.git
|
||||
commit: 9f9fe00591c429c410475349560252ca7e622f1b
|
||||
nix:
|
||||
packages: [zlib]
|
||||
|
69
test/Demo.hs
69
test/Demo.hs
@ -3,6 +3,7 @@
|
||||
|
||||
module Demo(main) where
|
||||
|
||||
import Data.Maybe
|
||||
import Control.Concurrent.Extra
|
||||
import Control.Monad
|
||||
import System.Time.Extra
|
||||
@ -18,22 +19,21 @@ import Development.IDE.Logger
|
||||
import qualified Data.Text.IO as T
|
||||
import Language.Haskell.LSP.Messages
|
||||
import Development.IDE.LSP.LanguageServer
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import System.FilePath
|
||||
import Data.Tuple.Extra
|
||||
import System.IO.Extra
|
||||
import System.IO
|
||||
import Development.IDE.Types.LSP
|
||||
import Development.Shake hiding (Env)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import CmdLineParser
|
||||
import DynFlags
|
||||
import Panic
|
||||
-- import CmdLineParser
|
||||
-- import DynFlags
|
||||
-- import Panic
|
||||
import GHC
|
||||
import qualified GHC.Paths
|
||||
|
||||
import HIE.Bios
|
||||
|
||||
-- Set the GHC libdir to the nix libdir if it's present.
|
||||
getLibdir :: IO FilePath
|
||||
getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"
|
||||
@ -43,28 +43,34 @@ 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
|
||||
args <- getArgs
|
||||
|
||||
-- lock to avoid overlapping output on stdout
|
||||
lock <- newLock
|
||||
let logger = makeOneHandle $ withLock lock . T.putStrLn
|
||||
|
||||
dir <- getCurrentDirectory
|
||||
hPutStrLn stderr dir
|
||||
|
||||
cradle <- findCradle (dir <> "/")
|
||||
|
||||
let options = IdeOptions
|
||||
{optPreprocessor = (,) []
|
||||
,optWriteIface = False
|
||||
,optGhcSession = liftIO $ newSession ghcOptions
|
||||
,optGhcSession = liftIO $ newSession' cradle
|
||||
,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"
|
||||
if "--ide" `elem` args then do
|
||||
hPutStrLn stderr "Starting IDE server"
|
||||
runLanguageServer logger $ \event vfs -> do
|
||||
hPutStrLn stderr "Server started"
|
||||
initialise (mainRule >> action kick) event logger options vfs
|
||||
else do
|
||||
let files = map toNormalizedFilePath $ filter (/= "--ide") args
|
||||
vfs <- makeVFSHandle
|
||||
ide <- initialise mainRule (showEvent lock) logger options vfs
|
||||
setFilesOfInterest ide $ Set.fromList files
|
||||
@ -87,40 +93,7 @@ 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'
|
||||
newSession' :: Cradle -> IO HscEnv
|
||||
newSession' cradle = getLibdir >>= \libdir -> runGhc (Just libdir) $ do
|
||||
initializeFlagsWithCradle "" cradle
|
||||
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)
|
||||
|
Loading…
Reference in New Issue
Block a user