00d914e · ghcide · git.iko.soy

git.iko.soy/ghcide

on master help sign in

Automatically pick up new dependencies (#408)

00d914eJinwoo Lee7 years ago

exe/Main.hs+70−22

compare with master

unifiedsplit

@@ -3,14 +3,19 @@

3{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above

4{-# LANGUAGE CPP #-} -- To get precise GHC version

5{-# LANGUAGE TemplateHaskell #-}

6+{-# LANGUAGE TypeFamilies #-}

7module Main(main) where

8module Main(main) where

9import Arguments

10import Arguments

11+import Data.Binary (Binary)

12+import Data.Dynamic (Typeable)

13+import Data.Hashable (Hashable)

10import Data.Maybe

14import Data.Maybe

11import Data.List.Extra

15import Data.List.Extra

12import System.FilePath

16import System.FilePath

13import Control.Concurrent.Extra

17import Control.Concurrent.Extra

18+import Control.DeepSeq (NFData)

14import Control.Exception

19import Control.Exception

15import Control.Monad.Extra

20import Control.Monad.Extra

16import Control.Monad.IO.Class

21import Control.Monad.IO.Class

@@ -39,20 +44,22 @@ import Language.Haskell.LSP.Types (LspId(IdInt))

39import Linker

44import Linker

40import Data.Version

45import Data.Version

41import Development.IDE.LSP.LanguageServer

46import Development.IDE.LSP.LanguageServer

42−import System.Directory.Extra as IO

47+import qualified System.Directory.Extra as IO

43import System.Environment

48import System.Environment

44import System.IO

49import System.IO

45import System.Exit

50import System.Exit

46import Paths_ghcide

51import Paths_ghcide

47import Development.GitRev

52import Development.GitRev

48−import Development.Shake (Action, action)

53+import Development.Shake (Action, RuleResult, Rules, action, doesFileExist, need)

49import qualified Data.HashSet as HashSet

54import qualified Data.HashSet as HashSet

50import qualified Data.Map.Strict as Map

55import qualified Data.Map.Strict as Map

52import GHC hiding (def)

57import GHC hiding (def)

58+import GHC.Generics (Generic)

53import qualified GHC.Paths

59import qualified GHC.Paths

55import HIE.Bios

61import HIE.Bios

62+import HIE.Bios.Cradle

56import HIE.Bios.Types

63import HIE.Bios.Types

58-- Set the GHC libdir to the nix libdir if it's present.

65-- Set the GHC libdir to the nix libdir if it's present.

@@ -84,9 +91,9 @@ main = do

84 let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $

91 let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $

85 T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg

92 T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg

87− whenJust argsCwd setCurrentDirectory

94+ whenJust argsCwd IO.setCurrentDirectory

89− dir <- getCurrentDirectory

96+ dir <- IO.getCurrentDirectory

91 let plugins = Completions.plugin <> CodeAction.plugin

98 let plugins = Completions.plugin <> CodeAction.plugin

92 onInitialConfiguration = const $ Right ()

99 onInitialConfiguration = const $ Right ()

@@ -99,14 +106,13 @@ main = do

99 runLanguageServer def (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do

106 runLanguageServer def (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do

100 t <- t

107 t <- t

101 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t

108 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t

102− -- very important we only call loadSession once, and it's fast, so just do it before starting

103− session <- loadSession dir

104− let options = (defaultIdeOptions $ return session)

109+ let options = (defaultIdeOptions $ loadSession dir)

105 { optReportProgress = clientSupportsProgress caps

110 { optReportProgress = clientSupportsProgress caps

106 , optShakeProfiling = argsShakeProfiling

111 , optShakeProfiling = argsShakeProfiling

107 }

112 }

108 debouncer <- newAsyncDebouncer

113 debouncer <- newAsyncDebouncer

114+ initialise caps (loadGhcSessionIO >> mainRule >> pluginRules plugins >> action kick)

109− initialise caps (mainRule >> pluginRules plugins >> action kick) getLspId event (logger minBound) debouncer options vfs

115+ getLspId event (logger minBound) debouncer options vfs

110 else do

116 else do

111 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."

117 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."

112 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"

118 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"

@@ -114,7 +120,7 @@ main = do

114 putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir

120 putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir

115 files <- expandFiles (argFiles ++ ["." | null argFiles])

121 files <- expandFiles (argFiles ++ ["." | null argFiles])

116 -- LSP works with absolute file paths, so try and behave similarly

122 -- LSP works with absolute file paths, so try and behave similarly

117− files <- nubOrd <$> mapM canonicalizePath files

123+ files <- nubOrd <$> mapM IO.canonicalizePath files

118 putStrLn $ "Found " ++ show (length files) ++ " files"

124 putStrLn $ "Found " ++ show (length files) ++ " files"

119

125

120 putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup"

126 putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup"

@@ -128,7 +134,8 @@ main = do

128 cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x

134 cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x

129 when (isNothing x) $ print cradle

135 when (isNothing x) $ print cradle

130 putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"

136 putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"

131− cradleToSession cradle

137+ opts <- getComponentOptions cradle

138+ createSession opts

132

139

133 putStrLn "\nStep 5/6: Initializing the IDE"

140 putStrLn "\nStep 5/6: Initializing the IDE"

134 vfs <- makeVFSHandle

141 vfs <- makeVFSHandle

@@ -141,7 +148,7 @@ main = do

141 let options =

148 let options =

142 (defaultIdeOptions $ return $ return . grab)

149 (defaultIdeOptions $ return $ return . grab)

143 { optShakeProfiling = argsShakeProfiling }

150 { optShakeProfiling = argsShakeProfiling }

144− ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs

151+ ide <- initialise def (loadGhcSessionIO >> mainRule) (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs

145

152

146 putStrLn "\nStep 6/6: Type checking the files"

153 putStrLn "\nStep 6/6: Type checking the files"

147 setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath files

154 setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath files

@@ -163,7 +170,7 @@ expandFiles = concatMapM $ \x -> do

163 let recurse "." = True

170 let recurse "." = True

164 recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc

171 recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc

165 recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories

172 recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories

166− files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> listFilesInside (return . recurse) x

173+ files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x

167 when (null files) $

174 when (null files) $

168 fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x

175 fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x

169 return files

176 return files

@@ -182,16 +189,42 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =

182showEvent lock e = withLock lock $ print e

189showEvent lock e = withLock lock $ print e

183

190

184

191

185−cradleToSession :: Cradle a -> IO HscEnvEq

192+-- Rule type for caching GHC sessions.

186−cradleToSession cradle = do

193+type instance RuleResult GetHscEnv = HscEnvEq

194+

195+data GetHscEnv = GetHscEnv

196+ { hscenvOptions :: [String] -- componentOptions from hie-bios

197+ , hscenvDependencies :: [FilePath] -- componentDependencies from hie-bios

198+ }

199+ deriving (Eq, Show, Typeable, Generic)

200+instance Hashable GetHscEnv

201+instance NFData GetHscEnv

202+instance Binary GetHscEnv

203+

204+

205+loadGhcSessionIO :: Rules ()

206+loadGhcSessionIO =

207+ -- This rule is for caching the GHC session. E.g., even when the cabal file

208+ -- changed, if the resulting flags did not change, we would continue to use

209+ -- the existing session.

210+ defineNoFile $ \(GetHscEnv opts deps) ->

211+ liftIO $ createSession $ ComponentOptions opts deps

212+

213+

214+getComponentOptions :: Cradle a -> IO ComponentOptions

215+getComponentOptions cradle = do

187 let showLine s = putStrLn ("> " ++ s)

216 let showLine s = putStrLn ("> " ++ s)

188 cradleRes <- runCradle (cradleOptsProg cradle) showLine ""

217 cradleRes <- runCradle (cradleOptsProg cradle) showLine ""

189− opts <- case cradleRes of

218+ case cradleRes of

190 CradleSuccess r -> pure r

219 CradleSuccess r -> pure r

191 CradleFail err -> throwIO err

220 CradleFail err -> throwIO err

192 -- TODO Rather than failing here, we should ignore any files that use this cradle.

221 -- TODO Rather than failing here, we should ignore any files that use this cradle.

193 -- That will require some more changes.

222 -- That will require some more changes.

194 CradleNone -> fail "'none' cradle is not yet supported"

223 CradleNone -> fail "'none' cradle is not yet supported"

224+

225+

226+createSession :: ComponentOptions -> IO HscEnvEq

227+createSession opts = do

195 libdir <- getLibdir

228 libdir <- getLibdir

196 env <- runGhc (Just libdir) $ do

229 env <- runGhc (Just libdir) $ do

197 _targets <- initSession opts

230 _targets <- initSession opts

@@ -200,19 +233,34 @@ cradleToSession cradle = do

200 newHscEnvEq env

233 newHscEnvEq env

201

234

202

235

236+cradleToSession :: Maybe FilePath -> Cradle a -> Action HscEnvEq

237+cradleToSession mbYaml cradle = do

238+ cmpOpts <- liftIO $ getComponentOptions cradle

239+ let opts = componentOptions cmpOpts

240+ deps = componentDependencies cmpOpts

241+ deps' = case mbYaml of

242+ -- For direct cradles, the hie.yaml file itself must be watched.

243+ Just yaml | isDirectCradle cradle -> yaml : deps

244+ _ -> deps

245+ existingDeps <- filterM doesFileExist deps'

246+ need existingDeps

247+ useNoFile_ $ GetHscEnv opts deps

248+

249+

203−loadSession :: FilePath -> IO (FilePath -> Action HscEnvEq)

250+loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq)

204−loadSession dir = do

251+loadSession dir = liftIO $ do

205 cradleLoc <- memoIO $ \v -> do

252 cradleLoc <- memoIO $ \v -> do

206 res <- findCradle v

253 res <- findCradle v

207 -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path

254 -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path

208 -- try and normalise that

255 -- try and normalise that

209 -- e.g. see https://github.com/digital-asset/ghcide/issues/126

256 -- e.g. see https://github.com/digital-asset/ghcide/issues/126

210− res' <- traverse makeAbsolute res

257+ res' <- traverse IO.makeAbsolute res

211 return $ normalise <$> res'

258 return $ normalise <$> res'

212− session <- memoIO $ \file -> do

259+ let session :: Maybe FilePath -> Action HscEnvEq

260+ session file = do

213− c <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file

261+ c <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file

214− cradleToSession c

262+ cradleToSession file c

215− return $ \file -> liftIO $ session =<< cradleLoc file

263+ return $ \file -> session =<< liftIO (cradleLoc file)

216

264

217

265

218-- | Memoize an IO function, with the characteristics:

266-- | Memoize an IO function, with the characteristics:

ghcide.cabal+4

@@ -169,14 +169,17 @@ executable ghcide

169 build-depends:

170 hslogger,

171 base == 4.*,

172+ binary,

172 containers,

173 containers,

173 data-default,

174 data-default,

175+ deepseq,

174 directory,

176 directory,

175 extra,

177 extra,

176 filepath,

178 filepath,

177 ghc-paths,

179 ghc-paths,

178 ghc,

180 ghc,

179 gitrev,

181 gitrev,

182+ hashable,

180 haskell-lsp,

183 haskell-lsp,

181 hie-bios >= 0.4.0 && < 0.5,

184 hie-bios >= 0.4.0 && < 0.5,

182 ghcide,

185 ghcide,

@@ -189,6 +192,7 @@ executable ghcide

189 Paths_ghcide

192 Paths_ghcide

190

193

191 default-extensions:

194 default-extensions:

195+ DeriveGeneric

192 RecordWildCards

196 RecordWildCards

193 TupleSections

197 TupleSections

194 ViewPatterns

198 ViewPatterns

src/Development/IDE/Core/Rules.hs+2−2

@@ -11,7 +11,7 @@

11--

12module Development.IDE.Core.Rules(

13 IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),

14− Priority(..),

14+ Priority(..), GhcSessionIO(..), GhcSessionFun(..),

15 priorityTypeCheck,

16 priorityGenerateCore,

17 priorityFilesOfInterest,

@@ -339,7 +339,7 @@ loadGhcSession :: Rules ()

339loadGhcSession = do

340 defineNoFile $ \GhcSessionIO -> do

341 opts <- getIdeOptions

342− liftIO $ GhcSessionFun <$> optGhcSession opts

342+ GhcSessionFun <$> optGhcSession opts

343 defineEarlyCutoff $ \GhcSession file -> do

344 GhcSessionFun fun <- useNoFile_ GhcSessionIO

345 val <- fun $ fromNormalizedFilePath file

src/Development/IDE/Types/Options.hs+3−5

@@ -25,12 +25,10 @@ data IdeOptions = IdeOptions

25 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource

26 -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings

27 -- and a list of errors, along with a new parse tree.

28− , optGhcSession :: IO (FilePath -> Action HscEnvEq)

28+ , optGhcSession :: Action (FilePath -> Action HscEnvEq)

29 -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.

30− -- The 'IO' will be called once, then the resulting function will be applied once per file.

30+ -- For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file.

31 -- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.

32− -- You should not use 'newCacheIO' to get that caching, because of

33− -- https://github.com/ndmitchell/shake/issues/725.

34 , optPkgLocationOpts :: IdePkgLocationOptions

32 , optPkgLocationOpts :: IdePkgLocationOptions

35 -- ^ How to locate source and @.hie@ files given a module name.

33 -- ^ How to locate source and @.hie@ files given a module name.

36 , optExtensions :: [String]

34 , optExtensions :: [String]

@@ -73,7 +71,7 @@ clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress

73clientSupportsProgress caps = IdeReportProgress $ fromMaybe False $

71clientSupportsProgress caps = IdeReportProgress $ fromMaybe False $

74 LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities)

72 LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities)

76−defaultIdeOptions :: IO (FilePath -> Action HscEnvEq) -> IdeOptions

74+defaultIdeOptions :: Action (FilePath -> Action HscEnvEq) -> IdeOptions

77defaultIdeOptions session = IdeOptions

75defaultIdeOptions session = IdeOptions

78 {optPreprocessor = IdePreprocessedSource [] []

76 {optPreprocessor = IdePreprocessedSource [] []

79 ,optGhcSession = session

77 ,optGhcSession = session

test/exe/Main.hs+49−1

@@ -64,6 +64,7 @@ main = defaultMain $ testGroup "HIE"

64 , haddockTests

65 , positionMappingTests

66 , watchedFilesTests

67+ , sessionDepsArePickedUp

67 ]

68 ]

69initializeResponseTests :: TestTree

70initializeResponseTests :: TestTree

@@ -1774,6 +1775,44 @@ haddockTests

1774 where

1775 where

1775 checkHaddock s txt = spanDocToMarkdownForTest s @?= txt

1776 checkHaddock s txt = spanDocToMarkdownForTest s @?= txt

1776

1777

1778+

1779+sessionDepsArePickedUp :: TestTree

1780+sessionDepsArePickedUp = testSession'

1781+ "session-deps-are-picked-up"

1782+ $ \dir -> do

1783+ liftIO $

1784+ writeFileUTF8

1785+ (dir </> "hie.yaml")

1786+ "cradle: {direct: {arguments: []}}"

1787+ -- Open without OverloadedStrings and expect an error.

1788+ doc <- openDoc' "Foo.hs" "haskell" fooContent

1789+ expectDiagnostics

1790+ [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]

1791+ -- Update hie.yaml to enable OverloadedStrings.

1792+ liftIO $

1793+ writeFileUTF8

1794+ (dir </> "hie.yaml")

1795+ "cradle: {direct: {arguments: [-XOverloadedStrings]}}"

1796+ -- Send change event.

1797+ let change =

1798+ TextDocumentContentChangeEvent

1799+ { _range = Just (Range (Position 4 0) (Position 4 0)),

1800+ _rangeLength = Nothing,

1801+ _text = "\n"

1802+ }

1803+ changeDoc doc [change]

1804+ -- Now no errors.

1805+ expectDiagnostics [("Foo.hs", [])]

1806+ where

1807+ fooContent =

1808+ T.unlines

1809+ [ "module Foo where",

1810+ "import Data.Text",

1811+ "foo :: Text",

1812+ "foo = \"hello\""

1813+ ]

1814+

1815+

1777----------------------------------------------------------------------

1816----------------------------------------------------------------------

1778-- Utils

1817-- Utils

1779

1818

@@ -1781,6 +1820,9 @@ haddockTests

1781testSession :: String -> Session () -> TestTree

1820testSession :: String -> Session () -> TestTree

1782testSession name = testCase name . run

1821testSession name = testCase name . run

1783

1822

1823+testSession' :: String -> (FilePath -> Session ()) -> TestTree

1824+testSession' name = testCase name . run'

1825+

1784testSessionWait :: String -> Session () -> TestTree

1826testSessionWait :: String -> Session () -> TestTree

1785testSessionWait name = testSession name .

1827testSessionWait name = testSession name .

1786 -- Check that any diagnostics produced were already consumed by the test case.

1828 -- Check that any diagnostics produced were already consumed by the test case.

@@ -1801,7 +1843,13 @@ mkRange :: Int -> Int -> Int -> Int -> Range

1801mkRange a b c d = Range (Position a b) (Position c d)

1843mkRange a b c d = Range (Position a b) (Position c d)

1802

1844

1803run :: Session a -> IO a

1845run :: Session a -> IO a

1804−run s = withTempDir $ \dir -> do

1846+run s = withTempDir $ \dir -> runInDir dir s

1847+

1848+run' :: (FilePath -> Session a) -> IO a

1849+run' s = withTempDir $ \dir -> runInDir dir (s dir)

1850+

1851+runInDir :: FilePath -> Session a -> IO a

1852+runInDir dir s = do

1805 ghcideExe <- locateGhcideExecutable

1853 ghcideExe <- locateGhcideExecutable

1806

1854

1807 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56

1855 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56