mirror of
https://github.com/haskell/ghcide.git
synced 2024-09-11 05:36:09 +03:00
Clean up the logging in hie-core (#1839)
* Move prettyPosition over to a more sensible place * Avoid some pretty printing * Remove duplicate methods and switch to having a function to get the logger handle * Remove unncessary bits of the logger * Remove reportSeriousErrorDie - was unused * Rename the Logger methods to Logger rather than Handle * Delete the unique supply * Decrease the use of getServiceEnv * Move getIdeOptions inside Service * Add getFilesOfInterest rule * Hide the existence of Env * Inline some redundant forwarding methods * Add a FIXME for a dodgy function * Delete some redundant imports * Rename Map to HMap, since I need to use Data.Map too * Make the Shake-specific Diagnostics functions into that module * Delete errorDiag which was unused * Inline the diagnostic function, since it had one user * Add ofInterest rule as a separate module * Sort the exposed modules * Fix up the demo * Make sure you add the OfInterestVar global * HLint * Get rid of some of interest stuff in other places * Remove the OfInterest stuff from Service
This commit is contained in:
Neil Mitchell
Gary Verhaegen
parent
bf2cbd259c
commit
f746db9dc4
@ -76,33 +76,34 @@ library
|
||||
hs-source-dirs:
|
||||
src
|
||||
exposed-modules:
|
||||
Development.IDE.Types.Logger
|
||||
Development.IDE.GHC.Util
|
||||
Development.IDE.Spans.AtPoint
|
||||
Development.IDE.Core.Compile
|
||||
Development.IDE.GHC.CPP
|
||||
Development.IDE.GHC.Orphans
|
||||
Development.IDE.Import.DependencyInformation
|
||||
Development.IDE.Spans.Documentation
|
||||
Development.IDE.Import.FindImports
|
||||
Development.IDE.GHC.Error
|
||||
Development.IDE.Spans.Calculate
|
||||
Development.IDE.GHC.Warnings
|
||||
Development.IDE.Core.FileStore
|
||||
Development.IDE.Core.OfInterest
|
||||
Development.IDE.Core.Rules
|
||||
Development.IDE.GHC.Compat
|
||||
Development.IDE.LSP.LanguageServer
|
||||
Development.IDE.LSP.Definition
|
||||
Development.IDE.LSP.Hover
|
||||
Development.IDE.LSP.Protocol
|
||||
Development.IDE.LSP.Server
|
||||
Development.IDE.Types.Options
|
||||
Development.IDE.Core.RuleTypes
|
||||
Development.IDE.Core.Service
|
||||
Development.IDE.Core.Shake
|
||||
Development.IDE.GHC.Compat
|
||||
Development.IDE.GHC.CPP
|
||||
Development.IDE.GHC.Error
|
||||
Development.IDE.GHC.Orphans
|
||||
Development.IDE.GHC.Util
|
||||
Development.IDE.GHC.Warnings
|
||||
Development.IDE.Import.DependencyInformation
|
||||
Development.IDE.Import.FindImports
|
||||
Development.IDE.LSP.Definition
|
||||
Development.IDE.LSP.Hover
|
||||
Development.IDE.LSP.LanguageServer
|
||||
Development.IDE.LSP.Protocol
|
||||
Development.IDE.LSP.Server
|
||||
Development.IDE.Spans.AtPoint
|
||||
Development.IDE.Spans.Calculate
|
||||
Development.IDE.Spans.Documentation
|
||||
Development.IDE.Spans.Type
|
||||
Development.IDE.Types.Diagnostics
|
||||
Development.IDE.Types.Location
|
||||
Development.IDE.Spans.Type
|
||||
Development.IDE.Types.Logger
|
||||
Development.IDE.Types.Options
|
||||
|
||||
executable hie-core
|
||||
default-language: Haskell2010
|
||||
|
||||
81
src/Development/IDE/Core/OfInterest.hs
Normal file
81
src/Development/IDE/Core/OfInterest.hs
Normal file
@ -0,0 +1,81 @@
|
||||
-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
-- | A Shake implementation of the compiler service, built
|
||||
-- using the "Shaker" abstraction layer for in-memory use.
|
||||
--
|
||||
module Development.IDE.Core.OfInterest(
|
||||
ofInterestRules,
|
||||
getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,
|
||||
) where
|
||||
|
||||
import Control.Concurrent.Extra
|
||||
import Control.Monad.Except
|
||||
import Data.Hashable
|
||||
import Control.DeepSeq
|
||||
import GHC.Generics
|
||||
import Data.Typeable
|
||||
import qualified Data.ByteString.UTF8 as BS
|
||||
import Control.Exception
|
||||
import Development.IDE.Types.Location
|
||||
import Development.IDE.Types.Logger
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
import Data.Tuple.Extra
|
||||
import Development.Shake hiding (Diagnostic, Env, newCache)
|
||||
|
||||
import Development.IDE.Core.Shake
|
||||
|
||||
|
||||
|
||||
newtype OfInterestVar = OfInterestVar (Var (Set NormalizedFilePath))
|
||||
instance IsIdeGlobal OfInterestVar
|
||||
|
||||
|
||||
type instance RuleResult GetFilesOfInterest = Set NormalizedFilePath
|
||||
|
||||
|
||||
data GetFilesOfInterest = GetFilesOfInterest
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
instance Hashable GetFilesOfInterest
|
||||
instance NFData GetFilesOfInterest
|
||||
|
||||
|
||||
ofInterestRules :: Rules ()
|
||||
ofInterestRules = do
|
||||
addIdeGlobal . OfInterestVar =<< liftIO (newVar Set.empty)
|
||||
defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do
|
||||
alwaysRerun
|
||||
filesOfInterest <- getFilesOfInterestUntracked
|
||||
pure (Just $ BS.fromString $ show filesOfInterest, ([], Just filesOfInterest))
|
||||
|
||||
|
||||
getFilesOfInterest :: Action (Set NormalizedFilePath)
|
||||
getFilesOfInterest = use_ GetFilesOfInterest ""
|
||||
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Exposed API
|
||||
|
||||
-- | Set the files-of-interest which will be built and kept-up-to-date.
|
||||
setFilesOfInterest :: IdeState -> Set NormalizedFilePath -> IO ()
|
||||
setFilesOfInterest state files = modifyFilesOfInterest state (const files)
|
||||
|
||||
getFilesOfInterestUntracked :: Action (Set NormalizedFilePath)
|
||||
getFilesOfInterestUntracked = do
|
||||
OfInterestVar var <- getIdeGlobalAction
|
||||
liftIO $ readVar var
|
||||
|
||||
modifyFilesOfInterest :: IdeState -> (Set NormalizedFilePath -> Set NormalizedFilePath) -> IO ()
|
||||
modifyFilesOfInterest state f = do
|
||||
OfInterestVar var <- getIdeGlobalState state
|
||||
files <- modifyVar var $ pure . dupe . f
|
||||
logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ Set.toList files)
|
||||
void $ shakeRun state [] (const $ pure ())
|
||||
@ -17,8 +17,6 @@ import Development.IDE.Import.FindImports (Import(..))
|
||||
import Development.IDE.Import.DependencyInformation
|
||||
import Data.Hashable
|
||||
import Data.Typeable
|
||||
import Development.IDE.Types.Location
|
||||
import Data.Set(Set)
|
||||
import Development.Shake hiding (Env, newCache)
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
@ -69,14 +67,6 @@ type instance RuleResult ReportImportCycles = ()
|
||||
type instance RuleResult GetHieFile = HieFile
|
||||
|
||||
|
||||
type instance RuleResult GetFilesOfInterest = Set NormalizedFilePath
|
||||
|
||||
|
||||
data GetFilesOfInterest = GetFilesOfInterest
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
instance Hashable GetFilesOfInterest
|
||||
instance NFData GetFilesOfInterest
|
||||
|
||||
data GetParsedModule = GetParsedModule
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
instance Hashable GetParsedModule
|
||||
|
||||
@ -32,9 +32,6 @@ import Development.IDE.Import.FindImports
|
||||
import Development.IDE.Core.FileStore
|
||||
import Development.IDE.Types.Diagnostics as Base
|
||||
import Development.IDE.Types.Location
|
||||
import qualified Data.ByteString.UTF8 as BS
|
||||
import Control.Exception
|
||||
import Control.Concurrent.Extra
|
||||
import Data.Bifunctor
|
||||
import Data.Either.Extra
|
||||
import Data.Maybe
|
||||
@ -78,14 +75,6 @@ defineNoFile f = define $ \k file -> do
|
||||
------------------------------------------------------------
|
||||
-- Exposed API
|
||||
|
||||
getFilesOfInterestRule :: Rules ()
|
||||
getFilesOfInterestRule = do
|
||||
defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do
|
||||
alwaysRerun
|
||||
Env{..} <- getServiceEnv
|
||||
filesOfInterest <- liftIO $ readVar envOfInterestVar
|
||||
pure (Just $ BS.fromString $ show filesOfInterest, ([], Just filesOfInterest))
|
||||
|
||||
|
||||
-- | Generate the GHC Core for the supplied file and its dependencies.
|
||||
getGhcCore :: NormalizedFilePath -> Action (Maybe [CoreModule])
|
||||
@ -104,7 +93,7 @@ getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file
|
||||
-- | Try to get hover text for the name under point.
|
||||
getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text]))
|
||||
getAtPoint file pos = fmap join $ runMaybeT $ do
|
||||
opts <- lift getOpts
|
||||
opts <- lift getIdeOptions
|
||||
files <- transitiveModuleDeps <$> useE GetDependencies file
|
||||
tms <- usesE TypeCheck (file : files)
|
||||
spans <- useE GetSpanInfo file
|
||||
@ -115,7 +104,7 @@ getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)
|
||||
getDefinition file pos = fmap join $ runMaybeT $ do
|
||||
spans <- useE GetSpanInfo file
|
||||
pkgState <- useE GhcSession ""
|
||||
opts <- lift getOpts
|
||||
opts <- lift getIdeOptions
|
||||
let getHieFile x = use (GetHieFile x) ""
|
||||
lift $ AtPoint.gotoDefinition getHieFile opts pkgState spans pos
|
||||
|
||||
@ -123,8 +112,6 @@ getDefinition file pos = fmap join $ runMaybeT $ do
|
||||
getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)
|
||||
getParsedModule file = use GetParsedModule file
|
||||
|
||||
getOpts :: Action Compile.IdeOptions
|
||||
getOpts = envOptions <$> getServiceEnv
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Rules
|
||||
@ -144,7 +131,7 @@ getParsedModuleRule =
|
||||
define $ \GetParsedModule file -> do
|
||||
(_, contents) <- getFileContents file
|
||||
packageState <- use_ GhcSession ""
|
||||
opt <- getOpts
|
||||
opt <- getIdeOptions
|
||||
liftIO $ Compile.parseModule opt packageState (fromNormalizedFilePath file) contents
|
||||
|
||||
getLocatedImportsRule :: Rules ()
|
||||
@ -155,7 +142,7 @@ getLocatedImportsRule =
|
||||
let imports = ms_textual_imps ms
|
||||
packageState <- use_ GhcSession ""
|
||||
dflags <- liftIO $ Compile.getGhcDynFlags pm packageState
|
||||
opt <- getOpts
|
||||
opt <- getIdeOptions
|
||||
xs <- forM imports $ \(mbPkgName, modName) ->
|
||||
(modName, ) <$> locateModule dflags (Compile.optExtensions opt) getFileExists modName mbPkgName
|
||||
return (concat $ lefts $ map snd xs, Just $ map (second eitherToMaybe) xs)
|
||||
@ -255,7 +242,7 @@ typeCheckRule =
|
||||
tms <- uses_ TypeCheck (transitiveModuleDeps deps)
|
||||
setPriority PriorityTypeCheck
|
||||
packageState <- use_ GhcSession ""
|
||||
opt <- getOpts
|
||||
opt <- getIdeOptions
|
||||
liftIO $ Compile.typecheckModule opt packageState tms pm
|
||||
|
||||
|
||||
@ -272,7 +259,7 @@ generateCoreRule =
|
||||
loadGhcSession :: Rules ()
|
||||
loadGhcSession =
|
||||
defineNoFile $ \GhcSession -> do
|
||||
opts <- envOptions <$> getServiceEnv
|
||||
opts <- getIdeOptions
|
||||
Compile.optGhcSession opts
|
||||
|
||||
|
||||
@ -296,7 +283,6 @@ mainRule = do
|
||||
generateCoreRule
|
||||
loadGhcSession
|
||||
getHieFileRule
|
||||
getFilesOfInterestRule
|
||||
|
||||
------------------------------------------------------------
|
||||
|
||||
|
||||
@ -9,64 +9,31 @@
|
||||
-- using the "Shaker" abstraction layer for in-memory use.
|
||||
--
|
||||
module Development.IDE.Core.Service(
|
||||
Env(..),
|
||||
getServiceEnv,
|
||||
getIdeOptions,
|
||||
IdeState, initialise, shutdown,
|
||||
runAction, runActions,
|
||||
runActionSync, runActionsSync,
|
||||
setFilesOfInterest, modifyFilesOfInterest,
|
||||
getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,
|
||||
writeProfile,
|
||||
getDiagnostics, unsafeClearDiagnostics,
|
||||
logDebug, logSeriousError
|
||||
ideLogger
|
||||
) where
|
||||
|
||||
import Control.Concurrent.Extra
|
||||
import Control.Monad.Except
|
||||
import Development.IDE.Types.Options (IdeOptions(..))
|
||||
import Development.IDE.Core.FileStore
|
||||
import qualified Development.IDE.Types.Logger as Logger
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
import Data.Tuple.Extra
|
||||
import Development.IDE.Types.Diagnostics(FileDiagnostic)
|
||||
import Development.IDE.Types.Location (NormalizedFilePath)
|
||||
import Development.IDE.Core.OfInterest
|
||||
import Development.IDE.Types.Logger
|
||||
import Development.Shake hiding (Diagnostic, Env, newCache)
|
||||
import qualified Language.Haskell.LSP.Messages as LSP
|
||||
|
||||
import UniqSupply
|
||||
|
||||
import Development.IDE.Core.Shake
|
||||
|
||||
|
||||
-- | Environment threaded through the Shake actions.
|
||||
data Env = Env
|
||||
{ envOptions :: IdeOptions
|
||||
-- ^ Compiler options.
|
||||
, envOfInterestVar :: Var (Set NormalizedFilePath)
|
||||
-- ^ The files of interest.
|
||||
, envUniqSupplyVar :: Var UniqSupply
|
||||
-- ^ The unique supply of names used by the compiler.
|
||||
}
|
||||
instance IsIdeGlobal Env
|
||||
|
||||
|
||||
mkEnv :: IdeOptions -> IO Env
|
||||
mkEnv options = do
|
||||
ofInterestVar <- newVar Set.empty
|
||||
uniqSupplyVar <- mkSplitUniqSupply 'a' >>= newVar
|
||||
return Env
|
||||
{ envOptions = options
|
||||
, envOfInterestVar = ofInterestVar
|
||||
, envUniqSupplyVar = uniqSupplyVar
|
||||
}
|
||||
|
||||
getDiagnostics :: IdeState -> IO [FileDiagnostic]
|
||||
getDiagnostics = getAllDiagnostics
|
||||
|
||||
unsafeClearDiagnostics :: IdeState -> IO ()
|
||||
unsafeClearDiagnostics = unsafeClearAllDiagnostics
|
||||
|
||||
newtype GlobalIdeOptions = GlobalIdeOptions IdeOptions
|
||||
instance IsIdeGlobal GlobalIdeOptions
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Exposed API
|
||||
@ -74,7 +41,7 @@ unsafeClearDiagnostics = unsafeClearAllDiagnostics
|
||||
-- | Initialise the Compiler Service.
|
||||
initialise :: Rules ()
|
||||
-> (LSP.FromServerMessage -> IO ())
|
||||
-> Logger.Handle
|
||||
-> Logger
|
||||
-> IdeOptions
|
||||
-> VFSHandle
|
||||
-> IO IdeState
|
||||
@ -86,8 +53,9 @@ initialise mainRule toDiags logger options vfs =
|
||||
shakeOptions { shakeThreads = optThreads options
|
||||
, shakeFiles = "/dev/null"
|
||||
}) $ do
|
||||
addIdeGlobal =<< liftIO (mkEnv options)
|
||||
addIdeGlobal $ GlobalIdeOptions options
|
||||
fileStoreRules vfs
|
||||
ofInterestRules
|
||||
mainRule
|
||||
|
||||
writeProfile :: IdeState -> FilePath -> IO ()
|
||||
@ -128,16 +96,7 @@ runActionSync s a = head <$> runActionsSync s [a]
|
||||
runActionsSync :: IdeState -> [Action a] -> IO [a]
|
||||
runActionsSync s acts = join $ shakeRun s acts (const $ pure ())
|
||||
|
||||
-- | Set the files-of-interest which will be built and kept-up-to-date.
|
||||
setFilesOfInterest :: IdeState -> Set NormalizedFilePath -> IO ()
|
||||
setFilesOfInterest state files = modifyFilesOfInterest state (const files)
|
||||
|
||||
modifyFilesOfInterest :: IdeState -> (Set NormalizedFilePath -> Set NormalizedFilePath) -> IO ()
|
||||
modifyFilesOfInterest state f = do
|
||||
Env{..} <- getIdeGlobalState state
|
||||
files <- modifyVar envOfInterestVar $ pure . dupe . f
|
||||
logDebug state $ "Set files of interest to: " <> T.pack (show $ Set.toList files)
|
||||
void $ shakeRun state [] (const $ pure ())
|
||||
|
||||
getServiceEnv :: Action Env
|
||||
getServiceEnv = getIdeGlobalAction
|
||||
getIdeOptions :: Action IdeOptions
|
||||
getIdeOptions = do
|
||||
GlobalIdeOptions x <- getIdeGlobalAction
|
||||
return x
|
||||
|
||||
@ -31,14 +31,13 @@ module Development.IDE.Core.Shake(
|
||||
use, uses,
|
||||
use_, uses_,
|
||||
define, defineEarlyCutoff,
|
||||
getAllDiagnostics, unsafeClearAllDiagnostics,
|
||||
reportSeriousError, reportSeriousErrorDie,
|
||||
getDiagnostics, unsafeClearDiagnostics,
|
||||
reportSeriousError,
|
||||
IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,
|
||||
garbageCollect,
|
||||
setPriority,
|
||||
sendEvent,
|
||||
Development.IDE.Core.Shake.logDebug,
|
||||
Development.IDE.Core.Shake.logSeriousError,
|
||||
ideLogger,
|
||||
FileVersion(..),
|
||||
vfsVersion
|
||||
) where
|
||||
@ -47,16 +46,18 @@ import Development.Shake
|
||||
import Development.Shake.Database
|
||||
import Development.Shake.Classes
|
||||
import Development.Shake.Rule
|
||||
import qualified Data.HashMap.Strict as Map
|
||||
import qualified Data.HashMap.Strict as HMap
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.Dynamic
|
||||
import Data.Maybe
|
||||
import Data.Either.Extra
|
||||
import Data.List.Extra
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE.Types.Logger as Logger
|
||||
import Development.IDE.Types.Diagnostics hiding (getAllDiagnostics)
|
||||
import qualified Development.IDE.Types.Diagnostics as D
|
||||
import Development.IDE.Types.Logger
|
||||
import Language.Haskell.LSP.Diagnostics
|
||||
import qualified Data.SortedList as SL
|
||||
import Development.IDE.Types.Diagnostics
|
||||
import Development.IDE.Types.Location
|
||||
import Control.Concurrent.Extra
|
||||
import Control.Exception
|
||||
@ -78,8 +79,8 @@ import Numeric.Extra
|
||||
-- information we stash inside the shakeExtra field
|
||||
data ShakeExtras = ShakeExtras
|
||||
{eventer :: LSP.FromServerMessage -> IO ()
|
||||
,logger :: Logger.Handle
|
||||
,globals :: Var (Map.HashMap TypeRep Dynamic)
|
||||
,logger :: Logger
|
||||
,globals :: Var (HMap.HashMap TypeRep Dynamic)
|
||||
,state :: Var Values
|
||||
,diagnostics :: Var DiagnosticStore
|
||||
}
|
||||
@ -101,14 +102,14 @@ class Typeable a => IsIdeGlobal a where
|
||||
addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
|
||||
addIdeGlobal x@(typeOf -> ty) = do
|
||||
ShakeExtras{globals} <- getShakeExtrasRules
|
||||
liftIO $ modifyVar_ globals $ \mp -> case Map.lookup ty mp of
|
||||
liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of
|
||||
Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty
|
||||
Nothing -> return $! Map.insert ty (toDyn x) mp
|
||||
Nothing -> return $! HMap.insert ty (toDyn x) mp
|
||||
|
||||
|
||||
getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
|
||||
getIdeGlobalExtras ShakeExtras{globals} = do
|
||||
Just x <- Map.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
|
||||
Just x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
|
||||
return $ fromDyn x $ error "Serious error, corrupt globals"
|
||||
|
||||
getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
|
||||
@ -119,7 +120,7 @@ getIdeGlobalState = getIdeGlobalExtras . shakeExtras
|
||||
|
||||
|
||||
-- | The state of the all values - nested so you can easily find all errors at a given file.
|
||||
type Values = Map.HashMap (NormalizedFilePath, Key) (Maybe Dynamic)
|
||||
type Values = HMap.HashMap (NormalizedFilePath, Key) (Maybe Dynamic)
|
||||
|
||||
-- | Key type
|
||||
data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k
|
||||
@ -168,7 +169,6 @@ data IdeState = IdeState
|
||||
,shakeExtras :: ShakeExtras
|
||||
}
|
||||
|
||||
|
||||
profileDir :: Maybe FilePath
|
||||
profileDir = Nothing -- set to Just the directory you want profile reports to appear in
|
||||
|
||||
@ -199,7 +199,7 @@ setValues :: IdeRule k v
|
||||
-> Maybe v
|
||||
-> IO ()
|
||||
setValues state key file val = modifyVar_ state $
|
||||
pure . Map.insert (file, Key key) (fmap toDyn val)
|
||||
pure . HMap.insert (file, Key key) (fmap toDyn val)
|
||||
|
||||
-- | The outer Maybe is Nothing if this function hasn't been computed before
|
||||
-- the inner Maybe is Nothing if the result of the previous computation failed to produce
|
||||
@ -208,19 +208,19 @@ getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath ->
|
||||
getValues state key file = do
|
||||
vs <- readVar state
|
||||
return $ do
|
||||
v <- Map.lookup (file, Key key) vs
|
||||
v <- HMap.lookup (file, Key key) vs
|
||||
pure $ fmap (fromJust . fromDynamic @v) v
|
||||
|
||||
-- | Open a 'IdeState', should be shut using 'shakeShut'.
|
||||
shakeOpen :: (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
|
||||
-> Logger.Handle
|
||||
-> Logger
|
||||
-> ShakeOptions
|
||||
-> Rules ()
|
||||
-> IO IdeState
|
||||
shakeOpen eventer logger opts rules = do
|
||||
shakeExtras <- do
|
||||
globals <- newVar Map.empty
|
||||
state <- newVar Map.empty
|
||||
globals <- newVar HMap.empty
|
||||
state <- newVar HMap.empty
|
||||
diagnostics <- newVar mempty
|
||||
pure ShakeExtras{..}
|
||||
(shakeDb, shakeClose) <- shakeOpenDatabase opts{shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts} rules
|
||||
@ -248,7 +248,7 @@ shakeRun :: IdeState -> [Action a] -> ([a] -> IO ()) -> IO (IO [a])
|
||||
-- not even start, which would make issues with async exceptions less problematic.
|
||||
shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts callback = modifyVar shakeAbort $ \stop -> do
|
||||
(stopTime,_) <- duration stop
|
||||
Logger.logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
|
||||
logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
|
||||
bar <- newBarrier
|
||||
start <- offsetTime
|
||||
let act = do
|
||||
@ -258,7 +258,7 @@ shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts callback = modifyVar sha
|
||||
thread <- forkFinally (shakeRunDatabaseProfile shakeDb [act]) $ \res -> do
|
||||
signalBarrier bar (mapRight head res)
|
||||
runTime <- start
|
||||
Logger.logDebug logger $ T.pack $
|
||||
logDebug logger $ T.pack $
|
||||
"Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ (if isLeft res then "exception" else "completed") ++ ")"
|
||||
-- important: we send an async exception to the thread, then wait for it to die, before continuing
|
||||
return (do killThread thread; void $ waitBarrier bar, either throwIO return =<< waitBarrier bar)
|
||||
@ -271,14 +271,14 @@ useStale IdeState{shakeExtras=ShakeExtras{state}} k fp =
|
||||
join <$> getValues state k fp
|
||||
|
||||
|
||||
getAllDiagnostics :: IdeState -> IO [FileDiagnostic]
|
||||
getAllDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
|
||||
getDiagnostics :: IdeState -> IO [FileDiagnostic]
|
||||
getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
|
||||
val <- readVar diagnostics
|
||||
return $ D.getAllDiagnostics val
|
||||
return $ getAllDiagnostics val
|
||||
|
||||
-- | FIXME: This function is temporary! Only required because the files of interest doesn't work
|
||||
unsafeClearAllDiagnostics :: IdeState -> IO ()
|
||||
unsafeClearAllDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
|
||||
unsafeClearDiagnostics :: IdeState -> IO ()
|
||||
unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
|
||||
writeVar diagnostics mempty
|
||||
|
||||
-- | Clear the results for all files that do not match the given predicate.
|
||||
@ -286,7 +286,7 @@ garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
|
||||
garbageCollect keep = do
|
||||
ShakeExtras{state, diagnostics} <- getShakeExtras
|
||||
liftIO $
|
||||
do modifyVar_ state $ return . Map.filterWithKey (\(file, _) _ -> keep file)
|
||||
do modifyVar_ state $ return . HMap.filterWithKey (\(file, _) _ -> keep file)
|
||||
modifyVar_ diagnostics $ return . filterDiagnostics keep
|
||||
|
||||
define
|
||||
@ -311,13 +311,7 @@ uses_ key files = do
|
||||
reportSeriousError :: String -> Action ()
|
||||
reportSeriousError t = do
|
||||
ShakeExtras{logger} <- getShakeExtras
|
||||
liftIO $ Logger.logSeriousError logger $ T.pack t
|
||||
|
||||
reportSeriousErrorDie :: String -> Action a
|
||||
reportSeriousErrorDie t = do
|
||||
ShakeExtras{logger} <- getShakeExtras
|
||||
liftIO $ Logger.logSeriousError logger $ T.pack t
|
||||
fail t
|
||||
liftIO $ logSeriousError logger $ T.pack t
|
||||
|
||||
|
||||
-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
|
||||
@ -424,14 +418,9 @@ sendEvent e = do
|
||||
ShakeExtras{eventer} <- getShakeExtras
|
||||
liftIO $ eventer e
|
||||
|
||||
-- | bit of an odd signature because we're trying to remove priority
|
||||
sl :: (Handle -> T.Text -> IO ()) -> IdeState -> T.Text -> IO ()
|
||||
sl f IdeState{shakeExtras=ShakeExtras{logger}} p = f logger p
|
||||
ideLogger :: IdeState -> Logger
|
||||
ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger
|
||||
|
||||
logDebug, logSeriousError
|
||||
:: IdeState -> T.Text -> IO ()
|
||||
logDebug = sl Logger.logDebug
|
||||
logSeriousError = sl Logger.logSeriousError
|
||||
|
||||
data GetModificationTime = GetModificationTime
|
||||
deriving (Eq, Show, Generic)
|
||||
@ -449,3 +438,46 @@ instance NFData FileVersion
|
||||
vfsVersion :: FileVersion -> Maybe Int
|
||||
vfsVersion (VFSVersion i) = Just i
|
||||
vfsVersion (ModificationTime _) = Nothing
|
||||
|
||||
|
||||
|
||||
getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
|
||||
getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
|
||||
|
||||
|
||||
-- | Sets the diagnostics for a file and compilation step
|
||||
-- if you want to clear the diagnostics call this with an empty list
|
||||
setStageDiagnostics ::
|
||||
NormalizedFilePath ->
|
||||
Maybe Int ->
|
||||
-- ^ the time that the file these diagnostics originate from was last edited
|
||||
T.Text ->
|
||||
[LSP.Diagnostic] ->
|
||||
DiagnosticStore ->
|
||||
DiagnosticStore
|
||||
setStageDiagnostics fp timeM stage diags ds =
|
||||
updateDiagnostics ds uri timeM diagsBySource
|
||||
where
|
||||
diagsBySource = Map.singleton (Just stage) (SL.toSortedList diags)
|
||||
uri = filePathToUri' fp
|
||||
|
||||
getAllDiagnostics ::
|
||||
DiagnosticStore ->
|
||||
[FileDiagnostic]
|
||||
getAllDiagnostics =
|
||||
concatMap (\(k,v) -> map (fromUri k,) $ getDiagnosticsFromStore v) . Map.toList
|
||||
|
||||
getFileDiagnostics ::
|
||||
NormalizedFilePath ->
|
||||
DiagnosticStore ->
|
||||
[LSP.Diagnostic]
|
||||
getFileDiagnostics fp ds =
|
||||
maybe [] getDiagnosticsFromStore $
|
||||
Map.lookup (filePathToUri' fp) ds
|
||||
|
||||
filterDiagnostics ::
|
||||
(NormalizedFilePath -> Bool) ->
|
||||
DiagnosticStore ->
|
||||
DiagnosticStore
|
||||
filterDiagnostics keep =
|
||||
Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)
|
||||
|
||||
@ -11,27 +11,25 @@ module Development.IDE.LSP.Definition
|
||||
import Development.IDE.LSP.Protocol
|
||||
import Development.IDE.Types.Location
|
||||
|
||||
import qualified Development.IDE.Types.Logger as Logger
|
||||
import Development.IDE.Types.Logger
|
||||
import Development.IDE.Core.Rules
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Prettyprint.Doc
|
||||
import Data.Text.Prettyprint.Doc.Render.Text
|
||||
|
||||
-- | Go to the definition of a variable.
|
||||
handle
|
||||
:: Logger.Handle
|
||||
:: Logger
|
||||
-> IdeState
|
||||
-> TextDocumentPositionParams
|
||||
-> IO LocationResponseParams
|
||||
handle loggerH compilerH (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = do
|
||||
handle logger compilerH (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = do
|
||||
|
||||
|
||||
mbResult <- case uriToFilePath' uri of
|
||||
Just (toNormalizedFilePath -> filePath) -> do
|
||||
Logger.logInfo loggerH $
|
||||
logInfo logger $
|
||||
"Definition request at position " <>
|
||||
renderStrict (layoutPretty defaultLayoutOptions $ prettyPosition pos) <>
|
||||
T.pack (showPosition pos) <>
|
||||
" in file: " <> T.pack (fromNormalizedFilePath filePath)
|
||||
runAction compilerH (getDefinition filePath pos)
|
||||
Nothing -> pure Nothing
|
||||
|
||||
@ -12,26 +12,24 @@ import Development.IDE.LSP.Protocol hiding (Hover)
|
||||
import Language.Haskell.LSP.Types (Hover(..))
|
||||
import Development.IDE.Types.Location
|
||||
|
||||
import qualified Development.IDE.Types.Logger as Logger
|
||||
import Development.IDE.Types.Logger
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Prettyprint.Doc
|
||||
import Data.Text.Prettyprint.Doc.Render.Text
|
||||
|
||||
import Development.IDE.Core.Rules
|
||||
|
||||
-- | Display information on hover.
|
||||
handle
|
||||
:: Logger.Handle
|
||||
:: Logger
|
||||
-> IdeState
|
||||
-> TextDocumentPositionParams
|
||||
-> IO (Maybe Hover)
|
||||
handle loggerH compilerH (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = do
|
||||
mbResult <- case uriToFilePath' uri of
|
||||
Just (toNormalizedFilePath -> filePath) -> do
|
||||
Logger.logInfo loggerH $
|
||||
logInfo loggerH $
|
||||
"Hover request at position " <>
|
||||
renderStrict (layoutPretty defaultLayoutOptions $ prettyPosition pos) <>
|
||||
T.pack (showPosition pos) <>
|
||||
" in file: " <> T.pack (fromNormalizedFilePath filePath)
|
||||
runAction compilerH $ getAtPoint filePath pos
|
||||
Nothing -> pure Nothing
|
||||
|
||||
@ -17,7 +17,7 @@ import Development.IDE.LSP.Server
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Development.IDE.LSP.Definition as LS.Definition
|
||||
import qualified Development.IDE.LSP.Hover as LS.Hover
|
||||
import qualified Development.IDE.Types.Logger as Logger
|
||||
import Development.IDE.Types.Logger
|
||||
import Development.IDE.Core.Service
|
||||
import Development.IDE.Types.Location
|
||||
|
||||
@ -44,30 +44,30 @@ textShow = T.pack . show
|
||||
------------------------------------------------------------------------
|
||||
|
||||
handleRequest
|
||||
:: Logger.Handle
|
||||
:: Logger
|
||||
-> IdeState
|
||||
-> (forall resp. resp -> ResponseMessage resp)
|
||||
-> (ErrorCode -> ResponseMessage ())
|
||||
-> ServerRequest
|
||||
-> IO FromServerMessage
|
||||
handleRequest loggerH compilerH makeResponse makeErrorResponse = \case
|
||||
handleRequest logger compilerH makeResponse makeErrorResponse = \case
|
||||
Shutdown -> do
|
||||
Logger.logInfo loggerH "Shutdown request received, terminating."
|
||||
logInfo logger "Shutdown request received, terminating."
|
||||
System.Exit.exitSuccess
|
||||
|
||||
KeepAlive -> pure $ RspCustomServer $ makeResponse Aeson.Null
|
||||
|
||||
Definition params -> RspDefinition . makeResponse <$> LS.Definition.handle loggerH compilerH params
|
||||
Hover params -> RspHover . makeResponse <$> LS.Hover.handle loggerH compilerH params
|
||||
Definition params -> RspDefinition . makeResponse <$> LS.Definition.handle logger compilerH params
|
||||
Hover params -> RspHover . makeResponse <$> LS.Hover.handle logger compilerH params
|
||||
CodeLens _params -> pure $ RspCodeLens $ makeResponse mempty
|
||||
|
||||
req -> do
|
||||
Logger.logWarning loggerH ("Method not found" <> T.pack (show req))
|
||||
logWarning logger ("Method not found" <> T.pack (show req))
|
||||
pure $ RspError $ makeErrorResponse MethodNotFound
|
||||
|
||||
|
||||
handleNotification :: LspFuncs () -> Logger.Handle -> IdeState -> ServerNotification -> IO ()
|
||||
handleNotification lspFuncs loggerH compilerH = \case
|
||||
handleNotification :: LspFuncs () -> Logger -> IdeState -> ServerNotification -> IO ()
|
||||
handleNotification lspFuncs logger compilerH = \case
|
||||
|
||||
DidOpenTextDocument (DidOpenTextDocumentParams item) -> do
|
||||
case URI.parseURI $ T.unpack $ getUri $ _uri (item :: TextDocumentItem) of
|
||||
@ -76,10 +76,10 @@ handleNotification lspFuncs loggerH compilerH = \case
|
||||
-> handleDidOpenFile item
|
||||
|
||||
| otherwise
|
||||
-> Logger.logWarning loggerH $ "Unknown scheme in URI: "
|
||||
-> logWarning logger $ "Unknown scheme in URI: "
|
||||
<> textShow uri
|
||||
|
||||
_ -> Logger.logSeriousError loggerH $ "Invalid URI in DidOpenTextDocument: "
|
||||
_ -> logSeriousError logger $ "Invalid URI in DidOpenTextDocument: "
|
||||
<> textShow (_uri (item :: TextDocumentItem))
|
||||
|
||||
DidChangeTextDocument (DidChangeTextDocumentParams docId _) -> do
|
||||
@ -90,11 +90,11 @@ handleNotification lspFuncs loggerH compilerH = \case
|
||||
mbVirtual <- getVirtualFileFunc lspFuncs $ toNormalizedUri uri
|
||||
let contents = maybe "" (Rope.toText . (_text :: VirtualFile -> Rope.Rope)) mbVirtual
|
||||
onFileModified compilerH filePath (Just contents)
|
||||
Logger.logInfo loggerH
|
||||
logInfo logger
|
||||
$ "Updated text document: " <> textShow (fromNormalizedFilePath filePath)
|
||||
|
||||
Nothing ->
|
||||
Logger.logSeriousError loggerH
|
||||
logSeriousError logger
|
||||
$ "Invalid file path: " <> textShow (_uri (docId :: VersionedTextDocumentIdentifier))
|
||||
|
||||
DidCloseTextDocument (DidCloseTextDocumentParams (TextDocumentIdentifier uri)) ->
|
||||
@ -103,9 +103,9 @@ handleNotification lspFuncs loggerH compilerH = \case
|
||||
| URI.uriScheme uri' == "file:" -> do
|
||||
Just fp <- pure $ toNormalizedFilePath <$> uriToFilePath' uri
|
||||
handleDidCloseFile fp
|
||||
| otherwise -> Logger.logWarning loggerH $ "Unknown scheme in URI: " <> textShow uri
|
||||
| otherwise -> logWarning logger $ "Unknown scheme in URI: " <> textShow uri
|
||||
|
||||
_ -> Logger.logSeriousError loggerH
|
||||
_ -> logSeriousError logger
|
||||
$ "Invalid URI in DidCloseTextDocument: "
|
||||
<> textShow uri
|
||||
|
||||
@ -122,10 +122,10 @@ handleNotification lspFuncs loggerH compilerH = \case
|
||||
Just filePath <- pure $ toNormalizedFilePath <$> uriToFilePath' uri
|
||||
onFileModified compilerH filePath (Just contents)
|
||||
modifyFilesOfInterest compilerH (S.insert filePath)
|
||||
Logger.logInfo loggerH $ "Opened text document: " <> textShow filePath
|
||||
logInfo logger $ "Opened text document: " <> textShow filePath
|
||||
|
||||
handleDidCloseFile filePath = do
|
||||
Logger.logInfo loggerH $ "Closed text document: " <> textShow (fromNormalizedFilePath filePath)
|
||||
logInfo logger $ "Closed text document: " <> textShow (fromNormalizedFilePath filePath)
|
||||
onFileModified compilerH filePath Nothing
|
||||
modifyFilesOfInterest compilerH (S.delete filePath)
|
||||
|
||||
@ -136,7 +136,7 @@ onFileModified
|
||||
-> Maybe T.Text
|
||||
-> IO ()
|
||||
onFileModified service fp mbContents = do
|
||||
logDebug service $ "File modified " <> T.pack (show fp)
|
||||
logDebug (ideLogger service) $ "File modified " <> T.pack (show fp)
|
||||
setBufferModified service fp mbContents
|
||||
|
||||
------------------------------------------------------------------------
|
||||
@ -144,7 +144,7 @@ onFileModified service fp mbContents = do
|
||||
------------------------------------------------------------------------
|
||||
|
||||
runLanguageServer
|
||||
:: Logger.Handle
|
||||
:: Logger
|
||||
-> ((FromServerMessage -> IO ()) -> VFSHandle -> IO IdeState)
|
||||
-> IO ()
|
||||
runLanguageServer loggerH getIdeState = do
|
||||
|
||||
@ -6,7 +6,6 @@ module Development.IDE.LSP.Protocol
|
||||
( module Language.Haskell.LSP.Types
|
||||
, ServerRequest(..)
|
||||
, ServerNotification(..)
|
||||
, prettyPosition
|
||||
, pattern EventFileDiagnostics
|
||||
) where
|
||||
|
||||
@ -15,7 +14,7 @@ import qualified Data.Text as T
|
||||
import Development.IDE.Types.Diagnostics
|
||||
import Development.IDE.Types.Location
|
||||
import Language.Haskell.LSP.Messages
|
||||
import Data.Text.Prettyprint.Doc
|
||||
|
||||
|
||||
import Language.Haskell.LSP.Types hiding
|
||||
( CodeLens
|
||||
@ -54,9 +53,6 @@ data ServerNotification
|
||||
-- Pretty printing
|
||||
----------------------------------------------------------------------------------------------------
|
||||
|
||||
prettyPosition :: Position -> Doc a
|
||||
prettyPosition Position{..} = pretty (_line + 1) <> colon <> pretty (_character + 1)
|
||||
|
||||
-- | Pattern synonym to make it a bit more convenient to match on diagnostics
|
||||
-- in things like damlc test.
|
||||
pattern EventFileDiagnostics :: FilePath -> [Diagnostic] -> FromServerMessage
|
||||
|
||||
@ -19,7 +19,7 @@ import Control.Concurrent.STM
|
||||
import Data.Default
|
||||
|
||||
import Development.IDE.LSP.Protocol
|
||||
import qualified Development.IDE.Types.Logger as Logger
|
||||
import Development.IDE.Types.Logger
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Text as Aeson
|
||||
@ -49,7 +49,7 @@ data Handlers = Handlers
|
||||
}
|
||||
|
||||
runServer
|
||||
:: Logger.Handle
|
||||
:: Logger
|
||||
-> (LSP.LspFuncs () -> IO Handlers)
|
||||
-- ^ Notification handler for language server notifications
|
||||
-> IO ()
|
||||
@ -93,7 +93,7 @@ runServer loggerH getHandlers = do
|
||||
_ <- flip forkFinally (const exitClientMsg) $ forever $ do
|
||||
msg <- atomically $ readTChan clientMsgChan
|
||||
case convClientMsg msg of
|
||||
Nothing -> Logger.logSeriousError loggerH $ "Unknown client msg: " <> T.pack (show msg)
|
||||
Nothing -> logSeriousError loggerH $ "Unknown client msg: " <> T.pack (show msg)
|
||||
Just (Left notif) -> notificationHandler notif
|
||||
Just (Right req) -> sendFunc =<< requestHandler' req
|
||||
pure Nothing
|
||||
|
||||
@ -8,34 +8,22 @@ module Development.IDE.Types.Diagnostics (
|
||||
FileDiagnostic,
|
||||
LSP.DiagnosticSeverity(..),
|
||||
DiagnosticStore,
|
||||
DiagnosticRelatedInformation(..),
|
||||
List(..),
|
||||
StoreItem(..),
|
||||
ideErrorText,
|
||||
ideErrorPretty,
|
||||
errorDiag,
|
||||
showDiagnostics,
|
||||
showDiagnosticsColored,
|
||||
setStageDiagnostics,
|
||||
getAllDiagnostics,
|
||||
filterDiagnostics,
|
||||
getFileDiagnostics,
|
||||
prettyDiagnostics
|
||||
) where
|
||||
|
||||
import Data.Maybe as Maybe
|
||||
import Data.Foldable
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Prettyprint.Doc
|
||||
import qualified Data.SortedList as SL
|
||||
import qualified Text.PrettyPrint.Annotated.HughesPJClass as Pretty
|
||||
import qualified Language.Haskell.LSP.Types as LSP
|
||||
import Language.Haskell.LSP.Types as LSP (
|
||||
DiagnosticSeverity(..)
|
||||
, Diagnostic(..)
|
||||
, List(..)
|
||||
, DiagnosticRelatedInformation(..)
|
||||
)
|
||||
import Language.Haskell.LSP.Diagnostics
|
||||
import Data.Text.Prettyprint.Doc.Render.Text
|
||||
@ -46,31 +34,18 @@ import Development.IDE.Types.Location
|
||||
|
||||
|
||||
ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic
|
||||
ideErrorText fp = errorDiag fp "Ide Error"
|
||||
ideErrorText fp msg = (fp, LSP.Diagnostic {
|
||||
_range = noRange,
|
||||
_severity = Just LSP.DsError,
|
||||
_code = Nothing,
|
||||
_source = Just "compiler",
|
||||
_message = msg,
|
||||
_relatedInformation = Nothing
|
||||
})
|
||||
|
||||
ideErrorPretty :: Pretty.Pretty e => NormalizedFilePath -> e -> FileDiagnostic
|
||||
ideErrorPretty fp = ideErrorText fp . T.pack . Pretty.prettyShow
|
||||
|
||||
errorDiag :: NormalizedFilePath -> T.Text -> T.Text -> FileDiagnostic
|
||||
errorDiag fp src msg =
|
||||
(fp, diagnostic noRange LSP.DsError src msg)
|
||||
|
||||
-- | This is for compatibility with our old diagnostic type
|
||||
diagnostic :: Range
|
||||
-> LSP.DiagnosticSeverity
|
||||
-> T.Text -- ^ source
|
||||
-> T.Text -- ^ message
|
||||
-> LSP.Diagnostic
|
||||
diagnostic rng sev src msg
|
||||
= LSP.Diagnostic {
|
||||
_range = rng,
|
||||
_severity = Just sev,
|
||||
_code = Nothing,
|
||||
_source = Just src,
|
||||
_message = msg,
|
||||
_relatedInformation = Nothing
|
||||
}
|
||||
|
||||
|
||||
-- | Human readable diagnostics for a specific file.
|
||||
--
|
||||
@ -116,49 +91,6 @@ prettyDiagnostic (fp, LSP.Diagnostic{..}) =
|
||||
where
|
||||
sev = fromMaybe LSP.DsError _severity
|
||||
|
||||
getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
|
||||
getDiagnosticsFromStore (StoreItem _ diags) =
|
||||
toList =<< Map.elems diags
|
||||
|
||||
|
||||
-- | Sets the diagnostics for a file and compilation step
|
||||
-- if you want to clear the diagnostics call this with an empty list
|
||||
setStageDiagnostics ::
|
||||
NormalizedFilePath ->
|
||||
Maybe Int ->
|
||||
-- ^ the time that the file these diagnostics originate from was last edited
|
||||
T.Text ->
|
||||
[LSP.Diagnostic] ->
|
||||
DiagnosticStore ->
|
||||
DiagnosticStore
|
||||
setStageDiagnostics fp timeM stage diags ds =
|
||||
updateDiagnostics ds uri timeM diagsBySource
|
||||
where
|
||||
diagsBySource = Map.singleton (Just stage) (SL.toSortedList diags)
|
||||
uri = filePathToUri' fp
|
||||
|
||||
getAllDiagnostics ::
|
||||
DiagnosticStore ->
|
||||
[FileDiagnostic]
|
||||
getAllDiagnostics =
|
||||
concatMap (\(k,v) -> map (fromUri k,) $ getDiagnosticsFromStore v) . Map.toList
|
||||
|
||||
getFileDiagnostics ::
|
||||
NormalizedFilePath ->
|
||||
DiagnosticStore ->
|
||||
[LSP.Diagnostic]
|
||||
getFileDiagnostics fp ds =
|
||||
maybe [] getDiagnosticsFromStore $
|
||||
Map.lookup (filePathToUri' fp) ds
|
||||
|
||||
filterDiagnostics ::
|
||||
(NormalizedFilePath -> Bool) ->
|
||||
DiagnosticStore ->
|
||||
DiagnosticStore
|
||||
filterDiagnostics keep =
|
||||
Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)
|
||||
|
||||
|
||||
|
||||
-- | Label a document.
|
||||
slabel_ :: String -> Doc a -> Doc a
|
||||
|
||||
@ -9,6 +9,7 @@ module Development.IDE.Types.Location
|
||||
, noFilePath
|
||||
, noRange
|
||||
, Position(..)
|
||||
, showPosition
|
||||
, Range(..)
|
||||
, Uri(..)
|
||||
, NormalizedUri
|
||||
@ -24,8 +25,6 @@ module Development.IDE.Types.Location
|
||||
) where
|
||||
|
||||
import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..))
|
||||
|
||||
|
||||
import Control.DeepSeq
|
||||
import Data.Maybe as Maybe
|
||||
import Data.Hashable
|
||||
@ -84,3 +83,7 @@ noFilePath = "<unknown>"
|
||||
-- A dummy range to use when range is unknown
|
||||
noRange :: Range
|
||||
noRange = Range (Position 0 0) (Position 100000 0)
|
||||
|
||||
|
||||
showPosition :: Position -> String
|
||||
showPosition Position{..} = show (_line + 1) ++ ":" ++ show (_character + 1)
|
||||
|
||||
@ -6,23 +6,23 @@
|
||||
-- concrete choice of logging framework so users can plug in whatever
|
||||
-- framework they want to.
|
||||
module Development.IDE.Types.Logger
|
||||
( Handle(..)
|
||||
, makeOneHandle
|
||||
, makeNopHandle
|
||||
( Logger(..)
|
||||
, makeOneLogger
|
||||
, makeNopLogger
|
||||
) where
|
||||
|
||||
import qualified Data.Text as T
|
||||
import GHC.Stack
|
||||
|
||||
data Handle = Handle {
|
||||
data Logger = Logger {
|
||||
logSeriousError :: HasCallStack => T.Text -> IO ()
|
||||
, logInfo :: HasCallStack => T.Text -> IO ()
|
||||
, logDebug :: HasCallStack => T.Text -> IO ()
|
||||
, logWarning :: HasCallStack => T.Text -> IO ()
|
||||
}
|
||||
|
||||
makeNopHandle :: Handle
|
||||
makeNopHandle = makeOneHandle $ const $ pure ()
|
||||
makeNopLogger :: Logger
|
||||
makeNopLogger = makeOneLogger $ const $ pure ()
|
||||
|
||||
makeOneHandle :: (HasCallStack => T.Text -> IO ()) -> Handle
|
||||
makeOneHandle x = Handle x x x x
|
||||
makeOneLogger :: (HasCallStack => T.Text -> IO ()) -> Logger
|
||||
makeOneLogger x = Logger x x x x
|
||||
|
||||
@ -14,7 +14,6 @@ import Development.IDE.Core.Shake
|
||||
import Development.IDE.Core.RuleTypes
|
||||
import Development.IDE.LSP.Protocol
|
||||
import Development.IDE.Types.Location
|
||||
import Data.String
|
||||
import Development.IDE.Types.Diagnostics
|
||||
import Development.IDE.Types.Options
|
||||
import Development.IDE.Types.Logger
|
||||
@ -47,7 +46,7 @@ main = do
|
||||
args <- getArgs
|
||||
-- lock to avoid overlapping output on stdout
|
||||
lock <- newLock
|
||||
let logger = makeOneHandle $ withLock lock . T.putStrLn
|
||||
let logger = makeOneLogger $ withLock lock . T.putStrLn
|
||||
|
||||
dir <- getCurrentDirectory
|
||||
hPutStrLn stderr dir
|
||||
@ -75,7 +74,7 @@ main = do
|
||||
|
||||
kick :: Action ()
|
||||
kick = do
|
||||
files <- use_ GetFilesOfInterest $ fromString ""
|
||||
files <- getFilesOfInterest
|
||||
void $ uses TypeCheck $ Set.toList files
|
||||
|
||||
-- | Print an LSP event.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user