mirror of
https://github.com/haskell/ghcide.git
synced 2024-12-18 07:31:33 +03:00
b6fd3c1a75
Ironically `managed` didn't turn out to make our code more manageable and we ended up mostly using it in very isolated places only to then immediately convert it back to bracket-style functions using `with`. This PR also removes the use of `managed` from the GcpLogger which was the only other place where we are using it and it finally kills the rather silly logic that starting up the scenario service was tied to having an event logger.
108 lines
3.4 KiB
Haskell
108 lines
3.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 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
|
|
(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)
|