@@ -13,6 +13,10 @@ module Development.IDE.Core.Actions
13
13
, lookupMod
14
14
) where
15
15
16
+ import Control.Concurrent.MVar (MVar , newEmptyMVar , putMVar , readMVar )
17
+ import Control.Concurrent.STM (atomically )
18
+ import Control.Concurrent.STM.TQueue (unGetTQueue )
19
+ import Control.Monad (unless )
16
20
import Control.Monad.Reader
17
21
import Control.Monad.Trans.Maybe
18
22
import qualified Data.ByteString as BS
@@ -48,48 +52,58 @@ lookupMod
48
52
-> Unit
49
53
-> Bool -- ^ Is this file a boot file?
50
54
-> MaybeT IdeAction Uri
51
- lookupMod _dbchan hieFile moduleName uid _boot = MaybeT $ do
55
+ lookupMod HieDbWriter {indexQueue} hieFile moduleName uid _boot = MaybeT $ do
52
56
mProjectRoot <- (resRootPath =<< ) <$> asks lspEnv
53
57
case mProjectRoot of
54
58
Nothing -> pure Nothing
55
59
Just projectRoot -> do
56
- let toFilePath :: ModuleName -> FilePath
57
- toFilePath = separateDirectories . prettyModuleName
58
- where
59
- separateDirectories :: FilePath -> FilePath
60
- separateDirectories moduleNameString =
61
- case breakOnDot moduleNameString of
62
- [] -> " "
63
- ms -> foldr1 (</>) ms
64
- breakOnDot :: FilePath -> [FilePath ]
65
- breakOnDot = words . map replaceDotWithSpace
66
- replaceDotWithSpace :: Char -> Char
67
- replaceDotWithSpace ' .' = ' '
68
- replaceDotWithSpace c = c
69
- prettyModuleName :: ModuleName -> String
70
- prettyModuleName = filter (/= ' "' )
71
- . concat
72
- . drop 1
73
- . words
74
- . show
75
- writeOutDir :: FilePath
76
- writeOutDir = projectRoot </> " .hls" </> " dependencies" </> show uid
77
- writeOutFile :: FilePath
78
- writeOutFile = toFilePath moduleName ++ " .hs"
79
- writeOutPath :: FilePath
80
- writeOutPath = writeOutDir </> writeOutFile
81
- moduleUri :: Uri
82
- moduleUri = AtPoint. toUri writeOutPath
60
+ completionToken <- liftIO $ newEmptyMVar
61
+ moduleUri <- writeAndIndexSource projectRoot completionToken
62
+ liftIO $ readMVar completionToken
63
+ pure $ Just moduleUri
64
+ where
65
+ writeAndIndexSource :: FilePath -> MVar () -> IdeAction Uri
66
+ writeAndIndexSource projectRoot completionToken = do
83
67
fileExists <- liftIO $ doesFileExist writeOutPath
84
- if fileExists
85
- then pure $ Just moduleUri
86
- else do
68
+ unless fileExists $ do
87
69
nc <- asks ideNc
88
70
liftIO $ do
89
71
createDirectoryIfMissing True $ takeDirectory writeOutPath
90
72
moduleSource <- hie_hs_src <$> loadHieFile (mkUpdater nc) hieFile
91
73
BS. writeFile writeOutPath moduleSource
92
- pure $ Just moduleUri
74
+ liftIO $ atomically $
75
+ unGetTQueue indexQueue $ \ withHieDb -> withHieDb $ \ db -> do
76
+ HieDb. addSrcFile db hieFile writeOutPath False
77
+ putMVar completionToken ()
78
+ pure $ moduleUri
79
+ where
80
+ writeOutDir :: FilePath
81
+ writeOutDir = projectRoot </> " .hls" </> " dependencies" </> show uid
82
+ writeOutFile :: FilePath
83
+ writeOutFile = toFilePath moduleName ++ " .hs"
84
+ writeOutPath :: FilePath
85
+ writeOutPath = writeOutDir </> writeOutFile
86
+ moduleUri :: Uri
87
+ moduleUri = AtPoint. toUri writeOutPath
88
+ toFilePath :: ModuleName -> FilePath
89
+ toFilePath = separateDirectories . prettyModuleName
90
+ where
91
+ separateDirectories :: FilePath -> FilePath
92
+ separateDirectories moduleNameString =
93
+ case breakOnDot moduleNameString of
94
+ [] -> " "
95
+ ms -> foldr1 (</>) ms
96
+ breakOnDot :: FilePath -> [FilePath ]
97
+ breakOnDot = words . map replaceDotWithSpace
98
+ replaceDotWithSpace :: Char -> Char
99
+ replaceDotWithSpace ' .' = ' '
100
+ replaceDotWithSpace c = c
101
+ prettyModuleName :: ModuleName -> String
102
+ prettyModuleName = filter (/= ' "' )
103
+ . concat
104
+ . drop 1
105
+ . words
106
+ . show
93
107
94
108
95
109
0 commit comments