Skip to content
This repository was archived by the owner on Oct 7, 2020. It is now read-only.

Commit 9e9432a

Browse files
fendorfendor
authored
Merge pull request #1569 from fendor/extend-debug-utility
Load all possible haskell source files
2 parents 9220fda + 8fce52f commit 9e9432a

File tree

4 files changed

+190
-7
lines changed

4 files changed

+190
-7
lines changed

‎app/MainHie.hs

Lines changed: 42 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -6,9 +6,11 @@ import qualified Control.Exception as E
66
import Control.Monad
77
import Data.Monoid ((<>))
88
import Data.Version (showVersion)
9+
import qualified Data.Text as T
10+
import qualified Data.Text.IO as T
911
import qualified Data.Yaml as Yaml
1012
import HIE.Bios.Types
11-
import Haskell.Ide.Engine.Cradle (findLocalCradle, cradleDisplay)
13+
import Haskell.Ide.Engine.Cradle (findLocalCradle, cradleDisplay, getProjectGhcLibDir)
1214
import Haskell.Ide.Engine.MonadFunctions
1315
import Haskell.Ide.Engine.MonadTypes
1416
import Haskell.Ide.Engine.Options
@@ -20,11 +22,15 @@ import Options.Applicative.Simple
2022
import qualified Paths_haskell_ide_engine as Meta
2123
import System.Directory
2224
import System.Environment
23-
import System.FilePath ((</>))
25+
import System.FilePath
2426
import System.Info
2527
import System.IO
2628
import qualified System.Log.Logger as L
2729

30+
-- ---------------------------------------------------------------------
31+
32+
import RunTest
33+
2834
-- ---------------------------------------------------------------------
2935
-- plugins
3036

@@ -117,6 +123,8 @@ run opts = do
117123
progName <- getProgName
118124
args <- getArgs
119125

126+
let plugins' = plugins (optExamplePlugin opts)
127+
120128
if optLsp opts
121129
then do
122130
-- Start up in LSP mode
@@ -136,8 +144,6 @@ run opts = do
136144
when (optExamplePlugin opts) $
137145
logm "Enabling Example2 plugin, will insert constant diagnostics etc."
138146

139-
let plugins' = plugins (optExamplePlugin opts)
140-
141147
-- launch the dispatcher.
142148
scheduler <- newScheduler plugins' initOpts
143149
server scheduler origDir plugins' (optCaptureFile opts)
@@ -155,7 +161,35 @@ run opts = do
155161
ecradle <- getCradleInfo origDir
156162
case ecradle of
157163
Left e -> cliOut $ "Could not get cradle:" ++ show e
158-
Right cradle -> cliOut $ "Cradle:" ++ cradleDisplay cradle
164+
Right cradle -> do
165+
projGhc <- getProjectGhcVersion cradle
166+
mlibdir <- getProjectGhcLibDir cradle
167+
cliOut "\n\n###################################################\n"
168+
cliOut $ "Cradle: " ++ cradleDisplay cradle
169+
cliOut $ "Project Ghc version: " ++ projGhc
170+
cliOut $ "Libdir: " ++ show mlibdir
171+
cliOut "Searching for Haskell source files..."
172+
targets <- case optFiles opts of
173+
[] -> findAllSourceFiles origDir
174+
xs -> concat <$> mapM findAllSourceFiles xs
175+
176+
cliOut $ "Found " ++ show (length targets) ++ " Haskell source files.\n"
177+
cliOut "###################################################"
178+
cliOut "\nFound the following files:\n"
179+
mapM_ cliOut targets
180+
cliOut ""
181+
182+
unless (optDryRun opts) $ do
183+
cliOut "\nLoad them all now. This may take a very long time.\n"
184+
loadDiagnostics <- runServer mlibdir plugins' targets
185+
186+
cliOut ""
187+
cliOut "###################################################"
188+
cliOut "###################################################"
189+
cliOut "\nDumping diagnostics:\n\n"
190+
mapM_ (cliOut' . uncurry prettyPrintDiags) loadDiagnostics
191+
cliOut "\n\nNote: loading of 'Setup.hs' is not supported."
192+
159193

160194
-- ---------------------------------------------------------------------
161195

@@ -170,4 +204,7 @@ getCradleInfo currentDir = do
170204
cliOut :: String -> IO ()
171205
cliOut = putStrLn
172206

207+
cliOut' :: T.Text -> IO ()
208+
cliOut' = T.putStrLn
209+
173210
-- ---------------------------------------------------------------------

‎app/RunTest.hs

Lines changed: 128 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,128 @@
1+
{-# LANGUAGE NamedFieldPuns #-}
2+
{-# LANGUAGE TupleSections #-}
3+
{-# LANGUAGE OverloadedStrings #-}
4+
module RunTest
5+
( findAllSourceFiles
6+
, compileTarget
7+
, runServer
8+
, prettyPrintDiags
9+
)
10+
where
11+
12+
import GhcMonad
13+
import qualified GHC
14+
import Control.Monad
15+
import qualified Control.Concurrent.STM as STM
16+
import Data.List ( isPrefixOf )
17+
import qualified Data.Text as T
18+
import qualified Data.Map as Map
19+
import Data.Default
20+
import System.Directory ( doesDirectoryExist
21+
, listDirectory
22+
, canonicalizePath
23+
, doesFileExist
24+
)
25+
import System.FilePath
26+
import Language.Haskell.LSP.Core
27+
import Language.Haskell.LSP.Types
28+
import Haskell.Ide.Engine.PluginsIdeMonads
29+
hiding ( withIndefiniteProgress
30+
, withProgress
31+
)
32+
import Haskell.Ide.Engine.GhcModuleCache
33+
import qualified Haskell.Ide.Engine.ModuleCache
34+
as MC
35+
import qualified Haskell.Ide.Engine.Ghc as Ghc
36+
37+
findAllSourceFiles :: FilePath -> IO [FilePath]
38+
findAllSourceFiles fp = do
39+
absFp <- canonicalizePath fp
40+
isDir <- doesDirectoryExist absFp
41+
if isDir
42+
then findFilesRecursively
43+
isHaskellSource
44+
(\path -> any (\p -> p path) [isHidden, isSpecialDir])
45+
absFp
46+
else filterM doesFileExist [absFp]
47+
where
48+
isHaskellSource = (== ".hs") . takeExtension
49+
isHidden = ("." `isPrefixOf`) . takeFileName
50+
isSpecialDir = (== "dist-newstyle") . takeFileName
51+
52+
findFilesRecursively
53+
:: (FilePath -> Bool) -> (FilePath -> Bool) -> FilePath -> IO [FilePath]
54+
findFilesRecursively p exclude dir = do
55+
dirContents' <- listDirectory dir
56+
let dirContents = map (dir </>) dirContents'
57+
58+
files <- forM dirContents $ \fp -> do
59+
isDirectory <- doesDirectoryExist fp
60+
if isDirectory
61+
then if not $ exclude fp
62+
then findFilesRecursively p exclude fp
63+
else return []
64+
else if p fp then return [fp] else return []
65+
66+
return $ concat files
67+
68+
69+
-- ---------------------------------------------------------------------
70+
71+
compileTarget
72+
:: GHC.DynFlags
73+
-> FilePath
74+
-> IdeGhcM (IdeResult (Ghc.Diagnostics, Ghc.AdditionalErrs))
75+
compileTarget dynFlags fp = do
76+
let pubDiags _ _ _ = return ()
77+
let defAction = return (mempty, mempty)
78+
let action = Ghc.setTypecheckedModule (filePathToUri fp)
79+
actionResult <- MC.runActionWithContext pubDiags
80+
dynFlags
81+
(Just fp)
82+
defAction
83+
action
84+
return $ join actionResult
85+
86+
-- ---------------------------------------------------------------------
87+
88+
runServer
89+
:: Maybe FilePath
90+
-> IdePlugins
91+
-> [FilePath]
92+
-> IO [(FilePath, IdeResult (Ghc.Diagnostics, Ghc.AdditionalErrs))]
93+
runServer mlibdir ideplugins targets = do
94+
let initialState = IdeState emptyModuleCache Map.empty Map.empty Nothing
95+
stateVar <- STM.newTVarIO initialState
96+
97+
runIdeGhcM mlibdir ideplugins dummyLspFuncs stateVar $ do
98+
dynFlags <- getSessionDynFlags
99+
mapM (\fp -> (fp, ) <$> compileTarget dynFlags fp) targets
100+
101+
-- ---------------------------------------------------------------------
102+
103+
prettyPrintDiags
104+
:: FilePath -> IdeResult (Ghc.Diagnostics, Ghc.AdditionalErrs) -> T.Text
105+
prettyPrintDiags fp diags = T.pack fp <> ": " <> case diags of
106+
IdeResultFail IdeError { ideMessage } -> "FAILED\n\t" <> ideMessage
107+
IdeResultOk (_diags, errs) ->
108+
if null errs then "OK" else T.unlines (map (T.append "\t") errs)
109+
110+
-- ---------------------------------------------------------------------
111+
112+
dummyLspFuncs :: Default a => LspFuncs a
113+
dummyLspFuncs = LspFuncs
114+
{ clientCapabilities = def
115+
, config = return (Just def)
116+
, sendFunc = const (return ())
117+
, getVirtualFileFunc = const (return Nothing)
118+
, persistVirtualFileFunc = \uri ->
119+
return (uriToFilePath (fromNormalizedUri uri))
120+
, reverseFileMapFunc = return id
121+
, publishDiagnosticsFunc = mempty
122+
, flushDiagnosticsBySourceFunc = mempty
123+
, getNextReqId = pure (IdInt 0)
124+
, rootPath = Nothing
125+
, getWorkspaceFolders = return Nothing
126+
, withProgress = \_ _ f -> f (const (return ()))
127+
, withIndefiniteProgress = \_ _ f -> f
128+
}

‎haskell-ide-engine.cabal

Lines changed: 7 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -110,17 +110,23 @@ library
110110
executable hie
111111
hs-source-dirs: app
112112
main-is: MainHie.hs
113-
other-modules: Paths_haskell_ide_engine
113+
other-modules: Paths_haskell_ide_engine, RunTest
114114
autogen-modules: Paths_haskell_ide_engine
115115
build-depends: base
116+
, containers
117+
, data-default
116118
, directory
117119
, filepath
120+
, ghc
118121
, hie-bios
119122
, haskell-ide-engine
120123
, haskell-lsp
124+
, haskell-lsp-types
121125
, hie-plugin-api
122126
, hslogger
123127
, optparse-simple
128+
, stm
129+
, text
124130
, yaml
125131
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wredundant-constraints
126132
-with-rtsopts=-T

‎src/Haskell/Ide/Engine/Options.hs

Lines changed: 13 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -6,11 +6,13 @@ import Options.Applicative.Simple
66
data GlobalOpts = GlobalOpts
77
{ optDebugOn :: Bool
88
, optLogFile :: Maybe String
9-
, optLsp :: Bool -- Kept for a while, to not break legacy clients
9+
, optLsp :: Bool
1010
, projectRoot :: Maybe String
1111
, optBiosVerbose :: Bool
1212
, optCaptureFile :: Maybe FilePath
1313
, optExamplePlugin :: Bool
14+
, optDryRun :: Bool
15+
, optFiles :: [FilePath]
1416
} deriving (Show)
1517

1618
globalOptsParser :: Parser GlobalOpts
@@ -53,3 +55,13 @@ globalOptsParser = GlobalOpts
5355
<*> switch
5456
( long "example"
5557
<> help "Enable Example2 plugin. Useful for developers only")
58+
<*> flag False True
59+
( long "dry-run"
60+
<> help "Perform a dry-run of loading files. Only searches for Haskell source files to load. Does nothing if run as LSP server."
61+
)
62+
<*> many
63+
( argument str
64+
( metavar "FILES..."
65+
<> help "Directories and Filepaths to load. Does nothing if run as LSP server.")
66+
)
67+

0 commit comments

Comments
 (0)