From 1be84f1a237b8c03265abb4fbf97d9a98c0ec959 Mon Sep 17 00:00:00 2001 From: Moritz Kiefer Date: Sat, 15 Jun 2019 10:29:40 +0200 Subject: [PATCH] Initial stab at integrating hie-bios (#1685) --- BUILD.bazel | 2 ++ haskell-ide-core.cabal | 2 ++ stack.yaml | 4 +++ test/Demo.hs | 69 +++++++++++++----------------------------- 4 files changed, 29 insertions(+), 48 deletions(-) diff --git a/BUILD.bazel b/BUILD.bazel index aad05520..bc833651 100644 --- a/BUILD.bazel +++ b/BUILD.bazel @@ -75,11 +75,13 @@ da_haskell_binary( hazel_deps = [ "base", "containers", + "directory", "extra", "filepath", "ghc-paths", "ghc", "haskell-lsp", + "hie-bios", "shake", "text", ], diff --git a/haskell-ide-core.cabal b/haskell-ide-core.cabal index cff202af..a37fa7dc 100644 --- a/haskell-ide-core.cabal +++ b/haskell-ide-core.cabal @@ -115,6 +115,8 @@ executable ide-demo base == 4.*, filepath, containers, + directory, + hie-bios, shake, ghc-paths, ghc, diff --git a/stack.yaml b/stack.yaml index e206745b..5f38c8fd 100644 --- a/stack.yaml +++ b/stack.yaml @@ -8,3 +8,7 @@ extra-deps: subdirs: - . - haskell-lsp-types +- git: https://github.com/mpickering/hie-bios.git + commit: 9f9fe00591c429c410475349560252ca7e622f1b +nix: + packages: [zlib] diff --git a/test/Demo.hs b/test/Demo.hs index 3b7a7ee8..43e0c2ac 100644 --- a/test/Demo.hs +++ b/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)