@@ -3,6 +3,7 @@
33
44module Demo(main) where
55
6+import Data.Maybe
67import Control.Concurrent.Extra
78import Control.Monad
89import System.Time.Extra
@@ -18,22 +19,21 @@ import Development.IDE.Logger
1819import qualified Data.Text.IO as T
1920import Language.Haskell.LSP.Messages
2021import Development.IDE.LSP.LanguageServer
22+import System.Directory
2123import System.Environment
22−import Data.List
23−import Data.Maybe
24−import System.FilePath
25−import Data.Tuple.Extra
26−import System.IO.Extra
24+import System.IO
2725import Development.IDE.Types.LSP
2826import Development.Shake hiding (Env)
2927import qualified Data.Set as Set
3028
31−import CmdLineParser
32−import DynFlags
33−import Panic
29+-- import CmdLineParser
30+-- import DynFlags
31+-- import Panic
3432import GHC
3533import qualified GHC.Paths
3634
35+import HIE.Bios
36+
3737-- Set the GHC libdir to the nix libdir if it's present.
3838getLibdir :: IO FilePath
3939getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"
@@ -43,28 +43,34 @@ main = do
4343 -- WARNING: If you write to stdout before runLanguageServer
4444 -- then the language server will not work
4545 hPutStrLn stderr "Starting haskell-ide-core Demo"
46− (ghcOptions, map toNormalizedFilePath -> files, isIde) <- getCmdLine
46+ args <- getArgs
4747
4848 -- lock to avoid overlapping output on stdout
4949 lock <- newLock
5050 let logger = makeOneHandle $ withLock lock . T.putStrLn
5151
52+ dir <- getCurrentDirectory
53+ hPutStrLn stderr dir
54+
55+ cradle <- findCradle (dir <> "/")
56+
5257 let options = IdeOptions
5358 {optPreprocessor = (,) []
5459 ,optWriteIface = False
55− ,optGhcSession = liftIO $ newSession ghcOptions
60+ ,optGhcSession = liftIO $ newSession' cradle
5661 ,optExtensions = ["hs"]
5762 ,optPkgLocationOpts = error "optPkgLocationOpts not implemented yet"
5863 ,optThreads = 0
5964 ,optShakeProfiling = Nothing -- Just "output.html"
6065 }
6166
62− if isIde then do
63− hPutStrLn stderr "Starting running the IDE server"
67+ if "--ide" `elem` args then do
68+ hPutStrLn stderr "Starting IDE server"
6469 runLanguageServer logger $ \event vfs -> do
6570 hPutStrLn stderr "Server started"
6671 initialise (mainRule >> action kick) event logger options vfs
6772 else do
73+ let files = map toNormalizedFilePath $ filter (/= "--ide") args
6874 vfs <- makeVFSHandle
6975 ide <- initialise mainRule (showEvent lock) logger options vfs
7076 setFilesOfInterest ide $ Set.fromList files
@@ -87,40 +93,7 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
8793 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,) diags
8894showEvent lock e = withLock lock $ print e
8995
90−
91−-- | Create a GHC session that will be subsequently reused.
92−newSession :: [String] -> IO HscEnv
93−newSession flags = getLibdir >>= \libdir -> runGhc (Just libdir) $ do
94− damlDFlags <- getSessionDynFlags
95− (dflags', leftover, warns) <- parseDynamicFlagsCmdLine damlDFlags $ map noLoc flags
96−
97− let leftoverError = CmdLineError $
98− (unlines . ("Unable to parse custom flags:":) . map unLoc) leftover
99− unless (null leftover) $ liftIO $ throwGhcExceptionIO leftoverError
100−
101− unless (null warns) $
102− liftIO $ putStrLn $ unlines $ "Warnings:" : map (unLoc . warnMsg) warns
103−
104− _ <- setSessionDynFlags dflags'
96+newSession' :: Cradle -> IO HscEnv
97+newSession' cradle = getLibdir >>= \libdir -> runGhc (Just libdir) $ do
98+ initializeFlagsWithCradle "" cradle
10599 getSession
106−
107−
108−-- | Convert the command line into GHC options and files to load.
109−getCmdLine :: IO ([String], [FilePath], Bool)
110−getCmdLine = do
111− args <- getArgs
112− let isIde = "--ide" `elem` args
113− args <- return $ delete "--ide" $ if null args then [".ghci"] else args
114− let (flags, files) = partition ("-" `isPrefixOf`) args
115− let (ghci, hs) = partition ((==) ".ghci" . takeExtension) files
116− (flags, files) <- both concat . unzip . ((flags,hs):) <$> mapM readGhci ghci
117− when (null files) $
118− fail "Expected some files to load, but didn't find any"
119− return (flags, files, isIde)
120−
121−readGhci :: FilePath -> IO ([String], [FilePath])
122−readGhci file = do
123− xs <- lines <$> readFileUTF8' file
124− let flags = concatMap words $ mapMaybe (stripPrefix ":set ") xs
125− let files = concatMap words $ mapMaybe (stripPrefix ":load ") xs
126− return (flags, files)