|
| 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 | + } |
0 commit comments